*DECK PTFS
          IDENT  PFSRES 
          TITLE  PTFS - PERMANENT FILE TRANSFER SERVICER. 
          SST    CM,CP
          SYSCOM B1 
          LIST   F
          ENTRY  PFSRES 
  
 DEBUG    MICRO  1,5,*"PCOMMENT"* 
  
  
          COMMENT  PERMANENT FILE TRANSFER SERVICER.
          COMMENT COPYRIGHT CONTROL DATA SYSTEMS INC. 1994. 
          SPACE  4,10 
***       PTFS - PERMANENT FILE TRANSFER SERVICER.
* 
*         J. G. CLARK        79/10/29.
          SPACE  4,10 
***              PTFS IS THE PERMANENT FILE TRANSFER FACILITY SERVICER. 
*        PTFS IS STARTED BY *RHF* IN RESPONSE TO A CONNECTION 
*         REQUEST FROM THE *PTF* APPLICATION.  PTFS PROVIDES THE *PFM*
*         FUNCTION PROCESSORS FOR THE INITIATOR (*MFLINK*). 
          SPACE  4,10 
***       DIRECTIVES PROCESSED. 
* 
*         USER(USERNUM,PASSWRD,FAMILY)
*         ACCOUNT(USERNUM,PASSWRD,FAMILY) 
*         CHARGE(CHARGENUM,PROJECTNUM)
* 
*         APPEND(PFN/UN= ,PW= ,PN= ,R= ,NA,WB)
*         ATTACH(PFN/M= ,UN= ,PW= ,PN= ,R= ,NA,RT,WB) 
*         CHANGE(NFN=OFN/PW= ,CT= ,M= ,BR= ,PR= ,PN= ,R= ,XD= ,XT= ,
*                NA,CE,WB,CP,AC= )
*         DEFINE(PFN/PW= ,CT= ,M= ,BR= ,PR= ,PN= ,R= ,S= ,AL= ,XD= ,
*                XT= ,NA,WB,AC= ) 
*         GET(PFN/UN= ,PW= ,PN= ,R= ,NA,WB,RT)
*         DROPDS(PFN/PN= ,R= ,NA,WB)
*         PACKNAM(PACKNAM)
*         PACKNAM(PN= ) 
*         PERMIT(PFN,USERNUM= ,/PN= ,R= ,XD= ,XT= ,NA,WB) 
*         PURGE(PFN/UN= ,PW= ,PN= ,R= ,NA,WB) 
*         REPLACE(PFN/UN= ,PW= ,PN= ,R= ,NA,WB) 
*         SAVE(PFN/PW= ,CT= ,M= ,BR= ,PR= ,PN= ,R= ,AL= ,XD= ,XT= ,NA,
*                AC= )
* 
*         FOR A DESCRIPTION OF THE PARAMETERS REFER TO THE *NOS*
*         REFERENCE MANUAL. 
  
  
**        MICROS
  
 PROGNAM  MICRO  1,10,*  PTFS  - *
          SPACE  4,15 
*CALL COMCMAC 
*CALL COMCAPR 
*CALL COMCCAE 
*CALL CMACROS 
  
 NOSONLY  IFEQ   OS$NOSBE 
 PFSRES   SUBR
          EQ     PFSRES 
          LIST   *
 NOSONLY  ELSE
  
          LIST   X
*CALL COMCPTF 
          LIST   *
          SPACE  4,10 
**        COMMON DECKS. 
  
  
          XTEXT  COMSPFM
*CALL     COMPTFS 
*CALL COMPRPV 
 PTFS     TITLE  MAIN PROGRAM.
**        PTFS - MFLINK SERVICER MAIN PROGRAM.
* 
*         PTFS CONTROLS THE TRANSFER OF APPLICATION PROTOCOL
*         MESSAGE BLOCKS AND PERMANENT FILES TO/FROM *MFLINK*.
*         WHEN A USER TEXT CONTROL CARD IS RECEIVED, THE
*         CORRESPONDING CONTROL CARD PRE-PROCESSOR IS 
*         EXECUTED.  IF A FILE TRANSFER IS REQUIRED, *NETXFR* 
*         WILL BE CALLED TO DO THE ACTUAL DATA TRANSFER.
*         IF A CONTROL CARD POST-PROCESSOR IS DEFINED IT
*         WILL BE CALLED TO COMPLETE THE OPERATION. 
  
  
 PFSRES   SUBR
          SB1    1
          SA2    A1+B1       POINTER TO NETSAVL 
          SA1    X2          NETWORK INTERFACES LOADED
          BX6    X1 
          SA6    NIFTYPE     SAVE NETWORK INTERFACE TYPE
          SB1    1
          SA4    OVLLWA      GET HIGHEST HIGH ADDRESS 
  
*         REQUEST MEMORY UP TO THE LWA OF OVERLAY.
  
          MEMORY CM,,R,X4    REQUEST MEMORY 
 PTF1     SB1    1
          RJ     =XDUMMAIN   EXECUTE PFSMAIN
          SA1    F           NETXFR FILE NAME 
          BX6    X1 
          SA6    XFRLFN      SAVE FOR *PTFXFR*
          RJ     =XDUMXFR    EXECUTE PTFXFR 
          EQ     PTF1        LOOP 
  
  
 NOSONLY  ENDIF 
  
          END 
          IDENT  PFSMAIN
          SST    CM,CP
          SYSCOM B1 
          LIST   F
          ENTRY  PFSMAIN
*CALL COMCMAC 
*CALL     COMCAPR 
*CALL     COMCCAE 
*CALL CMACROS 
  
 NOSONLY  IFEQ   OS$NOSBE 
 PFSMAIN  SUBR
          EQ     PFSMAIN
          LIST   *
 NOSONLY  ELSE
  
*CALL     COMCPTF 
*CALL     COMQUPC 
          XTEXT  COMSMLS
          XTEXT  COMSPFM
          XTEXT  COMSPRD
          XTEXT  COMSPRO
          XTEXT  COMSSFM
          XTEXT  COMSSRU
          XTEXT  COMSSSJ
  
          EXT    DXB= 
 DXB      EQU    DXB=        USE *DXB* FROM SYSLIB
          EXT    SSJ=        USE *SSJ=* BLOCK IN *SSJ*
  
  
*CALL     COMPTFS 
*CALL COMPRPV 
          SPACE  4,10 
****      DAYFILE MESSAGES. 
  
  
*         MESSAGES ISSUED WITH AN UNCONDITIONAL ABORT.
  
 CNFM     ERRMSG (  PTFS  - CONTINUATION BLOCK DID NOT FOLLOW.) 
 ICCM     ERRMSG (  PTFS  - INVALID CONTROL CARD.)
 RNOM     ERRMSG (  PTFS  - NETON REJECTED BY SUBSYSTEM.) 
 UNIF     ERRMSG (  PTFS  - UNKNOWN NETWORK INTERFACE TYPE.)
  
*         DAYFILE MESSAGES ISSUED TO REMOTE INITIATOR.
  
 ACTO     ERRMSG (  PTFS  - APPLICATION CONNECTION TIMEOUT.)
 CCRD     ERRMSG (  PTFS  - CHARGE REQUIRED.) 
 CPED     ERRMSG (  PTFS - PARAMETERS CE AND CP ARE MUTUALLY EXCLUSIVE.)
 CRDD     ERRMSG (  PTFS  - CHARGE RESTRICTED TO DEFAULT.)
 DDER     ERRMSG (  PTFS  - INVALID DATA DECLARATION TYPE.) 
 EARD     ERRMSG (  PTFS  - ERROR IN ARGUMENTS.)
 EOFD     ERRMSG (  PTFS  - EXECUTE ONLY FILE.) 
 ERAD     ERRMSG (  PTFS  - ERROR MESSAGE RETURNED BY PFM.) 
 EXPD     ERRMSG (  PTFS  - ERROR IN EXPIRATION DATE.)
 FAPD     ERRMSG (  PTFS  - FILE ALREADY PERMANENT.)
 FNID     ERRMSG (  PTFS  - FILE IS DIRECT ACCESS.) 
 HNSD     ERRMSG (  PTFS  - HOST NOT SPECIFIED TYPE.) 
 IAVD     ERRMSG (  PTFS  - INVALID ACCESS VALIDATION.) 
 IACD     ERRMSG (  PTFS  - INVALID ALTERNATE CATLIST PERMISSION.)
 IBRD     ERRMSG (  PTFS  - INVALID BACKUP/RESIDENCE REQUIREMENT.)
 ICCD     ERRMSG (  PTFS  - INVALID DIRECTIVE.) 
 IDSD     ERRMSG (  PTFS  - INVALID DEVICE SPECIFICATION.)
 IMCD     ERRMSG (  PTFS  - INVALID MODE/CATEGORY.) 
 LUAD     ERRMSG (  PTFS  - LID UNAVAILABLE.) 
 MCPD     ERRMSG (  PTFS  - MISSING CHARGE/PROJECT.)
 MUND     ERRMSG (  PTFS  - MISSING USER NAME.) 
 PNRD     ERRMSG (  PTFS  - PF NAME REQUIRED.)
 PRCD     ERRMSG (  PTFS  - PF REQUEST COMPLETE.) 
 SUCD     ERRMSG (  PTFS  - SECONDARY USER DIRECTIVES DISABLED.)
 UALD     ERRMSG (  PTFS  - UNKNOWN ACCESS LEVEL NAME.) 
 UCRD     ERRMSG (  PTFS  - USER DIRECTIVE REQUIRED FIRST.) 
 MFXD     ERRMSG (  PTFS  - MULTIPLE FILE TRANSFERS REQUESTED.) 
 RCSD     ERRMSG (  PTFS  - RECOVERY DIRECTIVE AFTER FILE TRANSFER.)
 TSLD     ERRMSG (  PTFS  - DIRECTIVE TOO LONG.)
 ICTD     ERRMSG (  PTFS  - INCOMPLETE CONTINUED DIRECTIVE.)
 FTSD     ERRMSG (  PTFS  - FL TOO SHORT FOR PROGRAM.)
  
  
****
          SPACE  4,10 
****      ACCOUNT FILE MESSAGES.
  
  
 ACUA     DATA   10HACUN, @@@@
 ABUA     ERRMSG (ABUN, @@@@@@@, \\\\\\\.)
  
*         @@@@@@@ IS THE USERNUMBER BEGINNING.
*         \\\\\\\ IS THE FAMILY OF THE USERNUMBER BEGINNING.
  
 ABIC     ERRMSG (ABIC, ??????????, !!!!!!!!!!%%%%%%%%%%.)
  
*         ?????????? IS THE INITIAL CHARGE NUMBER.
*         !!!!!!!!!! IS THE FIRST PART OF THE INITIAL PROJECT NUMBER. 
*         %%%%%%%%%% IS THE SECOND PART OF THE INITIAL PROJECT NUMBER.
  
  
****
  
  
 DDC6     DATA   2LC6        C6 DD TYPE 
 DDC8     DATA   2LC8        C8 DD TYPE 
 DDUH     DATA   2LUH        UH DD TYPE 
 DDUS     DATA   2LUS        US DD TYPE 
  
 HMAP     CON    HA          SEND AND RECEIVE BUFFER ADDRESS LIST 
          CON    SMB+1       *NETPUT* MESSAGE BUFFER
 HMBP     CON    QBIT        RECEIVE BUFFER ADDRESS LIST
          CON    STAT        APPLICATION CONNECTION STATUS
          CON    ACKT        *RHFWAIT* INTERVAL FOR *FC/ACK*/MESSAGE
          CON    =0          *RHFWAIT* WAIT FOR EVENT FLAG
          CON    HA          MESSAGE HEADER ADDRESS 
          CON    MB+1        RECEIVE MESSAGE BUFFER ADDRESS 
          CON    MBL         MESSAGE BUFFER LENGTH
          CON    =0 
  
 MB       BSSZ   NTLMAX+2    *NETGET* MESSAGE BUFFER
  
 MBL      CON    NTLMAX      MESSAGE BUFFER LENGTH
  
 SHMP     CON    QBIT        SUPERVISORY PARAMETER ADDRESS LIST 
          CON    STAT        APPLICATION CONNECTION STATUS
          CON    REQT        *RHFWAIT* INTERVAL FOR *FC/ACK*/MESSAGE
          CON    =0          *RHFWAIT* WAIT FOR EVENT FLAG
          CON    SHAB        SUPERVISORY MESSAGE HEADER ADDRESS 
          CON    STAB        SUPERVISORY MESSAGE BUFFER ADDRESS 
          CON    STABL       MESSAGE BUFFER LENGTH
  
 SMB      BSSZ   NTLMAX+2    *NETPUT* MESSAGE BUFFER
          SPACE  4,10 
**        PRESET DATA AREAS.
  
  
          USE    // 
  
  
*         THE FOLLOWING DATA AREAS WILL BE CLEARED AFTER RECEIVING
*         EVERY *RFT* COMMAND.
  
 DARA     BSS    0           START OF AREA TO BE CLEARED
  
 ACCESS   BSS    1           MODE OF ACCESS PARAMETER TEXT
  
 FXCT     BSS    1           FILE TRANSFER COUNT PER *RFT*
  
 SIZT     BSS    1           FILE SIZE IN CHARACTERS / 1024 
  
 TSTA     BSS    1           TRANSFER STATE 
  
 TXTCONT  BSS    1           TEXT CONTINUATION FLAG 
  
 TEXTLTH  BSS    1           CUMULATIVE TEXT LENGTH, CHARACTERS 
  
 DARAA    EQU    *           START OF AREA TO BE CLEARED EACH CTRL CARD 
  
*         THE FOLLOWING DATA AREAS ARE CLEARED BEFORE EACH CONTROL
*         CARD IS PROCESSED.
  
          LIST   G
  
 OFN      BSS    1           OLD FILE NAME FOR *CHANGE* 
  
 FB       BSS    NWCE+1      CATALOG BUFFER FOR *CATLIST* 
 FBL      EQU    *-FB        BUFFER LENGTH
 ENDC     EQU    *           END OF AREA TO CLEAR 
  
  
 VPFP     BSS    2           PARAMETER BLOCK FOR *SETPFP* 
 VUBP     BSS    11D         PARAMETER BLOCK FOR VALIDATION 
 FAMILY   EQU    VUBP+2      FAMILY FOR USER VALIDATION 
 PASSWRD  EQU    VUBP+1      PASSWORD FOR USER VALIDATION 
 USERNUM  EQU    VUBP        USER NUMBER
  
 ENDA     EQU    *           END OF AREA TO BE CLEARED
  
 ATTR     BSS    1           PARAMETER RETURN ATTRIBUTE 
 FACQUAL  BSS    1           FACILITIES QUALIFIER 
 FACTEXT  BSS    1           FACILITIES TEXT
 FACTXTL  BSS    1           FACILITIES TEXT LENGTH 
  
 OMSGL    BSS    1           OPERATOR MESSAGE LENGTH IN CHARACTERS
  
 QUAL     BSS    1           PARAMETER RETURN QUALIFIER 
  
 TXTL     BSS    1           TEXT RETURNED LENGTH 
  
 ENDB     EQU    *           END OF PRESET BUFFER 
  
  
          LIST   -G 
  
  
          USE    *
          TITLE PTFS - FILE TRANSFER SERVICER (MAIN OVERLAY). 
 TFS      SPACE  4,20 
**        TFS - PTFS MAIN PROGRAM.
* 
*         TFS IS THE MAIN LOOP PROCESSOR OF PTFS.  IT IS STRUCTURED 
*         AS A SUBROUTINE SINCE THE (1,0) OVERLAY IN WHICH IT RESIDES 
*         IS CALLED FROM THE (0,0) OVERLAY.  THE (2,0) OVERLAY CONTAINS 
*         ONLY THE CALL TO NETXFR.  ALL OTHER PROCESSING IS DONE BY 
*         CALLS FROM TFS IN THE (1,0).  THIS OVERLAY STRUCTURE WAS
*         CHOSEN TO MINIMIZE CM REQUIREMENTS DURING FILE TRANSFERS. 
*         WHEN PTFS IS FIRST ENTERED, THE (0,0) RESIDENT ROUTINE
*         IMMEDIATELY LOADS THE (1,0) AND CALLS TFS.  CONTROL REMAINS 
*         WITH TFS UNTIL EITHER PTFS TERMINATES OR A FILE TRANSFER
*         IS REQUIRED IN WHICH CASE TFS RETURNS TO THE (0,0) WHICH
*         WILL LOAD (2,0), PERFORM NETXFR, RELOAD (1,0), AND CALL 
*         TFS.  BEFORE TFS EXITS FOR A NETXFR, CURRENT STATE IS 
*         SAVED IN GLOBAL VARIABLE *XFR* SO THAT TFS WILL KNOW WHERE
*         TO RESUME PROCESSING WHEN RECALLED. 
  
  
 TFS      SUBR               ENTRY/EXIT 
  
 PFSMAIN  EQU    TFS         EXTERNAL ENTRY POINT 
  
          SA1    XFR
          NZ     X1,TFS5     IF RETURN FROM *NETXFR* OVERLAY
          RJ     PRS         PRESET FOR FILE TRANSFERS
          NZ     X6,TFS7     IF NETON REJECTED
          NZ     X1,TFS6     IF ERROR DETECTED
          SA1    CNCDEL      CONNECTION DELAY TIME
          BX6    X1 
          SA6    TOUT 
          RJ     =XSTT       SET TIMEOUT
          SA1    SHMP 
          RJ     =XECL       ESTABLISH COMMUNICATION LINK 
          SX6    NCRM        *NO CONNECTION RECEIVED* 
          BX6    X1-X6
          ZR     X6,TFS7     IF CONNECTION REQUEST TIMEOUT
          NZ     X1,TFS6     IF OTHER ERROR 
          SX6    TIMEOUT     DEFAULT TIMEOUT
          SA6    TOUT 
          RJ     =XSTT       RESET TIMEOUT
          SX6    1
          RJ     RCC         CALL RECOVR TO ACTIVATE PFSRPV 
          MX6    0
          SA6    F           CLEAR FILE TRANSFER FET
          SA1    HMBP 
          RJ     =XRML       RECEIVE COMMAND FROM *MFLINK*
 TFS1     NZ     X1,TFS6     IF ERROR IN TRANSFER OR COMMAND
          SA1    STAT 
          MX6    60 
          BX6    X1-X6
          ZR     X6,TFS8     IF CONNECTION BROKEN 
          SX1    DDC6 
          RJ     =XDDC       GET CODE FOR C6
          SA6    DDXFR       SET DEFAULT DD TO C6 
          SX6    ACKNW
          SA6    ACKWXFR     SET DEFAULT FOR ACKNOWLEGEMENT WINDOW
          MX6    0
          SA6    TXTL 
          RJ     PFA         SET REQUIRED FACILITIES
          SA1    =1LS 
          BX6    X1 
          SA6    FACQUAL     RESET QUALIFIER TO *SELECT*
          SA1    F
          ZR     X1,TFS2     IF EMPTY FET 
          RETURN F,R         RETURN ANY PERMANENT FILE ATTACHED 
 TFS2     SX6    B0+         CLEAR PREVIOUS USER TEXT 
          SA6    ARGR 
          SA6    MBS         CLEAR MAXIMUM BLOCK SIZE 
          SB2    ENDA-DARA   SET NUMBER OF PARAMETERS 
          SX6    B0+
 TFS3     SA6    DARA-1+B2   CLEAR PARAMETER AREA 
          SB2    B2-1 
          NZ     B2,TFS3     IF MORE WORDS TO CLEAR 
          SA6    FUNC        CLEAR *PFM* FUNCTION 
          PACKNAM  PACK      CLEAR DEFAULT PACKNAME 
          RJ     CAF         CALL ACFETCH (GET COMMAND) 
          SA2    ICPT        SET IDLE STATE COMMAND TABLE 
          RJ     =XEPT       EXECUTE PROCESSOR FROM TABLE 
  
*         THE ONLY ALLOWABLE *MFLINK* COMMANDS IN THE IDLE STATE ARE
*         *EPT* AND *RFT*.  IF AN *EPT* COMMAND IS RECEIVED,
*         PROCESSING COMPLETES IN A TERMINATION STATE AND LOGIC FLOW
*         DOES NOT RETURN HERE.  IF AN *RFT* COMMAND IS RECEIVED, 
*         ROUTINE *EPT* WILL CALL ROUTINE *CFT*, WHICH WILL EVENTUALLY
*         RETURN HERE.
  
*         RJ     CFT
  
*         THE ONLY ALLOWABLE *MFLINK* COMMANDS IN THE FILE TRANSFER STAT
*         ARE *GO* AND *STOP*.  IF A *GO* COMMAND IS RECEIVED, ROUTINE
*         *CGO* WILL SET FLAG *XFR* NON-ZERO TO INDICATE THE (2,0)
*         OVERLAY NEEDS TO BE LOADED AND EXECUTED (*NETXFR*).  UPON 
*         RETURNING FROM THE (2,0) OVERLAY, THE (1,0) OVERLAY WILL BE 
*         LOADED, THE *XFR* FLAG WILL BE CLEARED, AND *GO* PROCESSING 
*         WILL BE COMPLETED.
  
          NZ     X1,TFS6     IF ERROR IN REPLY PROCESSOR
          SA3    XFR         *NETXFR* FLAG
          ZR     X3,TFS1     IF NO TRANSFER (STOPR SENT), GET RFT/ETP 
          MX6    0
          RJ     RCC         CALL RECOVR TO DEACTIVATE PFSRPV 
          EQ     TFSX        LOAD AND EXECUTE *NETXFR* OVERLAY
  
 TFS5     BX6    X6-X6       CLEAR FILE TRANSFER FLAG 
          SA6    XFR
          SX6    1
          RJ     RCC         CALL RECOVR TO ACTIVATE PFSRPV 
  
*         ENABLE SUBSEQUENT CONSECUTIVE *MFLINK* CALLS BY FILLING 
*         IN THE ZERO WORDS IN THE *VCCT* TABLE WITH VALID CONTROL
*         STATEMENTS (NOTE THAT THESE TWO FIELDS WERE CLEARED WHEN
*         THIS OVERLAY WAS RELOADED AFTER THE CALL TO *NETXFR*).
  
          SA1    VCCC        ENABLE *APPEND* STATEMENTS 
          SA2    A1+B1       ENABLE *CHARGE* STATEMENTS 
          BX6    X1 
          SA6    VCCB 
          BX7    X2 
          SA7    A6-B1
          ERRNZ  VCCB-VCCA-1 CODE DEPENDS ON VALUE
          RJ     COG         COMPLETE *GO* PROCESSING 
          RJ     =XEPT       EXECUTE RESPONSE PROCESSOR 
          EQ     TFS1        LOOP 
  
 TFS6     RJ     =XABT       ISSUE DAYFILE MESSAGE AND ABORT
  
 TFS7     MESSAGE X1,0,RCL   ISSUE DAYFILE MESSAGE
          GETJCI JCI         GET JOB CONTROL REGISTERS
          SA1    JCI+1
          MX6    -1 
          BX6    -X6+X1 
          SA6    A1          SET R1 NON-ZERO (FOR JOB TO TEST)
          SETJCI JCI
  
 TFS8     MX6    0
          RJ     RCC         CALL RECOVR TO DEACTIVATE PFSRPV 
          SA1    NETONF      CHECK NETTED-ON FLAG 
          ZR     X1,TFS9     IF NOT NETTED-ON 
          RJ     =XFTUOFF 
          SB1    1
  
 TFS9     ENDRUN             TERMINATE
          TITLE UTILITY SUBROUTINES 
ABT       SPACE  4,10 
**        ABT - ABORT 
* 
*         ABT ISSUES AN ERROR MESSAGE AND ABORTS. 
* 
*         ENTRY  (X1) = ERROR MESSAGE ADDRESS.
* 
*         EXIT CPU ABORT
* 
*         CALLS  MSG=, SYS=.
  
  
 ABT      SUBR               ENTRY
          ZR     X1,ABT1     IF NO ERROR MESSAGE
          MESSAGE  X1,0,R 
  
 ABT1     SA1    STAT        CONNECTION STATUS
          PL     X1,ABT2     IF NO CONNECTION 
          NZ     X1,ABT2     IF NOT BROKEN
          SA1    ABTFLG      FORCE ABORT FLAG 
          ZR     X1,ABT3     IF FORCED ABORT NOT SELECTED 
  
 ABT2     ABORT 
  
 ABT3     SA1    NETONF      CHECK NETTED-ON FLAG 
          ZR     X1,ABT4     IF NOT NETTED-ON 
          RJ     =XFTUOFF 
          SB1    1
  
 ABT4     ENDRUN
 CAF      SPACE  4,10 
**        CAF - CALL ACFETCH. 
* 
*         THIS ROUTINE CALLS ACFETCH AND PUTS THE COMMAND NUMBER
*         INTO THE ERROR MESSAGE *INVALID COMMAND  XX*. 
* 
*         ENTRY  HA   = NETGET HEADER WORD
*                MB   = NETGET TEXT HEADER WORD 
* 
*         EXIT   LCMD = (X6) = COMMAND NUMBER.
*                ICSM = * INVALID COMMAND  XX* (XX = COMMAND NUMBER). 
*                X1   = ICSM (ERROR MESSAGE ADDR).
* 
*         USES   A - 3, 6, 7. 
*                X - 1, 3, 5, 6, 7. 
* 
*         MACROS ACFETCH. 
  
  
 CAF      SUBR
          SA3    HA          GET TEXT LENGTH
          MX7    -12
          BX7    -X7*X3 
          SA7    MB          SET TEXT LENGTH FOR ACFETCH
          ACFETCH MB,MB,LCMD  GET COMMAND 
          SX1    ICSM        INITIALIZE ERROR MESSAGE 
          SA3    X1+2 
          MX7    -12
          LX5    12 
          BX7    X7*X3       MASK 
          BX7    X5+X7       INSERT COMMAND 
          SA7    A3          RESET ERROR MESSAGE
          EQ     CAFX        RETURN 
 CAT      SPACE  4,10 
