*M*      TEL      TERMINAL EXECUTIVE LANGUAGE
         SYSTEM   SIG7FDP
UTSPROC  SET      0
S69PROC  SET      1
         SYSTEM   UTS
*
* THE SYMBOL 'A' IS USED FOR ASSEMBLY CONTROL. WHEN SET TO TWO, A TEST
* ENVIRONMENT ASSEMBLY RESULTS. SETTING 'A' TO ONE YIELDS AN ASSEMBLY
* SUITABLE FOR INCLUSION IN A REAL UTS SYSTEM.
*
A        SET      1
         DO       A=1
         REF      M:UC
       REF     J:AMR
         REF      M:XX
         REF      J:JIT
JIT      EQU      J:JIT
         REF      JACCN
         REF      JUNAME
         REF      JOPT
         REF      J:LMN
         REF      J:ABUF
         REF      J:START
         REF      J:ABC
         REF      J:INTENT
         REF      INTENT
         REF      J:USENT
         REF      J:TELFLGS
         REF      ERRMSGE
         REF      ERO
         REF      JPUF
         REF      JRNST
         REF      JTELFLGS          FLAGS UNIQUE FOR TEL
         REF      JABC              ERROR CODE FOR LAST MAJOR OPERATION
         REF      JASSIGN           WORD 20 OF JIT
         REF      JCPPO             WORD 23
         REF      UTS
         REF      JPLL,J:PLL,JPUL,JDDLL,J:DDLL,JDDUL,J:DDUL
         REF      DCBLINK
         REF      J:DCBLINK
         REF      J:DLL,JDUL
         REF,1    JBPCP
JBPCD    EQU   JBPCP+1                                               RL2
         REF      J:BUP
         REF      JB:LMAP
         REF      SBUF1VPA          SPECIAL WINDOW BUFFERS,
         REF      SBUF2VPA          DEFINED IN JIT
         REF      JSBUF1VP          PAGE NUMBER OF SBUF1
         REF      JB:VLH
         REF,1    JB:FRS
         REF      :LOGSZ            :USERS REC. SIZE
         REF      JJITVP
         REF      J:CPROCS
         REF      J:CFLGS
         REF      J:CLM
TSTACK   EQU      UTS
         REF     JBUP
         REF     JEUP
         REF     J:EUP
         REF     J:CPPO
         REF      J:EXLY
         REF      J:PUL
         REF,2    JH:PC
         REF,1    JBPCDD
         REF,1    JBTDP
         REF,1    JBBCP
         REF,1    JB:PCDCB
         REF      JDLL
         REF      J:ALB
         REF      J:DUL
         REF      J:CCBUF
         REF      JSTDOPT
         REF,1    JB:LPP
         REF,1    JB:PROMPT
       REF,1   JB:PCW
         REF      JRESOPT
         REF      J:ASSIGN
         REF      PRDCRM
         REF      PRDPRM
         REF      CDPO
         REF     CIC
         REF      CPO
         REF   CPPO
         REF      CUPO
         REF      J:CALCNT
         REF      J:INTER
         REF     J:PTIME
         REF      J:UTIME
         REF      TPIOT
         REF      TUIOT
         REF      J:DCBLL
         REF      J:DCBUL
         REF      JBUPVP,JEUPVP,JCMAP,JBVLH,JLMAP
         REF      J:CLL
AMBUF    EQU      SBUF2VPA          DEFINE WINDOW FOR A/M RECORD
         ELSE
*
*** BEGIN DEBUG-ONLY SYMBOLS
*
JACCN    EQU      1
JUNAME   EQU      3
JOPT     EQU      8
JB:PCW   EQU      BA(J:JIT+9)
JRNST    EQU      13
JTELFLGS EQU      14
J:TELFLGS EQU     JTELFLGS+J:JIT
JABC     EQU      15
J:ABC    EQU      JABC+J:JIT
JASSIGN  EQU      17
JCPPO    EQU      18
JSTDOPT  EQU      19
JRESOPT  EQU      20
JPUF     EQU      21
:LOGSZ   EQU      126
SBUF1VPA EQU      X'C000'           USE ARBITRARY PAGE FOR DEBUG
JSBUF1VP EQU      SBUF1VPA**-9
         DEF      J:JIT
         REF      M:EI
         REF      M:EO
         REF      M:XX
M:UC     EQU      M:EI
AMBUF    EQU      MERTAB
*
*** END DEBUG-ONLY SYMBOLS
*
         FIN
         REF      OV:NMSZ,OH:NM,TYPMNSZ
         REF      SV:RSIZ,SH:RNM,SB:RTY,TB:FLGS
         REF      SV:LSIZ,SH:LNM
         REF      JX:CMAP           FOR SBUF CHECK
         REF      WRITERR,WRITERR1
         REF      FPMC
         DEF      TEL
         DEF      PATCH
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
SR1      EQU      8
SR2      EQU      9
SR3      EQU      10
SR4      EQU      11
D1       EQU      12
D2       EQU      13
D3       EQU      14
D4       EQU      15
VERSCELL EQU      X'2B'             MONITOR TYPE CELL
ARS      EQU      M:UC+4
TELSTACK EQU      SBUF1VPA          DEFINE WINDOW FOR STACK
TELBUF   EQU      TELSTACK+2        BUFFER LIVES IN STACK AT FRONT
M17      EQU      X'1FFFF'
SETBUF   EQU      TELSTACK+256
SETBUFE  EQU      TELSTACK+511
SETBUFSZ EQU      SETBUFE-SETBUF
I38      EQU      38+2              38+SPD
I39      EQU      39+2              39+SPD
I40      EQU      40+2              40+SPD
SZCELL   EQU      TELSTACK+I40
LOGSIZE  EQU      :LOGSZ
BACKFUL  EQU      X'7A'             BACKUP FULL
FORSEC   EQU      0                 SET TO 0 FOR ELAP TIME IN MIN
*
* LOWER CASE SYMBOL EQUIVALENTS
*
SA       EQU      X'81'
SB       EQU      X'82'
SC       EQU      X'83'
SD       EQU      X'84'
SE       EQU      X'85'
SF       EQU      X'86'
SG       EQU      X'87'
SH       EQU      X'88'
SI       EQU      X'89'
SJ       EQU      X'91'
SK       EQU      X'92'
SL       EQU      X'93'
SM       EQU      X'94'
SN       EQU      X'95'
SO       EQU      X'96'
SP       EQU      X'97'
SQ       EQU      X'98'
SR       EQU      X'99'
SS       EQU      X'A2'
ST       EQU      X'A3'
SU       EQU      X'A4'
SV       EQU      X'A5'
SW       EQU      X'A6'
SX       EQU      X'A7'
SY       EQU      X'A8'
SZ       EQU      X'A9'
S        EQU      X'40'
         PAGE
*
* PROC TO CHANGE STACK POINTER THE AMOUNT SPECIFIED BY THE 1ST ARGUMENT
* USING THE REGISTER SPECIFIED BY THE 2ND ARGUMENT.
*
BUMP     CNAME
         PROC
LF       LI,AF(2) AF(1)
         MSP,AF(2)  TELSTACK
         PEND
*
* PUSH OR PULL N WORDS SPECIFIED BY 1ST ARGUMENT INTO REGS STARTING
* AT 2ND ARGUMENT.
*
PUSH     CNAME    X'9',X'B'
PULL     CNAME    X'8',X'A'
         PROC
         DO       NUM(AF)=1
LF       GEN,1,7,4,3,17  0,NAME(1),AF(1),0,TELSTACK
         ELSE
         DO       AF(1)=1
LF       GEN,1,7,4,3,17  0,NAME(1),AF(2),0,TELSTACK
         ELSE
         DO       AF(1)=16
LF       LCI      0
         ELSE
LF       LCI      AF(1)
         FIN
         GEN,1,7,4,3,17  0,NAME(2),AF(2),0,TELSTACK
         FIN
         FIN
         PEND
         TITLE    'TEL-TERMINAL EXECUTIVE LANGUAGE'
* THE TEL PROCESSOR IS CHARGED WITH THE TASK OF INTERFACING WITH THE
* USER TERMINAL, RECOGNIZING AND ACTING UPON THE COMMANDS ISSUED BY THE
* PROGRAMMER AT THE TERMINAL. TEL MAINTAINS DEVICE AND FILE ASSIGNMENTS
* AS WELL AS INITIATING SUB-PROCESSES AS THE NEED MAY ARISE. TEL HAS
* ACCESS TO THE JOB INFORMATION TABLE(JIT) AND TO USER/SYSTEM DCB'S.
* TEL WILL PROVIDE ERROR AND LOGICAL DIAGNOSIS FOR EACH JOB STEP AS WELL
* AS NORMAL SYNTATICAL ERROR DETECTION.
*
* ENTRY IS MADE INITIALLY FROM THE LOGON PROCESSOR WITH JIT CONTAINING
* THE USERS' LINE NUMBER(SYSID), LOGON ID, ACCOUNT, AND PASSWORD.
* SUBSEQUENT ENTRIES TO TEL ARE MADE AS EACH SUB-PROCESSOR COMPLETES ITS
* ASSIGNED TASK.
*
* FINAL EXIT IS MADE TO THE LOGOFF PROCESSOR UPON RECEIVING AN 'OFF'
* COMMAND; AT THIS POINT THE ACCOUNTING REPORT IS PRODUCED AND THE JOB
* TERMINATING SEQUENCE IS PERFORMED.
*
*
         PAGE
*                 ******************************
*                 * JIT DATA BASES USED BY TEL *
*                 ******************************
*
*        J:TELFLGS, JTELFLGS
*
*  BIT            MEANS
*  X'1'           AT JOB STEP
*  X'2'           BREAK RECEIVED
*  X'4'           0=BUILD GO DCB;  1=BUILD LO DCB
*  X'8'           DO NOT RELEASE SI ENTRIES FROM A/M
*  X'10'          SI HAS BEEN ASSIGNED.  CHAIN REMAINING FIDS
*  X'20'          'ON' SPECIFIED
*  X'40'          'OVER' SPECIFIED
*  X'80'          'UNDER DELTA' SPECIFIED
*  X'100'         'UNDER FDP' SPECIFIED
*  X'200'         DEFAULT FOR % ROM IN PROGRESS
*  X'400'         UNIQUE 'COMMENT' COMMAND INDICATOR
*  X'800'         'LIST', 'OUTPUT', 'COMMENT' IN PROGRESS
*  X'1000'        'DONT' IN EFFECT
*  X'2000'        RE-PROCESS CURRENT BUFFER IMAGE
*  X'4000'        LMN WAS DETECTED BY START COMM. (SYSERR PROCESS)
*  X'8000'        AUTO-GET ASSOCIATION (SET BY LOGON)
*  X'10000'       AUTO-PROCESSOR ASSOCIATION  (SET BY LOGON)
*  X'20000'       ALLOW NO FOLLOWING MESSAGE TEXT
*  X'40000'       IMPLIED QUIT FLAG
*  X'80000'       UNDER DELTA IMPLIED FOR NEXT COMMAND
*  X'100000'      UNRECOGNIZED LOAD MODULE
*  X'200000'      USER REQUESTED EXTENDED MEMORY MODE
*  X'400000'      PROCESSING SINGLE USER ABORT (SET BY INITRCVR)
         SPACE    5
         DO       A>1
         CSECT    0
         ELSE
         CSECT    1
         FIN
*                                   OBTAIN DATA AREA
TEL    RES     0                                                     RL2
         LI,SR2   TELSTACK          GET FIRST SPECIAL BUFFER IN
         CAL1,8   GPFPT               CONTEXT AREA FOR TEL TEMP
         BCS,8    NOPAGE              STACK.  BR IF NO PAGE AVAIL
         AI,SR2   2
         STW,SR2  TELSTACK          INITIALIZE STACK POINTER DW
JENT     RES       0                                                 RL2
         LW,D1    =X'00FE0000'      254  WDS
*
         STW,D1   TELSTACK+1        SET STACK SIZE
         DO       A<2
         LW,D2    J:AMR             CHK IF A/M RECORD EXISTS
         BEZ      ERRABN1           IF NOT, LOG USER OFF
         ELSE
         FIN
         BUMP     55,D2
         LW,D2    JTELFLGS+J:JIT
         CI,D2    2
         BANZ     BREAKER           BREAK SET
         LB,R7    J:JIT+JABC        TEST STATUS OF LAST MAJOR COMMAND
         BNEZ     ERRABN
         LB,R7    J:JIT+JRNST       TEST IF RUN STATUS HAS BEEN SET
         BNEZ     SYSERR
SETUP    LI,R7    1
         STS,R7   J:JIT+JTELFLGS    SET JOB STEP FLAG
BUFINT   RES      0                 CHECK FOR VALID INFO
         LI,R7    X'2000'           IS CURRENT BUFFER VALID
         LS,R7    J:JIT+JTELFLGS
         BEZ      PROMPT            NO
         BAL,R0   CCBUFTEL                                              TEL
         LB,R1    J:JIT+JPUF        RESET ARS
         LI,D4    0                 CLEAR IMPLIED DELTA % OUIT FLAGS
         B        ITSOK
         PAGE
*
* TEL MUST ISSUE A PROMPT(!) BY GIVING COC A SINGLE CHARACTER WRITE.
*
PROMPT   LI,R1    RETN              PUT OUT LF/CR AND PROMPT
         LI,R2    2
         LCI      7                 SAVE M:UC DATA
         LM,SR1   M:UC
         PSM,SR1  TELSTACK
         CAL1,1   WRITE
         DO       A=1
         LW,SR2   =X'FFFD7EFF'      RESET MOD,DRC(TRNSP MODE) & VFC BITS
         LS,SR2   M:UC              BEFORE READING RESPONSE
         STW,SR2  M:UC
         FIN
PROMPTA  CAL1,1   READ              READ RESPONSE INTO TELBUF
         LW,R1    ARS               TEST TERMINATING CHARACTER FOR AN
         SLS,R1   -17               ESCAPE.
         CI,R1    0                 REISSUE READ IF ARS=0
         BE       PROMPTA
         LCI      7                 RESTORE M:UC DATA
         PLM,SR1  TELSTACK
         DO       A=1
         LCI      7
         STM,SR1  M:UC              M:UC
         FIN                                                         RL2
*
         LH,D4    J:TELFLGS         CHECK IF UNRECOGNZD LM DURING BREAK
         CI,D4    4                 OCCURED ON PREVIOUS COMMAND
         BAZ      PRMPT50           B IF NO
         AI,D4    -4                RESET IMPLIED QUIT FLAG IN
         STH,D4   J:TELFLGS         CURRENT FLAGS
         CI,R1    1                 1 CHAR RESPONSE TO "QUIT?"
         BNE      PRMPT50           B IF NO
         LB,D1    TELBUF            GET FIRST CHARACTER
         CI,D1    X'0D'             WAS IT A CARRIAGE RETURN
         BE       PRMPT20           B TO DO IMPLIED QUIT
         CI,D1    X'15'             WAS IT LINE FEED
         BNE      PRMPT50           B TO NORMAL PROCESSING
PRMPT20  EQU      %
         LW,R2    TELBUF+54         GET 1ST WORD OF PREV CMND
         STW,R2   TELBUF            RESTORE 1ST WORD
         LB,R1    J:JIT+JPUF        GET PREV ARS
         LI,D4    4                 INDICATE IMPLIED QUIT
         B        ITSOK10
*
PRMPT50  EQU      %
         LW,R2    R1
         AI,R2    -1
         LB,D1    TELBUF,R2         GET LINE TERMINATOR
         CI,D1    X'15'             IST IT LINE FEED
         BNE      %+2               B IF NO
         LI,D4    4                 SET IMPLIED QUIT FLAG
         STB,R1   J:JIT+JPUF        SAVE ORIGINAL ARS-1
ITSOK    LW,D1    J:JIT+JTELFLGS    RESET TEL WORKING FLAGS
         AND,D1   FLAGS
         STW,D1   J:JIT+JTELFLGS
         LW,D1    J:JIT+JSTDOPT     SAVE CURRENT CONTENTS OF OPTION
         STW,D1   J:JIT+JRESOPT     SPECIFICATIONS IN THE EVENT OF ABORT
         CI,D4    8                 CHECK IF PREVIOUS COMMAND WAS
         BAZ      ITSOK10           "UNDER DELTA", B IF NO
         LI,R7    X'80'             YES, SET "UNDER DELTA" FLAG
         STS,R7   J:TELFLGS         FOR THE CURRENT COMMAND
ITSOK10  EQU      %
*
* PICK-UP FIRST FIELD OF INPUT STATEMENT AND DECODE COMMAND VERB.
*
         LI,R2    0                 INITIALIZE BUFFER POSITION
NEXTTIME  RES     0                                                  RL2
         BAL,SR3  GETFIELD                                           RL2
         CI,R7    0                 INSURE DATA IS PRESENT
         BE       PROMPT            GO AGAIN IF NO COMMAND GIVEN
         CI,R6    '.'               DID A PERIOD TERMINATE THE FIELD--
         BNE      SCANCVT           NO, NOT A LOAD MODULE
         CI,R7    1                 DID FIELD CONTAIN MORE THAN I CHAR.
         BG       LMNCMD            YES, MUST BE A LMN.
         LB,SR4   D1                IMPLIES A LMN OR PCL COMMAND.
         CI,SR4   'L'               L  .ACCNT ENTERED AS COMMAND.
         BNE      LMNCMD            IF NOT A L COMMAND, MUST BE A LMN.
*
* SCAN COMMAND VERB TABLE(S)
*
SCANCVT  CI,R7    4                 TEST SIZE OF COMMAND VERB.
         BG       DOUBLE            USE DOUBLEWORD SEARCH
         LI,R5    SIZVERB1          SEARCH SINGLE WORD COMMANDS
         CW,D1    VERB1,R5
         BE       VECTA             IT'S A MATCH
         BDR,R5   %-2
         B        DOUBLE1
*
* PROCESS A COMPLEX LMN AS COMMAND.
*
LMNCMD   EQU      %
         CI,D4    4                 CHECK FOR IMPLIED QUIT
         BANZ     LMNCMD10          B IF YES
         LI,R5    1
         LS,R5    J:JIT+JTELFLGS    ARE WE AT JOB STEP
         BEZ      BKOPT0            NO - ASK IF QUIT?
LMNCMD10 EQU      %
         BAL,SR4  FID               BREAK COMPLEX FID
         PUSH     2,SR2             SAVE ACCOUNT
         PUSH     2,R7              SAVE PASSWORD
         BAL,SR3  NFND              THIS WILL LEAVE LMN IN R6,R7,SR1
         PULL     2,SR3             RESTORE PASSWORD
         PULL     2,D2              AND ACCOUNT
         LW,R5    =X'00100000'      SET FLAG TO INDICATE UNKNOWN LMN
         STS,R5   J:TELFLGS
         LI,D1    PARSER            SET TO SCAN REMAINING MSG
         B        GROUP2B
*
DOUBLE   CI,R7    8                 LMN ASSUMED IF COMMAND SIZE>8 CHARS.
         BG       DOUBLE1
         LI,R4    VERB2             SEARCH DOUBLEWORD COMMMANDS.
         LI,R5    SIZVERB2/2
         CD,D1    *R4,R5
         BE       VECTB             IT'S A MATCH
         AI,R5    -1
         BNEZ     %-3
DOUBLE1  EQU      %
         CI,D4    4                 CHECK FOR IMPLIED QUIT
         BANZ     DBL10             B IF YES
         LI,R5    1
         LS,R5    J:JIT+JTELFLGS   ARE WE AT JOB STEP
         BEZ      BKOPT0            NO - ASK IF QUIT?
DBL10    EQU      %
         BAL,SR3  NFND              NO FIND-PROCESS AS UNKNOWN LMN
         LI,D1    PARSER            SET TO SCAN REMAINING INPUT WITH
*                                   UNKNOWN LMN. IF NO SCAN IS DESIRED,
*                                   CHANGE TO LI,D1 0.
         LW,R5    =X'00100000'      SET FLAG TO INDICATE UNKNOWN LMN
         STS,R5   J:TELFLGS
         B        GROUP2A
*
VECTA    CI,R5    SIZVERB1/2        ABSOLUTIZE VECTOR INDEX
         BLE      %+2
         AI,R5    -(SIZVERB1/2)
         EXU      VECTOR1,R5        ENTER VECTOR
         LI,D1    0                 INDICATE NO FURTHER SCAN REQUIRED
         B        GROUP2            AND LOAD THE PROCESSOR.
VECTB    CI,R5    SIZVERB2/4        ABSOLUTIZE VECTOR INDEX FOR
         BLE      %+2               DOUBLEWORD COMMAND
         AI,R5    -(SIZVERB2/4)
         EXU      VECTOR2,R5
VECTB10  EQU      %
         LI,D1    0                 LMN NAME LOADED IN R6,R7 AND NO
*                                   FURTHER SCAN NECESSARY
*
* THE GROUP2 COMMANDS ARE THOSE REQUIREING THE LOAD OF AN ASSOCIATED
* PROGRAM. THE LOAD IS EXECUTED IMMEDIATLY IF NO FURTHER SCAN IS
* REQUIRED BUT DEFERRED TO THE END IF SCANNING IS DONE.
*
GROUP2   LW,SR1   VERB1
GROUP2A  LW,D2    SYS               SET SYSTEM ACCOUNT AND JIT FOR
         LW,D3    VERB1             THE PROGRAM LOADER.
         LI,SR3   0                 CLEAR PASSWORD
         LI,SR4   0
GROUP2B  EQU      %
*
* TEST FOR WITHIN JOB STEP. ABORT PREVIOUS MAJOR OPERATION IF NOT.
*
         LI,R5    1                 BIT 31 OF TELFLGS IS SET WITHIN JOB
         LS,R5    J:JIT+JTELFLGS    STEP
         BEZ      INBREAK           JUMP IF GROUP2 COMMAND AND BREAK
         CI,D1    0                 IS FURTHER SCAN IMPLIED
         BNE      PARSE             YES
GROUP2C  EQU      %
*
* TEST FOR SI RELEASE AND ASSIGN/MERGE WRITE LOGIC
*
         PUSH     16,R1             SAVE REGS
         BAL,SR4  READAM            NO-READ IT IN
         LW,R4    J:ABUF            NOW PICKUP ADDRESS
         LI,R1    X'8'              CAN SI BE RELEASED
         LS,R1    J:JIT+JTELFLGS    IF SET-DO NOT RELEASE SI FROM A/M
         BEZ      GRPEXT            AS THIS IS A NEW ENTRY
         LI,R1    -9               RESET SI RELEASE FLAG
         AND,R1   J:JIT+JTELFLGS
         STW,R1   J:JIT+JTELFLGS
         B        GRPEXT1
GRPEXT   LD,R6    TM:SI             RELEASE SI ENTRIES
         BAL,SR4  ASSIGN+2
GRPEXT1  LD,R6    TM:GO             IS THERE A GO IN A/M
         BAL,SR4  ASSIGN+1
         CI,R5    0
         BNE      GRPEXT2           YES
         LI,R1    X'200'            NO-CREATE % DEFAULT
         STS,R1   J:JIT+JTELFLGS    SET RETURN FLAG
         B        %ROM              THIS WILL RETURN %+1
GRPEXT2  BAL,SR4  WRITEAM           WRITE ASSIGN/MERGE
         LW,R5    J:JIT+JSTDOPT     SET ASSIGNED OPTIONS FOR THIS JOB
         STW,R5   J:JIT+JOPT        STEP.
         LI,R5    X'10'
         STS,R5   J:JIT+JOPT        AN SI OPTION IS ALWAYS PROVIDED
         BAL,R0   TELCCBUF                                              TEL
         LI,R1    -4                RESET BREAK AND JOB STEP FLAGS
         AND,R1   J:JIT+JTELFLGS
         STW,R1   J:JIT+JTELFLGS
         SLS,R4   17                RESET ARS YO ITS ORIGINAL VALUE
         LI,R5    -X'20000'         X'FFFE0000'
         DO1      A=1
         STS,R4   ARS               (M:UC)
         PULL     16,R1             RESTORE REGS
         CD,R0    FDP               IF THE COMMAND WAS EITHER
         BE       NODEL             FDP OR DELTA, SKIP THE
         CD,R0    DELTA             SMALL SECTION OF CODE
         BE       NODEL
         LI,R0    X'100'            FDP FLAG BIT
         AND,R0   J:JIT+JTELFLGS
         BEZ      NOFDP             BR. IF FDP BIT NOT SET
         LD,R0    FDP1              DEBUGGER ASSO.
         B        XEXIT             SKIP DELTA ASSOCIATION
*
NOFDP    LI,0     X'80'
         AND,0    J:JIT+JTELFLGS
         BEZ      NODEL             BR. IF DELTA BIT NOT SET
         LD,0     DELTA             YES
NODEL    RES      0
*                                   *  RELEASE DATA
XEXIT    RES      0
         DO       A=1
         LW,R3    =X'FFFD7EFF'      RESET MOD,DRC(TRNSP MODE) & VFC BITS
         LS,R3    M:UC              BEFORE EXITING
         STW,R3   M:UC
         FIN
         LI,R3    0                                                  RL2
         CD,R6    LOGOFF            RESET RUN STATUS FOR ALL EXITS
         BE       YEXIT             EXCEPT LOGOFF
         LI,R4    JB:FRS
         STB,R3   0,R4
YEXIT    EQU      %
         BAL,D4   FREEBUF1          RELEASE OUR BUFFER
*
BBEXIT   RES      0                                                  RL2
         DO       A=1
         CAL1,9   1                 EXIT    --- LOAD R6
         ELSE
         B        TEL               DEBUG ONLY
         FIN
         PAGE
* THE FOLLOWING IS EXECUTED WHEN A MAJOR COMMAND(ONE REQUIRERING THE
* LOAD AND EXECUTION OF AN OUTSIDE PROCESSOR) IS RECEIVED OUTSIDE OF A
* JOB STEP. THIS IMPLIES THE ABORTION OF THE PREVIOUS JOB STEP AND
* REPLACING IT WITH THE CURRENT ONE.
*
INBREAK  EQU      %
         CW,R6    DELTA             IS THIS A REQUEST FOR DELTA
         BE       GROUP2C
         LI,R5    X'2000'           SET IMAGE BUFFER CONTROL TO RETAIN
         STS,R5   J:JIT+JTELFLGS    CURRENT MESSAGE AND RE-PROCESS
         BAL,0    TELCCBUF
         LI,R5    X'1FFFF'
         CW,R5    J:EXTENT          EX CON SPECIFIED?
         BANZ     QUIT              YES, FORCE EXIT
INBREAK1 EQU      %
         LI,5     0
         STB,R5   J:JIT+JABC        ABORTED PREVIOUS PROCESS
XABORT   RES      0
         BAL,D4   FREEBUF1          RELEASE OUR BUFFER
ABORTEXIT  RES    0                                                  RL2
         CAL1,9   3                 ABORT
         PAGE
*
* QUIT COMMAND COMES HERE.
*
QUIT     LI,R5    1                 WE MUST BE IN A BREAK CONDITION
         LS,R5    J:JIT+JTELFLGS
         BNEZ     SYN1
*  INTERPRET AS A 'GO' COMMAND IF EXIT CONTROL HAS
* BEEN ESTABLISHED AND NOT IN PROGRESS
         REF      J:EXTENT
*
         LI,R5    X'1FFFF'
         CW,R5    J:EXTENT
         BAZ      INBREAK1
         LB,R5    J:EXTENT
         CI,R5    X'20'
         BANZ     INBREAK1          IF IN PROGRESS, NO FAKE
         LI,R7    2                 FAKE IT,SET BIT 6
         OR,R5    R7
         STB,R5   J:EXTENT
         B        CONTINX
         TITLE    'PARSE COMPILE AND ASSEMBLE COMMANDS'
*
* THE FOLLOWING LOGIC PRESERVES THE INTEGRITY OF THE REGISTERS THAT WILL
* BE USED WHEN WE FINALLY EXIT AND LOAD THE DESIRED LMN. IT ALSO
* PROVIDES A COMMON EXIT FROM THE PARSING LOGIC.
*
PARSE    PUSH     15,R1             SAVE LOAD PARAMETERS
         CI,R1    0                 IS THERE MORE MESSAGE TO SCAN
         BNE      *D1               YES-ENTER CORRECT PROCESS
ENTPRG   EQU      %                 NO-PROVIDE COMMON EXIT
         PULL     15,R1
         B        GROUP2C
* THIS SECTION OF CODE IS DEDICATED TO THE BREAKDOWN OF THE INPUT STREAM
* AS IT PERTAINS TO THE COMPILE AND ASSEMBLE COMMAND VERBS. THERE IS A
* GREAT VARIETY OF FORM ASSOCIATED WITH THIS INPUT STREAM AND,
* CONSEQUENTLY, A GOOD DEAL OF LOGIC IS PROVIDED, NOT ALL OF WHICH NEED
* BE EXECUTED FOR A PARTICULAR BUFFER IMAGE. ENTRY TO THIS CODE MAY BE
* MADE ONLY IF AT LEAST ONE FIELD FOLLOWS THE COMMAND VERB.
*
PARSER   EQU      %
         BAL,SR4  READAM            GET ASSIGN/MERGE TABLE
TOPPARSE EQU      %
         STW,R2   TELBUF+I38        SAVE INP PTR FOR SYNTAX CHECKING
         BAL,SR3  GETFIELD
         BAL,0    STOPS,5
         CI,R7    0                 DIS WE GET SOME DATA
         BE       TESTEOM           NO
*
* AT THIS POINT, A DETERMINATION MUST BE MADE TO DETECT CERTAIN,
* RECOGNIZABLE ELEMENTS SUCH AS %, ME, OVER, OR ON. IF NONE OF THESE,
* THE FIELD IS ASSUMED TO BE A SIMPLE FID.
*
         CW,D1    DOLL              A % IS EXPLICILY ILLEGAL AS A FID
         BE       CHKULM            SYNTAX ERROR
         CW,D1    ME
         BE       DOME
         CW,D1    ON
         BE       DOON
         CW,D1    OVER
         BE       DOOVER
A1       EQU      %
         BAL,R5   GETACPAS
TESTSI   LI,R5    X'10'             IS THIS THE 1ST SI ENTITY
         LS,R5    J:JIT+JTELFLGS
         BEZ      TESTSI2           YES
TESTSI1  LW,R2    TELBUF+I38        MULT SI NOT ALLOWED, SYNTAX ERR
         AI,R2    -1
         B        CHKULM
*
* THIS FID MUST NOW BE SET IN THE ASSIGN/MERGE TABLES REPLACING ALL
* PREVIOUS M:SI ASSIGNMENTS.
*
TESTSI2  PUSH     R7
         LD,R6    TM:SI
         LW,R4    J:ABUF            CLEAR ASSIGN/MERGE AND FIND A
         BAL,SR4  ASSIGN            PLACE FOR THIS ENTRY(RETURNED IN R5)
         PULL R7
MGSI     BAL,SR4  FILENT            ENTER SI PLIST
         LI,R3    1                 BUT MAKE IT AN IN MODE FILE
         STW,R3   MODE-PLIST+3,R5
         LI,R3    X'200'            SET ASSIGNMENT MADE FLAG
         STS,R3   7,R4              BUT IN A/M TABLE
TESTEOM  LI,R5    X'200'            ARE WE PROCESSING FOR DEFAULT GO
         LS,R5    J:JIT+JTELFLGS
         BNEZ     GRPEXT2           YES
         LI,R5    X'60'             HOW ABOUT AN OVER/ON CONDITION
         LS,R5    J:JIT+JTELFLGS
         BNEZ     %+3
         LI,R5    TOPPARSE
         B        %+2
         LI,R5    OPRSE
         CI,R1    0                 ANY MORE MESSAGE
         BLE      ENTPRG            NO
         LI,R3    X'20000'
         LS,R3    J:JIT+JTELFLGS    TEST FOR TRAILING GARBAGE
         BNEZ     CHKULM            SYNTAX ERROR
         B        *R5
*
*
* PROCESS INVOKED WHEN 'ME' IS ENCOUNTERED AS A FID
*
DOME     LI,R5    X'10'             HAS THERE BEEN AN SI YET
         LS,R5    J:JIT+JTELFLGS
         BEZ      DOME2             NO-GO CREATE ONE
         B        TESTSI1           YES, MULTIPLE SI NOT ALLOWED
DOME1    LCI      4                 CREATE ME OP LABL PLIST
         LM,D1    OPENME
         STM,D1   3,R5
         B        MGSI+3
DOME2    LW,R4    J:ABUF
         LD,R6    TM:SI
         BAL,SR4  ASSIGN
         LW,D1    0,R4              OLD AVAIL HD
         AI,D1    7                 SIZE THIS ENTRY
         STW,D1   0,R4              UPDATE HEAD
         B        DOME1
         TITLE    'PARSE OVER/ON PORTION OF COMMAND VERB'
DOON     LI,R3    X'20'             SET 'ON' BIT
         B        DOOVER1
DOOVER   CI,R7    4                 DOUBLECHECK OVER IMPLICATION
         BG       A1                ITS AN SI FID
         LI,R3    X'40'             SET 'OVER' BIT
DOOVER1  EQU      %
         STS,R3   J:JIT+JTELFLGS
         CI,R6    C','              DID ADVERB END WITH A COMMA
         BE       EXTDGO            ASSUME IMPLIED SPECIFICATION IF YES
OPRSE    BAL,SR3  GETFIELD
         CI,R7    0                 INSURE WE GOT DATA
         BE       CHKULM            SYNTAX ERROR
         BAL,0    STOPS,R5
         LI,R5    X'4'
         LS,R5    J:JIT+JTELFLGS    PHASING. (GO OR LO PROCESS)
         BNEZ     DOLO              PROCESS FOR LIST SPECIFICATION
         LI,R5    X'4'              PROCESS FOR A ROM SPECIFICATION-FLIP
         STS,R5   J:JIT+JTELFLGS    THE PHASE FLAG.
         CW,D1    DOLL              TEST FOR % ROM SPECIFICATION
         BE       %ROM
         CW,D1    ME                ME IS NOT ALLOWABLE FOR OUTPUT
         BNE      ROMDEV
         LH,R1    J:TELFLGS         IS IT UNRECOGNIZED LMN?
         CI,R1    X'10'
         BANZ     ENTPRG            IGNORE ERROR AND EXECUTE LMN
         B        ERRME
ROM%BLT  CW,D1    LP                LP IS NON-ALLOWED INTHIS POSITION
         BE       CHKULM            SYNTAX ERROR
         CW,D4    FULAM             WAS A FID PROCESSED
         BE       ROM%BLT1          YES
         LCI      2                 CREATE COMPLETE FID FROM INPUT DATA
         LM,SR2   J:JIT+JACCN       PUT LOG-ON ACCOUNT IN SR2, SR3
         LI,R7    0                 NO PASSWORD IS ASSUMED IN R7, SR1
         LI,SR1   0
ROM%BLT1 LW,R4    J:ABUF
         LI,R5    X'20'             WAS ON SPECIFIED
         LS,R5    J:JIT+JTELFLGS
         BEZ      ROMGO             NO
         LI,R5    X'200'            IS BUILD % DEFAULT
         LS,R5    J:JIT+JTELFLGS      SPECIFIED??
         BNEZ     ROMGO             YES
         BAL,SR4  FLOP              CHECK IF FILE ALREADY EXISTS
         CI,R0    0
         BNE      ROMGO
         BAL,4    SETACL            SET AND CLOSE
         B        ONERR             PUT OUT ERROR MSG
ROMGO    EQU      %
         PUSH     R7
         LD,R6    TM:GO             RELEASE ANY PREVIOUS GO ENTRIES AS
         BAL,SR4  ASSIGN            THIS IS A NEW SPECIFICATION.
         PULL     R7
         BAL,SR4  FILENT            FILL FILE DATA INTO ASSIGN ENTRY
ROMGO1   LI,R5    -2                FINISH UP 'GO'
         AND,R5   6,R4              IN THE A/M IMAGE OF JCPPO
         STW,R5   6,R4
         LI,R5    X'200'            SET ASSIGNED BITS FOR GO IN A/M
         STS,R5   7,R4
         LI,R5    X'80'
         B        LOFINS
         PAGE
*
* CHKS FOR LDEV,CP OR NO. IF FOUND BUILDS
* DEVICE PLIST FOR M:GO. OTHERWISE RETURNS TO
* ROM%BLT AND PROCESSES FOR FID.
*
*
ROMDEV   EQU      %
         CI,R7    2                 CHK SIZE OF FIELD
         BNE      ROM%BLT           DOESN'T QUALIFY
         LW,R5    D1
         SAS,R5   -16
         LI,R7    SV:LSIZ
         CH,R5    SH:LNM,R7         IS IT STRM ID?
         BE       ROMDEV1
         BDR,R7   %-2
         AND,R5   L(X'FFFF')
         CI,R5    'CP'              CARD PUNCH?
         BE       ROMDEV1
         CI,R5    'NO'
         BNE      ROM%BLT           GO PROCESS FOR FID
