CPUREL
          IDENT  CPU.CPM
          ENTRY  CPM= 
*COMMENT  CPUREL - CONTROL POINT MANAGER PROCESSOR. 
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC.  1992. 
          TITLE  CPU.CPM - CONTROL POINT MANAGER PROCESSOR. 
*CALL     COMCCPM 
          END 
          IDENT  CPU.ECS
          ENTRY  REC= 
          ENTRY  WEC= 
*COMMENT  CPUREL - ECS INTERPRETIVE MODE MACRO PROCESSORS.
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC.  1992. 
          TITLE  CPU.ECS - ECS INTERPRETIVE MODE MACRO PROCESSORS.
*CALL     COMCECM 
*CALL     COMCECS 
          END 
          IDENT  CPU.LFM
          ENTRY  LFM= 
*COMMENT  CPUREL - LOCAL FILE MANAGER PROCESSOR.
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC.  1992. 
          TITLE  CPU.LFM - LOCAL FILE MANAGER PROCESSOR.
*CALL     COMCLFM 
          END 
          IDENT  CPU.OVL
          ENTRY  OVL= 
*COMMENT  CPUREL - OVERLAY LOAD PROCESSOR.
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC.  1992. 
          TITLE  CPU.OVL - OVERLAY LOAD PROCESSOR.
*CALL     COMCOVL 
          END 
          IDENT  CPU.PFM
          ENTRY  PFM= 
*COMMENT  CPUREL - PERMANENT FILE PROCESSOR.
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC.  1992. 
          TITLE  CPU.PFM - PERMANENT FILE PROCESSOR.
*CALL     COMCPFM 
          END 
          IDENT  PF 
          SST 
          ENTRY  PF 
          SYSCOM B1 
          TITLE  PF - PERMANENT FILE REQUEST PROCESSOR. 
*COMMENT  CPUREL - PERMANENT FILE REQUEST PROCESSOR.
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC.  1992. 
          SPACE  4,20 
***       PF - PERMANENT FILE REQUEST PROCESSOR.
* 
*         S. M. HATCH.       78/04/27.    (RAYTHEON)
*         D. W. BOSTROM.     80/05/30.
          SPACE  4,10 
***       *PF* PROVIDES AN INTERFACE TO *NOS* PERMANENT FILE COMMANDS 
*         FOR PROGRAMS WRITTEN IN HIGHER LEVEL LANGUAGES.  THE USE
*         OF KEYWORDS ALLOWS THE USER TO OMIT THOSE PARAMETERS WHICH
*         ARE NOT NEEDED. 
          SPACE  4,10 
***       CALLING SEQUENCE. 
* 
*         *FORTRAN* CALL -
* 
*              CALL PF(REQ,LFN,PFN,KEY(1),OPT(1),...,KEY(N),OPT(N)) 
* 
*         *SYMPL* CALL -
* 
*              PF(REQ,LFN,PFN,KEY(1),OPT(1),...,KEY(N),OPT(N),0); 
* 
*              IT IS REQUIRED THAT THE LAST PARAMETER IN A *SYMPL*
*              CALL BE A ZERO, IN ORDER TO TERMINATE THE PARAMETER
*              LIST PROPERLY.  (THIS IS NOT MANDATORY IF THE *SYMPL*
*              PROGRAM EITHER CONTAINS A *CONTROL FTNCALL*, OR IS 
*              COMPILED WITH THE *F* OPTION.) 
* 
* 
*         THE PARAMETERS CONSIST OF ORDER DEPENDENT MANDATORY 
*         PARAMETERS, FOLLOWED OPTIONALLY BY ORDER INDEPENDENT
*         KEYWORD PAIRED PARAMETER STRINGS.  KEYWORDS AND ALL 
*         OTHER DISPLAY CODE PARAMETERS ARE REQUIRED TO BE LEFT 
*         JUSTIFIED WITH ZERO OR BLANK FILL, OR ELSE IN *FTN5*
*         CHARACTER FORMAT.  OPTIONAL KEYWORD PAIRS CONSIST OF
*         A KEYWORD FOLLOWED BY THE VALUE TO BE ASSOCIATED WITH 
*         THIS KEYWORD. 
* 
*         MANDATORY ORDER DEPENDENT PARAMETERS. 
* 
*              REQ - PERMANENT FILE REQUEST.
*                    THE FOLLOWING *PFM* REQUESTS ARE SUPPORTED - 
*                    *APPEND*, *ATTACH*, *CHANGE*, *DEFINE*, *GET*, 
*                    *PERMIT*, *PURGE*, *REPLACE*, AND *SAVE*.
* 
*              LFN - LOCAL FILE NAME OR *FORTRAN* UNIT NUMBER.
*                    IF *LFN* IS NONZERO AND THE UPPER 42 BITS ARE
*                    ZERO, THEN THE LOWER 18 BITS ARE ASSUMED TO
*                    CONTAIN AN INTEGER.  THIS INTEGER IS CONVERTED 
*                    TO DISPLAY CODE AND PREFIXED WITH THE CHARACTERS 
*                    "TAPE" TO YIELD A *FORTRAN* FILE NAME. 
*                    IF *LFN* EQUALS ZERO OR IS ALL BLANKS, THEN
*                    *LFN* = *PFN* IS ASSUMED.
* 
*              PFN - PERMANENT FILE NAME. 
*                    IF *PFN* EQUALS ZERO OR IS ALL BLANKS, THEN
*                    *PFN* = *LFN* IS ASSUMED.
* 
*         OPTIONAL KEYWORD PARAMETERS.
* 
*              THE FOLLOWING PARAMETERS ARE SIMILAR IN MEANING TO 
*              THE CORRESPONDING OPTIONS ON *NOS* PERMANENT FILE
*              CONTROL CARDS AND MACROS.
* 
*              "AC"   - ALTERNATE CATLIST PERMISSION. 
*              "BR"   - BACKUP REQUIREMENT. 
*              "CT"   - FILE CATEGORY.
*              "M"    - FILE OR USER PERMISSION MODE. 
*              "PN"   - PACK NAME.
*              "PR"   - PREFERRED RESIDENCE.
*              "PW"   - PASSWORD. 
*              "R"    - RESIDENCE DEVICE TYPE.
*              "RT"   - REAL-TIME MODE. 
*              "S"    - SIZE IN PRU-S, IN DISPLAY CODE.  DECIMAL IS 
*                       ASSUMED UNLESS A *B* POST RADIX IS USED TO
*                       INDICATE OCTAL. 
*              "UN"   - USER NUMBER.
*              "XD"   - EXPIRATION DATE.
*              "XT"   - EXPIRATION TERM.
* 
*              THE FOLLOWING PARAMETERS DO NOT DIRECTLY CORRESPOND
*              TO ANY OPTIONS ON *NOS* PERMANENT FILE CONTROL CARDS 
*              OR MACROS. 
* 
*              "EL"   - ERROR MESSAGE LENGTH. 
*                       NUMBER OF CHARACTERS TO BE RETURNED TO THE
*                       ERROR MESSAGE BUFFER SPECIFIED BY THE *EM*
*                       PARAMETER.  IF THE BUFFER SPECIFIED BY *EM* IS
*                       A *FTN5* VARIABLE, THE VALUE USED FOR *EL* IS 
*                       THE LENGTH OF THAT VARIABLE, AND THE *EL* 
*                       PARAMETER IS IGNORED; OTHERWISE, THE DEFAULT
*                       FOR *EL* IS 10. 
*              "EM"   - ERROR MESSAGE RETURN ADDRESS. 
*                       THE BUFFER TO WHICH THE *PFM* ERROR MESSAGE 
*                       WILL BE RETURNED.  THE NUMBER OF CHARACTERS 
*                       RETURNED IS DETERMINED BY THE VALUE USED FOR
*                       THE *EL* PARAMETER. 
*              "IP"   - SETS THE INTERLOCK PROCESSING BIT IN THE FET. 
*              "IUP"  - IGNORE UNNEEDED PARAMETERS. 
*              "NA"   - INHIBITS ROLLOUT IF DIRECT FILE BUSY, AND 
*                       PREVENTS ABORT ON ERROR CONDITIONS. 
*              "NF"   - OPTIONAL MEANS OF SPECIFYING NEW FILE NAME
*                       ON *CHANGE* REQUEST.  (SEE EXAMPLE BELOW.)
*              "NONE" - USED TO NULLIFY SPECIFIC KEYWORDS.
*              "OF"   - OPTIONAL MEANS OF SPECIFYING OLD FILE NAME
*                       ON *CHANGE* REQUEST.  (SEE EXAMPLE BELOW.)
*              "RC"   - RETURNS ERROR CODE IN INTEGER FORMAT AND
*                       PREVENTS ABORT ON ERROR CONDITIONS. 
*              "RRC"  - RETURNS ERROR CODE IN REAL FORMAT AND 
*                       PREVENTS ABORT ON ERROR CONDITIONS. 
*              "SR"   - SPECIAL *PFM* REQUEST.
*                       = "CE" - CLEAR FILE ERROR CODE (*CHANGE*).
*                       = "CP" - RESET CHARGE/PROJECT NUMBERS 
*                         (*CHANGE*). 
*                       = "MR" - MASTER DEVICE RESIDENCE (*DEFINE*).
*                       = "IE" - IGNORE ERROR IDLE STATUS (ALL).
*                                VALID ONLY FOR *SSJ=* JOBS.
*                       = "FA" - FORCE FAST ATTACH OF FILE (*ATTACH*).
*                                VALID ONLY FOR *SSJ=* JOBS.
*                       = "NF" - FORCE NON-FAST ATTACH FILE (*ATTACH*). 
*              "SS"   - SUBSYSTEM MODE OF INDIRECT FILE.
*              "UC"   - USER CONTROL WORD (59 BITS).
*              "UP"   - SETS THE USER PROCESSING BIT IN THE FET.
* 
*         EXAMPLES. 
* 
*              CALL PF("GET",1,"PFILE","UN","USERNO","PW","STRING7")
*              CALL PF ("DEFINE","LFILE","PFILE","CT","PU","M","W");
* 
*              SPECIAL FORMATS ARE USED FOR THE *CHANGE*, *PERMIT*, 
*              AND *PURGE* REQUESTS, E.G. - 
* 
*              CALL PF ("CHANGE","NEWPFN","OLDPFN","BR","MD") 
*              CALL PF ("PERMIT","PFN","UN","USERNAM","M","R")
*              CALL PF ("PURGE","PFN","RC",ERRCODE) 
* 
*         NOTES.
* 
*              A KEYWORD VALUE PARAMETER IS REQUIRED TO FOLLOW EVERY
*              KEYWORD, ALTHOUGH THE VALUES FOLLOWING SOME KEYWORDS,
*              SUCH AS *NA* AND *RT*, ARE IGNORED.
* 
*              BEFORE ISSUING A *SAVE*, *REPLACE*, OR *APPEND* REQUEST
*              THE USER MUST ENSURE THAT THE APPROPRIATE *CIO* BUFFER 
*              IS FLUSHED.
          SPACE  4,10 
