Retro1.org codex

          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