ROMDEV1  LI,R5    X'40'             CHK OVER FLG&
         LS,R5    J:JIT+JTELFLGS      DON'T ALLOW
         BNEZ     CHKULM                FOR DEVICES.
         LW,R4    J:ABUF            GET ADR OF A/M REC
         LD,R6    TM:GO
         BAL,SR4  ASSIGN            REL PREV ENTRIES
         LW,R7    0,R4              OLD FREE HEAD
         AI,R7    7                 SIZE THIS ENTRY
         STW,R7   0,R4              NEW FREE HEAD
         LCI      4
         LM,R7    OPENME            DEV PLIST
         STW,D1   SR3               STORE DEV IN PLIST
         SLS,SR3  -16
         LCI      4
         STM,R7   3,R5              PLACE PLIST IN A/M REC.
         B        ROMGO1
         PAGE
*
* CREATE A %ROM FILE ENTRY IN THE ASSIGN/MERGE AND RELEASE ANY PREVIOUS
* ENTRIES FOR THE GO DCB. ANY PREVIOUS %ROM FILES WILL ALSO BE RELEASED.
*
%ROM     EQU      %
         LI,5     C'G'
         BAL,SR4  NAME%
         STW,5    D1
         LW,D2    VERB1
         LW,D3    VERB1
         LCI      2
         LM,SR2   J:JIT+JACCN
         LI,7     0
         LI,SR1   0
         B        ROM%BLT1
*
* PERFORM NECESSARY FUNCTIONS WHEN A FIELD HAS BEEN IMPLIED.
*
EXTDGO   RES      0
         LI,R5    4                 INSURE PHASE FLAG IS SET
         STS,R5   J:JIT+JTELFLGS
         LI,R5    X'80'
         B        LOFINS
*
* ON IS NOT AN ALLOWABLE MODIFYER. PUT OUT ERROR MESSAGE.
*
ONERR    LI,R1    ONFERR            PUT OUT ON FILE ERROR MESSAGE
         LI,R2    8
         CAL1,1   WRITE
         BAL,SR3  NFND              SET SIZE OF FILE NAME
         LB,R2    R6
         LW,R1    TELSTACK
         AI,R1    1
         PUSH     3,D1
         CAL1,1   WRITE
         BUMP     -3,R6
         B        ONERR2+1
ONERR2   CAL1,1   WRITE
         LI,R1    LEGER
         LI,R2    8
         CAL1,1   WRITE
         B        SYN2
*
* PROCESS FOR LIST SPECIFICATION.
*
DOLO     EQU      %
         CI,R7    2                 POSSIBLE STRM OR DEV?
         BNE      DOLO1             NO
         LW,R5    D1
         SAS,R5   -16
         LI,R7    SV:LSIZ
         CH,R5    SH:LNM,R7
         BE       LOME              FOUND DEV STREAM
         BDR,R7   %-2
         CW,D1    ME                TEST FOR VARIATIONS
         BE       LOME
         CW,D1    LP
         BE       LOME
         CW,D1    NO
         BE       LOME
DOLO1    CW,D1    DOLL              A % IS ILLEGAL IN THIS POSITION
         BE       CHKULM            SYNTAX ERROR
         CW,D4    FULAM             WAS A COMPLEX FID PROCESSED
         BE       LOBLT
         LCI      2                 CREATE A COMPLETE FID
         LM,SR2   J:JIT+JACCN       USING LOG-ON ACCOUNT
         LI,R7    0                 NO PASSWORD IS THE ASSUMPTION
         LI,SR1   0
LOBLT    LI,R5    X'20'             WAS ON SPECIFIED
         LS,R5    J:JIT+JTELFLGS
         BEZ      LOMGO             NO
         BAL,SR4  FLOP              CHECK FOR UNIQUE FILE
         CI,R0    0
         BNE      LOMGO
         BAL,4    SETACL            SET AND CLOSE
         B        ONERR
LOMGO    LI,R5    X'400'            TEST FOR COMMENT CMD
         LS,R5    J:JIT+JTELFLGS
         BNEZ     DOBLT
         LW,R4    J:ABUF
         PUSH     R7
         LD,R6    TM:LO             ANY PREVIOUS ENTRIES ARE RELEASED AS
         BAL,SR4  ASSIGN            THIS IS A NEW SPECIFICATION.
         PULL     R7
         BAL,SR4  FILENT            ENTER THE FILE DATA
LOSETUP  EQU      %
         LI,R5    -5                RESET FILE EXTENSION FOR LO IN A/M
         AND,R5   6,R4
         STW,R5   6,R4
         LI,R5    X'200'            NOW SET ASSIGNMENT BITS FOR LO
         STS,R5   7,R4
         LI,R5    X'20000'          SET END OF MSG FLAG
         STS,R5   J:JIT+JTELFLGS
         LI,R5    1                 SET LO SPEC IN OPTIONS
LOFINS   EQU      %
         STS,R5   J:JIT+JSTDOPT
         LI,R5    X'800'            HAVE WE BEEN PROCESSING A LIST CMD
         LS,R5    J:JIT+JTELFLGS
         BEZ      TESTEOM           NO
         CI,R1    0                 INSURE NO TRAILING JAZZ
         BG       CHKULM
         BAL,SR4  WRITEAM           WRITE A/M
         B        PROMPT            YES-GO FOR NEXT MESSAGE
DOBLT    EQU      %
         LW,R4    J:ABUF
         PUSH     R7
         LD,R6    TM:DO             MAKE ENTRY FOR DO DCB
         BAL,SR4  ASSIGN
         PULL     R7
         BAL,SR4  FILENT
LAS      LI,R5    X'FFFEF'          RESET FILE EXTENSION FOR DO IN A/M
         AND,R5   6,R4
         STW,R5   6,R4
         LI,R5    X'200'            AND SET DO ASSIGNED
         STS,R5   7,R4
         LI,R5    X'100'            SET DO IN OPTIONS
         B        LOFINS
*
* CREATE ME OR LP OPLABEL AND MERGE INTO DCB.
*
LOME     LI,R5    X'400'            DETERMINE IF LO OR DO
         LS,R5    J:JIT+JTELFLGS
         BNEZ     LOME3
         LW,R4    J:ABUF            CREATE NEW LO ASSIGN ENTRY
         LD,R6    TM:LO
         BAL,SR4  ASSIGN            ADDRESS RETURNED IN R5
         LW,R7    0,R4              OLD FREE HD
         AI,R7    7                 SIZE THIS ENTRY
         STW,R7   0,R4              NEW HD
         LCI      4
         LM,R7    OPENME
         CW,D1    ME
         BE       %+3
         STW,D1   SR3
         SLS,SR3  -16
         LCI      4
         STM,R7   3,R5
         B        LOSETUP           GO SET BITS FOR LO
LOME3    LW,R4    J:ABUF
         LD,R6    TM:DO             CREATE NEW DO ASSIGN ENTRY AS WAS
         BAL,SR4  ASSIGN            DONE FOR LO
         LW,R7    0,R4              OLD FREE HD
         AI,R7    7                 SIZE THIS ENTRY
         STW,R7   0,R4              NEW FREE HEAD
         LCI      4
         LM,R7    OPENME
         CW,D1    ME
         BE       %+3
         STW,D1   SR3
         SLS,SR3  -16
         LCI      4
         STM,R7   3,R5
         B        LAS               COMPLETE THE PROCESS
*
* DETERMINES IF UNRECOGNIZED LOAD MODULE (NOT FORTRAN OR META). IF SET,
*TERMINATE SCAN,IGNORE ERROR AND EXECUTE LOAD MODULE.
*
CHKULM   EQU      %
         PUSH     R1
         LH,R1    J:TELFLGS         IS THIS AN UNRECOGNIZED LMN?
         CI,R1    X'10'
         BAZ      SYNTAX            NO, PUT OUT SYNTAX ERROR MSGE.
         PULL     R1                YES, EXIT AND EXECUTE LMN
         B        ENTPRG
         PAGE
*
*  BUILD SHORT FORM REQUEST
*
BUILD    EQU      %
         BAL,SR4  SHFTBUF           SHIFT REQUEST
         LD,D1    BUILDA
         LD,R6    EDIT
         B        CMNDSET
*
* EDIT SHORT FORM COMMAND VERB
*
EDIT0    EQU      %
         BAL,SR4  SHFTBUF           SHIFT COMMAND
         LD,D1    EDITA             MAKE IT LOOK LIKE
         LD,R6    EDIT              LONG FORM
         B        CMNDSET
CMNDSET  EQU      %
         LCI      2                 STOORE COMMAND IN BUF
         STM,D1   TELBUF
         LB,D1    J:JIT+JPUF
         CI,D1    80                IS EXPANDED COMMAND >80 CHARS.
         BG       CMNDSET5          IF YES, ERROR
         BAL,R0   TELCCBUF          MOVE MESSAGE TO CCBUF
         B        VECTB10
CMNDSET5 LI,R1    INEXC             WRITE ERROR MSG.
         LI,R2    36
         CAL1,1   WRITE
         B        CLEANSTACK
*
* UNDER DELTA SHORT (&ONLY) FORM COMMAND VERB
*
UDELT    EQU      %
         CI,R1    1                 IF U IS SPECIFIED, "UNDER DELTA"
         BG       SYNTAX            IS IMPLIED FOR THE NEXT COMMAND.
         LW,D2    =X'80000'
         STS,D2   J:TELFLGS         SET UNDER DELTA FOR NEXT COMMAND
         B        PROMPT            FLAG
         TITLE    'OUTPUT COMMAND VERB'
OUTPUT   LI,R4    0                 SET COMMAND INDEX
         B        LISTCOM
*
*                 COMMENT COMMAND VERB
*
COMMENT  LI,R3    X'404'            FLIP PHASE TO LO AND SET CMD UNIQUE
         STS,R3   J:JIT+JTELFLGS
         LI,R4    2                 SET COMMAND INDEX FOR COMMENT
         B        LISTCOM
*
* THIS LOGIC HANDLES THE ADVERB DONT BY SETTING A SPECIAL FLAG AND
* CONTINUING THE COMMAND INTERPRETATION. THE FLAG IS CHECKED ONLY IN
* THE COMMAND PROCESS WHERE IT HAS MEANING.
*
DONT     LI,R3    X'1000'           SET THE DONT FLAG
         STS,R3   J:JIT+JTELFLGS
         B        NEXTTIME          GET REST OF COMMAND
OPTAB    DATA,2   X'80',X'01'
         DATA,2   X'100',X'0'
NOPTAB   DATA     X'FFFFFF7F'
         DATA     X'FFFFFFFE'
         DATA     X'FFFFFEFF'
         TITLE    'LIST COMMAND VERB'
LIST     LI,R3    X'4'              FLIP THE PHASE TO LO
         STS,R3   J:JIT+JTELFLGS
         LI,R4    1                 SET COMMAND INDEX FOR LIST
*
* THE FOLLOWING IS COMMON CODE USED BY THE LIST, OUTPUT AND COMMENT
* COMMAND VERBS. R4 MUST CONTAIN AN INDEX UNIQUE TO THE COMMAND.
*
LISTCOM  CI,R1    0                 TEST FOR FOLLOWING MODIFIER
         BE       LIST1             NO DATA-IMPLIES FUNCTION CHANGE
         LI,R3    1                 PRE-ASSIGN CAN ONLY BE DONE
         LS,R3    J:JIT+JTELFLGS    AT JOB STEP.
         BEZ      NTJBST            COMMAND ILLEGAL UNLESS JOB STEP TIME
         LW,D1    VERB1
         LI,R3    D1
         BAL,SR3  SCAN              OBTAIN MODIFIER
         LI,R3    X'800'            SET LIST CMD FLAG
         STS,R3   J:JIT+JTELFLGS
         BAL,SR4  READAM            NO-READ IT IN
         CW,D1    ON                IS MODIFIER ON
         BE       DOON              YES-ENTER COMMON CODE
         CW,D1    OVER              HOW ABOUT OVER
         BE       DOOVER
         B        SYNTAX            NEITHER ONE IS AN ERROR
LIST1    LI,R3    1                 ARE WE AT JOB STEP OR BREAK
         LI,R5    J:JIT+JOPT
         LS,R3    J:JIT+JTELFLGS
         BNEZ     LIST4             JOB STEP
LIST2    LI,R3    X'1000'           BREAK
         LS,R3    J:JIT+JTELFLGS    TEST FOR DONT ADVERB
         BNEZ     LIST3             IT HAS BEEN GIVEN
         LH,R3    OPTAB,R4
         STS,R3   *R5
         B        PROMPT
LIST3    LW,R3    NOPTAB,R4         TURN OFF OPTION
         AND,R3   *R5
         STW,R3   *R5
         B        PROMPT
LIST4    LI,R5    J:JIT+JSTDOPT     INSERT SPECIFICATION CELL ADDRESS
         B        LIST2
         TITLE    'START COMMAND'
START    CI,R1    1                 IS THERE MORE MSG
         BLE      START4
         LI,R3    D1
         LD,D1    VERB2
         LW,D3    VERB1
         BAL,SR3   SCAN             GET NEXT FIELD
         CD,D1    UNDER             CHK IF FORM OF 'START UNDER LMN'
         BE       START8
         CI,R6    '.'               CHECK COMPLEX FID
         BNE      START5-2
         BAL,SR4  FID               BRAEK FID
START1A  PUSH     2,SR2
         PUSH     2,R7
         BAL,SR3  NFND              MAKE NAME TEXTC
         PULL     2,SR3
         PULL     2,D2
START2   LI,D1    0
         LI,R5    X'4000'           SET BIT FOR SYSERR IN CASE FETCH
         STS,R5   J:JIT+JTELFLGS    DOES'NT FIND IT.
         CI,R1    1                 TEST FURTHER MESSAGE
         BLE      GROUP2B           NO MORE
         PUSH     9,R6              SAVE LOAD DATA
         LD,D1    VERB2
         BAL,SR3  SCAN              NEXT FILD CAN ONLY BE 'UNDER'
         CI,R7    1                 CHECK FOR SINGLE CHAR "UNDER DELTA"
         BNE START70                REQUEST. B IF NO
         CI,R1    1                 NO MORE ALLOWED
         BG       SYNTAX
         LI,SR3   'U'               WAS IT 'U' FOR "UNDER DELTA"
         CB,SR3   D1
         BE       START75           B IF YES
START70  EQU      %
         CD,D1    UNDER
         BNE      SYNTAX
START7   RES      0
         LD,D1    VERB2
         BAL,SR3  SCAN
         CI,R1    1
         BG       SYNTAX
         CD,D1    DELTA1            IS IT DELTA OR FDP
         BNE      START3
START75  EQU      %
         LI,R3    X'80'             SET DELTA FLAG
         STS,R3    J:JIT+JTELFLGS
         PULL     9,R6
         B        START2
START3   CD,D1    FDP1
         BNE      SYNTAX
         LI,R3    X'100'
         STS,R3   J:JIT+JTELFLGS
         PULL     9,R6
         B        START2
START4   RES      0
         BAL,R0   START9
         B        START2
         CW,D1    DOLL              CHECK FOR % FILE
         BE       START6
START5   LCI      2
         LM,SR2   J:JIT+JACCN
         LI,R7    0
         LI,SR1   0
         B        START1A
START6   LI,R6    X'30000'          BYTE COUNT FOR IDL
         LI,R7    X'FFFF'           MASK TO GET SYSID
         LS,R6    J:JIT             GET SYSID
         SLS,R6   8                 POSITION
         OR,R6    ='L'
         LCI      2
         LM,D2    J:JIT+JACCN
         B        START2
START8   RES      0
         CI,R1    1                 MORE INFO MUST  FOLLOW
         BLE      STARTERR
         BAL,R0   START9
         LI,R5     X'4000'
         STS,R5   J:JIT+JTELFLGS
         PUSH     9,R6
         B        START7
*
*
START9   RES      0
         LCI      3
         LM,R6    J:LMN             INSURE A LMN  EXISTS
         CI,R6    0
         BE       STARTERR
         LCI      2
         LM,D2    J:JIT+JACCN
         LI,SR3   0                 PASS. FOR LINK LM ALWAYS=0
         LI,SR4   0
         B        *R0
         TITLE    'CONTINUE COMMAND VERB'
CONTINUE LI,R3    1                 ARE WE AT A JOB STEP
         LS,R3    J:JIT+JTELFLGS
         BNEZ     DOWHAT
CONTINX  RES      0
         LI,R6    0                 SET UP RETURN EXIT
         LI,R7    0
         DO1      A=2
         B        TEL               TEMP             *****
         B        XEXIT
         TITLE    'FDP  VERB  SETUP'
*
FDPSET   RES      0
         LD,R6    FDP
         LD,R0    FDP
         LI,D1    0
         B        GROUP2
         TITLE    'DELTA  VERB  SETUP'
*
DELTASET RES      0
         LW,R6    J:EXLY
         AND,R6   =X'04000000'
         BAZ      %+2
         B        BKOPT0            ONLY QUIT OR GO ALLOWED
         LD,R6    DELTA
         LD,R0    DELTA
         LI,D1    0
         B        GROUP2
         TITLE    'PASSWORD COMMAND VERB'
PASSWORD LW,R3    =X'00200000'      CHECK IF M:XX IS OPEN.
         CW,R3    M:XX
         BANZ     DELCONF           IF SO, DONT PERMIT PASSWORD EXEC.
         LI,R3    D1
         LI,D1    0                 NO DATA IMPLIES HE WANTS TO
         LI,D2    0                 REMOVE THE PASSWORD
         BAL,SR3  SCAN              GET USERS NEWPASSWORD
         CI,R7    8                 MAX PASSWORD LENGTH
         BG       SYNTAX
         LI,R0    PASSWRD1          * SET THE RETURN REG
*                                   *SHOW CMMAND USES THE
PASSWRD2 LW,R3    TELSTACK
         AI,R3    1                 PROVIDE A KEY BUFFER IN UTS
         BUMP     6,R1
         LI,R2    J:JIT+JACCN       CONCATINATE ACCOUNT AND NAME AND
         LI,R4    0                 FORM KEY TO GET USER'S LOGIN RECORD
         LI,SR1   8                 MAX ACCOUNT 8 CHARS
         BAL,SR4  CONCAT
         LI,R6    X'40'             BLANK BETWEEN ACCOUNT AND NAME
         AI,R4    1
         STB,R6   *R3,R4
         LI,R2    J:JIT+JUNAME
         LI,SR1   12                MAX NAME 12 CHARS
         BAL,SR4  CONCAT
         STB,R4   *R3               PLACE BYTE COUNT IN KEY
         LCI      2                 TEMPORARILY PLACE US UNDER THE
         LM,R5    SECAC             SPECIAL LOGIN ACCOUNT
         LM,D3    J:JIT+JACCN       SAVE USERS ACCOUNT
         STM,R5   J:JIT+JACCN
         LI,SR3   0
         CAL1,1   OPLOG             OPEN THE FILE
         CI,SR3   0                 CHECK ERROR
         BNE      PASSBAD           ERROR ON OPEN
         LW,R4    TELSTACK
         AI,R4    1                 AND FOR THE READ PLIST
         BUMP     LOGSIZE+6,R5
         LCI      6                 DO A KEYED READ FOR USERS LOGIN REC.
         LM,R5    RWLOG
         OR,R5    L(X'10000000')    INSERT READ CMD
         STW,R4   R1                AND BUILD ADDRESS FOR PLIST
         AI,R1    LOGSIZE
         LCI      6
         STM,R5   0,R1
         LI,SR3   0
         CAL1,1   *R1               AND READ IN USERS LOGIN RECORD
         CI,SR3   0
         BNE      PASSBAD           ERROR OR READ
         B        *R0               %+1 OR RETURN
PASSWRD1 STW,D1   6,R4              *DONT MOVE THIS LABEL
         STW,D2   7,R4
         LW,R5    L(X'11000000')    AND WRITE THE RECORD BACK
         STS,R5   0,R1
         CAL1,1   *R1
         CI,SR3   0
         BNE      PASSBAD
         LW,R1    R4                SAVE ADR OF PASSWORD
         BAL,4    SETACL            SET AND CLOSE
         BUMP     -(LOGSIZE+12),5
         STW,D3   J:JIT+JACCN       RESTORE USERS ACCOUNT
         STW,D4   J:JIT+JACCN+1
         AI,R1    6
         LW,R5    R1                PASSWORD ADR
         LI,R1    PACOMP            PUT OUT A COMPLETED MESSAGE
         LI,R2    27
         CAL1,1   WRITE
         LCI      2                 BLANK OUT PASSWORD WHEREVER IT
         LM,D1    VERB2             APPEARS IN CORE
         STM,D1   *R5
         LB,R2    J:JIT+JPUF
         AI,R2    -1
         LI,R1    TELBUF
         BAL,R4   BLANKBUF          BLANK COMMAND BUFFER
         B        PROMPT            DONE,WHEW.
OPERR    B        *SR1              ERROR RETURN VECTOR
         TITLE    'SHOW COMMAND'
* THE SHOW COMMAND READS THE :USERS ENTRY FOR THIS USER
* AND MOVES IT TO A COMMON PAGE FOR THE SHOW PROCESSOR
* AFTER MOVING THE RECORD TO THE COMMON PAGE IT CALLS
* SHOW VIA AN INTERP EXIT. THE 'PASSWORD' CODE HAS BEEN
* GREATLY UTILIZED FOR THE READING OF THE :USERS FILE.
*
*
SHOW     EQU      %
         LW,R3    =X'00200000'      CHK IF M:XX OPEN?
         CW,R3    M:XX
         BANZ     BKOPT             PUT OUT QUIT MESSG
         BAL,R0   PASSWRD2          RD IN :USERS REC
         LI,R3    0
         STW,R3   6,R4              ZERO PASSWD
         STW,R3   7,R4                FOR SECURITY.
         LW,R1    R4                :USERS REC
         BAL,R4   SETACL            SET&CLOSE M:XX
         STW,D3   J:JIT+JACCN       RESTORE USERS ACCN
         STW,D4   J:JIT+JACCN+1
         CAL1,8   =X'0C000001'      GET COMMON PAGE
         BCS,8    SHOWXX            CANT GET PAGE
         LI,R4    LOGSIZE+1         SET FOR BDR
         AI,R1    -1
         AI,SR2   -1
         LW,R2    *R1,R4
         STW,R2   *SR2,R4           MOVE TO COMMN PG.
         BDR,R4   %-2
         BUMP     -(LOGSIZE+12),R5  EVEN UP THE STACK
         LI,D1    0                 DONT SCAN CMMAND
         LD,R6    XSHOW             CMMAND TO R6&R7
         B        GROUP2            GO LOAD AND LINK
*
*
SHOWXX   BUMP     -(LOGSIZE+12),R5
         LI,R1    NOCMP             NO COMMON PAGE
         CAL1,2   TYPE              OUTPUT MESSG
         B        SYN1              ABORT THE PROCESS
         TITLE    'RESET COMMAND'
*
* THE RESET COMMAND REMOVES AA CURRENT DCB ASSIGNMENTS BY LINKING
* THE ASSIGNED AND SI CHAINS IN THE A-M RECORD TO THE AVAILABLE CHAIN.
*
RESET    EQU      %
         LI,R5    1
         LS,R5    J:TELFLGS         CHECK IF AT JOB STEP
         BEZ      NTJBST            ERROR, B IF NOT
         BAL,SR4  READAM            READ IN A-M RECORD
         LW,R4    J:ABUF            A-M BUFFER ADR
         LI,R5    22                SET NEW AVAIL SLOT
         STW,R5   0,R4
         LI,R5    0
         STW,R5   1,R4              ZRO INUSE CHAIN
         LI,R3    X'FFDFF'
         AND,R3   7,R4              RESET "ASSIGNS EXIST" FLAG
         STW,R3   7,R4
         BAL,SR4  WRITEAM           RE-WRITE A-M RECORD
         LW,R3    J:JIT+JSTDOPT     RESET TO STANDARD OPTIONS
         STW,R3   J:JIT+JOPT
         B        PROMPT            GET NEXT COMMAND
*
         TITLE    'SET COMMAND VERB'
* THE TEL SET COMMAND IS ANALAGOUS TO THE ASSIGN CARD IN BPM. THROUGH
* THIS COMMAND, THE USER CAN FORCE SPECIFIC DCB ASSIGNMENTS AND OPTIONS
* TO BE MADE. ALL ASSIGNMENTS ARE CURRENTLY MADE IN THE A/M TABLE AND
* THE COMMAND IS ONLY ALLOWED AT JOB STEP TIME.
*
SET      LI,R5    1                 INSURE WE'RE AT JOB STEP
         LS,R5    J:JIT+JTELFLGS
         BEZ      NTJBST            COMMAND ILLEGAL UNLESS JOB STEP TIME
         BAL,SR3  GETFIELD                                           RL2
         PUSH     R6                                                 RL2
         BAL,11   CHKDCBN           CHECK DCB NAME                   RL2
         BAL,SR3  NFND              MAKE TEXTC                       RL2
         BAL,11   READAM            GET  A/M                         RL2
         PULL     0                                                  RL2
         CI,0     ';'                                                RL2
         BE       SETUPDAT                                           RL2
         LI,R4    0
         LI,R5    SETBUFE           ZRO WORK AREA
         STW,R4   *R5                & SET R5=SETBUF
         CI,R5    SETBUF
         BE       %+2
         BDR,R5   %-3
         AI,R5    1                 SETBUF+1
         LB,R4    R6                #BYTES DCB NAME
         STB,R4   *R5               BYTE CNT TO SETBUF
         LB,SR3   R6,R4
         STB,SR3  *R5,R4            MOVE NAME TO BUF
         BDR,R4   %-2
         AI,R5    -1                R5(SETBUF)
         LB,12    6                                                  RL2
         AI,12    8                                                  RL2
         SLS,12   -2                                                 RL2
         LW,8     OPENME                                             RL2
         STW,8    *12,5             1ST WD OF PLIST                  RL2
         LI,3     D1                                                 RL2
         LD,D1    VERB2
         STW,R5   R4                SAVE A/M ENTRY ADDRESS
          LI,R7   0
         CI,R0    '/'               WAS A DC/FID IMPLIED
         BE       SETFILE           YES
         BAL,SR3  SCAN#             GET DEVICE FIELD
         CI,R7    0                 CHECK IF RESET REQUEST
         BE       SET10             B IF YES
         LI,D4    '0'               CHECK FOR RELEASE
         CB,D4    D1
         BNE      SET2
SET10    EQU      %
         LCI      3                                                  RL2
         LM,R6    1,R4              OF HIS OLD ENTRY SO JUST RELEASE THE
         LW,R4    J:ABUF            CURRENT ONE.
         BAL,SR4  ASSIGN+2
         CD,R6    TM:SI
         BNE      %+4
         LI,R7    -9                RESET SI BITS
         AND,R7   J:JIT+JTELFLGS    AS SI IS RELD.
         STW,R7   J:JIT+JTELFLGS
         BAL,SR4  WRITEAM           WRITE THE ASSIGN/MERGE
         B        PROMPT            AND GO AGAIN
SET2     EXU      SETSTP,R5         TEST DELIMITER AND DO REQ'D LOGIC
         CW,D1    VERB1             INSURE WE'RE PROCESSING SOME CODE
         BE       SYNTAX            HE NEVER ENTERED ANOTHER FIELD
*
* SCAN FOR LEGAL CODE COMBINATION AND PROCESS ACCORDINGLY.
*
         CI,R7    2                 WD SHOULD ONLY HAVE A TWO CHARACTER
         BG       SYNTAX            DEVICE CODE OR OP LABEL
         SAS,D1   -16
         LI,R7    OV:NMSZ           TBL SIZE TO R7
         CH,D1    OH:NM,R7          TBL SRCH
         BE       SETDEVA           GOOD OP LABEL
         BDR,R7   %-2
         CH,D1    OH:NM             IS IT A 'NO' ENTRY???
         BE       SETDEVA           YES IT IS
         AND,D1   L(X'FFFF')
         CI,D1    'FT'              FREE FORM TPE?
         BNE      SYNTAX            CANT FIND
         LI,D1    '9T'              DEFAULT-> 9T
         B        SETDEVA
*
DOER     CI,R6    ';'               DOES HE WANT ANY MORE
         BE       SETKEYS           YES-DO KEYWORD OPTIONS
         CI,R1    1                 MORE DATA AT THIS POINT IMPLIES
         BG       BADFORM           A BAD FORMAT MSG
         BAL,SR4  TRUNDLE           COMPACT SKELETAL PLIST
         LD,R6    VERB2             BLANK FOR DCB NAME
         LW,SR1   VERB1
         LB,R4    SETBUF+1          #CHARS IN NAME
         STB,R4   R6
         LB,R3    SETBUF+1,R4       MVE TO REGS
         STB,R3   R6,R4              TO SEARCH
         BDR,R4   %-2                 EXISTING ENTRIES
         LW,R4    J:ABUF
         BAL,SR4  ASSIGN            GET SLOT FOR ENTRY
         BAL,SR4  MOVESET           MOVE COMPLETED ENTRY
*                                   TO A/M BUF FOR WRITE OUT.
         BAL,SR4  WRITEAM           WRITE A/M AND GO FOR NEXT CARD
         B        PROMPT
         PAGE
*
* PROCESS SYMBIONT DEVICE CONNECTIONS, AND TAPE TYPE DEVICES.
*
SETDEVA  LI,SR3   DOER              PROVIDE RETURN
SETDEV   AND,D1   L(X'FFFF')        ISOLATE CODE
         LI,R7    P14               SET POSITION AND
         LI,R5    X'40000'          PARAMETER BIT
         BAL,SR4  PENT              PLACE IT
         B        *SR3
*
* PROCESS INVOKED WHEN A # SIGN TERMINATED THE SCAN. IT IMPLIES A
* SERIAL NUMBER FOLLOWS A DEVICE ASSIGNMENT.
*
SETNUMB  EQU      %
         CI,R7    2                 INSURE WE GOT A DEVICE CODE
         BG       SYNTAX
         SAS,D1   -16               SHFT FOR COMPARE
         LI,R7    XV:RS1            TPE TBL (9T)
         CH,D1    XH:RN1,R7         LOOK FOR TPE TYPE
         BE       SETNUMBC          GOT IT
         BDR,R7   %-2
         LI,R7    XV:RS2            'OTHER' TBL SIZE
         CH,D1    XH:RN2,R7         7T,DP..ETC
         BE       SETNUMBH          DONT DEFAULT THESE
         BDR,R7   %-2
         B        SYNTAX            NO FIND
SETNUMBC AND,D1   L(X'FFFF')        DELE SIGN EXTEN.
         PUSH     D1                SAVE FIELD FOR ASN
         LI,D1    '9T'              DEFLT DEV FOR XH:RN1
*                 CAN OVERRIDE DEFAULT(9T) BY -TT
         B        SETNUMBG
*
SETNUMBH AND,D1   L(X'FFFF')        DELE SIGN EXTEN.
         PUSH     D1                SAVE FIELD FOR ASN
SETNUMBG BAL,SR3  SETDEV            SET IN OPLBL FIELD
         LI,R3    D1
         LD,D1    VERB2
         BAL,SR3  SCAN#             LOOK FOR '-'
         LI,5     X'4002'                                            RL2
         PULL     R3
         CI,R3    'AT'
         BNE      SETNUMBI
         LI,R5    X'4005'
         CI,R6    '-'               ANS TPE MUST
         BE       %+3                 MUST BE LABELED
         CI,R6    '/'                  IST CURSORY
         BNE      SYNTAX                 CHECK.
         CI,R7    6                 'AT' SN=6 CHARS ALWAYS
         BNE      SYNTAX
         LI,SR4   SETNUMBD          SET RETURN REG.
         B        SIXPACK           HASH SN
SETNUMBI CI,R7    4
         BG       SYNTAX
         CI,R3    'DP'
         BNE      SETNUMBD
         CI,R6    '/'               YES, IF DP FORM MUST BE DP#SN/FID
         BE       %+3
         CI,R6    '-'
         BNE      SYNTAX
         LI,R5    X'4001'           YES, SET F11,F12 TO FILE
SETNUMBD BAL,SR4  ADJUST4
         STS,R5   1,R4
         AI,4     PFOUT                                              RL2
         STW,D1   1,R4              INSN                             RL2
         LW,D1    L(X'07000101')                                     RL2
         STW,D1   0,R4                                               RL2
         STW,R3   D4                SAVE DEVICE# CODE
         LW,3     4                 SAVE 4
         PULL     4                                                  RL2
         CI,R6    '-'
         BNE      SETNUMBE-1
         LI,R3    D1
         LD,D1    VERB2
         BAL,SR3  SCAN
         CI,R7    2
         BNE      SYNTAX
         CI,D4    'AT'              ANS ONLY MUST BE
         BNE      %+3                  LABELED TAPE
         CI,R6    '/'               IS IT???
         BNE      SYNTAX            ABORT COMMND
         LI,R7    SV:RSIZ           TBL SIZE
         SAS,D1   -16               SHIFT ENTRY
         CH,D1    SH:RNM,R7
         BE       %+3
         BDR,R7   %-2
         B        RTYERR
         LB,R7    SB:RTY,R7         GET INDX TO TB:FLGS
         CI,R7    X'FF'             IS IT NONDEV TYPE?
         BE       RTYERR            BAD TYPE ENTERED
         AND,D4   =X'FF'
         LC       TB:FLGS,R7        GET DEV TYPE
         BCR,8    RTYERR            NOT TPE OR DISK
         BCR,4    %+4               GO, SET FOR TAPE
         CI,D4    'P'               WAS IT A DP??
         BE       SETNUMBF
         B        RTYERR
         CI,D4    'T'               WAS AT,MT,9T,7T??
         BNE      RTYERR
SETNUMBF BAL,SR3  SETDEV
         CI,R6    '/'               GOT A SLASH
SETNUMBE BE       SETFILE1
         LI,R5    X'F000'           MASK
         LS,R5    1-PFOUT,3         GET CURR. ENTRY
         STW,R5   1-PFOUT,3
         B        DOER
         PAGE
*
* PROCESS INVOKED FOR SIMPLE FILE PLIST WITH NO INSN
* OR SN.    COMMAND FORM: SET X:XXX  YY/FILENAME
*     X:XXX=DCBNAME
*    YY= OP OR DEV LABEL.
*
SETFLE   EQU      %
         CI,R7    2                 # CHARS IN FIELD YY OK?
         BG       SYNTAX
         SAS,D1   -16               SFT FOR COMP
         LW,D2    D1                GET RID OFSIGN
         AND,D2   L(X'FFFF')        KNOCK OF BITS
         CI,D2    'LT'
         BE       SETFLE1           LT=>9T OR DEFAULT
         CI,D2    'MT'              MT=>9T OR DEFAULT
         BNE      %+2               NEITHER, GO NORMAL
SETFLE1  LW,D1    L(X'FFFFF9E3')    DEFAULT DEV & SET
*                                   SIGN EXTEN FOR COMPRE
         LI,R7    TYPMNSZ
         CH,D1    OH:NM,R7          DONT BOTHER TO CHK 'NO'
         BE       %+3
         BDR,R7   %-2
         B        SYNTAX
         PUSH     R7                SAVE INDEX
         BAL,SR3  SETDEV
         PULL     R7
         LI,R5    X'4002'           SET FOR TAPE
         LC       TB:FLGS,R7        GET DEV TYPE
         BCR,8    SYNTAX            NOT TPE OR DISC
         BCR,4    %+2
         LI,R5    X'4001'           SET FOR DISC
         BAL,SR4  ADJUST4           STEP OVER DCB NME
         STS,R5   1,R4              PLCE IN PLIST
         PULL     R4                EVEN UP FROM ADJUST4
         B        SETFILE
         PAGE
*
* PROCESS INVOKED WHEN A / HAS TERMINATED THE SCAN. IT IMPLIES THAT A
* FILE PLIST IS TO BE BUILT.
*
SETFILE  RES     0
SETFILE1 LI,R3    D1
         LD,D1    VERB2
         LW,D3    VERB1
         BAL,SR3  SCAN              GET FID
         CI,R7    0                 INSURE WE GOT SOMETHING
         BE       SYNTAX
         CI,R6    '.'               TEST FOR COMPLEX FID
         BNE      %+3               NONE
         BAL,SR4  FID               BREAK FID
         B        SETFILE2
         LCI      2
         LM,SR2   J:JIT+JACCN
         LI,R7    0
SETFILE2 PUSH     R6                SAVE TERMINATOR
         PUSH     D1                SAVE NAME
         LW,D1    L(X'03000202')    PUT PASSWORD PARAM WORD IN PLIST
         CI,R7    0                 SEE IF WE HAVE ONE
         BNE      SETFILE3          WE DO
         AI,D1    -X'200'           TURN OFF EFFECTIVE WORD COUNT
         LW,R7    VERB1             AND DUMMY WORD CONTENTS FOR COMPACT
         LW,SR1   VERB1