***       ERROR PROCESSING. 
* 
*         THE COMBINATION OF *RC*/*RRC* AND *NA* PARAMETERS USED
*         DETERMINES THE TYPE OF ERROR PROCESSING DONE. 
* 
*          1.   IF NEITHER *NA* NOR *RC*/*RRC* ARE SPECIFIED AND
*               AN ERROR IS DETECTED BY PF OR *PFM*, THE ERROR
*               MESSAGE IS WRITTEN TO THE USER-S DAYFILE AND THE
*               PROGRAM IS ABORTED. 
* 
*          2.   IF THE KEYWORD *RC*/*RRC* IS SPECIFIED AND AN 
*               ERROR OCCURS, THE *PFM* ERROR CODE IS PLACED
*               IN THE APPROPRIATE RETURN CODE PARAMETER(S).  A 
*               ZERO VALUE INDICATES SUCCESSFUL COMPLETION, AND 
*               A NEGATIVE VALUE IMPLIES A CALL ARGUMENT ERROR. 
* 
*          3.   IF THE KEYWORD *NA* IS SPECIFIED AND THE *PFM*
*               FUNCTION FAILS, CONTROL RETURNS TO THE CALLING
*               PROGRAM, AFTER PLACING THE PF ERROR CODE IN THE 
*               *RC*/*RRC* PARAMETER (IF SPECIFIED) OR ISSUING
*               A DAYFILE MESSAGE.
* 
*          4.   IF *NA* IS NOT SPECIFIED, AN *ATTACH* REQUEST FOR 
*               A DIRECT ACCESS FILE WHICH IS CURRENTLY BUSY WILL 
*               CAUSE THE JOB TO BE ROLLED OUT UNTIL THE FILE 
*               BECOMES AVAILABLE.
          SPACE  4,10 
***       DAYFILE MESSAGES. 
* 
*         * PF NO.-1 INVALID PARAMETER - UNPAIRED.* 
*             A KEYWORD NOT FOLLOWED BY A KEYWORD VALUE WAS 
*             ENCOUNTERED.
* 
*         * PF NO.-1 INVALID PARAMETER - XXXXXXX.*
*             AN INVALID KEYWORD OR KEYWORD VALUE WAS ENCOUNTERED.
* 
*         * PF NO.-XX CCCC...CCCC.* 
*             ERROR CODE AND MESSAGE RETURNED BY *PFM*. 
          SPACE  4,10 
          TITLE  MACRO DEFINITIONS. 
*         COMMON DECKS. 
  
*CALL     COMCMAC 
*CALL     COMSMSP 
*CALL     COMSPFM 
 PVALID   SPACE  4,10 
**        PVALID - GENERATE EQUIVALENCES FOR PARAMETER VALIDATION.
* 
* SYM     PVALID (REQ1,REQ2,...,REQN) 
* 
*         ENTRY  *SYM* = SYMBOL TO REPRESENT VALID USES OF A
*                        PARAMETER. 
*                *REQ* = A *PFM* REQUEST FOR WHICH THE PARAMETER
*                        IS VALID.  THE SYMBOL *CC_REQ* MUST BE 
*                        DEFINED IN *COMSPFM*.
* 
*         NOTE   THE VALUE OF *SYM* IS GENERATED BY SETTING A BIT 
*                CORRESPONDING TO EACH REQUEST SPECIFIED. 
  
  
          PURGMAC  PVALID 
  
          MACRO  PVALID,SYM,REQ 
          MACREF PVALID 
 SYM      SET    0
          IRP    REQ
 REQ      DECMIC CC_REQ-1 
 SYM      SET    SYM+1S"REQ"
 PVALID   ENDM
          SPACE  4,10 
          ECHO   1,SYM=(CLLF,CLNA,CLNO,CLPF,CLPN,CLRC,CLRS,CLEM,CLIU) 
 SYM      PVALID (SV,GT,PG,PM,RP,AP,DF,AT,CG) 
 CLAC     PVALID (SV,DF,CG) 
 CLBR     PVALID (SV,DF,CG) 
 CLCT     PVALID (SV,DF,CG) 
 CLIP     PVALID (SV,GT,PG,PM,RP,AP,DF,AT,CG) 
 CLMD     PVALID (SV,RP,DF,AT,CG,PM)
 CLNF     PVALID (CG) 
 CLOF     PVALID (CG) 
 CLPR     PVALID (SV,DF,CG) 
 CLPW     PVALID (SV,GT,PG,RP,AP,DF,AT,CG)
 CLRT     PVALID (GT,AP,AT) 
 CLSP     PVALID (DF) 
 CLSR     PVALID (SV,GT,PG,PM,RP,AP,DF,AT,CG) 
 CLSS     PVALID (SV,RP,CG) 
 CLUC     PVALID (SV,GT,RP,CG,DF,AT)
 CLUN     PVALID (GT,PG,RP,AP,AT,PM)
 CLUP     PVALID (SV,GT,PG,PM,RP,AP,DF,AT,CG) 
 CLXD     PVALID (SV,PM,DF,CG)
 CLXT     PVALID (SV,PM,DF,CG)
 TREQ     TITLE  TABLE DEFINITIONS. 
 TREQ     SPACE  4,10 
**        TREQ - TABLE OF PERMANENT FILE REQUEST CODES. 
* 
*T        42/7LCOMMAND,18/CODE
  
  
 TREQ     BSS    0
          VFD    42/0LSAVE,18/CCSV              SAVE
          VFD    42/0LGET,18/CCGT               GET 
          VFD    42/0LPURGE,18/CCPG             PURGE 
          VFD    42/0LPERMIT,18/CCPM            PERMIT
          VFD    42/0LREPLACE,18/CCRP           REPLACE 
          VFD    42/0LAPPEND,18/CCAP            APPEND
          VFD    42/0LDEFINE,18/CCDF            DEFINE
          VFD    42/0LATTACH,18/CCAT            ATTACH
          VFD    42/0LCHANGE,18/CCCG            CHANGE
 TREQL    CON    0
 TOPT     SPACE  4,10 