**        CAT - CATLIST 
* 
*         CAT CALLS CATLIST TO RETURN INFORMATION ABOUT A PERMANENT FILE
* 
*         ENTRY  F = FET ADDR.
* 
*         EXIT   F+2 (FET IN POINTER) = FB (FIRST). 
*                X2 = F (FETADDR).
*                X1 = 0, IF NO ERROR. 
*                   .LE. 0, IF ERROR. 
*                X0 = ERROR CODE. 
* 
*         USES   A - 7. 
*                X - 7. 
* 
*         CALLS  CFE. 
* 
*         MACROS CATLIST. 
  
  
 CAT      SUBR
 CAT1     CATLIST F          GET PERM FILE INFORMATION
          RJ     CFE         CHECK FOR ERROR
          SX7    FB 
          SA7    F+2         RESET FET IN = FIRST 
          ZR     X1,CATX     IF NO ERROR
          NG     X1,CATX     IF ERROR 
          EQ     CAT1        RETRY
 CDD      SPACE  4,15 
**        CDD - CHECK DATA DECLARATION
* 
*         CDD CHECKS TH DD PARAMETER AND BASED ON THE MAINFRAME 
*         TYPE THE DD PARAMETER MA BE CHANGED.
* 
*         IF THE MAINFRAME TYPE IS -
* 
*                NOSBE AND DD .NE. US, DD IS CHANGED TO US. 
*                NS2, DD IS CHANGED TO UH.
*                NOS AND DD .EQ. C8, DD IS NOT CHANGED. 
*                NOS AND DD .NE. C8, DD IS CHANGED TO UH. 
* 
*         ALSO CHECK FOR DD = UH, IF SO FORCE A RNEG. 
* 
*         ENTRY - DDXFR IS SET UP 
*                 HOSTYP IS SET UP
* 
*         EXIT - CORRECT PARAMETER IS SET UP IN THE RPOS. 
*                IF ERROR RNEG IS FORCED. 
* 
*         USES  X - 1,2,3,6.
*               A - 1,2,6.
*               B - 1,2,3.
  
  
 CDD      SUBR               ENTRY/EXIT 
          SA1    UHPL 
          RJ     =XDDC       GET CODE FOR UH
          SA1    DDXFR
          BX1    X1-X6
          ZR     X1,CDD8     IF MFLINK SPECIFIED UH 
          SA2    HOSTYP 
          SA3    /CONSTANT/NS2
          BX3    X2-X3
          ZR     X3,CDD6     IF REMOTE HOST IS NS2
          SA3    /CONSTANT/NOSBE
          BX3    X2-X3
          ZR     X3,CDD4     IF REMOTE HOST IS NOSBE
          SA3    /CONSTANT/NOS
          BX3    X2-X3
          NZ     X3,CDDX     IF REMOTE HOST IS NOT NS2, NOS, NOSBE
          SA1    C8PL 
          RJ     =XDDC       GET CODE FOR C8
          SA1    DDXFR
          BX5    X1-X6
          ZR     X5,CDDX     IF DD .EQ. C8 AND REMOTE HOST IS NOS 
          EQ     CDD6        MODIFY DD TO UH
  
*         REMOTE HOST IS NOSBE, IF DD .EQ. US THEN RETURN 
*         ELSE MODIFY DD TO US. 
  
 CDD4     SA1    USPL 
          RJ     =XDDC       CONVERT US 
          SA1    DDXFR
          BX1    X1-X6
          ZR     X1,CDDX     IF DD .EQ. US
          SA6    A1 
          SA6    DDXFR       SET DDXFR TO US
          RJL    =XSNP,HMAP,(SMB,/AP/TYPE,MODIFY,/AP/TYPEL,DDUS)
          ZR     X1,CDDX     IF NO ERROR
          RJ     =XABT       ABORT
  
*         REMOTE HOST IS NS2, MODIFY DD TO BE USED TO UH. 
  
 CDD6     SA1    UHPL 
          RJ     =XDDC       CONVERT UH 
          SA6    DDXFR       SET DDFR TO UH 
          RJL    =XSNP,HMAP,(SMB,/AP/TYPE,MODIFY,/AP/TYPEL,DDUH)
          ZR     X1,CDDX     IF NO ERROR
          RJ     =XABT       ABORT
  
*         DD TYPE SPECIFIED IS UH FORCE A RNEG - SERVICERS ARE THE
*         ONLY APPLICATIONS TO SEND A UH DD PARAMETER.
  
 CDD8     MX6    -1 
          SX7    DDER 
          SA6    RTYP        FORCE NEG
          SA7    OMSGE       SET OPERATOR MESSAGE 
          SA2    RSTS 
          BX7    X2 
          SA7    TSTA 
          EQ     CDDX        RETURN 
  
 C8PL     CON    DDC8        C8 PARAMETER FOR DDC CALL
  
 UHPL     CON    DDUH        UH PARAMETER FOR DDC CALL
  
 USPL     CON    DDUS        US PARAMETER FOR DDC CALL
 CFE      SPACE 4,15
**        CFE - CHECK FOR FET ERROR.
* 
*         CFE EXAMINES THE ERROR STATUS IN THE *FET*.  IF THE NO ABORT
*         OPTION WAS SELECTED ON THE LAST CONTROL STATEMENT AND THE 
*         ERROR INDICATES THAT A ROLLOUT SHOULD BE ISSUED (*PFM* HAS
*         SET THE EVENT AND TIME IN THE *CPA*), THE ROLLOUT WILL BE 
*         ISSUED AND THE RETURN TO THE CALLER WILL INDICATE A RETRY 
*         CONDITION.  OTHERWISE THE ERROR WILL BE RETURNED TO THE 
*         CALLER. 
* 
*         ENTRY  THE *PFM* FUNCTION HAS BEEN COMPLETED. 
* 
*         EXIT   (X1) = NEGATIVE IF AN ERROR WAS FOUND
*                     = ZERO IF NO ERROR WAS FOUND
*                     = +1 IF THE REQUEST SHOULD BE RETRIED.
*                WHEN X1 = 0, X2 HAS THE FOLLOWING MEANINGS 
*                (X2) = 0    STAGE NOT REQUIRED/INITIATED 
*                (X2) = +1   STAGE REQUIRED AND INITIATED 
*                (X0) = FET ERROR CODE
* 
*         ERROR  *ABT* CALLED IF A NETWORK ERROR IS DETECTED
*                (X1) = ERROR MESSAGE ADDRESS.
* 
*         USES   A - 1,2,3,4. 
*                B - 2. 
*                X - 0,1,2,3,4,5,6. 
* 
*         CALLS  ABT, GMB, RCT. 
* 
*         MACROS MESSAGE, NETWAIT, WRITEC.
  
  
 CFE1     SA1    HMBP+1 
          RJ     =XGMB       GET THE SUPERVISORY MESSAGE
          ZR     X1,CFE2     IF NO NETWORK ERROR ENCOUNTERED
          RJ     =XABT       ISSUE DAYFILE MESSAGE AND ABORT
  
 CFE2     SA2    CFED        RETURN FET ERROR CODE
          SX1    B1          SET RETRY STATE
          BX0    X2 
  
 CFE      SUBR               ENTRY/EXIT 
          SA1    F
          MX0    -8          CHECK ERROR FIELD
          AX1    10-0 
          BX1    -X0*X1 
          BX0    X1          FET ERROR CODE 
          MX2    0           STAGE NOT REQUIRED/INITIATED 
          ZR     X1,CFEX     IF NO ERROR IS IN THE FET
          SA2    CFEA        RETRY LIST OF PFM ERROR CODES
          BX6    X1          SAVE FET ERROR CODE
          SX3    X0-/ERRMSG/INA 
          SX1    B1 
          ZR     X3,CFEX     IF INTERLOCK NOT AVAILABLE 
          MX1    1           SET ERROR RETURN CODE
          SA6    CFED 
 CFE3     IX6    X0-X2
          ZR     X6,CFE4     IF ERROR CODE IN RETRY LIST
          SA2    A2+B1
          NZ     X2,CFE3     IF NOT END OF LIST 
          EQ     CFEX        DO NOT RETRY - ERROR 
  
 CFE4     SB2    A2-CFEB
          LT     B2,CFE8     IF AN ERROR CODE TO ALWAYS RETRY 
          SX2    APLO        REMOVABLE PACK OPTION
          SA3    WB          WAIT BUSY
          SA4    NA          NO ABORT 
          SX6    X0-/ERRMSG/PFN 
          BX2    X6+X2
          BX5    X3+X4
          ZR     X2,CFEX     IF DEVICE UNAVAILABLE AND APLO NOT ENABLED 
          NZ     X6,CFE5     IF NOT DEVICE UNAVAILABLE
          NZ     X5,CFE8     IF NA OR WB
          EQ     CFEX        DO NOT RETRY - ERROR 
  
 CFE5     SX6    X0-/ERRMSG/FBS 
          NZ     X6,CFE6     IF NOT FILE BUSY 
          NZ     X5,CFE8     IF NA OR WB
          EQ     CFEX        DO NOT RETRY - ERROR 
  
 CFE6     SX6    X0-/ERRMSG/PSI 
          SA2    RT          REAL TIME
          NZ     X6,CFE7     IF NOT STAGE INITIATED 
          ZR     X2,CFE7     IF NO RT 
          MX1    0           CLEAR ERROR RETURN 
          EQ     CFEX        DO NOT RETRY - NO ERROR
  
 CFE7     SX6    X0-/ERRMSG/PWE 
          NZ     X6,CFE7.1   IF NOT WAIT MSF EXEC 
          ZR     X4,CFEX     DO NOT RETRY - ERROR 
          EQ     CFE8 
  
  
 CFE7.1   SX6    X0-/ERRMSG/SGD 
          SA2    RT          REAL TIME
          NZ     X6,CFE8     IF NOT - FILE MUST BE STAGED (CONTINUE)
          ZR     X2,CFE8     IF NOT - RT (WAIT) 
          MX1    0           CLEAR ERROR RETURN 
          EQ     CFEX        DO NOT RETRY - NO ERROR
  
 CFE8     RJ     =XRCT       RECOMPUTE REMAINING TIME 
          SX1    X1-TERT-30 
          NG     X1,CFE9     IF NOT ENOUGHT TIME FOR ROLLOUT
          RJL    =XFTUWAIT,CFEC,(=0)
          SA2    QBIT 
          SB1    1           RESET B1 
          SA3    CFED        GET FET ERROR CODE 
          SX1    B1 
          LX2    59-55
          BX0    X3 
          PL     X2,CFEX     IF NO SUPERVISORY MESSAGE PENDING
          MX6    -1 
          EQ     CFE1        CHECK SUPERVISORY MESSAGE
  
 CFE9     WRITEC DFMFILE,ACTO  *PTFS - APPLICATION CONNECTION TIMEOUT.* 
          MESSAGE  ACTO+1,3,R 
          SA2    CFED        GET FET ERROR CODE 
          MX1    1           ERROR FOUND
          BX0    X2 
          EQ     CFEX        RETURN 
  
 CFEA     CON    /ERRMSG/FTF PFM ERROR CODES TO ALWAYS RETRY
          CON    /ERRMSG/PFA
          CON    /ERRMSG/FIN
          CON    /ERRMSG/PEA
 CFEB     CON    /ERRMSG/PFN PFM ERROR CODES TO CONDITIONALLY RETRY 
          CON    /ERRMSG/PSI
          CON    /ERRMSG/PWE
          CON    /ERRMSG/SGD
          CON    /ERRMSG/FBS
          CON    0           END OF RETRY LIST
 CFEC     VFD    48/0,12/TERT 
 CFED     CON    0           FET ERROR CODE 
 RNE      SPACE  4,10 
**        CHI - GET CHARACTER INDEX 
* 
*         CONVERT CHARACTER NUMBER TO WORD NUMBER FROM START OF TEXT
*         STRING AND CHARACTER-IN-WORD INDEX. 
* 
*         ENTRY  (X1) = CHARACTER NUMBER (1 THROUGH N)
* 
*         EXIT   (B2) = WORD NUMBER (0 THROUGH N) 
*                (X2) = CHARACTER-IN-WORD INDEX (0 - 9) 
* 
*         USES   B - 2
*                X - 1,2,5,7
          SPACE  2
 CHI      SUBR
          SX1    X1-1 
          PX2    X1 
          NX2 
          SA5    =10.E0 
          FX2    X2/X5
          UX2    X2,B2
          LX2    X2,B2
          SB2    X2          WORD NUMBER
          SX7    10 
          IX2    X2*X7
          IX2    X1-X2       CHARACTER-IN-WORD INDEX
          EQ     CHIX        EXIT 
          SPACE  4
**        CHF - FETCH CHARACTER 
* 
*         RETURN ONE CHARACTER FROM A TEXT STRING.
* 
*         ENTRY  (B2) = ADDRESS OF WORD CONTAINING CHARACTER
*                (X2) = CHARACTER-IN-WORD INDEX (0 - 9) 
* 
*         EXIT   (X6) - BITS 59-6 = 0, BITS 5-0 = CHARACTER 
*                (B2) AND (X2) ARE ADVANCED TO POINT TO NEXT CHARACTER. 
* 
*         USES   A - 5
*                B - 2, 4 
*                X - 5, 6 
          SPACE  2
 CHF      SUBR
          SX6    6
          IX6    X2*X6
          SB4    X6+6 
          SA5    B2          FETCH WORD 
          LX5    B4 
          MX6    -6 
          BX6    -X6*X5      ISOLATE WANTED CHARACTER 
          SX2    X2+B1       ADVANCE CHARACTER-IN-WORD INDEX
          SX5    X2-10
          NG     X5,CHFX     IF NOT NEXT WORD 
          SB2    B2+B1       POINT TO NEXT WORD 
          MX2    0
          EQ     CHFX        EXIT 
          SPACE  4
**        CHP - PUT CHARACTER 
* 
*         PUT CHARACTER INTO TEXT STRING. 
* 
*         ENTRY  (B3) = WORD ADDRESS
*                (X3) = CHARACTER-IN-WORD ADDRESS (0 - 9) 
*                (X6) = CHARACTER IN BITS 5 - 0 
* 
*         EXIT   (B3) AND (X3) ARE ADVANCED TO POINT TO NEXT CHARACTER. 
*                THE CHARACTER IS INSERTED IN THE TEXT STRING.
* 
*         USES   A - 5, 7 
*                B - 3, 4 
*                X - 3, 5, 6, 7 
          SPACE  2
 CHP      SUBR
          SX5    6
          IX5    X3*X5
          SX7    54 
          IX5    X7-X5
          SB4    X5 
          SA5    B3          FETCH WORD 
          LX6    B4          SHIFT CHARACTER
          MX7    -6 
          LX7    B4          SHIFT MASK 
          BX7    X7*X5       CLEAR CHARACTER IN WORD
          BX7    X7+X6       INSERT CHARACTER IN WORD 
          SA7    A5          STORE WORD BACK
          SX3    X3+B1       ADVANCE INDEX
          SX5    X3-10
          NG     X5,CHPX     IF NOT NEXT WORD 
          SB3    B3+B1       ADVANCE POINTERS TO NEXT WORD
          MX3    0
          EQ     CHPX        EXIT 
 CNL      SPACE  4,12 
**        CNL - CHECK FOR NULL LINE 
* 
*         CNL CHECKS FOR A LINE OF ALL BLANKS OF
*         USER TEXT.
* 
*         USES   A  5 
*                B  6 
*                X  0 1 2 3 4 5 6 7 
* 
*         ENTRY  A5 = FWA OF TEXT LINE
*                X5 = FIRST WORD OF TEXT
* 
*         EXIT   X1 = 0 IF A NULL LINE FOUND I.E. ALL 
*                   CHARACTERS ARE A BLANK FROM THE FIRST 
*                   CHARACTER TO THE TERMINATOR (A PERIOD OR
*                   A RIGHT PARENTHESIS) OR TO THE
*                   FIRST NULL (BINARY ZERO) CHARACTER. 
*                X1.NE.0 IF NOT A NULL LINE 
          SPACE  2
 CNL4     MX1    0           EXIT - NULL LINE FOUND 
  
 CNL      SUBR
          MX0    -6 
          SX2    1R.         TERMINATORS
          SX3    1R)
          SX4    1R 
  
 CNL1     BX1    X5          WORD TO BE CHECKED 
          SB6    10          CHARACTERS TO CHECK
          LX1    6
          SA5    A5+1        NEXT WORD OF TEXT
  
 CNL2     BX6    -X0*X1 
          ZR     X6,CNL4     IF NULL CHARACTER
          BX7    X6-X2
          SB6    B6-1 
          ZR     X7,CNL4     IF TERMINATOR
          BX7    X6-X3
          LX1    6
          ZR     X7,CNL4     IF TERMINATOR
          BX6    X6-X4
          NZ     X6,CNL3     IF NOT A NULL LINE 
          NZ     B6,CNL2     IF MORE IN THIS WORD 
          EQ     CNL1 
  
CNL3      SX1    1
          EQ     CNLX 
          SPACE  4,10 
**        RCC    RECOVR CALL. 
* 
*         RCC CALLS RECOVR TO ACTIVATE OR DEACTIVATE PFSRPV (REPRIEVE). 
* 
*         ENTRY  X6 = 0 (DEACTIVATE). 
*                X6 .NE. 0 (ACTIVATE).
* 
*         EXIT   PFSRPVA = 0/277B (PFSRPV INACTIVE/ACTIVE). 
* 
*         USES   A - 1, 6.
*                X - 1, 6.
* 
*         CALLS  RECOVR.
  
  
 RCC      SUBR
          ZR     X6,RCC1     IF DEACTIVATING
          SX6    277B        SET RECOVR MASK
 RCC1     SA1    PFSRPVA     OLD MASK 
          SA6    A1 
          BX1    X1-X6
          ZR     X1,RCCX     IF NO CHANGE 
          RECOVR =XPFSRPV,X6,0
          EQ     RCCX        RETURN 
          SPACE  4
**        RNE - FORCE REPLY NEGATIVE WITH ERROR.
* 
*         RNE SETS THE DAYFILE MESSAGE AND REPLY TYPE FOR A REPLY 
*         NEGATIVE RESPONSE.
* 
*         ENTRY  (X6) = ERROR MESSAGE ADDRESS.
* 
*         EXIT   (X1) = ZERO
*                (RTYP) = -1 (SEND REPLY NEGATIVE)
*                (TSTA) = TRANSFER REJECTED STATUS. 
* 
*         USES   A - 1,2,6,7. 
*                B - NONE.
*                X - 1,2,6,7. 
* 
*         CALLS  GTL. 
  
  
 RNE      SUBR               ENTRY/EXIT 
          SA6    RNEA 
          WRITEC DFMFILE,X6 
          SA1    RNEA 
          SX1    X1+B1
          MESSAGE  X1,3,R 
          SA1    NA          CHECK IF NO ABORT SPECIFIED
          SA2    AASS        *ACCEPTABLE AND SATISFACTORY*
          NZ     X1,RNE1     IF NO ABORT SPECIFIED
          SA2    RNAS        *REJECTED, FILE ACCESS NOT ALLOWED*
          MX7    -1 
          SA7    RTYP 
 RNE1     MX1    0
          BX7    X2 
          SA7    TSTA        SET TRANSFER STATUS
          SA2    NULL 
          BX7    X2 
          SA7    ACCESS      MODE OF TRANSFER = *NULL*
          EQ     RNEX        RETURN 
  
 RNEA     BSS    1           DAYFILE MESSAGE ADDRESS
          SPACE  4
**        RPC - FORCE STOP REPLY POSITIVE WITH COMPLETION MESSAGE.
* 
*         RPC SETS THE NORMAL RETURN STATUS AND THE DAYFILE MESSAGE 
*         ADDRESS AND LENGTH FOR A *STOPR* TO BE RETURNED.  THE MESSAGE 
*         *PTFS - PF REQUEST COMPLETE.* IS THE DAYFILE MESSAGE SENT.
* 
*         ENTRY  NONE.
* 
*         EXIT   (TSTA) = NORMAL STATUS (*AASS*)
*                (X1) = ZERO. 
* 
*         USES   A - 2,6,7. 
*                B - NONE.
*                X - 1,2,6,7. 
* 
*         CALLS  NONE.
  
  
 RPC      SUBR               ENTRY/EXIT 
          WRITEC  DFMFILE,PRCD
          MESSAGE  PRCD+1,3,R 
          SA2    AASS        *ACCEPTABLE AND SATISFACTORY*
          BX6    X2 
          MX1    0
          SA6    TSTA        SET NORMAL STATUS FOR RETURN 
          EQ     RPCX        RETURN 
 SBP      SPACE  4,10 
**        RWF - REWIND FILE 
* 
* 
*         IF THERE IS A WRITE FUNCTION IN THE FET, AN EOR IS
*         WRITTEN AND THE FILE IS REWOUND.  IF LAST CODE IS NOT WRITE,
*         SET OUT = FIRST AND CODE/STATUS = EOR, COMPLETE.
* 
*         ENTRY  (A1) = ADDRESS OF FET
*                (X1) = FET WORD 0
* 
*         EXIT   (X6) = 0 IF NO WRITE DONE (NOT REWOUND)
*                (A1) = ADDRESS OF FET IF NO WRITE/REWIND 
*                (X7) = FIRST POINTER IF NO WRITE/REWIND
*                       NON-ZERO IF CODE WAS WRITE (REWOUND)
* 
*         USES   A - 2, 6, 7
*                X - 2, 6, 7
  
  
 RWF      SUBR
          SX6    754B 
          BX6    X6*X1
          ZR     X6,RWF2     IF NO FUNCTION 
          SX6    X6-14B 
          NZ     X6,RWF1     IF NOT WRITE FUNCTION
          WRITER A1,R 
          SA1    X2 
 RWF1     REWIND A1,R 
          SX6    B1 
          EQ     RWFX        EXIT 
  
 RWF2     SA2    A1+B1
          BX7    X2 
          SA7    A1+3        OUT = FIRST
          MX6    42D
          SX2    21B         EOR, COMPLETION
          BX6    X1*X6
          BX6    X6+X2
          SA6    A1 
          MX6    0
          EQ     RWFX        EXIT 
 SAC      SPACE  4,20 
**        SAC - SET ALTERNATE CATLIST PERMISSION. 
* 
*         *SAC* CHECKS THE ALTERNATE CATLIST PERMISSION AND SETS THE
*         CORRESPONDING VALUE IN THE FET. 
* 
*         ENTRY  (AC) = ALTERNATE CATLIST PERMISSION. 
* 
*         EXIT   (X1) = 0 IF NO ERROR.
*                (X6) = ERROR MESSAGE ADDRESS IF ERROR DETECTED.
*                (F+CFAP) SET WITH ALTERNATE CATLIST PERMISSION.
* 
*         USES   X - 1, 2, 3, 6.
*                A - 1, 2, 6. 
*                B - 2. 
  
  
 SAC      SUBR               ENTRY/EXIT 
          SA1    AC 
          ZR     X1,SACX     IF NO PERMISSION SPECIFIED 
          SX6    IACD        *PTFS - INVALID ALT CATLIST PERMISSION.* 
          SA2    SACA        SEARCH TABLE FOR IDENTIFIER
          SB2    SACB 
 SAC1     IX3    X2-X1
          AX3    18 
          ZR     X3,SAC2     IF MATCH FOUND 
          ZR     B2,SACX     IF END OF TABLE
          SB2    B2-B1
          SA2    A2+B1
          EQ     SAC1        CONTINUE SCAN
  
 SAC2     MX3    -6          SET *AC* IN FET
          BX2    -X3*X2 
          LX2    46-0 
          SA1    F+CFAP 
          MX3    60-2 
          LX3    46-0 
          BX6    X3*X1
          BX6    X6+X2
          SA6    A1 
          SX1    B0          INDICATE VALID PERMISSION STATUS 
          EQ     SACX        RETURN 
  
  
 SACA     VFD    42/1LN,12/0,6/ACNO 
          VFD    42/1LY,12/0,6/ACYS 
  
 SACB     EQU    *-SACA-1 
          SPACE  4
**        SBP - SET BACKUP AND RESIDENCE REQUIREMENTS.
* 
*         SBP CHECKS THE SPECIFIED BACKUP AND RESIDENCE (*BR=*, 
*         *PR=*) AND SETS THE DEFINED VALUE INTO THE *FET*.  IF 
*         THE SPECIFIED BACKUP OR RESIDENCE IS UNDEFINED AN ERROR 
*         IS RETURNED.
* 
*         ENTRY  (BR) = BACKUP REQUIREMENT FOR FILE 
*                (PR) = PREFERRED RESIDENCE FOR FILE. 
* 
*         EXIT   (X1) = ZERO IF NO ERROR DETECTED 
*                     = NON-ZERO IF VALUE COULD NOT BE CONVERTED
*                (X6) = ERROR MESSAGE ADDRESS IF ERROR
*                (F+CFPR) = *PRBR*
* 
**T,PRBR   3/ P,3/ B,54/
* 
*                *P* = PREFERRED RESIDENCE VALUE
*                *B* = BACKUP REQUIREMENT VALUE.
* 
*         USES   A - 1,2,3,6. 
*                B - 2. 
*                X - 1,2,3,4,6. 
* 
*         CALLS  NONE.
  
  
 SBP4     SA1    F+CFPR      SET VALUES IN THE *FET*
          MX4    -6 
          BX3    -X4*X3 
          BX2    -X4*X2 
          LX3    59-2        POSITION PREFERRED RESIDENCE 
          LX2    56-2        POSITION BACKUP REQUIREMENT
          BX3    X2+X3
          BX6    X1+X3
          MX1    0           RETURN WITH NO ERROR 
          SA6    F+CFPR 
  
 SBP      SUBR               ENTRY/EXIT 
          SA1    BR          CONVERT BACKUP REQUIREMENT 
          SX2    B0+
          SX6    IBRD        *PTFS - INVALID BACKUP/RESIDENCE.* 
          ZR     X1,SBP2     IF NO BACKUP REQUIREMENT 
          SA2    SBPA        SET ADDRESS OF CONVERSION TABLE
          SB2    SBPB        SET LENGTH OF TABLE
 SBP1     IX3    X2-X1
          AX3    18 
          ZR     X3,SBP2     IF MATCH FOUND 
          ZR     B2,SBPX     IF NO MATCH FOUND
          SA2    A2+B1
          SB2    B2-B1
          EQ     SBP1        CONTINUE SEARCH
  
 SBP2     SA1    PR          CHECK IF PREFERRED RESIDENCE 
          SX3    B0+
          ZR     X1,SBP4     IF NO PREFERRED RESIDENCE
          SA3    SBPC        SET ADDRESS OF CONVERSION TABLE
          SB2    SBPD        SET LENGTH OF TABLE
 SBP3     IX4    X3-X1
          AX4    18 
          ZR     X4,SBP4     IF MATCH FOUND 
          ZR     B2,SBPX     IF NO MATCH FOUND
          SA3    A3+B1
          SB2    B2-B1
          EQ     SBP3        CONTINUE SEARCH
  
 SBPA     VFD    42/1LN,12/0,6/BRNO 
          VFD    42/1LY,12/0,6/BRAL 
          VFD    42/2LMD,12/0,6/BRMD
  
 SBPB     EQU    *-SBPA-1 
  
 SBPC     BSS    0
          VFD    42/1LL,12/0,6/RSLK 
          VFD    42/1LD,12/0,6/RSDS 
          VFD    42/1LM,12/0,6/RSMS 
          VFD    42/1LN,12/0,6/RSNP 
          VFD    42/1LT,12/0,6/RSTP 
  
 SBPD     EQU    *-SBPC-1 