SETFILE3 LI,R5    0
         PUSH     R7                HOLD PASSWORD
         LI,R7    PFPAS
         BAL,SR4  PENT
         PULL     D1
         AI,R7    1
         BAL,SR4  PENT
         STW,SR1  D1
         AI,R7    1
         BAL,SR4  PENT
         LW,SR1   PACC              IF PASSWORD FITS IN PLIST, NAME AND
         PULL     D1
         BAL,SR4  ADJUST4
         LCI      3                 ACCOUNT MAY BE ENTERED WITHOUT
         STM,SR1  PFACC,4
         BAL,SR3  NFND              AND MAKE IT TEXTC
         LW,R5    NAME
         LCI      4
         STM,5    PFNAM,4
         LI,R5    X'4001'           SET FILE INDICATOR BIT AND VARIABLE
         MTW,0    1,4                                                RL2
         BNEZ     %+2                                                RL2
         STS,5    1,R4                                               RL2
         PULL     R4                                                 RL2
         BAL,SR4  BITS              EXTENSION IF M:
         PULL     R6                REGAIN TERMINATOR
         B        DOER              FINISH UP
*
* THE FOLLOWING LOGIC IS ORGANIZED TO PROCESS THE VARIOUS KEYED OPTIONS
* WHICH MAY FOLLOW THE SEMI-COLON FOR DEVICE SPECIFICATIONS.
*
SETKEYS  LD,D1    VERB2             GET KEYWORD FIELD
         LW,D3    VERB1
         LI,R3    D1
         BAL,SR3  SCAN
         CI,R7    0                 INSURE A KEYWORD WAS GIVEN
         BE       SYNTAX
         LI,R5    7                 MSK FOR TYPE FPT
         BAL,SR4  ADJUST4           IF SO, ALLOW CERTAIN FILE OPTIONS
         LS,R5    1,R4              FOR DEVICES MT,7T,9T.
         PULL     R4
         CI,R5    0
         BNEZ     FOPT
         LI,R5    SIZKEYS           DECODE KEYWD & ENTER CORRECT
         CW,D1    KEYS,R5           PROCESS-SAVE TERMINATOR IN R6
         BE       SETK
         BDR,R5   %-2
         LI,R5    SIZFKY
         CW,D1    FKEY,R5
         BE       JUNK
         BDR,R5   %-2
         B        SYNTAX
*
JUNK     LW,R1    TELSTACK
         AI,R1    1
         PUSH     3,D1
         BAL,SR3  NFND              GET ACTUAL SIZE
         LB,R2    R6
         CAL1,1   WRITE             PRINT OPTION GIVEN
         LI,R1    BADDOPT
         LI,R2    28
         CAL1,1   WRITE
         B        SYN2
SETK     EXU      KEYVECT,R5        ENTER THE PROCESS
         LI,D1    -1
         B        LOPT
         TITLE    'SET COMMAND OPTION PROCESSING'
*
* THE FOLLOWING GROUPS OF CODE ARE NEEDED TO CREATE THE UNIQUE PLIST
* ENTRIES FOR THE DESIRED OPTION.
*
* TAB OPTION
*
TAB      CI,R6    '='               CHECK FOR EQUALS SIGN
         BNE      SYNTAX
         LW,R5    TELSTACK
         AI,R5    1
         BUMP     4,R6
         PUSH     R4                SAVE ENTRY ADDRESS
         LI,R4    0                 AND INITIALIZE TAB POSITION COUNT
         STW,R4   0,R5
         STW,R4   1,R5
         STW,R4   2,R5
         STW,R4   3,R5
         STW,R5   R0                SAVE PARAMETER LOCATION
TAB1     LW,D1    VERB1
         LI,R3    D1
         BAL,SR3  SCAN              GET TAB VALUE
         CI,R7    3                 ALLOW NO MORE THAN 3 CHARACTERS
         BG       SYNTAX
         BAL,SR4  DECBIN            CONVERT THE VALUE
         CI,R7    0
         BE       TAB2              FINISHED INPUT-INSERT INTO ENTRY
         STB,R7   *R0,R4            PLACE VALUE IN PARAMETER IMAGE
         AI,R4    1                 BUMP POSITION
         CI,R4    16
         BG       SYNTAX            TOO MANY TAB STOPS
         CI,R6    ','               ANY MORE
         BE       TAB1              YES-GET NEXT ONE
TAB2     LW,R3    R0                GET LAST TAB WORD INTO ENTRY-IF IT
         LW,D1    3,R3              FITS, THE THREE OTHERS ALSO WILL.
         LI,R7    DTABS+3
         LI,R5    0
         PULL     R4
         BAL,SR4  PENT
         BAL,SR4  ADJUST4           PUSH R4 AND ADD OFFSET           RL2
         LI,R7    DTABS
         LCI      3                 IT FIT SO PUT THE REST OF IT IN
         LM,D1    0,R3
         STM,D1   *R4,R7
         LI,7     DTABS+1                                            RL2
         LW,R5    BIT0              PLACE PRESENCE AND DEVICE PLIST BITS
         PULL     R4                                                 RL2
TAB3     RES      0                                                  RL2
         BAL,SR4  ADJUST4                                            RL2
         STS,5    DPW,R4                                             RL2
         LI,R5    X'1000'
         STS,5    1,4                                                RL2
         PULL     R4                                                 RL2
         BUMP     -4,R5                                              RL2
         B        DOER              TABS COMPLETED
*
* LINES OPTION
*
LINES    LI,D2    DLINES            SET DISPLACEMENT
         LW,D3    L(X'4000000')     AND PRESENCE BIT
LINES1   CI,R6    '='               CHECK FOR EQUALS TERMINATOR
         BNE      SYNTAX
         LW,D1    VERB1
         LI,R3    D1
         BAL,SR3  SCAN              GET THE VALUE
         CI,R7    3                 MAX # OF CHARACTERS IS 3 (255)
         BG       SYNTAX
         BAL,SR4  DECBIN            CONVERT THE RESULT
         CW,D3    =X'6000000'       SPACE & LINES KEYS
         BAZ      %+3
         CI,R7    255               MAX SPACE & LINES VALUE
         BG       SYNTAX
         CW,D3    =X'20000000'      DATA KEY
         BAZ      %+3
         CI,R7    144               MAX DATA VALUE
         BG       SYNTAX
         LW,D1    R7                A ZERO VALUE EQUALS ONE LINE
         BNEZ     %+2
         LI,D1    1
         LW,R7    D2                PLACE IN PLIST
         LI,R5    0
         BAL,SR4  PENT
         LW,R5    D3                SET PRESENCE AND FLAG FOR DEVICE
         B        TAB3
*
* L OPTION
* ALSO PROCESS FOR OTHER BIT OPTIONS WITH IMAGE IN D1, MASKED BY D2.
*
LOPT     LI,R3    1                 PRESENCE BIT FOR P8
         LI,R7    DDRC
         LI,R5    -1
         BAL,SR4  PENT
         LW,R5    L(X'1000000')
         B        TAB3              DO PRESENCE BITS
*
* SPACE OPTION
*
SPACE    LI,D2    DSPACE            SET DISPLACEMENT
         LW,D3    L(X'2000000')     AND PRESENCE BIT
         B        LINES1
*
* COUNT OPTION
*
COUNT    LI,D2    DCOUNT            SET DISPLACEMENT
         LW,D3    L(X'10000000')    AND PRESENCE BIT
         B        LINES1            COMPLETE THE PROCESS
*
* DATA OPTION
*
DATA     LI,D2    DDATA
         LW,D3    L(X'20000000')
         B        LINES1
*
* SEQ OPTION
*
SEQ      LW,D2    L(X'80008')       SET SEQ BIT
         LI,D1    -1
         LI,R7    DDRC
         LI,R5    -1
         BAL,SR4  PENT
         LW,R5    L(X'01000000')    SET PRESENCE PARAM
         BAL,SR4   ADJUST4          SAVE 4                           RL2
         STS,5    DPW,4                                              RL2
         PULL     R4                                                 RL2
         CI,R6    '='               DID HE SPECIFY AN ID
         BNE      DOER              NO
         LW,D1    VERB1             YES-PICK IT UP
         LI,R3    D1
         BAL,SR3  SCAN
         CI,R7    4                 ALLOW ONLY 4 CHARACTERS
         BG       SYNTAX
         LI,R5    0                 PLACE IO AS IS IN PLIST
         LI,R7    DSEQID
         BAL,SR4  PENT
         LW,R5    L(X'40000000')
         B        TAB3
*
* NODRC OPTION
*
NODRC    LW,D2    L(X'400040')      SET BITS TO STORE A PRESENCE AND A
         LI,D1    X'F0000'          ZERO BIT IN DDRC
         B        LOPT
*
* NOVFC OPTION
*
NOVFC    LI,D2    X'20002'
         B        NODRC+1
*
* BCD OPTION
*
BCD      LW,D2    L(X'200020')
         B        NODRC+1
*
* NOFBCD OPTION
*
NOFBCD   LI,D2    X'4004'
         B        NODRC+1
*
* UNPACK OPTION
*
UNPACK   LW,D2    L(X'100010')
         B        NODRC+1
*
* NO L OPTION
*
NOL      LI,D2    X'10001'
         B        NODRC+1
         PAGE
*
* THE FOLLOWING HANDLES THE OPTIONS PERTAINING TO FILE SPECIFICATIONS.
*
FOPT     LI,R5    SIZFKY            SEARCH FILE OPTION LIST
         CW,D1    FKEY,R5
         BE       FOPT2
         BDR,R5   %-2
         LI,R5    SIZKEYS
         CW,D1    KEYS,R5
         BE       FOPT1
         BDR,R5   %-2
         B        SYNTAX
*
FOPT2    LB,R3    FTABLE,R5         GET ENTRY FROM OPT TABLE
         BAL,SR4  ADJUST4
         LW,D4    1,R4
         PULL     R4
         AND,D4   L(X'00000007')    GET F10,F11,F12
         CI,D4    5                 IS IT ANS TAPE?
         BNE      %+2               NO
         AND,D4   L(X'00000004')    KNOCK OFF F12
         LS,R3    D4                COMPARE AGAINST OPTION
         BNEZ     FOPK,R5           DO THE OPTION
         LW,R1    TELSTACK
         AI,R1    1
         PUSH     3,D1
         BAL,SR3  NFND
         LB,R2    R6
         CAL1,1   WRITE
         LI,R1    BADOPT
         LI,R2    20
         CAL1,1   WRITE
         BAL,SR4  ADJUST4
         LI,R3    7
         LS,R3    1,R4
         PULL     R4
         LW,R1    ERRFIM,R3
         LI,R2    8
         CAL1,1   WRITE
         B        SYN2
*
ERRFIM   GEN,32   QMARK
         GEN,32   FFILE
         GEN,32   LLABLE
         GEN,32   QMARK
         GEN,32   QMARK
         GEN,32   AANS
FOPT1    LW,R1    TELSTACK
         AI,R1    1
         PUSH     3,D1
         BAL,SR3  NFND              GET ACTUAL SIZE
         LB,R2    R6
         CAL1,1   WRITE             PRINT OPTION
         LI,R1    BADFOPT1
         LI,R2    44
         CAL1,1   WRITE
         B        SYN2
         PAGE
*
* CONSECUTIVE OPTION
*
CONSEC   LI,D1    1
         LI,R7    P6
         LW,R5    L(X'4000000')
         B        DOPENT                                             RL2
RSTORE   RES      0                                                  RL2
         CI,R6    '='                                                RL2
         BNE      SYNTAX                                             RL2
         LW,D1    VERB1                                              RL2
         LW,D2    VERB1                                              RL2
         LI,R3    D1                                                 RL2
         BAL,SR3  SCAN              GET VALUE                        RL2
         BAL,SR4  DECBIN                                             RL2
         LW,12     7                                                 RL2
         BEZ      SYNTAX
         LW,5     =X'00FFFFFF'      EXCEED MAX ???
         CW,7     5
         BG       SYNTAX            YES
         LI,R7    P20                                                RL2
         LI,5     X'1000'           P20 POSITION                     RL2
         B        DOPENT                                             RL2
*
RANDOM   RES      0                                                  RL2
         LI,D1    3                 RANDOM
         B        CONSEC+1                                           RL2
* KEYED OPTION
*
KEYED    LI,D1    2
         B        CONSEC+1
*
* SEQUEN OPTION
*
SEQUEN   LI,D1    1
         LI,R7    P7
         LW,R5    L(X'2000000')
DOPENT   RES      0                                                  RL2
         BAL,SR4  PENT
         B        DOER
*
* DIRECT OPTION
*
DIRECT   LI,D1    2
         B        SEQUEN+1
*
* IN OPTION
*
IN       LI,D1    1
         CI,R6    ','
         BNE      IN1
         PUSH     D1
         LD,D1    VERB2
         LI,R3    D1
         BAL,SR3  SCAN
         CI,R7    0
         BE       SYNTAX
         CD,D1    SHARE
         BNE      %+3
         LI,D3    X'300'
         B        %+4
         CD,D1    EXCL
         BNE      SYNTAX
         LI,D3    X'200'
         PULL     D1
         LI,D2    X'300'
         LS,D1    D3
IN1      LI,R7    P8
         LW,R5    L(X'1000000')
         B        DOPENT                                             RL2
         PAGE
*
* OUT OPTION
*
OUT      LI,D1    2
         B        IN+1
*
* INOUT OPTION
*
INOUT    LI,D1    4
         B        IN+1
*
* OUTIN OPTION
*
OUTIN    LI,D1    8
         B        IN+1
*
* RELEASE OPTION
*
REL      LI,D1    1
         LI,R7    P10
         LW,R5    L(X'400000')
         B        DOPENT                                             RL2
*
* SAVE OPTION
*
SAVEOPT  LI,D1    2
         B        REL+1
*
* CYLINDER OPTION
*
CYLINDER LW,D2    L(X'200000')      SET CYL BIT(10) WORD 0
         LI,D1    -1
         LI,R7    0
         LI,R5    -1
         BAL,SR4  PENT
         B        DOER
*
* NOSEP OPTION
*
NOSEP    LW,D2    L(X'400000')      SET NOSEP BIT(9) WORD 0
         B        CYLINDER+1
*
* EXPIRE OPTION
*
EXPIRE   BAL,SR3  GTFIELD1
         CI,R7    0
         BE       SYNTAX            NO, ERROR
         CD,D1    NEVER             IS IT NEVER
         BE       EXPIRE50
         CI,R6    ','               WAS ',' SCANNED AS TERMINATOR
         BE       EXPIRE10          YES, MM,DD,YY ASSUMED
*
         CI,R7    3                 MORE THAN 3 DIGITS SCANNED
         BG       SYNTAX            ERROR
         BE       EXPIRE5
         CI,R7    2
         BE       EXPIRE3
         OR,D1    L(X'F0F0')
         SCS,D1   -8                SHIFT TO BYTE 3
EXPIRE3  OR,D1    F0F9
         SCS,D1   -8                SHIFT TO BYTES 2,3
EXPIRE5  SCS,D1   -8                SHIFT TO BYTES 1,2,3
         LW,D2    L(X'F0F04040')
         B        EXPIRE50
*
EXPIRE10 RES      0                 PROCESS MM,DD,YY
         BAL,SR4  EXPIRE55          PERFORM VALIDITY CHECK ON MM
         CW,D1    EDAY              MM>12
         BG       SYNTAX            ERROR
         STH,D1   D4                SAVE MM
         LW,D1    VERB1
         BAL,SR3  SCAN              SCAN FOR YY
         CI,R6    ','               WAS ',' BETWEEN MM,DD
         BNE      SYNTAX            NO, ERROR
         BAL,SR4  EXPIRE55          PERFORM VALIDITY CHECK ON DD
         CW,D1    EMONTH            DD>31
         BG       SYNTAX            YES, ERROR
         LI,R7    1
         STH,D1   D4,R7             SCAN FOR MM,DD
         LW,D1    VERB1             SCAN FOR YY
         BAL,SR3  SCAN
         BAL,SR4  EXPIRE55          PERFORM VALIDITY CHECK ON YY
         LW,D2    ZEROS
         LI,R7    1
         STH,D1   D2,R7
         STW,D4   D1
*
EXPIRE50 RES      0
         BAL,SR4  ADJUST4
         LW,SR4   L(X'04000202')    EXPIR,DATE VLP CONTROL WORD
         LCI      3
         STM,SR4  PFEXP,R4
         PULL     R4
         B        DOER
*
EXPIRE55 RES      0                 PERFORM VALIDITY CHECK ON MM,DD,YY
         CI,R7    2                 DIGITS SCANNED>2
         BG       SYNTAX            YES, ERROR
         BE       EXPIRE58
         SCS,D1   -24               1 DIGIT SCANNES
         CW,D1    BCZRO1            IS IT=0
         BE       SYNTAX            YES, ERROR
         OR,D1    L(X'4040F000')    NO PUT ZERO IN BYTE 2
         B        *SR4
EXPIRE58 RES      0
         SCS,D1   -16               2 DIGITS SCANNED
         CW,D1    BCZRO2            IS IT 00
         BE       SYNTAX            YES, ERROR
         B        *SR4
         PAGE
TRIES    BAL,SR3  GTFIELD1
         CI,R7    3
         BG       SYNTAX
         BAL,SR4  DECBIN
         CI,R7    255
         BG       SYNTAX
         LW,D1    R7
         BEZ      DOER
         LI,R7    P5
         LW,R5    L(X'08000000')
         B        DOPENT
*
RECL     BAL,SR3  GTFIELD1
         CI,R7    5
         BG       SYNTAX
         BAL,SR4  DECBIN
         CI,R7    X'7FFF'
         BG       SYNTAX
         LW,D1    R7
         BEZ      DOER              SKIP, TAKE DEFAULT
         LI,R7    P4
         LW,R5    L(X'10000000')
         B        DOPENT
*
         TITLE    'C00 CPV SET OPTIONS'
*
*        KEYM
*
KEYM     EQU      %
         BAL,SR3  GTFIELD1
         CI,R7    2
         BG       SYNTAX
         BAL,SR4  DECBIN
         CI,R7    31
         BG       SYNTAX
         LW,D1    R7
         LI,R7    P13
         LW,R5    L(X'00080000')
         B        DOPENT
*
*        ABCERR
*
ABCERR   EQU      %
         LW,R3    1,R4
         LB,R3    R3
         AI,R3    4+4               ROUND OFF& COUNT FLINK WD
         SLS,R3   -2                CONVERT TO WDS
         AW,R3    R4
         LW,R5    L(X'00100000')    ABCERR FLG
         STS,R5   *R3
         B        DOER
*
*        FORMAT
*
FORM     EQU      %
         BAL,SR3  GTFIELD1
         CI,R7    1
         BNE      SYNTAX
         LB,D1    D1
         LI,R3    SZFRM
         CB,D1    FRM,R3
         BE       %+3
         BDR,R3   %-2
         B        SYNTAX
         LW,D1    R3
         LI,R7    P6
         LW,R5    L(X'04000000')
         B        DOPENT
*
*
         BOUND    4
FRM      DATA,1   0,'F','D','V','U'
SZFRM    EQU      BA(%)-BA(FRM)-1
         BOUND    4
*
*        LRECL
*
LRECL    EQU      %
         BAL,SR3  GTFIELD1
         CI,R7    5
         BG       SYNTAX
         BAL,SR4  DECBIN
         CI,R7    X'7FFF'
         BG       SYNTAX
         CI,R7    0
         BE       DOER              TAKE THE DEFAULT, SKIP
         LW,D1    R7
         LI,R7    P20
         LW,R5    L(X'00001000')
         B        DOPENT
*
*        DENSITY
*
DENSITY  EQU      %
         BAL,SR3  GTFIELD1
         CW,D1    L(X'F1F6F0F0')
         BNE      DENST1            NOT 1600 BPI
* A ZERO WORD CANNOT BE STORED IN A/M ADCB FPT SO 0=2000 HERE.
         LI,D1    X'2000'           SET 1600 BPI
DENST2   LI,R7    P21
         LW,R5    L(X'00000800')
         B        DOPENT
*
DENST1   CW,D1    L(X'F8F0F040')
         BNE      SYNTAX
         LI,D1    1                 SET FOR 800 BPI
         B        DENST2
*
*        VOL
*
VOL      EQU      %
         BAL,SR3  GTFIELD1
         CI,R7    0
         BE       SYNTAX
         BAL,SR4  DECBIN
         CI,R7    50
         BG       SYNTAX
         LW,D1    R7
         LI,R7    P16
         LW,R5    L(X'00010000')
         B        DOPENT
*
*        ASCII
*
ASCII    EQU      %
         LI,D1    1                 CCF=1
EBCDIC1  LI,R7    P22
         LW,R5    L(X'00000400')
         B        DOPENT
*
*        EBCDIC
*
EBCDIC   LI,D1    X'2000'           0=2000 HERE AND FOR DENSITY
         B        EBCDIC1
*
*        BLKL
*
BLKL     EQU      %
         BAL,SR3  GTFIELD1
         CI,R7    5
         BG       SYNTAX
         BAL,SR4  DECBIN
         CI,R7    X'7FFF'
         BG       SYNTAX
         LW,D1    R7
         BEZ      SYNTAX
         LI,R7    P4
         LW,R5    L(X'10000000')
         B        DOPENT
*
*        CONCAT
*
CONCATOP EQU      %
         BAL,SR3  GTFIELD1
         CI,R7    3
         BG       SYNTAX
         BAL,SR4  DECBIN
         CI,R7    255
         BG       SYNTAX
         CI,R7    2
         BL       SYNTAX
         LW,D1    R7
         LI,R7    P18
         LW,R5    L(X'00004000')
         B        DOPENT
*
*        SPARE
*
SPARE    EQU      %
         BAL,SR3  GTFIELD1
         CI,R7    3
         BG       SYNTAX
         BAL,SR4  DECBIN
         CI,R7    255
         BG       SYNTAX
         LW,D1    R7
         BEZ      DOER              SKIP, TAKE DEFAULT
         LI,R7    P18
         LW,R5    L(X'00004000')
         B        DOPENT
*
*        NEWX
*
NEWX     EQU      %
         BAL,SR3  GTFIELD1
         CI,R7    0
         BE       NEWX1
         CI,R7    3
         BG       SYNTAX
         BAL,SR4  DECBIN
         SLS,R7   8                 SHFT SLIDES OVER
         CI,R6    ','               GOT ANOTHER FIELD
         BE       NEWX2             BOTH FIELDS PRES
         LW,D1    R7
         LI,R7    P17
         LW,R5    L(X'00008000')
         B        DOPENT
*
NEWX1    CI,R6    ','
         BNE      SYNTAX
NEWX2    STW,R7   D2
         LW,D1    VERB1
         LI,R3    D1
         BAL,SR3  SCAN
         CI,R7    3
         BG       SYNTAX
         BAL,SR4  DECBIN
         CI,R7    255
         BG       SYNTAX
         LW,D1    D2
         LI,R3    3
         STB,R7   D1,R3
         LI,R7    P17
         LW,R5    L(X'00008000')
         B        DOPENT
*
*
         PAGE
*
*  SIXPACK HASHES A SIX CHAR SERIAL# INTO 1 WORD
*  R1=BYTE ADDRESS OF SERIAL #...SET IN THIS VERSION.
*  R2=RESULT
*  CALL BAL,SR4 SIXPACK
*
*
SIXPACK  EQU      %
         PUSH     5,R1              SAVE REGS
         LI,R1    D1                CALCULATE B.A. OF D1
         SLS,R1   2                 GET BYTE ADR
         LI,R5    0
         LI,R4    6
SIXPACK1 EQU      %
         LB,R3    0,R1
         AI,R1    1
         SLS,R3   26
         SLD,R2   2
         SLS,R3   -28
         MI,R5    10
         AW,R5    R3
         BDR,R4   SIXPACK1
         SLS,R2   20
         OR,R2    R5
         STW,R2   D1
         PULL     5,R1              EVEN UP
         B        *SR4
         PAGE
*
* SN OPTION PROCESSING.
*   LIMIT OF 3 SERIAL #S.  ANS TAPE MUST BE SIX CHARS
*   AND MUST BE HASHED.  OTHERS MAY BE FOUR CHARS OR
*   LESS AND ARE STORED AS IS.
*
*
SNOPT    EQU      %
         CI,R6    ';'               NO ARGS PRES??
         BE       NOSN              NONE, DO DELETE
         CI,R1    1                 CMMND LINE FINISHED?
         BLE      NOSN              YES, IMPLIES DELETE
         CI,R6    '='
         BNE      SYNTAX
         BAL,SR4  ADJUST4           PUSHES R4
         LW,R5    PFOUT,R4          GET CW IF ANY
         BNEZ     %+3               GOT ONE
         LW,R5    =X'07000000'      SKELETON CW
         STW,R5   PFOUT,R4
         PUSH     R5                * CW 1ST INTO STACK
         SLS,R5   16
         LB,R5    R5                GET PRESENT COUNT
         PUSH     R5                * COUNT 2ND INTO STACK
         CI,R5    3                 MAX # ALLOWED
         BGE      NOSNSPC           NO SPACE LEFT
         LI,D4    X'4000'
         STS,D4   1,R4              SET VLP PRES JUST IN CASE
         LI,D4    X'F'
         LS,D4    1,R4              GET ASN, LOOKING FOR ANS TPE
         CI,D4    5                 CHK FOR ANS TPE
         BE       %+2
         LI,D4    0                 IGNORE OTHERS
         PUSH     D4                * POSS ANS TPE 3RD INTO STACK
         LW,R5    TELSTACK
         AI,R5    -2
         LW,D4    1,R5              GET COUNT
         AI,D4    PFOUT
         AW,D4    R4                ABS POINTER TO LAST USED SLOT
SNOPT1   LD,D1    VERB2
         LI,R3    D1
         PUSH     R5
         BAL,SR3  SCAN
         PULL     R5
         CI,R7    0
         BE       SYNTAX            NO CHARS, ERROR
         CI,R7    6
         BG       SYNTAX
         MTW,0    2,R5              SEE IF ANS TAPE
         BEZ      SNOPT2
         CI,R7    6                 MUST BE EXACTLY SIX CHARS
         BNE      SYNTAX
         BAL,SR4  SIXPACK           HSH THE ANS SN.
SNOPT3   AI,D4    1                 BUMP FOR STORE
         MTW,1    1,R5              BUMP COUNT
         STW,D1   *D4               PUT SN AWAY
         CI,R6    ','               ANY MORE?
         BNE      SNOPTX            NO
         LW,SR3   1,R5              GET COUNT
         CI,SR3   3
         BGE      NOSNSPC           NO MORE ROOM IN PLIST
         B        SNOPT1            GET ANOTHER SN
*
SNOPT2   CI,R7    4                 STD CASE
         BG       SYNTAX
         B        SNOPT3
*
SNOPTX   PULL     3,D1              D1=CW, D2=COUNT, D3=ANS?
         LI,R5    2
         STB,D2   D1,R5             PUT COUNT IN CW
         AI,R5    1
         STB,D2   D1,R5             PUT LENGTH OF ENTRY
         STW,D1   PFOUT,R4          PUT CW AWAY
         PULL     R4
         B        DOER
*
*
NOSNSPC  LI,R1    SNMSG
         LI,R2    29
         CAL1,1   WRITE
         B        SYN2
*
SNMSG    TEXT     ' MAX. NUMBER OF SN''S EXCEEDED'
*
*
NOSN     EQU      %
         BAL,SR4  ADJUST4           PUSHES R4
         LI,D4    X'F'
         LS,D4    1,R4              SEE IF PLIST DEVICE TYPE?
         BNEZ     %+4               NO-BRANCH
         LW,D4    =X'FFFFBFFF'      YES, RESET VLP BIT
         AND,D4   1,R4               AS 'SN' IS ONLY ONE POSSIBLE
         STW,D4   1,R4
         LI,R5    PFOUT+3
         LI,D4    0
         LI,R7    4
         STW,D4   *R4,R5            ZER0 THE SN'S &CW
         AI,R5    -1
         BDR,R7   %-2
         PULL     R4
         B        DOER
*
*
*
* GTFIELD1:  FOR SET OPTS THAT USE '=' (EQUAL SIGN)
*
GTFIELD1 EQU      %
         CI,R6    '='
         BNE      SYNTAX
         LD,D1    VERB2
         LW,D3    VERB1
         LI,R3    D1
         B        SCAN              EXIT ON SR3
*
*
         PAGE
*
*  READ ACCT OPTION PROCESSING
*
READOPT  EQU      %
         LI,R7    NOREAD            ENTRY TO DELE READ ACCTS
         BAL,SR3  NONONE            SEE IF DELE OR ENTER.
         BAL,SR3  GTFIELD1          GET 1ST ENTRY
         CI,R7    0
         BE SYNTAX
         CI,R7    8                 MAX #
         BG       SYNTAX
         BAL,SR4  ADJUST4           PUSHES R4
         AI,R4    PFRD              R4 ABS ADDR OF RD C.W.
         LW,D4    *R4
         BNEZ     %+3
         LW,D4    =X'05000000'
         STW,D4   *R4
         BAL,SR3  ACCTS
         LW,D1    =X'05000000'      RD CONTROL WD (CW)
         B        ACCEXIT           PUT IT AWAY
*
*  WRITE ACCT OPTION
*
WRITEOPT EQU      %
         LI,R7    NOWR              ENTRY TO DELE WRITE ACCTS
         BAL,SR3  NONONE
         BAL,SR3  GTFIELD1
         CI,R7    0
         BE       SYNTAX
         CI,R7    8                 MAX #
         BG       SYNTAX
         BAL,SR4  ADJUST4
         AI,R4    PFWRT
         LW,D4    *R4
         BNEZ     %+3
         LW,D4    =X'06000000'
         STW,D4   *R4
         BAL,SR3  ACCTS
         LW,D1    =X'06000000'      WRT DUMMY CW
         B        ACCEXIT
         PAGE
*
*  EXECUTE ACCT OPTION
*
EXECUTE  EQU      %
         LI,R7    NOEX              ENTRY TO DELE EXECU ACCTS
         BAL,SR3  NONONE            SEE IF DELE OR NOT.
         BAL,SR3  GTFIELD1
         CI,R7    0
         BE       SYNTAX
         CI,R7    8
         BG       SYNTAX
         BAL,SR4  ADJUST4
         AI,R4    PFEXU
         LW,D4    *R4
         BNEZ     %+3
         LW,D4    =X'14000000'
         STW,D4   *R4
         BAL,SR3  ACCTS
         LW,D1    =X'14000000'      EXU DUMMY CW
         B        ACCEXIT
*
*  UNDER 'PROCESSOR' OPTION
*
UNDEROP  EQU      %
         CI,R6    ';'               DELETE PROCESSOR NAME?
         BE       NOUNDE            YES
         CI,R1    1                 DELE? LINE FINISHED?
         BLE      NOUNDE            YES
         BAL,SR3  GTFIELD1
         CI,R7    0
         BE       SYNTAX
         CI,R7    11                MAX CHAR ALLOWED
         BG       SYNTAX
         PUSH     3,R4
         BAL,SR3  NFND              CVRT TO TEXTC
         LCI      3
         STM,R6   D1
         PULL     3,R4
         BAL,SR4  ADJUST4           PUSHES R4
         LW,SR4   =X'15000303'
         LCI      4
         STM,SR4  PFUND,R4
         PULL     R4
         B        DOER
*
*
* DELET EXISTING PROCESSOR NAME FROM ADCB PLIST THIS DCB
*
NOUNDE   BAL,SR4  ADJUST4           PUSHES R4
         LI,R5    PFUND+3
         LI,D4    0
         LI,R7    4
         STW,D4   *R4,R5
         AI,R5    -1
         BDR,R7   %-2
         PULL     R4
         B        DOER
*
         PAGE
*
*
* LINK=SR3
* R4=ABS ADDR OF OPTION
* RETURN D4 # OF WDS USED.
* D4 CONTAINS CW ON ENTRY
*
ACCTS    EQU      %
         PUSH     SR3
         SLS,D4   16
         LB,D4    D4                # WDS IN USE
         CI,D4    14                ANY SPACE LEFT????
         BG       ACCTERR           NOPE
*
         LW,R5    R4
         AW,R5    D4                ADD # ALREADY USED
         AI,R5    1                 PLUS CW
ACCTS3   LCI      2
         STM,D1   *R5               PUT EM AWAY
         AI,D4    2                 COUNT EM
         CI,R6    ','               ANY MORE?
         BNE      ACCTS4
         BAL,SR4  GTACCT            GET ANOTHER ACCT
         B        ACCTS3
ACCTS4   PULL     SR3
         B        *SR3
*
ACCTERR  LW,R1    TELSTACK
         AI,R1    1
         LCI      9
         LM,R7    BADACCTS
         PUSH     9,R7              PUT MESSG IN STACK
         LB,R4    *R4               TYPE OF OPT FROM CW
         CI,R4    5                 READ?
         BNE      %+3
         LD,R4    RDNAME
         B        ACCTERR1
         CI,R4    6                 WRITE?
         BNE      ACCTERR2
         LD,R4    WRNAME
ACCTERR1 STW,R4   0,R1
         STW,R5   1,R1              PUT IN MESSG STRING
ACCTERR2 LI,R2    36
         CAL1,1   WRITE
         B        SYN2
*
*
BADACCTS TEXT     'EXECUTE ACCOUNTS EXCEED 8 ENTRIES   '
*
         BOUND    8
WRNAME   TEXT     '  WRITE '
RDNAME   TEXT     '   READ '
         PAGE
*
* GET ACCOUNT # FOR RD,WRT, AND EXU SET OPTIONS
* SR4=LINK
* D4= # OF ENTRIES (2WDS EACH. MAX OF 8)
* R5= DISPLACE INTO IN PROGRESS PLIST.
*
GTACCT   EQU      %
         LI,R3    D1
         LD,D1    VERB2
         PUSH     R5                SAVE
         BAL,SR3  SCAN
         PULL     R5                RECOVER COUNT
         CI,R7    0
         BE       SYNTAX
         CI,R7    8                 MAX #
         BG       SYNTAX
         CI,D4    15
         BGE      ACCTERR
         AI,R5    2
         B        *SR4
*
* ACCEXIT: EXIT ROUTINE FOR RD,WRT, AND EXU OPTIONS
*
ACCEXIT  LI,R5    2
         STB,D4   D1,R5             UPDATE # WDS IN USE
         AI,R5    1
         STB,D4   D1,R5
         STW,D1   *R4               PUT CW AWAY
         PULL     R4
         B        DOER
*
         PAGE
*
* THE FOLLOWING ROUTINES NOREAD,NOWR AND NOEX WIPE OUT
* THOSE ACCOUNTS WHICH HAVE BEEN SET DUE TO THE READ,WRIT AND
* EXECUTE OPTIONS.
*
NOREAD   LI,R7    PFRD
         B        WIPEOUT
*
NOWR     LI,R7    PFWRT
         B        WIPEOUT
*
NOEX     LI,R7    PFEXU
WIPEOUT  LI,D1    0
         BAL,SR4  ADJUST4
         LI,R5    0
         AW,R4    R7                POINT TO ENTRY
WIPEOUT1 STW,D1   *R4,R5
         AI,R5    1
         CI,R5    17
         BL       WIPEOUT1
         PULL     R4
         B        DOER
*
*
NONONE   EQU      %
         CI,R6    ';'               OPTION TERMINATED?
         BE       *R7               YES, DO DELETE
         CI,R1    1                 CMMND LINE EXHAUSTED?
         BLE      *R7               YES, DO DELETE
         B        *SR3              NO DEL, GO PROCESS OPTIONS.
         TITLE    'SET COMMAND UPDATE FUNCTION'
*
* PROCESS FOR UPDATING A PREVIOUSLY MADE SPECIFICATION. FIND THE OLD
* A/M ENTRY FIRST.
*
SETUPDAT LW,R4    J:ABUF
         BAL,SR4  ASSIGN+1          R6 AND R7 CONTAIN DCB NAME
         LW,R4    R5
         BEZ      BADDCB            NO MATCH
         BAL,SR4  EXPAND            OPEN UP THE CURRENT A/M ENTRY
         B        SETKEYS           AND GO PROCESS IN THE NORMAL MANNER
*
*
* LINK   SR4
* R4     ADDR OF A/M BUFFER
* R5     ABS ENTRY ADDR OF DESTINATION IN A/M TABLE.
*
*        MOVESET
* CALLED FROM 'DOER' IN SET LOGIC. USED FOR NEW & UPDATE SETS.
* 'SZCELL' CONTAINS SZE OF ENTRY TO MOVE INTO A/M TABLE.*
*
*
MOVESET  EQU      %
         LI,R2    0                 ZRO FWD LINK &
         STW,R2   SETBUF            AS ITS LAST IN CHAIN.
         LW,R2    R4
         AI,R2    X'1FF'
         SW,R2    R5                SPACE LEFT IN A/M TABLE
         LW,R3    SZCELL            SZE OF ENTRY
         CW,R3    R2
         BG       MVERR1            WON'T FIT
         AW,R3    R5
         SW,R3    R4                FIND NEW AVAIL
         STW,R3   0,R4              SET NEW AVAIL HEAD
         LW,R3    SZCELL
         LI,R4    SETBUF
         AI,R4    -1
         AI,R5    -1
         AI,R3    1
         LW,R6    *R4,R3
         STW,R6   *R5,R3
         BDR,R3   %-2               MOVE IT A/M BUF
         B        *SR4
*
MVERR1   EQU      %
         LI,R1    MVERM1
         LI,R2    36
         CAL1,1   WRITE
         B        SYN1
*
MVERM1   TEXT     'CANNOT CREATE OR MODIFY DCB-A/M FULL'
         TITLE    'TABS COMMAND VERB'