**        TOPT - TABLE OF PERMANENT FILE ACCESS OPTIONS.
* 
*T        12/OPTION,12/VALID,6/WORD,6/LBIT,6/LENGTH,18/TABLE
* 
*         OPTION = PF OPTION IN DISPLAY CODE.  FOR KEYWORDS LONGER
*                     THAN TWO CHARACTERS, ONLY THE FIRST TWO 
*                     CHARACTERS ARE USED.
*         VALID  = FIELD INDICATING VALID USES OF THIS PARAMETER, 
*                     DEFINED USING THE *PVALID* MACRO. 
*         WORD   = WORD IN *FET* CONTAINING THE FIELD TO BE SET.
*         LBIT   = LOWER BIT OF THE FIELD IN THE *FET*. 
*         LENGTH = LENGTH OF THE *FET* FIELD IN BITS. 
*         TABLE  = ADDRESS OF TABLE, IF ANY, GIVING PERMISSABLE 
*                     VALUES FOR THIS OPTION. 
*                = 0, INDICATES THAT THE VALUE SPECIFIED IS NOT 
*                     VALIDATED BY PF.
*                = 1, INDICATES THAT THE VALUE IS TO BE CONVERTED 
*                     FROM DISPLAY CODE TO BINARY.
*                = 2, INDICATES THAT THE VALUE SPECIFIED FOR THIS 
*                     OPTION IS IGNORED.
*                = 3, INDICATES THAT ENTIRE PARAMETER DESCRIPTION FOR 
*                     PARAMETER IS SAVED, TO BE PROCESSED INDIVIDUALLY. 
*                = 4, INDICATES THAT THE VALUE SPECIFIED FOR THIS 
*                     OPTION IS A RETURN ADDRESS. 
*                = NEGATIVE VALUE, INDICATES THAT THIS IS THE 
*                     COMPLEMENT OF AN ADDRESS FOR A SPECIAL
*                     VALIDATION ROUTINE. 
  
  
 TOPT     BSS    0
          VFD    12/0LAC,12/CLAC,6/CFAP,6/46,6/02,18/TBAC 
          VFD    12/0LBR,12/CLBR,6/CFBR,6/54,6/03,18/TBRQ 
          VFD    12/0LCT,12/CLCT,6/CFCT,6/06,6/06,18/TCAT 
          VFD    12/0LEL,12/CLEM,6/CFEL,6/00,6/18,18/1
          VFD    12/0LEM,12/CLEM,6/CFEM,6/00,6/18,18/3
          VFD    12/0LIP,12/CLIP,6/0001,6/42,6/01,18/2
          VFD    12/0LIU,12/CLIU,6/CFIU,6/00,6/60,18/4
          VFD    12/0LLF,12/CLLF,6/CFSN,6/18,6/42,18/0
          VFD    12/0LM,012/CLMD,6/CFMD,6/00,6/06,18/TMOD 
          VFD    12/0LNA,12/CLNA,6/CFNA,6/00,6/60,18/2
          VFD    12/0LNF,12/CLNF,6/CFNF,6/18,6/42,18/0
          VFD    12/0LNO,12/CLNO,6/CFNO,6/00,6/60,18/2
          VFD    12/0LOF,12/CLOF,6/CFSN,6/18,6/42,18/0
          VFD    12/0LPF,12/CLPF,6/CFPN,6/18,6/42,18/0
          VFD    12/0LPN,12/CLPN,6/CFPK,6/18,6/42,18/0
          VFD    12/0LPR,12/CLPR,6/CFPR,6/57,6/03,18/TPRS 
          VFD    12/0LPW,12/CLPW,6/CFPW,6/18,6/42,18/0
          VFD    12/0LR,012/CLRS,6/0001,6/48,6/12,18/-PRD 
          VFD    12/0LRC,12/CLRC,6/CFRC,6/00,6/60,18/4
          VFD    12/0LRR,12/CLRC,6/CFRR,6/00,6/60,18/4
          VFD    12/0LRT,12/CLRT,6/0001,6/43,6/01,18/2
          VFD    12/0LS,012/CLSP,6/CFOU,6/00,6/24,18/1
          VFD    12/0LSR,12/CLSR,6/CFCT,6/12,6/06,18/TSRQ 
          VFD    12/0LSS,12/CLSS,6/CFSS,6/48,6/06,18/TSUB 
          VFD    12/0LUC,12/CLUC,6/CFCW,6/00,6/60,18/4
          VFD    12/0LUN,12/CLUN,6/CFOU,6/18,6/42,18/0
          VFD    12/0LUP,12/CLUP,6/0001,6/45,6/01,18/2
          VFD    12/0LXD,12/CLXD,6/CFNF,6/0,6/18,18/-PXD
          VFD    12/0LXT,12/CLXT,6/CFNF,6/0,6/18,18/-PXT
          VFD    60/0 
 TBAC     SPACE  4,10 
**        TBAC - TABLE OF ALTERNATE CATLIST PERMISSIONS.
* 
*T        42/PERMISSION,18/CODE 
  
  
 TBAC     BSS    0
          VFD    42/0LN,18/ACNO    ALTERNATE CATLIST NOT PERMITTED
          VFD    42/0LY,18/ACYS    ALTERNATE CATLIST PERMITTED
          VFD    60/0 
 TBRQ     SPACE  4,10 
**        TBRQ - TABLE OF BACKUP REQUIREMENT TYPES. 
* 
*T        42/REQUIREMENT,18/CODE
  
  
 TBRQ     BSS    0
          VFD    42/0LN,018/BRNO    NO BACKUP REQUIRED
          VFD    42/0LY,018/BRAL    BACKUP ALWAYS REQUIRED
          VFD    42/0LMD,18/BRMD    MEDIA DEPENDENT 
          VFD    60/0 
 TCAT     SPACE  4,10 
**        TCAT - TABLE OF PERMANENT FILE CATEGORY TYPES.
* 
*T        42/CATEGORY,18/CODE 
  
  
 TCAT     BSS    0
          VFD    42/0LPRIVATE,18/FCPR+40B    PRIVATE
          VFD    42/0LSPRIV,0018/FCSP+40B    SEMI-PRIVATE 
          VFD    42/0LPUBLIC,018/FCPB+40B    PUBLIC 
          VFD    42/0LP,00000018/FCPR+40B    PRIVATE
          VFD    42/0LS,00000018/FCSP+40B    SEMI-PRIVATE 
          VFD    42/0LPU,0000018/FCPB+40B    PUBLIC 
          VFD    60/0 
 TMOD     SPACE  4,10 
**        TMOD - TABLE OF PERMANENT FILE PERMISSION TYPES.
* 
*T        42/ACCESS,18/CODE 
  
  
 TMOD     BSS    0
          VFD    42/0LWRITE,0018/PTWR+40B    WRITE
          VFD    42/0LREAD,00018/PTRD+40B    READ 
          VFD    42/0LAPPEND,018/PTAP+40B    APPEND 
          VFD    42/0LEXECUTE,18/PTEX+40B    EXECUTE
          VFD    42/0LNULL,00018/PTNU+40B    NULL 
          VFD    42/0LMODIFY,018/PTMD+40B    MODIFY 
          VFD    42/0LREADMD,018/PTRM+40B    READ ALLOW MODIFY
          VFD    42/0LREADAP,018/PTRA+40B    READ ALLOW APPEND
          VFD    42/0LUPDATE,018/PTUP+40B    UPDATE 
          VFD    42/0LREADUP,018/PTRU+40B    READ ALLOW UPDATE
          VFD    42/0LW,00000018/PTWR+40B    WRITE
          VFD    42/0LR,00000018/PTRD+40B    READ 
          VFD    42/0LA,00000018/PTAP+40B    APPEND 
          VFD    42/0LE,00000018/PTEX+40B    EXECUTE
          VFD    42/0LN,00000018/PTNU+40B    NULL 
          VFD    42/0LM,00000018/PTMD+40B    MODIFY 
          VFD    42/0LRM,0000018/PTRM+40B    READ ALLOW MODIFY
          VFD    42/0LRA,0000018/PTRA+40B    READ ALLOW APPEND
          VFD    42/0LU,00000018/PTUP+40B    UPDATE 
          VFD    42/0LRU,0000018/PTRU+40B    READ ALLOW UPDATE
          VFD    60/0 
 TPRS     SPACE  4,10 