SFP       SPACE  4,10 
**        SDM - SEND DAYFILE MESSAGES 
* 
*         SDM REWINDS AND READS THE DAYFILE MESSAGE FILE. 
*         EACH MESSAGE IS PUT IN THE *NETPUT* BUFFER. 
*         THE FILE IS LEFT REWOUND. 
* 
*         USES   A - 1, 6 
*                X - 1, 6 
* 
*         CALLS  GTL, RWF, SNP
* 
*         MACROS READS, READNS
  
  
 SDM      SUBR
          SA1    DFMFILE     REWIND DFMFILE 
          RJ     RWF
          ZR     X6,SDM1     IF NO WRITE/REWIND DONE
          READNS  DFMFILE,R 
 SDM1     READC  DFMFILE,TEXT,TEXTL 
          NZ     X1,SDM2     IF EOR/EOF/EOI 
          SX1    TEXT 
          RJ     =XGTL
          SA6    TXTL 
          RJL    =XSNP,HMAP,(SMB,/AP/DMSG,SELECT,TXTL,TEXT) 
          ZR     X1,SDM1     IF NO ERROR
          RJ     =XABT       ABORT
 SDM2     SA1    DFMFILE     REWIND DFMFILE 
          RJ     RWF
          SA1    DFMFILE     FETCH FET C/S
          MX6    17 
          LX6    17-59       (X6) = 0000 0000 0000 0077 7776B 
          BX6    -X6*X1      CLEAR C/S, RETAIN COMPLETE BIT 
          SA6    A1 
          SA1    A1+B1       FIRST
          BX6    X1 
          SA6    A1+B1       IN = FIRST 
          EQ     SDMX        EXIT.
          SPACE  4
**        SFP - SET FET PARAMETERS. 
* 
*         SFP CHECKS AND SETS *PFM* FET PARAMETERS.  SFP ALSO 
*         CHECKS THE DEVICE TYPE SPECIFIED WITH THE *R=*
*         PARAMETER.  THE TYPE AND NUMBER OF UNITS IS SET 
*         IN THE FET. 
* 
*         ENTRY  (ARGR+1) = CONTROL CARD PARAMETER LIST 
*                (B5) = VALID PARAMETER TABLE ADDRESS.
* 
*         EXIT   (F) = *FET* CONTAINING THE PARAMETER VALUES
*                (X1) = NON-ZERO IF ERROR DETECTED
*                (X6) = ERROR MESSAGE ADDRESS IF ERROR DETECTED 
* 
*         USES   X - ALL. 
*                A - 1, 2, 3, 4, 5, 6, 7. 
*                B - 2, 6.
* 
*         CALLS  RSP, VCP.
* 
*         MACROS MESSAGE, WRITEC. 
  
  
 SFP      SUBR               ENTRY/EXIT 
          BX6    X6-X6       CLEAR FET
          SB2    FVPL 
 SFP0.1   SA6    F-1+B2 
          SB2    B2-1 
          NZ     B2,SFP0.1   IF MORE WORDS TO CLEAR 
          SA3    ARGR+1 
          RJ     =XVCP       VALIDATE CONTROL CARD PARAMETERS 
          BX7    X1 
          SA7    SFPB        SAVE ERROR MESSAGE ADDRESS 
          SA4    SFPC        SET UP ARGUMENTS FOR RSP 
          SA5    TEXT 
          SB2    B0 
          SB6    A4 
          RJ     RSP         REMOVE SECURE PARAMETERS FROM CONTROL STMT 
          MESSAGE  TEXT,3,R 
          WRITEC  DFMFILE,TEXTPFX 
          SA1    SFPB 
          SX6    X1-1 
          NZ     X1,SFPX     IF ERROR IN PARAMETERS 
          SA1    SFPA        SET UP BUFFER POINTERS 
          BX6    X1 
          SA6    F+1         FIRST
          SX6    X6 
          SA6    A6+B1       IN 
          SA6    A6+B1       OUT
          SX6    X6+FBL 
          SA6    A6+B1       LIMIT
          MX1    -1 
          SA2    WB          WAIT BUSY
          SA3    NA          NO ABORT 
          SX6    ICCM        *INVALID CONTROL CARD* 
          ZR     X2,SFP0     IF WAIT BUSY NOT SET 
          NZ     X3,SFPX     IF BOTH WAIT BUSY AND NO ABORT 
 SFP0     SA2    PFN
          SX6    PNRD        *PTFS - PF NAME REQUIRED.* 
          ZR     X2,SFPX     IF NO PF NAME GIVEN
          SA3    PW 
          MX7    -1          SET *PFN* AS LOCAL FILE NAME 
          BX7    -X7+X2 
          SA7    F
          SX6    ERAD+1      *ERROR MESSAGE RETURNED BY PFM.* 
          SA1    R           GET THE PARAMETER VALUE FOR DEVICE TYPE
          BX6    X3+X6
          SA6    A3          SET ERROR MESSAGE RETURN ADDRESS 
          SA3    F+1
          SX7    APLO 
          MX0    12 
          MX6    15 
          BX6    -X6*X3      CLEAR DEVICE TYPE AND USER PROCESSING
          BX3    X0*X1
          SX2    1R0         CHECK FOR R=0 SPECIFIED
          LX2    59-5 
          BX2    X2-X3
          NZ     X2,SFP.1    IF NOT R=0 SPECIFIED 
          SX3    0
 SFP.1    BX6    X3+X6
          MX3    1
          NZ     X7,SFP1     IF REMOVABLE PACK OPTION ENABLED 
          LX3    -14         SET USER PROCESSING BIT
          BX6    X3+X6
 SFP1     SA6    A3          REPLACE FET WORD 
          BX2    -X0*X1 
          AX2    42-0 
          ZR     X1,SFPX     IF NO DEVICE TYPE SPECIFIED
          SX6    IDSD        *PTFS - INVALID DEVICE SPECIFICATION.* 
          ZR     X2,SFP2     IF DEFAULT (1) TO BE USED
          SX2    X2-1R1 
          MI     X2,SFPX     IF NOT A DIGIT 1 - 8 
          SX3    X2+1R1-1R9 
          PL     X3,SFPX     IF NOT A DIGIT 1 - 8 
 SFP2     SA3    F+CFPK 
          SX2    X2+B1
          BX6    X2+X3       SET NUMBER OF UNITS
          SA6    A3 
          MX1    0
          EQ     SFPX        EXIT, NO ERROR 
  
 SFPA     VFD    15/0,1/1,20/0,6/CFLM-5,18/FB 
 SFPB     BSS    1           ERROR MESSAGE ADDRESS FROM VCP 
 SFPC     VFD    12/2LPW,48/0  PARAMETER TABLE FOR RSP
          CON    0
 SMC      SPACE  4,10 
**        SMC - SET MODE AND CATEGORY.
* 
*         SMC CHECKS THE SPECIFIED MODE AND CATEGORY (*M=*, 
*         *CT=*) AND SETS THE CORRESPONDING VALUES INTO 
*         THE FET.
* 
*         ENTRY  (X1) = 0, IF DEFAULT MODE OF ACCESS MUST BE *READ*.
*                (M)  = SPECIFIED MODE OF ACCESS. 
*                (CT) = FILE CATEGORY.
* 
*         EXIT   (F+CFCT) = FILE CATAGORY AND MODE OF ACCESS VALUES 
*                (X1) = NON-ZERO IF ERROR DETECTED
*                (X6) = ERROR MESSAGE ADDRESS IF ERROR DETECTED 
* 
*         USES   A - 1,2,3,6. 
*                B - 2. 
*                X - 1,2,3,4,6. 
* 
*         CALLS  NONE.
  
  
 SMC4     SA1    F+CFCT      SET VALUES IN FET
          MX4    -6 
          BX3    -X4*X3 
          BX2    -X4*X2 
          LX3    6
          BX2    X2+X3
          BX6    X1+X2
          SX1    B0+         CLEAR ERROR INDICATOR
          SA6    A1+
  
 SMC      SUBR               ENTRY/EXIT 
          NZ     X1,SMC0     IF DEFAULT MODE = READ NOT REQUIRED
          SA1    M           FETCH SPECIFIED MODE 
          NZ     X1,SMC0     IF MODE SPECIFIED
          SX6    1RR
          LX6    54 
          SA6    A1          RESET SPECIFIED MODE TO READ 
 SMC0     SA1    M           FETCH SPECIFIED MODE 
          SX6    IMCD        *PTFS - INVALID MODE/CATEGORY.*
          SX2    B0+
          ZR     X1,SMC2     IF NO MODE SPECIFIED 
          SA2    SMCA        SET TABLE OF MODE CONVERSION 
          SB2    SMCB 
 SMC1     IX3    X2-X1
          AX3    18 
          ZR     X3,SMC2     IF MATCH FOUND 
          ZR     B2,SMCX     IF NO MATCH FOUND
          SB2    B2-B1
          SA2    A2+B1
          EQ     SMC1        CONTINUE SEARCH
  
 SMC2     SA1    CT 
          SX3    B0+
          ZR     X1,SMC4     IF NO CATEGORY SPECIFIED 
          SB2    SMCD 
          SA3    SMCC        SET TABLE OF CATEGORY CONVERSION 
 SMC3     IX4    X3-X1
          AX4    18 
          ZR     X4,SMC4     IF MATCH FOUND 
          ZR     B2,SMCX     IF NO MATCH FOUND
          SB2    B2-B1
          SA3    A3+B1
          EQ     SMC3        CONTINUE SEARCH
  
 SMCA     VFD    42/1LR,12/0,1/1,5/PTRD 
          VFD    42/1LW,12/0,1/1,5/PTWR 
          VFD    42/1LA,12/0,1/1,5/PTAP 
          VFD    42/1LE,12/0,1/1,5/PTEX 
          VFD    42/1LN,12/0,1/1,5/PTNU 
          VFD    42/1LM,12/0,1/1,5/PTMD 
          VFD    42/2LRM,12/0,1/1,5/PTRM
          VFD    42/2LRA,12/0,1/1,5/PTRA
          VFD    42/5LWRITE,12/0,1/1,5/PTWR 
          VFD    42/4LREAD,12/0,1/1,5/PTRD
          VFD    42/6LAPPEND,12/0,1/1,5/PTAP
          VFD    42/7LEXECUTE,12/0,1/1,5/PTEX 
          VFD    42/4LNULL,12/0,1/1,5/PTNU
          VFD    42/6LMODIFY,12/0,1/1,5/PTMD
          VFD    42/6LREADMD,12/0,1/1,5/PTRM
          VFD    42/6LREADAP,12/0,1/1,5/PTRA
  
 SMCB     EQU    *-SMCA-1 
  
 SMCC     VFD    42/1LP,12/0,1/1,5/FCPR 
          VFD    42/1LS,12/0,1/1,5/FCSP 
          VFD    42/2LPR,12/0,1/1,5/FCPR
          VFD    42/2LPU,12/0,1/1,5/FCPB
          VFD    42/7LPRIVATE,12/0,1/1,5/FCPR 
          VFD    42/5LSPRIV,12/0,1/1,5/FCSP 
          VFD    42/6LPUBLIC,12/0,1/1,5/FCPB
  
 SMCD     EQU    *-SMCC-1 
 SNR      SPACE  4,10 
**        SNR - SEND NEGATIVE RESPONSE. 
* 
*         SNR REPLIES TO A *RFT* WITH A *RNEG* WHEN IT HAS BEEN 
*         DETERMINED THAT NO PERMANENT FILE TRANSACTION CAN OCCUR 
*         DUE TO A PARAMETER OR PRE-PROCESSOR ERROR.
* 
*         ENTRY  (TSTA) = ERROR STATE 
*                (OMSGL) = LENGTH OF THE OPERATOR MESSAGE 
*                (DMSGL) = LENGTH OF THE DAYFILE MESSAGE
*                (OMSGE) = OPERATOR MESSAGE ADDRESS 
*                (DMSGE) = DAYFILE MESSAGE ADDRESS. 
*                (PIDERR) = NON-ZERO, IF PROTOCOL IDENT MISMATCH. 
* 
*         EXIT   (A2) = RESPONSE PROCESSOR TABLE ADDRESS
*                (X2) = FIRST WORD OF THE TABLE 
*                (X1) = MESSAGE ADDRESS FOR *EPT* 
*                (X6) = LAST COMMAND RECEIVED.
* 
*         ERROR  *ABT* CALLED IF A NETWORK ERROR IS DETECTED
*                (X1) = ERROR MESSAGE ADDRESS.
* 
*         USES   A - 1,2,3,5,6,7. 
*                B - NONE.
*                X - 1,2,3,5,6,7. 
* 
*         CALLS  ABT, CAF, SDM, SNP, SRM, SRT, WSM. 
* 
*         MACROS ACSTORE, RETURN, RJL.
  
  
 SNR1     RJ     WSM         WRITE SYSTEM ERROR MESSAGE 
          ZR     X6,SNR1.0   IF NO SYSTEM ERROR 
          SA1    RSTS        *REJECTED, SEE TEXT* 
          BX6    X1 
          SA6    TSTA 
 SNR1.0   RJ     SDM         SEND DAYFILE MESSAGE 
          SA1    TSTA 
          NZ     X1,SNR1.1   IF STATE OF TRANSFER SET 
          SA1    RSTS        *REJECTED, SEE TEXT* 
          BX6    X1 
          SA6    TSTA 
 SNR1.1   RJL    =XSNP,HMAP,(SMB,/AP/STATE,SELECT,/AP/STATEL,TSTA)
          NZ     X1,SNR0     IF ERROR 
          SA1    F
          ZR     X1,SNR2     IF EMPTY FILE TRANSFER FET 
          RETURN F,R         RETURN ANY PERMANENT FILE
 SNR2     RJ     SRT         SEND ANY RECOVERY TEXT 
          SA1    HMAP 
          SX6    B0+
          SA6    ARGR        CLEAR ANY POSSIBLE POST PROCESSING 
          RJ     =XSRM       SEND AND RECEIVE MESSAGES
          NZ     X1,SNR0     IF ERROR IN TRANSFER 
          RJ     CAF         CALL ACFETCH (GET COMMAND) 
          SA2    NCPT        SET RNEG RESPONSE TABLE
  
 SNR      SUBR               ENTRY/EXIT 
          ACSTORE  SMB,RNEG,MBL 
          SA5    PIDERR 
          ZR     X5,SNR0.1   IF PROTOCOL IDENTS MATCH 
          RJL    =XSNP,HMAP,(SMB,/AP/ID,SELECT,/AP/IDL,CURID) 
          NZ     X1,SNR0     IF ERROR 
 SNR0.1   BSS    0
          SA5    OMSGE
          ZR     X5,SNR1     IF NO OPERATOR MESSAGE 
          MX6    0
          SA6    A5          CLEAR ERROR MESSAGE ADDRESS
          RJL    =XSNP,HMAP,(SMB,/AP/OMSG,SELECT,OMSGL,X5)
          NZ     X1,SNR0     IF ERROR 
          EQ     SNR1        SEND REPLY 
  
 SNR0     RJ     =XABT
          EQ     SNRX        RETURN 
 SPR      SPACE  4,10 
**        SPR - SEND POSITIVE RESPONSE. 
* 
*         SPR IS CALLED TO SEND A POSITIVE RESPONSE AFTER INITIAL 
*         POSITIVE PARAMETER PROCESSING OF *RFT* COMMAND. 
* 
*         ENTRY  (DMSGL) = DAYFILE MESSAGE LENGTH 
*                (DMSGE) = DAYFILE MESSAGE ADDRESS
*                (ACCESS) = MODE OF THE TRANSFER
*                (CHAR) = FILE FORMAT TO BE USED
*                (JOBNAME) = *PTFS-S* JOBNAME 
*                (HOST) = *PTFS-S* HOST PID.
* 
*         EXIT   (A2) = RESPONSE PROCESSOR TABLE ADDRESS
*                (X2) = FIRST WORD OF THE TABLE 
*                (X1) = MESSAGE ADDRESS FOR *EPT* 
*                (X6) = LAST COMMAND RECEIVED.
* 
*         ERROR  *ABT* CALLED IF A NETWORK ERROR IS DETECTED
*                (X1) = ERROR MESSAGE ADDRESS.
* 
*         USES   A - 1,2,3,6,7. 
*                B - NONE.
*                X - 1,2,3,5,6,7. 
* 
*         CALLS  CAF, GFL, SNP, SRM.
* 
*         MACROS MESSAGE, RJL.
  
  
 SPR      SUBR               ENTRY/EXIT 
          MESSAGE ALKA,5,R   ISSUE ACCOUNTING MESSAGE 
  
 DBG      IFC    EQ,*"DEBUG"*DEBUG* 
          MESSAGE  ALKA,0,R 
 DBG      ENDIF 
  
          SA1    F
          ZR     X1,SPR2     IF EMPTY FILE TRANSFER FET 
          RJL    =XGFL,F,(DDXFR)   GET FILE LENGTH
          SA6    SIZT 
          RJL    =XSNP,HMAP,(SMB,/AP/SIZE,SELECT,/AP/SIZEL,SIZT)
          NZ     X1,SPR9     IF ERROR 
 SPR2     RJL    =XSNP,HMAP,(SMB,/AP/MODE,SELECT,/AP/MODEL,ACCESS)
          NZ     X1,SPR9     IF ERROR 
          RJL    =XSNP,HMAP,(SMB,/AP/JOBN,SELECT,/AP/JOBNL,JOBNAME) 
          NZ     X1,SPR9     IF ERROR 
          RJL    =XSNP,HMAP,(SMB,/AP/PID,SELECT,/AP/PIDL,HOST)
          NZ     X1,SPR9     IF ERROR 
          RJL    =XSNP,HMAP,(SMB,/AP/HOSTT,SELECT,/AP/HOSTTL,NS2) 
          NZ     X1,SPR9     IF ERROR 
          SA1    MBSIZE      NETXFR MAXIMUM BLOCK SIZE
          SA2    MBS         BLOCK SIZE SELECTED BY INITIATOR 
          ZR     X2,SPR3     IF NONE SENT 
          BX6    X1-X2
          ZR     X6,SPR3     IF RFT MBZ MATCHES NETXFR MBZ
          RJ     =XCDZ
          LX6    60-6*/AP/MBZL
          SA6    SPRA 
          RJL    =XSNP,HMAP,(SMB,/AP/MBZ,MODIFY,/AP/MBZL,SPRA)
          NZ     X1,SPR9     IF ERROR 
  
 SPR3     SA1    FACTXTL
          NG     X1,SPR4     IF NO FACILITIES PARAMETER NEEDED
          RJL    =XSNP,HMAP,(SMB,/AP/FAC,FACQUAL,FACTXTL,FACTEXT) 
          NZ     X1,SPR9     IF ERROR 
 SPR4     SA1    FACIL       (=MRS/MS/RS/S IF NAM, =0 IF LCN) 
          AX1    9*6
          SX1    X1-1RM 
          NZ     X1,SPR5     IF *M* PARAMETER NOT RECEIVED
          SA1    ACKWXFR
          RJ     =XCDZ       CONVERT TO DISPLAY CODE
          LX6    60-6*/AP/AWL 
          SA6    SPRA 
          RJL    =XSNP,HMAP,(SMB,/AP/ACKW,MODIFY,/AP/AWL,SPRA)
          NZ     X1,SPR9     IF ERROR 
  
 SPR5     RJ     SDM         SEND DAYFILE MESSAGES
          MX6    0
          SA6    ACCESS 
          RJ     SRT         SEND RECOVERY TEXT 
          SA1    HMAP 
          RJ     =XSRM       SEND AND RECEIVE MESSAGES
          NZ     X1,SPR9     IF ERROR 
          RJ     CAF         CALL ACFETCH (GET COMMAND) 
          SA2    PCPT        SET COMMAND TABLE
          EQ     SPRX        RETURN 
  
 SPR9     RJ     =XABT       ABORT
  
 SPRA     CON    0           TEMPORARY STORAGE
          SPACE  4,10 
**        SRT - SEND RECOVERY TEXT
* 
*         SRT REWINDS AND READS THE RECOVERY TEXT FILE.  EACH TEXT
*         LINE IS PUT IN THE *NETPUT* BUFFER AS USER TEXT.
* 
*         USES   A - 1, 6 
*                X - 1, 6 
* 
*         CALLS  GTL, SNP, RWF
* 
*         MACROS READC, READNS
  
  
 SRT      SUBR
          SA1    ZZFILE 
          RJ     RWF         REWIND RFILE 
          ZR     X6,SRT1     IF NO WRITE DONE 
          READNS ZZFILE,R    START READ ON RECOVERY FILE
 SRT1     READC  ZZFILE,TEXT,TEXTL
          NZ     X1,SRTX     IF EOR/EOF/EOI 
          SX1    TEXT 
          RJ     =XGTL       GET TEXT LENGTH
          SA6    TXTL 
          RJL    =XSNP,HMAP,(SMB,/AP/UTEXT,SELECT,TXTL,TEXT)
          ZR     X1,SRT1     IF NO ERROR
          RJ     =XABT
          SPACE  4,10 
**        WSM - WRITE SYSTEM ERROR MESSAGE. 
* 
*         WSM WRITES A SYSTEM ERROR MESSAGE TO THE INITIATOR-S
*         MESSAGE FILE. 
* 
*         ENTRY  PFSRPVT = 0 (NO SYSTEM ERROR). 
*                        = 1 (MESSAGE WRITTEN PREVIOUSLY).
*                        .NE. 0 OR 1 (NEW MESSAGE TO WRITE).
*                PFSRPVM = FWA OF MESSAGE.
* 
*         EXIT   X6 = PFSRPVT = 0 (NO MESSAGE). 
*                             = 1 (MESSAGE WRITTEN).
* 
*         USES   A - 1, 6.
*                X - 1, 6.
* 
*         CALLS  WRITEC.
  
  
 WSM      SUBR
          SA1    PFSRPVT     CHECK FOR SYSTEM ERROR MESSAGE 
          BX6    X1 
          AX1    1
          ZR     X1,WSMX     IF NO ERROR NOR NEW MESSAGE
          WRITEC DFMFILE,PFSRPVM  SEND MESSAGE TO INITIATOR MESSAGE FILE
 DBG      IFC    EQ,*"DEBUG"*DEBUG* 
          MESSAGE PFSRPVM,3,RCL 
 DBG      ENDIF 
          SX6    1
          SA6    PFSRPVT     1 = MESSAGE WRITTEN
          EQ     WSMX        RETURN 
          SPACE  4
**        COMMON DECKS. 
  
  
          XTEXT  COMCCHG
  
          IFGT   CHGL,*,1 
          BSS    CHGL-* 
  
          XTEXT  COMCRSP
          XTEXT  COMCSFM
          XTEXT  COMCSNM
          XTEXT  COMCVDT
          XTEXT  COMCVLC
          TITLE  COMMAND PROCESSORS.
          SPACE  4,20 
**        COMMAND PROCESSORS. 
* 
*         THE FOLLOWING ROUTINES ARE CALLED BY THE EXECUTE PROCESSOR
*         FROM TABLE (*EPT*) ROUTINE.  WHEN A LEVEL 7 PROTOCOL COMMAND
*         IS RECEIVED THE PROCESSOR DEFINED FOR THE COMMAND (IN A 
*         COMMAND RESPONSE PROCESSOR TABLE) IS EXECUTED TO COMPLETE 
*         THE COMMAND PROCEDURE.  EXIT CONDITIONS SHOULD CONFORM
*         TO THE EXIT CONDITION REQUIREMENTS AS DESCRIBED HERE. 
* 
*         ENTRY  (LCMD) = VALUE OF THE COMMAND
*                (MB) = COMMAND AND PARAMETER BLOCK AS RECEIVED.
* 
*         EXIT   (X1) = ERROR MESSAGE ADDRESS IF PROCESSOR ERROR
*                     = ZERO IF NO ERROR DETECTED 
*                ALL PARAMETERS ASSOCIATED WITH THE COMMAND ARE 
*                PROCESSED. 
 CET      SPACE  4,10 