TABS     EQU      %
         CI,R6    X'E2'             TABS INQUEIRY ??
         BE       TABS1             YES, BRANCH
         CI,R6    ' '               CHECK FOR SPACK
         BNE      SYNTAX
         LW,R4    TELSTACK
         AI,R4    1
         BUMP     7,R5
         LCI      7
         LM,SR1   TABPL
         STM,SR1  0,R4
         AI,R4    2
         LI,R0    0                 CLEAR A COUNT FOR TAB VALUES
TABSA    LI,R3    D1
         LW,D1    VERB1
         BAL,SR3  SCAN              GET THE TAB VALUE
         CI,R7    0                 INSURE DATA
         BE       SYNTAX
         CI,R7    3                 ALLOW UP TO 3 CHARACTERS
         BG       SYNTAX
         AI,R0    1                 BUMP THE COUNT
         BAL,SR4  DECBIN            CONVERT THE VALUE TO BINARY
         STW,R0   R3
         STB,R7   *R4,R3            STORE THE VALUE IN PLIST
         CI,R0    16                TEST FOR LIMIT
         BG       SYNTAX
         CI,R6    ','               ANY MORE
         BE       TABSA             YUP
         CI,R1    1                 TEST FOR TRAILING GARBAGE
         BG       SYNTAX
         STB,R0   *R4               NOPE-STORE COUNT
         AI,R4    -2
         CAL1,1   *R4               ISSUE M:DEVICE CAL
         BUMP     -7,R5
         B        PROMPT
*                                   OUTPUT CURRENT TABS
TABS1    EQU      %
         LI,R3    M:UC+19           PT TO END OF TABS
         LI,R7    -16               INDEX BACK
         LB,SR3   *R3,R7            ANY TAB ENTRIES?
         BNEZ     TABS2             YES
         LI,R1    NONE              NO
         LI,R2    4                 BYTE COUNT
         CAL1,1   WRITE             OUTPUT NONE MSSG
         B        PROMPT            PROMPT
*
TABS2    EQU      %                 DISPLAY TABS ROUTINE
         LW,R6    TELSTACK
         AI,R6    1                    SPACE
         BUMP     16,R5                  FOR OUTPUT
         LI,R0    ','               COMMA BETWEEN ENTRIES
         LI,R2    0                 INITIAL BYTE COUNT
TABS4    LB,D1    *R3,R7            GET TAB ENTRY
         BEZ      TABS3             NO ENTRY, GIVEUP
         BAL,SR4  BINDECBCD         CONVERT TO DECIMAL
         LI,R4    0
TABS5    LB,R5    D2,R4
         CI,R5    '0'               IS DATA A ZERO?
         BNE      TABS6
         AI,R4    1
         B        TABS5
TABS6    STB,R5   *R6,R2
         AI,R2    1
         AI,R4    1
         CI,R4    4
         BE       TABS7
         LB,R5    D2,R4
         B        TABS6
*
*
TABS7    STB,R0   *R6,R2
         AI,R2    1
         BIR,R7   TABS4
TABS3    EQU      %
         AI,R2    -1
         LI,R0    ' '               BLANK
         STB,R0   *R6,R2
         LW,R1    R6                BUFFER ADDR TO R1
         CAL1,1   WRITE             OUTPUT TO TERMINAL
         BUMP     -16,R5            EVEN UP
         B        PROMPT            PROMPT
*
* PAGE ROUTINE
* THE PAGE FUNCTION ALLOWS THE ON-LINE USER TO RESET THE
* CURRENT PAGE NO. OUTOUT IN THE HEADER BY THE COC ROUTINE
*
*
PAGE     EQU      %
         CI,R1    0
         BE       SYNTAX            NO INPUT FOLLOWS
         CI,R6    ' '
         BNE      SYNTAX
         LI,R3    D1
         LD,D1    VERB2
         LW,D3    VERB1
         BAL,SR3  SCAN              GET NUMBER
         BAL,SR4  DECBIN            CONVERT TO BIN
         LH,SR3   R7                SEE IF # TO BIG
         BNEZ     SYNTAX            YES, TEL HIM
         LI,R6    JH:PC
         STH,R7   0,R6              PUT VALUE IN JIT
         B        PROMPT
         TITLE    'PLATEN COMMAND VERB'
PLATEN   EQU      %
         CI,R6    'N'               IS IT A PLATEN ONLY ?
         BE       PLATEN1
         CI,R6    ','               ONLY LENGTH PRESENT?
         BE       COMMA+2           IF YES GO PROCESS IT
         LW,D1    VERB1
         LI,R3    D1
         BAL,SR3  SCAN
         CI,R7    0                 WAS DATA PRESENT
         BE       COMMA             NO; GO CHECK FOR COMMA
         CI,R7    3
         BG       SYNTAX            HE GETS ONLY 3 CHARACTERS
         BAL,SR4  DECBIN
         CI,R7    140
         BG       SYNTAX            WIDTH MAGNITUDE TEST
         LI,R5    JB:PCW
         STB,R7   0,R5              STORE WIDTH
COMMA    EQU      %
         CI,R6    ','               IS A LENGHT FIELD PRESENT
         BNE      DONE              NO;
         LI,R3    D1                YES; GET LENGHT
         LW,D1    VERB1
         BAL,SR3  SCAN
         CI,R7    0                 INSURE DATA
         BE       SYNTAX
         CI,R7    3                 ARE MORE THAN 3 CHARACTERS PRESENT
         BG       SYNTAX
         BAL,SR4  DECBIN
         CI,R7    255               CHECK LENGTH MAGNITUDE
         BG       SYNTAX
         DO       A<2
         LI,R6    JB:LPP
         ELSE
         LI,R6    BA(JB:LPP)
         FIN
         STB,R7   0,R6
DONE     EQU      %
         CI,R1    1                 TEST FOR TRAILING JAZZ
         BG       SYNTAX
         B        PROMPT
*
* PLATEN1: INFORMS USER OF CURRENT PLATEN SETTINGS
*
PLATEN1  EQU      %
         LI,R2    12                MESSAGE BYTE SIZE
         LW,R7    TELSTACK          MAKE A BUFFER
         AI,R7    1                   OPEN THE STACK
         BUMP     3,R1
         LCI      3
         LM,SR1   WIDTH             GET WIDTH MESSAGE
         STM,SR1  *R7               PUT IN BUFFER
         LI,R4    2                 SET UP LOOP
         LI,R5    JB:PCW            GET WIDTH
PLATEN2  LB,D1    0,R5              GET DATA BYTE
         CI,D1    0                 HAVE WE GOT A ZERO
         BNE      %+3
         LW,D2    =X'404040F0'
         B        PLATEN4
         BAL,SR4  BINDECBCD         CONVERT IT
         LI,R0    ' '
         LI,R1    0
PLATEN3  LB,R5    D2,R1             PICK UP THE CONVERTED BYTE
         CI,R5    '0'
         BNE      PLATEN4
         STB,R0   D2,R1
         AI,R1    1
         B        PLATEN3
PLATEN4  AI,R7    2                 INC BUFF POINTER
         STW,D2   *R7               # TO BUFFER
         AI,R7    -2                BACK TO BEGIN OF BUFF
         LW,R1    R7                BUF ADDR TO R1
         CAL1,1   WRITE             OUTPUT MESSG
         DO       A<2
         LI,R5    JB:LPP            GET LINE/PAGE
         ELSE
         LI,R5    BA(JB:LPP)
         FIN
         LCI      3
         LM,SR1   LLINES            GET LINES MESSAGE
         STM,SR1  *R7
         BDR,R4   PLATEN2
         BUMP     -3,R1
*
         B        PROMPT            PROMPT
         TITLE   'SAVE'
SAVEP    RES      0
         LW,5     J:JIT+JTELFLGS
         CI,5     1                 JOB STEP
         BANZ     SAVWHAT
         LW,R5    J:EXLY
         AND,R5   =X'04000000'
         BAZ      %+2
         B        EXONLY
*                 INSERT
*                 CODE
*                 FOR
*                 WHICH PROCESSES CAN BE SAVED
         CAL1,4  =X'02000000'       JOADS J:CPOCS AND J:CFLGS
         BAL,4    SETACL            SET AND CLOSE
         BAL,SR3  GETFIELD
         CI,R7    0                 ANYTHING
         BEZ      SAVWHAT
         CI,R6    C'.'
         BE       SAVE00
         CW,D1    ON
         BE       SAVEON
         CW,D1    OVER
         BNE      SAVE00
*                 SAVE OVER FID
         LI,R3    X'40'
SAVEOVR1 STS,R3   J:JIT+JTELFLGS    ON/OVER
         BAL,SR3  GETFIELD
         CI,R7    0
         BE       SYNTAX
SAVEOVR2  BAL,0   FIDER
*                                   GOOD RETURN ON "RO"
         BAL,SR4  FLOP              YES
         LI,R5    X'20'             ON
         LS,R5    J:JIT+JTELFLGS
         BEZ      SAVEOK            NO
         CI,R0    0
         BE       SAVENO
         LI,R4    0
         STS,R4   J:JIT+JTELFLGS
         BAL,SR4  FLOP
SAVEOK   RES      0
         CAL1,9   6                 SUPER CLOSE
         BAL,11   TRUNK             TRUNK DCB'S
*        OPEN     TO WRITE
*
         LH,R4    VERSCELL          CURRENT SYST&VERS
         XW,R4    J:START
         LI,R1    J:JIT
         LI,R2    2048
         CAL1,1   WRITERAD
         XW,R4    J:START
         LI,7    J:JIT
*
         LI,D2    WRITERAD
         BAL,0    JJEND
ENDPRO   BAL,4    SETACL            SET AND CLOSE
         B        CLEANSTACK
SAVWHAT  LI,R1    SAVW              BUF
SAVWHAT1 RES      0
         LI,R2    10
         CAL1,1   WRITE
         B        CLEANSTACK
SAVEON   RES
         LI,R3    X'20'             ON
         B        SAVEOVR1
SAVE00   RES      0
         LI,R3    X'20'
         STS,R3   J:JIT+JTELFLGS    ASSUME ON
         B        SAVEOVR2
*
*
GETFIELD LD,D1    VERB2
         LW,D3    VERB2
         LI,R3    D1
         B        SCAN              EXIT ON SR3
GETACPAS RES      0
         LCI      2
         LM,SR2   J:JIT+JACCN
         LI,R7    0
         LI,SR1   0
         B        0,R5
TRUNK    LI,R4    J:DCBLINK
TRUNKL   LW,R3    *R4               LINK ADR
         BNEZ     TRUNKL2
         LI,R6    M:XX
         B        TRUNKL3
TRUNKL2  LB,R3    *R4
         BEZ      TRUNKAD           LINK ADD
         AI,R3    4
         SLS,R3   -2                #WDS
         AW,R4    R3
         LW,R6    0,R4              DCB ADDRESS
TRUNKL3  LW,R3    0,R6
         CW,R3   =X'00200000'       OPEN
         BAZ      TRUNKL1           NO
         CAL1,1   TRUNKD
TRUNKL1  AI,R4    1
         CI,R6    M:XX              IS IT M:XX
         BE       *SR4              YES END OF TRUNK EXIT
         B        TRUNKL
TRUNKD   DATA     X'92000006'       TRUNK DCB IN 6
         DATA     0
TRUNKAD  LW,R4    0,R4
         B        TRUNKL1
SAVENO   RES      0
         BAL,4    SETACL            SET AND CLOSE M:XX
         B        ONERR
*                 R7= JIT SR4= EXIT
WRITERAD GEN,8,24 X'11',M:XX
         GEN,4,4,24    15,4,0
         DATA     SAVERR
         DATA     SAVERR
         PZE      *1
         PZE      *2
         PZE      0
READAD   GEN,8,24  X'10',M:XX
         GEN,4,4,24    15,4,0
         DATA     GETNG1
         DATA     GETNG1
         PZE      *1
         PZE      *2
         PZE      0
         TITLE     'GET'
GETWHAT  LI,R1    GETW
         B        SAVWHAT1
GET      RES      0
         LW,5     J:JIT+JTELFLGS    JOB STEP
         CI,5     1
         BAZ      NTJBST            COMMAND ILLEGAL UNLESS JOB STEP TIME
         LW,R3    M:XX
         CW,R3   =X'00200000'
         BANZ     LATER             OPEN-
         BAL,SR3  GETFIELD
         CI,R7    0                 FID
         BEZ      GETWHAT           NO
         LI,R5   X'20'
         STS,R5   J:JIT+JTELFLGS    ON = IN
         BAL,SR4  FID               N.A.P.                           RL2
         BAL,SR4  FLOP              OPEN
         CI,R0    0
         BNE      SYSE3             PRIMT 'NOT FOUND' MESSAGE
         LI,7     0                 IN CASE ABUF IS HANGING
         XW,7     J:ABUF            AROUND, USE IT.
         BNEZ     GT10
         LI,SR2   AMBUF             GET SECOND SPEC BUFFER IN
         CAL1,8   GPFPT              CONTEXT AREA TO READ JIT
         BCS,8    AMERR             INTO.  BAD TROUBLE IF NO PAGE
         LI,7     AMBUF
GT10     EQU      %
         LW,1     7
         LI,R2    2048
         CAL1,1   READAD            JIT TO BUFF
         LW,D1    0,R7
         BGZ      GETNG             NOT ON-LINE
         LH,R4    VERSCELL          GET RUNNING CELL
         LW,R5    J:START-J:JIT,R7  SAVED VERS&SYST
         CW,R4    R5
         BNE      GETNG2
         LW,SR4   JBUP,R7
         CI,SR4   JBUPVP            BEGIN-USER-PAGE
         BNE      GETNG1
         LW,SR4   JEUP,R7             AND END-USER-PAGE
         CI,SR4   JEUPVP              MUST BE CORRECT
         BNE      GETNG1
*
*  READ IN ALL PAGES
*
         LI,D2    READAD            FPT FOR READ
         BAL,R0   JJEND             READ THE PAGES IN
*
         LW,R1    DCBLINK,R7        MOVE DCB LINK ADDRESS
         STW,R1    J:DCBLINK        AND SET INTO JIT TABLE
*
         LW,D2    J:ASSIGN-J:JIT,7
         STS,D2    J:ASSIGN       INSERT ASSIGN OR NO ASSIGN CODE TO
*                                  ASSIGN CHK WORD
         LW,R5    JRNST,R7          GET RUNFLAGS FROM OLF JIT TABLE
         AND,R5   =X'380000'        SAVE ONLY FAG BITS
         STS,R5   J:JIT+JRNST
         LCI      3
         LM,D1    (J:CLM+4)-J:JIT,R7  GET CURRENT LM NAME
         STM,D1   J:CLM+4
         LCI      4
         LM,D1    J:CLM-J:JIT,R7    GET PASS & ACCT OF CUR LM
         STM,D1   J:CLM
*  RESTORE EXIT CONTROL ADDRESS
         LW,D2    =X'1011FFFF'      MASK FLAGS EXCEPT XCON
         LS,D2    J:EXTENT-J:JIT,R7 GET OLD XCON ADDR
         STW,D2   J:EXTENT             AND PUT INTO REAL JIT
         LW,D1    J:CPROCS-J:JIT,7
         STW,D1   J:CPROCS
         LW,D1    J:CFLGS-J:JIT,7
         STW,D1   J:CFLGS
         LW,D1    INTENT,7
         STW,D1   J:INTENT
         LCI      3
         LM,D1    J:USENT-J:JIT,7
         STM,D1   J:USENT           +JCB AND TREE
*        MOVE STACK
*        MOVE     TSTACK
*
         LW,R1    UTS+1             ADJUST
         AND,R1  =X'7FFF'           STACK
         LCW,R1   R1
         AI,R1    19
         MSP,R1   UTS
         LI,R1    JB:PROMPT-BA(J:JIT)
         LB,R0    *7,1
         BEZ      NOPROMPT                                           RL2
         AW,R0   =X'2C000000'                                        RL2
         CAL1,1   0                                                  RL2
NOPROMPT   RES    0                                                  RL2
         LI,R1    19                SET STACK TO 19
         LI,2     TSTACK-J:JIT+1
         AW,2     R7
         LW,D1    *2,1
         STW,D1   TSTACK+1,R1
         BDR,R1  %-2
         STW,R1   TSTACK+3   SET WK/CI/II/EI/RP  =0
         LW,R1    =X'00C00000'
         STS,R1   TSTACK+2   SET MAP AND SLAVE
*
         BAL,D4   FREEBUF1          REL SP BUFR1 IF WE'VE GOT IT
PROCSEXIT EQU     %
         LI,R7    -2                INDICATE AMBUF RELEASED
         LI,SR2   AMBUF
         CAL1,8   FPFPT
         CAL1,4  =X'03000000'       LD J:CPOCS
         BCS,8    GETBAD
         BAL,4    SETACL            SET AND CLOSE DCB
         LI,1     2
         STW,1    J:TELFLGS         SET NOT AT JOB STEP.
         B        TEL               RECYCLE
         PAGE
LATER    LI,R1    LATERM
LATERX   CAL1,2   TYPE
LATERX1A LI,R0    0
         LW,R1    =X'60000000'
         STS,R0   J:ASSIGN          RESET PPS AND IORT FLAG
         CI,7     AMBUF
         BNE      LATERX1
         LI,SR2   AMBUF             RELEASE SPEC BUFFER PAGE
         CAL1,8   FPFPT
LATERX1  EQU      %
         BAL,R4   SETACL            CLOSE M:XX
         B        INBREAK1           RELEASE IBUF AND ABORT          RL2
*
PAGERR   LI,R2    JJITVP
         LI,R3    JBUPVP-1
         STD,R2   J:CLL             RESET CONTEXT LIMITS
GETNG    LI,R5    BADJIT
LATERX5  LI,R1    BADFILE
         CAL1,2   TYPE
         LW,R1    R5
         B        LATERX
*
GETNG1   LI,R5    BADLIT
         B        LATERX5
*
GETNG2   LI,R5    BADSYS
         B        LATERX5
*
GETBAD   LI,R5    BADDCBP
         B        LATERX5
*
CVMERR   LI,R1    CVMMES
         B        LATERX
*
NOTGVP   LI,R5    NGVP
         B        LATERX5
TYPE     DATA     X'02000000'
         PZE      *0
         PZE      *1                MESSAGE TEXTC
*
*
         TITLE    'SAVE/GET COMMON ROUTINES'
*        D2=      PLIST
*        R0=      ENTRY
*        R7=      JIT
*
JJEND    RES      0
         CI,R7    J:JIT
         BE       JRDWRT            BR IF SAVE
*
*  VALIDATE MEMORY MANAGEMENT POINTERS
*
         LI,R5    JBUPVP            SET CONTEXT LIMITS
         LW,R4    R7                  TO PASS TESTS BELOW
         AI,R4    J:CLL-J:JIT
         STD,R5   *R4
         LW,R5    R7                ADDRESS OF JIT
         AI,R5    JPLL-2
         LI,R4    5                 # DOUBLEWORDS
JMMLOOP  LD,R2    *R5,R4            GET NEXT PAIR
         CI,R2    X'FFF00'
         BANZ     PAGERR            PAGE NUMBER MUST
         CI,R3    X'FFF00'            BE <= X'FF'
         BANZ     PAGERR
         CW,R2    J:BUP             LOWER LIMIT MUST
         BL       PAGERR              BE >= BUP
         CW,R3    J:EUP             UPPER LIMIT MUST
         BG       PAGERR              BE <= EUP
         STD,R2   J:PLL-2,R4        PUT IN REAL JIT
         BDR,R4   JMMLOOP
         LI,R2    JJITVP
         LI,R3    JBUPVP-1
         STD,R2   J:CLL             SET CONTEXT LIMITS
*
         LI,R5    JBTDP
         LB,SR4   *R7,R5            TOP DYNAMIC PAGE
         CLM,SR4  J:BUP
         BCS,9    PAGERR
         STB,SR4  J:JIT,R5
*
         LI,R5    JBBCP
         LB,SR4   *R7,R5            BOTTOM COMMON PAGE
         CLM,SR4  J:BUP
         BCS,9    PAGERR
         STB,SR4  J:JIT,R5
*
*  READ/WRITE USER PAGES
*
JRDWRT   EQU      %
         LW,R4    R7
         AI,R4    JLMAP             ADDRESS OF LMAP
         LI,R1    JBVLH             HEAD OF LMAP
         LB,R1    *R7,R1            FIRST LMAP ENTRY
         B        JJITLP2
*
JJITLOOP LB,R1    *R4,R1            NEXT LMAP ENTRY
JJITLP2  BEZ      CVMPGS            END OF LMAP
         CI,R1    JBUPVP
         BL       JJITLOOP          IGNORE FPOOL BUFFERS
         CI,R7    J:JIT
         BE       JRW10             BR IF SAVE
         LI,R2    TEL
         SLS,R2   -9
         AI,R2    -1                FIRST PAGE BELOW TEL
         CW,R1    R2
         BG       PAGERR            NO PAGES ALLOWED WHERE TEL IS
         STW,R2   J:EUP             INCREASE J:EUP FOR DELTA DATA
         SLS,R1   9                 WORD ADDRESS
         CAL1,8   =X'84000001'      M:GVP  *R1
         STCF     SR4
         LI,R3    JEUPVP
         STW,R3   J:EUP             RESET J:EUP
         LCF      SR4
         BCS,8    NOTGVP            COULDN'T GET PAGE
         LW,R3    =X'60000000'      SET PURE-PROCEDURE-SWAP, ALLOW
         STS,R3   J:ASSIGN            READ INTO PROCEDURE
         B        JRW15
*
JRW10    SLS,R1   9                 WORD ADDRESS OF BUFFER
JRW15    LI,R2    2048              BYTE COUNT
         LI,SR3   0
         CAL1,1   *D2               READ/WRITE
         AI,SR3   0
         BNEZ     SAVERR
         SLS,R1   -9
         LW,R2    M:XX+13           RECORD SIZE
         CI,R2    2048
         BNE      GETNG1            ERROR
         B        JJITLOOP
*
*  PROCESS M:CVM PAGES
*
CVMPGS   EQU      %
         CI,R7    J:JIT
         BE       JJXIT             BR IF SAVE
         LW,SR1   R7
         AI,SR1   JLMAP
         LW,SR2   R7
         AI,SR2   JCMAP
         LI,R1    X'FF'             LAST VIRTUAL PAGE
CVM10    LB,R4    *SR1,R1           GET NEXT LMAP ENTRY
         CI,R4    1
         BNE      CVM20             NOT CVM PAGE
         LOAD,R5  *SR2,R1           PHYSICAL PAGE
         LW,R4    R1                VIRTUAL PAGE
         SLD,R4   9                 CONVERT TO WORD ADDRESSES
         CAL1,8   CVMFPT            M:CVM
         BCS,8    CVMERR            CAN'T DO IT
CVM20    AI,R1    -1
         CI,R1    JBUPVP
         BGE      CVM10             NOT DONE YET
*
JJXIT    B        *R0               DONE
         TITLE     'TERMINAL COMMAND VERB'
TERMINAL EQU      %
         LC       J:JIT             IGNORE THIS COMMAND IF
         BCS,2    PROMPT            NON-COC USER
         LW,D1    VERB1             BLANKS
         LI,R3     D1
         BAL,SR3   SCAN
         CI,R7     0                WAS DATA PRESENT?
         BE       COCSTAT           GIVE 'EM STATUS
         CI,R6    ','               , TERMINATED SCAN?
         BE       %+3               YES,SKIP CHECKING
         CI,R1     1
         BG        SYNTAX           INSURE NO TRAILING DATA
         LI,R7     SIZETAB1
SRCHTAB1 CW,D1     TERMTAB1,R7
         BE       FOUNDP
         AI,R7     -1
         BGEZ      SRCHTAB1
         CW,D1    =X'A2A381A3'      LOWER CASE 'STAT'US.
         BE       COCSTAT
         B        TERMERR
FOUNDP   RES      0
         CI,R7    4
         BE       COCSTAT           BRANCH IF LINE STATUS WAS REQUESTED
         LW,SR2   TELSTACK          GET STACK POINTER
         AI,SR2   1
         BUMP     4,R5              OPEN STACK UP
         LI,R5    0
         LW,SR3   TERMTYPE,R5       MOVE FPT TO STACK
         STW,SR3  *SR2,R5            FOR CHNGE CAL
         AI,R5    1
         CI,R5    4
         BL       %-4                KEEP GOING
         LB,R5    TERMTAB2,R7       COCTERM BYTE
         LI,R1    3                 INDX INTO FPT
         STW,R5   *SR2,R1           STORE COCTERM
         LB,R5    TERMTAB3,R7       ALGO BYTE
         AI,R1    -1
         SLS,R5   19                SHIFT ALGO #; POSITION IN BITS 10-12
         AI,R5    X'38'             +.38; SELECTION MASK
         STW,R5   *SR2,R1           STORE ALGORITHM #
         CI,R6    ','               ALGOR OVERRIDE? PRES
         BNE      CHNGTYPE          NO, TAKE THE DEFAULT
         LW,D1    VERB1
         LI,R3    D1
         LI,R1    2                 DISP INTO BUFFER
         BAL,SR3  SCAN              SCAN FOR ALGO OVERIDE
         CI,R7    1
         BNE      SYNTAX
         BAL,SR4  DECBIN            CONVERT DEC #
         LI,R5    2                 INDX INTO FPT
         SLS,R7   19                SHIFT ALGO #; POSITION IN BITS 10-12
         AI,R7    X'38'             +.38; SELECTION MASK
         STW,R7   *SR2,R5           PUT IN FPT
CHNGTYPE CAL1,8   *SR2
         BCS,8    CHNGERR           ERROR EXIT
         BUMP     -4,R5             RESTORE STACK
         B        PROMPT
CHNGERR  BUMP     -4,R5             MUST EVEN UP STACK
         B        TERMERR           ERROR RETURN
*
*
COCSTAT  CAL1,8   COCSTATC          GET STATUS OF LINE
         LB,R3    SR1
         AI,R3    -4
         BLZ      %+2
         SLS,R3   -1
         LW,R1    TTYPTAB+4,R3
         BAL,R4   COCPRT            PRINT TERMINAL TYPE
         LW,SR2   MODECW
         LI,SR3   MODECW
COCMLOOP SLS,SR2  1
         BEV      NOCOCM            BIT TO BE IGNORED
         AI,SR3   1
         LI,R1    RETN              NEW LINE
         LI,R2    1
         CAL1,1   WRITE
         LW,R1    *SR3
         BAL,R4   COCPRT            IDENTIFY MODE
         LI,R1    COCON             GIVE
         AI,SR1   0                  ON/
         BLZ      %+2                 OFF
         LI,R1    COCOFF               MSG
         LI,R2    4
         CAL1,1   WRITE
NOCOCM   SLS,SR1  1
         AI,SR2   0
         BNEZ     COCMLOOP          GO IF MORE TO CHECK
         B        PROMPT
COCPRT   EQU      %
         LB,R2    R1
         CAL1,1   WRITE
         B        0,R4
*
TERMTYPE DATA     X'06200000'       FPT FOR TRANS TBL
         DATA     X'06000000'       & COC IDLE ALGORITHM
         DATA     0                 IDLE FIELD
         DATA     0                 COCTERM FIELD
*
*
COCSTATC GEN,8,4,20 6,4,0           FPT TO GET VALUES FROM LINE TABLES
*
TTYPTAB  GEN,8,24 7,TTYP0
         GEN,8,24 7,TTYP1
         GEN,8,24 7,TTYP2
         GEN,8,24 9,TTYP3
         GEN,8,24 14,TTYP4
         GEN,8,24 14,TTYP5
         GEN,8,24 19,TTYP6
         GEN,8,24 19,TTYP7
TTYP0    TEXT     '
TTY 33'
TTYP1    TEXT     '
TTY 35'
TTYP2    TEXT     '
TTY 37'
TTYP3    TEXT     '
XDS 7015'
TTYP4    TEXT     '
2741 EBCD STD'
TTYP5    TEXT     '
2741 EBCD APL'
TTYP6    TEXT     '
2741 SELECTRIC STD'
TTYP7    TEXT     '
2741 SELECTRIC APL'
MODECW   DATA     X'008C6CA0'
         GEN,8,24 8,MM0
         GEN,8,24 14,MM1
         GEN,8,24 19,MM2
         GEN,8,24 10,MM3
         GEN,8,24 15,MM4
         GEN,8,24 16,MM5
         GEN,8,24 12,MM6
         GEN,8,24 16,MM7
         GEN,8,24 14,MM8
*
COCON    TEXT     ' ON '
COCOFF   TEXT     ' OFF'
MM0      TEXT     'ECHOPLEX'
MM1      TEXT     'TAB SIMULATION'
MM2      TEXT     'UPPER CASE RESTRICT'
MM3      TEXT     'PAPER TAPE'
MM4      TEXT     'SPACE INSERTION'
MM5      TEXT     'LOWER CASE SHIFT'
MM6      TEXT     'PARITY CHECK'
MM7      TEXT     'RELATIVE TABBING'
MM8      TEXT     'BACKSPACE EDIT'
         TITLE    'PRINT COMMAND VERB'
* THE PRINT COMMAND CAUSES OUTPUT ACCUMULATED FOR THE LINE PRINTER TO BE
* PLACED ON THE PRINT QUEUE. OUTPUT DESTINED FOR THE LINE PRINTER FROM
* ALL ON-LINE COMPLIATIONS, ASSEMBLIES, PCL OPERATIONS, DELTA DUMPS,
* ETC., ARE ACCUMULATED ON RAD UNTIL THE PRINT COMMAND IS GIVEN.
PRINT    EQU      %
         CI,R1    1                 REMOTE WORK STATION ID ON PRINT
         BG       SYNTAX
         CAL1,9   6
         B        PROMPT
*
*        EXTEND COMMAND
*        EXTEND AVAILABLE CORE FOR NEXT PROCESSOR CALLED
*
EXTEND   EQU      %
         LI,R5    1
         AND,R5   J:JIT+JTELFLGS    AT JOB STEP?
         BEZ      NTJBST            BR IF NOT
         LW,R5    =X'00200000'
         STS,R5   J:JIT+JTELFLGS    SET EXTEND BIT
         B        PROMPT
         TITLE    'DISPLAY COMMAND VERB'
*
*        THE DISPLAY COMMAND OUTPUTS INFORMATION ABOUT THE CURRENT
*        SYSTEMS OPERATIONS.  THE INFO OUTPUT IS THE NO. OF USERS
*        CURRENTLY  ON THE SYSTEMS, AND THE CURRENT VALUES OF INTER-
*        ACTION  AND  COMPUTE RESPONSE  TIME.  THE OUTPUT IS  AS
*        FOLLOWS:
*        !DISPLAY
*        USERS ='XXX
*        ETMF  = XXX
*        RESPONSE 90%  >  XXX SECONDS
*        RADS  =  XXX GRANULES
*
DISPLAY  RES      0
          BAL,SR4   OUTCARR        OUTPUT LINE OF BALNKS
         CAL1,8   DISPFPT           GO GET DISPLAY INFO FROM MONITOR
         LW,D1    R7                NO. OF USERS
         BAL,SR4  BINDECBCD         GO CONVERT NO. IN D1- ANS. IN D2
         LW,R7    D2                PUT CONVERTED NO INTO R7
         LW,D1    R5                ETMF
         BAL,SR4  BINDECBCD         GO CONVERT TO DEC. - ANS. IN D2
         LW,R5    D2                RESET ETMF BOX WITH DEC VALUE
         LW,D1    R6                MEDIAN VALUE OF TERM RESPONSE TIME
         BAL,SR4  BINDECBCD         GO CONVERT TO DEC  FOR OUTPUT
         LW,R6    D2                RESET MEDIAN VALUE TO DEC.
*
         LW,R1    TELSTACK          GET OUTPUT BUFFER
         AI,R1    1                 ADDRESS
         LCI      3
         LM,SR1   USERSQT           GET USERS MESS AND STORE INTO BUFF
         STM,SR1  0,R1              FOR CONSOLE  PRINT OUT.
         STW,R7   2,R1              PUT NO. OF USERS INTO  MESSAGE
         LW,R2    CARRETRN          INSERT CARRIAGE RETURN
         STW,R2   3,R1              STORE INTO BUFFER AREA FOR OUTPUT
         LI,R2    13                NO. OF CHARS TO OUTPUT
         CAL1,1   WRITE             WRITE MESS. ON TYPEWRITER
         LCI      3                 PICKUP ETMF  QUOTE AND PUT INTO BUFF
         LM,SR1   ETMFQT            PUT ETMF VALUE INTO BUFFER
         STM,SR1  0,R1
         STW,R5   2,R1
         LW,R2    CARRETRN          INSERT CARRIAGE RETURN
         STW,R2   3,R1              STORE INTO BUFFER AREA FOR OUTPUT
         LI,R2    13
         CAL1,1   WRITE             OUTPUT ETMF MESS. ONTO TERMINAL
         LCI      7                 PICKUP MEAN TERM TIME
         LM,SR1   MEANQT            AND PUT INTO BUFFER TO BE PRINTED
         STM,SR1  0,R1
         STW,R6   4,R1              PUT MEAN VAL INTO BUFF TO BE PRINTED
         LW,R2    CARRETRN          INSERT CARRIAGE RETURN
         STW,R2   7,R1              STORE INTO BUFFER AREA FOR OUTPUT
         LI,R2    29                SIZE OF MESS TO OUTPUT IN BYTES
         CAL1,1   WRITE             OUTPUT ONTO TERMINAL
         LW,R3    J:JIT+PRDCRM      PERM. DISC SPACE REMAINING
         AW,R3    J:JIT+PRDPRM      PERM . DISC PACK SPACE REMAINING
         BGEZ     RADPLUS
         LI,R4    X'60'             NEG VALUE GET MINUS SIGN
         LCW,D1   R3                AND VALUE
         B        CONVBIN
RADPLUS  RES      0
         LI,R4    X'40'             BLANK FOR PLUS
         LW,D1    R3
CONVBIN  RES      0
         BAL,SR4  BINDECBCD         CONV BIN RAD VALUE TO DEC
         LW,R1    TELSTACK          GET BUFFER ADDRESS
         AI,R1    1
         LCI      7
         LM,R5    RADSQT            PICKUP 'RADS =  XXXXX GRANULES' QT
         STW,D2   R7                PUT IN NO. OF GRANULES AVAILABLE
         LI,R3    2                 PICKUP BYTE OFFSET
         STB,R4   R6,R3             STORE BYTE INTO OUTPUT BUFFER
         AI,R3    1                 SET STORE FOR LEAD BYTE OF RAD SIZE
         STB,D1   R6,R3             STORE LEAD BYTE OF RAD SIZE
         LW,SR4   CARRETRN          PUT IN SIZE BYTE
         LCI      7
         STM,R5   0,R1              PUT IT ALL INTO OUTPUT BUFFER
         LI,R2    25                BUFFER OUTPUT SIZE
         CAL1,1   WRITE             OUTPUT BUFFER ONTO  TTY
          BAL,SR4   OUTCARR        OUTPUT LINE OF BALNKS
         B        PROMPT            GO GET NXT  CMD
*
DISPFPT  RES      0
         DATA     X'13000000'
USERSQT  RES      0
         TEXT     'USERS =   '
ETMFQT   RES      0
         TEXT     'ETMF  =   '
MEANQT   RES      0
         TEXT     'RESPONSE 90%  <      MSECS  '
RADSQT   RES      0
         TEXT     'RADS =         GRANULES'
         TITLE    'STATUS  COMMAND  VERB'
*
*        THE  STATUS VERB IS PROCESSED  BELOW.  THE WORK IS  DONE
*        IN  THE  ROUTINE STATUSL.  NO REGISTERS ARE SET ON
*        ENTRY TO THE ROUTINE STATUSL.  THE LINE IS OUTPUT  TO THE
*        TERMINAL FROM THE  ROUTINE  STATUSL.
*
*
STATUS   RES      0
         LW,D1    L(X'00200000')    CHECK IF M:XX IS OPEN
         CW,D1    M:XX
         BANZ     BKOPT
          BAL,SR4   OUTCARR        OUTPUT LINE OF BALNKS
         BAL,R2   STATUSL           GO COMPUTE AND PRINT OUTPUT LINE
          BAL,SR4   OUTCARR        OUTPUT LINE OF BALNKS
         B        PROMPT
          SPACE     4
*
*         THE FOLLOWING ROUTINE OUTPUTS ONE LINE OF BLANKS
*         SR4 IS  THE LINK REGISTER
*         R1 AND R2 ARE DESTROYED
OUTCARR   RES       0
          LI,R1     CARRETRN       POINT TO CARRIAGE RETURN WORD
          LI,R2     1              THE NO. OF CHARACTERS TO OUTPUT
          CAL1,1    WRITE          OUTPUT TO TERMINAL
          B         *SR4           EXIT
         TITLE    'MESSAGE COMMAND VERB'