**        TPRS - TABLE OF PREFERRED RESIDENCE TYPES.
* 
*T        42/PREFERENCE,18/CODE 
  
  
 TPRS     BSS    0
          VFD    42/0LL,18/RSLK   LOCKED TO DISK RESIDENCE
          VFD    42/0LD,18/RSDS   DISK RESIDENCE PREFERRED
          VFD    42/0LM,18/RSMS   CARTRIDGE ALTERNATE STORAGE PREFERRED 
          VFD    42/0LN,18/RSNP   NO PREFERENCE 
          VFD    42/0LT,18/RSTP   TAPE ALTERNATE STORAGE PREFERRED
          VFD    60/0 
 TRES     SPACE  4,10 
**        TRES - TABLE OF PERMANENCE FILE RESIDENCE TYPES.
* 
*T        42/DEVICE,18/CODE 
  
 TBLM     SPACE  4,10 
**        TBLM - DEFINE MACRO TO PRODUCE *TRES* TABLE.
  
          PURGMAC  TBLM 
 TBLM     MACRO  EQ 
          VFD    42/0L_EQ,18/2R_EQ
 TBLM     ENDM
  
  
          LIST   G
 TRES     TBL    "MSEQ" 
          VFD    60/0 
          LIST   -G 
 TSRQ     SPACE  4,10 
**        TSRQ - TABLE OF SPECIAL REQUEST TYPES.
* 
*T        42/REQUEST,18/CODE
  
  
 TSRQ     BSS    0
          VFD    42/0LCE,18/SRCE    CLEAR ERROR STATUS
          VFD    42/0LMR,18/SRMR    FORCE MASTER DEVICE RESIDENCY 
          VFD    42/0LIE,18/SRIE    IGNORE ERROR IDLE STATUS (*SSJ=*) 
          VFD    42/0LCP,18/SRCP    RESET CHARGE/PROJECT NUMBERS
          VFD    42/0LFA,18/SRFA    FORCE FAST ATTACH OF FILE (*SSJ=*)
          VFD    42/0LNF,18/SRNF    FORCE NON-FAST ATTACH OF FILE 
          VFD    60/0 
 TSUB     SPACE  4,10 
**        TSUB - TABLE OF PERMANENT FILE SUBSYSTEM TYPES. 
* 
*T        42/SUBSYSTEM,18/CODE
  
  
 TSUB     BSS    0
          VFD    42/0LNULL,00018/40B+0    NULL
          VFD    42/0LBASIC,0018/40B+1    BASIC 
          VFD    42/0LFORTRAN,18/40B+2    FTN5
          VFD    42/0LFTNTS,0018/40B+3    FTNTS 
          VFD    42/0LEXECUTE,18/40B+4    EXECUTE 
          VFD    42/0LBATCH,0018/40B+5    BATCH 
          VFD    60/0 
          SPACE  4,10 
*         CONSTANTS AND DATA STORAGE. 
  
  
 FET      FILEB  FET,CFLM,(FET=CFLM),(EPR)
 XRCW     BSS    1           ADDRESS TO RETURN USER CONTROL WORD
 XRRC     BSS    1           ADDRESS TO RETURN INTEGER ERROR CODE 
 XRRR     BSS    1           ADDRESS TO RETURN REAL ERROR CODE
 XRNA     BSS    1           *NA* FLAG
 XRIU     BSS    1           IGNORE PARAMETERS RETURN ADDRESS 
 XREL     BSS    1           ERROR MESSAGE LENGTH 
 XREM     BSS    1           *EM* PARAMETER VALUE DESCRIPTOR
 PFEC     BSS    1           ADDRESS OF *PFM* ERROR CODE MESSAGES 
 PFMA     BSS    4           ADDRESS TO RETURN *PFM* ERROR MESSAGES 
 NONE     BSS    1           UNUSED *NONE* PARAMETER VALUE
 ICTR     BSS    1           IGNORED PARAMETERS COUNTER 
 EADR     BSS    1           ERROR ADDRESS FOR IGNORED PARAMETER
 CFCW     EQU    XRCW-FET 
 CFRC     EQU    XRRC-FET 
 CFRR     EQU    XRRR-FET 
 CFNA     EQU    XRNA-FET 
 CFIU     EQU    XRIU-FET 
 CFEL     EQU    XREL-FET 
 CFEM     EQU    XREM-FET 
 CFNO     EQU    NONE-FET 
          ERRNZ  PTWR        CODE ASSUMES *PTWR* EQUALS ZERO
          ERRNZ  FCPR        CODE ASSUMES *FCPR* EQUALS ZERO
 FET1     BSS    0           DEFAULT VALUES FOR FET+1 
          VFD    15/0,1/1    ERROR PROCESSING BIT 
          VFD    20/0,6/CFLM-5  FET LENGTH
          VFD    18/FET      FIRST
  
 APLIST   VFD    42/0,18/*+1S17  ADDRESS OF THE FORMAL PARAMETER LIST 
 TEMPA0   VFD    42/0,18/*+1S17  CONTENTS OF A0 FROM CALLING ROUTINE
 ACCESS   CON    0           CURRENT PERMANENT FILE REQUEST CODE
 TEVENT   CON    0           ROLLOUT ON TIME/EVENT DEPENDENCIES 
 OPTION   CON    0           CURRENT OPTIONS PF *FET* CONFIGURATION 
 BLANKS   DATA   10R
 XDATE    BSS    1           CURRENT DATE 
 XFLAG    CON    0           *XD* AND *XT* PARAMETER FLAG 
 PF       TITLE  MAIN ROUTINE.
 PF       SPACE  4,10 
**        PF - MAIN ROUTINE FOR *NOS* PERMANENT FILE ACCESS.
* 
*         ENTRY  (A1) = FWA OF FORMAL PARAMETER LIST. 
* 
*         USES   ALL (A0 PRESERVED).
* 
*         CALLS  COD=        CONVERT BINARY TO OCTAL DISPLAY. 
*                DXB=        CONVERT DISPLAY CODE TO BINARY.
*                GETFIT.     GET PROGRAM *FIT* ADDRESS. 
*                LCP         LOAD CHARACTER PARAMETER.
*                ZFN         ZERO FILE NAME.
* 
*         MACROS ABORT, MESSAGE, ROLLOUT, SYSTEM. 
  
  
  
 TRACE    VFD    42/0LPF,18/PF
 PF       EQ     *+1S17      ENTRY/EXIT 
  
**        PRE - PRESET INITIAL CONDITIONS AND STORAGE AREAS.
  
 PRE      SB1    1           INITIALIZE (B1) AS ONE 
          SX6    A0 
          SX7    A1 
          SA6    TEMPA0      PRESERVE (A0) FOR EXIT 
          SA7    APLIST 
          SA0    A1          SET FWA APLIST POINTER 
          BX6    X6-X6
          SA6    XFLAG       INITIALIZE *XD*/*XT* FLAG
          SA6    ICTR        INITIALIZE UNUSED PARAMETER COUNTER
          SA6    XRIU        INITIALIZE *IUP* FLAG
          SA6    XRRC        INITIALIZE *RC* PARAMETER
          SA6    XRRR        INITIALIZE *RRC* PARAMETER 
          SA6    XREL        INITIALIZE *EL* PARAMETER
          SA6    FET+CFSN 
          SB2    FET+2
          SB3    NONE 
 PRE1     SA6    B2          CLEAR *FET*/MESSAGE AREA 
          SB2    B2+B1
          NE     B2,B3,PRE1  IF NOT COMPLETLY CLEAR 
          SA1    BLANKS 
          BX6    X1 
          SA6    PFMA        BLANK FILL ERROR MESSAGE AREA
          SA6    A6+B1
          SA6    A6+B1
          SA6    A6+B1
          SX6    PFMA 
          SA6    FET+CFPW    SET ADDRESS OF MESSAGE 
          SA1    FET1        RESET SECOND WORD OF FET 
          BX6    X1 
          SA6    FET+1
  