**        CET - ETP COMMAND PROCESSOR.
* 
*         THIS ROUTINE IS ENTERED AFTER RECEIVING THE ENTER 
*         TERMINATION PHASE COMMAND FROM *MFLINK*.  THE *ETPR*
*         IS BUILT AND SENT BACK TO *MFLINK*.  THE NEXT COMMAND 
*         IS ACCEPTED FROM *MFLINK* AND THE APPROPRIATE PROCESSOR 
*         ENTERED.
* 
*         ENTRY  (MB) = MESSAGE BUFFER RECEIVED.
* 
*         EXIT   (X1) = ERROR MESSAGE ADDRESS IF ERROR DETECTED 
*                     = ZERO IF NO ERROR
*                THE *ETPR* WAS SENT AND THE REPLY PROCESSED. 
* 
*         USES   A - 1,2,3,7. 
*                B - NONE.
*                X - 1,2,3,5,7. 
* 
*         CALLS  CAF, EPT, RCC, SRM.
* 
*         MACROS ACSTORE. 
  
  
 CET      SUBR               ENTRY/EXIT 
          MX6    0
          RJ     RCC         CALL RECOVR TO DEACTIVATE PFSRPV 
          ACSTORE  SMB,ETPR,MBL 
          SA1    HMAP 
          RJ     =XSRM       SEND *ETP* REPLY AND GET *FINI*
          ZR     X1,CET1     IF NO ERROR
          SA4    STAT        CHECK STATUS WORD
          MX5    60 
          BX4    X4-X5
          NZ     X4,CETX     IF NOT CONNECTION BROKEN, EXIT WITH ERROR
  
*         SPECIAL CASE CONNECTION BROKEN IF RECEIVED IN LIEU OF FINI. 
*         THE NETGET SUBROUTINE (GMB) GIVES PREFERENCE TO SUPERVISORY 
*         MESSAGES OVER DATA MESSAGES.  NORMALLY TERMINATE IF *FINI*
*         WAS ALSO QUEUED.
  
          SA2    QBIT        CHECK NSUP WORD
          LX2    59-56
          PL     X2,CETX     IF NO DATA PENDING, EXIT WITH ERROR
          SA1    HMBP+1 
          RJ     =XGMB       *FINI* EXPECTED
          NZ     X1,CETX     IF ERROR 
  
 CET1     RJ     CAF         CALL ACFETCH (GET COMMAND) 
          SA2    ECPT        SET VALID COMMAND TABLE
          RJ     =XEPT
          EQ     CETX        RETURN 
 CFI      SPACE  4,10 
**        CFI - FINI COMMAND PROCESSOR. 
* 
*         CFI IS CALLED TO PROCESS THE *FINI* COMMAND RECEIVED
*         FROM THE INITIATOR. 
* 
*         ENTRY  THE *FINI* COMMAND BLOCK WAS RECEIVED. 
* 
*         EXIT   (X1) = ERROR MESSAGE ADDRESS,
*                       ZERO, IF CONNECTION ENDED.
  
  
 CFI      SUBR               ENTRY ONLY 
          SA4    STAT        CHECK STATUS WORD
          MX5    60 
          BX4    X4-X5
          ZR     X4,CFI2     IF CONNECTION BROKEN ALREADY RECEIVED
          SA1    HMBP 
          RJ     =XRML       WAIT FOR CONNECTION BROKEN 
          SA4    STAT 
          MX5    60 
          BX4    X4-X5
          ZR     X4,CFI2     IF CONNECTION BROKEN 
          NZ     X1,CFI1     IF ERROR RECEIVED
  
*         CONTROL SHOULD NOT PASS THROUGH HERE.  IF THE NETWORK 
*         OR THE INITIATOR HAS NOT TERMINATED THE CONNECTION
*         *PTFS* WILL AT THIS TIME. 
  
          SX1    NSEM        * NETWORK SEQUENCE ERROR.* 
  
 CFI1     EQ     CFIX        RETURN 
  
 CFI2     BX1    X1-X1       NO ERROR 
          EQ     CFIX        RETURN 
 CFT      SPACE  4,10 
**        CFT - RFT COMMAND PROCESSOR.
* 
*         CFT PROCESSES ALL PARAMETERS ASSOCIATED WITH THE
*         REQUEST FILE TRANSFER COMMAND.  THE FILE TRANSFER 
*         STATUS IS INITIALLY SET TO *NULL*.
* 
*         ENTRY  (MB) = MESSAGE BUFFER CONTAING *RFT* PARAMETERS. 
* 
*         EXIT   (X1) = ERROR MESSAGE ADDRESS,
*                       ZERO, IF NO ERROR.
* 
*         USES   A - 1, 2, 3, 6, 7. 
*                X - 1, 2, 3, 6, 7. 
* 
*         CALLS  CDD, CPA, RNE, RWF, SNR, SPR.
* 
*         MACROS ACSTORE, MESSAGE, READ, READC. 
  
  
 CFT      SUBR               ENTRY/EXIT 
          SX7    -1 
          SA7    XMIT        SET DEFAULT TO NO TRANSFER 
          MX6    0
          SA6    PUR         CLEAR ENTRY POINTS USED AS FLAGS 
          SA6    PURF        CLEAR FLAG 
          SA6    RFTPASS     MAKE SURE FIRST PASS 
          SA6    RTYP        REPLY TYPE POSITIVE
          SA6    =XPJN
          SA6    PLD
          ACSTORE SMB,RPOS,MBL     *RPOS* COMMAND 
          RJL    =XSNP,HMAP,(SMB,/AP/ID,SELECT,/AP/IDL,CURID) 
          SA1    ZZFILE      REWIND RECOVERY TEXT FILE
          RJ     RWF
          NZ     X6,CFT1     IF WRITE/REWIND
          SA7    A1+2        IN = FIRST 
 CFT1     SA1    TXTFILE     REWIND USER TEXT FILE
          RJ     RWF
          NZ     X6,CFT2     IF WRITE/REWIND
          SA7    A1+2        IN = FIRST 
 CFT2     RJL    =XPRP,MB,(ATTR,QUAL,TXTL,TEXT,RPPT)
          ZR     X1,CFT3     IF NO ERROR DETECTED 
          NG     X1,CFT2.1   IF UNKNOWN ATTRIBUTE 
          MESSAGE  X1,0,R 
 CFT2.1   BSS    0
          RJL    =XSNP,HMAP,(SMB,ATTR,IGNORE,TXTL,TEXT) 
          EQ     CFT2        PROCESS NEXT PARAMETER 
  
 CFT3     SA1    RTYP 
          NZ     X1,CFT10    IF ERROR IN PASS 1 
          SA1    PUR
          SA2    =XPJN
          SA3    PLD
          ZR     X1,CFT9     IF NO USER TEXT PROCESSED
          ZR     X2,CFT9     IF NO JOB NAME PROCESSED 
          ZR     X3,CFT9     IF NO LID PROCESSED
          SA1    RLID        *RFT* *LID*
          SX6    LUAD        * LID UNAVAILABLE.*
          LX1    59-41
          PL     X1,CFT7.1   IF *LID* NOT A HOST
          LX1    59-39-59+41
          PL     X1,CFT7.1   IF *LID* IS DISABLED 
          SA1    TXTCONT
          ZR     X1,CFT4     IF NO CONTINUATION TEXT EXPECTED 
          SX6    ICTD 
          SA6    TMSGE       *INCOMPETE CONTINUED DIRECTIVE.* 
          MX7    0
          SA7    TEXTLTH
 CFT4     SX7    B1 
          SA7    RFTPASS     SECOND PASS THRU USER TEXT 
          SA1    TXTFILE     REWIND USER TEXT 
          RJ     RWF
          ZR     X6,CFT5     IF NO WRITE CODE 
          READ   TXTFILE,R
 CFT5     READC  TXTFILE,TEXT,TEXTL 
          NZ     X1,CFT7     IF EOR/EOF/EOI 
          SB2    ENDC-DARAA  CLEAR BUFFER 
          SX6    B0+
 CFT6     SA6    DARAA-1+B2 
          SB2    B2-1 
          NZ     B2,CFT6     IF ALL NOT CLEARED 
          RJ     PUR         PROCESS USER TEXT
          SA3    RTYP        GET REPLY TYPE 
          NZ     X3,CFT10    IF NEGATIVE REPLY TO BE SENT 
          SA1    XMIT 
          NG     X1,CFT5     IF NO FILE TRANSFER REQUIRED 
 CFT7     SA1    TMSGE
          ZR     X1,CFT8     IF NO TEXT ERROR 
          BX6    X1 
 CFT7.1   RJ     RNE            FORCE RNEG
          MX6    0
          SA6    TMSGE
          SA1    RSTS        *REJECTED, SEE TEXT* 
          BX6    X1 
          SA6    TSTA        SET TRANSFER STATUS
          EQ     CFT10       SEND NEGATIVE REPLY
  
 CFT8     RJ     CDD         CHECK DATA DECLARATION 
          SA3    RTYP 
          NZ     X3,CFT10    IF ERROR IN DD COVERSION 
          RJL    =XMBZ,DDXFR,(DBZ,NWTYPE) 
          SA6    MBSIZE      MAXIMUM BLOCK SIZE 
          SA1    MBS         BLOCK SIZE SENT BY INITIATOR 
          ZR     X1,CFT11    IF NONE SENT 
          IX2    X1-X6
          PL     X2,CFT11    IF NETXFR MBZ .LE. RFT MBZ 
 .1       DECMIC /AP/MBZ,2
          SX6    3R".1".
          LX6    59-17
          SA6    PEPM+3 
          SX6    PEPM        *PROTOCOL ERROR IN XX* 
          EQ     CFT7.1      FORCE NEGATIVE REPLY 
  
 CFT9     SA2    RUTS        *REJECTED, UNSPECIFIC XFER*
          BX6    X2 
          SA6    TSTA        SET TRANSFER STATUS
  
 CFT10    RJ     SNR         SEND NEGATIVE REPLY
          EQ     CFT12
  
 CFT11    SA1    PFSRPVT     CHECK SYSTEM ERROR 
          NZ     X1,CFT10    IF SYSTEM ERROR OCCURRED 
          RJ     SPR         SEND POSITIVE RESPONSE 
  
 CFT12    RJ     =XEPT       PROCESS *GO* OR *STOP* 
          EQ     CFTX        RETURN 
 CGO      SPACE  4,10 
**        CGO - GO COMMAND PROCESSOR. 
* 
*         CGO IS ENTERED WHEN THE *GO* COMMAND IS RECEIVED FROM 
*         THE INITIATOR.  NO PARAMETERS ARE VALID AND THE 
*         TRANSFER DIRECTION MUST HAVE BEEN PREVIOUSLY SET. 
* 
*         EXIT   (XFR) = NON-ZERO, IF FILE TO BE TRANSFERRED. 
* 
*         EXIT   (X1) = ERROR MESSAGE ADDRESS.
  
  
 CGO      SUBR               ENTRY/EXIT 
          SA1    HMBP 
          RJ     =XWLB       WAIT FOR LAST BACK 
          NZ     X1,CGO1     IF ERROR IN RECEIVE
          BX1    X1-X1       SET NO ERROR 
          SX6    B1 
          SA6    XFR
  
 CGO1     EQ     CGOX        RETURN 
 COG      SPACE  4,15 
**        COG - COMPLETE *GO* COMMAND PROCESSING. 
* 
*         COG IS ENTERED TO COMPLETE *GO* PROCESSING AFTER *NETXFR* 
*         HAS DONE THE ACTUAL FILE TRANSFER.
* 
*         ENTRY  (XMIT) = 0, IF RECEIVED FILE TRANSFER. 
*                       = 1, IF SENT FILE TRANSFER. 
* 
*         EXIT   (TSTA) = FILE TRANSFER STATUS. 
  
  
 COG      SUBR               ENTRY/EXIT 
          RJ     =XSTT       SET TIMEOUT TIME 
          RJL    =XPTERXF,PEPM,(XFRA,COGA,COGB) 
          SA2    COGA        NETXFR STATUS FLAGS
*         LX2    59-59       CONNECTION-NOT-VIABLE FLAG 
          SA1    COGB        MESSAGE LOCATION 
          PL     X2,COG1     IF CONNECTION VIABLE 
          SA3    NWTYPE 
          NZ     X3,COG0.1   IF NOT RHF 
          BX6    X2 
          LX6    59-54
          PL     X6,COG1     IF CONNECTION NOT BROKEN 
  
 COG0.1   MX6    60 
          SA6    STAT        SET CONNECTION BROKEN STATUS 
          RJ     =XABT       ISSUE MESSAGE AND TERMINATE
  
 COG1     ZR     X1,COG2     IF NO ERROR MESSAGE
          LX2    59-56
          PL     X2,COG1.1   IF NO NETXFR MESSAGE 
          SX1    MS1W        ADDR OF LAST MESSAGE 
          MX6    1
          LX6    18+1        RSB BLOCK-READ 
          BX6    X6+X1       MERGE ADDR 
          SA6    COGD        SET RSB PARAMETERS 
          SYSTEM RSB,R,COGC  FETCH NETXFR MESSAGE 
          SA1    COGD 
          ZR     X1,COG1.1   IF NO NETXFR  MESSAGE
          SX1    A1 
          WRITEC DFMFILE,X1  WRITE TO INITIATOR MESSAGE FILE
 DBG      IFC    EQ,*"DEBUG"*DEBUG* 
          MESSAGE COGD,3,R   SEND TO DAYFILE
 DBG      ENDIF 
 COG1.1   SA1    COGB 
          MESSAGE X1,3,R     ISSUE DAYFILE MESSAGE
          SA1    COGB 
          WRITEC DFMFILE,X1  WRITE TO INITIATOR MESSAGE FILE
 COG1.2   RJ     WSM         WRITE SYSTEM ERROR MESSAGE 
          SA1    TSTS        *TERMINATED, SEE TEXT* 
          NZ     X6,COG3     IF SYSTEM ERROR
          SA2    COGA        NETXFR STATUS
          LX2    59-55       NO RETRY FLAG (BIT 55) 
          SA3    XMIT        TRANSFER DIRECTION 
          NG     X2,COG3     IF NO RETRY POSSIBLE 
          SA1    RPRS        *RECEIVE PROBLEM, RETRY* 
          ZR     X3,COG3     IF RECEIVING 
          SA1    SPRS        *SENDER PROBLEM, RETRY*
          EQ     COG3        DO NOT ISSUE ACCOUNTING MESSAGE
  
 COG2     SA1    PFSRPVT     CHECK SYSTEM ERROR MESSAGE 
          NZ     X1,COG1.2   IF SYSTEM ERROR OCCURRED 
          RJL    =XGFL,F,(DDXFR) GET FILE LENGTH
          BX1    X7 
          RJ     =XCFD=      CONVERT LENGTH TO F10.3 FORMAT 
          SA6    ULSA+1 
          MESSAGE  ULSA,5,R  *UCLS,PF,XX.XXXKUNS.*
 DBG      IFC    EQ,*"DEBUG"*DEBUG* 
          MESSAGE  ULSA,0,R 
 DBG      ENDIF 
          MX1    0           FLAG NO ERROR
  
 COG3     BX7    X1          SAVE ERROR FLAG
          SA7    TSTA 
          SA1    HMBP 
          RJ     =XRML       RECEIVE *MFLINK* STATUS
          NZ     X1,COG4     IF ERROR IN TRANSFER 
          RJ     CAF         CALL ACFETCH (GET COMMAND) 
          SA2    DCPT        DATA TRANSFER PHASE VALID RESPONSES
          EQ     COGX        RETURN 
  
 COG4     RJ     =XABT       ISSUE MESSAGE AND ABORT
  
 COGA     CON    0           CONNECTION BROKEN FLAG 
  
 COGB     CON    0           NETXFR MESSAGE ADDRESS 
  
 COGC     VFD    12/0,12/8,18/MS1W,18/COGD  RSB PARAMETER 
 COGD     BSSZ   8           NETXFR ERROR MESSAGE 
 CPA      SPACE  4,15 
**        CPA - CLEAR PARAMETER AREA. 
* 
*         CPA IS CALLED TO CLEAR CERTAIN PARAMETERS BEFORE THE USER 
*         TEXT IS PROCESSED.
* 
*         EXIT   (X3) = REPLY TYPE FOR *RFT*. 
* 
*         USES   X - 3, 6.
*                A - 3, 6.
*                B - 2. 
  
  
 CPA      SUBR               ENTRY/EXIT 
          SB2    ENDA-DARAA  NUMBER OF WORDS TO CLEAR 
          SX6    B0+
 CPA1     SA6    DARAA-1+B2  CLEAR PARAMETER AREA 
          SB2    B2-1 
          NZ     B2,CPA1     IF MORE WORDS TO CLEAR 
          SB2    FVPL        NUMBER OF WORDS TO CLEAR 
 CPA2     SA6    F-1+B2      CLEAR FET OR PARAMETER 
          SB2    B2-1 
          NZ     B2,CPA2     IF MORE WORDS TO CLEAR 
          EQ     CPAX        RETURN 
 CST      SPACE  4,10 
**        CST - STOP COMMAND PROCESSOR. 
* 
*         CST IS CALLED AFTER RECEIVING THE *STOP* COMMAND
*         FROM *MFLINK*.  ANY POST-PROCESSOR DEFINED FOR
*         THE CURRENT PERMANENT FILE REQUEST WILL BE
*         CALLED.  THE ACCOUNTING MESSAGE WILL BE ISSUED
*         IF A FILE TRANSFER HAS COMPLETED. 
* 
*         ENTRY  (MB) = COMMAND BUFFER RECEIVED 
*                (TSTA) = FILE TRANSFER STATUS. 
* 
*         EXIT   (X1) = ERROR MESSAGE ADDRESS IF ERROR DETECTED 
*                     = ZERO IF NO ERROR
*                (A2) = COMMAND PROCESSOR TABLE IF (X5) = 1 
*                (X2) = FIRST WORD OF TABLE 
*                *STOPR* COMMAND SENT AND NEXT COMMAND RECEIVED.
  
  
 CST2     SA2    TSTA        CHECK TRANSFER ERROR STATUS
          SA3    ARGR        GET PF REQUEST TO BE POST-PROCESSED
          NZ     X2,CST4     IF ERROR WAS SET 
          BX6    X3 
          AX6    18 
          SA2    VPCT        SET POST-PROCESSOR ADDRESS TABLE 
          RJ     =XEPT       EXECUTE POST PROCESSOR (IF DEFINED)
          SA1    RTYP 
          NZ     X1,CST4     IF ERROR WAS SET 
 CST3     READC  TXTFILE,TEXT,TEXTL 
          NZ     X1,CST4     IF EOR/EOF/EOI 
          RJ     CPA         CLEAR PARAMETER AREA 
          RJ     PUR         PROCESS USER TEXT
          SA3    RTYP        GET REPLY TYPE 
          ZR     X3,CST3     IF NO ERROR YET
 CST4     SA1    TMSGE
          NZ     X1,CST4.1   IF TEXT ERROR
          SA1    TSTA 
          NZ     X1,CST5     IF STATUS WAS SET
          SA1    AASS        USE *SATISFACTORY AND COMPLETE*
          EQ     CST4.2 
  
 CST4.1   BSS    0
          BX6    X1 
          RJ     RNE
          MX6    0
          SA6    TMSGE
          SA1    RSTS        *REJECTED, SEE TEXT* 
  
 CST4.2   BSS    0
          BX6    X1 
          SA6    TSTA        SET TRANSFER STATUS
 CST5     RJL    =XSNP,HMAP,(SMB,/AP/STATE,SELECT,/AP/STATEL,TSTA)
          NZ     X1,CST9     IF ERROR 
          RJ     SDM         SEND DAYFILE MESSAGES
          SA1    HMAP        SET PARAMETER LIST ADDRESS 
          RJ     =XSRM       SEND *STOPR* AND WAIT FOR REPLY
  
 CST      SUBR               ENTRY/EXIT 
          ACSTORE  SMB,STOPR,MBL
 CST1     RJL    =XPRP,MB,(ATTR,QUAL,TXTL,TEXT,SPPT)
          ZR     X1,CST2     IF NO ERROR IN PARAMETER 
          NG     X1,CST1     IF UNKNOWN ATTRIBUTE 
          MESSAGE  X1,0,R 
          RJL    =XSNP,HMAP,(SMB,ATTR,IGNORE,TXTL,TEXT) 
          ZR     X1,CST1     IF NO ERROR, CONTINUE
  
 CST9     RJ     =XABT
 ECPT     TITLE  COMMAND RESPONSE PROCESSOR TABLES. 
**        ECPT - ETPR COMMAND RESPONSE PROCESSOR ADDRESS TABLE. 
* 
**T,ECPT   42/ CMND,18/ ADDR+1
* 
*         ADDR   - ADDRESS OF COMMAND PROCESSOR.
*         CMND   - COMMAND VALUE. 
  
  
 ECPT     CADDRE FINI,CFI 
          BSSZ   1
 ICPT     SPACE  4,10 
**        ICPT - VALID IDLE STATE COMMAND PROCESSOR ADDRESS TABLE.
* 
**T,ICPT   42/ CMND,18/ ADDR+1
* 
*         ADDR   - ADDRESS OF COMMAND PROCESSOR.
*         CMND   - COMMAND VALUE. 
  
  
 ICPT     CADDRE RFT,CFT
          CADDRE ETP,CET
          BSSZ   1
 PCPT     SPACE  4,10 
**        PCPT - RPOS COMMAND RESPONSE PROCESSOR ADDRESS TABLE. 
* 
**T,PCPT   42/ CMND,18/ ADDR+1
* 
*         ADDR   - ADDRESS OF COMMAND PROCESSOR.
*         CMND   - COMMAND VALUE. 
  
  
 PCPT     CADDRE GO,CGO 
 NCPT     SPACE  4,10 
**        NCPT - RNEG COMMAND RESPONSE PROCESSOR ADDRESS TABLE. 
* 
**T,NCPT   42/ CMND,18/ ADDR+1
* 
*         ADDR   - ADDRESS OF COMMAND PROCESSOR.
*         CMND   - COMMAND VALUE. 
  
  
 NCPT     CADDRE STOP,CST 
          BSSZ   1
 DCPT     SPACE  4,10 
**        DCPT - DATA TRANSFER PHASE COMMAND ADDRESS TABLE. 
* 
**T,DCPT   42/ CMND,18/ ADDR+1
* 
*         ADDR   - ADDRESS OF COMMAND PROCESSOR.
*         CMND   - COMMAND VALUE. 
  
  
 DCPT     EQU    NCPT 
          TITLE  PARAMETER PROCESSORS.
**        PARAMETER PROCESSORS. 
* 
*         THE FOLLOWING ROUTINES PROCESS PARAMETERS ASSOCIATED
*         WITH A COMMAND(S).  THE ROUTINES ARE ENTERED BY THE EXECUTE 
*         PROCESSOR FROM TABLE (*EPT*) ROUTINE.  THE ASSOCIATION OF A 
*         PARAMETER PROCESSOR WITH A PARAMETER VALUE IS DONE VIA A
*         COMMAND PARAMETER PROCESSOR TABLE.  THE PROCESSORS MUST 
*         CONFORM TO THE CONDITIONS AS STATED HERE. 
* 
*         ENTRY  (A1) = ADDRESS OF THE PARAMETER LIST 
* 
*         PARAMETER LIST FORMAT 
*         ATTR   - ATTRIBUTE VALUE OF THE PARAMETER 
*         QUAL   - QUALIFIER OF THE PARAMETER 
*         TEXT   - THE TEXT PORTION OF THE PARAMETER
*         TXTL   - THE LENGTH OF THE TEXT PORTION.
* 
*         EXIT   (X1) = ERROR MESSAGE ADDRESS IF ERROR DETECTED 
*                     = ZERO IF NO ERROR. 
 EXI      SPACE  4,10 
**        EXI - EXIT WITH NO ERROR. 
* 
*         EXI IS CALLED TO IGNORE A PARAMETER.
* 
*         ENTRY  A PARAMETER TO BE IGNORED WAS FETCHED. 
* 
*         EXIT   (X1) = ZERO. 
* 
*         USES   A - NONE.
*                B - NONE.
*                X - 1. 
* 
*         CALLS  NONE.
  
  
 EXI      SUBR               ENTRY/EXIT 
          MX1    0
          EQ     EXIX        EXIT WITH NO ERROR 
 PCT      SPACE  4,10 
**        MFX - DETECT MULTIPLE FILE TRANSFERS
* 
*         MFX IS CALLED DURING PASS 1 PROCESSING OF RFT USER TEXT 
*         FOR EACH TEXT REQUIRING A FILE TRANSFER.  IF A FILE 
*         TRANSFER IS ALREADY REQUIRED FOR THE CURRENT RFT, 
*         FORCE RNEG. 
* 
*         USES   A - 5, 6 
*                X - 5, 6 
  
  
 MFX      SUBR
          SA1    FXCT 
          SX6    X1+B1       INCREMENT FILE TRANSFER COUNT THIS RFT 
          SA6    A1 
          ZR     X1,MFXX     IF NO XFERS PREVIOUSLY REQUIRED
          SX6    MFXD 
          RJ     RNE         FORCE RNEG 
          EQ     MFXX        EXIT 
 PAL      SPACE  4,20 
**        PAL - PROCESS ACCESS LEVEL. 
* 
*         *PAL* EVALUATES IF AN ACCESS LEVEL HAS BEEN SPECIFIED ON
*         A *SAVE* OR A *DEFINE* STATEMENT.  IF SO, SET ACCESS
*         LEVEL VALUE AND *SP* BIT IN THE FET.
* 
*         ENTRY  (AL) = ACCESS LEVEL, IF SPECIFIED IN STATEMENT.
* 
*         EXIT   (X6) = 0, IF VALID ACCESS LEVEL SPECIFIED. 
*                     = ADDRESS OF ERROR MESSAGE, OTHERWISE.
* 
*         USES   X - 1, 2, 6. 
*                A - 1, 6.
*                B - 2. 
* 
*         CALLS  VLC. 
  
  
 PAL1     SX6    UALD        *  PTFS  - UNKNOWN ACCESS LEVEL NAME.* 
  
 PAL      SUBR               ENTRY/EXIT 
          SA1    AL 
          BX6    X6-X6       ASSUME NO ERROR
          SB2    B0          SET ACCESS LEVEL FLAG
          ZR     X1,PALX     IF *AL* NOT SPECIFIED
          RJ     VLC         VALIDATE ACCESS LEVEL MNEMONIC 
          NG     X2,PAL1     IF INCORRECT ACCESS LEVEL
          SA1    ALV
          MX6    60-3 
          LX2    36-0        POSITION NEW *AL*
          LX6    36-0 
          BX6    X6*X1       CLEAR *AL* FIELD 
          BX6    X2+X6       MERGE *AL* IN FET
          SA6    A1 
          SA1    F+B1        SET *SP* BIT IN FET
          SX2    B1 
          LX2    39-0 
          BX6    X1+X2
          SA6    A1 
          SX6    B0+         INDICATE VALID ACCESS LEVEL
          EQ     PALX        RETURN 
          SPACE  4,10 