MESSAGE0 EQU      %
         BAL,D4   MESSAGE4          CHK FOR LOWER CASE CHARS
         LI,D4    0                 EXCEED FLG
         LB,R4    J:JIT+JPUF        GET REC SIZE
         AI,R4    -2                SET INDX&DROP C/R
         CI,R4    73                CHK FOR MAX SIZE
         BLE      %+2
         LI,R4    73                SET TO MAX
         LW,R5    R4                SAVE THE PUF
         AI,R5    6                 ADD TABS &ASTERISK
         LW,R1    R5
         CI,R1    51
         BLE      %+2
         AI,R1    1
         LB,R6    TELBUF,R4         GET THE BYTE
         STB,R6   TELBUF,R5         MOVE THE BYTE
         AI,R5    -1                DECRE
         BDR,R4   %-3               MOVE EM ALL
         B        MESSAGE1
*
MESSAGE  EQU      %
         BAL,D4   MESSAGE4          CHK FOR LOWER CASE CHARS
         LI,D4    0                 EXCEED FLG
         LB,R1    J:JIT+JPUF        GET REC SIZE
         AI,R1    -2                DROP C/R& SPACE
         CI,R1    51
         BLE      %+2               ADJUST HERE FOR COUNT
         AI,R1    1                 FUDGE BACK
MESSAGE1 CI,R1    51
         BLE      %+2
         LI,D4    1
         LCI      2
         LM,R2    MSGMESS
         STM,R2   TELBUF
         CI,D4    1
         BNE      %+4
         LI,R5    51
         STB,R5   TELBUF            SET SIZE TO 51
         B        %+2
         STB,R1   TELBUF
         LCI      3
         LM,D1    SENDMES
         CAL1,2   D1                SEND THE MESSAGE
         CI,D4    1
         BNE      MESSAGE3
         LCI      2                 INSERT TABS & ASTERISK
         STM,R2   TELBUF+11         FOR 2ND PART OF MSG
         STB,R1   TELBUF+11         INSERT BYTE COUNT
         LI,D3    TELBUF+11         BUFFER ADDR FOR FPT IN REGS
         CAL1,2   D1                SEND 2ND HALF OF MESSAGE
MESSAGE3 B        PROMPT
*
*
         BOUND    8
MSGMESS  DATA     X'0005055C',X'5C5C5C40'
*
MESSAGE4 EQU      %                 CONVERT LOWER CASE CHARS
         LB,R1    J:JIT+JPUF        GET REC SIZE
         LW,R4    R1
         AI,R4    -1
MESSAGE5 LB,R5    TELBUF,R4         GET DATA
         CLM,R5   ATOZ              IS IT LOWER CASE??
         BCS,6    %+2               NO
         AI,R5    X'40'             YES-MAKE IT UPPER
         STB,R5   TELBUF,R4
         AI,R4    -1
         BDR,R1   MESSAGE5
         B        *D4
*
*
         BOUND    8
ATOZ     DATA     X'A9',X'81'       Z......TO....A
*
         TITLE    'BACKUP COMMAND VERB'
BACKUP   EQU      %
         LW,R4    L(X'00200000')    CHECK IF M:XX IS OPEN
         CW,R4    M:XX
         BANZ     BKOPT
         LI,R4    TELBUF+24         GET START ADDRESS
         LW,D2    VERB1             LOAD A BLANK
         LI,R3    17
         STW,D2   *R4,R3            STORE BLANKS INTO BUFFER
         BDR,R3   %-1
         LI,D4    2                 D4=WORD COUNTER FOR VLP. 2=CNTRL WRD
         LW,D2    =X'01000008'      SET UP CONTROL WORD FOR FILE NAME
         STW,D2   *R4
         LW,D2    =X'02000202'      SET UP CONTROL WORD FOR ACCOUNT
         STW,D2   9,R4
         LW,D2    =X'03010202'      SET UP CONTROL WORD FOR PASSWORD
         STW,D2   12,R4
*
         LI,R3    1
         AW,R3    R4                GET DESTINATION FOR FILE NAME
         BAL,SR3  SCAN              SCAN FOR FILE NAME
         CI,R7    31                ARE THERE MORE THAN 31 CHAR IN NAME
         BG       SYNTAX            YES; THEN THERE IS AN ERROR
         CI,R7    0                 ANY DATA PRESENT
         BE       SYNTAX
         LW,R5    R7                PUT NUMBER OF CHARACTERS IN NAME
         AI,R5    -1                INTO POINTER FOR OLD LOCATION
         LW,R6    R7                PUT NUMBER OF BYTES INTO POINTER FOR
STORNAME LB,SR1   *R3,R5            NEW LOCATION. THE ROUTINE WILL MOVE
         STB,SR1  *R3,R6            THE FILE NAME ONE BYTE TO THE RIGHT
         AI,R5    -1                SO THAT A COUNT BYTE  CAN MAKE THE
         BDR,R6   STORNAME          NAME INTO TEXTC FORMAT.
         STB,R7   *R3
         AI,R7    4                 ADD 4 TO FORCE A CARRY IN CASE OF A
         SLS,R7   -2                PARTIAL WRD; GET NUMBER WRDS IN NAME
         AW,D4    R7                ADD  NUMBER OF WORDS  TO COUNT
         LI,R3    2                 PUT SIZE OF FILE NAME IN CONTROL WORD
         STB,R7   *R4,R3
*
         LI,R3    10
         AW,R3    R4                GET DESTINATION ADDRESS FOR ACCOUNT
         BAL,SR3  SCAN              SCAN FOR ACCOUNT
         AI,D4    2                 ADD 2 TO TOTAL WORD COUNT
         CI,R7    0                 WAS THERE AN ACCOUNT SPECIFIED
         BNE      CHKACT            YES; GO CHECK IT
         LW,R7    J:JIT+JACCN       *NO;
         STW,R7   10,R4             * GET ACCOUNT FROM JIT
         LW,R7    J:JIT+JACCN+1     *
         STW,R7   11,R4
         B        PASWRD
CHKACT   CI,R7    8                 ARE MORE THAN 8 CHARACTERS IN ACT.
         BG       SYNTAX            YES;THEN THERE IS AN ERROR.
*
PASWRD   LI,R3    13                LOAD PASWRD DESTINATION ADDRESS
         AW,R3    R4
         BAL,SR3  SCAN              SCAN FOR PASSWORD
         CI,R7    8                 ARE MORE THAN 8 CHARS. IN THE PASS.
         BG       SYNTAX            YES; THEN THERE IS AN ERROR
         CI,R7    0                 WAS THERE A PASSWORD
         BE       %+3               NO;
         AI,D4    3                 YES; ADD CONTRL WRD & PASSWORD
         B        PAGEGET           GO AND GET A PAGE
         LI,R7    X'01'
         LI,R2    1
         LW,R3    R4
         AI,R3    9
         STB,R7   *R3,R2            SET ACT. CONTRL WRD TO LAST PARAMETR
*
PAGEGET  EQU      %
         SLS,D4   2
         CAL1,8   GETPG             GET A PAGE
         BCS,8    NOPAGE11          EXIT IF NO PAGE AVAIL.
         LI,R3    TELBUF+20         CREATE FPT TO DET. FILE EXIST.
         LCI      4
         LM,R5    TESTFILE
         STM,R5   *R3
         CAL1,1   *R3
PAGEGETA LI,R5    2                 SET TOTAL VLP WORDS=
         LB,R6    *R4,R5            SIGNIFICANT NO. FOR BACKUP RECD.
         AI,R5    1
         STB,R6   *R4,R5
         LW,R7    SYSACT
         LW,D1    SYSACT+1
         XW,R7    J:JIT+JACCN       EXCHANGE THE USER'S ACCOUNT
         XW,D1    J:JIT+JACCN+1     *
OPEN1    LI,R1    4                 OPEN IN THE 'INOUT' MODE
         CAL1,1   OPENBKUP
         STW,R7   J:JIT+JACCN       RESTORE USER'S ACCOUNT TO JIT
         STW,D1   J:JIT+JACCN+1     *
         LW,R3    R4
         AI,R3    -2                GET ADDRESS FOR KEY
         LW,D1    =X'06C2C1C3'
         STW,D1   *R3               * PUT IN THE KEY
         LW,D1    =X'D2E4D740'
         STW,D1   1,R3
         CAL1,1   READBKUP          READ IN BACKUP RECORD
         AW,D4    M:XX+13           GET RECORD SIZE IN BYTES
         CI,D4    2048              DOES THE SIZE EXCEED A PAGE
         BGE      SIZER
         LW,R5    M:XX+13           LOAD RECORD DISPLACEMENT
*
STLOOP   SLS,R5   -2                SHIFT TO A WORD BOUNDRY
         LI,R6    0
         LI,R3    3
         LB,R2    *R4,R3            LOAD NAME SIZE
         AI,R2    1                 ADD IN CONTROL WORD
STORNAM  LW,D2    *R4,R6
         STW,D2   *SR2,R5           STORE NAME INTO RECORD
         AI,R6    1
         AI,R5    1
         BDR,R2   STORNAM
         LCI      3
         LM,SR3   9,R4              LOAD ACCOUNT FIELD
         LCI      3
         STM,SR3  *SR2,R5           STORE ACCOUNT FIELD
         LI,D2    X'01'
         LI,R1    1
         LW,R3    R4
         AI,R3    9
         CB,D2    *R3,R1            IS ACCOUNT THE LAST VLP FIELD
         BE       KEYPUT            GO PUT IN THE KEY
         AI,R5    3
         LCI      3
         LM,SR3   12,R4
         LCI      3
         STM,SR3  *SR2,R5           STORE PASSWORD IN RECORD
*
KEYPUT   EQU      %
         LW,R3    R4
         AI,R3    -2                GET ADDRESS FOR KEY
         LW,D1    =X'06C2C1C3'
         STW,D1   *R3               STORE FIRST WORD OF KEY
         LW,D1    =X'D2E4D740'
         STW,D1   1,R3              STORE 2ND WORD OF THE KEY
WRITOUT  CAL1,1   WRITERC           WRITE OUT THE RECORD TO BACKUP FILE
         CAL1,8   PGDROP            DROP A PAGE
         CAL1,1   CLOSEBK           CLOSE THE BACKUP FILE
         CAL1,6   BKUPCAL           SEND A CAL FOR THE BACKUP PROCESS
         B        PROMPT
*
NOPAGE11 RES                        BACKUP
         LI,1     NOPAGETX
         LI,2     14
         CAL1,1   WRITE
         B        CLEANSTACK
NOFILE   LB,SR3   SR3
         CI,SR3   3                 DOES FILE EXIST
         BNE      PAGEGETA          YES
         CAL1,8   PGDROP            NO, NOTIFY USER FILE DOESNT EXIST
         LI,R1    HAVANO
         LI,R2    19
         CAL1,1   WRITE
         B        CLEANSTACK
ABRTN    EQU      %
         LB,SR3   SR3
         CI,SR3   3                 DOES THE BACKUP FILE EXIST
         BNE      OPEN1             YES; GO TRY & TO OPEN FILE AGAIN
         LI,R1    2                 NO; OPEN THE FILE IN 'OUT' MODE
         CAL1,1   OPENBKUP
         STW,R7   J:JIT+JACCN       RESTORE USER'S ACCOUNT TO JIT
         STW,D1   J:JIT+JACCN+1     *
RDERT    LI,R5    0                 SET RECORD INDEX POINTER
         B        STLOOP
SIZER    EQU      %
         LW,D1    BACKFUL
         BAL,0    WRITERR
         B        WRITOUT+1
         TITLE    'JOB COMMAND VERB'
JOB      EQU      %
         CI,R1    1
         BLE      SYNTAX
         LI,D1    0                 CLEAR DATA RECIEVING AREA
         LI,R3    D1                LOAD ADDRESS WHERE DATA WILL BE PUT
         BAL,SR3  SCAN              AFTER THE SCAN; GO TO SCAN ROUTINE.
         CI,R7    4                 DOES THE FIELD CONTAIN MORE THAN
         BG       SYNTAX            FOUR CHARACTERS; YES=ERROR
         PUSH     2,R1
         CI,R7    0                 DOES THE FIELD CONTAIN ANY CHARS.
         BE       MULJOB            NO, GET NEXT FIELD
         BAL,R1   HEX2BIN           GO CONVERT FIELD TO BINARY
         CI,SR1   0                 WAS AN ILLEGAL CHARACTER PRESENT
         BGE      JOB2
         PULL     2,R1              YES; THERE WAS AN ERROR. RESTORE BUFFER
         B        SYNTAX            POINTER.
JOB2     CAL1,1   JOBCAL            ISSUE THE JOB CAL.
         CI,SR1   0                 IS THE JOB COMPLETED
         BE       JCMPLT            YES; GO TO THE JOB COMPLETED ROUTINE
         CI,SR1   1                 IS THE JOB RUNNING
         BE       JRUNNG            YES; GO TO THE JOB RUNNING ROUTINE
         CI,SR1   2                 IS THE JOB WAITING TO COMPUTE
         BE       JWAIT2RN          YES; GO TO THE WAITING TO RUN ROUTNE
         CI,SR1   3
         BE       JDNTEXT
         CI,SR1   4                 IS JOB WAITNG FOR SYMBIONT OUTPUT
         BE       JWAIT2OT          YES; GO TO WAITING FOR OUTPUT ROUTNE
GIVEMEH  EQU      %
         LI,R1    EHMSG             THE JOB NEVER EXISTED OR JID. IS
         LI,R2    4                 INDECIPHERABLE SEND OUT
         CAL1,1   WRITE             THE 'EH' MESSAGE.
         B        PROMPT            GO BACK & GIVE ANOTHER PROMPT
JCMPLT   EQU      %
         LI,R1    CMPLTX            LOAD ADDRESS OF TEXT
         LI,R2    9                 LOAD NUMBER OF BYTES IN TEXT
         CAL1,1   WRITE             WRITE OUT THE MESSAGE
         B        MULJOB            CHECK FOR MORE ID'S
CMPLTX   TEXT     'COMPLETED'
JRUNNG   EQU      %
         LI,R1    JRUNTX            LOAD ADDRESS OF TEXT
         LI,R2    7                 LOAD NUMBER OF BYTES IN THE TEXT
         CAL1,1   WRITE             WRITE OUT THE MESSAGE
         B        MULJOB            CHECK FOR MORE ID'S
JRUNTX   TEXT     'RUNNING'
JDNTEXT  EQU      %
         LI,R1    NOEXIST
         LI,R2    13
         CAL1,1   WRITE
         B        MULJOB            CHECK FOR MORE ID'S
NOEXIST  TEXT     'DOESN''T EXIST'
JWAIT2RN EQU      %
         LW,D1    SR3               PUT # OF USERS IN RUN QUEUE INTO D1
         BAL,SR4  BINDECBCD         GO CONVERT NUMBER IN D1
         LW,R1    TELSTACK          GET BUFFER ADDRESS
         AI,R1    1                 GET NEXT WORD
         BUMP     6,R2              SAVE SIX REGISTERS
         LCI      6                 GET THE MESSAGE TEXT AND PUT
         LM,R2    WT2RTX            IT INTO RESISTERS
         STM,R2   0,R1              STORE THE MESSAGE IN THE BUFFER
         STW,D2   3,R1              STORE CONVERTED HEX NUMBER INTO TEXT
         LI,R2    24                LOAD NUMBER OF BYTES IN THE TEXT
         CAL1,1   WRITE             WRITE THE MESSAGE
         BUMP     -6,R2             RESTORE THE REGISTERS
         B        MULJOB            CHECK FOR MORE ID'S
WT2RTX   TEXT     '   WAITING:       TO RUN'
JWAIT2OT EQU      %
         LI,R1    WT2OPTX           LOAD ADDRESS OF TEXT
         LI,R2    17                LOAD NUMBER OF BYTES IN TEXT
         CAL1,1   WRITE             WRITE THE MESSAGE
         B        MULJOB            CHECK FOR MORE ID'S
WT2OPTX  TEXT     'WAITING TO OUTPUT'
MULJOB   EQU      %
         LI,R1    RETN
         LI,R2    1
         CAL1,1   WRITE
         PULL     2,R1
         CI,R1    1
         BLE      PROMPT
         B        JOB+2
         TITLE    'BATCH COMMAND VERB'
BATCH1   CI,R1    0                 MORE MESSAGE?
         BNE      BATCH2
         LI,R1    BATCHW            PUT OUT
         LI,R2    10                ERROR
         CAL1,1   WRITE             MESSAGE
         B        PROMPT            RETURN
BATCH2   EQU      %
         LI,R6    1
         STB,R2   J:JIT+JPUF,R6     SAVE ARGUMENT INDEX
         LD,R6    BATCH             LMN FOR LOAD
         LI,D1    0                 NO FURTHER SCAN
         B        GROUP2            GO TO LOAD
         TITLE    'TABLES, CONSTANTS, AND SUCH'
BIT0     GEN,1,31 1,0
CARRETRN DATA     X'0D000000'
NBIT0    DATA     X'7FFFFFFF'
EHMSG    DATA,4   X'C5C86F40',X'7C400000'
JUSTEH   DATA     X'15C5C86F'
FLAGS    DATA     X'0020000B'
RETN     DATA     X'155A0000'
NBIT30   DATA     -X'3'
XA       DATA     X'A'
ZEROS   DATA      X'F0F0F0F0'
         BOUND    8
F0F9     DATA     X'F0',X'F9'
C1C6     DATA     X'C1',X'C6'
PCL      EQU      COPY
EDITA    TEXT     'EDIT '
COPY     TEXTC    'PCL'
         TEXT     '    '
FDP      TEXTC    'FDP'
         TEXT     '    '
FDP1     TEXT     'FDP     '
UNDER    TEXT     'UNDER'
DELTA1   TEXT     'DELTA'
DELTA    TEXTC     'DELTA'
EDIT     TEXTC    'EDIT'
BATCH    TEXTC    'BATCH'
LINK     TEXTC    'LINK'
METASYM  TEXTC    'METASYM'
FORTRAN  TEXTC    'FORT'
LOGOFF   TEXTC    'LOGON'
BASIC    TEXTC    'BASIC'
COBOL    TEXTC    'COBOL'
XSHOW    TEXTC    'SHOW'
* END OF DOUBLE WORD TABLE
SYS      TEXT     ':SYS'
DOLL     TEXT     '%   '
ME       TEXT     'ME  '
ON       TEXT     'ON  '
LP       TEXT     'LP  '
NO       TEXT     'NO  '
OVER     TEXT     'OVER'
         BOUND    8
TM:SI    TEXTC    'M:SI'
TM:GO    TEXTC    'M:GO'
TM:LO    TEXTC    'M:LO'
TM:DO    TEXTC    'M:DO'
NEVER    TEXT     'NEVER   '
SHARE    TEXT     'SHARE   '
EXCL     TEXT     'EXCL    '
BCZRO2   TEXT     '  00'
BCZRO1   TEXT     '   0'
EMONTH   TEXT     '  31'
EDAY     TEXT     '  12'
* END OF DOUBLEWORD TABLE
FULAM    TEXT     'ASSIGN LIMIT EXCEEDED'
NOAM     TEXT     'UNABLE TO READ A/M TABLE'
PARMSG   TEXT     'INPUT ERROR-RETRY'
ONFERR   TEXT     'ON FILE '
FILME    TEXT     'FILE: ME'
LEGER    TEXT     ' ILLEGAL'
LEGER1   TEXT     ' NOT FOUND'
WHO      TEXT     'START WHAT?'
FORMAT   TEXT     'IMPROPER FORMAT FOR SET CMD'
CWHAT    TEXT     'CONTINUE WHAT?'
LEGCMD   TEXT     'COMMAND LEGAL AT JOB STEP ONLY'
BADPLT   TEXT     'BAD PLIST-RESPECIFY DCB'
DELWHT   TEXT     'WHAT FID?'
BADACC   TEXT     'CANNOT ACCESS THE FILE'
HAVANO   TEXT     'FILE DOES NOT EXIST'
PACOMP   TEXT     'PASSWORD CHANGE SUCCESSFUL'
BADOPT   TEXT     ' OPTION ILLEGAL FOR '
QMARK    TEXT     ' ??     '
FFILE    TEXT     'FILES   '
LLABLE   TEXT     'LABEL TP'
AANS     TEXT     'ANS TP  '
BADFOPT1 TEXT     ' OPTION ILLEGAL FOR FILES, LABEL OR ANS TAPE'
BADDOPT  TEXT     ' OPTION ILLEGAL FOR DEVICES'
BKMSG    TEXT     'QUIT?'
EXLYMSG  TEXT     'CANNOT SAVE EXECUTE ONLY FILE-QUIT OR GO'
PSML     TEXT     'INSUFFICIENT ASSIGN/MERGE ENTRY SIZE'
EXPERM   TEXT     'DCB FULL-CANNOT EXPAND TO UPDATE'
WHATDCB  TEXT     'DCB NOT ASSIGNED'
TRMERMSG TEXT      'TERMINAL TYPE NOT VALID'
GETW     TEXTC    'GET WHAT?'
SAVW     TEXT     'SAVE WHAT?'
DELETED  TEXT     '..DELETED'
BATCHW   TEXT     'BATCH WHAT'
LATERM   TEXTC    'CONFLICT WITH DELTA-TRY LATER '
560MSG   TEXT     'LAST BRANCH TAKEN FROM '
BADFILE  TEXTC    'IMPROPER FILE'
NGVP     TEXTC    'NOT ABLE TO OBTAIN PAGE'
NOCMP    TEXTC    'NOT ABLE TO GET COMMON PAGE'
CVMMES   TEXTC    'CAN''T GET M:CVM PAGE'
BADDCBP  TEXTC    '-BAD DCBS'
BADJIT    TEXTC   '-BAD JIT'
BADLIT   TEXTC    '-BAD LIMITS'
BADSYS   TEXTC    '-CANNOT SAVE ACROSS SYST VERSIONS'
WIDTH    TEXT     '  WIDTH=    '
LLINES   TEXT     '  LINES=    '
NOPAGETX TEXTC    'CORE EXCEEDED'
NONE     TEXT     'NONE'
INEXC    TEXT     'EXPANDED INPUT EXCEEDS 80 CHARACTERS'
INEXC1   TEXT     'TEL ERROR-RETRY'
RERR     TEXT     'ILLEGAL OR INCONSISTENT RTYPE ENTRY'
*
PATCH    RES      50
* THIS IS THE GENERAL PLIST FOR WRITING THROUGH THE M:UC DCB. THE BUFFER
* ADDRESS MUST BE IN R1 AND THE BUFFER SIZE MUST BE IN R2.
*
WRITE    GEN,8,24 X'11',M:UC
         GEN,4,28 3,0
         GEN,1,31 1,R1
         GEN,1,31 1,R2
*
* PLIST FOR READING USER COMMANDS INTO TELBUF IN USER'S CONTEXT
*
READ     GEN,8,24 X'10',M:UC
         GEN,7,25 X'78',0
         GEN,1,31 0,ABNRET
         GEN,1,31 0,ABNRET
         DATA     TELBUF
         GEN,1,31 0,80
*
         PAGE
*        CLOSE    DCB
SETACL   CAL1,1   SETDCBL
         CAL1,1   SHUTDCB
SETX     B        0,R4
SAVERR   CAL1,1   KLOSE
         LW,D1    SR3
         SLS,D1  -15
         BAL,0    WRITERR1
         B        LATERX1A
KLOSE    GEN,8,24 X'15',M:XX
         DATA     0
* PLIST TO CLOSE A DCB.
*
SHUTDCB  GEN,8,24  X'15',M:XX
         GEN,1,31    1,0
         GEN,24,8    0,2            SAVE SPECIFIED
SETDCBL  RES      0
         GEN,8,24  6,M:XX
         GEN,2,30  3,0
         DATA     SETX
         DATA     SETX
*
*
* PLIST FOR A 'ME' SPECIFICATION(OP LABEL=UC)
*
OPENME   GEN,8,24 X'14',0
         GEN,16,4,12  0,X'A',0
         GEN,16,16 4,0
         GEN,32   C'UC'
*
* PLIST TO READ AND WRITE THE LOGIN RECORD
*
RWLOG    GEN,8,24 0,M:XX
         DATA     X'B8000010'
         GEN,32   OPERR
         GEN,1,31 1,R4              BUFFER ADDRESS
         GEN,32   LOGSIZE+LOGSIZE+LOGSIZE+LOGSIZE
         GEN,1,31 1,R3              KEY ADDRESS
*
* PLIST USED TO READ IN ASSIGN/MERGE TABLE.
*
         DO1      A=1
AMR      GEN,1,7,24 1,X'2D',R4
         DO1      A=2
AMR      GEN,1,7,24 1,X'10',R4      TEMP
         GEN,4,28 X'3',X'10'
         GEN,1,31 1,R7
         GEN,32   4*512
*
* PLIST USED TO WRITE THE UPDATE ASSIGN/MERGE TABLE.
*
         DO1      A=1
WAMR     GEN,1,7,24 1,X'2E',R4
         DO1      A=2
WAMR     GEN,1,7,24 1,X'11',R4      TEMP
         GEN,4,28 3,0
         GEN,1,31 1,R7
         GEN,32   4*512
*
* PLIST USED TO OPEN THE LOGIN FILE FOR A CHANGE IN PASSWORD
*
OPLOG    GEN,8,24 X'14',M:XX
         DATA     X'CB480219'
         GEN,32   OPERR
         GEN,32   OPERR
         GEN,32   10
         GEN,32   2
         GEN,32   4                 INOUT MODE
         GEN,32   2
         GEN,32   16
         GEN,8,8,8,8 1,0,2,2
          TEXTC     ':USERS'
         LIST     1
         GEN,8,8,8,8 2,0,2,2
SECAC    TEXT     ':SYS'
         TEXT     '    '
         GEN,8,8,8,8 3,0,2,2
         DATA     X'DFEF803F'
         DATA     X'AFC0BF9F'
         LIST     1
         GEN,8,8,8,8 5,1,1,1
         TEXT     'NONE'
*
*
* DEVICE PLIST FOR TABS COMMAND VERB.
*
TABPL    GEN,8,24 X'28',M:UC
         GEN,1,31 1,0
         GEN,64   0
         GEN,64   0
         GEN,32   0
*
* BASIC PLIST SKELETON FOR FPT CREATED IN ASSIGN/MERGE TABLE. (FILE)
*
PLIST    GEN,8,24 X'14',0           THE 1ST FIVE WORDS ARE FIXED AND
         GEN,16,4,12  0,X'E',1      CANNOT BE ALTERED BY SEQUENCE
         GEN,12,20  X'14',0
MODE     GEN,32   2                 NORMAL OUTPUT MODE
SAVE     GEN,32   2                 NORMAL SAVE
NAME     GEN,8,8,8,8  1,0,3,3       NAME VARIABLE PARAM
         GEN,64   0
         GEN,32   0
PACC     GEN,8,8,8,8  2,0,2,2       ACCOUNT VARIABLE PARAM
         GEN,64   0
PPAS     GEN,8,8,8,8  3,1,0,2       PASSWORD PARAM DEFAULTS TO NULL
         GEN,64   0
PSIZE    EQU      %-PLIST
*
* PLIST  FOR OPENING THE BACKUP RECORD
*
OPENBKUP GEN,8,7,17  X'14',0,M:XX
         DATA     X'F7480019'
         DATA     RDERT
         DATA     ABRTN             ABNORMAL RETURN
         PZE      *SR2
         DATA     2048              MAXIMUM RECORD SIZE
         DATA     2                 KEYED FILE
         DATA     2                 DIRRECT ACCESS
         GEN,1,14,17 1,0,R1         MODE
         DATA     2                 SAVE
         DATA     7                 MAXIMUM KEY LENGHT
         DATA,1   1,0,3,3
         TEXTC    'F:BACKUP'
         DATA,1   2,0,2,2
SYSACT   TEXT     ':SYS    '        ACCOUNT
         DATA,1   5,1,1,1
         TEXT     'NONE'
*
* PLIST  TO GET A PAGE FOR THE PURPOSE OF READING IN THE BACKUP RECORD
GETPG    GEN,8,7,17  X'08',0,1
*
* PLIST  TO RELEASE A PAGE AFTER  WRITING OUT THE  BACKUP RECORD
PGDROP   GEN,8,7,17  X'09',0,1
*
* PLIST FOR READING THE BACKUP RECORD
*
READBKUP GEN,8,7,17  X'10',0,M:XX
         DATA     X'B8000010'
         DATA     RDERT             READ ERROR RETURN
         GEN,1,14,17 1,0,SR2        BUFFER ADDRESS
         DATA     2048              BUFFER SIZE
         PZE      *R3               KEY ADDRESS
*
* PLIST FOR WRITING OUT THE BACKUP RECORD
*
WRITERC  GEN,8,7,17  X'11',0,M:XX
         DATA     X'38000050'
         GEN,1,14,17 1,0,SR2        BUFFER ADDRESS
         PZE      *D4               SIZE OF RECORD
         PZE      *R3               KEY ADDRESS
*
* PLIST FOR CLOSING THE BACKUP RECORD
*
CLOSEBK  GEN,8,7,17  X'15',0,M:XX
         DATA     X'80000000'
         DATA     2                 SAVE
*
* PLIST TO NOTIFY THE SYSTEM THAT THERE IS A FILE WHICH MUST BE BACKEDUP
*
BKUPCAL  GEN,8,24 6,0
         TEXTC    'FILL'
*
* PLIST USED TO DETERMINE FILE EXISTENCE
*
TESTFILE GEN,8,7,17 X'14',4,M:XX
         GEN,32   X'C0000209'
         DATA     NOFILE            ERROR
         DATA     NOFILE            ABNORMAL
*
*
* PLIST FOR THE MESSAGE COMMAND
*
SENDMES  GEN,8,24 X'0',0
         GEN,1,31 1,0
         DATA     TELBUF            ADDRESS OF BUFFER
*
* PLIST FOR THE JOB COMMAND
*
JOBCAL   GEN,8,24 X'2F',M:XX
         DATA     0
*
*   PLIST TO GET AND RELEASE SPECIAL BUFFER
*   PAGES IN CONTEXT AREA.
*
GPFPT    GEN,1,7,24  1,4,SR2        GET PAGE
FPFPT    GEN,1,7,24  1,5,SR2        RELEASE PAGE
CVMFPT   GEN,1,7,24   1,7,5         M:CVM
         GEN,1,7,24   1,0,4
         TITLE    'VECTORS, TABLES AND WHATEVER'
*
* THE FOLLOWING TABLE IS USED TO DETERMINE THE SHIFT REQUIRED (USING BIT
* 31) TO SET OR RESET THE FILE EXTENSION BITS IN JCPPO. IT IS A HALF-
* WORD TABLE AND IS USED BY LOOKING FOR A MATCH ON THE LAST TWO CHARS OF
* THE M: DCB NAME. THE RELATIVE POSITION DENOTES THE DISTANCE BIT 31
* MUST BE SHIFTED LEFT.
*
FILEXTP  DATA,2   C'GO',C'OC'
         DATA,2   C'LO',C'LL'
         DATA,2   C'DO',C'PO'
         DATA,2   C'BO',C'LI'
         DATA,2   C'SI',C'BI'
         DATA,2   C'SL',C'SO'
         DATA,2   C'CI',C'CO'
         DATA,2   C'AL',C'EI'
         DATA,2   C'EO',C'  '
SIZFILXP EQU      HA(%)-HA(FILEXTP)
*
         BOUND    4
XH:RN1   DATA,2   '  ','MT'
         DATA,2   'LT','FT'
         DATA,2   '9T','AT'
XV:RS1   EQU      HA(%)-HA(XH:RN1)-1
         BOUND    4
XH:RN2   DATA,2   '  ','7T'
         DATA,2   'DP'
XV:RS2   EQU      HA(%)-HA(XH:RN2)-1
         BOUND    4
*
* TABLES TO IDENTIFY RECOGNIZABLE OPTIONS FOR PROCESSORS
*
RECOPT   DATA,2   'LO','BO'
         DATA,2   'CO','CI'
         DATA,2   'SI','LS'
         DATA,2   'SO','GO'
         DATA,2   'DO'
SIZRECO  EQU      HA(%)-HA(RECOPT)-1
         BOUND    4
*
* TABLE OF RECOGNIZED KEYWORDS FOR SET COMMAND DEVICE OPTIONS.
*
KEYS     TEXT     '    '
         TEXT     'L   '
         TEXT     'NOL '
         TEXT     'TAB '
         TEXT     'LINE'
         TEXT     'SPAC'
         TEXT     'DRC '
         TEXT     'NODR'
         TEXT     'VFC '
         TEXT     'NOVF'
         TEXT     'COUN'
         TEXT     'BCD '
         TEXT     'BIN '
         TEXT     'FBCD'
         TEXT     'NOFB'
         TEXT     'PACK'
         TEXT     'UNPA'
         TEXT     'DATA'
         TEXT     'SEQ '
         TEXT     'IN  '
         TEXT     'OUT '
         TEXT     'INOU'
         TEXT     'OUTI'
         TEXT     'RECL'
         TEXT     'TRIE'
         TEXT     'DEN '
         TEXT     'ASCI'
         TEXT     'ASC '
         TEXT     'EBCD'
         TEXT     'EBC '
         TEXT     'SN  '
SIZKEYS  EQU      %-KEYS-1
*
* VECTOR TABLE USED TO ENTER CORRECT KEYWORD PROCESS FOR SET COMMAND.
* PARALLEL TO TABLE 'KEYS'.
*
KEYVECT  B        JUNK
         LI,D2    X'10001'          L
         B        NOL
         B        TAB
         B        LINES
         B        SPACE
         LW,D2    L(X'400040')      DRC
         B        NODRC
         LI,D2    X'20002'          VFC
         B        NOVFC
         B        COUNT
         B        BCD
         LW,D2    L(X'200020')      BIN
         LI,D2    X'40004'          FBCD
         B        NOFBCD
         LW,D2    L(X'100010')      PACK
         B        UNPACK
         B        DATA
         B        SEQ
         B        IN
         B        OUT
         B        INOUT
         B        OUTIN
         B        RECL
         B        TRIES
         B        DENSITY
         B        ASCII
         B        ASCII
         B        EBCDIC
         B        EBCDIC
         B        SNOPT
         PAGE
* TABLE OF RECOGNIZED KEYWORDS FOR SET COMMAND FILES,
* LABELED TAPE, AND ANS TAPE. (SEE COMMENTS AT 'FTABLE'  )
*     F=FILE    L=LABEL TP     A=ANS TP
*
FKEY     TEXT     '    '
         TEXT     'CONS'            F/L
         TEXT     'KEYE'            F/L
         TEXT     'RAND'            F
         TEXT     'SEQU'            F/L
         TEXT     'DIRE'            F/L
         TEXT     'IN  '            F/L/A
         TEXT     'OUT '            F/L/A
         TEXT     'INOU'            F/L/A
         TEXT     'OUTI'            F/L/A
         TEXT     'REL '            F
         TEXT     'SAVE'            F
         TEXT     'CYLI'            F
         TEXT     'EXPI'            F/A  (EXPIRE)
         TEXT     'EXP '            F/A  (EXPIRE)
         TEXT     'KEYM'            F/L
         TEXT     'NEWX'            F
         TEXT     'NOSE'            F
         TEXT     'READ'            F/L
         TEXT     'RD  '            F/L
         TEXT     'RECL'            F/L
         TEXT     'RSTO'            F
         TEXT     'SPAR'            F
         TEXT     'TRIE'            F/L/A
         TEXT     'WRIT'            F/L
         TEXT     'WR  '            F/L
         TEXT     'VOL '            L/A
         TEXT     'ABCE'            A
         TEXT     'BLKL'            A
         TEXT     'BLK '            A
         TEXT     'CONC'            A
         TEXT     'CAT '            A
         TEXT     'FORM'            A
         TEXT     'FMT '            A
         TEXT     'LREC'            A
         TEXT     'REC '            A
         TEXT     'DEN '            L/A
         TEXT     'ASCI'            L/A
         TEXT     'ASC '            L/A
         TEXT     'EBCD'            L/A
         TEXT     'EBC '            L/A
         TEXT     'EX  '            F
         TEXT     'EXEC'            F
         TEXT     'UN  '            F
         TEXT     'UNDE'            F
         TEXT     'SN  '            F/L/A
SIZFKY   EQU      %-FKEY-1
         PAGE
* FTABLE IS PARALLEL TO TABLES FKEY AND FOPK.
* ANY CHANGE TO ANY ONE REQUIRES CORRESPONDING CHANGES
* TO THE OTHER TABLES.  THE TABLES ARE ORDER DEPENDANT
* AND REFLECT EACH OTHER.
* FTABLE HAS BYTE ENTRIES, EACH BYTE HAS BITS REPRESENTING
* WHICH ASN IT MAY BE A VALID OPTION FOR.
*  BIT 7=1 FILE OP.... BIT 6=1 LABEL TPE OP.... BIT5=1 ANS TPE OP.
* BIT 5,6,7=1 THE OPTION IS APPL TO ALL THREE TYPES, E.G.  'IN'  .
*
         BOUND    4