**        REQ - PROCESS PERMANENT FILE REQUEST. 
  
 REQ      SA1    A0 
          RJ     LCP         CHECK *PFM* REQUEST TYPE 
          RJ     ZFN         ZERO FILL ALPHANUMERIC 
          MX0    42 
          BX1    X6 
          SA2    TREQ 
 REQ1     ZR     X2,PCE      IF NOT A VALID REQUEST 
          BX3    X2-X1
          BX3    X0*X3
          BX6    -X0*X2 
          SA2    A2+B1
          NZ     X3,REQ1     IF NOT THIS TABLE ENTRY
          SA6    ACCESS 
          SX1    X6-CCAT
          ZR     X1,REQ2     IF *ATTACH* REQUEST
          SX1    X6-CCDF
          ZR     X1,REQ2     IF *DEFINE* REQUEST
          SX1    X6-CCSV
          ZR     X1,REQ2     IF *SAVE* REQUEST
          SX1    X6-CCPM
          ZR     X1,REQ2     IF *PERMIT* REQUEST
          SX1    X6-CCRP
          NZ     X1,REQ3     IF NOT *REPLACE* REQUEST 
 REQ2     SX7    PTRD        USE DEFAULT OF READ MODE 
          SA7    FET+CFMD 
 REQ3     SX1    X6-CCPG
          ZR     X1,PFN      IF  *PURGE* REQUEST
          SX1    X6-CCPM
          ZR     X1,PFN      IF  *PERMIT* REQUEST 
          SX1    X6-CCCG
          NZ     X1,LFN      IF NOT *CHANGE* REQUEST
          MX6    42          DO NOT CHANGE PASSWORD UNLESS SPECIFIED
          SA1    FET+CFPW 
          BX6    X6+X1
          SA6    A1 
          SA0    A0+B1
          SA1    A0 
          ZR     X1,PCE      IF NO NEW NAME DECLARED
          RJ     LCP
          RJ     ZFN         ZERO FILL NEW FILE NAME
          SA6    FET+CFNF 
          EQ     PFN         PROCESS PERMANENT FILE NAME PARAMETER
  
**        LFN - PROCESS LOCAL FILE NAME/UNIT DESIGNATOR.
  
 LFN      SA0    A0+B1       GET LOCAL FILE PARAMETER 
          SA1    A0 
          ZR     X1,PCE      IF LFN WAS NOT DECLARED
          RJ     LCP
          ZR     X1,PFN      IF LFN NOT PROGRAM FILE
          MX0    42 
          BX2    X0*X1
          NZ     X2,LFN1     IF NAME DESIGNATED FILE
          SA1    A0 
          MX0    1
          BX1    X0+X1
+         RJ     =YGETFIT.   GET PROGRAM *FIT* ADDRESS
-         VFD    12/0,18/TRACE
          SA1    X1 
          MX0    42 
          BX1    X0*X1
 LFN1     RJ     ZFN         DELETE BLANKS FROM NAME
          SX1    B1 
          BX7    X6+X1
          SA7    FET         SET *FET* STATUS NOT BUSY
  
**        PFN - PROCESS PERMANENT FILE NAME PARAMETER.
  
 PFN      SA0    A0+B1       GET PERMANENT FILE NAME
          SA1    A0 
          ZR     X1,PRO      IF NO PFN SPECIFICATION
          RJ     LCP
          RJ     ZFN         ZERO FILL ALPHANUMERIC 
          SA1    FET+CFPN 
          BX7    X6+X1
          SA7    A1 
  
**        OPT - PROCESS OPTIONAL PARAMETERS.
  
 OPT      SA0    A0+B1
          SA1    A0 
          ZR     X1,PRO      IF END OF USER OPTIONS 
          RJ     LCP
          ZR     X1,PRO      IF END OF USER OPTIONS 
          RJ     ZFN
          MX0    12 
          SA2    TOPT-1 
 OPT1     SA2    A2+B1
          ZR     X2,PCE      IF NOT A VALID OPTION
          BX3    X6-X2
          BX3    X0*X3
          NZ     X3,OPT1     IF NO TABLE COMPARISION
          SB2    X2 
          BX6    X2 
          SA6    OPTION 
          SA3    ACCESS 
          SB3    X3-24D 
          LX3    X2,-B3 
          PL     X3,CIP      IF NOT VALID KEYWORD 
          SA0    A0+B1
          SA1    A0 
          ZR     X1,PCE      IF NOT PROPERLY PAIRED 
          SB4    2
          NE     B2,B4,OPT2  IF KEYWORD DATA NOT IGNORED
          SX6    B1 
          EQ     OPT4        IGNORE KEYWORD DATA
  
 OPT2     BX6    X1 
          SB4    B4+B4
          EQ     B2,B4,OPT4  IF RETURN CODE ADDRESS 
          SB4    B4-B1
          EQ     B2,B4,OPT7  IF OPTION IS TYPE 3
          RJ     LCP
          RJ     ZFN         ZERO FILL ALPHANUMERIC 
          NG     B2,OPT2.1   IF SPECIAL PROCESSOR REQUIRED
          ZR     B2,OPT4     IF KEYWORD DATA OPTION 
          NE     B1,B2,OPT3  IF TABLE SEARCH OPTION 
          SB7    B1 
          BX5    X6 
          RJ     =XDXB=      DISPLAY CODE TO BINARY 
          EQ     OPT4        SET FIELD IN *FET* 
  
 OPT2.1   SB2    -B2
          JP     B2          JUMP TO SPECIAL COMMAND PROCESSOR
  
 OPT3     SA1    B2 
          MX0    42 
          ZR     X1,PCE      IF NOT PROPERLY PAIRED 
          BX3    X6-X1
          BX3    X0*X3
          SB2    B2+B1
          NZ     X3,OPT3     IF NOT THIS TABLE ITEM 
          SX6    X1 
 OPT4     SA2    OPTION      *FET* CONFIGURATION DATA 
          SB2    X2 
          AX2    18 
          MX0    -6 
          BX3    -X0*X2 
          SB3    X3          (B3) = LENGTH OF FIELD 
          AX2    6
          BX3    -X0*X2 
          SB4    X3          (B4) = LOWER BIT OF FIELD
          AX2    6
          BX2    -X0*X2 
          SA2    FET+X2 
          NZ     B2,OPT5     IF NOT LEFT JUSTIFIED
          LX6    B3,X6
 OPT5     SB2    B3-59       MERGE OPTION IN FIELD
          MX4    0
          EQ     B1,B2,OPT6  IF LENGTH .EQ. 60
          MX4    1
          AX4    -B2         GENERATE MASK
 OPT6     LX4    B4 
          LX6    B4 
          BX2    X4*X2
          BX6    -X4*X6 
          BX6    X2+X6
          SA6    A2 
          EQ     OPT         CHECK FOR NEXT OPTION
  
 OPT7     SA2    OPTION      GET FET OFFSET 
          AX2    30 
          MX0    -6 
          BX2    -X0*X2 
          SA6    FET+X2      STORE VARIABLE DESCRIPTOR WORD 
          EQ     OPT         CHECK FOR NEXT OPTION
  
 WFA      ROLLOUT TEVENT     WAIT FOR FILE AVAILABILITY 
  
**        PRO - PROCESS THE PERMANENT FILE REQUEST. 
  
 PRO      SA1    ICTR        CHECK UNUSED PARAMETERS COUNT
          ZR     X1,PRO0     IF NO UNUSED PARAMETERS
          SA1    XRIU 
          NZ     X1,PRO0     IF IGNORING UNUSED PARAMETERS
          SA1    EADR 
          EQ     PCE         PROCESS INVALID PARAMETER ERROR
  
 PRO0     SA2    FET+CFSN 
          SA3    FET+CFPN 
          MX0    42 
          BX2    X0*X2
          SA1    ACCESS      FETCH REQUEST FUNCTION 
          NZ     X2,PRO1     IF LOCAL NAME DECLARED 
          BX6    X0*X3       ASSUME *LFN* = *PFN* 
          SA6    A2 
 PRO1     SX2    X1-CCCG
          ZR     X2,PRO1.1   IF *CHANGE* COMMAND
          SX2    X1-CCPM
          ZR     X2,PRO1.1   IF *PERMIT* COMMAND
          SA2    FET+CFNF 
          MX6    -18
          BX2    -X6*X2      EXTRACT EXPIRATION DATE
          ZR     X2,PRO1.1   IF NO EXPIRATION DATE
          SA2    FET+CFPW 
          BX2    X6*X2       EXTRACT PASSWORD 
          ZR     X2,PCE      IF EXPIRATION DATE BUT NO PASSWORD 
 PRO1.1   SA2    XRCW        CHECK FOR *UCW* OPTION 
          ZR     X2,PRO3     IF NO USER CONTROL WORD
          SX6    X1-CCSV
          ZR     X6,PRO2     IF SAVE *UCW* FUNCTION 
          SX6    X1-CCDF
          NZ     X6,PRO3     IF NOT *DEFINE* FUNCTION 
 PRO2     SA3    X2 
          SA6    A2          CLEAR ADDRESS OF *UCW* 
          MX6    1
          BX6    X6+X3
          SA6    FET+CFUC 
 PRO3     LX1    6
          SYSTEM PFM,RECALL,FET,X1
          SA1    XRCW 
          ZR     X1,END      IF NO USER CONTROL WORD
          SA2    FET+CFUC 
          BX6    X2 
          NG     X1,PRO4     IF ECS/LCM ADDRESS 
          SA6    X1 
          EQ     END         NOT ECS/LCM ADDRESS
  
 PRO4     WX6    X1 
  