**        PAW    - PROCESS ACKNOWLEGEMENT WINDOW
* 
*         IF NAM SUBSYSTEM, PAW EXTRACTS AND VALIDATES THE ACKNOW-
*         LEDGEMENT WINDOW PARAMETER, CONVERTS IT TO BINARY AND 
*         SAVES FOR USE BY NETXFR.
* 
*         ENTRY  (TEXT)      AKNOWLEDGEMENT WINDOW PARAMETER
* 
*         EXIT   (ACKWXFR)   ACKNOWLEDGEMENT WINDOW (BINARY)
* 
*         USES   X - 1, 3, 5, 6, 7
*                A - 1, 5, 7. 
*                B - 7. 
* 
*         CALLS  DXB=.
  
  
 PAW      SUBR               ENTRY/EXIT 
          SA1    NWTYPE 
          ZR     X1,PAWX     IF RHF SUBSYSTEM 
          SA5    TEXT 
          SB7    B1 
          RJ     =XDXB=      CONVERT TO BINARY
          SX7    MAXACKW
          IX3    X7-X6
          NG     X3,PAW1     IF PARAMETER .GT. MAXACKW
          SX7    MINACKW
          IX3    X6-X7
          NG     X3,PAW1     IF PARAMETER .LT. MINACKW
          BX7    X6 
 PAW1     SA7    ACKWXFR
          MX1    0
          EQ     PAWX 
  
          SPACE  4
**        PCT - PROCESS CONTINUED MESSAGE BLOCK.
* 
*         PCT READS THE NEXT MESSAGE BLOCK FROM THE NETWORK.  THE 
*         LAST COMMAND RECEIVED MUST MATCH THE COMMAND IN THE 
*         CURRENT BLOCK.  CONTROL RETURNS TO THE CALLER AFTER 
*         SETTING OF THE TEXT HEADER (*ACFETCH*). 
* 
*         ENTRY  (LCMD) = LAST COMMAND VALUE. 
* 
*         EXIT   (MB) = CONTINUATION MESSAGE BLOCK. 
*                (X1) = ZERO. 
* 
*         ERROR  *ABT* CALLED IF THE COMMAND BLOCK DOES NOT CONTINUE
*                (X1) = ERROR MESSAGE ADDRESS.
* 
*         USES   A - 1. 
*                B - NONE.
*                X - 1. 
* 
*         CALLS  ABT, CAF, RML. 
  
  
 PCT      SUBR               ENTRY/EXIT 
          SA1    HMBP 
          RJ     =XRML       RECEIVE CONTINUATION MESSAGE 
          NZ     X1,PCT1     IF ERROR IN RECEIVE
          SA3    LCMD        SAVE LAST COMMAND RECEIVED 
          BX7    X3 
          SA7    PCTA 
          RJ     CAF         CALL ACFETCH (GET COMMAND) 
          SA1    PCTA        COMPARE LAST AND CURRENT COMMANDS
          IX1    X6-X1
          ZR     X1,PCTX     IF COMMANDS MATCH
          SX1    CNFM        *CONTINUATION BLOCK DID NOT FOLLOW.* 
 PCT1     RJ     =XABT       ISSUE DAYFILE MESSAGE AND ABORT
  
 PCTA     BSS    1           LAST COMMAND RECEIVED
 PDM      SPACE  4,10 
**        PDM - PROCESS DAYFILE MESSAGE.
* 
*         PDM ISSUES THE OPERATOR OR DAYFILE MESSAGES SENT
*         BY THE INITIATOR.  OPERATOR MESSAGES ARE ISSUED TO
*         THE SYSTEM AND LOCAL DAYFILES.  DAYFILE MESSAGES
*         ARE ISSUED TO ONLY THE LOCAL DAYFILE. 
* 
*         ENTRY  (A1) = PARAMETER LIST ADDRESS
* 
*         PARAMETER LIST FORMAT 
*         ATTR   - PARAMETER ATTRIBUTE (*DMSG* OR *OMSG*) 
*         QUAL   - PARAMETER QUALIFIER
*         TEXTL  - PARAMETER TEXT LENGTH
*         TEXT   - DAYFILE MESSAGE. 
* 
*         EXIT   (X1) = ZERO. 
* 
*         USES   A - 1,6. 
*                B - 2. 
*                X - 1,6. 
* 
*         CALLS  NONE.
* 
*         MACROS MESSAGE, SUBRL.
  
  
 PDM      SUBRL  (ATTR,,,#TEXT) 
          SA1    ATTR 
          SB2    3           SET DEFAULT FOR DAYFILE MESSAGE
          SX1    X1-/AP/DMSG
          ZR     X1,PDM1     IF DAYFILE MESSAGE 
          SB2    B0+
 PDM1     SA2    "TEXT"      GET MESSAGE ADDRESS
          MESSAGE  X2,B2,R
          EQ     PDMX        RETURN 
  
  
          QUAL   *
 PEP      SPACE  4,10                                              ECHO 
**        PEP - PROCESS ECHO PARAMETER.                            ECHO 
*                                                                  ECHO 
*         PEP ECHOES THE ECHO PARAMETER TEXT ON THE *RPOS*         ECHO 
*         COMMAND.  IF RNEG SENT, THIS IS OVERWRITTEN.             ECHO 
*                                                                  ECHO 
*         ENTRY  (TEXT) = PARAMETER TEXT TO BE ECHOED              ECHO 
*                (TXTL) = TEXT LENGTH.                             ECHO 
*                                                                  ECHO 
*         EXIT   (X1) = ZERO                                       ECHO 
*                THE PARAMETER IS ECHOED ON THE *RPOS* COMMAND.    ECHO 
*                                                                  ECHO 
*         ERROR  *ABT* CALLED IF NETWORK ERROR DETECTED            ECHO 
*                (X1) = ERROR MESSAGE ADDRESS.                     ECHO 
*                                                                  ECHO 
*         USES   A - 1,2,3,4.                                      ECHO 
*                B - NONE.                                         ECHO 
*                X - 1,2,3,4.                                      ECHO 
*                                                                  ECHO 
*         CALLS  ABT, SNP.                                         ECHO 
*                                                                  ECHO 
*         MACROS RJL.                                              ECHO 
                                                                   ECHO 
                                                                   ECHO 
 PEP      SUBR               ENTRY/EXIT                            ECHO 
          RJL    =XSNP,HMAP,(SMB,/AP/ECHO,SELECT,TXTL,TEXT)       ECHO
          NZ     X1,PEP1     IF ERROR 
          MX1    0           NO ERROR                              ECHO 
          EQ     PEPX        RETURN                                ECHO 
  
 PEP1     RJ     =XABT       ABORT
          SPACE  4,10 
**        PFA - PROCESS FACILITIES PARAMETER
* 
*         PFA VALIDATES FACILITIES RECEIVED IN RFT COMMAND. 
* 
*         ENTRY  (TEXT)      FACILITIES PARAMETER 
*                (TXTL)      TEXT LENGTH
*                (NWTYPE)    NETWORK TYPE 
* 
*         EXIT   (X1)      = ERROR MESSAGE ADDRESS
*                          = 0 (NO ERROR) 
*                (FACQUAL) = QUALIFIER (FOR RPOS) 
*                (FACTEXT) = RPOS FACILITIES TEXT 
*                (FACTXTL) = RPOS FACILITIES TEXT LENGTH
*                          = -1 IF NO RPOS PARAMETER NEEDED)
*                (FACIL)   = NETXFR FACILITIES
* 
*         USES   ALL REGISTERS. 
* 
*         CALLS  FACCHK.
  
  
 .1       DECMIC /AP/FAC,2
  
 PFA      SUBR
          RJL    =XFACCHK,TEXT,(TXTL,NWTYPE,PFAA,FACTEXT,FACTXTL,FACQUAL
,,FACIL,PFAB) 
          SA2    PFAB        CHECK ERROR
          NG     X2,PFA9     IF INVALID CHARACTER OR TEXT LENGTH > 240
          MX1    0
          NZ     X2,PFAX     IF RPOS PARAMETER REQUIRED 
          MX6    -1 
          SA6    FACTXTL     SET TEXT LENGTH .LT. 0 
          EQ     PFAX 
  
 PFA9     SX6    3R".1" 
          SX1    PEPM        PROTOCOL ERROR IN XX 
          LX6    59-17
          SA6    PEPM+3 
          EQ     PFAX 
  
 PFAA     CON    1           FACCHK APPLICATION CODE (1=PTF)
 PFAB     BSS    1           ERROR FLAG 
 PID      SPACE  4,10 
**        PID - PROCESS ID PARAMETER. 
* 
*         PID COMPARES THE LOCAL AND REMOTE PROTOCOL IDENTIFIERS. 
*         IF CHARACTERS 1-4 MATCH:  
*           SET PIDERR = 0. 
*           RETURN (RPOS RESPONSE). 
*         ELSE
*           SET PIDERR NON-ZERO.
*           SET TSTA = *RUTS*, RTYP = -1 (RNEG RESPONSE). 
* 
*         ENTRY  (TEXT) = RECEIVED PARAMETER TEXT 
*                (CURID) = ASSEMBLED CURRENT ID.
* 
*         EXIT   (RTYP) = NEGATIVE IF *RNEG* TO BE RETURNED 
*                (TSTA) = *RUTS* IF PROTOCOL ID DOES NOT MATCH. 
*                (PIDERR) = NON-ZERO, IF PROTOCOL IDENT MISMATCH. 
* 
*         USES   A - 2,3,6,7. 
*                B - NONE.
*                X - 1,2,3,6,7. 
* 
*         CALLS  NONE.
  
  
 PID      SUBR               ENTRY/EXIT 
          SA2    TEXT 
          SA3    /CONSTANT/CURID  CHECK RECEIVED WITH *CURID* 
          BX6    X2-X3
          SA6    PIDERR      CLEAR/SET PID MISMATCH FLAG
          MX1    0
          ZR     X6,PIDX     IF IDENTS MATCH
          SA2    RUTS        *REJECTED, UNSPECIFIC TRANSFER*
          MX6    -1 
          BX7    X2 
          SA6    RTYP        SET REPLY NEGATIVE 
          SA7    TSTA        SET TRANSFER STATUS
          EQ     PIDX        RETURN 
  
 PIDERR   BSS    1           PID MISMATCH FLAG
 PLD      SPACE  4,10 
**        PLD - PROCESS LID PARAMETER.
* 
*         PLD MOVES THE RECEIVED LOGICAL ID TO THE ACCOUNTING 
*         MESSAGE AREA. 
* 
*         ENTRY  (TEXT) = RECEIVED *LID*. 
* 
*         EXIT   (ALKA+2) = *LID*.
*                (RLID)   = *LID* 
* 
*         USES   A - 2,6. 
*                B - NONE.
*                X - 1,2,3,6. 
* 
*         CALLS GETLIDA 
  
  
 PLD      SUBR               ENTRY/EXIT 
          SA2    TEXT 
          MX3    3*6
          BX2    X2*X3       ENSURE 3 CHARACTER *LID* 
          SX6    B1 
          BX6    X2+X6
          SA6    RLID        STORE *LID*
          SX3    1R.         SET MESSAGE TERMINATOR 
          LX3    41-5        POSITION TERMINATOR
          BX6    X2+X3
          SA6    ALKA+2      STORE ACCOUNTING MESSAGE 
          MX1    0
          GETLIDA  RLID      GET *RFT* *LID* ATTRIBUTES 
          EQ     PLDX        RETURN 
 PMB      SPACE  4,10 
**        PMB - PROCESS MAXIMUM BLOCKSIZE 
* 
*         PMB EXTRACTS THE MAXIMUM BLOCKSIZE PARAMETER, CONVERTS IT 
*         TO BINARY AND SAVES FOR USE BY NETXFR.
* 
*         ENTRY  (TEXT) = MAXIMUM BLOCKSIZE 
*                (DBZ)  = DOWNLINE BLOCK SIZE FROM *CON/REQ/R*. 
* 
*         EXIT   (MBS)  = BLOCK SIZE PARAMETER FROM INITIATOR.
*                (DBZ)  = MIN(DBZ,MBS)
*                (X1)   = ERROR MSG IF PROTOCOL ERROR.
*                       = ZERO IF NO ERROR. 
  
  
 .1       DECMIC /AP/MBZ,2
  
 PMB      SUBR
          SA5    TEXT        GET TEXT (MAXIMUM BLOCK SIZE)
          SB7    1
          RJ     =XDXB=      CONVERT TO BINARY
          NZ     X4,PMB1     IF ERROR 
          SX1    X6-1 
          MI     X1,PMB1     IF BLOCK SIZE TOO SMALL
          SA6    MBS         SAVE MAXIMUM BLOCK SIZE (IN BINARY)
          SA2    DBZ         DOWNLINE BLOCK SIZE
          IX1    X6-X2
          AX1    59 
          BX2    -X1*X2 
          BX6    X1*X6
          BX6    X2+X6
          SA6    DBZ         (DBZ) = MIN(MBS,DBZ) 
          BX1    X1-X1       NO ERROR ON RETURN 
          EQ     PMB2 
  
 PMB1     SX6    3R".1".
          SX1    PEPM        * PROTOCOL ERROR IN XX. *
          LX6    59-17
          SA6    PEPM+3 
  
 PMB2     EQ     PMBX 
 PPI      SPACE  4,10 
**        PPI - PROCESS PID PARAMETER.
* 
*         PPI ACCEPTS THE PHYSICAL ID (*PID*) AND ENTERS IT IN THE
*         CORRELATION ACCOUNTING MESSAGE. 
* 
*         ENTRY  (TEXT) = *PID*.
* 
*         EXIT   (ALKA) = MODIFIED CORRELLATION ACCOUNTING MESSAGE
*                (X1) = ZERO. 
  
  
 PPI      SUBR               ENTRY/EXIT 
          SA2    TEXT 
          BX1    X1-X1
          MX6    18          SET PID MASK 
          SA3    ALKA+1 
          BX7    X6*X2       EXTRACT PID FROM TEXT
          LX6    12-42
          LX7    12-42       POSITION PID AND MASK
          BX6    -X6*X3 
          BX7    X6+X7       MERGE PID WITH MESSAGE 
          SA7    A3 
          EQ     PPIX        RETURN 
 PPX      SPACE  4,20 
**        PPX - PROCESS PASSWORD/PERMIT EXPIRATION DATE/TERM. 
* 
*         ENTRY  (B2) = COMMAND CODE. 
*                (XD) = EXPIRATION DATE (DISPLAY CODE). 
*                (XT) = EXPIRATION TERM (DISPLAY CODE). 
* 
*         EXIT   (X6) = 0, IF VALID PARAMETER.
*                     = ADDRESS OF ERROR MESSAGE, OTHERWISE.
* 
*         USES   X - 0, 1, 2, 3, 5, 6.
*                A - 1, 2, 3, 6.
*                B - 2, 3, 7. 
* 
*         CALLS  VDT. 
* 
*         MACROS PDATE. 
  
  
 PPX9     SX6    EARD        * PTFS - ERROR IN ARGUMENTS.*
  
 PPX      SUBR               ENTRY/EXIT 
          SA1    XT 
          SA2    XD 
          BX6    X6-X6       ASSUME NO ERROR
          BX3    X1+X2
          ZR     X3,PPXX     IF NEITHER *XD* NOR *XT* SPECIFIED 
          ZR     X1,PPX1     IF *XT* NOT SPECIFIED
          NZ     X2,PPX9     IF BOTH *XD* AND *XT* SPECIFIED
 PPX1     SB3    B2-CCCG
          ZR     B3,PPX2     IF *CHANGE* COMMAND
          SB3    B2-CCPM
          ZR     B3,PPX2     IF *PERMIT* COMMAND
  
*         EITHER A *SAVE* OR A *DEFINE* COMMAND WAS ISSUED WITH AN
*         *XD* OR AN *XT* SPECIFIED.  A PASSWORD MUST BE ENTERED
*         UNDER THESE CONDITIONS. 
  
          SA3    PW 
          ZR     X3,PPX9     IF *PW* NOT ENTERED
 PPX2     MX0    42 
          ZR     X2,PPX4     IF *XT* SPECIFIED RATHER THAN *XD* 
  
*         PROCESS EXPIRATION DATE.
  
          BX1    X0*X2
          SX2    B0+
          RJ     VDT         VERIFY DATE SPECIFIED
          NG     X1,PPX7     IF DATE ALREADY OCCURRED 
          NG     X6,PPX7     IF CONVERSION ERROR
 PPX3     SA1    NFN         SAVE EXPIRATION DATE/TERM
          ERRNZ  CFNF-CFXT   ERROR IF FIELD CHANGES 
          BX6    X1+X6       MERGE NEW VALUE
          SA6    A1 
          SX6    B0+         INDICATE NO ERROR
          EQ     PPXX        RETURN 
  
*         PROCESS EXPIRATION TERM.
  
 PPX4     BX1    X0*X1
          BX5    X1 
          LX1    -54
          SX2    X1-1R* 
          NZ     X2,PPX5     IF NOT NON-EXPIRING
          SX6    7777B
          EQ     PPX3        STORE NON-EXPIRING TERM
  
 PPX5     SX2    X1-1R0 
          NZ     X2,PPX6     IF NOT IMMEDIATELY EXPIRING
          PDATE  PPXA        SET *XT* = CURRENT DATE
          SA2    PPXA 
          AX2    18 
          BX6    X2 
          EQ     PPX3        SAVE CURRENT DATE
  
 PPX6     SB7    1           ASSUME DECIMAL BASE
          RJ     DXB         CONVERT DISPLAY CODE TO BINARY 
          NZ     X4,PPX7     IF CONVERSION ERROR
          SB2    X6-7777B 
          LE     B2,B0,PPX3  IF TERM DOES NOT EXCEED MAXIMUM
 PPX7     SX6    EXPD        * PTFS - ERROR IN EXPIRATION DATE.*
          EQ     PPXX        RETURN 
  
 PPXA     DATA   0           TEMPORARY STORAGE
 PRH      SPACE  4,10 
**        PRH - PROCESS REQUESTED HOST TYPE PARAMETER.
* 
*         PRH WILL SEND A REJECTION TO THE INITIATOR WITH AN
*         ERROR MESSAGE IF THE REQUESTED HOST TYPE IS NOT *NOS*.
*         IF THE REQUESTED TYPE IS *NOS* NO ACTION WILL BE TAKEN. 
* 
*         ENTRY  (TEXT) = REQUESTED HOST TYPE.
* 
*         EXIT   (RTYP) = NEGATIVE IF THE REQUESTED TYPE IS NOT *NOS* 
*                (DMSGE) = *HNSD* IF NOT *NOS*
*                (DMSGL) = *HNSDL* IF NOT *NOS* 
*                (X1) = ZERO. 
* 
*         USES   A - 1,2. 
*                B - NONE.
*                X - 1,2,6. 
* 
*         CALLS  RNE. 
  
  
 PRH1     SX6    HNSD        *PTFS - HOST NOT SPECIFIED TYPE.*
          RJ     RNE         FORCE REPLY NEGATAIVE WITH MESSAGE 
  
 PRH      SUBR               ENTRY/EXIT 
          SA1    TEXT 
          SA2    /CONSTANT/NS2
          BX6    X1-X2
          NZ     X6,PRH1     SEND REPLY NEGATIVE IF NOT *NOS* 
          MX1    0
          EQ     PRHX        EXIT WITH NO ERROR 
 PST      SPACE  4,10 
**        PST - PROCESS STATE OF TRANSFER.
* 
*         PST MOVES THE RECEIVED STATE OF TRANSFER TO *TSTA* IF 
*         *TSTA* DOES NOT ALREADY CONTAIN A VALUE.
* 
*         ENTRY  (TSTA) = ZERO IF NO ERRORS HAVE BEEN DETECTED
*                       = NON-ZERO IF ANY TRANSFER ERROR STATUS 
*                (TEXT) = RECEIVED STATE OF TRANSFER. 
* 
*         EXIT   (TSTA) = (TEXT) IF NO PREVIOUS ERROR AND (TEXT) IS 
*                         NOT *AASS* OR *TSCS*
*                (X1) = ZERO. 
* 
*         USES   A - 2,3,4,5,6. 
*                B - NONE.
*                X - 1,2,3,4,5,6. 
* 
*         CALLS  NONE.
  
  
 PST      SUBR               ENTRY/EXIT 
          SA4    AASS        *ACCEPTABLE AND SATISFACTORY*
          SA2    TSTA 
          SA3    TEXT        GET RECEIVED STATUS
          MX1    0
          BX4    X3-X4
          SA5    TSAC        *TERMINATED, SATISFACTORY AND COMPLETE*
          NZ     X2,PSTX     IF STATE ALREADY SET 
          BX5    X3-X5
          ZR     X4,PSTX     IF ACCEPTABLE STATUS 
          ZR     X5,PSTX     IF ACCEPTABLE STATUS 
          BX6    X3 
          SA6    A2          SET NEW STATE
          EQ     PSTX        RETURN 
 PUR      SPACE  4,10 
**        PUR - PROCESS USER REQUEST. 
* 
*         PUR PROCESSES THE USER TEXT PARAMETER.  DIFFERENT TABLES ARE
*         PROCESSED FOR PASS 1 AND PASS 2.  IN PASS 1, FILE TRANSFER
*         AND RECOVERY TEXT STATEMENTS ARE CHECKED, AND USER TEXT IS
*         CONCATENATED.  IN PASS 2, THE PROCESSOR FOR THE STATEMENT 
*         IS CALLED.
* 
*         ENTRY  (TEXT) = USER TEXT CONTROL CARD
*                (ARGR) = NON-ZERO IF PREVIOUS USER TEXT IN *RFT* 
*                       = ZERO IF FIRST USER TEXT IN CURRENT *RFT*. 
* 
*         EXIT   (RTYP) = NEGATIVE IF CONTROL CARD IS INVALID 
*                (TSTA) = TRANSFER STATE IF *RTYP* IS NEGATIVE
*                (X1) = ZERO
*                IF PASS 2, THE CONTROL CARD PROCESSOR
*                HAS BEEN CALLED. 
* 
*         USES   X - 1, 2, 3, 4, 5, 6, 7. 
*                A - 1, 2, 3, 4, 5, 6, 7. 
*                B - 2, 3, 7. 
* 
*         CALLS  CHF, CHI, CHP, EPT, GTL, RNE, UPC. 
* 
*         MACROS MESSAGE, WRITEC. 
  
  
 PUR8     SA2    RFTPASS
          NZ     X2,PUR9     IF PASS 2 THROUGH RFT
          SX6    ICCD        *PTFS - INVALID DIRECTIVE.*
          SA6    TMSGE
          WRITEC  TXTFILE,TEXT
          EQ     PUR11
  
 PUR9     WRITEC  DFMFILE,TEXTPFX 
          MESSAGE  TEXT,3,R 
          EQ     PUR11
  
 PUR10    RJ     RNE         SET REPLY NEGATIVE 
 PUR11    MX1    0
  
 PUR      SUBR               ENTRY/EXIT 
          SA1    RFTPASS
          NZ     X1,PUR6.1   IF PHASE 2 
          SA2    TMSGE
          NZ     X2,PUR11    IF  PREVIOUS TEXT ERROR THIS RFT 
          SX1    TEXT 
          RJ     =XGTL       GET TEXT LENGTH
          SA6    PURA 
          SA1    TEXTLTH
          IX2    X6+X1
          SX2    X2-TEXTMAX-1 
          NG     X2,PUR1     IF TEXT DOES NOT EXCEED MAX LENGTH 
          SX6    TSLD 
          SA6    TMSGE       TEXT ERROR = *DIRECTIVE TOO LONG.* 
          MX6    0
          SA6    TEXTLTH
          SA6    TXTCONT
          EQ     PUR11       EXIT 
  
 PUR1     SA1    PURA 
          RJ     CHI         GET CHARACTER INDEX
          SB2    TEXT+B2
          RJ     CHF         FETCH LAST CHARACTER OF TEXT 
          SX6    X6-CONTCHR 
          SA6    PURB        SAVE CURRENT CONTINUATION FLAG 
          SA2    TXTCONT
          NZ     X2,PUR3     IF PREVIOUS TEXT CONTINUED 
          NZ     X6,PUR6     IF CURRENT TEXT NOT CONTINUED
          MX6    -1 
          SA6    TXTCONT     SET TEXT CONTINUED FLAG
          MX7    -12
          SB2    B0 
 PUR2     SA4    TEXT+B2
          BX6    X4 
          SA6    PACKTXT+B2  MOVE TEXT TO PACKTXT 
          BX6    -X7*X6 
          SB2    B2+B1
          NZ     X6,PUR2     IF NOT END OF TEXT 
          SA5    PURA 
          BX6    X5 
          SA6    TEXTLTH     TEXT LTH = CURRENT TEXT LTH
          EQ     PUR11       EXIT 
  
 PUR3     SA1    TEXTLTH
          SX1    X1+B1
          RJ     CHI         GET CHARACTER INDEX
          SB3    PACKTXT+B2  CHARACTER PUT POINTERS 
          SX3    X2 
          SB2    TEXT        CHARACTER GET POINTERS 
          MX2    0
          SA1    PURA        LENGTH OF CURRENT TEXT, CHARACTERS 
          SA4    TEXTLTH
          IX6    X1+X4
          SA6    TEXTLTH     INCREMENT TEXT LENGTH
          SA6    A1          SAVE TEXT LENGTH 
 PUR4     RJ     CHF         APPEND CURRENT TO PREVIOUS TEXT
          RJ     CHP
          SX1    X1-1 
          NZ     X1,PUR4     IF MORE CHARACTERS TO MOVE 
          SA1    PURB 
          ZR     X1,PURX     IF CURRENT TEXT CONTINUED
          MX7    0
          SB2    9
 PUR5     SA5    PACKTXT-1+B2  MOVE PACKTXT TO TEXT 
          BX6    X5 
          SA6    TEXT-1+B2
          SA7    A5          CLEAR PACKTXT
          SB2    B2-B1
          NE     B2,B0,PUR5  IF MORE WORDS TO MOVE
          SA7    TXTCONT     CLEAR CONTINUATION FLAG
          SA7    TEXTLTH     CLEAR PREVIOUS TEXT LENGTH 
 PUR6     SA1    PURA        GET CHARACTER LENGTH 
          RJ     CHI         GET CHARACTER INDEX
          SX1    X2+B2
          NG     X1,PUR6.00  IF NO TEXT TO PROCESS
          SB2    TEXT+B2     SAVE CHARACTER GET POINTER 
          RJ     CHF         FETCH LAST CHARACTER 
          SX1    X6-1R. 
          ZR     X1,PUR6.0   IF LAST CHARACTER *.*
          SX1    X6-1R) 
          ZR     X1,PUR6.0   IF LAST CHARACTER *)*
          SA1    PURA 
          SX1    X1+B1
          RJ     CHI         GET CHARACTER INDEX
          BX3    X2 
          SB3    B2+TEXT     LWA OF TEXT
          SX6    1R.
          RJ     CHP         PUT *.* AS LAST CHARACTER
          BX6    X6-X6       ADD END OF LINE
          SA6    A7+B1
 PUR6.0   SA5    TEXT 
          RJ     CNL         CHECK FOR BLANK LINE 
          NZ     X1,PUR6.1   IF NOT NULL/BLANK LINE FOUND 
 PUR6.00  SA2    PUR         GET EXIT ADDRESS 
          SA3    PURF        GET TEXT FOUND FLAG
          MX6    0
          AX2    30 
          SB2    X2+0        RETURN ADDRESS 
          NZ     X3,PUR6.02  IF PREVIOUS VALID TEXT FOUND 
          SA4    VCCA 
          NZ     X4,PUR6.01  IF *USER* STATEMENT PROCESSED
          SA6    A2+0        CLEAR ENTRY POINT
          EQ     PUR6.02     EXIT 
  
 PUR6.01  SA4    NULL 
          BX6    X4 
          SA6    ACCESS      SET ACCESS MODE
 PUR6.02  BSS    0
          MX1    0
          JP     B2 
  
 PUR6.1   SA5    TEXT 
          SX6    B0+1 
          SA6    PURF        SET FLAG TO INDICATE TEXT FOUND
          SB7    ARGR 
          RJ     UPC         UNPACK CONTROL CARD TO PARAMETER AREA
          SA1    ARGR 
          SX6    B6-B1
          SX3    X1 
          SA6    ACTR        SET PARAMETER COUNT
          NZ     X3,PUR8     IF INVALID STATEMENT 
          BX6    X1 
          AX6    18          CONTROL CARD NAME
          SA2    RFTPASS
          NZ     X2,PUR7     IF PASS 2 OF RFT PROCESSING
          WRITEC  TXTFILE,TEXT   SAVE USER TEXT FOR PASS 2. 
          SA1    ARGR 
          SA2    VC1T 
          BX6    X1 
          SX1    ICCD+1      ASSUME INVALID DIRECTIVE 
          AX6    18 
          RJ     =XEPT       EXECUTE CONTROL STATEMENT PROCESSOR
  