FTABLE   DATA,1   0,3,3,1           NUL,CONS,KEYED,RAND
         DATA,1   3,3,7,7           SEQUN,DIR,IN,OUT
         DATA,1   7,7,1,1           INOUT,OUTIN,REL,SAVE
         DATA,1   1,5,5,3,1         CYL,EXPI,EXP,KEYM,NEWX
         DATA,1   1,3,3,3,1         NOSEP,READ,RD,RECL,RSTORE
         DATA,1   1,7,3,3,6         SPAR,TRIES,WRITE,WR,VOL
         DATA,1   4,4,4,4,4,4,4     ABC,BLKL,BLK,CONCAT,CAT,FORM,FMT
         DATA,1   4,4,6,6,6,6,6     LRECL,REC,DEN,ASCI,ASC,EBCD,EBC
         DATA,1   1,1,1,1           EX,EXEC,UN,UNDE
         DATA,1   7,0,0,0           SNOPT,0,0,0
         PAGE
* VECTOR FOR TABLE FKEY
*
FOPK     B        FOPT1             SECURITY IS A CLOSED ERROR PATH
         B        CONSEC            F/L
         B        KEYED             F/L
         B        RANDOM            F
         B        SEQUEN            F/L
         B        DIRECT            F/L
         B        IN                F/L/A
         B        OUT               F/L/A
         B        INOUT             F/L/A
         B        OUTIN             F/L/A
         B        REL               F
         B        SAVEOPT           F
         B        CYLINDER          F
         B        EXPIRE            F/A
         B        EXPIRE            F/A
         B        KEYM              F/L
         B        NEWX              F
         B        NOSEP             F
         B        READOPT           F/L
         B        READOPT           F/L
         B        RECL              F/L
         B        RSTORE            F
         B        SPARE             F
         B        TRIES             F/L/A
         B        WRITEOPT          F/L
         B        WRITEOPT          F/L
         B        VOL               L/A
         B        ABCERR            A
         B        BLKL              A
         B        BLKL              A
         B        CONCATOP          A
         B        CONCATOP          A
         B        FORM              A
         B        FORM              A
         B        LRECL             A
         B        LRECL             A
         B        DENSITY           L/A
         B        ASCII             L/A
         B        ASCII             L/A
         B        EBCDIC            L/A
         B        EBCDIC            L/A
         B        EXECUTE           F
         B        EXECUTE           F
         B        UNDEROP           F
         B        UNDEROP           F
         B        SNOPT             F/L/A
*
         TITLE    'PARAMETER PLACES'
*
* TABLE OF DISPLACEMENT POSITIONS FOR EXPANSION OF BASIC PLIST. KEYED TO
* PRESENCE WORD OF PLIST.
*
PLACES   DATA,1   0,0,0,0
         DATA,1   P4,P5,P6,P7
         DATA,1   P8,0,P10,0
         DATA,1   0,P13,P14,0
         DATA,1   P16,P17,P18,0
         DATA,1   P20,P21,P22,0,0,0,0,0,0,0,0,0
         TITLE    'DEVICE PARAM PLACEMENTS'
         BOUND    4
*
* TABLE OF DISPLACEMENTS FOR EXPANSION OF DEVICE PLIST. KEYED TO DEVICE
* PRESENCE WORD OF PLIST.
*
THINGS   DATA,1     0,DTABS,DSEQID,DDATA
         DATA,1   DCOUNT,0,DLINES,DSPACE
         DATA,1   DDRC,0,0,0,0,0,0,0,0,0,0,0,0
         DATA,1   0,0,0,0,0,0,0,0,0,0,0,0
         BOUND    4
*
*   TABLE OF CONVERSIONS FOR TERMINAL COMMAND
*
TERMTAB1 TEXT      '33  '
         TEXT      '35  '
         TEXT      '37  '
         TEXT     '7015'
         TEXT     'STAT'
         TEXT     'ESTD'
         TEXT     'EAPL'
         TEXT     'SSTD'
         TEXT     'SAPL'
         TEXT     'MEMO'            MEMOREX
         TEXT     'EXEC'            EXECUPORT
         TEXT     'DATA'            DATAPOINT
         TEXT     'TI  '            TEXAS INSTRUMENTS SERIES 700
SIZETAB1 EQU      %-TERMTAB1-1
*
*
*SIZE OF TERMTAB1,2,3 ARE ALL THE SAME-PARALLEL TABLES.**
*
TERMTAB2 DATA,1   0,1,2,3           COC TRANSLATION TABLE TABLE
         DATA,1   0,4,6,8           DUMMY,4,6,8
         DATA,1   10,2,0,0
         DATA,1   2                 TI
         BOUND    4
SIZETAB2 EQU      BA(%)-BA(TERMTAB2)-1
*
*
*  IDLE ALGORITHM NUMBER TABLE
TERMTAB3 DATA,1   5,5,5,5           M33, M35, M37, 7015
         DATA,1   0,1,1,1           DUMMY, ESTD, EAPL, SSTD
         DATA,1   1,3,2,0           SAPL, MEMO, EXEC, DATAPOINT
         DATA,1   5                 TI
         BOUND    4
SIZETAB3 EQU      BA(%)-BA(TERMTAB3)-1
         TITLE    'PARAMETER DISPLACEMENTS'
*
*
*
* THE FOLLOWING ARE DISPLACEMENTS USED IN CREATING THE SKELETAL OPEN
* PRIME PLIST. A CHANGE HERE REQUIRES A SIMILAR CHANGE TO THE 'PLACES'
* OR 'THINGS' TABLES.
*
PP       EQU      3                 TO MOVE THIS WHOLE     *
P4       EQU      PP                TABLE UP OR DOWN ONLY  *
P5       EQU      P4+1              THE ENTRIES ON EITHER  *
P6       EQU      P5+1              SIDE OF THE INSERTION  *
P7       EQU      P6+1              OR DELETION NEED BE    *
P8       EQU      P7+1              MODIFIED. THE WHOLE    *
P10      EQU      P8+1              TABLE FROM PP TO DDRC  *
P13      EQU      P10+1             WILL ADJUST ITSELF.    *
P14      EQU      P13+1                                    *
P16      EQU      P14+1                                    *
P17      EQU      P16+1                                    *
P18      EQU      P17+1                                    *
P20      EQU      P18+1                                    *
P21      EQU      P20+1                                    *
P22      EQU      P21+1                                    *
VP       EQU      P22+1                                    *
PFNAM    EQU      VP                TO ALTER THE SIZE OF   *
PFACC    EQU      PFNAM+4           ANY VLP ONLY THE ENTRY *
PFPAS    EQU      PFACC+3           FOLLOWING IT NEED BE   *
PFEXP    EQU      PFPAS+3           MODIFIED.              *
PFOUT    EQU      PFEXP+3                                  *
PFRD     EQU      PFOUT+4                                  *
PFWRT    EQU      PFRD+17           ALLOW 8 RD ACCTS
PFEXU    EQU      PFWRT+17          ALLOW 8 WRT ACCTS
PFUND    EQU      PFEXU+17          ALLOW 8 EXU ACCTS
*
DPW      EQU      PFUND+4           DEV PARAM PRES WDS
DTABS    EQU      DPW+1             D
DSEQID   EQU      DTABS+4           D
DDATA    EQU      DSEQID+1          D
DCOUNT   EQU      DDATA+1           D
DLINES   EQU      DCOUNT+1          D
DSPACE   EQU      DLINES+1          D
DDRC     EQU      DSPACE+1          D'S=> DEV PARAMETERS
         TITLE    ' '
*
* THE FOLLOWING GROUPS OF CODE ARE THE VECTOR AMPLIFIERS FOR THE LOAD
* AND CONTINUE TYPE OF COMMANDS. THE COMMAND VERB IS TRANSLATED INTO LMN
*
ASSEMBLE LI,D1    PARSER
         LD,R6    METASYM
         B        GROUP2
COMPILE  LI,D1    PARSER
         LD,R6    FORTRAN
         B        GROUP2
FIDER    BAL,SR4   FID              GO BREAK FID
         LI,R5    X'60'             WAS OVER/ON SPECIFIED
         LS,R5    J:JIT+JTELFLGS
         BEZ      TESTSI            NEITHER
         LI,R5    X'20'
         LS,R5    J:JIT+JTELFLGS    WAS OVER SPECIFIED
         BEZ      FIDER1            YES
         CW,SR2   J:JIT+JACCN       ON-CHECK FOR VALID ACCOUNT
         BNE      ONERR
         CW,SR3   J:JIT+JACCN+1
         BNE      ONERR             ITS A NO-NO
FIDER1   EQU      %                 ITS OK
         LW,D4    FULAM             PLACE PATTERN TO SIGNAL FID HAS
         B        *0                EXIT
         TITLE    'RUN AND LINK COMMAND VERBS'
RUN      EQU      %
         LI,R5    -2
         AND,R5   J:JIT+JCPPO
         STW,R5   J:JIT+JCPPO
         LI,D1    0
         LD,R6    LINK
         B        GROUP2            GO LOAD LINK
*
*
*          BREAK PROCESSING   (RESETS BRK BIT)
*
*
BREAKER  RES      0
         AND,D2   NBIT30
         STW,D2   J:JIT+JTELFLGS
         B        BUFINT
         TITLE    'VECTORS'