**        END - PROCESS ERRORS AND/OR EXIT PF ROUTINE.
  
 END      SA1    FET         CHECK REQUEST COMPLETION 
          LX1    60-10
          MX0    -8 
          BX6    -X0*X1 
 END0     SB2    X6-/ERRMSG/FBS 
          SA2    XRNA 
          NZ     B2,END1     IF DIRECT FILE NOT BUSY
          ZR     X2,WFA      IF NO *NA* OPTION PRESENT
 END1     SA3    XRRC 
          ZR     X3,END3     IF NO *RC* RETURN ADDRESS
          NG     X3,END2     IF ECS/LCM ADDRESS 
          SA6    X3 
          EQ     END3        NOT ECS/LCM ADDRESS
  
 END2     WX6    X3 
 END3     SA4    XRRR 
          ZR     X4,END5     IF NO *RRC* RETURN ADDRESS 
          PX6    X6 
          NX6    X6 
          NG     X4,END4     IF ECS/LCM ADDRESS 
          SA6    X4 
          EQ     END5        NOT ECS/LCM ADDRESS
  
 END4     WX6    X4 
 END5     ZR     X6,END8     IF FUNCTION SUCCESSFUL 
          BX7    X3+X4
          NG     X6,END6     IF DETECTED CALL ERRORS
          NZ     X7,END8     IF RETURN CODES PRESENT
          BX1    X6 
          RJ     =XCOD=      BINARY TO OCTAL DISPLAY
          SA1    PCEA 
          MX0    42 
          BX1    X0*X1
          BX6    -X0*X6 
          BX6    X1+X6
          SA6    PFEC 
          SA1    A6 
 END6     MESSAGE A1,3,R     USER-S DAYFILE MESSAGE 
          SA1    XRNA 
          NZ     X1,END8     IF *NA* SPECIFIED
          SA1    XREM 
          ZR     X1,END7     IF *EM* PARAMETER NOT SPECIFIED
          RJ     MCM         MOVE *PFM* ERROR MESSAGE INTO *EM* 
 END7     ABORT 
  
 END8     SA1    XRIU        CHECK *IUP*
          ZR     X1,END9     IF NOT IGNORING UNUSED PARAMETERS
          SA2    ICTR        RETURN IGNORED PARAMETER COUNT 
          BX6    X2 
          SA6    X1 
 END9     SA1    XREM 
          ZR     X1,END10    IF *EM* NOT SPECIFIED
          RJ     MCM         MOVE *PFM* ERROR MESSAGE INTO *EM* 
 END10    SA2    TEMPA0      RESTORE (A0) ON ENTRY
          SA0    X2 
          EQ     PF          EXIT 
          TITLE  SUBROUTINES. 
 CIP      SPACE  4,15 
**        CIP - COUNT IGNORED PARAMETERS. 
* 
*         ENTRY  (X1) = PARAMETER IGNORED (IN DISPLAY CODE).
*                (A0) = ADDRESS OF CURRENT PARAMETER. 
* 
*         EXIT   (X1) = NEXT PARAMETER VALUE. 
*                (ICTR) INCREMENTED.
*                TO *OPT* TO CHECK FOR NEXT OPTION. 
*                TO *PCE* IF END OF PARAMETER LIST. 
* 
*         USES   X - 1, 6.
*                A - 0, 1, 6. 
  
  
 CIP      BSS    0           ENTRY
          BX6    X1          SAVE PARAMETER 
          SA6    EADR 
          SA1    ICTR        REPLACE NEW VALUE
          SX6    X1+B1       INCREMENT COUNTER
          SA6    A1 
          SA0    A0+B1
          SA1    A0          GET NEXT PARAMETER VALUE 
          ZR     X1,PCE      IF AT END OF PARAMETER LIST
          EQ     OPT         CHECK FOR NEXT OPTION
 LCP      SPACE  4,10 
**        LCP - LOAD CHARACTER PARAMETER. 
* 
*         ENTRY  (X1) = PARAMETER ADDRESS.
*                (B1) = 1.
* 
*         EXIT   (X1) = PARAMETER VALUE.  IF THE PARAMETER IS *FTN5*
*                       TYPE CHARACTER DATA, IT IS LEFT JUSTIFIED WITH
*                       ZERO FILL.
* 
*         USES   X - 0, 1, 2, 3.
*                A - 1, 3.
*                B - 4, 5, 6. 
  
 LCP      EQ     *+1S17      ENTRY/EXIT 
          LX1    30          EXTRACT CHARACTER LENGTH 
          SB4    X1 
          ZR     B4,LCP6     IF NOT *FTN5* CHARACTER DATA 
          LX1    6           EXTRACT CHARACTER POSITION 
          MX0    -6 
          BX3    -X0*X1 
          LX1    24          GET FIRST WORD OF PARAMETER
          MX0    -25
          LX0    -1 
          BX1    -X0*X1 
          NG     X1,LCP1     IF ECS/LCM ADDRESS 
          SA2    X1 
          EQ     LCP2        NOT ECS/LCM ADDRESS
  
 LCP1     RX2    X1 
 LCP2     SB6    X3          (B6) = CHARACTER POSITION
          SX0    B1          INCREMENT PARAMETER ADDRESS
          IX1    X1+X0
          MX0    0
          ZR     B6,LCP3     IF POSITION .EQ. ZERO
          SB5    B6+B6       CALCULATE BIT POSITION OF STRING 
          SB6    B5+B5
          SB6    B5+B6       (B6) = BIT POSITION
          MX0    1           EXTRACT STRING FROM FIRST WORD 
          SB5    B6-B1
          AX0    B5 
          BX2    -X0*X2 
          LX2    B6 
 LCP3     NG     X1,LCP4     IF ECS/LCM ADDRESS 
          SA1    X1 
          EQ     LCP5        NOT ECS/LCM ADDRESS
  
 LCP4     RX1    X1 
 LCP5     BX1    X0*X1       EXTRACT STRING FROM SECOND WORD
          LX1    B6 
          BX1    X1+X2       MERGE STRINGS
          SB5    10 
          GE     B4,B5,LCP   IF LENGTH .GE. 10, RETURN
          SB5    B4+B4       CALCULATE BIT LENGTH OF STRING 
          SB6    B5+B5
          SB6    B5+B6
          SB6    B6-B1       (B6) = BIT LENGTH - 1
          MX2    1           ZERO FILL PARAMETER
          AX2    B6 
          BX1    X2*X1
          EQ     LCP         RETURN 
  
 LCP6     LX1    -30
          NG     X1,LCP7     IF ECS/LCM ADDRESS 
          SA1    X1 
          EQ     LCP         RETURN 
  
 LCP7     RX1    X1 
          EQ     LCP         RETURN 
  
 MCM      SPACE  4,15 