*         IF *EPT* COULD NOT FIND A MATCHING VALID DIRECTIVE, CONTROL 
*         IS IMMEDIATELY RETURNED TO HERE WITH (X1) = NON-ZERO. 
*         OTHERWISE, *EPT* SIMULATES A RETURN JUMP TO THE ADDRESS OF
*         THE DIRECTIVE PROCESSOR, WHICH EVENTUALLY RETURNS HERE
*         WITH (X1) = 0.
  
          SB7    X1-ICCD-1
          ZR     B7,PUR7.2   IF INVALID DIRECTIVE 
          EQ     PURX        EXIT 
  
 PUR7     SA2    VCCT 
          SA1    VCCD        GET ERROR MESSAGE DEFAULT
          SX1    X1+B1
          RJ     =XEPT       EXECUTE CONTROL STATEMENT PROCESSOR
          ZR     X1,PURX     IF NO ERROR
          SA3    VCCB 
          NZ     X3,PUR7.1   IF *CHARGE* ALREADY PROCESSED
          SA4    VCCA 
          ZR     X4,PUR7.1   IF NO *USER* STATEMENT PROCESSED 
          SA3    =6LCHARGE
          SA2    ARGR 
          BX3    X3-X2
          AX3    24 
          ZR     X3,PUR7.1   IF *CHARGE* BEING PROCESSED
          SX6    B1+         SET INTERNAL DEFAULT CHARGE CALL FLAG
          SA6    VCCE 
          SA3    TEXT        SAVE FIRST 2 WORDS OF TEXT 
          SA4    TEXT+1 
          BX6    X3 
          BX7    X4 
          SA3    PURD        SET CHARGE STATEMENT IN TEXT 
          SA6    PURE 
          SA7    PURE+1 
          BX6    X3 
          SX7    B0 
          SA6    TEXT 
          SA7    TEXT+1 
          SA3    PURC+1      SET TO PROCESS DEFAULT CHARGE
          SA2    PURC 
          BX7    X3 
          BX6    X2 
          SA7    ARGR+1 
          SA6    ARGR 
          SX7    B1 
          AX6    18          CONTROL CARD NAME
          SA7    ACTR 
          SA2    VCCT 
          SA1    VCCD        GET ERROR MESSAGE DEFAULT
          SX1    X1+B1
          RJ     =XEPT       EXECUTE DEFAULT CHARGE 
          SA2    RTYP 
          NG     X2,PURX     IF ERROR 
          SA3    PURE        RESTORE TEXT 
          SA4    PURE+1 
          BX6    X3 
          BX7    X4 
          SA6    TEXT 
          SA7    TEXT+1 
          EQ     PUR6.1      EXECUTE *CHARGE* STATEMENT.
  
 PUR7.1   SX2    X1-ICCD-1
          SX6    X1-1 
          NZ     X2,PUR10    IF NOT INVALID CONTROL STATEMENT 
 PUR7.2   MESSAGE  TEXT,3,R 
          WRITEC  DFMFILE,TEXTPFX 
          SX6    ICCD 
          EQ     PUR10       REPLY NEGATIVE 
  
 PURA     BSS    1           LENGTH IN CHARACTERS OF CURRENT TEXT 
 PURB     BSS    1           0 IF CURRENT TEXT ENDS IN CONT. CHARACTER
 PURC     DATA   6LCHARGE 
          DATA   1L*
 PURD     DATA   9LCHARGE,*.
 PURE     BSS    2
 PURF     BSS    1           TEXT FLAG
          SPACE  4
**        RCS - RECOVERY CONTROL STATEMENT PROCESSING 
* 
*         RCS IS CALLED DURING PASS 1 PROCESSING OF RFT USER TEXT.
*         IF A FILE TRANSFER IS ALREADY REQUIRED, FORCE RNEG. 
* 
*         USES   A - 5, 6 
*                X - 5, 6 
  
  
 RCS      SUBR
          SA1    FXCT 
          ZR     X1,RCSX     IF NO FILE TRANSFERS YET REQUIRED
          SX6    RCSD 
          RJ     RNE         FORCE RNEG 
          EQ     RCSX        EXIT 
          SPACE  4
 RPPT     TITLE  COMMAND PARAMETER PROCESSOR TABLES.
**        RPPT - RFT COMMAND PARAMETER PROCESSOR ADDRESS TABLE. 
* 
**T,RPPT   42/ ATTR,18/ ADDR+1
* 
*         ADDR   - ADDRESS OF PARAMETER PROCESSOR.
*         ATTR   - VALUE OF ATTRIBUTE.
  
  
 RPPT     PADDRE ACKW,PAW    ACKNOWLEDGE WINDOW 
          PADDRE CONT,PCT    CONTINUATION TEXT
          PADDRE ECHO,PEP                                          ECHO 
          PADDRE FAC,PFA
          PADDRE HOSTT,=XPHT
          PADDRE ID,PID 
          PADDRE JOBN,=XPJN 
          PADDRE LID,PLD
          PADDRE MBZ,PMB
          PADDRE PID,PPI
          PADDRE RHOST,PRH
          PADDRE SIZE,EXI 
          PADDRE TMOUT,=XPTP
          PADDRE TYPE,=XPDP 
          PADDRE UTEXT,PUR
          BSSZ   1
 SPPT     SPACE  4,10 
**        SPPT - STOP COMMAND PARAMETER PROCESSOR ADDRESS TABLE.
* 
**T,SPPT   42/ ATTR,18/ ADDR+1
* 
*         ADDR   - ADDRESS OF PARAMETER PROCESSOR.
*         ATTR   - VALUE OF ATTRIBUTE.
  
  
 SPPT     PADDRE CONT,PCT 
          PADDRE DMSG,PDM 
          PADDRE OMSG,PDM 
          PADDRE STATE,PST
          BSSZ   1
 APP      TITLE  USER TEXT PROCESSORS.
**        APP - APPEND FILE PRE-PROCESSOR.
* 
*         APP DETERMINES IF THE APPEND OPERATION WILL SUCCEED BY CALLING
*         CATLIST TO CHECK THE FILE NAME.  IF CATLIST SHOWS THE FILE AS 
*         EITHER INDIRECT-ACCESS OR NON-EXISTENT, THE TRANSFER PROCEEDS.
*         OTHERWISE, APP RETURNS AN ERROR MESSAGE TO THE USER.
* 
*         ENTRY  (ARGR+1) = CONTROL CARD PARAMETER LIST.
* 
*         EXIT   (X1) = 0.
*                (RTYP) .LT. 0 IF FILE APPEND IS NOT POSSIBLE.
*                (ACCESS) = *TAKE* FILE TRANSFER IF APPEND IS POSSIBLE
*                (FUNC) = APPEND *PFM* FUNCTION (*CCAP*) IF NO ERROR
*                (XMIT) = *NETXFR* FILE RECEIVE (ZERO) IF NO ERROR
* 
*         USES   A - 1,2,6,7. 
*                B - 5. 
*                X - 1,2,6,7. 
* 
*         CALLS  CAT, RNE, SFP. 
  
  
 APP1     SX6    FNID        *PTFS - FILE IS DIRECT ACCESS.*
 APP2     RJ     RNE         SET REPLY NEGATIVE TO BE SENT
  
 APP      SUBR               ENTRY/EXIT 
          SB5    VGPT 
          RJ     SFP         SET FET PARAMETERS 
          NZ     X1,APP2     IF ERROR IN PARAMETER
          RJ     CAT         GET PERM FILE INFORMATION (CATLIST)
          ZR     X1,APP3     IF NO ERROR
          SX0    X0-/ERRMSG/FNF 
          ZR     X0,APP4     IF FILE NOT FOUND
          SX6    ERAD        *PTFS - ERROR MESSAGE RETURNED BY PFM.*
          EQ     APP2        RETURN WITH ERROR
  
 APP3     SA1    FB+FCBT     CHECK IF DIRECT ACCESS 
          LX1    59-11
          MI     X1,APP1     IF FILE IS DIRECT ACCESS 
 APP4     SA2    TAKE 
          MX7    0
          BX6    X2          SET MODE TO TAKE FILE
          SA7    XMIT 
          SA6    ACCESS 
          SX7    CCAP        SET APPEND *PFM* FUNCTION
          SA7    FUNC 
          BX1    X1-X1       CLEAR ERROR FLAG 
          EQ     APPX        RETURN 
 CHR      SPACE  4,10 
**        CHR - CHARGE CONTROL STATEMENT PROCESSOR. 
* 
*         THIS ROUTINE IS ENTERED TO PROCESS A *CHARGE* CONTROL 
*         STATEMENT.  THE CONTROL STATEMENT PARAMETERS ARE CHECKED TO 
*         DETERMINE VALIDITY.  THE ACTUAL PROCESSING OF THE CHARGE
*         AND PROJECT NUMBERS IS PERFORMED BY *CHG* IN COMMON DECK
*         *COMCCHG*.  ANY ERROR MESSAGE RETURNED IS SENT BACK TO THE
*         USER AND THE CHARGE REQUIRED FLAG IS NOT CLEARED. 
* 
*         ENTRY  (ARGR+1) = CHARGE CONTROL CARD PARAMETER LIST. 
*                (VCCE) .NE. 0 IF INTERNAL DEFAULT CHARGE CALL. 
*                (VCCF) = *AAWC* (USER VALIDATION WORD).
* 
*         EXIT   (X1) = 0.
*                (RNEG) .LT. 0 IF CHARGE NOT VALID. 
*                (ACCESS) = *NULL* TRANSFER IF NO ERROR DETECTED
*                (TSTA) = SATISFACTORY, REQUIRED (*ASRS*) IF NO ERROR 
*                (VCCD) = *ICCD* ERROR MESSAGE ADDRESS IF NO ERROR
*                (VCCE) = 0.
*                USER LIMITS ARE SET IN THE CONTROL POINT AREA. 
* 
*         USES   A - 1,2,3,4,6,7. 
*                B - 5. 
*                X - 1,2,3,4,6,7. 
* 
*         CALLS  CHG, RNE, VCP, CPM=. 
* 
*         MACROS MOVE, SETASL, SETJSL, SETTL. 
  
  
 CHR1     MOVE   5,B6,ERAD+1
          SX6    ERAD        *PTFS - ERROR MESSAGE RETURNED BY PFM.*
 CHR2     RJ     RNE         SET REPLY NEGATIVE 
  
 CHR      SUBR               ENTRY/EXIT 
          SA3    ARGR+1 
          SB5    VCPT 
          RJ     =XVCP       VALIDATE CHARGE PARAMETERS 
          BX7    X1 
          SA7    CHRA        SAVE ERROR INDICATOR 
          SA1    VCCE 
          NZ     X1,CHR0     IF INTERNAL DEFAULT CHARGE CALL
          MESSAGE  TEXT,3,R 
          WRITEC  DFMFILE,TEXTPFX 
 CHR0     SX6    B0+         CLEAR INTERNAL DEFAULT CHARGE CALL FLAG
          SA6    VCCE 
          SA1    CHRA 
          SX6    X1-1 
          NZ     X1,CHR2     IF ERROR IN PARAMETER
          SA1    CGN         CHECK CHARGE AND PROJECT NUMBERS 
          SA3    =1L* 
          BX3    X1-X3
          ZR     X3,CHR0.0   IF DEFAULT CHARGE SPECIFIED
          SA2    VCCF        CHECK USER VALIDATIONS 
          LX2    59-22       POSITION *CNRD*
          NG     X2,CHR0.1   IF CHARGE NOT RESTRICTED TO DEFAULT
          SX6    CRDD        * PTFS - CHARGE RESTRICTED TO DEFAULT.*
          SA2    DCI+2
          BX1    X1-X2
          NZ     X1,CHR2     IF NON-DEFAULT CHARGE SPECIFIED
          SA1    PRN
          SA2    DCI
          BX1    X1-X2
          NZ     X1,CHR2     IF NON-DEFAULT PROJECT SPECIFIED 
          SA1    A1+B1
          SA2    A2+B1
          BX1    X1-X2
          NZ     X1,CHR2     IF NON-DEFAULT PROJECT SPECIFIED 
          EQ     CHR0.1      PROCESS SPECIFIED CHARGE 
  
 CHR0.0   SA1    DCI         SET DEFAULT CHARGE AND PROJECT 
          SA2    A1+B1
          BX6    X1 
          BX7    X2 
          SA6    PRN
          SA7    A6+B1
          SA1    A2+B1
          BX6    X1 
          SA6    CGN
          NZ     X1,CHR0.1   IF DEFAULT CHARGE NUMBER DEFINED 
          MESSAGE CHRC+1,3,R  SEND MESSAGE
          WRITEC DFMFILE,CHRC 
          SA2    VCCF        CHECK *AAWC* FOR CHARGE-REQUIRED 
          SX6    CCRD        * PTFS - CHARGE REQUIRED * 
          LX2    59-7        POSITION *CCNR*
          PL     X2,CHR2     IF CHARGE REQUIRED 
          EQ     CHR0.3      SKIP VALIDATION
  
 CHR0.1   SX6    MCPD        *PTFS - MISSING CHARGE/PROJECT.* 
          SA1    CGN
          SA2    PRN
          ZR     X2,CHR2     IF PROJECT MISSING 
          ZR     X1,CHR2     IF CHARGE MISSING
          SX2    B0          CLEAR DEFAULT CHARGE FLAG
          NZ     X3,CHR0.2   IF NOT DEFAULT CHARGE
          SX2    B1          SET DEFAULT CHARGE FLAG
          SB2    1R?         SET DEFAULT CHARGE IN MESSAGE
          SB5    CHRB 
          SA1    CGN
          RJ     SNM
          SB2    1R!
          SA1    PRN
          RJ     SNM
          SB2    1R%
          SA1    PRN+1
          RJ     SNM
          MESSAGE  CHRB+1,3,R 
          WRITEC  DFMFILE,CHRB
 CHR0.2   SA3    DCI+3       USER NUMBER
          RJ     CHG         CALL CHARGE PROCESSOR
          NZ     B6,CHR1     IF ERROR IN CHARGE PROCESSING
          SA3    VCCC        CLEAR CHARGE REQUIRED
          BX6    X3 
          SA6    VCCB 
          SX7    ICCD        *PTFS - INVALID DIRECTIVE.*
          SA7    VCCD 
 CHR0.3   SA2    NULL 
          BX6    X2 
          SA6    ACCESS      SET NULL TRANSFER
          WRITEC ZZFILE,TEXT  SAVE RECOVERY TEXT
          MX1    0
          EQ     CHRX        RETURN 
  
 CHRA     BSS    1           VCP ERROR RETURN 
 CHRB     VFD    60/10L  PTFS  -       DEFAULT CHARGE AND PROJECT MESSAG
          VFD    60/10L*  CHARGE( 
          VFD    60/10L?????????? 
          VFD    60/10L,!!!!!!!!! 
          VFD    60/10L!%%%%%%%%% 
          VFD    60/2L%)
 CHRC     VFD    60/10L  PTFS  -
          VFD    60/10L* DEFAULT
          VFD    60/10LCHARGE IS
          VFD    60/5LNULL. 
 DDS      SPACE  4,10 
**        DDS - DROPDS COMMAND PROCESSOR. 
* 
*         DDS VALIDATES THE USER-SUPPLIED *DROPDS* COMMAND, 
*         AND PERFORMS THE DROPDS FUNCTION BY A CALL TO *PFM*.
*         DDS REPORTS ERRORS TO THE INITIATOR IN DAYFILE MESSAGES.
* 
*         ENTRY  (ARGR) = CONTROL CARD NAME AND PARAMETERS. 
* 
*         EXIT   (X1) = 0.
*                (RTYP) .LT. 0 IF ERROR IN COMMAND. 
*                (ACCESS) = *NULL* (NO TRANSFER) IF NO ERROR DETECTED 
* 
*         USES   A - 1,2,3,6,7. 
*                B - 5. 
*                X - 1,2,3,6,7. 
* 
*         CALLS  CFE, PFM=, RNE, SFP. 
  
  
 DDS3     SX6    ERAD        *PTFS - ERROR MESSAGE RETURNED BY PFM.*
 DDS4     RJ     RNE         FORCE REPLY NEGATIVE 
 DDS      SUBR               ENTRY/EXIT 
          SB5    VDDT 
          RJ     SFP         SET PARAMETERS IN FET
          NZ     X1,DDS4     IF PARAMETER ERROR 
 DDS2     SX2    F           FET ADDR 
          SX7    CCDD 
          RJ     =XPFM=      DROPDS/DROPIDS 
          RJ     CFE         CHECK PFM ERROR
          NG     X1,DDS3     IF ERROR 
          NZ     X1,DDS2     IF RETRY 
          SA2    NULL 
          BX6    X2 
          SA6    ACCESS 
          EQ     DDSX        RETURN 
 GIA      SPACE  4,10 
**        GIA - GET INDIRECT OR DIRECT ACCESS FILE. 
* 
*         GIA CHECKS THE USER SUPPLIED CONTROL CARD AND 
*         IF VALID ATTEMPTS TO GET THE FILE.  IF SUCCESSFUL THE 
*         TRANSFER MODE AND DIRECTION WILL BE SET FOR THE POSITIVE
*         REPLY.  IF THE GET FAILS AN ERROR MESSAGE WILL BE RETURNED
*         IN A REPLY NEGATIVE.
* 
*         ENTRY  (ARGR) = CONTROL CARD NAME AND PARAMETERS. 
* 
*         EXIT   (X1) = 0.
*                (RTYP) .LT. 0 IF ERROR IN COMMAND. 
*                (ACCESS) = *GIVE* TRANSFER IF NO ERROR DETECTED
*                (XMIT) = *NETXFR* FILE SEND (+1) IF NO ERROR 
* 
*         USES   A - 1,2,3,6,7. 
*                B - 5. 
*                X - 1,2,3,6,7. 
* 
*         CALLS  CFE, GFL, RNE, SFP, PFM=.
  
  
 GIA4     SX6    ERAD        *PTFS - ERROR MESSAGE RETURNED BY PFM.*
 GIA5     RJ     RNE         SET REPLY NEGATIVE 
  
 GIA      SUBR               ENTRY/EXIT 
          SB5    VAPT        SET ATTACH/GET PARAMETER TABLE 
          RJ     SFP         SET FET PARAMETERS 
          NZ     X1,GIA5     IF ERROR IN PARAMETER
 GIA1     SA3    RT 
          ZR     X3,GIA2     IF REAL-TIME PROCESSING NOT SELECTED 
          SA2    F+1         SET REAL-TIME REQUEST BIT
          SX1    B1+
          LX1    43-0 
          BX6    X1+X2
          SA6    A2+
 GIA2     SA1    ARGR 
          SX7    CCGT 
          MX2    3*6         CHECK IF GET 
          BX1    -X2*X1 
          ZR     X1,GIA3     IF GET FUNCTION
          SA1    PFN
          SX2    SRNF*10000B+PTRD+40B  MODE = READ ONLY, NO FAST ATTACH 
          BX6    X1+X2
          SA6    A1 
          SX7    CCAT        SET (ATTACH) FUNCTION
 GIA3     SX2    F
          RJ     =XPFM=      PERFORM THE FUNCTION 
          RJ     CFE         CHECK FOR FET ERROR
          MI     X1,GIA4     IF ERROR IN FET
          NZ     X1,GIA1     IF RETRY STATUS SET
          NZ     X2,GIA6     IF FILE ON MS AND STAGE INITIATED
          RJL    =XGFL,F,(DDXFR)   GET FILE LENGTH
          LX5    59-6        POSITION FILE STATUS (READ PERM) 
          SX6    EOFD        *PTFS - EXECUTE ONLY FILE.*
          MI     X7,GIA5     IF EXECUTE ONLY FILE 
          PL     X5,GIA5     IF NO READ PERMISSION
          SA2    GIVE 
          SX7    B1+         SET MODE OF TRANSFER TO SEND 
          MX1    0
          BX6    X2 
          SA7    XMIT 
          SA6    ACCESS      SET MODE OF ACCESS TO GIVE 
          EQ     GIAX        RETURN 
  
 GIA6     WRITEC  DFMFILE,STGM
          SA2    NULL 
          MX1    0
          BX6    X2 
          SA6    ACCESS      SET ACCESS MODE TO NULL
          EQ     GIAX 
 PCP      SPACE  4,10 