*
* VECTOR TABLES FOR RECOGNIZED TEL COMMAND VERBS
*
*
VECTOR1  NOP                        THE ORDER OF THESE TABLES MAY NOT BE
         LD,R6    COPY              ALTERED WITHOUT A CORRESPONDING
         LD,R6    EDIT              CHANGE TO TABLES VERB1 AND VERB2
         B        GET
         B        JOB
         B        RUN               (LINK)
         B        LIST
         LD,R6    LOGOFF            (OFF)
         B        QUIT
         B        RUN
         B        SHOW
         B        SAVEP
         B        DONT
         B        TABS
         B        SET
         B        FDPSET
         B        ASSEMBLE
         LD,R6    COPY              (PCL)
         B        CONTINUE
         B        QUIT
         B        QUIT
         B        RESET
         LD,R6    LOGOFF            (BYE)
         B        UDELT             (UNDER DELTA
         LD,R6    COPY              (L)
         B        BUILD             (EDIT)
         LD,R6    PCL               (D)
         LD,R6    PCL               (C)
         B        EDIT0
         B        MESSAGE0
         B        QUIT
         B        START
         B        PAGE
         B        DISPLAY
         B        STATUS
         B        TERMINAL          (TERMINAL STATUS/TYPE)
VECTOR2  NOP
         B        GET               (RESTORE)
         B        CONTINUE          (PROCEED)
         B        RESET
         LD,R6    EDIT              (BUILD)
         B        BATCH1
         B        CANCEL
         B        COMMENT
         B        COMPILE
         B        CONTINUE
         LD,R6    PCL               (DELETE)
         B        DISPLAY
         B        OUTPUT
         B        START
         B        STATUS
         B        TERMINAL
         B        PLATEN
         B        PASSWORD
         B        DELTASET
         B        DOUBLE1
         LD,R6    BASIC
         B        PRINT
         B        MESSAGE
         B        BACKUP
         B        EXTEND
*
         TITLE    'COMMAND VERB TRANSLATE TABLES'
VERB1    TEXT     '    '
* LOWER CASE VERSIONS               THE POSITION OF ENTRIES WITHIN THIS
         DATA,1   SC,SO,SP,SY       TABLE IS DIRECTLY KEYED TO A VECTOR
         DATA,1   SE,SD,SI,ST       TABLE. SHUFFLING MAY NOT OCCUR
         DATA,1   SG,SE,ST,S        WITHOUT A CORRESPONDING CHANGE TO
         DATA,1   SJ,SO,SB,S        TABLE VECT1. SCANNING IS DOWN FROM
         DATA,1   SL,SI,SN,SK       BACK TO FRONT. A NEW ENTRY MUST BE
         DATA,1   SL,SI,SS,ST       REFLECTED IN BOTH LOWER AND UPPER
         DATA,1   SO,SF,SF,S        CASE VERSIONS.
         DATA,1   SQ,SU,SI,ST
         DATA,1   SR,SU,SN,S
         DATA,1   SS,SH,SO,SW
         DATA,1   SS,SA,SV,SE
         DATA,1   SD,SO,SN,ST
         DATA,1   ST,SA,SB,SS
         DATA,1   SS,SE,ST,S
         DATA,1   SF,SD,SP,S
         DATA,1   SM,SE,ST,SA
         DATA,1   SP,SC,SL,S
         DATA,1   SG,SO,S,S
         DATA,1   SS,ST,SO,SP
         DATA,1   SE,SN,SD,S
         DATA,1   SR,S,S,S
         DATA,1   SB,SY,SE,S
         DATA,1   SU,S,S,S
         DATA,1   SL,S,S,S
         DATA,1   SB,S,S,S
         DATA,1   SD,S,S,S
         DATA,1   SC,S,S,S
         DATA,1   SE,S,S,S
         DATA,1   SM,S,S,S
         DATA,1   SQ,S,S,S
         DATA,1   SS,S,S,S
         DATA,1   SP,SA,SG,SE
         DATA,1   SD,SI,S,S
         DATA,1   SS,ST,S,S
         DATA,1   ST,S,S,S          TERMINAL STATUS/TYPE
         TEXT     'COPY'
         TEXT     'EDIT'
         TEXT     'GET '
         TEXT     'JOB '
         TEXT     'LINK'
         TEXT     'LIST'
         TEXT     'OFF '
         TEXT     'QUIT'
         TEXT     'RUN '
         TEXT     'SHOW'
         TEXT     'SAVE'
         TEXT     'DONT'
         TEXT     'TABS'
         TEXT     'SET '
         TEXT     'FDP '
         TEXT     'META'
         TEXT     'PCL '
         TEXT     'GO  '
         TEXT     'STOP'
         TEXT     'END '
         TEXT     'R   '
         TEXT     'BYE '
         TEXT     'U   '
         TEXT     'L   '            PCL LIST
         TEXT     'B   '            EDIT BUILD
         TEXT     'D   '            DELETE
         TEXT     'C   '            PCL COPY
         TEXT     'E   '            EDIT
         TEXT     'M   '            MESSAGE
         TEXT     'Q   '            QUIT
         TEXT     'S   '            START
         TEXT     'PAGE'
         TEXT     'DI  '            DISPLAY
         TEXT     'ST  '            STATUS
         TEXT     'T   '            TERMINAL STATUS/TYPE
SIZVERB1 EQU      %-VERB1-1
* DOUBLEWORD VERBS
         BOUND    8
VERB2    TEXT     '        '
* LOWERCASE VERSIONS-THIS TABLE IS ORDERED LIKE VERB1 WITH THE SAME
*                                   COMMENT APPLYING. ITS
         DATA,1   SR,SE,SS,ST,SO,SR,SE,S
         DATA,1   SP,SR,SO,SC,SE,SE,SD,S
         DATA,1   SR,SE,SS,SE,ST,S,S,S
         DATA,1   SB,SU,SI,SL,SD,S,S,S      CORRESPONDING VECTOR IS
         DATA,1   SB,SA,ST,SC,SH,S,S,S      VECT2
         DATA,1   SC,SA,SN,SC,SE,SL,S,S
         DATA,1   SC,SO,SM,SM,SE,SN,ST,S
         DATA,1   SF,SO,SR,ST,C'4',S,S,S
         DATA,1   SC,SO,SN,ST,SI,SN,SU,SE
         DATA,1   SD,SE,SL,SE,ST,SE,S,S
         DATA,1   SD,SI,SS,SP,SL,SA,SY,S
         DATA,1   SO,SU,ST,SP,SU,ST,S,S
         DATA,1   SS,ST,SA,SR,ST,S,S,S
         DATA,1   SS,ST,SA,ST,SU,SS,S,S
         DATA,1   ST,SE,SR,SM,SI,SN,SA,SL
         DATA,1   SP,SL,SA,ST,SE,SN,S,S
         DATA,1   SP,SA,SS,SS,SW,SO,SR,SD
         DATA,1   SD,SE,SL,ST,SA,S,S,S
         DATA,1   SC,SO,SB,SO,SL,S,S,S
         DATA,1   SB,SA,SS,SI,SC,S,S,S
         DATA,1   SP,SR,SI,SN,ST,S,S,S
         DATA,1   SM,SE,SS,SS,SA,SG,SE,S
         DATA,1   SB,SA,SC,SK,SU,SP,S,S
         DATA,1   SE,SX,ST,SE,SN,SD,S,S
         TEXT     'RESTORE'         (GET)
         TEXT     'PROCEED'         (GO)
         TEXT     'RESET'
BUILDA   EQU      %
         TEXT     'BUILD   '
         TEXT     'BATCH   '
         TEXT     'CANCEL  '
         TEXT     'COMMENT '
         TEXT     'FORT4   '
         TEXT     'CONTINUE'
         TEXT     'DELETE  '
         TEXT     'DISPLAY '
         TEXT     'OUTPUT  '
         TEXT     'START   '
         TEXT     'STATUS  '
         TEXT     'TERMINAL'
         TEXT     'PLATEN  '
         TEXT     'PASSWORD'
         TEXT     'DELTA   '
         TEXT     'COBOL   '
         TEXT     'BASIC   '
         TEXT     'PRINT   '
         TEXT     'MESSAGE '
         TEXT     'BACKUP  '
         TEXT     'EXTEND  '
SIZVERB2 EQU      %-VERB2-2
         TITLE    'SUB-ROUTINES'
         PAGE
* THE ASSIGN SUB-ROUTINE IS THE MANIPULATOR OF THE ASSIGN/MERGE TABLE.
* THROUGH THIS ROUTINE, ENTRIES ARE LOCATED, CHAINED, DELETED AND, WHEN
* REQUIRED, ADDITIONAL SPACE FOR ENTRIES IS OBTAINED AND INITIALIZED.
* THERE ARE ACTUALLY 3 ENTRIES TO ASSIGN. IN ALL CASES, REG 6
* AND 7 MUST CONTAIN THE ASSOCIATED DCB NAME, IN TEXTC FORMAT. REGISTER
* 4 MUST CONTAIN THE ADDRESS OF THE ASSIGN/MERGE TABLE.
*
* ENTRY 1-BAL,SR4 ASSIGN:
*        WILL CREATE A NEW ENTRY POSITION FOR THE GIVEN DCB AND RELEASE
*        ALL OTHER LIKE-DCB ENTRIES.
* ENTRY 2-BAL,SR4 ASSIGN+1:
*        WILL LOCATE THE CURRENT ENTRY FOR THE GIVEN DCB.
* ENTRY 3-BAL,SR4  ASSIGN+2:
*        WILL RELEASE THE MATCHING ENTRY(IF PRESENT) AND RETURN THE
*        SPACE TO THE AVAILABLE CHAIN. THE IN USE CHAIN IS RE-LINKED
*        AROUND THE REMOVED ENTRY.
* UPON EXIT FROM 1 AND 2:
*        REG 5 = ABSOLUTE ADDRESS OF DESIRED ENTRY. OTHER REGISTERS ARE
*        RETURNED INTACT. THE INPUT DCB NAME WILL BE STORED IN THE
*        ENTRY POINTED TO BY REG5. FOR ENTRIES 1 AND 3, THE REMAINING
*        WORDS WILL BE ZERO FILLED.
* REGISTER 5 MAY BE SET TO ZERO FOR THE FOLLOWING CONDITION:
*  ON EXIT FROM ENTRY 2 WHEN NO MATCH FOR THE DCB HAS BEEN FOUND.
*
ASSIGN   B        ASNEW1A           CREATE NEW ENTRY
         B        ASCURT            RETURN CURRENT ENTRY ADDRESS
         B        ASREL             RELEASE ENTRY AND RE-LINK
ASNEW    PUSH     5,R0
         CD,R6    TM:SI             IS IT M:SI?
         BNE      %+3
         LI,R3    X'18'             SI DON'T REL&CHAIN FLG
         STS,R3   J:JIT+JTELFLGS
         LW,R0    0,R4
         LW,R1    1,R4
         BNEZ     ASFIN1
*        NO ASSIGNS EXIST YET.
         LI,R0    22                INIT HEAD
         STW,R0   0,R4
         LI,R1    22
         STW,R1   1,R4              INIT AM CHAINS
         B        ASFIN
*
ASFIN1   CI,R0    X'1FF'            ANY ROOM LEFT IN PAGE?
         BGE      ASERR             NO
         STW,R1   R2
         LW,R1    *R4,R1
         BNEZ     %-2
         LW,R1    R2
         STW,R0   *R4,R1            LINK TO LAST ENTRY
         LW,R1    R0                NEW ENTRY TO R1
ASFIN    LI,R3    0
         LW,R2    R1
         STW,R3   *R4,R2            ZERO THE REST OF A/M PG.
         AI,R2    1
         CI,R2    X'1FF'
         BLE      %-3
         AW,R1    R4                ABS ENTRY
*
         AI,R1    1                                                  RL2
         LB,2     6                                                  RL2
         STB,2    *1                                                 RL2
         LB,3     6,2                                                RL2
         STB,3    *1,2                                               RL2
         BDR,2    %-2                                                RL2
         AI,R1    -1                                                 RL2
         STW,R1   R5                RETURN THE ENTRY ADDRESS
         PULL     5,R0
         B        *SR4
*
ASCURT   PUSH     3,R1
         PUSH     R0                ';' IMPLIES UPDATE
         BAL,R3   ASCUR
         PULL     R0
         LW,R5    R1                PROVIDE ENTRY ADDRESS
         PULL   3,R1
         B        *SR4
ASCUR    EQU      %
         LW,R1    1,R4              SCAN ASSIGNED CHAIN
ASCUR1   BEZ      *R3               NO FIND EXIT
         AW,R1    R4                ABSOLUTIZE LINK ADDRESS
         CW,6     1,R1                                               RL2
         BNE      ASCUR1A
         LB,5     6                                                  RL2
         LW,15    1                                                  RL2
         AI,15    1                                                  RL2
         LB,0     *15,5                                              RL2
         CB,0     6,5                                                RL2
         BNE      ASCUR1A                                            RL2
         BDR,5    %-3                                                RL2
         LW,R5    *TELSTACK         LOOK FOR UPDATE FUNC
         CI,R5    ';'
         BNE      %+2               NOT UPDATE FUNCTION
         BAL,R5   ASGMV             FOR UPDATE MOVE ENTRY
         B        0,3               RET NEW ADDR IN R1
*
ASCUR1A  EQU      %
         STW,R1   R2                R2=ADR OF BACKWARD LINK
         LW,R1    0,R1
         B        ASCUR1
*
ASREL1   PUSH     6,R0
         B        ASREL2
*
ASREL    PUSH     6,R0              RELEASE ENTRY SAVE 0-5
         BAL,R3   ASCUR             GO LOCATE ENTRY
*                                   RET ABS ENTRY ADDR R1
         CI,R1    0                 DID WE GET ONE
         BE       ASRELX            NO
ASREL2   SW,R1    R4                RESET TO REL POINTER
         CW,R1    1,R4              IS IT THE FIRST ENTRY IN CHAIN
         BE       AGREL1
         LW,R3    *R4,R1            NEXT LINK
         BEZ      AGREL2
AGREL    LW,R0    R3
         SW,R3    R1                ADJ FACTOR R3
         LW,R5    0,R4
         SW,R5    R0                # WDS TO MOVE
         PUSH     3,R1
         AW,R1    R4                TO
         AW,R0    R4                FROM
         LI,R3    0
         LW,R2    *R0,R3            MOVE PLIST
         STW,R2   *R1,R3             UP
         AI,R3    1                   OVER
         CW,R3    R5                   DELETED ENTRY.
         BLE      %-4
         PULL     3,R1
         LW,R0    0,R4
         SW,R0    R3
         STW,R0   0,R4              ADJUST AVAIL LINK
*        NOW ADJUST THE ENTRY LINKS UP.
AGREL3   LW,R0    *R4,R1            GET OLD LINK
         BEZ      ASRELX            END OF CHAIN
         SW,R0    R3                MINUS ADJ FACTOR
         STW,R0   *R4,R1
         STW,R0   R1
         B        AGREL3
*
*
ASRELX   LW,R3    1,R4              IF BOTH ASG CHAINS ARE EMPTY, RESET
         BNEZ     ASRELX1           ASSIGN BIT TO INDICATE NO ENTRIES.
         LI,R3    X'FFDFF'
         AND,R3   7,R4
         STW,R3   7,R4
ASRELX1  PULL     6,R0
         B        *SR4
*
AGREL1   LW,R3    *R4,R1
         BNEZ     AGREL             FWD LINKS EXIST
         STW,R3   1,R4              ONLY ENTRY, DELETE
         LI,R1    22                INIT AM CHAIN
         STW,R1   0,R4              AND MAKE AVAIL.
         B        ASRELX
*        RELEASING LAST ENTRY
AGREL2   STW,R3   *R2               ZERO PREV LINK
         STW,R1   0,R4              SET LAST AS NEW HEAD
         B        ASRELX
*
*
ASNEW1A  PUSH     SR4               RELEASE ANY LIKE ENTRIES
         BAL,SR4  ASREL
         PULL     SR4
         PUSH     R0
         LW,R0    0,R4              IS THERE ROOM FOR THIS ENTRY
         AI,R0    PSIZE+3           MINIMUM POSSIBLE FPT SPACE NEED.
         CI,R0    X'1FF'            EXCEED ONE PG??
         BG       ASERR             YES
         PULL     R0
         B        ASNEW
         PAGE
*
*        R5       LINK
*        R2       ENTER WITH PREV LINK ADDR
*        R1       RETURN ADDR OF SETBUF FOR UPDATE
*        TO UPDATE AN ENTRY: MOVE THE ENTRY FROM
*        THE ASSIGNED CHAIN TO A FIXED AREA (SETBUF)
*        ON TOP OF TELSTACK. COMPRESS THE ASSIGNED CHAIN
*        AND MOVE THE ENTRY THAT IS UPDATED TO THE
*        END OF THE CHAIN.
*
*
ASGMV    EQU      %
         PUSH     SR4               SAVE LINK
         PUSH     3,R3
         PUSH     R2                SAVE PREV LINK
         LW,R5    *R1               GET LINK TO NEXT
         BNEZ     ASGMV1
         LW,R5    0,R4              END OF CHAIN
         SW,R1    R4                DISP TO CURR ENTRY
         SW,R5    R1                # WDS TO MOVE
         STW,R5   TELBUF+I39        SAVE #
         AW,R1    R4                ABS CURR ENTRY
         B        ASGMV2
ASGMV1   AW,R5    R4                ABS
         SW,R5    R1                #WDS TO SAVE
         STW,R5   TELBUF+I39
ASGMV2   LI,R2    SETBUFE           END OF TELSTACK
         LI,R3    0
         CI,R2    SETBUF            BEGIN OF PLIST AREA
         BL       %+3
         STW,R3   *R2               INIT PLIST AREA
         BDR,R2   %-3               R2 SET FOR MOVE
*
         AI,R1    -1
         LW,R3    *R1,R5            FROM
         STW,R3   *R2,R5            TO
         BDR,R5   %-2
         AI,R1    1
         PULL     R2                GET LAST LINK
         BAL,SR4  ASREL1
         LI,R1    SETBUF            ADDR OF ENTRY TO UPDATE
         PULL     3,R3
         PULL     SR4
         B        *R5
ASERR    EQU      %
         LI,R2    21
         LI,R1    FULAM
         CAL1,1   WRITE
         B        SYN2
         PAGE
*
* THE FOLLOWING ARE ERROR AMPLIFYERS USED TO PRINT THE CORRECT MESSAGE.
*
NTJBST   LI,R1    LEGCMD            NOT AT JOB STEP TIME
         LI,R2    30                SIZE OF MESSAGE
         CAL1,1   WRITE             M:WRITE
         B        SYN1
ERRME    LI,R1    FILME             PUT OUT 'FILE: ME' MESSAGE
         LI,R2    8
         B        ONERR2
BADFORM  LI,R1    FORMAT
         LI,R2    27
         CAL1,1   WRITE
         B        SYN1
AMERR    LI,R1    NOAM
         LI,R2    24
         CAL1,1   WRITE
         B        SYN1
STARTERR LI,R1    WHO
         LI,R2    11
         CAL1,1   WRITE
         B        SYN1
DOWHAT   LI,R1    CWHAT
         LI,R2    14
         CAL1,1   WRITE
         B        SYN1
BADDCB   LI,R1    WHATDCB
         LI,R2    16
         CAL1,1   WRITE
         B        SYN1
PASSBAD  LI,R1    BADACC
         LI,R2    22
         LCI      2
         STM,D3   J:JIT+JACCN       RESTORE USERS ACCOUNT
         CAL1,1   WRITE
         B        SYN1
BKOPT0   EQU      %
         LW,R1    =X'40000'         SET IMPLIED QUIT FLAG TO ALLOW
         STS,R1   J:TELFLGS         'CR' TO CAUSE PROCESSING OF CURRENT
         LW,R1    TELBUF            COMMAND. SAVE 1ST WORD OF COMMAND
         STW,R1   TELBUF+54         FOR RESTORE AFTER NEXT READ
BKOPT    LI,R1    BKMSG
         LI,R2    5
         CAL1,1   WRITE
         B        SYN1
ASIZER   LI,R1    PSML              NOT ENOUGH ROOM IN ENTRY FOR DESIRED
         LI,R2    36                PLIST PARAMETERS
         CAL1,1   WRITE
         B        SYN1
TERMERR  LI,R1     TRMERMSG
         LI,R2     23
         CAL1,1    WRITE
         B         SYN1
DELCONF  LI,R1    LATERM            PUT OUT 'CONFLICT WITH DELTA' MSGE.
         CAL1,2   TYPE
         B        PROMPT
MOVEERR  LI,R1    INEXC1            ERR MESSG
         LI,R2    15
         CAL1,1   WRITE
         B        SYN1              ABORT
RTYERR   EQU      %
         LI,R1    RERR              BAD RTYPE OR
         LI,R2    35                 INCONSISTENT TYPE
         CAL1,1   WRITE
         B        SYN2
         PAGE
NOPAGE   RES      0
         LI,1     NOPAGETX
         LI,2     14
         CAL1,1   WRITE
         LI,1     X'A7'
         STB,1    J:JIT+JABC
         CAL1,9   3                 ABORT
*
EXPERR   EQU      %
         LI,R1    EXPERM
         LI,R2    32
         CAL1,1   WRITE
         B        SYN1
*
EXONLY   EQU      %
         LI,R1    EXLYMSG
         LI,R2    40
         CAL1,1   WRITE
         B        SYN1
*
         PAGE
* THIS SUB-ROUTINE IS CHARGED WITH THE OBTAINING OF A BUFFER FROM THE
* FPOOL AREA AND READING THE ASSIGN/MERGE TABLE INTO IT.
* NO INPUT PARAMETERS ARE REQUIRED. ENTER WITH A BAL,SR4.
* OUTPUT CONSISTS OF THE TABLE IN MEMORY WITH ITS ADDRESS PLACED IN THE
* JIT CELL J:ABUF.
READAM   PUSH     5,R4
         LW,R4    J:ABUF            IS A/M ALREADY IN
         BNEZ     READAM1
         LI,SR2   AMBUF             GET 2ND BUFFER FOR
         DO1      A=1               DON'T GET PAGE IN DEBUG MODE
         CAL1,8   GPFPT               A-M RECORD
         BCS,8    AMERR
         STW,SR2  J:ABUF            STORE ITS ADDRESS
         STW,SR2  7                 AM BUFFER ADDRESS
         BAL,R4   SETACL            MAKE SURE M:XX IS CLOSED
         LI,R4    M:XX
         LI,R5    SYSERR            ERR RETURN
         STW,R5   M:XX+3
         STW,R5   M:XX+4
         DO1      A=2
         CAL1,1   OPENXX            TEMP                           ****
         CAL1,1   AMR               READ IN THE TABLE
         DO1      A=2
         CAL1,1   SHUTDCB           AND CLOSE THE DCB
         LI,R5    0                 CLEAN UP DCB
         STW,R5   M:XX+3
         STW,R5   M:XX+4
         LW,R4    J:JIT+JCPPO       INITIALIZE JOB-ORIENTED DATA
         STW,R4   6,R7              EXT
READAM1  EQU      %
         PULL     5,R4
         B        *SR4
         PAGE
* THIS SUB-ROUTINE PROVIDES THE WRITE OF THE ASSIGN/MERGE TABLE AND
* ALSO PLACES THE BIT ASSIGNMENT DATA INTO JIT.
* THE WRITE CALL IS IGNORED IF THE A/M IS NOT IN MEMORY.
* ENTER WITH A BAL,SR4
*
WRITEAM  PUSH     8,R4
         DO   A=2                                                    RL2
         B       WITEX                                               RL2
         FIN                                                         RL2
         LW,R7    J:ABUF
         BEZ      WITEX             WRITE ONLU IF IN MEMORY
         LW,SR1   6,7               EXT
         STW,SR1  J:JIT+JCPPO
         DO       A=2
         LI,R5    2                 TEMP                 ******
         XW,R5    OPENXX+4          TEMP                 *******
         CAL1,1   OPENXX            TEMP                 *******
         FIN
         DO       A=1
         BAL,R4   SETACL            CLOSE M:XX
         LI,R5    SYSERR            ERROR RETURN
         STW,R5   M:XX+3            SET ERR RET
         STW,R5   M:XX+4
         LI,R4    M:XX
         FIN
         CAL1,1   WAMR
         DO       A=2
         CAL1,1   SHUTDCB
         STW,R5   OPENXX+4          TEMP               ******
         FIN
         LI,R5    0                 CLEAN UP DCB
         STW,R5   M:XX+3
         STW,R5   M:XX+4
WITEX    PULL     8,R4
         B        *SR4
         PAGE
* THIS ROUTINE IS A SPECIAL PURPOSE BODY OF CODE USED IN THE PASSWORD
* COMMAND PROCESSING TO OBTAIN A CONCATINATED KEY FOR READING THE LOGIN
* FILE.
*
CONCAT   LI,R5    0
         LB,R6    *R2,R5
         AI,R5    1
         CI,R6    ' '               TEST END OF CHARACTER STRING
         BE       *SR4
         AI,R4    1
         STB,R6   *R3,R4
         CW,R5    SR1               REACHED MAX CHARS
         BE       *SR4              YES: EXIT
         B        CONCAT+1
         PAGE
* TJIS ROUTINE WILL PROVIDE A GENERAL PLIST AND AN OPE TO THE INPUT
* FILE USING THE M:XX DCB. THE OPEN MODE IS ALWAYS 'IN'.
* ENTER WITH A BAL,SR4 WITH:
*        REGS SR2,SR3 = ACCOUNT
*        REGS D1,D2,D3 = FILE NAME(NON-TEXTC)
*        REGS R7,SR1 = PASSWORD OR ZEROS
* ON EXIT R0 = 0 IF NO ERROR; = ERROR CODE RIGHT JUSTIFIED IF ERROR.
*        EA  ROAM D
*        110001110100   =C74
*
*
FLOP     PUSH     15,R1
         LI,R1    TELBUF+20         TEMP
         LW,R2    PLIST             CREATE PLIST
         AI,R2    M:XX
         STW,R2   0,R1
         LW,R2   =X'C7400209'
         LI,R3    RFE
         LI,R4    RFE
         LI,5     1                 CON
         LI,6     1                 SEQ
         LCI      5
         STM,R2   1,R1
         LI,R5    1                 INPUT MODE
         LW,R6    J:JIT+JTELFLGS
         CI,R6    X'20'
*        THIS TEST IS FOR SAVE /GET
         BANZ     %+2               0 = OVER, 1 = ON
         LI,R5    2                 OUT
         CI,R6    X'8000'           IS DELETE IN PROGRESS?
         BAZ      %+2               NO, SKIP
         LI,R5    4                 OPEN IN INOUT MODE
         LI,R6    2                 SAVE
         STW,5    6,1               MODE
         STW,6    7,1               DISP
         LW,R6    PPAS
         CI,R7    0                 TEST FOR PASSWORD
         BE       %+2
         AI,R6    X'200'            TURN ON PASSWORD PARAM
         LCI      3
         STM,R6   15,R1             PASS
         LW,SR1   PACC
         LCI      3
         STM,SR1  12,R1             ACC
         BAL,SR3  NFND              MAKE NAME TEXTC
         LW,R5    NAME
         LCI      4
         STM,5    8,R1              NAME
         LI,SR3   0                 CLEAR ERROR RETURN
         CAL1,1   *R1               AND OPEN THE FILE
         LB,R0    SR3               POSITION ANY ERROR CODE
         PULL     15,R1
         B        *SR4
RFE      B        *SR1              ERROR RETURN TO CAL+1
         PAGE
* THE 'NFND' ROUTINE IS USED WHEN A LMN HAS BEEN PRESENTED AS A COMMAND.
* IT FORMS A TEXTC LMN FORMAT IN REGS 6,7 AND 8. ENTRY IS WITH BAL,SR3.
* THE INPUT LMN MUST BE IN D1, D2 AND D3.
*
NFND     PUSH     2,R4
         LI,R4    0
         LD,R6    VERB2             BLANK FILL BUFFER
         LW,SR1   VERB1
NFND1    LB,R5    D1,R4
         CI,R5    C' '
         BE       NFND2
         AI,R4    1
         STB,R5   R6,R4
         B        NFND1
NFND2    STB,R4   R6                INSERT COUNT
         PULL     2,R4
         B        *SR3
         PAGE
*
* THE SCAN SUB-ROUTINE PROGRESSES THROUGH THE INPUT COMMAND PICKING UP
* THE NEXT FIELD. IT PROVIDES THE BOOKEEPING TO ALWAYS START AT THE
* BEGINNING OF A FIELD. FIELD TERMINATORS ARE DETERMINED BY THE CONTENTS
* OF TABLE 'TERMS'. LEADING AND TRAILING BLANKS ARE SUPPRESSED AS WELL
* AS SERVING AS A TERMINATOR. ALL DATA ENCLOSED WITHIN PARENS() IS
* IGNORED AND ANY CHARACTERS MAY BE USED.
*
* ENTRY IS MADE WITH A BAL,SR3 SCAN OR BAL,SR3 SCAN#
* A BAL TO SCAN# IS USED TO INCLUDE # AS A TERMINATOR FOR THE SET COMMAND
*   R2 =  BYTE DISPLACEMENT WITHIN INPUT FIELD(NEXT FIELDS' STARTING
*         POSITION).
*   R3 =  ADDRESS TO WHERE FIELD IS TO BE MOVED. ZERO IF NO MOVE IS TO
*         TAKE PLACE.
*   R1 =  REMAINING SIZE OF INPUT MESSAGE(ARS).
*
* ON EXIT, THE FOLLOWING IS IN THE REGISTERS:
*   R6 =  FIELD DELIMITER CHARACTER(EXCEPT EOM IS NEVER SEEN-R1=0).
*   R7 =  NUMBER OF CHARACTERS IN FIELD, EXCLUSIVE OF SEPERATORS.
*   SR1 = DESTROYED.
*   R5 =  INDEX INTO TERMS TABLE(CHARACTER TYPE THAT STOPPED THE SCAN).
*   R1 =  AS ABOVE BUT DECREMENTED BY NUMBER OF CHARACTERS SCANNED.
*   R2 =  AS ABOVE POSITIONED TO START OF NEXT FIELD
*
* NOTE-R1=0 IMPLIES END OF MESSAGE.
*
SCAN     LI,R5    SIZETERM-2        SKIP # AND - SIGNS
         B        SCAN2
SCAN#    LI,R5    SIZETERM
SCAN2    LI,SR1   0
         LI,R7    0
         PUSH     R0
         LI,R0    0                 CLEAR PAREN COUNTER
         PUSH     R5                SAVE TERMS TABLE SIZE
         LI,R5    0                 PRE-SET DELIMIT VECTOR TO BLANK
LOOP     BDR,R1   LOOP1
LOOP5    PULL     R0                REMOVE TERMS TABLE SIZE FROM STACK
         PULL     R0
         B        *SR3              REMAINING BYTES
LOOP1    EQU      %
         LB,R6    TELBUF,R2         CHAR
         AI,R2    1                 AND INCREMENT TO NEXT POSITION
         CI,R6    ' '               BLANK TEST
         BE       YBLK
         CI,R6    '('               PROVIDE SKIP ON PAREN FEATURE
         BE       PARENO
         CI,R6    ')'               END PAREN SKIP
         BE       PARENC
         CI,R6    X'05'             TAB TEST-SAME AS BLANK
         BNE      TERMTST
YBLK     CI,R7    0                 TEST FOR PREVIOUS DATA
         BEZ      LOOP              IGNORE LEADING BLANKS
         AI,SR1   1                 SET BLANK FLAG
         B        LOOP              SUPPRESS TRAILING BLANKS
TERMTST  EQU      %                 SCAN FOR TERMINATING CHARACTERS
         CI,R0    0
         BE       TERMTST1
         LI,SR1   1                 IN SKIP-FORCE BLANK LOGIC
         B        LOOP
TERMTST1 EQU      %
         LW,R5    *TELSTACK         GET TERMS TABLE SIZE
         CB,R6    TERMS,R5
         BE       LOOP+1
         BDR,R5   %-2
         CI,SR1   0                 NOT A TERMINATOR-TEST BLANK FLAG
         BE       CHAROK            JUMP IF NOT SET
         AI,R1    1                 RESET POSITION TO START OF NEW FIELD
         AI,R2    -1
         LI,R6    ' '               FORCE BLANK DELIMITER
         B        LOOP+1
CHAROK   CI,7      11                                                RL2
         BNE      CHAROK5
         LI,SR3   CHKULM            TOO MANY CHARS.
         B        LOOP5
CHAROK5  CI,R3    0                 IS DATA TO BE MOVED
         BE       %+2               NO
         STB,R6   *R3,R7            YES
         AI,R7    1                 COUNT CHARACTER
         B        LOOP              AND GO FOR NEXT ONE
PARENO   AI,R0    1                 BUMP PAREN COUNT
         B        LOOP
PARENC   AI,R0    -1                DECREMENT PAREN COUNT
         BGEZ     LOOP
         LI,R0    0                 CLEAR COUNT
         CI,R7    0                 STRAY CLOSE PAREN IS IGNORED
         BE       LOOP
         LI,SR3   CHKULM            BUT IS FLAGGED AS ERROR WHEN MORE
         B        LOOP5             CLOSE THAN OPENS EXIST.
*
* THE TERMS TABLE IS A BYTE TABLE CONTAINING A TERMINATOR CHARACTER IN
* EACH ENTRY. THE SCAN SUB-ROUTINE LOOKS AT THE TABLE FROM BACK TO FRONT
* AND THE FIRST ENTRY MUST BE A DUMMY. A SPACE SEPERATOR IS NOT NEEDED
* AS THIS LOGIC IS PERFORMED MORE EFFICIENTLY OUTSIDE OF THE TABLE.
* THE TERMINATOR # MUST BE LAST ENTRY IN TABLE
* THE TERMINATOR - MUST BE THE NEXT TO LAST ENTRY IN TABLE.
TERMS    DATA,1   C' '              DUM-DUMB
         DATA,1   C'?'  INDEX 1     ORDERING WITHIN
         DATA,1   C'='        2     THIS TABLE IS
         DATA,1   C'/'        3     IMPORTANT! IF
         DATA,1   C'.'        4     ADDITIONAL ENTRIES
         DATA,1   C'>'        5     ARE DESIRED,
         DATA,1   C'<'        6     ALWAYS ENTER
         DATA,1   C';'        7     THEM BELOW
         DATA,1   C','        8     THIS POINT!
         DATA,1   C''''             9
         DATA,1   '-'
         DATA,1   C'#'              10
SIZETERM EQU      BA(%)-BA(TERMS)-1
         BOUND    4
*
* 'STOPS' IS A VECTOR USED TO DEFINE THE TERMINATING CHARACTER AND ENTER
* THE CORRECT LOGIC. IT IS EMPLOYED DURING THE SCAN OF A COMPILE OR
* ASSEMBLE DIRECTIVE. THE FORMAT IS ORIENTED TO THE TERMS TABLE AND MAY
* NOT BE ALTERED WITHOUT CORRECT CORRESPONDENCE TO TERMS.
*
STOPS    RES      0
         B        *0                SPACE
         B        CHKULM            QUESTION MARK ILLEGAL
         B        CHKULM            =  ILLEGAL
         B        CHKULM            /  ILLEGAL
         B        FIDER             . IMPLIES COMPLEX FID
         B        CHKULM            >  ILLEGAL
         B        CHKULM            <  ILLEGAL
         B        CHKULM            ;  ILLEGAL
         B        *0                ","
         B        CHKULM
         B        CHKULM            - (MINUS)
         B        CHKULM
*
* THE FOLLOWING IS A UNIQUE TERMINATOR VECTOR FOR THE SET COMMAND.
* DEVICE CODE FIELD.
SETSTP   NOP                        THE ORDER OF THIS VECTOR IS KEYED
         B        SYNTAX            TO THE TERMS TABLE.
         B        SYNTAX            = ILLEGAL IN THIS FIELD
         B        SETFLE            / IMPLIES FILE PLIST
         B        SYNTAX            . ILLEGAL IN THIS FIELD
         B        SYNTAX            > ILLEGAL IN THIS FIELD
         B        SYNTAX            < ILLEGAL IN THIS FIELD
         NOP                        ; REQUIRES DEVICE OPTION PLIST
         B        SYNTAX            , ILLEGAL IN THIS FIELD
         B        SYNTAX
         B        SYNTAX
         B        SETNUMB           # IMPLIES DEVICE SERIAL NUMBER
         PAGE
* THIS SUB-ROUTINE IS USED TO TEST THE VALIDITY OF A DCB NAME. IF VALID,
* RETURN IS MADE TO THE CALL+1 LOC. IF ERRONEOUS, A DIRECT ENTRY TO
* SYNTAX IS MADE.
* ON ENTRY,D1 AND D2 MUST CONTAIN THE DCB NAME.
*          R7 CONTAINS THE COUNT OF CHARACTERS.
* ENTER WITH BAL,SR4.
*
CHKDCBN  CI,R7    7+8                                                RL2
         BG       SYNTAX
         LI,R7    X'FD47A'          CHECK FOR M: OR F:
         CH,R7    D1
         BE       CHKOK
         LI,R7    X'FC67A'
         CH,R7    D1
         BNE      SYNTAX            ITS NEITHER M: NOR F:
CHKOK    LI,R7    SIZDCBN           INSURE ITS NOT ONE OF THE NON-ALLOW
         CW,D1    DCBNS,R7          DCB NAMES
         BE       SYNTAX            FOUND A NO-NO
         BDR,R7   CHKOK+1
         B        *SR4              DCB NAME IS OK
*
* LIST OF NON-ALLOWED DCB NAMES.
*
DCBNS    TEXT     '    '
         TEXT     'M:  '
         TEXT     'M:UC'
         TEXT     'M:OC'
         TEXT     'M:XX'
SIZDCBN  EQU      %-DCBNS-1
         PAGE
* THE FOLLOWING IS ENTERED ANY TIME SOME UNINTELLIGIBLE ENTITY IS
* ENCOUNTERED DURING THE FIELD SCAN OR MESSAGE PARSE. THE ACTION IS TO
* PUT OUT THE ''EH'' MESSAGE AND TURN THE CONSOLE BACK TO THE USER FOR
* A RETRY. THE ENTIRE MSG MUST BE RE-ENTERED.
*
SYNTAX   EQU      %
         LW,D1    R2                SAVE ERROR POSITION
         BAL,SR4  BINDECBCD         CONVERT BINARY PLACE VALUE TO PRINT
         LCI      2
         LM,R6    EHMSG
         LI,R1    1                 PUT LAST 2 DIGITS IN MESSAGE.
         STH,D2   R7,R1
         LW,R1    TELSTACK
         AI,R1    1
         PUSH     2,R6
         LI,R2    8
         CAL1,1   WRITE
*
* ANY PREVIOUS PROCESSING WILL HAVE NO LASTING EFFECT AS THE A/M TABLE
* WILL BE READ FROM OISC AGAIN, THEREBY NULLIFYING ERROR MSG.
*
SYN2     EQU      %
SYN1     LW,R7    J:JIT+JRESOPT     RESTORE OPTION SPECIFICATIONS TO
         STW,R7   J:JIT+JSTDOPT     STATE PREVIOUS TO ABORT.
         DO       A=1
         LI,R1    0
         STW,R1   M:XX+3            CLEAR ERR AND ABN WORDS
         STW,R1   M:XX+4
         ELSE
         CAL1,1   CLEARXX
         FIN
         LI,R4    M:XX              SAFETY CLEANUP
         CAL1,1   SHUTDCB
         LW,R1    J:ABUF            RELEASE A-M BUFF AS REQ'D
         BEZ      SYN3
         LI,SR2   AMBUF
         DO1      A=1               DON'T FR PG IN DEBUG MODE
         CAL1,8   FPFPT
         LI,R1    0
         STW,R1   J:ABUF
         LI,R1    X'10'             WAS AN SI CREATED ON THIS CMD
         LS,R1    J:JIT+JTELFLGS
         BEZ      SYN3              NO
         LI,R1    -9                TURN OFF SI DONT RELEASE FLAG
         AND,R1   J:JIT+JTELFLGS
         STW,R1   J:JIT+JTELFLGS
SYN3     EQU      %                                                  RL2
CLEANSTACK RES    0
         LI,D1    TELBUF
         LW,D2   =X'00FE0000'       STACK SIZE
         STD,D1   TELSTACK          STORE STACK PTR DWD
         BUMP     55,D2             55=X'37'
         B        PROMPT            GIVE 'EM ANOTHER GO
*
*PROCESS A SYSTEM DETECTED ERROR.
*
SYSERR   EQU      %
ERRABN   EQU      %
         LW,R1    J:JIT+JTELFLGS    TURN OFF ANY BREAK BIT
         AND,R1   NBIT30
         STW,R1   J:JIT+JTELFLGS
         LB,R4    J:JIT+JRNST
         CI,R4    4
         BAZ      ERRABN1
         LI,R4    32
         INT,R3   J:JIT+JASSIGN
         AND,R3   =X'1FF'
         SLS,R3   1
         BCS,8    %+3
         AI,R4    -1
         B        %-3
         LI,R5     X'1FFFF'
         STS,R4   J:JIT+ERO
         LI,R4    X'B3'
         STB,R4   J:ABC
ERRABN1  EQU      %
*                 READ ERRO MESSAGE FILE
         LW,D1    ERO+J:JIT
         SLD,D1   -8
         LB,D1    J:ABC
         SLD,D1   8
         LI,SR1   X'0300'           KEY LENG&GROUP CODE
         STH,SR1  D1
         LI,R1    0
         STB,R1   J:ABC             CLEAR ERROR CELLS
         STB,R1   J:JIT+JRNST
         STW,R1   J:JIT+ERO
         BAL,R4   SETACL            INSURE M:XX IS CLOSED
         BAL,0    WRITERR1
         BAL,R0   560ERR            HANDLE SPC 560 ERRORS
SYSE1    BAL,R4   SETACL            CLOSE M:XX
         LI,R1    0
         STW,R1   M:XX+3
         STW,R1   M:XX+4            SAFETY CLEANUP
         LI,R1    X'FFFCF'          RESET BYTE OFFSET
         AND,R1   M:XX              IN CASE OF READ OF ERROR FILE
         STW,R1   M:XX
         LI,R1    0
         STB,R1   J:JIT+JABC
         STB,R1   J:JIT+JRNST
         LW,R1    L(X'0000FF00')
         LS,R1    D1                GET ERROR CODE
         SLS,R1   -8
         CI,R1    X'A9'
         BE       %+3               LOG 'EM OFF
         LW,R1    J:AMR             A/M ERROR
         BCS,3    SYSE1A             NO
         LD,R6    LOGOFF            DO
         LW,SR1   VERB1              INTERPRITIVE
         LW,D2    SYS                 EXIT
         LW,SR4   VERB1                TO
         LW,SR3   VERB1                 LOGOFF
         LI,0     0
         CAL1,9   1
SYSE1A   EQU      %
         DO1      A=2
         B        SETUP             TEMP               ******
         B        XABORT
*
SYSE3    LI,R1    M:XX+23           LMNNAME
         LB,R2    *R1               PICK UP BYTE COUNT OF LMN NAME
       LI,R3   X'15'
       STB,R3  *R1                 ADD A CR IN PLACE OF COUNT
       AI,R2   1
         CAL1,1   WRITE             PRINT NAME ILLEGAL
         LI,R1    LEGER1
         LI,R2    10
         CAL1,1   WRITE
         B        SYSE1
         PAGE
*
* THIS ROUTINE HANDLES SPECIAL REPORTING OF CERTAIN
*  ERRORS FOR CP-V WHEN RUN ON 560 HARDWARE.
*
560ERR   EQU      %
         LI,R1    X'C0'             SEE IF 560
         LS,R1    X'2B'
         BEZ      *R0               RET TO SYSE1; NOT 560
         LW,R1    L(X'0000FF00')
         LS,R1    D1                GET ABC CODE
         SLS,R1   -8
         LI,R4    ABCSZE
         CB,R1    ABCTAB,R4         THESE ARE THE SPC ONES.
         BE       560ERR1
         BDR,R4   %-2
         B        *R0               RET TO SYSE1
560ERR1  PUSH     2,D1
         LW,D1    J:ALB             560 BRANCH LOC.
         BAL,SR4  BINDECBCD         CONV'T
         LI,R1    560MSG
         LI,R2    23
         CAL1,1   WRITE
         LI,R1    D1
         LI,R2    8
         CAL1,1   WRITE
         PULL     2,D1
         B        *R0               RET TO SYSE1
*
*
         BOUND    4
ABCTAB   EQU      %
         DATA,1   0,X'B2',X'A3',X'A4'
ABCSZE   EQU      BA(%)-BA(ABCTAB)-1
         BOUND    4
         PAGE
* THE FOLLOWING LOGIC IS PROVIDED TO HANDLE THE OCCURANCE OF AN ABNORMAL
* OR ERROR CONDITION INCURRED DURING THE READ OF THE USER TERMINAL.
* THE '05' ERROR IS IGNORED AS THE MESSAGE HAS ALREADY BEEN REPEATED BY
* THE TIME IT IS SENSED. OTHER ERRORS WILL OUTPUT A MESSAGE AND ALLOW
* THE USER TO TRY AGAIN.
*
*
ABNRET   SLS,SR3  -24               POSITION ERROR CODE
         CI,SR3   X'05'
         BE       CLEANSTACK
         LI,R1    TELBUF            ECHO INPUT
         LW,R2    ARS
         SLS,R2   -17
         AI,R2    -1
         CAL1,1   WRITE
         LI,R1    PARMSG            PUT OUT ERROR MSG.
         LI,R2    17
         CAL1,1   WRITE
         B        CLEANSTACK        GIVE ANOTHER TRY
         PAGE
* THIS IS A SUB-ROUTINE WHICH CONVERTS A BINARY BUFFER POSITION TO A
* PRINTABLE DECIMAL VALUE.
* ENTER WITH
*        D1 = DIGIT TO BE CONVERTED(HEX).
*
* EXIT WITH
*        D1, D2 = 8 CHARACTER RESULT
*
*        REGS R1, D3 AND D4 ARE DESTROYED
*
BINDCB   RES      0                 STATUS ROUTINE ENTRY POINT
BINDECBCD EQU     %
         LI,R1    7
         LW,D4    D1
BINA     LI,D3    0
         DW,D3    XA
         AI,D3    X'F0'
         STB,D3   D1,R1
         AI,R1    -1
         BGEZ     BINA
         B        *SR4
         PAGE
* THE DECBIN ROUTINE WILL CONVERT AN EBCDIC DECIMAL CHARACTER STRING TP
* BINARY.
* ENTER WITH A BAL,SR4 AND:
*        R7 = NUMBER OF CHARACTERS
*        R3 = WORD ADDRESS OF FIRST CHARACTER
* EXIT WITH:
*        R7 = RESULT
*        OTHER REGISTERS ARE RETURNED INTACT
*
DECBIN   PUSH     3,SR2
         PUSH     R4
         LI,SR2   0
         LI,R4    0
DECBIN1  LB,SR4   *R3,R4
         AI,SR4   -X'F0'            REMOVE LEADING F
         BLZ      SYNTAX
         CI,SR4   X'A'
         BGE      SYNTAX
         MI,SR2   X'A'
         AW,SR2   SR4
         AI,R4    1
         BDR,R7   DECBIN1
         STW,SR2  R7
         PULL     R4
         PULL     3,SR2
         B        *SR4
         PAGE
*  THIS ROUTINE CONVERTS AN EBDIC HEX FIELD TO BINARY
*    ENTER: BAL,R1
*           D1 = NUMBER TO BE CONVERTED
*  EXIT  :
*           SR1 = BINARY RESULT
* WHEN A NON HEX CHARACTER IS ENCOUNTERED,  A NEGATIVE VALUE WILL
*  BE RETURNED IN SR1 TO INDICATE THE ERROR.
*
*  THE FOLLOWING REGISTERS WILL BE DESTROYED
*            R2
*             SR2
*
HEX2BIN  EQU      %
         LI,SR1   0
         LI,R2    0
SCN      LB,SR2   D1,R2
         CI,SR2   0
         BE       *R1
         CLM,SR2  F0F9
         BCR,9    CONTINU
         CLM,SR2  C1C6
         BCR,9    CONTINU-1
         B        ERBIN
         AI,SR2   9
CONTINU  SLS,SR2  28
         SLD,SR1  4
         AI,R2    1
         CI,R2    4
         BL       SCN
         B        *R1
*
ERBIN    LI,SR1   -1                INDICATE ERROR
         B        *R1
         PAGE
* THE EXPAND ROUTINE IS USED TO PULL APART A COMPRESSED A/M ENTRY AND
* PUT IT IN THE NORMAL SKELETAL FORM. IN THIS MANNER, SPACE IS MADE
* AVAILABLE FOR THE INSERTION OF NEW ENTRIES OR THE ALTERATION OF
* CURRENT ONES.
* ENTER WITH BAL,SR4 AND:
*    R4=ADDRESS OF SETBUF
*        EXPAND CALLED ONLY BY 'SETUPDAT' ROUTINE.
*
*
EXPAND   PUSH     15,R1
         LI,R5    0
         XW,R5    TELBUF+I39        GET SZE OF ENTRY
         BEZ      EXPAND12
         CI,R5    SETBUFSZ          WILL REC FIT?
         BG       EXPERR            ERROR
         LW,R3    1,R4
         LB,R3    R3                SZE OF DCB NAME
         SLS,R3   -2                MAKE # OF WDS.
         AI,R3    1+1+2             ROUND DCB WDS, WD FOR LINK CELL
*                                   AND STEP OVER ADCB TO PP WD.
         SW,R5    R3                ENTRYSZE-DCB NAME&HEAD
         AW,R3    R4                PT TO ADCB FPT
         LI,R7    SETBUFSZ            BUFFER SIZE
         LI,D1    0                 MOVE PLIST TO BOTTOM OF ENTRY
         AI,R7    -1                                                 RL2
         XW,D1    *R3,R5            CLEARING THE OLD LOCATIONS AS WE GO
         XW,D1    *R4,R7            (HEADING AND PRESENCE WORDS STAY
         BDR,R5   %-3
         AI,R3    -2                                                 RL2
* NOW THAT THE INTACT PLIST IS MOVED TO THE BOTTOM OF THE ENTRY, WE CAN
* START EXPANDING IT UPWARD, STARTING FROM THE TOP OF THE PLIST.
         LI,R2    1                 DECODE PARAMETERS PRESENT
         LW,R1    2,R3              PICK UP PRESENCE WORD
EXPAND2  BAL,SR4  SHIFTY
         CI,R2    0
         BE       EXPAND3           NO MORE PARAMETERS INDICATED
         LB,R6    PLACES,R2         GET THE DISPLACEMENT POSITION
         BEZ      EXPAND12          NO DEFINED POSITION-ERROR
         LI,R5    1
         BAL,SR4  EXPAND9
         B        EXPAND2
EXPAND3  LI,R1    X'4000'           CHECK FOR VARIABLE PARAMETERS
         LS,R1    1,R3
         BNEZ     EXPAND6           GO PROCESS VARIABLES
EXPAND4  LI,R1    X'1000'           HOW ABOUT A DEVICE ORIENTED PLIST
         LS,R1    1,R3
         BNEZ     EXPAND8           YUP-GO TO IT
EXPAND5  PULL     15,R1             ITS ALL GROWED UP NOW
         B        *SR4
*
*        PROCESS VLP'S
*        CW IN COMMENTS IS VLP CONTOL WORD
EXPAND6  LW,R6    *R4,R7             HE SET CMD ONLY HANDLES TWO
         LB,D1    R6                TYPE VLP
         CI,D1    1                 NAME?
         BE       %+3
         LW,D4    R6
         B        EXPAND7
         LI,R5    7                 MOVE NAME-ACCOUNT-PASSWORD
         LI,R6    PFNAM
         BAL,SR4  EXPAND9
         LW,D4    *R4,R7            D4 = PASSWORD KEY WORD
         LI,R5    3
         BAL,SR4  EXPAND9
         LI,R1    X'10000'          CHECK FOR MORE VARIABLES
         LS,R1    D4
         BNEZ     EXPAND4           NO MORE
         LW,D4    *R4,R7            D4=EXPIR. OR INSN/OUTSN KEYWORD
         LB,D1    D4
         CI,D1    4                 IS IT EXPIR.
         BNE      EXPAND7           NO, MUST BE INSN
         LI,R6    PFEXP
         LI,R5    3                 YES
         BAL,SR4  EXPAND9           MOVE EXPIR.
         LI,R1    X'10000'          CHECK FOR MORE VARIABLES
         LS,R1    D4
         BNEZ     EXPAND4           NO MORE
         LW,D4    *R4,R7
         LB,D1    D4                CONTROL BYTE
EXPAND7  CI,D1    7                 IS IT SN?
         BNE      EXPANDRD          GO TRY RD ACCTS
         BAL,SR4  EXPSUB1
         LI,R6    PFOUT
EXPAND71 BAL,SR4  EXPAND9           MOVE ENTRIES.
         LI,R1    X'10000'
         LS,R1    D4                LAST VLP?
         BNEZ     EXPAND4           YES
         LW,D4    *R4,R7
         LB,D1    D4
EXPANDRD CI,D1    5                 RD ACCTS?
         BNE      EXPANDWR          NO
         BAL,SR4  EXPSUB1
         LI,R6    PFRD
         B        EXPAND71          GO MOVE 'EM
*
EXPANDWR CI,D1    6                 WRT ACCTS?
         BNE      EXPANDEX          NO
         BAL,SR4  EXPSUB1
         LI,R6    PFWRT
         B        EXPAND71
*
EXPANDEX CI,D1    X'14'             EXEC ACCTS?
         BNE      EXPANDUN          NO
         BAL,SR4  EXPSUB1
         LI,R6    PFEXU
         B        EXPAND71
*
EXPANDUN CI,D1    X'15'             UNDER VLP?
         BNE      EXPAND12          NO, THIS IS LAST SO ERROR.
         BAL,SR4  EXPSUB1
         LI,R6    PFUND
         BAL,SR4  EXPAND9
         B        EXPAND4
EXPAND8  LW,R1    *R4,R7            PICK UP DEVICE PRESENCE WORD
         LI,R5    1                 MOVE IT UP
         LI,R6    DPW
         BAL,SR4  EXPAND9
         LI,R2    1
EXPAND10 BAL,SR4  SHIFTY            DECODE PRESENCE WORD
         CI,R2    0                 TEST FOR COMPLETION
         BE       EXPAND5
         LB,R6    THINGS,R2
         BEZ      EXPAND12          ERROR IN FORMAT
         CI,R6    DTABS             TABS IS A UNIQUE CASE
         BE       EXPAND11
         LI,R5    1
         BAL,SR4  EXPAND9
         B        EXPAND10
EXPAND11 LI,R5    4
         B        EXPAND11-2
EXPAND12 LI,R1    BADPLT            PLIST IS BAD
         LI,R2    23
         CAL1,1   WRITE
         B        SYN1
EXPAND9  LI,D1    0
         XW,D1    *R4,R7            MOVE THE PARAMETER UP, CLEARING THE
         STW,D1   *R3,R6            OLD LOCATION
         AI,R7    1
         AI,R6    1
         BDR,R5   EXPAND9
         B        *SR4
*
EXPSUB1  LW,D3    D4                CW TO D3
         SLS,D3   16                SHFT TO # WDS IN USE
         LB,R5    D3                # TO MOVE
         AI,R5    1                 ADD IN CW TO COUNT
         B        *SR4              DO IT!
         PAGE
* THIS SUB-ROUTINE WILL DETERMINE THE VALUE OF A PRESENCE BIT AND RETURN
* ITS RELATIVE POSITION WITHIN A TEL SKELETAL PLIST. THIS IS DONE BY A
* REPETITIVE LEFT SHIFT AND COUNTING THE NUMBER OF SHIFTS REQUIRED TO
* BRING A ONE INTO POSITION ZERO OF THE WORD.
* THE INPUT PRESENCE IMAGE MUST BE IN R1.
* THE POSITION COUNT IS MAINTAINED IN R2, WHICH MUST BE INITIALIZED
* OUTSIDE OF THE SUB-ROUTINE. IF 0 IS RETURNED, NO BITS WERE PRESENT.
* THE SUB-ROUTINE WILL AUTO-MATICALLY RESET BIT ZERO AFTER SHIFTING SO
* THAT SUBSEQUENT CALLS WILL PROVIDE AN ACCUMULATIVE EFFECT.
* ENTER WITH BAL,SR4
*
SHIFTY   PUSH     R3
         LW,R3    R1                INITIAL TEST FOR BIT0
         BGZ      SHIFTY3
         BEZ      SHIFTY2
         LI,R2    1                 PARAMETER ONE INDICATED
SHIFTY1  AND,R1   NBIT0             RESET BIT 0
         PULL     R3
         B        *SR4
SHIFTY2  LI,R2    0                 NO BITS SET
         B        SHIFTY1+1
SHIFTY3  AI,R2    1
         SLS,R1   1
         BCS,4    SHIFTY1
         B        SHIFTY3
         PAGE
* THE FOLLOWING IS A SUB-ROUTINE USED TO DO THE GENERAL TASK OF TURNING
* OFF THE FILE EXTEND BITS AND TRUN ON THE DCB ASSIGNED BITS FOR A DCB,
* THE NAME OF WHICH APPEARS IN THE CONTROLLING A/M ENTRY. THESE BITS ARE
* INITIALLY SET IN THE TOP OF THE A/M TABLE AND ARE TRANSFERRED TO JIT
* WHEN THE A/M IS FINALLY WRITTEN TO RAD. ONLY SYSTEM DCB'S ARE OFFECTED
* BUT A BIT IS SET TO INDICATE A/M ENTRIES EXIST.
* ENTER WITH BAL,SR4 AND R4= A/M ENTRY IN QUESTION.
BITS     LW,R5    J:ABUF            GET A/M TABLE ADDRESS
         LCI      2                 GET DCB NAME
         LM,D1    1,R4
         SLD,D1   8                 REMOVE BYTE COUNT
         LI,R0    X'FD47A'          CHECK FOR SYSTEM DCB
         CH,R0    D1
         BNE      *SR4              NOPE
         OR,D1    L(X'FFFF0000')
         LI,R7    0                 LOOK FOR MATCH IN FILE EXTEND BITS
BITS1    CH,D1    FILEXTP,R7
         BE       BITS4             FOUND ONE
         AI,R7    1
         CI,R7    SIZFILXP-1
         BLE      BITS1
         B        *SR4
BITS4    LI,SR2   -2                RESET APPROPRIATE EXTEND BIT
         AI,R7    X'200'            ADD A CIRCULAR SHIFT TO COUNT
         S,SR2    *R7               POSITION BIT TO BE RESET I.E. LEFT
         AND,SR2  6,R5              FILE EXTEND IMAGE
         STW,SR2  6,R5
         LI,R7    0                 DOES DCB CORRESPOND TO A RECOGNIZ-
BITS5    CH,D1    RECOPT,R7         ABLE OPTION FOR PROCESSORS
         BE       *SR4
         AI,R7    1
         CI,R7    SIZRECO
         BLE      BITS5
         B        *SR4
         PAGE
* THE PMAKE ROUTINE FIRST TESTS AN A/M ENTRY FOR SPACE AND, IF IT WILL
* FIT, PLACES THE PRE-FORMED PARAMETER WORD AND FLAG INTO THE SKELETAL
* PLIST.
* ENTER WITH A BAL,SR4 WITH D1 = PARAMETER WORD IMAGE;
*        R5 = -1 INDICATES SPECIAL INSERTION TO A BIT ORIENTED WORD. THE
*        CONTENTS OF D2 MUST THEN CONTAIN A MASK FOR A STS OPERATION.
*        R7 = INDEX POSITION FROM TOP OF PLIST
*        R5 = POSITIONED PARAMETER PRESENCE BIT
*        R4 = ADDR OF SETBUF.
PENT     PUSH     R3
         LI,R3    SETBUFSZ          SZE OF EXPANDED AREA
         CW,R7    R3
         BGE      ASIZER            IT WON'T GO IN SKELETAL PLIST
         LW,3     1,4                                                RL2
         LB,3     3                                                  RL2
         AI,3     4+4                                                RL2
         SLS,3    -2                #WDS TO PLIST                    RL2
         AW,3     4                 PT TO PLIST                      RL2
         CI,R5    -1
         BE       PENT1
         STW,D1   *R3,R7
         STS,5    2,3               STORE PRESENTS BITS              RL2
         PULL     R3
         B        *SR4
PENT1    STS,D1   *R3,R7            D2 WILL CONTAIN MASK FOR BITS OF D1
         PULL     R3                TO BE STORED
         B        *SR4
         PAGE
* TRUNDLE ROUTINE WILL COMPACT THE PREFORMED PLIST, ELIMINATING ANY
* ZERO WORDS, RESULTING IN A CLOSED FORM USABLE BY THE MONITOR OPEN'
* LOGIC.
* ENTER WITH A BAL,SR4 WITH:
*        R4 = ABSOLUTE ADDRESS OF A/M ENTRY TO BE COMPACTED.
* THERE ARE NO ERROR RETURNS AND ALL REGISTERS ARE PRESERVED.
*  ENTRY POINT: 'TRUNDLE'...CALLED BY DOER IN SET LOGIC.
*
*
TRUNDLE  PUSH     5,R5              GET WORKING SPACE AND INDEXES
*                                   TRUNDLE                          RL2
         LI,R4    SETBUF
         LW,8     1,4                                                RL2
         LB,8     8                                                  RL2
         AI,8     4+4                                                RL2
         SLS,8    -2                                                 RL2
         LW,R7    8                 DCB WDS+CHN LINK WD
         AI,R7    3                 1ST 3 WDS OF PLIST
         STW,R7   SZCELL            KEEP TRCK OF LENG HERE
         AW,8     4                 PT  TO  PLIST                    RL2
         LW,7     8                                                  RL2
         LW,10    8                                                  RL2
         AI,10    DPW                                                RL2
*                                        COMPRESSING OF PARMS
         LI,R5    X'A000'           SET FIXED FLAGS IN 1ST PRESENCE WORD
         STS,R5   1,R7
         LI,R5    X'4000'           ARE THERE ANY VARIABLE PARAMS
         LS,R5    1,R7
         BEZ      TRUNDLE1          NO
         LI,R5    X'10000'          FLAG FOR LAST VLP
         LW,SR1   PFUND,R7          LOOKING FOR LAST VLP HERE
         BEZ      TRUNDLEF          NO PROCESSORS
         STS,R5   PFUND,R7
         B        TRUNZ             GO RESET ANY LAST VLP BITS
TRUNDLEF LW,SR1   PFEXU,R7
         BEZ      TRUNDLEE
         STS,R5   PFEXU,R7
         B        TRUNZ1
TRUNDLEE LW,SR1   PFWRT,R7
         BEZ      TRUNDLED
         STS,R5   PFWRT,R7
         B        TRUNZ2
TRUNDLED LW,SR1   PFRD,R7
         BEZ      TRUNDLEC
         STS,R5   PFRD,R7
         B        TRUNZ3
TRUNDLEC LW,SR1   PFOUT,R7
         BEZ      TRUNDLEA
         STS,R5   PFOUT,R7
         B        TRUNZ4
TRUNDLEA LW,SR1   PFEXP,R7          IS THERE AN EXPIR. DATE
         BEZ      TRUNDLEB          NO
         STS,R5   PFEXP,R7          YES, CONSIDER IT AS LAST VLP
         B        TRUNZ5
TRUNDLEB STS,R5   PFPAS,R7          CONSIDER PASS. AS LAST VLP
*                  TRUNDLE          *                                RL2
TRUNDLE1 RES      0                                                  RL2
         AI,7     3                 BYPASS  P BITS                   RL2
         LI,SR1   0                                                  RL2
         LI,SR2   SETBUFE
TRUNDLE2 LW,R5    0,R7              FIND A ZERO WORD
         BNEZ     TRUNDLE4
         LW,R6    R7
TRUNDLE3 AI,R6    1
         CW,R6    SR2               TEST FOR END OF ENTRY
         BE       TRUNDLE5          DONE
         LW,R5    0,R6
         BEZ      TRUNDLE3
         CW,6     10                                                 RL2
         BNE      TRUNA             NO
         LW,R5    0,R6              YES-ARE TABS SPECIFIED
         BCR,1    TRUNA             NO
         LI,R5    5                 YES-HANDLE UNIQUELY AS TAB WORDS CAN
TRUNB    XW,SR1   0,R6              LEGITIMITTILY CONTAIN ZEROS. THE
         XW,SR1   0,R7              TAB PARAMETER WILL ALWAYS HAVE FOUR
         AI,R6    1                 WORDS. WE MOVE THOSE PLUS THE
         AI,R7    1                 PRESENCE WORD TOGETHER AS ORIG.
         BDR,R5   TRUNB             CODED, TEERE WILL ALWAYS BE AT LEAST
         MTW,5    SZCELL            COUNT DPW&TABS WDS
         B        TRUNDLE4+2        1 ZRO WD FOUND BEFORE DPW+3
TRUNA    XW,SR1   0,R6              MOVE THE WORD UP, CLEARING THE OLD
         XW,SR1   0,R7              LOCATION IN THE PROCESS
TRUNDLE4 AI,R7    1
         MTW,1    SZCELL            COUNT THE WD
         CW,R7    SR2               CHECK FOR ENTRY LIMIT
         BL       TRUNDLE2
TRUNDLE5 PULL     5,R5
         B        *SR4
*
*
TRUNZ    LW,R5    =X'FFFEFFFF'      * CARE MUST BE TAKEN
         LS,R5    PFEXU,R7          * TO RESET ANY PREVIOUSLY
         STW,R5   PFEXU,R7          * SET LAST ENTRY INDICATORS
TRUNZ1   LW,R5    =X'FFFEFFFF'      * IN VLP CW'S OCCURRING
         LS,R5    PFWRT,R7          * EARLIER IN THE PLIST
         STW,R5   PFWRT,R7          *
TRUNZ2   LW,R5    =X'FFFEFFFF'      *
         LS,R5    PFRD,R7           *
         STW,R5   PFRD,R7           *
TRUNZ3   LW,R5    =X'FFFEFFFF'      *
         LS,R5    PFOUT,R7          *
         STW,R5   PFOUT,R7          *
TRUNZ4   LW,R5    =X'FFFEFFFF'      *
         LS,R5    PFEXP,R7          *
         STW,R5   PFEXP,R7          *
TRUNZ5   LW,R5    =X'FFFEFFFF'      * PASS IS LAST NECESS TO CHK
         LS,R5    PFPAS,R7          * IF PASS EXIST SO DO ACCT&NAME.
         STW,R5   PFPAS,R7          *
         B        TRUNDLE1
*
         PAGE
*                 ENTER ON SR4                                       RL2
ADJUST4  PUSH     R4                ADJUST FOR NAME                  RL2
         LW,4     1,4                                                RL2
         LB,4     4                                                  RL2
         AI,4     4+4                                                RL2
         SLS,4    -2                                                 RL2
         AW,4     *TELSTACK
         B        *SR4                                               RL2
         PAGE
* THIS SUB-ROUTINE WILL CREATE A 'STANDARD' SHORT FORM PLIST IN THE
* ASSIGN/MERGE TABLE. THE IMAGE USED IS THAT OF LOCATION 'PLIST'.
* THE ENTRY CREATED IS ALWAYS SPECIFIED AS AN OUT MODE ENTRY.
* ENTER WITH A BAL,SR4 WITH:
*        REG R5 = ASSIGN TABLE ENTRY
*        REGS D1,D2,D3 = FILE NAME
*        REGS SR2,SR3  = ACCOUNT
*        REGS R7,SR1   = PASSWORD
*
FILENT   PUSH     15,R1
         LW,2     1,5                                                RL2
         LB,2     2                                                  RL2
         AI,2     4+4                                                RL2
         SLS,2   -2                 PLIST                            RL2
         AI,2    -3                 ADJUSTMENT                       RL2
         AW,5     2                                                  RL2
         PUSH     R0
         LCI      5
         LM,R0    PLIST
         STM,R0   3,R5              THERE GO THE FIXED WORDS
         PULL     R0
         LW,R6    PPAS              MOVE PASSWORD
         CI,R7    0                 IS THERE REALLY A PASSWORD
         BE       FILT3
         AI,R6    X'200'            YES-TURN ON PARAMETER WORD
FILT2    EQU      %
         LCI      3
         STM,R6   PPAS-PLIST+3,R5
         LW,SR1   PACC              ACCOUNT PARAM
         LCI      3
         STM,SR1  PACC-PLIST+3,R5
         STW,R5   R1                MOVE ENTRY ADDRESS
         BAL,SR3  NFND              MAKE NAME TEXTC
         LW,R5    NAME              AND STORE IT
         LCI      4
         STM,R5   NAME-PLIST+3,R1
         LW,R4    J:ABUF
         LW,R7    0,R4
         AI,R7    PSIZE+3           SIZE THIS ENTRY
         STW,R7   0,R4              UPDATE FREE HEAD
         PULL     15,R1
         B        *SR4              RETURN
FILT3    LW,R7    VERB1             PAD SPACES(FOR TRUNDLE IN
         LW,SR1   VERB1             CASE OF UPDATE)
         B        FILT2
         PAGE
* THIS SUB-ROUTINE CREATES A 4 CHARACTER FILE NAME FOR % FILES. THE USER
* LINE NUMBER IS USED TO MAKE THE NAME UNIQUE. A TRAILING L OR R IS USED
* TO DIFFERENTIATE BETWEEN A ROM OR LMN FILE. THE 2 CHARACTER LINE
* ENTER ON BAL,SR4 WITH:
*        R5 = HEX L OR R RIGHT JUSTIFIED FOR DESIRED TYPE.
* EXIT WITH R5 CONTAINING COMPLETED NAME. R4 IS DESTROYED
*
NAME%    RES      0
         SLS,R5   8
         AI,R5    X'40'
         LW,R4    J:JIT
         STH,R4   R5
         B        *SR4
         PAGE
* THIS BIT OF LOGIC IS USED TO OBTAIN A COMPLEX FID PRIOR TO ENTERING
* THE NORMAL PROCESS FOR THE SI DCB. IF ACCOUNT HAS NOT BEEN SUPPLIED,
* IT IS OBTAINED FROM JIT. LMN IS CURRENTLY IN D1,D2, AND D3. RETURN
* ACCOUNT IN SR2,SR3 AND PASSWORD(OR ZEROS) IN R7,SR1.
*
FID      LI,R3    D1                GET NEXT SUB-FIELD
         PUSH     3,D1              SAVE LMN
         LB,R6    TELBUF,R2         FID.  THIS LOGIC
         CI,R6    ' '               IS FOR USE ON A LMN LOAD FROM
         BE       FID3              THE USER'S ACCOUNT
         LI,R6    0
         CW,D1    DOLL              INSURE NO DOLLAR FILE NAME
         BE       SYNTAX
         LD,D1    VERB2             BLANK FILL
         BAL,SR3  SCAN
         CI,R7    0                 WAS AN ACCOUNT GIVEN
         BE       FID3              NO
         PUSH     2,D1
FIDO     CI,R6    '.'               IS THERE A PASSWORD SUB-FIELD
         BE       FID4              YES
         LI,R7    0                 NO-PUT IN ZEROS
         LI,SR1   0
FID2     PULL     2,SR2             REGAIN ACCOUNT
         PULL     3,D1              REGAIN LMN
         B        *SR4              GO PROCESS THE RESULT
FID3     LCI      2                 GET ACCOUNT FROM JIT
         LM,SR2   J:JIT+JACCN
         PUSH     2,SR2
         B        FIDO
FID4     PUSH     3,D1
         LI,R3    D1
         LD,D1    VERB2
         BAL,SR3  SCAN
         STW,D1   R7
         STW,D2   SR1
         PULL     3,D1
         B        FID2
         PAGE
* THIS ROUTIN BLANKS THE SSPECIFIED BUFFER
*  R2 - BYTE COUNT
*  R1 - BUFFER ADDRESS
*
BLANKBUF EQU      %
         SLS,R1   2
         STB,R2   R1
         LI,R0    ' '
         MBS,0    3
         B        *R4
*
*
*  SHIFT COMMAND RIGHT TO CONTSTRUCT LONG FORM COMMANDS FROM SHORT FORM.
*
*  R1 - # OF REMAINING CHARS IN INPUT REQUEST, I.E. # TO MOVE
* R7 - # OF CHARACTERS IN COMMAND, DETERMINES # TO MOVE
*
SHFTBUF  EQU      %
         LI,SR3   8                 COMPUTE # OF POSITIONS TO
         SW,SR3   R2                SHIFT TO ALLOW 2 WORD CMND
         BLEZ     *SR4              EXIT IF NONE TO SHIFT
         LW,R3    R1                R3 IS SOURCE BYTE POINTER
         LW,R4    R3
         AW,R4    R2                COMPUTE SOURCE BYTE POINTER
         CI,R3    1                 CHECK IF 1 CHAR COMND
         BLE      %+2               MOVE TERMINATOR
         AI,R4    -1
         LW,R6    R4
         AW,R6    SR3               R6 IS DESTINATION BYTE POINTER
         SLS,SR3  24                SR3 IS ALSO THE ADDITIONAL SIZE
         AWM,SR3  J:JIT+JPUF        OF THE INPUT REQUEST
SHFT10   EQU      %
         LB,D1    TELBUF,R4         MOVE IT
         STB,D1   TELBUF,R6
         BDR,R3   SHFT20
         B        *SR4
SHFT20   BDR,R6   SHFT30
SHFT30   BDR,R4   SHFT10
*
         PAGE
*
* THIS ROUTINE DELETES ANY INPUT SYMBIONT FILES IN THE SYMBIONT TABLES
* WITH THE SPECIFIED SYSID.  IF THE SYSID REFERS TO A RUNNING BATCH JOB
* THE JOB IS ABORTED(IF THE CURRENT USERS ACCOUNT = THE ACCOUNT OF
* THE SPECIFIED JOB).
*
CANCEL   EQU      %
         LI,D1    0                 0 SYSID BUFFER
         LI,D2    0
         LI,R3    D1
         BAL,SR3  SCAN              GET SYSID
         CI,R7    4                 SYSID MUST BE < 5 CHARS
         BG       SYNTAX
         BAL,R1   HEX2BIN           CONVERT TO BINARY
         BLZ      SYNTAX            B IF ERROR
         LW,R1    =X'00200000'
         CW,R1    M:XX
         BAZ      %+5
         LI,R1    BKMSG
         LI,R2    5
         CAL1,1   WRITE
         B        PROMPT
         CAL1,1   CANCL             DELETE IT
         LI,R0    X'40'             SUPPLY TRAILING BLANKS
         B        CNCL10
         STB,R0   D1,R7             IN SPECIFIED ID
         AI,R7    1
CNCL10   CI,R7    4                 DONE
         BL       %-3               B IF NO
         LW,R1    TELSTACK          MAKE ROOM IN THE STACK...
         AI,R1    1                 FOR OP MESSAGE TEXT
         BUMP     5,R2
         LCI      5
         LM,R2    CNCLMSG           GET MESSAGE
         STM,R2   0,R1              INTO STACK
         STW,D1   1,R1              ID INTO MESSAGE
         CAL1,2   SENDCNCL
         BUMP     -5,R2
         B        PROMPT
*
CNCL20   EQU      %                 ABNORMAL ON DELETE
         LI,R2    1
         LB,R2    SR3,R2            GET SUBCODE
         SLS,R2   -1
         CI,R2    X'39'             IS IT THAT THE ID DOESNT EXIST
         BNE      CNCL30            B IF NO
         LI,R1    WRNGACCT
         LI,R2    13
         CAL1,1   WRITE             TELL HIM IT DOESNT EXIST
         B        PROMPT
CNCL30   EQU      %
         CI,R2    X'3A'             IS IT TOO LATE
         BNE      GIVEMEH           GIVE HIM EH
         LI,R1    LATEMSG
         LI,R2    22
         CAL1,1   WRITE             TELL HIM ITS TOO LATE
         B        PROMPT
*
CANCL    EQU      %
         GEN,8,24 X'2F',M:XX
         GEN,8,24 X'88',0
         DATA     CNCL20            ABN
         PZE      *SR1
*
SENDCNCL EQU      %
         DATA     0
         PZE      *0
         PZE      *R1
*
CNCLMSG  TEXTC    'ID      CANCELED'
LATEMSG  TEXT     'COMPLETED OR NOT INPUT'
WRNGACCT TEXT     'NOT YOUR FILE'
         PAGE
*        R2       =FROM
*        R3       =TO
TELCCBUF RES      0
         LI,R2    TELBUF            FROM
         LI,R3    J:CCBUF           TO
BUFCOM   SLD,R2   2
         LB,R4    J:JIT+JPUF
         CI,R4    80                MAX CHARS
         BLE      %+2               O.K.
         B        MOVEERR           ERROR
         STB,R4   R3
         MBS,R2   0
         B        *0
CCBUFTEL LI,R3    TELBUF            TO
         LI,R2    J:CCBUF
         B        BUFCOM
         SPACE    5
*
* THIS ROUTINE CHECKS TO SEE IF WE HAVE SPECIAL BUFFER 1
* AND RELEASES IT IF WE DO.
*    USES R4,R5,SR2
*    LINK ON D4
FREEBUF1 EQU      %
         STW,SR1  R4                SAVE SR1 FROM T:FVP
         LI,R5    JSBUF1VP          PAGE NUMBER OF SP. BUFR 1
         LI,SR2   FPMC
         COMPARE,SR2  JX:CMAP,R5    DO WE HAVE THE BUFFER?
         BE       FRBFXT            NO, RETURN
         LI,SR2   TELSTACK          YES,
         CAL1,8   FPFPT             LOSE IT
FRBFXT   LW,SR1   R4                RESTORE SR1 AND
         B        *D4               RETURN
         PAGE
*USED BY ON-LINE DEBUGG VERSION OF TEL
*
*
         DO       A=2
J:CCBUF  RES      20
J:ABUF   PZE      MERTAB                                             RL2
J:ASGT   EQU      %
*     ASSIGN/MERGE TABLE IMAGE
MERTAB   GEN,32   22
         DO       511
         DATA     0
         LIST     0
         FIN
         LIST     1
J:JIT    DATA     X'22'             SYSID
JIT      EQU     J:JIT
         DATA     C'C730'
         DATA     C'8314'
         DATA     C'SHI0'
         DATA     C'8493'
         DATA     C'3241'
         DO       17
         GEN,32   0
         FIN
         BOUND      8
J:ADCBTL DATA     %+3
         TEXTC    'M:EO'
         DATA     M:EO
         DATA     LLINK
         RES      2
LLINK    DATA     %+3
         TEXTC    'M:EI'
         DATA     M:EI
         DATA     LLLINK
         RES      3
LLLINK   DATA     %+3
         TEXTC    'M:XX'
         DATA     M:XX
DCBLINK  EQU      %-JIT
J:DCBLINK  RES    0
J:CLM    DATA     0,0,0,0,0,0,0
J:CPOCS  DATA     0
J:CPPO   DATA     0
TSTACK   EQU      UTS
         DATA     0
JBUP     EQU      %-JIT
J:BUP    DATA     26
JEUP     EQU      %-JIT
J:EUP    DATA     119
JPLL     EQU      %-JIT
J:PLL    DATA     40
JPUL     EQU      %-JIT
J:PUL    DATA     41
JDLL     EQU      %-JIT
J:DLL    DATA     26
JDUL     EQU      %-JIT
J:DUL    DATA     27
JDDLL    EQU      %-JIT
J:DDLL   DATA     28
JDDUL    EQU      %-JIT
J:DDUL   DATA     39
JCLL     EQU      %-JIT
J:CLL    DATA     18
JCUL     EQU      %-JIT
J:CUL    DATA     25
JBVLH    EQU      %-JIT
JB:VLH   DATA,1   41,0,0,0
JBPPT    EQU      %-JIT
JCMAP    EQU      %-JIT
         BOUND    8
JB:LMAP  DATA     0                 0
         DATA     0                 4
         DATA     0                 8
         DATA     0                 12
         DATA,1   0,0,0,0           16
         DATA,1   0,0,0,0           20
         DATA,1   00,00,22,26       24    CONTEXT
         DATA,1   27,28,29,0        28    4 DD
         DATA,1   0,0,0,0           32
          DATA,1   0,0,0,0          36
          DATA,1  30,40,0,0         40  2 PP
         DATA,1   0,0,0,0           44
J:CFLGS  DATA      0
JBPCP    EQU       BA(%)-BA(JIT)
JB:PCP   DATA,1   2
JBPCD    EQU       BA(%)-BA(JIT)
JB:PCD   DATA,1   2
JBPCDD   EQU       BA(%)-BA(JIT)
JB:PCDD  DATA,1   4
JBPCC    EQU       BA(%)-BA(JIT)
JB:PCC   DATA,1   1
JJITVP   EQU       18
JBLMAP   EQU      %-JIT
         RES      20                FOR JX:CMAP (MAY NOT BE NEEDED)
J:FPOOL  GEN,32   J:ASGT
J:LMN    GEN,64   0
         GEN,32   0
         DEF      TELINIT
J:INTENT DATA     68
INTENT   EQU      J:INTENT-JIT
J:USENT  DATA     67
         DATA     44
         DATA     33
JB:LPP   DATA,1   0
ERO      EQU      %-JIT
         DATA     0                 DUMMY ERO
JB:FRS   EQU      BA(JBFRS)
JBFRS    DATA     0
J:EXLY   DATA     0
JH:PC    DATA     0
J:START  DATA     0
JB:PROMPT DATA    0
PRDCRM   DATA     10                10 DUMMY RAD GRANULES
PRDPRM   DATA     100               100 DUMMY PACK GRANULES
TELINIT  CAL1,1   TFILE             WRITE THE ASSIGN/MERGE TABLE
         LI,R1    8
         STW,R1   OPENXX+4
         CAL1,1   OPENXX
         LI,R4    M:XX
         LI,R7    J:ASGT
         CAL1,1   WAMR
         CAL1,1   SHUTDCB
         LI,R1    1
         STW,R1    OPENXX+4
         B        TEL
TFILE    GEN,8,24 X'0F',M:XX
         GEN,8,24 X'18',X'50'
         GEN,32   0
         GEN,32   TELTEMP
TELTEMP  TEXTC    'TELTEMP'
OPENXX   GEN,8,24 X'14',M:XX
         GEN,8,4,20  X'31',4,1
         GEN,32   J:ASGT
         GEN,32   4*512
         GEN,32   8
         GEN,32   2
         GEN,8,8,8,8   1,0,2,2
         TEXTC    'TELTEMP'
         GEN,8,8,8,8   3,1,0,2
         DATA     0,0
* FOLLOWING FPT USED IN DEBUG MODE ONLY
CLEARXX  GEN,8,24    6,M:XX
         GEN,2,30    3,0
         DATA     0,0
         BOUND    8
UTS      GEN,15,17,16,16 0,UTSA,254,0
UTSA     RES      510
J:IPOOL  DATA     0
         FIN
         PAGE
         CLOSE    TYPE,DONE
         OPEN     TYPE,DONE
*
*        THE ROUTINE STATUS PRINTS OUT THE FOLLOWING LINE ON
*        THE USERS TERMINAL WHEN THE CALL   !STATUS    IS RECEIVED
*        FROM THE USER:
*                 CPU = M.MMMM CON = H:MM  INT = NN  CHG = XXXX
*        WHICH IS :
*            1.   CPU TIME IN MINUTES
*            2.   CONSOLE TIME IN HOURS AND MONUTES
*            3.   NUMBER OF INTERACTIONS
*            4.   TOTAL CHARGE UNITS
*        CONTENTS OF ALL REGESTERS CAN BE ASSUMED TO BE DESTROYED BY
*        THIS ROUTINE.
*
STATUSL  RES      0          CREATE STATUS LINE OUTPUT
         PSW,R2   TELSTACK          SAVE RETURN ADDRESS
* COMPUTE ELAPSED TIME
*
         LW,R1    TELSTACK          GET BUFFER ADDRESS FOR OUTPUT
         AI,R1    6                 MESSAGE
         LCI      14
         LM,R2    TEXTJUNK          MOVE OUTPUT TEXT TO
         STM,R2   0,R1              BUILD BUFFER
         LW,SR1   R1
         AI,R1    -4                SET INDEX TO HANDLE 4 WORDS FOR
*                                   TIME CAL
         DO1      FORSEC
         PSW,SR1  TELSTACK          SR1 DESTRYED BY M:TIME
         CAL1,8   TIMER
         DO1      FORSEC
         PLW,SR1  TELSTACK          RESTORE SR1
         BAL,SR4  TIMEVERT          CONVERT TIME TO BIN MIN FROM 12:00
         BAL,SR4  READAM            NOW D3 HAS MIN. FROM MIDN. IN BIN.
         LW,R1    J:ABUF            GET J:TIME FROM A/M TABLE
         LW,D3    12,R1
         CW,D2    D3                COMPARE LOGON TIME WITH LOGOFF TIME
         BGE      %+2               IS LOGOFF TIME LESS THAN LOGON TIME
         DO       FORSEC
1DAY     EQU      1440*60
         ELSE
1DAY     EQU      1440
         FIN
         AI,D2    1DAY              FOR CROSSING MIDNIGHT
         SW,D2    D3                SUBTRACT LOGON TIME FROM LOGOFF TIME
         DO       FORSEC=0
         PSW,D2   TELSTACK          SAVE MINUTES
         LI,D1    0                 SETUP D1 FOR DIVIDE INSTRUCTION.
         DW,D1   =60                GET TIME IN HRS AND MINUTES.
         STW,D1   SR2               SAVE MINUTES
         LW,D1    D2                CONVERT HOURS TO EBCDIC
         BAL,SR4  BINDCB
         LW,D1    SR2               GET MINUTES
         STW,D2   SR2               SAVE HOURS
         BAL,SR4  BINDCB            CONVERT MINUTES TO EBCDIC
         LI,D1    ' :'
         STH,D1   D2                D2 = ' :MM'
         LW,D1    SR2               GET HOURS AGAIN (IN EBCDIC)
         BAL,SR4  ZEROBK            CONVERT LEADING ZEROS TO BLANKS
         SCS,D2   8                 D2 = ':MM '
         SCD,D1   -8                D1,D2 = '   H','H:MM'
         ELSE
         LW,R7    SR1
         LI,D1    0
         DW,D1    =60               D1:=BIN SECS; D2:=BIN TOT MINS
         PSW,D2   TELSTACK          BIN TOT MINS ARE SAVED
         STW,D2   7,R7              TEMP SAVE OF BIN TOT MINS
         BAL,SR4  BINDCB            D2:=EBC SECS
         XW,D2    7,R7              D2:=BIN TOT MINS; SAVE EBC SECS
         LI,D1    0
         DW,D1    =60               D1:=BIN MINS; D2:=BIN HRS
         STW,D2   R6                R6:=BIN HRS
         BAL,SR4  BINDCB            D2:=EBC MINS
         LI,D1    ':'               ':' TO PRECEDE MM IN BUFFER
         SLS,D2   16                SHIFT EBC MINS NEXT TO ':'
         LI,R2    3                 COUNT FOR MBS
         LW,R3    R7                R3:=WA(DEST)
         SLS,R3   +2                R3:=BA(DEST)-6*4+2
         AI,R3    6*4+2             R3:=BA(DEST)
         STB,R2   R3                SET COUNT IN RU1
         LI,2     51                R2:=BA(SOURCE) (BYTE 3 OF D1)
         MBS,2    0                 :MM INTO BUFFER...
         LW,D1    R6                RESTORE BIN HRS
         BAL,SR4  BINDCB            D2:=EBC HRS
         SLS,R7   +1                R7 NOW HALF WORD ADDR
         STH,D2   6,R7              HH INTO BUFFER
         SLS,R7   -1                R7 WORD ADDR AGIAN
         LI,R1    7*4+1
         LI,D1    ':'
         STB,D1   *R7,R1            SS INTO BUFFER
         LW,D1    6,R7
         LW,D2    7,R7
         FIN
         LW,R7    SR1
         STW,D1   6,R7              PUT MINS + HRS TIME IN MESSAGE  BUFF
         STW,D2   7,R7              IN LOGON TO BE PRINTED OUT LATER
*
* COMPUTE CHARGE UNITS
*
OPENIT   RES      0
         LW,R6    TELSTACK          GET BUFFER TO READ RATE FILE
         AI,R6       78
         CAL1,1   ORATE             OPEN RATE FILE
         CAL1,1   RRATE             READ IT
         CAL1,1   CRATE             CLOSE IT
         LW,R1    J:ABUF            CHECK IF THERE IS ANYTHING IN J:RAT
         LI,D1    X'70000'
         AND,D1   13,R1
         SLS,D1   -16
         BNEZ     %+2               IF J:RATE = 0, SET DEFAULTS
         AI,D1    1                 IF NOT, DEFAULT TO TABLE 1
         AW,R6    *D1,R6            SET UP POINTER IN RATE FILE
* TOTAL CPU TIME
         LW,D2    J:UTIME           TOTAL USER EXECUTE TIME
         AW,D2    J:UTIME+1         TOTAL USER OVERHEAD TIME
         AW,D2    J:PTIME           TOTAL PROCESSOR EXECUTION TIME
         AW,D2    J:PTIME+1         TOTAL PROCESSOR OVERHEAD TIME
         MW,D2    0,R6              MULT  TOTAL IN D2 BY CPU TIME RATE
         LW,D1    D2                PUT RESULT INTO D2
* CORE-TIME
         LW,D2    JIT+TUIOT         USER CORE-TIME FACTOR
         AW,D2    JIT+TPIOT         PROCESSOR CORE-TIME FACTOR
         MW,D2    1,R6              MULTIPLY CORE SIZE  TIMES CPU TIME
         AW,D1    D2                ADD RESULT TO TOTAL
* TERMINAL INTERACTIONS
         LI,D2    X'1FFFF'          LOAD MASK
         AND,D2   J:INTER           GET NUMBER OF CONSOLE INTERACTIONS
         MW,D2    2,R6              MULTIPLY NO. INTERA. BY TERM INT.RTE
         AW,D1    D2                ADD RESULT TO TOTAL
* I/O CALS
         LW,D2    J:CALCNT          GET NUMBER OF I/O CALS
         MW,D2    3,R6              MULTIPLY
         AW,D1    D2                ADD RESULT TO TOTAL
* ELAPSED TIME
         PLW,D2   TELSTACK          LOAD ELAPSED TIME
         MW,D2    4,R6              MULTIPLY
         AW,D1    D2                ADD RESULT TO THE TOTAL
* TAPES
Z        EQU      0
Z4       EQU      0
         REF,1    JB:TMTS,JB:PMTS
         LI,D2    0
         LI,R5    JB:TMTS+Z4
         LB,R0    0,R5              TAPES MOUNTED
         AW,D2    R0
         LI,R5    JB:PMTS+Z4
         LB,R0    0,R5              PACKS MOUNTED
         AW,D2    R0
         MW,D2    5,R6              MULTIPLY
         AW,D1    D2                ADD RESULT TO TOTAL
         LW,R0    CIC+JIT           GET CARD INPUT COUNT
         SLS,R0  -17                SHIFT TO RIGHT-JUSTIFY THE COUNT
         LW,D2    CPO+JIT           GET CARD PUNCH OUT COUNT
         SLS,D2  -17                SHIFT TO RIGHT-JUSTIFY THE COUNT
         AW,D2    R0                ADD CD INPUT COUNT TO PUNCHOUT COUNT
         LW,R0    CPPO+JIT          GET CURRENT PROCESSOR PAGESOUT COUNT
         SLS,R0  -17                SHIFT TO RIGHT-JUSTIFY THE COUNT
         AW,D2    R0                ADD CURRENT PROCESSOR PGS OUT TO TOT
         LW,R0    CUPO+JIT          GET CURRENT USER PAGES OUT COUNT
         SLS,R0  -17                SHIFT TO RIGHT-JUSTIFY THE COUNT
         AW,D2    R0                ADD RESULT TO TOTAL
         LW,R0    CDPO+JIT          GET CURR DIAGNOSTIC PAGES OUT COUNT
         SLS,R0  -17                SHIFT TO RIGHT-JUSTIFY THE COUNT
         AW,D2    R0                ADD COUNT TO TOTAL
         MW,D2    7,R6              MULT. TOTAL X PERIPHERAL TO CDS+ PGS
         AW,D1    D2                ADD RESULT TO FIRST TOTAL IN D1
CHARGES  BAL,SR4  BINDCB            CONVERT CHG UNITS TO EBCDIC
         BAL,SR4  ZEROBK            CONVERT LEADING ZEROS TO BLANKS
         LW,R7    SR1
         STW,D1   13,R7             PUT CHRG UNITS IN MSGE BUFFER IN
         STW,D2   14,R7             LOGON-PRINT OUT LATER FOR ON LINE.
*
*        GET TOTAL CPU TIME
*
         LW,D1    J:UTIME           GET TOT USER EXECU TIME FOR CURR.JOB
         AW,D1    J:UTIME+1         ADD TOT USER EXECU TIME TO TOTAL
         AW,D1    J:PTIME           ADD TOT PROCESS EXEC TIME TO TOT
         AW,D1    J:PTIME+1         ADD PROCESSOR OH TIME TO OTHER TOTAL
         DH,D1    =X'00030000'      CONVERTS TICS TO MINUTES
         BAL,SR4  BINDCB            CONVERT TIME TO EBCDIC
         SLS,D1   8
         AI,D1    '.'
         BAL,SR4  ZEROBK            CONVERT LEADING ZEROS TO BLANKS
         LW,R7    SR1
         LCI      2                 MOVE TO MESSAGE AREA
         STM,D1   2,R7
*
*        GET CONSOLE INTERACTIONS
*
         LI,D1    X'1FFFF'
         AND,D1   J:INTER           STRIP OFF 1ST-1/2 WD-NO. INTERACTION
         BAL,SR4  BINDCB            CONVERT THE NUMBER TO BCD
         BAL,SR4  ZEROBK            CONVERT LEADING ZEROS TO BLANKS
         LW,R7    SR1
         STW,D2   10,R7             PUT NO. INTERACT. IN ON-LINE MSGE
*
*        FORMAT MESSAGE FOR OUTPUT
*
         LW,R4    TELSTACK          GET ADDRESS OF OUTPUT BUFFER
         AI,R4    78
         LW,R5    SR1               GET ADDRESS OF TEXT TO BE OUTPUT
         LI,R3    60                LOAD MESSAGE SIZE
         LI,R1    0                 LOAD POINTER TO PROCURING AREA
         LI,R2    0                 LOAD POINTER TO STORAGE AREA
         B        HXX
HXXL     CI,D1    ' '
         BE       HXXB
HXX      LB,D1    *R5,R1            PICKUP TEXT BYTE
HXXC     STB,D1   *R4,R2            STORE INTO BUFFER OUTPUT AREA
         AI,R2    1                 COUNT
HXXU     AI,R1    1
         BDR,R3   HXXL
         CAL1,1   TYPE
         B        DONE              FINISHED WITH ROUTINE
HXXB     RES      0                 NEXT
         LB,D1    *R5,R1
         CI,D1    ' '
         BNE      HXXC              NO
         B        HXXU              YES
DONE     RES      0                 DONE WHEN WE GET HERE
*
*********END OF ROUTINE**********
*
         PLW,R2   TELSTACK
         B        *R2               RETURN
         PAGE
TRUNKBF  RES      0
         LI,R1    0
         LB,R7    J:JIT+JRNST       SAVE RUN STATUS
         STB,R1   J:JIT+JRNST       CLEAR
         BAL,SR4  TRUNK             MAKE BUFFER AVAILABLE
         STB,R7   J:JIT+JRNST
         B        *SR2
         PAGE
* THE TIMEVERT SUB-ROUTINE PULLS THE HOUR/MINUTE TIME FROM TIMBUF AND
* CONVERTS IT INTO A BINARY, MINUTES FROM MIDNIGHT REPRESENTATION, AND
* STORES THE RESULT IN JIT.
* ENTER WITH BAL,SR4. TIMBUF MUST HAVE HAD A M:TIME DONE INTO IT.
*
*        IF SECFLAG SET, SR2 MUST CONTAIN DATA FROM M:TIME
TIMEVERT RES      0
         DO       FORSEC=0
         LW,D1     *R1
         LI,R3       12
         LI,R2    2
         BAL,SR3    DECBIN10
         STW,R4   R3                MICKEY MOUSE FOR MI INSTRUCTION
         MI,R3    60                CONVERT HOURS TO MINUTES
         PSW,R3   TELSTACK          SAVE RESULTS
         LW,D1    *R1               AND GET MINUTES VALUE
         AI,R1    1
         LW,D2    *R1
         SLD,D1   24
         LI,R3    12
         LI,R2    2
         BAL,SR3    DECBIN10
         PLW,D2   TELSTACK
         AW,D2    R4                CURRENT TIME  TO D2
         B        *SR4
         ELSE
         LB,R3    SR2               GET HRS
         MI,R3    60*60             HRS -> SECS
         STW,R3   D2                ACCRUE IN D2
         SLS,SR2  8                 SHIFY IN MINS
         LB,R3    SR2
         MI,R3    60                GET MINS -> SECS
         AW,D2    R3                ACCRUE
         SLS,SR2  8                 SHIFT IN SECS
         LB,R3    SR2               GET SECS
         AW,D2    R3
         B        *SR4              RETURN
         FIN
*
*        CHANGE   LEAD  ZEROS  INTO  BLANKS
*        D1-D2   = DCB   ALSO  ANSWER
*        D4,R1    USED
*
ZEROBK   LI,R1   -8                 CHARACTER COUNT AND BYTE POINTER
ZEROBK1  LB,D4    D1+2,R1           GET NEXT CHARACTER FROM LEFT
         CI,D4    '0'               IS IT A ZERO
         BNE      *SR4              IF NOT, EXIT
         LI,D4    ' '               IF IT IS, SUBSTITUTE A SPACE
         STB,D4   D1+2,R1
         CI,R1    -2                DON'T CONVERT LAST ZERO
         BE       *SR4
         BIR,R1   ZEROBK1
         B        *SR4
         PAGE
*
* PLIST TO OBTAIN DATE/TIME
*
TIMER    GEN,8,1,23  X'90',FORSEC,R1
*
*        COME HERE ON OPEN OR READ ERROR OF RATE FILE
*
M1RATER  CAL1,1   CRATE             CLOSE IT UP
RATEERR  RES      0
         SLD,D1   -64               ZERO CHARGE UNITS DESTINATION
         PLW,SR1  TELSTACK
         LW,SR1   TELSTACK          CALCULATE ADDRESS OF
         AI,SR1    6                 TEST AREA
         B        CHARGES           CONTINUE PROCESSING
         PAGE
*
*        RATE FILE PARAMETER LISTS
*
ORATE    RES      0
         GEN,8,24 X'14',M:XX        OPEN RATE FILE
         DATA     X'CF400009'       P1,P2,P5,P6,P7,P8,P10,F9,F12
         DATA     RATEERR           ERROR RETURN ADDRESS
         DATA     RATEERR           ABNORMAL RETURN ADDRESS
         DATA     10                RECOVERY TRIES
         DATA     1                 CONSECUTIVE
         DATA     1                 SEQUENTIAL ACCESS
         DATA     1                 INPUT MODE
         DATA     2                 SAVE
         DATA     X'01000202'       FILE NAME
         TEXTC    ':RATE'
         DATA     X'02010202'       ACCOUNT
         TEXT     ':SYS    '
*
*        WAIT ONE SECOND
*
WAIT1    GEN,8,24 X'F',1            WAIT CAL PLIST
*
*        READ RATE FILE
*
RRATE    RES      0
         GEN,8,24 X'10',M:XX        READ RATE FILE
         DATA     X'F4000000'       P1,P2,P3,P4,P6
         DATA     M1RATER           ERROR AD
         DATA     M1RATER           ABN AD
         GEN,1,31   1,R6            BUFFER AREA
         DATA     288               MAXIMUM SIZE
         DATA     0                 BYTE DISPLACEMENT
*
*        CLOSE RATE FILE
*
CRATE    RES      0
         GEN,8,24 X'15',M:XX        CLOSE RATE FILE
         DATA     0
*
*        TYPE ON USER'S TERMINAL
*
TYPE     GEN,8,24 X'11',M:UC        WRITE TO USER'S TERMINAL
         DATA     X'30000000'       P3,P4
         GEN,1,31   1,R4            BUFFER MESSAGE
         GEN,1,31 1,R2              BUFFER SIZE IN R2
         PAGE
*        CONVERTS EBCDIC STRING TO BINARY
*        R2 V NO. OF CHARACTERS
*        R3 = WORD ADDRESS OF 1ST CHARACTER
*        R4 = RESULT
*        ENTER WITH BAL ON SR3
*        CCI IS SET IF AYN ERRORS OCCURERS
*
DECBIN10 RES      0
         LI,R4    0
         LI,R5    0
DECBIN11 RES      0
         LB,R6    *R3,R4
         AI,R6    -X'F0'            REMOVE LEADING 'F'
         MI,R5    10                MULTIPLY BY 10
         BCS,4    DECBIN21          CHK FOR ILLEGAL RESULTS
         AW,R5    R6
         AI,R4    1
         BDR,R2   DECBIN11
         STW,R5   R4
         LCI      0                 SET CCI = 0 FOR GOOD RESULT
         B        *SR3              EXIT
DECBIN21 RES      0
         LCI      8                 SET CCU = 1 FOR BAD RESULT
         B        *SR3
         PAGE
TEXTJUNK RES      0
CPU      DATA,1   X'15'             MESSAGE AREA
         DATA,3   'CPU'
         TEXT     ' =  '
CPUV     TEXT     '    '            FILLED
         TEXT     '    '            FILLED
         TEXT     '  CO'
         TEXT     'N=  '
CONV     TEXT     '    '            FILLED
         TEXT     '    '            FILLED
         TEXT     ' INT'
         TEXT     ' =  '
INTV     TEXT     '    '            FILLED
         TEXT     ' CHG'
         TEXT     ' =  '
CHGV     TEXT     '    '            FILLED
         TEXT     '    '            FILLED
         DATA     0                 END OF MESSAGE
         END      TEL