**        MCM - MOVE CHARACTER MESSAGE. 
* 
*         ENTRY  (X1) = FTN5 DESCRIPTOR OF VARIABLE TO RECEIVE MESSAGE. 
*                       BITS 47-30 = VARIABLE LENGTH, IN CHARACTERS.
*                            VALUE IS ZERO IF NOT CHARACTER VARIABLE. 
*                       BITS 27-24 = BEGINNING CHARACTER POSITION,
*                            0 BEING LEFTMOST CHARACTER.
*                       BITS 23-0  = FIRST WORD ADDRESS OF VARIABLE.
* 
* 
*         EXIT   MESSAGE MOVED TO VARIABLE. 
* 
*         USES   X - ALL. 
*                A - 2, 3, 4, 6.
*                B - 5, 6, 7. 
  
  
 MCM      EQ     *+1S17      ENTRY/EXIT 
          SA2    X1          VALUE OF VARIABLE
          LX1    30 
          SB5    X1          CHARACTER LENGTH OF VARIABLE 
          GT     B5,B0,MCM1  IF CHARACTER LENGTH PRESENT
          SA3    XREL        GET CHARACTER LENGTH (*EL* PARAMETER)
          SX0    B0          SET BEGINNING CHARACTER POSITION (BCP) 
          SB5    X3 
          NZ     X3,MCM2     IF CHARACTER LENGTH SPECIFIED
          SB5    10          SET DEFAULT CHARACTER LENGTH 
          EQ     MCM2        CONTINUE 
  
 MCM1     LX1    6
          MX0    -6 
          BX0    -X0*X1      BEGINNING CHARACTER POSITION 
 MCM2     SA3    PFMA        GET *PFM* MESSAGE
          SA1    BLANKS 
          BX1    X1-X3
          ZR     X1,MCM      IF BLANK MESSAGE 
          SB6    40          MAXIMUM MESSAGE LENGTH 
          GT     B6,B5,MCM3  IF NOT TOO LONG
          SB5    B6          RESET LENGTH TO MAXIMUM
 MCM3     SB6    X0          CALCULATE BIT POSITION (6*BCP) 
          SB7    B6+B6
          SB6    B7+B7
          SB6    B6+B7       BIT POSITON
          SB7    60 
          SB6    B7-B6       SHIFT COUNT FOR MASK 
          SB7    B0          BCP FOR *PFM* MESSAGE
          MX1    6
          LX0    B6,X1       POSITION MASK FOR DESTINATION WORD 
          BX6    X2          ORIGINAL VALUE OF VARIABLE 
          SA4    BLANKS 
          BX4    X4*X1       SET BLANK CHARACTER
 MCM4     BX5    X1*X3       GET NEW CHARACTER
          BX7    X5 
          NZ     X7,MCM5     IF NOT 00 CHARACTER
          BX5    X4          REPLACE WITH BLANK 
 MCM5     BX6    -X0*X6      REMOVE OLD CHARACTER 
          LX5    B6,X5       POSITION SOURCE CHARACTER
          BX6    X5+X6       ADD CHARACTER TO DESTINATION WORD
          SB5    B5-B1
          ZR     B5,MCM9     IF DONE
          LX1    -6 
          LX4    -6          POSITION MASKS FOR NEXT CHARACTER
          NG     X1,MCM7     IF END OF SOURCE WORD
 MCM6     LX0    -6 
          NG     X0,MCM8     IF END OF DESTINATION WORD 
          EQ     MCM4        CONTINUE WITH NEXT CHARACTER 
  
 MCM7     SA3    A3+B1       FETCH NEXT SOURCE WORD 
          EQ     MCM6        CHECK DESTINATION WORD 
  
 MCM8     SA6    A2          REPLACE UPDATED DESTINATION WORD 
          SA2    A2+B1       GET NEXT DESTINATION WORD
          BX6    X2 
          EQ     MCM4        CONTINUE WITH NEXT CHARACTER 
  
 MCM9     SA6    A2          REPLACE LAST DESTINATION WORD
          EQ     MCM         RETURN 
 PCE      SPACE  4,10 
**        PCE - PROCESS CALL ERROR. 
* 
*         ENTRY  (A0) = ADDRESS OF CURRENT POSITION IN PARAMETER
*                       LIST. 
*                (X1) = 0, PARAMETER NAME NOT PROVIDED. 
*                     = NONZERO VALUE, ASSUMED TO BE THE CURRENT
*                       PARAMETER IN DISPLAY CODE.
* 
*         EXIT   (X6) = -1. 
*                (A1) = ADDRESS OF ERROR MESSAGE. 
* 
*         USES   X - 1, 6, 7. 
*                A - 1, 7.
*                B - NONE.
  
  
 PCE      NZ     X1,PCE2     IF PARAMETER NAME PROVIDED 
          SA1    A0 
          ZR     X1,PCE1     IF END OF PARAMETER LIST 
          SA1    X1 
          NZ     X1,PCE2     IF NONZERO PARAMETER 
 PCE1     SA1    PCEB 
 PCE2     MX6    59 
          BX7    X1 
          SA7    PCEB 
          SA1    PCEA 
          EQ     END0        PROCESS USER CALL ERROR
  
 PCEA     DATA   30H PF NO.-1 INVALID PARAMETER - 
 PCEB     DATA   10H UNPAIRED.
          DATA   0
 PRD      SPACE  4,15 
**        PRD - PROCESS RESIDENCE DEFINITION. 
* 
*         ENTRY  (X6) = *R* PARAMETER.
* 
*         EXIT   TO *OPT4*. 
*                (X6) = VALIDATED PARAMETER.
*                UNIT COUNT (IF SPECIFIED) SET INTO FET+CFPK. 
* 
*         ERROR  TO *PCE* IF ERROR ENCOUNTERED. 
* 
*         USES   X - 0, 2, 3, 6, 7. 
*                A - 2, 3, 7. 
  
  
 PRD      BSS    0           ENTRY
          SA2    TRES-1      TABLE OF DEVICE TYPES
          MX0    -6          CONVERT UNIT COUNT 
          LX0    42 
          BX3    -X0*X6 
          ZR     X3,PRD1     IF NO UNIT COUNT SPECIFIED 
          LX0    -6 
          BX2    -X0*X6 
          NZ     X2,PCE      IF UNIT COUNT TOO LONG 
          LX3    -42
          SX2    X3-1R1 
          NG     X2,PCE      IF INCORRECT UNIT COUNT
          SX3    X3-1R9 
          PL     X3,PCE      IF INCORRECT UNIT COUNT
          SA3    FET+CFPK    SET UNIT COUNT INTO FET
          SX2    X2+B1
          MX0    42 
          BX3    X0*X3
          BX7    X3+X2
          SA7    A3+
  
*         SEARCH FOR DEVICE TYPE IN TABLE.
  
 PRD1     SA2    A2+B1
          MX0    12 
          ZR     X2,PCE      IF DEVICE TYPE NOT FOUND IN TABLE
          BX3    X6-X2
          BX3    X0*X3
          NZ     X3,PRD1     IF NOT THIS TABLE ITEM 
          SX6    X2 
          EQ     OPT4        PUT ENTRY INTO FET 
 PXD      SPACE  4,15 
**        PXD - PROCESS EXPIRATION DATE.
* 
*         ENTRY  (X6) = *XD* PARAMETER. 
*                (XFLAG) = NON-ZERO IF *XD* OR *XT* ALREADY USED. 
* 
*         EXIT   TO *OPT4*. 
*                (X6) = VALIDATED PARAMETER.
* 
*         ERROR  TO *PCE* IF ERROR ENCOUNTERED. 
* 
*         USES   X - 1, 2, 4, 6, 7. 
*                A - 2, 7.
*                B - NONE.
* 
*         CALLS  VDT. 
* 
*         MACROS NONE.
  
  
 PXD      BSS    0           ENTRY
          SA2    XFLAG
          NZ     X2,PCE      IF *XD* OR *XT* ALREADY SPECIFIED
          SX7    B1 
          SA7    A2          SET PARAMETER SPECIFIED
          BX1    X6 
          LX6    6
          SX4    X6-1R* 
          NZ     X4,PXD1     IF NOT ASTERISK
          SX6    7777B       SET NO EXPIRATION DATE 
          EQ     OPT4        PUT ENTRY IN FET 
  
 PXD1     SX2    B0 
          RJ     VDT         CONVERT DATE 
          NG     X1,PXD2     IF DATE BEFORE TODAY 
          NG     X6,PXD2     IF ERROR IN CONVERSION 
          EQ     OPT4        PUT ENTRY IN FET 
  
 PXD2     BX1    X1-X1
          EQ     PCE         PROCESS ERROR
 PXT      SPACE  4,20 
**        PXT - PROCESS EXPIRATION TERM.
* 
*         ENTRY  (X6) = *XT* PARAMETER. 
*                (XFLAG) = NON-ZERO IF *XD* OR *XT* ALREADY USED. 
* 
*         EXIT   TO *OPT4*. 
*                (X6) = VALIDATED *XT* PARAMETER. 
* 
*         ERROR  TO *PCE* IF ERROR ENCOUNTERED. 
* 
*         USES   X - 1, 2, 4, 5, 6, 7.
*                A - 2, 7.
*                B - 2, 7.
* 
*         CALLS  =XDXB=.
* 
*         MACROS PDATE. 
  
  
 PXT      BSS    0           ENTRY
          SA2    XFLAG
          NZ     X2,PCE      IF *XD* OR *XT* ALREADY SPECIFIED
          SX7    B1 
          SA7    A2          SET PARAMETER SPECIFIED
          BX5    X6 
          LX6    6
          SX4    X6-1R* 
          NZ     X4,PXT1     IF NOT ASTERISK
          SX6    7777B       NO EXPIRATION DATE 
          EQ     OPT4        PUT ENTRY IN FET 
  
 PXT1     SX2    X6-1R0 
          NZ     X2,PXT2     IF NOT IMMEDIATE EXPIRATION
          PDATE  XDATE       GET CURRENT DATE 
          SA2    XDATE
          AX2    18 
          BX6    X2 
          EQ     OPT4        PUT ENTRY IN FET 
  
 PXT2     SB7    B1 
          RJ     =XDXB=      CONVERT TO BINARY
          NZ     X4,PXT3     IF ERROR IN CONVERSION 
          SB2    X6-7777B 
          GT     B2,PXT3     IF EXPIRATION TERM IS TOO LARGE
          EQ     OPT4        PUT ENTRY IN FET 
  
 PXT3     BX1    X1-X1
          EQ     PCE         PROCESS ERROR
 ZFN      SPACE  4,10 