**        PCP - PERMIT/CHANGE PROCESSOR.
* 
*         PCP PROVIDES THE PERMIT AND CHANGE CONTROL STATEMENT
*         PROCESSES.  NO FILE TRANSFER IS REQUESTED.  ANY *PFM* 
*         ERROR RESPONSE IS RETURNED TO THE INITIATOR AS TYPE 
*         DAYFILE.
* 
*         ENTRY  (ARGR) = CONTROL CARD NAME AND PARAMETERS. 
* 
*         EXIT   (X1) = 0.
*                (RTYP) .LT. 0 IF ERROR IN REQUESTED CHANGE.
*                (ACCESS) = *NULL* TRANSFER IF NO ERROR.
* 
*         USES   X - 1, 2, 3, 6, 7. 
*                A - 1, 2, 3, 6, 7. 
*                B - 2, 5.
* 
*         CALLS  CFE, PFM=, PPX, RNE, SAC, SBP, SFP, SMC. 
  
  
 PCP6     SX6    ERAD        *PTFS - ERROR MESSAGE RETURNED BY PFM.*
 PCP7     RJ     RNE         FORCE REPLY NEGATIVE 
  
 PCP      SUBR               ENTRY/EXIT 
          SA1    ARGR 
          SX7    CCPM        SET PERMIT *PFM* FUNCTION
          SB5    VPPT        SET PERMIT VALID PARAMETER TABLE 
          LX1    59-58
          MI     X1,PCP1     IF PERMIT CONTROL STATEMENT
          SB5    VHPT        SET CHANGE VALID PARAMETER TABLE 
          SX7    CCCG        SET CHANGE *PFM* FUNCTION
 PCP1     SA7    FUNC        SAVE *PFM* FUNCTION CODE 
          RJ     SFP         SET FET PARAMETERS 
          NZ     X1,PCP7     IF ERROR IN PARAMETER
          SA1    FUNC        CHECK FUNCTION 
          SX1    X1-CCPM     (X1 = 0 IF *PERMIT*) 
          RJ     SMC         SET MODE AND CATEGORY
          NZ     X1,PCP7     IF ERROR IN MODE OR CATEGORY 
          RJ     SBP         SET BACKUP AND PREFERRED RESIDENCE 
          NZ     X1,PCP7     IF ERROR IN BACKUP OR RESIDENCE
          RJ     SAC         SET ALTERNATE CATLIST PERMISSION 
          NZ     X1,PCP7     IF ERROR IN ALTERNATE CATLIST PERMISSION 
          SA2    CE 
          SA3    CP 
          SA1    F+CFPN      SET SPECIAL REQUEST FIELD
          ZR     X2,PCP2     IF CLEAR ERROR FLAG NOT SET
          ZR     X3,PCP1.1   IF RESET CHARGE/PROJECT NOT SET
          SX6    CPED        *PTFS - CE AND CP ARE MUTUALLY EXCLUSIVE.* 
          EQ     PCP7        PROCESS ERROR
  
 PCP1.1   SX2    SRCE*10000B *CLEAR ERROR* SPECIAL REQUEST
          EQ     PCP2.1      CONTINUE 
  
 PCP2     ZR     X3,PCP2.2   IF RESET CHARGE/PROJECT NOT SET
          SX2    SRCP*10000B *RESET CHARGE/PROJECT* SPECIAL REQUEST 
 PCP2.1   IX6    X1+X2       SET SPECIAL REQUEST
          SA6    A1 
 PCP2.2   SA2    OFN         CHECK IF *NFN=OFN* CHANGE
          SA3    PFN
          ZR     X2,PCP3     IF NO NEW FILE NAME GIVEN
          MX7    -18
          BX6    -X7*X3 
          BX6    X6+X2       MERGE IN THE OFN 
          SA6    A3+         SET OLD FILE NAME AS *PFN* 
          BX7    X7*X3
          SA7    NFN         SET NEW FILE NAME
 PCP3     SA1    FUNC        GET FUNCTION 
          SB2    X1+
          RJ     PPX         PROCESS PASSWORD/PERMIT EXPIRATION DATE
          NZ     X6,PCP7     IF INCORRECT EXPIRATION DATE/TERM
          SA3    PW          CHECK IF PASSWORD CHANGED
          MX6    42 
          BX7    X6*X3       EXTRACT PASSWORD 
          BX6    X3+X6       SET PASSWORD UNCHANGED 
          ZR     X7,PCP4     IF PASSWORD UNCHANGED
          BX6    X3-X7       SET PASSWORD CLEARED 
          SX3    1R0
          LX7    5-59 
          BX7    X3-X7
 PCP4     NZ     X7,PCP5     IF PASSWORD CHANGED
          SA6    PW          SET PASSWORD UNCHANGED/CLEARED 
 PCP5     SA1    FUNC        GET FUNCTION CODE
          SX2    F           SET FET ADDRESS
          SX7    X1 
          RJ     =XPFM=      MAKE THE *PFM* REQUEST 
          RJ     CFE         CHECK FET FOR ERROR RETURN 
          MI     X1,PCP6     IF ERROR IN FET
          NZ     X1,PCP5     IF RETRY REQUESTED 
          SA2    NULL 
          BX6    X2 
          SA6    ACCESS      SET NULL FILE TRANSFER 
          EQ     PCPX        RETURN 
 PKN      SPACE  4,25 
**        PKN - PROCESS PACKNAM CONTROL STATEMENT.
* 
*         PKN ISSUES THE *CPM* FUNCTION TO SET THE DEFAULT
*         PACKNAME IN THE CONTROL POINT AREA.  THE DEFAULT
*         PACKNAME CAN BE CLEARED BY NOT INCLUDING ONE ON THE 
*         *PACKNAM* CONTROL STATEMENT.
* 
*         ENTRY  (ARGR+1) = CONTROL CARD PARAMETERS.
* 
*         EXIT   (X1) = 0.
*                (RTYP) .LT. 0 IF PARAMETER ERROR DETECTED. 
*                (ACCESS) = *NULL* TRANSFER IF NO ERROR 
*                THE PACKNAME IS SET AS THE DEFAULT PACKNAME. 
* 
*         USES   X - 0, 1, 2, 3, 6, 7.
*                A - 1, 2, 3, 6, 7. 
*                B - 5. 
* 
*         CALLS  RNE, VCP.
* 
*         MACROS MESSAGE, PACKNAM, WRITEC.
  
  
 PKN4     SX6    X1-1        *PTFS - INVALID XXXXXXX.*
 PKN5     RJ     RNE         SET REPLY NEGATIVE WITH ERROR
  
 PKN      SUBR               ENTRY/EXIT 
          SA3    ARGR+1 
          SB5    VKPT 
          RJ     =XVCP       VALIDATE PACKNAM PARAMETERS
          BX7    X1 
          SA7    PKNA 
          MESSAGE  TEXT,3,R 
          WRITEC  DFMFILE,TEXTPFX 
          SA1    PKNA 
          SA2    PN          GET *PN* PARAMETER 
          NZ     X1,PKN4     IF ERROR IN PARAMETERS 
          SX1    ICCD+1 
          SA3    PACK        GET PACKNAM PARAMETER
          ZR     X2,PKN0.1   IF NO *PN=* PARAMETER
          NZ     X3,PKN4     IF BOTH *PACKNAM* AND *PN=* SPECIFIED
          BX3    X2 
 PKN0.1   ZR     X3,PKN3     IF NO *PACKNAM* PARAMETER
          SX2    1R0
          MX6    0
          LX2    -6 
          SA6    A3          CLEAR *PACK* 
          BX2    X2-X3
          ZR     X2,PKN3     IF *PACKNAM* = *0* 
          SA2    R           GET *R=* PARAMETER 
          ZR     X2,PKN2     IF DEVICE TYPE NOT SPECIFIED 
          SX6    IDSD        *PTFS - INVALID DEVICE SPECIFICATION.* 
          SX0    77B
          LX2    18 
          BX7    X0*X2
          ZR     X7,PKN1     IF TWO CHARACTER DEVICE TYPE 
          SX1    X7-1R1 
          NG     X1,PKN5     IF NOT A DIGIT 1-8 
          SX1    X1+1R1-1R9 
          PL     X1,PKN5     IF NOT A DIGIT 1-8 
          EQ     PKN2        MERGE PACKNAME AND DEVICE TYPE 
  
 PKN1     SX7    1R1         ADD *1* TO TWO CHARACTER DEVICE TYPE 
          BX2    X2+X7
 PKN2     BX6    X2+X3       COMBINE *PN* WITH *R*
          SA6    PACK 
 PKN3     PACKNAM  PACK      SET DEFAULT PACKNAME 
          SA2    NULL 
          BX6    X2 
          SA6    ACCESS      SET TRANSFER MODE TO *NULL*
          MX1    0
          EQ     PKNX        RETURN 
  
 PKNA     BSS    1           *VCP* ERROR MESSAGE ADDRESS
 PRG      SPACE  4,10 
**        PRG - PURGE FILE PROCESSOR. 
* 
*         PRG WILL PURGE THE SPECIFIED FILE AND WILL RETURN ANY 
*         ERROR MESSAGE OR THE COMPLETED MESSAGE.  NO FILE
*         TRANSFER IS REQUIRED.  THE NO ABORT (*NA*) OPTION IS
*         USED TO PURGE FILES ON PRIVATE PACKS WHICH MAY OR MAY 
*         NOT BE MOUNTED. 
* 
*         ENTRY  (ARGR+1) = PURGE CONTROL CARD PARAMETERS.
* 
*         EXIT   (X1) = 0.
*                (RTYP) .LT. 0 IF ERROR IN REQUESTED PURGE. 
*                (ACCESS) = *NULL* TRANSFER IF NO ERROR DETECTED
*                THE REQUESTED FILE IS PURGED IF NO ERROR.
* 
*         USES   A - 2,6. 
*                B - 5. 
*                X - 2,6. 
* 
*         CALLS  CFE, RNE, SFP. 
* 
*         MACROS PURGE. 
  
  
 PRG2     SX6    ERAD        *PTFS - ERROR MESSAGE RETURNED BY PFM.*
 PRG3     RJ     RNE         SET REPLY NEGATIVE 
  
  
 PRG      SUBR               ENTRY/EXIT 
          SB5    VGPT        SET VALID PARAMETER TABLE
          RJ     SFP         SET FET PARAMETERS 
          NZ     X1,PRG3     IF ERROR IN PARAMETER
 PRG1     PURGE  F
          RJ     CFE         CHECK FET FOR ERROR
          MI     X1,PRG2     IF ERROR IS PRESENT
          NZ     X1,PRG1     IF RETRY STATUS IS SET 
          SA2    NULL 
          BX6    X2 
          SA6    ACCESS      SET ACCESS MODE TO NULL
          EQ     PRGX        RETURN 
 RPL      SPACE  4,10 
**        RPL - REPLACE FILE PRE-PROCESSOR. 
* 
*         RPL DETERMINES IF THE REPLACE OPERATION WILL BE SUCCESSFUL
*         BY TESTING IF A DIRECT ACCESS FILE ALREADY EXISTS.  IF NO 
*         FILE OR AN INDIRECT ACCESS FILE EXISTS A REPLY POSITIVE 
*         WILL BE RETURNED.  OTHERWISE AN ERROR MESSAGE WILL BE 
*         RETURNED TO THE USER. 
* 
*         ENTRY  (ARGR+1) = CONTROL CARD PARAMETERS.
* 
*         EXIT   (X1) = 0.
*                (RTYP) .LT. 0 IF ERROR IN REQUESTED REPLACE. 
*                (ACCESS) = *TAKE* TRANSFER IF NO ERROR DETECTED
*                (FUNC) = *PFM* REPLACE FUNCTION (*CCRP*) IF NO ERROR 
*                (XMIT) = *NETXFR* RECEIVE FILE TRANSFER (ZERO).
* 
*         USES   A - 1,2,6,7. 
*                B - 5. 
*                X - 1,2,6,7. 
* 
*         CALLS  CAT, RNE, SFP, SMC.
  
  
 RPL1     SX6    FNID        *PTFS - FILE IS DIRECT ACCESS.*
 RPL2     RJ     RNE         FORCE REPLY NEGATIVE 
  
 RPL      SUBR               ENTRY/EXIT 
          SB5    VRPT 
          RJ     SFP         SET FET PARAMETERS 
          NZ     X1,RPL2     IF AN ERROR IN PARAMETER 
          RJ     CAT         GET PERM FILE INFORMATION (CATLIST)
          ZR     X1,RPL4     IF NO ERROR
          SX0    X0-/ERRMSG/FNF 
          NZ     X0,RPL3     IF NOT FILE-NOT-FOUND (ERROR)
          MX1    0
          RJ     SMC         SET MODE AND CATEGORY
          ZR     X1,RPL5     IF NO ERROR
 RPL3     SX6    ERAD        *PTFS - ERROR MESSAGE RETURNED BY PFM.*
          EQ     RPL2        IF ERROR AND NO RETRY
 RPL4     SA1    FB+FCBT     CHECK IF FILE IS DIRECT ACCESS 
          LX1    59-11
          MI     X1,RPL1     IF FILE IS DIRECT ACCESS 
 RPL5     SA2    TAKE 
          MX7    0
          BX6    X2 
          SA7    XMIT 
          SA6    ACCESS      SET *TAKE* TRANSFER
          SX7    CCRP 
          SA7    FUNC        SET REPLACE FUNCTION 
          SX1    B0+
          EQ     RPLX        EXIT WITH NO ERROR 
 SDP      SPACE  4,10 
**        SDP - DEFINE PRE-PROCESSOR. 
* 
*         SDP SETS THE FET PARAMETERS FOR THE FILE *DEFINE* 
*         FUNCTION.  THE EXISTENCE OF A PERMANENT FILE WITH THE 
*         SAME NAME IS CHECKED.  IF THE FILE IS NOT ALREADY 
*         PERMANENT A *PFM* ASSIGNPF FUNCTION IS ISSUED TO
*         ASSIGN THE LOCAL FILE TO A DEVICE WHICH FILES CAN 
*         BE DEFINED UNDER. 
* 
*         ENTRY  (ARGR+1) = CONTROL CARD PARAMETER LIST.
* 
*         EXIT   (X1) = 0.
*                (RTYP) .LT. 0 IF *RNEG* TO BE RETURNED.
*                (ACCESS) = *TAKE* TRANSFER, IF NO ERROR DETECTED.
*                (FUNC) = *PFM* DEFINE FUNCTION (*CCDF*), IF NO ERROR.
*                (XMIT) = *NETXFR* RECEIVE FILE (ZERO) IF NO ERROR. 
* 
*         USES   X - 1, 2, 6, 7.
*                A - 1, 6, 7. 
*                B - 2, 5.
* 
*         CALLS  CAT, CFE, PAL, PFM=, PPX, RNE, SAC, SBP, SFP, SMC. 
  
  
 SDP2     SX6    ERAD        *PTFS - ERROR MESSAGE RETURNED BY PFM.*
 SDP3     RJ     RNE         SET NEGATIVE REPLY 
  
 SDP      SUBR               ENTRY/EXIT 
          SB5    VDPT 
          RJ     SFP         SET *DEFINE* PARAMETERS
          NZ     X1,SDP3     IF ERROR IN PARAMETER
          RJ     PAL         PROCESS ACCESS LEVEL 
          NZ     X6,SDP3     IF INCORRECT ACCESS LEVEL
          SB2    CCDF 
          RJ     PPX         PROCESS PASSWORD/PERMIT EXPIRATION DATE
          NZ     X6,SDP3     IF INCORRECT EXPIRATION DATE/TERM
          RJ     CAT         GET PERM FILE INFORMATION (CATLIST)
          SX6    FAPD        *PTFS - FILE ALREADY PERMANENT.* 
          ZR     X1,SDP3     IF NO ERROR - FILE FOUND 
          SX1    X0-/ERRMSG/FNF 
          NZ     X1,SDP2     IF NOT FILE NOT FOUND - ERROR
          SA1    F+CFCT      SET SPECIAL REQUEST WORD 
          SX7    SRSY*1S12
          BX7    X1+X7
          SA7    A1          *PFM* TO SET SYSTEM SECTOR 
 SDP1     SX2    F
          SX7    CCAN 
          RJ     =XPFM=      MAKE *PFM* FUNCTION REQUEST
          RJ     CFE         CHECK FET FOR ERROR
          MI     X1,SDP2     IF ERROR IN FET
          NZ     X1,SDP1     IF RETRY FUNCTION SET
*                            (X1 = 0 FOR *SMC*) 
          RJ     SMC         SET MODE AND CATEGORY
          NZ     X1,SDP3     IF ERROR IN PARAMETER
          RJ     SBP         SET BACKUP AND PREFERRED RESIDENCE 
          NZ     X1,SDP3     IF ERROR IN PARAMETER
          RJ     SAC         SET ALTERNATE CATLIST PERMISSION 
          NZ     X1,SDP3     IF ERROR IN PARAMETER
          SA2    TAKE 
          MX7    0
          BX6    X2 
          SA7    XMIT        SET TRANSFER DIRECTION 
          SA6    ACCESS      SET MODE OF ACCESS TO TAKE 
          SX7    CCDF 
          SA7    FUNC        SET *PFM* DEFINE FUNCTION
          SX1    B0+         SET NO ERROR 
          EQ     SDPX        RETURN 
 SIA      SPACE  4,10 
**        SIA - APPEND, REPLACE, SAVE, DEFINE, POST-PROCESSOR.
* 
*         SIA PERFORMS THE *PFM* FUNCTION SET UP BY A PRE-PROCESSOR.
*         THE FILE TRANSFER HAS BEEN COMPLETED NORMALLY.  IF THE
*         FUNCTION RETURNS AN ERROR RESPONCE IT IS SENT BACK TO THE 
*         INITIATOR.
* 
*         ENTRY  THE *STOP* COMMAND WAS RECEIVED AND THE FILE 
*                TRANSFER COMPLETED NORMALLY ON BOTH SIDES. 
* 
*         EXIT   (TSTA) = STATUS OF THE SAVE OPERATION
*                DMSGE = ADDRESS OF THE ERROR OR COMPLETE MESSAGE 
*                DMSGL = LENGTH OF THE DAYFILE MESSAGE. 
* 
*         USES   A - 1. 
*                B - NONE.
*                X - 1,2,6,7. 
* 
*         CALLS  CFE, RNE, RPC, PFM=. 
  
  
 SIA2     SX6    ERAD        *PTFS - ERROR MESSAGE RETURNED BY PFM.*
          RJ     RNE         FORCE *STOPR* TO BE NEGATIVE 
  
 SIA      SUBR               ENTRY/EXIT 
 SIA1     SA1    FUNC        GET *PFM* FUNCTON
          SX2    F
          BX7    X1 
          RJ     =XPFM=      PERFORM THE FUNCTION 
          RJ     CFE         CHECK FOR *FET* ERROR
          MI     X1,SIA2     IF ERROR IS PRESENT
          NZ     X1,SIA1     IF RETRY STATUS IS SET 
          RJ     RPC         SET *STOPR* NORMAL AND COMPLETE
          EQ     SIAX        RETURN 
 SIP      SPACE  4,10 
**        SIP - SAVE PRE-PROCESSOR. 
* 
*         SIP SETS *FET* PARAMETERS FOR SUBSEQUENT SAVE PROCESSING. 
*         THE EXISTENCE OF A SAME NAMED FILE IS CHECKED AND THE 
*         FILE LENGTH CHECKED FOR ZERO.  THE ACTUAL SAVE FUNCTION 
*         WILL NOT BE DONE UNTIL THE *STOP* COMMAND IS RECEIVED.
* 
*         ENTRY  (ARGR+1) = CONTROL CARD PARAMETER LIST.
* 
*         EXIT   (X1) = 0.
*                (RTYP) .LT. 0 IF *RNEG* RESPONSE TO BE RETURNED. 
*                (ACCESS) = *TAKE* TRANSFER, IF NO ERROR DETECTED.
*                (FUNC) = *PFM* SAVE FUNCTION (*CCSV*), IF NO ERROR.
*                (XMIT) = *NETXFR* RECEIVE FILE (ZERO) IF NO ERROR. 
* 
*         USES   X - 1, 2, 6, 7.
*                A - 1, 2, 6, 7.
*                B - 2, 5.
* 
*         CALLS  CAT, PAL, PPX, RNE, SAC, SBP, SFP, SMC.
  
  
 SIP2     RJ     RNE         SET REPLY NEGATIVE 
  
 SIP      SUBR               ENTRY/EXIT 
          SB5    VSPT        SET VALID PARAMETER TABLE ADDRESS
          RJ     SFP         SET FET PARAMETERS 
          NZ     X1,SIP2     IF ERROR IN PARAMETER
          RJ     PAL         PROCESS ACCESS LEVEL 
          NZ     X6,SIP2     IF INCORRECT ACCESS LEVEL
          SB2    CCSV 
          RJ     PPX         PROCESS PASSWORD/PERMIT EXPIRATION DATE
          NZ     X6,SIP2     IF INCORRECT EXPIRATION DATE/TERM
          RJ     CAT         GET PERM FILE INFORMATION (CATLIST)
          SX6    FAPD        *PTFS - FILE ALREADY PERMANENT.* 
          ZR     X1,SIP2     IF NO ERROR - FILE FOUND 
          SX1    X0-/ERRMSG/FNF 
          SX6    ERAD        *PTFS - ERROR MESSAGE RETURNED BY PFM.*
          NZ     X1,SIP2     IF NOT FILE NOT FOUND
*                            (X1 = 0 FOR *SMC*) 
          RJ     SMC         SET MODE AND CATEGORY
          NZ     X1,SIP2     IF ERROR IN  PARAMETER 
          RJ     SBP         SET BACKUP AND PREFERRED RESIDENCE 
          NZ     X1,SIP2     IF ERROR IN PARAMETER
          RJ     SAC         SET ALTERNATE CATLIST PERMISSION 
          NZ     X1,SIP2     IF ERROR IN PARAMETER
          SA2    TAKE 
          MX7    0
          BX6    X2 
          SA7    XMIT        SET TRANSFER DIRECTION FOR *NETXFR*
          SA6    ACCESS      SET MODE OF ACCESS TO TAKE 
          SX7    CCSV 
          SA7    FUNC        SET SAVE *PFM* FUNCTION
          SX1    B0+         SET NO ERROR 
          EQ     SIPX        RETURN 
 USR      SPACE  4,10 
**        USR - USER CARD PROCESSOR.
* 
*         ROUTINE TO PROCESS THE USER CARD AS SUPPORTED 
*         BY *NOS*.  THIS ROUTINE DETERMINES IF A USER CARD 
*         IS VALID (NO PREVIOUS USER CARD OR SECONDARY USER 
*         CARDS ARE ENABLED).  THE USER CARD IS PROCESSED BY
*         A *CPM* FUNCTION.  THE CHARGE REQUIRED AND VALIDITY 
*         ARE STORED FOR SUBSEQUENT *RPOS* OR *RNEG* REPLY. 
*         IF THE CARD WAS VALID THEN THE USER PERMISSIONS 
*         ARE ALSO SET IN THE CONTROL POINT AREA. 
* 
*         ENTRY  (ARGR+1) = USER CARD PARAMETER LIST. 
* 
*         EXIT   (X1) = 0 IF NO ERROR DETECTED. 
*                (X1) = ERROR MESSAGE ADDRESS + 1, IF ERROR DETECTED. 
*                (RTYP) .LT. 0 IF ERROR DETECTED. 
*                (ACCESS) = *NULL* TRANSFER IF NO ERROR DETECTED
*                (TSTA) = SATISFACTORY, REQUIRED (*ASRS*) IF NO ERROR 
*                       = ERROR STATUS IF A *RNEG* IS TO BE RETURNED. 
*                (VCCF) = *AAWC* (USER VALIDATION WORD).
* 
*         USES   A - 1,2,3,4,5,6,7. 
*                B - 2,3,5. 
*                X - 1,2,3,4,5,6,7. 
* 
*         CALLS  VCP, CPM=, SNM.
* 
*         MACROS MESSAGE, SETASL, SETJSL, SETPFP, SETTL, SYSTEM, VALID. 
  
  
 USR5     BX7    X2 
          SA7    TSTA 
          BX6    X1 
          SA6    USRF 
          WRITEC  DFMFILE,X1
          SA1    USRF 
          SX1    X1+B1
          MESSAGE  X1,3,R 
          MX1    0
          MX6    -1 
          SA6    RTYP 
  
 USR      SUBR               ENTRY/EXIT 
          SA3    ARGR+1 
          SB5    VUPT 
          RJ     =XVCP       VALIDATE CONTROL CARD PARAMETERS 
          BX7    X1 
          SA7    USRF        SAVE VCP RETURN
          SA4    USRE        SET UP ARGUMENTS TO RSP
          SA5    TEXT 
          SB2    0
          SB6    USRD 
          MOVE   TEXTMAX/10+1,TEXT,TEXT+TEXTMAX/10+1
          RJ     RSP         REMOVE SECURE PARAMETERS FROM CONTROL STMT 
          MESSAGE  TEXT,3,R 
          WRITEC  DFMFILE,TEXTPFX 
          SA1    USRF 
          SA3    USERNUM
          NZ     X1,USRX     IF ERROR IN PARAMETERS 
          SX1    MUND+1      *MISSING USER NUMBER.* 
          ZR     X3,USRX     IF NO USER NUMBER SPECIFIED
          SA1    USRB        CHECK IF SECONDARY USER CARD 
          MX6    -1          READ *SSTL* FROM *CMR* 
          SA6    A1 
          ZR     X1,USR1     IF FIRST USER CARD 
          SYSTEM RSB,R,USRA,0 
          SA3    USRB        CHECK IF SECONDARY USER CARDS ALLOWED
          SA2    UPIS        *USERNUM/PASSWRD INCORRECT*
          SX1    SUCD+1      SECONDARY USER NOT ALLOW 
          SX7    SUCDL
          SA7    A3          SET USER CARD PROCESSED
          LX3    59-40
          NG     X3,USRX     IF SECONDARY USER NOT ALLOWED
          SA1    ACUA        *ACUN, XXXXXXX, YYYYYYY.*
          BX6    X1 
          SA6    ABUA 
 USR1     SA1    VUBP+1      FORCE VALIDATION FROM VALIDUS, NO ABORT
          SX3    6
          BX6    X1+X3
          SA6    A1 
          VALID  VUBP        GET USER ACCESS WORDS
          SA1    VUBP+7      SAVE DEFAULT CHARGE INFORMATION
          SA2    A1+B1
          SA3    A2+B1
          BX6    X1 
          BX7    X2 
          SA6    DCI
          SA7    A6+B1
          BX6    X3 
          SA6    A7+B1
          SA3    VUBP 
          BX7    X3 
          SA7    DCI+3
          SX1    IAVD        *PTFS - INVALID ACCESS VALIDATION.*
          SA4    A3+2 
          SX3    X3+
          SA2    UPIS        *USERNUM/PASSWRD INCORRECT*
          ZR     X3,USR5     IF USER NOT VALID
          SA5    VUBP+5 
          SA2    RSTS        *REJECTED - SEE TEXT*
          BX7    X5          VUBP+5 = *AAWC* (USER VALIDATION WORD) 
          LX4    59-1        CHECK SECURITY COUNT EXHAUSTED FLAG
          LX5    59-15       CHECK *AAWC* FOR LINK VALIDATION 
          NG     X4,USR5     IF SECURITY COUNT IS ZERO
          PL     X5,USR5     IF NOT ALLOWED TO USE LINK 
          SA7    VCCF        SAVE *AAWC* FOR CHARGE PROCESSING
          SA4    VCCC+1      SELECT *CHARGE* ALLOWED
          BX7    X4 
          SA7    VCCA 
          SA1    VCCC 
          LX5    59-59+15-7 
          BX6    X1 
          SA6    VCCA+1 
          SX7    ICCD        *PTFS - INVALID DIRECTIVE.*
          MI     X5,USR3     IF CHARGE NOT REQUIRED 
          SX6    B0 
          SX7    CCRD        *PTFS - CHARGE REQUIRED.*
 USR3     SA7    VCCD        SET NEW MESSAGE RETURNED 
          SA4    VUBP+2 
          SA6    VCCB        SET/CLEAR CHARGE REQUIRED
          MX7    42 
          BX4    X7*X4       EXTRACT FAMILY NAME
          SX2    13B         SET FAMILY,USER NUMBER,INDEX 
          BX6    X2+X4
          SA6    VPFP 
          SETPFP VPFP        SET PERMANENT FILE PARAMETERS
          SX2    115B        SET USER ACCESS FROM *VALID* BLOCK 
          SX1    VUBP+3 
          RJ     =XCPM=      CALL *CPM* TO UPDATE *CPA* 
          SETTL  77770B 
          SA1    USERNUM     SET USERNUMBER IN MESSAGE
          SB2    1R@
          SB3    USRC        SET MESSAGE RETURN AREA
          SB5    -ABUA       *ABUN, XXXXXXX, YYYYYYY.*
          MX5    42 
          BX1    X5*X1
          RJ     SNM         SET NAME IN MESSAGE
          SA1    FAMILY 
          SB2    1R\
          SB5    USRC        SET MESSAGE ADDRESS
          BX1    X5*X1
          RJ     SNM         SET FAMILY NAME IN MESSAGE 
          MESSAGE  B5,5,R    ISSUE ACCOUNT FILE MESSAGE 
          SA1    USRB 
          SX1    X1-SUCDL 
          ZR     X1,USR3.1   IF SECONDARY USER COMMAND
          SA1    DCI+2       GET DEFAULT CHARGE NUMBER
          ZR     X1,USR3.1   IF DEFAULT CHARGE NULL 
          SB2    1R?         SET CHARGE NUMBER IN MESSAGE 
          SB5    ABIC        *ABIC, ??????????, !!!!!!!!!!%%%%%%%%%%.*
          RJ     SNM
          SA1    DCI         SET FIRST PART OF PROJECT NUMBER 
          SB2    1R!
          RJ     SNM
          SA1    DCI+1       SET SECOND PART OF PROJECT NUMBER
          SB2    1R%
          RJ     SNM
          MESSAGE  B5,5,R    ISSUE ACCOUNT FILE MESSAGE 
 USR3.1   SA2    NULL 
          BX6    X2 
          SA6    ACCESS      SET NO TRANSFER REQUIRED 
          MX6    29 
          MX7    0
          SA7    USRC 
          SA6    USRC+1 
          MEMORY  CM,USRC,R  GET CURRENT FL 
          MEMORY  CM,USRC+1,R  GET MAX. VALIDATED FL
          SA2    USRC 
          MX4    30 
          SA3    USRC+1 
          LX2    30 
          LX3    30 
          BX2    -X4*X2 
          BX3    -X4*X3 
          SX4    NTLMAX+2 
          IX2    X2+X4       ALLOW ROOM FOR *NETPUT* BUFFER 
          IX3    X3-X2
          PL     X3,USR4     IF CURRENT + DELTA .LT. MAX VALIDATED
          SX1    FTSD 
          SA2    RSTS        *REJECTED, SEE TEXT* 
          MX7    0
          SA7    VCCA        REQUIRE USER CARD NEXT 
          EQ     USR5        SKIP RETURNING BAD USER CARD 
  
 USR4     WRITEC ZZFILE,TEXT+TEXTMAX/10+1  SAVE RECOVERY TEXT 
          MX1    0
          EQ     USRX        RETURN 
  
 USRA     VFD    12/0,12/1,18/SSTL,18/USRB
 USRB     BSSZ   1           *SSTL* WORD AND FIRST USER FLAG
 USRC     BSS    4           ACCOUNT FILE MESSAGE BUILD AREA
 USRD     BSS    0           TABLE OF KEYWORD/POSITIONS TO REMOVE 
          CON    2           PASSWORD IN ARGUMENT 2 
          CON    0           END OF TABLE 
 USRE     BSS    0           ARGUMENT TABLE FOR PARAMETER REMOVAL 
          CON    0
 USRF     BSS    1           ERROR MESSAGE ADDRESS
          SPACE  4,10 