**        ZFN - DELETE TRAILING BLANKS FROM WORD. 
* 
*         ENTRY  (X1) = WORD TO DELETE BLANKS FROM (LEFT JUSTIFIED).
* 
*         EXIT   (X6) = WORD WITH TRAILING BLANKS DELETED.
* 
*         USES   X - 0, 2, 3, 6.
  
  
 ZFN      EQ     *+1S17      ENTRY/EXIT 
          SX0    1R          BLANK CHARACTER
          MX2    -6 
          BX6    X1 
 ZFN1     BX3    -X2*X6 
          ZR     X3,ZFN2     IF ZERO CHARACTER
          BX3    X3-X0       CHECK FOR BLANK
          NZ     X3,ZFN      IF NOT *00* OR * * 
 ZFN2     BX6    X2*X6       CLEAR BLANK
          LX2    6
          LX0    6
          NZ     X6,ZFN1     IF NOT END OF WORD 
          EQ     ZFN         RETURN 
          SPACE  4,10 
*         COMMON DECKS. 
  
*CALL     COMCDXB 
*CALL     COMCVDT 
          SPACE  4,10 
          END 
          IDENT  GETPAGE
          ENTRY  GETPAGE
          SYSCOM B1 
          TITLE  GETPAGE - GET PAGE PARAMETERS. 
*COMMENT  CPUREL - GET PAGE PARAMETERS. 
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC.  1992. 
*CALL     COMCMAC 
 GETPAGE  SPACE  4,10 
***       GETPAGE - GET PAGE PARAMETERS.
* 
*         A. SKJOLDEBRAND.   82/11/21.
          SPACE  4,10 
***       *GETPAGE* PROVIDES AN INTERFACE TO ALLOW GETTING THE
*         JOB AND SYSTEM PAGE PARAMETERS FOR PROGRAMS 
*         WRITTEN IN HIGHER LEVEL LANGUAGES.
          SPACE  4,30 
***       COMMAND FORMAT. 
* 
*         FORTRAN CALL -
* 
*         CALL GETPAGE(ARRAY) 
* 
*         SYMPL CALL -
* 
*         GETPAGE(ARRAY); 
* 
* 
*         ENTRY  (ARRAY) = A 6 WORD ARRAY TO RECEIVE THE RESPONSE.
* 
*         EXIT   (ARRAY) = PAGE PARAMETERS (RIGHT JUSTIFIED). 
*                ARRAY(1) = JOB PRINT DENSITY ( 6 OR 8 ). 
*                ARRAY(2) = JOB PAGE SIZE ( 16 - 255 ). 
*                ARRAY(3) = JOB PAGE WIDTH ( 40 - 255 ).
*                ARRAY(4) = SYSTEM PRINT DENSITY (6 OR 8).
*                ARRAY(5) = SYSTEM PAGE SIZE (16-255).
*                ARRAY(6) = SYSTEM PAGE WIDTH (40-255). 
  
  
 GETPAGE  BSS    0
 GPG      SUBR               ENTRY/EXIT 
          SB1    1
          SB7    X1          SAVE  PARAMETER BLOCK
          GETPAGE  GPGA      GET PAGE PARAMETERS
          SB2    B1 
          SA1    GPGA        GET JOB PAGE PARAMETERS
 GPG1     MX0    -4 
          LX1    0-28        POSITION PRINT DENSITY 
          BX6    -X0*X1 
          SA6    B7          SET PRINT DENSITY RESPONSE 
          MX0    -8 
          LX1    8           POSITION PAGE SIZE 
          BX6    -X0*X1 
          SA6    A6+B1       SET PAGE SIZE RESPONSE 
          LX1    8           POSITION PAGE WIDTH
          BX6    -X0*X1 
          SA6    A6+B1       SET PAGE WIDTH RESPONSE
          ZR     B2,GPGX     IF END OF PARAMETERS 
          SB2    B2-B1
          SA1    A1+B1
          SB7    A6+B1
          EQ     GPG1        GET SYSTEM PAGE PARAMETERS 
  
  
 GPGA     BSS    2           *GETPAGE* RESPONSE BLOCK 
          SPACE  4,10 
          END 
          IDENT  SETPAGE
          ENTRY  SETPAGE
          SYSCOM B1 
          TITLE  SETPAGE - SET PAGE PARAMETERS. 
*COMMENT  CPUREL - SET PAGE PARAMETERS. 
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC.  1992. 
*CALL     COMCMAC 
 SETPAGE  SPACE  4,10 
***       SETPAGE - SET PAGE PARAMETERS.
* 
*         A. SKJOLDEBRAND.   82/11/21.
          SPACE  4,10 
***       *SETPAGE* PROVIDES AN INTERFACE TO ALLOW SETTING THE JOB
*         PAGE PARAMETERS FOR PROGRAMS WRITTEN IN HIGHER LEVEL
*         LANGUAGES.
          SPACE  4,30 
***       COMMAND FORMAT. 
* 
*         FORTRAN CALL -
* 
*         CALL SETPAGE(ARRAY) 
* 
*         SYMPL CALL -
* 
*         SETPAGE(ARRAY); 
* 
* 
*         ENTRY  (ARRAY) = PAGE PARAMETERS (RIGHT JUSTIFIED). 
*                ARRAY(1) = JOB PRINT DENSITY ( 6 OR 8 ). 
*                ARRAY(2) = JOB PAGE SIZE ( 16 - 255 ). 
*                ARRAY(3) = JOB PAGE WIDTH ( 40 - 255 ).
* 
*                IF ARRAY(N) .LT. 0 CURRENT JOB VALUES WILL BE USED.
* 
*         EXIT   PAGE SIZE PARAMETERS SET FOR JOB.
  
 SETPAGE  BSS    0
 SPG      SUBR               ENTRY/EXIT 
          SB1    1
          SB7    X1+         SAVE PARAMETER BLOCK ADDRESS 
          GETPAGE  SPGA      GET CURRENT JOB VALUES 
          SA3    SPGA 
          RJ     MPP         MERGE USER AND CURRENT JOB VALUES
 SPG1     SA6    SPGA 
          SETPAGE  A6 
          EQ     SPGX        RETURN 
  
  
 SPGA     BSS    2           RESPONSE BLOCK 
 MPP      SPACE  4,15        *GETPAGE*/*SETPAGE*
**        MPP - MERGE PAGE PARAMETERS.
* 
*         ENTRY  (X3) = CURRENT JOB PAGE PARAMETERS.
*                (B7) = ADDRESS OF USER LIST OF PAGE PARAMETERS.
* 
*         EXIT   (X6) = *SETPAGE* REQUEST WORD. 
* 
*         USES   X - 0, 1, 2, 3, 6. 
*                A - 1, 2.
  
  
 MPP      SUBR               ENTRY/EXIT 
          MX0    -4          MASK FOR PRINT DENSITY 
          LX3    0-28 
          SA1    B7          GET USER PRINT DENSITY 
          PL     X1,MPP1     IF USER VALUE SPECIFIED
          BX1    -X0*X3      USE CURRENT JOB PRINT DENSITY
 MPP1     LX1    8
          SA2    A1+B1       GET PAGE SIZE PARAMETER
          LX3    8
          MX0    -8 
          PL     X2,MPP2     IF USER VALUE SPECIFIED
          BX2    -X0*X3      USE CURRENT JOB PAGE SIZE
 MPP2     BX6    X1+X2       MERGE PRINT DENSITY AND PAGE SIZE
          LX3    8
          SA1    A2+B1       GET PAGE WIDTH PARAMETER 
          LX6    8
          PL     X1,MPP3     IF USER VALUE SPECIFIED
          BX1    -X0*X3      USE CURRENT JOB PAGE WIDTH 
 MPP3     BX6    X1+X6       ADD IN PAGE WIDTH
          LX6    12D         POSITION *SETPAGE* PARAMETER BLOCK 
          EQ     MPPX        RETURN 
          SPACE  4,10 
          END 