**        VCCT - TABLE OF VALID CONTROL CARDS.
* 
**T,VCCT   42/ CSTMT,18/ ADDR+1 
* 
*         CSTMT  - CONTROL STATEMENT NAME LEFT JUSTIFIED. 
*         ADDR   - ADDRESS OF STATEMENT PROCESSOR.
  
  
 VCCT     CSTMT  USER,USR 
          CSTMT  ACCOUNT,USR
 VCCA     BSSZ   1           SET TO *CHARGE,CHR*
 VCCB     BSSZ   1           SET TO *APPEND,APP*
          CSTMT  ATTACH,GIA 
          CSTMT  CHANGE,PCP 
          CSTMT  DEFINE,SDP 
          CSTMT  DROPDS,DDS 
          CSTMT  GET,GIA
          CSTMT  PACKNAM,PKN
          CSTMT  PERMIT,PCP 
          CSTMT  PURGE,PRG
          CSTMT  REPLACE,RPL
          CSTMT  SAVE,SIP 
          BSSZ   1
 VCCC     CSTMT  APPEND,APP 
          CSTMT  CHARGE,CHR 
 VCCD     CON    UCRD        *PTFS - USER DIRECTIVE REQUIRED FIRST.*
 VCCE     CON    0           INTERNAL DEFAULT CHARGE FLAG 
 VCCF     BSS    1           *AAWC* (USER VALIDATION WORD)
 VPCT     SPACE  4,10 
**        VC1T - TABLE OF CONTROL CARDS FOR PASS 1 OF RFT 
* 
**T,VC1T   42/ CSTMT,18/ ADDR+1 
* 
*         CSTMT  - CONTROL STATEMENT NAME LEFT JUSTIFIED
*         ADDR   - ADDRESS OF STATEMENT PROCESSOR 
  
  
 VC1T     CSTMT  USER,RCS 
          CSTMT  ACCOUNT,RCS
          CSTMT  APPEND,MFX 
          CSTMT  ATTACH,MFX 
          CSTMT  CHANGE,EXI 
          CSTMT  CHARGE,RCS 
          CSTMT  DEFINE,MFX 
          CSTMT  DROPDS,EXI 
          CSTMT  GET,MFX
          CSTMT  PACKNAM,RCS
          CSTMT  PURGE,EXI
          CSTMT  PERMIT,EXI 
          CSTMT  REPLACE,MFX
          CSTMT  SAVE,MFX 
          BSSZ   1
          SPACE  4
**        VPCT - TABLE OF POST PROCESSORS.
* 
**T,VPCT   42/ CSTMT,18/ ADDR+1 
* 
*         CSTMT  - CONTROL STATEMENT NAME LEFT JUSTIFIED. 
*         ADDR   - ADDRESS OF POST PROCESSOR. 
  
  
 VPCT     CSTMT  APPEND,SIA 
          CSTMT  ATTACH,RPC 
          CSTMT  GET,RPC
          CSTMT  DEFINE,SIA 
          CSTMT  REPLACE,SIA
          CSTMT  SAVE,SIA 
          BSSZ   1
          SPACE  4,10 
**        VAPT - VALID ATTACH, GET STATEMENT PARAMETERS.
* 
**T,VAPT   12/ -PN,8/,11/ MIN,11/ MAX,18/ ADDR
**T, OR    12/ PARAM,8/,11/ MIN,11/ MAX,18/ ADDR
* 
*         PN     - POSITIONAL PARAMETER NUMBER
*         MIN    - MINIMUM CHARACTER SHIFT COUNT
*         MAX    - MAXIMUM CHARACTER SHIFT COUNT
*         ADDR   - ADDRESS TO STORE PARAMETER VALUE 
*         PARAM  - TWO CHARACTER PARAMETER NAME.
  
  
 VAPT     DEFPOS 1,PFN,0,7
          DEFPAR NA 
          DEFPAR PN,0,7 
          DEFPAR PW,0,7 
          DEFPAR R,0,3
          DEFPAR RT 
          DEFPAR UN,0,7 
          DEFPAR WB 
          BSSZ   1
          SPACE  4,10 
**        VCPT - VALID CHARGE STATEMENT PARAMETERS. 
* 
**T,VCPT   12/ -PN,8/,11/ MIN,11/ MAX,18/ ADDR
* 
*         PN     - POSITIONAL PARAMETER NUMBER
*         MIN    - MINIMUM CHARACTER SHIFT COUNT
*         MAX    - MAXIMUM CHARACTER SHIFT COUNT
*         ADDR   - ADDRESS TO STORE PARAMETER VALUE.
  
  
 VCPT     DEFPOS 1,CGN,0,10 
          DEFPOS 2,PRN,0,10,,D
          DEFPOS 3,PRN+1,0,10 
          BSSZ   1
 VDDT     SPACE  4,10 
**        VDDT - VALID DROPDS COMMAND PARAMETERS. 
* 
**T,VPPT   12/ -PN,8/,11/ MIN,11/ MAX,18/ ADDR
**T, OR    12/ PARAM,8/,11/ MIN,11/ MAX,18/ ADDR
* 
*         PN     - POSITIONAL PARAMETER NUMBER
*         MIN    - MINIMUM CHARACTER SHIFT COUNT
*         MAX    - MAXIMUM CHARACTER SHIFT COUNT
*         ADDR   - ADDRESS TO STORE PARAMETER VALUE 
*         PARAM  - TWO CHARACTER PARAMETER NAME.
  
  
 VDDT     DEFPOS 1,PFN,0,7
          DEFPAR NA 
          DEFPAR PN,0,7 
          DEFPAR R,0,3
          DEFPAR WB 
          BSSZ   1
          SPACE  4,10 
**        VDPT - VALID DEFINE STATEMENT PARAMETERS. 
* 
**T,VDPT   12/ -PN,8/,11/ MIN,11/ MAX,18/ ADDR
**T, OR    12/ PARAM,8/,11/ MIN,11/ MAX,18/ ADDR
* 
*         PN     - POSITIONAL PARAMETER NUMBER
*         MIN    - MINIMUM CHARACTER SHIFT COUNT
*         MAX    - MAXIMUM CHARACTER SHIFT COUNT
*         ADDR   - ADDRESS TO STORE PARAMETER VALUE 
*         PARAM  - TWO CHARACTER PARAMETER NAME.
  
  
 VDPT     DEFPOS 1,PFN,0,7
          DEFPAR AC,0,1 
          DEFPAR AL,0,7 
          DEFPAR BR,0,2 
          DEFPAR CT,0,7 
          DEFPAR M,0,7
          DEFPAR NA 
          DEFPAR PN,0,7 
          DEFPAR PR,0,1 
          DEFPAR PW,0,7 
          DEFPAR R,0,3
          DEFPAR S,0,7,C
          DEFPAR WB 
          DEFPAR XD,0,6 
          DEFPAR XT,0,5 
          BSSZ   1
          SPACE  4,10 
**        VGPT - VALID APPEND, PURGE PARAMETERS.
* 
**T,VGPT   12/ -PN,8/,11/ MIN,11/ MAX,18/ ADDR
**T, OR    12/ PARAM,8/,11/ MIN,11/ MAX,18/ ADDR
* 
*         PN     - POSITIONAL PARAMETER NUMBER
*         MIN    - MINIMUM CHARACTER SHIFT COUNT
*         MAX    - MAXIMUM CHARACTER SHIFT COUNT
*         ADDR   - ADDRESS TO STORE PARAMETER VALUE 
*         PARAM  - TWO CHARACTER PARAMETER NAME.
  
  
 VGPT     DEFPOS 1,PFN,0,7
          DEFPAR NA 
          DEFPAR PN,0,7 
          DEFPAR PW,0,7 
          DEFPAR R,0,3
          DEFPAR UN,0,7 
          DEFPAR WB 
          BSSZ   1
          SPACE  4,10 
**        VHPT - VALID CHANGE STATEMENT PARAMETERS. 
* 
**T,VHPT   12/ -PN,8/,11/ MIN,11/ MAX,18/ ADDR
**T, OR    12/ PARAM,8/,11/ MIN,11/ MAX,18/ ADDR
* 
*         PN     - POSITIONAL PARAMETER NUMBER
*         MIN    - MINIMUM CHARACTER SHIFT COUNT
*         MAX    - MAXIMUM CHARACTER SHIFT COUNT
*         ADDR   - ADDRESS TO STORE PARAMETER VALUE 
*         PARAM  - TWO CHARACTER PARAMETER NAME.
  
  
 VHPT     DEFPOS 1,PFN,0,7
          DEFPOS 2,#OFN,0,7 
          DEFPAR AC,0,1 
          DEFPAR BR,0,2 
          DEFPAR CE 
          DEFPAR CP 
          DEFPAR CT,0,7 
          DEFPAR M,0,7
          DEFPAR NA 
          DEFPAR PN,0,7 
          DEFPAR PR,0,1 
          DEFPAR PW,0,7 
          DEFPAR R,0,3
          DEFPAR WB 
          DEFPAR XD,0,6 
          DEFPAR XT,0,5 
          BSSZ   1
          SPACE  4,10 
**        VKPT - VALID PACKNAM PARAMETERS.
* 
**T,VKPT   12/ -PN,8/,11/ MIN,11/ MAX,18/ ADDR
**T, OR    12/ PARAM,8/,11/ MIN,11/ MAX,18/ ADDR
* 
*         PN     - POSITIONAL PARAMETER NUMBER
*         MIN    - MINIMUM CHARACTER SHIFT COUNT
*         MAX    - MAXIMUM CHARACTER SHIFT COUNT
*         ADDR   - ADDRESS TO STORE PARAMETER VALUE 
*         PARAM  - TWO CHARACTER PARAMETER NAME.
  
  
 VKPT     DEFPAR PN,0,7 
          DEFPOS 1,PACK,0,7 
          DEFPAR R,0,3
          BSSZ   1
          SPACE  4,10 
**        VPPT - VALID PERMIT STATEMENT PARAMETERS. 
* 
**T,VPPT   12/ -PN,8/,11/ MIN,11/ MAX,18/ ADDR
**T, OR    12/ PARAM,8/,11/ MIN,11/ MAX,18/ ADDR
* 
*         PN     - POSITIONAL PARAMETER NUMBER
*         MIN    - MINIMUM CHARACTER SHIFT COUNT
*         MAX    - MAXIMUM CHARACTER SHIFT COUNT
*         ADDR   - ADDRESS TO STORE PARAMETER VALUE 
*         PARAM  - TWO CHARACTER PARAMETER NAME.
  
  
 VPPT     DEFPOS 1,PFN,0,7
          DEFPOS 2,UN,0,7 
          DEFPOS 3,#M,0,7 
          DEFPAR NA 
          DEFPAR PN,0,7 
          DEFPAR R,0,3
          DEFPAR WB 
          DEFPAR XD,0,6 
          DEFPAR XT,0,5 
          BSSZ   1
 VRPT     SPACE  4,10 
**        VRPT - VALID REPLACE PARAMETERS.
* 
**T,VRPT   12/ -PN,8/,11/ MIN,11/ MAX,18/ ADDR
**T, OR    12/ PARAM,8/,11/ MIN,11/ MAX,18/ ADDR
* 
*         PN     - POSITIONAL PARAMETER NUMBER
*         MIN    - MINIMUM CHARACTER SHIFT COUNT
*         MAX    - MAXIMUM CHARACTER SHIFT COUNT
*         ADDR   - ADDRESS TO STORE PARAMETER VALUE 
*         PARAM  - TWO CHARACTER PARAMETER NAME.
  
  
 VRPT     DEFPOS 1,PFN,0,7
          DEFPAR M,0,7
          DEFPAR NA 
          DEFPAR PN,0,7 
          DEFPAR PW,0,7 
          DEFPAR R,0,3
          DEFPAR UN,0,7 
          DEFPAR WB 
          BSSZ   1
          SPACE  4,10 
**        VSPT - VALID SAVE STATEMENT PARAMETERS. 
* 
**T,VSPT   12/ -PN,8/,11/ MIN,11/ MAX,18/ ADDR
**T, OR    12/ PARAM,8/,11/ MIN,11/ MAX,18/ ADDR
* 
*         PN     - POSITIONAL PARAMETER NUMBER
*         MIN    - MINIMUM CHARACTER SHIFT COUNT
*         MAX    - MAXIMUM CHARACTER SHIFT COUNT
*         ADDR   - ADDRESS TO STORE PARAMETER VALUE 
*         PARAM  - TWO CHARACTER PARAMETER NAME.
  
  
 VSPT     DEFPOS 1,PFN,0,7
          DEFPAR AC,0,1 
          DEFPAR AL,0,7 
          DEFPAR BR,0,2 
          DEFPAR CT,0,7 
          DEFPAR M,0,7
          DEFPAR NA 
          DEFPAR PN,0,7 
          DEFPAR PR,0 
          DEFPAR PW,0,7 
          DEFPAR R,0,3
          DEFPAR WB 
          DEFPAR XD,0,6 
          DEFPAR XT,0,5 
          BSSZ   1
          SPACE  4,10 
**        VUPT - VALID USER STATEMENT PARAMETERS. 
* 
**T,VUPT   12/ -PN,8/,11/ MIN,11/ MAX,18/ ADDR
* 
*         PN     - POSITIONAL PARAMETER NUMBER
*         MIN    - MINIMUM CHARACTER SHIFT COUNT
*         MAX    - MAXIMUM CHARACTER SHIFT COUNT
*         ADDR   - ADDRESS TO STORE PARAMETER VALUE.
  
  
 VUPT     DEFPOS 3,FAMILY,0,7 
          DEFPOS 2,PASSWRD,0,7
          DEFPOS 1,USERNUM,0,7
          BSSZ   1
 PRS      TITLE  PRESET.
          USE    PRESET 
  
  
**        PRS - PRESET FOR PROCESSING.
* 
*         PRS INITIALIZES PTFS BY SETTING SOME VALUES AND FILES,
*         CHECKING THE CALLER, AND CONNECTING WITH THE NETWORK
*         AND THE REMOTE *MFLINK*.
* 
*         ENTRY  (B1) = 1.
* 
*         EXIT   (STAT) = CURRENT COMMUNICATIONS STATUS.
*                (JOBNAME) = PTFS JOB NAME. 
* 
*                TO *ABT* IF PTFS CALLED BY USER, OR
*                         IF NETWORK CONNECTION REJECTED. 
*                (X1) = ERROR MESSAGE ADDRESS.
  
  
 PRS      SUBR               ENTRY/EXIT 
          SA1    ACTR        CONTROL STATEMENT ARGUMENT COUNT 
          SB4    X1 
          SA4    ARGR        FWA OF ARGUMENTS 
          SB5    PRSB        ARGUMENT TABLE 
          RJ     =XARG=      PROCESS ARGUMENTS
*         NZ     X4,****     (IGNORE ANY ERRORS)
          SA5    CNCDEL      CONNECTION DELAY 
          SB7    1
          RJ     =XDXB=      CONVERT DPC TO BINARY
          SX7    30          MINIMUM CONNECTION DELAY 
          NZ     X4,PRS1     IF INCORRECT NUMBER
          IX5    X6-X7
          MI     X5,PRS1     IF LESS THAN MINIMUM 
          BX7    X6          USE VALUE FROM CS
  
 PRS1     SA7    CNCDEL      STORE CONNECTION DELAY 
          RETURN F,R         RETURN INPUT 
          SX6    21B
          SA5    DFMFILE
          BX6    X6+X5
          SA6    A5          SET DFMFILE EOR, COMPLETE. 
          RJ     CUC         CHECK IF USER CALLED 
          NZ     X1,PRS5     IF USER CALLED 
          RJ     =XGETHD     GET HOST PID 
          SA6    HOST 
          GETJN  JOBNAME
          RJ     SNW         SET NETWORK INTERFACE TYPE 
          NZ     X1,PRS5     IF ERROR 
          RJL    =XFTUSETF,=1,(PRSA)
          RJL    =XFTUON,APPL,(QBIT,STAT,=1,=1) 
          SA1    STAT 
          SB1    1
          ZR     X1,PRS4     IF NETON SUCCESSFUL
          SX1    X1-1 
          MI     X1,PRS2     IF RETURN CODE TOO SMALL 
          SX6    X1-PRSD
          MI     X6,PRS3     IF RETURN CODE IN RANGE
  
 PRS2     SX1    X1+B1
          RJ     =XCDZ       CONVERT TO DPC 
          SA1    PRSC+PRSD-1 * = NN.    * 
          SA1    X1+2 
          MX0    2*6
          LX6    3*6
          LX0    -5*6 
          BX1    -X0*X1 
          BX6    X0*X6
          BX6    X1+X6
          SA6    A1 
          SX1    PRSD-1      * NETON REJECT = NN.*
  
 PRS3     SA2    PRSC+X1     GET ADDRESS OF MESSAGE 
          MX6    1           FLAG NETON REJECT ERROR
          SX1    X2          GET MESSAGE ADDRESS
          PL     X2,PRS6     IF NON-FATAL ERROR 
          EQ     PRS5        FATAL ERROR
  
 PRS4     SA1    TRACE       TRACE ENABLED FLAG (0 = ON)
          SA2    NWTYPE      NETWORK TYPE (0 = RHF) 
          LX2    59-0 
          AX2    59 
          BX6    X2*X1       ALWAYS ENABLE TRACE IF RHF 
          SA6    A1 
          MX6    -1 
          SA6    NETONF      FLAG APPLICATION NETTED-ON 
          RJL    =XFTUDBG,TRACE,(TRACE,PRSA,TRACE)
          SB1    1
          RECOVR =XRHCRPV,277B,0   SET UP REPRIEVE LIST 
          SB1    1
          BX1    X1-X1       FLAG NO ERROR
  
 PRS5     BX6    X6-X6       FLAG NOT NETON REJECT
  
 PRS6     EQ     PRSX        RETURN 
  
 PRSA     CON    0           TEMPORARY STORAGE
  
 PRSB     BSS    0           CONTROL STATEMENT ARGUMENT TABLE 
          VFD    12/0LA,18/-=-1,30/ABTFLG 
          VFD    12/0LCD,18/CNCDEL,30/CNCDEL
          VFD    12/0LTR,18/=0,30/TRACE 
          CON    0
  
 PRSC     BSS    0           NETON REJECT CODES 
          LOC    1
          CON    0S59+=C*  PTFS  - SUBSYSTEM UNAVAILABLE.*
          CON    0S59+=C*  PTFS  - SUBSYSTEM FULL.* 
          CON    0S59+=C*  PTFS  - APPLICATION DISABLED.* 
  
 PRSD     CON    1S59+=C*  PTFS  - NETON REJECT = NN.*
          LOC    *O 
 CUC      TITLE  PRESET SUBROUTINES.
 CUC      SPACE  4,20 
**        CUC - CHECK IF USER CALLED. 
* 
*         CUC CHECKS IF *PTFS* WAS CALLED BY A NORMAL USER. 
*         TO HAVE BEEN CALLED BY *RHF* THE JOB ORIGIN 
*         MUST BE SYSTEM AND NO USER VALIDATION PERFORMED.
* 
*         ENTRY  NONE.
* 
*         EXIT   (X1) = ZERO IF NOT CALLED BY A USER
*                     = ERROR MESSAGE ADDRESS IF USER CALLED. 
* 
*         USES   A - 1. 
*                B - NONE.
*                X - 1,2. 
* 
*         CALLS  NONE.
* 
*         MACROS SYSTEM.
  
  
 CUC      SUBR               ENTRY/EXIT 
          SA1    JOPR        JOB ORIGIN TYPE
          MX2    -12         FORM JOB ORIGIN MASK 
          LX1    -24
          BX1    -X2*X1      EXTRACT JOB ORIGIN 
          SX2    X1-SYOT
          NZ     X2,CUC1     IF NOT SYSTEM ORIGIN 
          SA1    SSJ=+UIDS
          LX1    59-16
          AX1    59-16
          ZR     X1,CUC2     IF UI=0 OR UI=377777B
  
 CUC1     SX1    ICCM        * INVALID CONTROL STATEMENT *
  
 DBG      IFC    EQ,*"DEBUG"*DEBUG* 
          BX1    X1-X1       ALLOW USER ACCESS
 DBG      ENDIF 
  
 CUC2     EQ     CUCX        RETURN 
 SNW      SPACE  4,10 
**        SNW - SET NETWORK INTERFACE TYPE. 
* 
*         SNW DETERMINES THE NETWORK TYPE FROM THE NETWORK INTERFACE
*         TYPE FLAG (NIFTYPE).
* 
*         ENTRY  (NIFTYPE)   NETWORK INTERFACE TYPE 
* 
*         EXIT   (X1)        ZERO, IF NO ERROR. 
*                            NONZERO, ERROR MESSAGE ADDRESS.
*                IF X1 ZERO 
*                THEN 
*                  (NWTYPE)  UPDATED
  
  
 SNW      SUBR
          MX0    59 
          SA2    NIFTYPE     CHECK NETWORK INTERFACE TYPE 
          BX3    -X0*X2      BIT 0
          AX2    1
          BX2    -X0*X2      BIT 1
          SX6    B0 
          NZ     X3,SNW1     IF RHF/FIP INTERFACE LOADED
          SX6    B1 
          NZ     X2,SNW1     IF NAM/AIP INTERFACE LOADED
          SX1    UNIF        *UNKNOWN NETWORK INTERFACE TYPE* 
          EQ     SNWX        RETURN 
  
 SNW1     SA6    NWTYPE      SET NETWORK TYPE (0=RHF,1=NAM) 
          RJL    =XFTUSNET,NWTYPE 
          MX1    0
          EQ     SNWX        RETURN 
          SPACE  4,10 
  
  
          USE    *
          SPACE  4
 NOSONLY  ENDIF 
  
          END 
