         PCC      0
         TITLE    ' '
         SPACE
         SYSTEM   BPM
         SYSTEM   SIG7
*
*  THIS PROGRAM INTERPRETS A USER'S LDEV  COMMAND AND
*  BUILDS A CORRESPONDING FPT AND ISSUES A CAL SO THAT
*  THE SPECIFIED LDEV  CONTEXT BLOCK MAY BE ALTERED.
         SPACE
*  ALL THE LANGUAGE ELEMENTS, DEFAULTS, LIMITS, AND FPT
*  SPECIFICATION ARE CONTAINED IN FIVE PARALLEL TABLES
*  INDEXED BY THE KEYWORD-INDEX, KWX.
         SPACE    2
*  DECEMBER 1972, RICK SINATRA
         SPACE    3
*        REGISTER ASSIGNMENT
X0       EQU      0
X1       EQU      1
X2       EQU      2
X3       EQU      3
         SPACE
IDX      EQU      4
X5,KWX   EQU      5
X6,IP    EQU      6
X7,X     EQU      7
R,R0     EQU      8
R1       EQU      9
R2       EQU      10
R3       EQU      11
R4       EQU      12
R5       EQU      13
R6       EQU      14
         SPACE
         SPACE
*        EXTERNAL REFERENCES
         SPACE
         REF      J:CCBUF,J:PUF,J:JIT,M:C
         REF      M:EI,JB:PRIV,JRBID
         REF      J:DWSK            HOLDS WSN
         REF,1    JB:BCP
         DEF      ALT,START,PATCH,NORMAL,KEYREAD
         REF      JDDUL
         TITLE    'PROC SECTION'
         SPACE
EXITC    CNAME
         PROC
EX%R     EQU      AF(1)
         BOUND    8
EX%D     DATA     EX%B
         GEN,1,15,1,15  0,AF(2),0,0
EX%D2    GEN,1,15,1,15  0,AF(2),0,0 TO RESET
EX%B     RES      AF(2)
         PEND
         SPACE
CALL     CNAME
         PROC
LF       BAL,EX%R AF
         PEND
         SPACE
ENTER    CNAME
         PROC
LF       PSW,EX%R EX%D
         PEND
         SPACE
RETURN   CNAME
         PROC
LF       PLW,EX%R EX%D
         LIST     0
         DO       AF(1)>1
         AI,EX%R  AF(1)-1
         FIN
         B        *EX%R
         LIST     1
         PEND
         PAGE
         SPACE
*        PROC FOR RESETTING EXIT CONTROL
         SPACE
EXITCR   CNAME
         PROC
         LIST     0
LF       LI,AF    EX%B
         STW,AF   EX%D
         LW,AF    EX%D2
         STW,AF   EX%D+1
         LIST     1
         PEND
         SPACE    2
STEP     CNAME
         PROC
         LIST     0
LF       AI,AF(1) AF(2)
         CW,AF(1) AF(3)
         BG       AF(4)
         LIST     1
         PEND
         SPACE
         SPACE
SECT1    EQU      %
         DEF      SECT1
         EXITC    15,5              EXIT CONTROL SPEC.
         SPACE    2
BYTES    COM,8,8,8,8 AF(1),AF(2),AF(3),AF(4)
         PAGE
         SPACE
*        SYNTAX SCANNING PROCEDURE
         SPACE
SCAN     CNAME    1                 FORWARD SCAN
SCANR    CNAME    0                 REVERSE
         PROC
         LIST     0
         DO       NAME
LF       AI,IP    1                 FORWARD
         CW,IP    CEND
         BG       CF(2)
         ELSE
LF       AI,IP    -1                REVERSE
         BLZ      CF(2)
         FIN
         LB,R     *BASE,IP
I        DO       NUM(AF)
         CW,R     SCANL+AF(I,1)
         DO       AFA(I,1)
         BNE      AF(I,2)
         ELSE
         BE       AF(I,2)
         FIN
         FIN
         B        LF
         LIST     1
         PEND
         PAGE
         TITLE    'DATA SECTION'
         SPACE
         BOUND    8
VALUE    RES      2                 'VALUE' DW
STRING   RES      2                 STRING DW
         TEXT     '    '            BLNKS
KEY      EQU      STRING
COMMAND  RES,1    100               HOLDS COMMAND
COMMAX   DATA     100               MAX LENGTH
CLEARP   GEN,8,24 100,BA(PLINE)
OUTFPT   EQU      PLINE             COMPRESSED FPT AT EXIT
LOGSIZE  EQU      80                CURRENT SIZE OF :RBLOG REC
*NEXT LINE MUST IMMEDIATELY PRECEDE 'PLINE'
CALFPT   DATA     X'1A000000'       PRECEDES FPT
PLINE    RES,1    100               FOR ERROR POINTER
RBLOG    RES      LOGSIZE           FOR :RBLOG RECORD
BASE     DATA     COMMAND
LOGKEY   RES      3                 TO HOLD WSN KEY IN TEXTC
BLANKS   EQU      KEYLIST
ONLINE   DATA     0
CEND     DATA     0
SARGVALUE DATA    0
PRBIT    DATA     0
ON       EQU      -1
OFF      EQU      0
BIT0     DATA     X'80000000'
TEST     DATA     0
LENGTH   DATA     0
TESTSW   DATA     0                 NON-ZERO DON'T CAL
ALTMODE  DATA     0                 SWITCH
EXITSW   DATA     0                 SET TO 1 IF ALT ERR
CONTSW   DATA     0                 1 IF COMND IS CONTD
HOLDPRIV DATA     0                 USERS PRIVELEDGE FROM JIT
PATCH    RES      20
         SPACE
*        'SPECIAL' IS A TWO WORD UNPRINTABLE
*        KEY TO ACCESS THE WSN NAME RECORD IN :RBLOG
         SPACE
PRIV     DATA     JB:PRIV
         BOUND    8
SPECIAL  TEXT     '///     '        KEY TO READ WSN RECORD
         SPACE
         SPACE    3
*        THE OUTPUT FPT IN COMPRESSED FORMAT IS LOCATED
*        AT 'OUTFPT' WHICH IS THE SAME AS 'PLINE'.
         SPACE
*        THE EXPANDED FPT IS IN 'FPT' DURING PROCESSING.
         SPACE
FPTLENG EQU 17                       SIZE OF OUTPUT FPT
FPT      RES      FPTLENG+1
PAGE     DATA     0                 PAGE ADDRESS WHEN LINKED
RETFLG   DATA     0                 -1 IF ERROR, 0 OK
LINKCAL  DATA     X'03000000'       LOAD/LINK RETURN FPT
SAVE8    DATA     0
EXITMODE DATA     0
         TITLE    'COMPOSITE PARALLEL TABLES FOR DOCUMENTATION'
         SPACE
*  KEYWORD  KWX TYP MIN MAX  FLV FPT SUBROUTINE
*---------------------------------------------*
*  DEV       1   2   2   2    1  2   SHIFT2   *
*  IN        2   0   0   0    1  4            *
*  OUT       3   0   0   0    1  4   OUTSUB   *
*  VFC       4   0   0   0    1  17           *
*  NOVFC     5   0   0   0    1  17  NVFCSUB  *
*  DRC       6   0   0   0    1  32           *
*  LINES     7   1   1   255  1  5            *
*  FORM      8   2   1   4    1  12  SHIFT4   *
*  FFORM     9   2   1   4    1  13  SHIFT4   *
*  COUNT     10  1   1   132  1  6            *
*  SPACE     11  1   0   255  1  7            *
*  SEQ       12  4   3   3    1  10  SEQSUB   *
*  JDE       13  1   1   33   1  8            *
*  FPC       14  2   1   4    1  11  SHIFT4   *
*  COPIES    15  1   1   255  1  9            *
*  WSN       16  2   1   8    1  3   WSNSUB   *
*  SRCB      17  0   0   0    1  29           *
*  DIRECT    18  0   0   0    1  31           *
*  ASAVE     19  0   0   0    1  28           *
*  AREL      20  0   0   0    1  27           *
*  AINIT     21  0   0   0    0  28           *
*  NAME      22  2   1   4    1  12  SHIFT4   *
*  DELETE    23  0   0   0    1  26           *
*  TESTMODE  24  0   0   0    0  0   TESTSUB  *
*---------------------------------------------*
         SPACE
*        KEYWORD  1-8 CHARACTER STRING ENTERED BY USER
*        KWX      KEYWORD INDEX
*        TYP      0; NO SECONDARY PARAMETER EXPECTED
*                 1; SECONDARY PARAMETER IS NUMERIC FIELD
*                 2; SECONDARY PARAMETER IS STRING
*                 3; OPTIONAL NUMERIC
*                 4; OPTIONAL STRING
*        MIN      MINIMUM VALUE OR STRING LENGTH
*        MAX      MAXIMUM VALUE OR STRING LENGTH
*        FLV      BIT VALUE FOR FPT P-WORD
*        FPT      INDEX TO FPT WORD FOR THIS VALUE
*        SUBR.    SPECIAL SUBROUTINE FOR THIS PARAMETER
         TITLE    'O U T P U T   F P T'
         SPACE    2
* WORD   NAME       DEFAULT
         SPACE
*---------------------------------------------*
*  01  H STREAM ID                            *
*  02  H DEV                                  *
*  03  B RBID                                 *
*  04  B IN/OUT     1 (OUT)                   *
*  05  B LINES/MINR RB:MIN,DEVX               *
*  06  B COUNT      0                         *
*  07  B SPACE      0                         *
*  08  B JDE        0                         *
*  09  B COPIES     1                         *
*  10  W SEQ        0                         *
*  11  W FPC        0                         *
*  12  W FORM       0                         *
*  13  W FFORM      0                         *
*  14  B FLAG1      RH:F2,DEVX                *
*  15  B FLAG2      RH:F2,DEVX                *
*  16  B MAXR       RB:MAX,DEVX               *
*  17  B VFC/NVFC  1(VFC)                     *
*---------------------------------------------*
         SPACE    2
*        FLAG BITS IN WORD 0:
         SPACE
*        32  DRC
*        31  DIRECT
*        30  HASP
*        29  (SRCB TEMPORARY)
*        28  ASAVE/AINIT
*        27  AREL
*        26  DELETE
         SPACE    2
* NOTE: FPT(8), THE SEQ WORD, CONTAINS A 1 IN BIT 0 IF GIVEN
         TITLE
*        SET OF PARALLEL TABLES WHICH DETERMINE THE
*        TRANSLATION FROM USER COMMAND TO FPT
         SPACE
PROCEDURE CSECT   1
         BOUND    8
KEYLIST  EQU      %
SECT4    EQU      %
         DEF      SECT4
*                           KWX
         TEXT     '        ' 0 DUMMY
         TEXT     'DEV     ' 1
         TEXT     'IN      ' 2
         TEXT     'OUT     ' 3
         TEXT     'VFC     ' 4
         TEXT     'NOVFC   ' 5
         TEXT     'DRC     ' 6
         TEXT     'LINES   ' 7
         TEXT     'FORM    ' 8
         TEXT     'FFORM   ' 9
         TEXT     'COUNT   ' 10
         TEXT     'SPACE   ' 11
         TEXT     'SEQ     ' 12
         TEXT     'JDE     ' 13
         TEXT     'FPC     ' 14
         TEXT     'COPIES  ' 15
         TEXT     'WSN     ' 16
         TEXT     'SRCB    ' 17
         TEXT     'DIRECT  ' 18
         TEXT     'ASAVE   ' 19
         TEXT     'AREL    '  20
         TEXT     'AINIT   '  21
         TEXT     'NAME    '  22 (SAME AS 'FORM')
         TEXT     'DELETE  '  23
         TEXT     'T       '  24  FOR CHECKOUT
NKEYS    EQU      24
         SPACE
         TITLE    'SECONDARY ARGUMENT PARALLEL TABLE'
*
*        BYTE 0 =0; NONE EXPECTED
*               =1; NUMERIC EXPECTED
*               =2; STRING EXPECTED
*               =3; NUMERIC OPTION
*               =4; STRING OPTION
         SPACE
*        BYTE 2     MIN VALUE OR LENGTH
*             3     MAX VALUE OR LENGTH
*
SARG     EQU      %
         BYTES    0,0,0,0           (INDEX=0 UNUSED)
         BYTES    2,0,2,2           DEV
         BYTES    0,0,0,0           IN
         BYTES    0,0,0,0           OUT
         BYTES    0,0,0,0           VFC
         BYTES    0,0,0,0           NOVFC
         BYTES    0,0,0,0           DRC
         BYTES    1,0,1,255         LINES
         BYTES    2,0,1,4           FORM
         BYTES    2,0,1,4           FFORM
         BYTES    1,0,1,132         COUNT
         BYTES    1,0,0,255         SPACE
         BYTES    4,0,0,3           SEQ
         BYTES    1,0,1,33          JDE
         BYTES    2,0,1,4           FPC
         BYTES    1,0,1,255         COPIES
         BYTES    2,0,1,8           WSN
         BYTES    0,0,0,0           SRCB
         BYTES    0,0,0,0           DIRECT
         BYTES    0,0,0,0           ASAVE
         BYTES    0,0,0,0           AREL
         BYTES    0,0,0,0           AINIT
         BYTES    2,0,1,4           NAME
         BYTES    0,0,0,0           DELETE
         BYTES    0,0,0,0           TESTMODE
         TITLE    'FPT FLAG PARALLEL TABLE'
*
*        VALUE INDICATES WHICH P-FLAG BIT IS TO BE
*        SET AND INTO WHICH FPT WORD THE VALUE IS
*        TO BE PLACED.  IF THE INDEX IS GREATER THAN
*        'HIFLAG', JUST SET FLAG AND DON'T STORE VALUE
         SPACE    3
HIFLAG   EQU      17
         BOUND    4
         SPACE    2
FLAG     DATA,1   0                 INDEX 0 UNUSED
         DATA,1   2                 DEV
         DATA,1   4                 IN
         DATA,1   4                 OUT
         DATA,1   17                VFC
         DATA,1   17                NOVFC
         DATA,1   32                DRC
         DATA,1   5                 LINES
         DATA,1   12                FORM
         DATA,1   13                FFORM
         DATA,1   6                 COUNT
         DATA,1   7                 SPACE
         DATA,1   10                SEQ
         DATA,1   8                 JDE
         DATA,1   11                FPC
         DATA,1   9                 COPIES
         DATA,1   3                 WSN
         DATA,1   29                SRCB
         DATA,1   31                DIRECT
         DATA,1   28                ASAVE
         DATA,1   27                AREL
         DATA,1   28                AINIT
         DATA,1   12                NAME
         DATA,1   26                DELETE
         DATA,1   HIFLAG+1          TESTMODE (NO BIT SET)
         TITLE    'DEFAULT VALUE PARALLEL TABLE'
         SPACE    3
         SPACE
* FPT FLAG AND PRESENCE BITS ARE NUMBERED 1-32
         SPACE
         BOUND    4
DEFAULT  EQU      %
FLAGVAL  DATA,1   ON                INDEX 0 UNUSED
         DATA,1   ON                DEV
         DATA,1   ON                IN
         DATA,1   ON                OUT
         DATA,1   ON                VFC
         DATA,1   ON                NOVFC
         DATA,1   ON                DRC
         DATA,1   ON                LINES
         DATA,1   ON                FORM
         DATA,1   ON                FFORM
         DATA,1   ON                COUNT
         DATA,1   ON                SPACE
         DATA,1   ON                SEQ
         DATA,1   ON                JDE
         DATA,1   ON                FPC
         DATA,1   ON                COPIES
         DATA,1   ON                WSN
         DATA,1   ON                SRCB
         DATA,1   ON                DIRECT
         DATA,1   ON                ASAVE
         DATA,1   ON                AREL
         DATA,1   OFF               AINIT
         DATA,1   ON                NAME
         DATA,1   ON                DELETE
         DATA,1   OFF               TESTMODE (NO BIT SET)
         TITLE    'SPECIAL SUBROUTINE PARALLEL TABLE'
         SPACE    3
         BOUND    4
SUBR     EQU      %
         DATA     0                 NOT USED
         DATA     SHIFT2            DEV
         DATA     0                 2
         DATA     OUTSUB            3
         DATA     0                 4
         DATA     NVFCSUB           5
         DATA     0                 6
         DATA     0                 7
         DATA     SHIFT4            FORM
         DATA     SHIFT4            FFORM
         DATA     0                 10
         DATA     0                 11
         DATA     SEQSUB            SEQ
         DATA     0                 13
         DATA     SHIFT4            FPC
         DATA     0                 15
         DATA     WSNSUB            WSN
         DATA     0                 17
         DATA     0                 18
         DATA     0                 ASAVE 19
         DATA     0                 AREL  20
         DATA     0                 AINIT 21
         DATA     SHIFT4            NAME  22
         DATA     0                 DELETE 23
         DATA     TESTSUB           TESTMODE 24
         PAGE
         SPACE
*        ACCESS SYMBOLS FOR FPT
         SPACE
SID      EQU      FPT+1
RBID,WSN EQU      FPT+3
DEV      EQU      FPT+2
MINR     EQU      FPT+5
MAXR     EQU      FPT+16
FORM     EQU      FPT+13
FLAG1    EQU      FPT+14
FLAG2    EQU      FPT+15
INOUT    EQU      FPT+4
         SPACE    2
FBITS    DATA     X'08070000'       5,14,15,16 FLAG BITS
DIRECTBIT EQU     2                 BIT 31
HASPBIT  EQU      4                 BIT 30
SRCBBIT  EQU      X'8'              BIT 29
         SPACE    2
*        FPT BITS ARE NUMBERED 1-32, LEFT TO RIGHT.
*        BIT 1 IN THE FPT P-WORD CORRESPONDS TO THE
*        FIRST PARAMETER, FPT+1, AND SO FORTH.
*        NON-FPT BITS ARE NUMBERED 0-31
         SPACE    2
*        TWO PARALLEL DATA LISTS FOR SCAN PROC ABOVE
         SPACE    2
COMMA    EQU      0
PERIOD   EQU      1
LPAREN   EQU      2
RPAREN   EQU      3
BLANK    EQU      4
SEMI     EQU      5
         SPACE    5
SCANL    DATA     ',','.','(',')',' ',';'
         TITLE    ':RBLOG SYMBOLS'
         SPACE
         SPACE    2
RB:RBID  EQU      RBLOG+0    ID OF THIS WSN IN BYTE ZERO
R:FLAG   EQU      RBLOG+1    FLAG WORD (HASP,SYS,SLV,XP1)
RD:WSN   EQU      RBLOG+2    DW WORK STATION NAME
RB:RP    EQU      RBLOG+4    MAX PRIORITY BYTE ZERO
R:BUF    EQU      RBLOG+5    MAX BYTES IN BLOCK THIS WORK STA
RD:RWSN  EQU      RBLOG+6    DW REMOTE WORK STA NAME
R:RMT    EQU      RBLOG+8    RMT NUMBER
RB:DMS   EQU      RBLOG+8           DMS MASK BYTE 0
R:INRCB  EQU      RBLOG+9    OC INPUT RCB OR ZERO
R:HSX    EQU      RBLOG+10   HIGHEST DEVICE INDEX SO FAR
R:OUTRCB EQU      RBLOG+11   SMD OUTPUT RCB
RH:DEV   EQU      RBLOG+12   16*HW DEVICE NAME TABLE
RB:RCB   EQU      RBLOG+20   16*BY RCB TABLE
RH:F1    EQU      RBLOG+24   16*HW FLAG1 TABLE
RH:F2    EQU      RBLOG+32   16*HW FLAG2 TABLE
RH:SUS   EQU      RBLOG+40   16*HW SUSBIT TABLE
RB:MAX   EQU      RBLOG+48   16*BY MAXIMUM REC SIZE TABLE
RB:MIN   EQU      RBLOG+52   16*BY MINIMUM REC SIZE TABLE
RB:PRIV  EQU      RBLOG+56   16*BY PRIV. TABLE
RB:TYPX  EQU      RBLOG+60   16*BY TYPE INDEX OC OPTION
         TITLE     ' '
         SPACE
*     M A I N   P R O G R A M
         SPACE    3
START    EXITCR                     RESET EXIT CONTROL
         M:PC     '%'
         LB,R     JB:PRIV           HOLD USERS PRIV
         STW,R    HOLDPRIV          FOR EXIT CONTROL
         M:XCON   XCON,LAST
         SPACE
         SPACE
*        SEE IF LDEV WAS LOADED AND LINKED TO
         SPACE
         LI,X1    JB:BCP
         LB,X1    0,X1              PAGE ADDRESS INTO X1
         CW,X1    J:JIT+JDDUL
         BE       NORMAL
         LW,X2    =X'E0100000'
         STW,X2   FPT
         SPACE
         LI,X1    BA(JB:BCP)+1
         LB,X1    0,X1
*        GET PAGE ADDRESS CONTAINING THE LDEV ARGUMENTS
*        AND PUT THEM INTO LINK FPT
         SPACE
         STW,8    SAVE8
         SLS,X1   9                 CONVERT TO WORD ADDRESS
         STW,X1   PAGE              ALSO ACTS AS LINKED SWITCH
         SPACE
         LW,X0    1,X1              STREAM ID
         STW,X0   SID
         SPACE
         LW,X0    4,X1              DEVICE NAME
         STW,X0   DEV
         SPACE
         LW,X0    5,X1              SRCB  0=NO
         BEZ      NOSRCB
         LW,X3    SRCBBIT
         STS,X3   FPT               SET SRCB SWITCH
         SPACE
NOSRCB   LW,X0    6,X1              FORM NAME
         STW,X0   FORM
         SPACE
         LW,X2    2,X1              WORK STATION NAME (WSN)
         LW,X3    3,X1
         STD,X2   STRING            TO BE MADE KEY
         STD,X2   WSN               ACTS LIKE SWITCH
         SPACE
*        GO OFF AND READ IN THE WSN RECORD
         SPACE
         MTW,1    EXITMODE          SET FOR I/O ERROR
         CALL     WSNSUB
         LW,X1    PAGE              RESTORE X1 AFTER WSNSUB
         SPACE
*        IF THE FLAG WORD CONTAINS 'TEST' SET TESTMODE SW
         SPACE
         LW,X0    0,X1              FLAG WORD
         CW,X0    ='TEST'
         BNE      FIN1              TO TO PROCESS WS
         MTW,1    TESTSW            SET TEST SWITCH (NO CAL)
         B        FIN1              TO PROCESS WS
         PAGE
NORMAL   EQU      %
         SPACE    1
*        ZERO OUT OUTPUT FPT
         SPACE
         LI,R     0
         LI,X     FPTLENG
         STW,R    FPT-1,X
         BDR,X    %-1
         SPACE
*        IF IN BATCH MODE AND J:CCBUF WORD 1 IS !JOB,
*        LDEV IS BEING CALLED BY CCI TO DO SPECIAL
*        CAL'S BECAUSE OF WSN ON JOB CARD
         SPACE
         LI,R     -1
         LCF      J:JIT
         BCS,8    ONL
BATCH    LW,0     J:CCBUF           SAYS JOB IF IN ALT MODE
         CW,0     ='!JOB'
         BE       ALT
         SPACE
         LI,IP    80                BATCH COMMAND LENGTH
         B        INIT
         SPACE
ONL      LI,R     -1
         STW,R    ONLINE            0 IF BATCH, -1 IF ONLINE
         SPACE
         LB,IP    J:PUF             COMMAND LENGTH IF ONLINE
         AI,IP    -1                RID CAR RET
         SPACE
****     PATCH UNTIL TEL ALLOWS FULL LENGTH COMMAND BUFFER
         CI,IP    52
         BG       EM4               COMMAND TOO LONG
*****    END PATCH
         SPACE
INIT     LI,2     BA(J:CCBUF)       USER'S COMMAND
         LI,3     BA(COMMAND)       WHERE WE WORK ON IT
         STB,IP   3                 BYTE COUNT TO MOVE
         MBS,2    0                 MOVE COMMAND
         AI,IP    -1                CONVERT TO INDEX
         STW,IP   CEND              DEFINE END INDEX +1
         SPACE
         SPACE
SPSCAN   LI,IP    0                 INITIAL INDEX
SP00     SCAN,EM0  (*BLANK,SP01)   TO 'L'DEV
SP01     SCAN,EM0  (BLANK,SP1)     TO LDEV' ' OR LDEV.' '
SP1      SCAN,SP1A (SEMI,SP2),(PERIOD,SP1A)
SP1A     SCANR,EM0 (COMMA,EM0),(LPAREN,EM0),(*BLANK,SP4)
SP2      ANLZ,R2  BASEIP            (BASE,IP)
         SLD,R2   -2
         SLS,R3   -30
SP3      M:READ   M:C,(BUF,*R2),(BTD,*R3),(SIZE,80)
         MTW,1    CONTSW            FOR DIAG MSG
         LW,R     M:C+4
         SLS,R    -17
         AW,R     ONLINE            TRUNC. CAR RET
         AW,IP    R
         CW,IP    COMMAX            MAX COM LENGTH
         BG       EM4               TOO LONG
         AI,IP    -1
         STW,IP   CEND
         B        SPSCAN            RE-SCAN COMMAND
         PAGE
         SPACE
*        FULL COMMAND LINE IS AT 'COMMAND' WITH 'CEND'
*        INDEX TO FINAL ')'
         SPACE
*        POINT IP TO STREAM ID IN COMMAND
         SPACE
SP4      STW,IP   CEND              INDEX OF LAST ')'
         LI,IP    0                 RESET INDEX
A1       SCAN,EM0 (*BLANK,A2)
A2       SCAN,EM0 (BLANK,A3)        TO LDEV'  '
A3       SCAN,EM0 (LPAREN,EM0),;
                  (COMMA,EM0),;
                  (RPAREN,EM0),;
                  (*BLANK,A4)       CHAR 1 OF SID
         SPACE
*        PUT STREAM ID IN 'VALUE'
         SPACE
A4       AI,IP    -1                FOR GETNEXT
         SPACE
         CALL     GETNEXT
           B      EM0               NONE GIVEN
           NOP
           CI,X   2                 CHECK LENGTH
         BNE      EM1               ILLEGAL SID
         LW,R     BIT0
         STW,R    FPT
         LW,R     VALUE
         SLS,R    -16
         STW,R    FPT+1
         PAGE
*        M A I N   L O O P
         SPACE
*        PLOW AHEAD FOR NEXT '(' AND GET KEYWORD
         SPACE
ML1      LI,R5    0                 INCREMENTAL SWITCH
         CALL     GETFIRST
           B      FIN1              NO MORE IN COMMAND
           AI,R5  1                 ')' FOLLOWS
           AI,R5  1                 ',' OR '(' FOLLOWS
         SPACE
*        GET KEYWORD INDEX INTO 'KWX'
         SPACE
         CALL     GETKWX
           B      EM2               UNRECOGNIZED
         SPACE
*        SET 'VALUE' TO SPECIFIED NUMERIC DEFAULT
         SPACE
         LI,R     0
         STW,R    VALUE
         STW,R    VALUE+1
         SPACE
*        HANDLE SECONDARY PARAMETER
         SPACE
ML2      LI,R     0
         STW,R    PRBIT             NORMAL PRESENCE BIT
         SPACE
         LW,X     SARG,KWX          SARG WORD
         LB,X     X                 SARG VALUE
         STW,X    SARGVALUE         FOR LATER
         CI,R5    2                 SET CC FOR LATER BRANCH
         SPACE
*        BRANCH ACCORDING TO SARG VALUE
         SPACE
         B        %+1,X
           B      ML20              0
           B      ML212             1,2
           B      ML212             1,2
           B      ML234             3,4
           B      ML234             3,4
         SPACE    2
ML20     BE       ML10
         B        EM0               NOT EXPECTED BUT PRESENT
         SPACE
ML212    BE       EM0               EXPECTED BUT NOT PRESENT
         B        ML3               EXPECTED AND PRESENT
         SPACE
ML234    BNE      ML3               OPTIONAL AND PRESENT
         LW,R     BIT0              OPTIONAL AND NOT PRESENT
         STW,R    PRBIT             SET PRESENCE BIT TO 1
         B        ML10
         SPACE
*        GET AND PROCESS SECONDARY PARA
         SPACE
ML3      CALL     GETNEXT
           B      EM0               COMMAND ENDS
           B      ML4               FOLLOWED BY ')'
           B      EM0               FOLLOWED BY ',' OR '('
         SPACE
*        SECONDARY PARA IN 'VALUE' DW AS LEFT-JUSTIFIED
*        STRING WITH TRAILING BLANK
         SPACE
ML4      STW,X    LENGTH            OF STRING
         LW,X     SARGVALUE
         B        %,X
           B      NUM               NUMERIC SPECIFICATION
           B      STR               STRING SPECIFICATION
           B      NUM               NUMERIC OPTIONAL
           B      STR               STRING OPTIONAL
         SPACE
*        CODE=1   NUMERIC FIELD. RIGHT JUSTIFY,ZERO FILL,
*        AND CONVERT TO BINARY
         SPACE
NUM      LI,X     3
         LD,0     VALUE
         LI,R     ' '
         CB,R     1,X
         BNE      %+3
         SLD,0    -8
         B        %-3
         STD,0    VALUE
         CALL     BCD2BIN
         SPACE
*        COMPARE WITH LIMITS IN TABLE
         SPACE
MINMAX   LW,R     SARG,KWX
         LI,X     2
         LB,R1    R,X               R1=MIN
         CW,R1    VALUE+1
         BG       EM3               TOO SMALL
         LI,X     3
         LB,R1    R,X
         CW,R1    VALUE+1
         BL       EM3               TOO BIG
         B        ML10
         SPACE
*        CODE=2   'VALUE' IS STRING. CHECK LENGTH
         SPACE
STR      LD,0     VALUE
         STD,0    STRING            HOLD THE STRING
         LW,R     LENGTH            (OF STRING)
         STW,R    VALUE+1
         B        MINMAX
         SPACE
*        GO TO SPECIAL SUBROUTINE IF SPECIFIED IN TABLE
         SPACE
ML10     LW,R     SUBR,KWX
         BEZ      %+2
         CALL     *R
         SPACE
*        SET FLAG IN FPT WORD ACCORDING TO TABLE
         SPACE
         LI,R1    1                 BECOMES MASK
         LI,R     0
         MTB,0    FLAGVAL,KWX       P-BIT 1 OR 0
         BEZ      %+2
         LI,R     -1                ONES
         LB,X     FLAG,KWX          WHICH POSITION
         LCW,X    X
         SCS,R1   0,X
         STS,R    FPT               INTO FLAG WORD
         SPACE
*        PLACE 'VALUE' IN FPT ACCORDING TO TABLE
         SPACE
ST       LB,X     FLAG,KWX          WHICH POSN IN FPT
         BEZ      ML1
         CI,X     HIFLAG            JUST FLAG BIT
         BG       ML1               DON'T STORE
         LW,R     VALUE+1
         STW,R    FPT,X
         LW,R1    PRBIT             PRESENCE BIT (1=NOT)
         STS,R1   FPT,X             INTO FPT WORD
         B        ML1               LOOP AGAIN
         TITLE    'SPECIAL USER SUBROUTINES'
         SPACE
*        THIS ROUTINE READS THE :RBLOG FILE WITH
*        WSN AS A KEY.  THE RBID AND OTHER DATA ARE
*        EXTRACTED FROM THE RECORD AND PLACED IN
*        THE LDEV FPT LATER ON.
         SPACE    2
         SPACE    2
WSNSUB   ENTER
         CALL     KEYREAD           READ ONE REC
           B      EM6               NONE SUCH REC
           RETURN                   GOT IT
         SPACE    2
         SPACE    2
SEQSUB   ENTER                      SHIFT VALUE WORD
         LW,R     PRBIT
         BNEZ     RET
         LW,R     VALUE
         SLS,R    -8
SHX      STW,R    VALUE+1
         RETURN
         SPACE    2
SHIFT2   ENTER
         LW,R     VALUE
         SLS,R    -16
         B        SHX
         SPACE    2
SHIFT4   ENTER
         LW,R     VALUE
         B        SHX
         SPACE    2
*        ENTERED IF USER SAID 'TESTMODE'. A SWITCH
*        IS SET SO NO CAL IS EXECUTED AND THE FPT
*        IS PRINTED.  THIS OPTION MAY REMAIN UNDOCUMENTED.
         SPACE
TESTSUB  ENTER
         MTW,1    TESTSW            LOADED AS ZERO
         RETURN
         SPACE    2
OUTSUB   ENTER
         LI,R     1
         STW,R    VALUE+1
         RETURN
NVFCSUB  EQU      OUTSUB
         TITLE    'PARAMETER FETCHING SUBROUTINES'
         SPACE
*        SUBROUTINE EXITS TO:
*        CALL+1: NO PARAMETERS REMAINING
*        CALL+2: THIS WAS FOLLOWED BY RIGHT PAREN
*        CALL+3: THIS WAS FOLLOWED BY COMMA
         SPACE
*        THE PARAMETER IS PLACED LEFT-JUSTIFIED IN 'VALUE' DW
*        NUMBER OF CHARACTERS RETURNED IN X (0-7)
         SPACE
GETFIRST ENTER                      'IP' POINTS BEFORE '('
         SPACE
GK1      SCAN,RET (LPAREN,GK2),;    TO (
                  (COMMA,GK1),;
                  (RPAREN,EM0),;
                  (*BLANK,EM0)
         SPACE
GK2      LI,X     0                 LENGTH COUNTER
GK2A     SCAN,EM0 (COMMA,RET3),;
                  (RPAREN,RET2),;
                  (LPAREN,EM0),;
                  (*BLANK,GK3)
         SPACE
GK3      LW,R     BLANKS
         STW,R    VALUE
         STW,R    VALUE+1           RESET VALUE DW
GK4      LB,R     *BASE,IP          NEXT CHAR OR ARG
BASEIP   EQU      GK4               FOR ANLZ INSTR ALSO
         STB,R    VALUE,X
         STEP     X,1,7,EM0         INC X
         SPACE
GK6      SCAN,RET2 (RPAREN,RET2),;
                  (LPAREN,EM0),;
                  (COMMA,RET3),;
                  (BLANK,GK8),;
                  (*BLANK,GK4)
         SPACE
GK8      SCAN,EM0 (RPAREN,RET2),;
                  (COMMA,RET3),;
                  (*BLANK,EM0)
         SPACE
RET      RETURN
RET2     RETURN   2
RET3     RETURN   3
         SPACE
*        ENTRY TO GET NEXT ARGUMENT
         SPACE
GETNEXT  ENTER
         B        GK2
         TITLE    'GET-KEYWORD-INDEX SUBROUTINE'
         SPACE
*        CALL     GETKWX            ENTRY
         SPACE
*        KEYWORD IN 'VALUE' DW IS COMPARED TO KEYLIST
*        AND INDEX VALUE IS LEFT IN 'KWX'.  INDEX ZERO
*        NOT USED.
         SPACE
*        EXIT TO CALL+1: UNRECOGNIZED KEY
*                CALL+2: OK
         SPACE
         SPACE
GETKWX   ENTER
         LD,0     VALUE
         LI,KWX   NKEYS             NUMBER OF KEYS IN LIST
         CD,0     KEYLIST,KWX
         BE       RET2              NORMAL EXIT
         BDR,KWX  %-2
         RETURN                     NOT FOUND
         TITLE    'END ROUTINE'
         SPACE
*        AT THIS POINT THE FPT CONTAINS ALL THE
*        DATA FROM USER'S COMMAND.  THE :RBLOG
*        RECORD IS IN RBLOG. MAKE VARIOUS CHECKS
*        AND TRANSFER APPROPRIATE DATA FROM RBLOG
*        TO FPT AND DO CAL
         SPACE
FIN1     EQU      %
*        WAS WSN SPECIFIED
         SPACE
         LW,R      WSN
         BEZ      WS99
         SPACE
*        WAS DEV SPECIFIED
         SPACE
         LW,R      DEV
         BEZ      EM7               NO DEV ERROR
         SPACE
*        SEARCH RH:DEV FOR DEV CODE IN R
         SPACE
         LI,IDX   0
WSN2     CW,IDX   R:HSX
         BG       EM8               NOT IN TABLE
         LH,R1    RH:DEV,IDX        GET DEV NAME
         AND,R1   =X'FFFF'          RID EXTENDED SIGN
         CW,R     R1
         BE       WSN3              FOUND IT
         AI,IDX   1                 STEP INDEX
         B        WSN2
         SPACE
         SPACE
*        REPLACE FPT(DEV) WITH DEVICE CODE
         SPACE
WSN3     LB,R     RB:RCB,IDX
         LB,R1    RB:DMS            MASK
         AND,R    R1
         STW,R     DEV
         SPACE
*        SET MIN AND MAX
         SPACE
         SPACE
*        IF MIN OR MAX NOT SPECIFIED ON LDEV COMMAND,
*        USE THE CORRESPONDING VALUES FROM WSN RECORD
         SPACE
         MTW,0    MINR              ON COMMAND
         BNEZ     %+3               YES
         LB,R     RB:MIN,IDX        NO, USE WSN
         STW,R    MINR              INTO FPT
         SPACE
         MTW,0    MAXR              ON COMMAND
         BNEZ     %+3               YES
         LB,R     RB:MAX,IDX        NO, USE WSN
         STW,R    MAXR
         SPACE    2
         LH,R     RH:F2,IDX
         LI,R1    X'FF'             MASK
         STS,R    FLAG2             SPLIT HALF WORD INTO
         SLS,R    -8                TWO BYTES AND PUT IN
         STS,R    FLAG1             FPT FLAG1 AND FLAG2
         SPACE    2
         LW,R1    FBITS             SET P WORD
         STS,R1   FPT
         SPACE
*        IF RBLOG(DIRECT)=0 AND USER SAID DIRECT;ERROR
         SPACE
         LI,R1    DIRECTBIT
         CS,R1    FPT
         BNE      WSN10
         LW,R1    =X'8000'          BIT 1 OF HW
         LH,R2    RH:F2,IDX
         CS,R1    R2
         SPACE
*        IF TYPE=2780 OR 7670,TEST DEVICE TYPE AND MAXREC
*        FOR POSSIBLE MODIFICATION
         SPACE
         LW,R     MAXR              TYPE IRBT BIT
         LW,R1    =X'02000000'      TYPE IRBT BIT
         CS,R1    R:FLAG
         BE       WSN9              BRANCH IF NOT 2780 OR 7670
         SPACE
*        TYPE = 2780 OR 7670
         SPACE
         LW,R2    DEV               DEVICE NAME
         CI,R2    'CP'
         BNE      WSN4
         SPACE
*        TYPE = 2780 OR 7670 AND DEV = CP
         SPACE
         CI,R     80                USE MAX OF MAXR AND 80
         BG       WSN9              OK AS IS
         LI,R     80
         B        WSN8              PUT 80 IN MAXR
WSN4     CI,R2    'LP'
         BNE      WSN9
         SPACE
*        TYPE = 2780 OR 7670 AND DEV = LP
         SPACE
         LW,R1    =X'002000000'     TYPE 2780 FLAG BIT IF SET
         CS,R1    R:FLAG
         BE       WSN6
         SPACE
*        TYPE = 7670 AND DEV = LP
         SPACE
         CI,R     128               USE MAX OF MAXR AND 128
         BG       WSN9              OK AS IS
         LI,R     128               USE 128 FOR MAXR
         B        WSN8
         SPACE
*        TYPE = 2780 AND DEV = LP
         SPACE
WSN6     CI,R     120               USE MAX OF MAXR AND 120
         BG       WSN9
         LI,R     120
WSN8     STW,R    MAXR              REPLACEMENT VALUE INTO MAXR
WSN9     EQU      %
         BNEZ     EM9
         SPACE
WSN10    LW,R1    =X'02000000'
         CS,R1    R:FLAG
         BNE      WS12              HASP=0
         LI,R1    HASPBIT
         STS,R1   FPT               SET HASP FLAG
         SPACE    2
*        CHECK USER PRIV
         SPACE
WS12     LB,R     RB:PRIV,IDX
         CB,R     *PRIV
         BG       EM10
         SPACE
         LB,R      RB:RBID
         STW,R     RBID
         SPACE    2
*        CHECK SRCB CONSISTANCY
         SPACE
WSN13    LI,R1    X'7'              MASK
         LI,R     X'4'
         SPACE
*        DID USER SAY SRCB ON LDEV COMMAND
         SPACE
         LI,R3    SRCBBIT           BIT 29
         CS,R3    FPT
         BNE      WSN15             NO
         SPACE
         STS,R    FLAG1             YES
         B        WSN18
         SPACE
WSN15    CS,R     FLAG1
         BE       EM12              ERROR
         SPACE
*        CHECK INPUT/OUTPUT CONSISTANCY
         SPACE
WSN18    LI,R3    X'30'
         LW,R1    =X'10000000'  IN/OUT BIT (OUT=1)
         CS,R1    FPT
         BNE      WSN25
         LI,R3    X'20'
         MTW,0    INOUT             IN FPT
         BEZ      WSN25
         LI,R3    X'10'
WSN25    CH,R3    RH:F2,IDX
         BAZ      EM13
         SPACE
*        IN-OUT CHECKS. TAKE IN/OUT VALUE FROM RBLOG
*        RECORD AND PUT INTO FPT AND SET IN/OUT FPT BIT
         SPACE
         LH,R1    RH:F1,IDX
         AI,R1    1                 TOGGLE LOW BIT
         AND,R1   =X'1'             IN/OUT (OUT=0)
         STW,R1   INOUT             INTO FPT
         LW,R1    =X'10000000'      IN/OUT P BIT
         OR,R1    FPT               INTO P WORD
         STW,R1   FPT
         SPACE
*        IF USER SAID 'SRCB' AND 'IN' AND DEVICE
*        DATA FROM :RBLOG RECORD HAS SRCB AS NOT 'U', ERROR
         SPACE
         LI,R3    SRCBBIT           P-BIT
         OR,R3    =X'10000000'      IN/OUT P-BIT
         CS,R3    FPT               SRCB AND (IN OR OUT)?
         BNE      WS99              NO, QUIT
         MTW,0    INOUT             IN?
         BNEZ     WS99              OUT, QUIT
         LI,R3    X'4'              SRCB=U BIT
         CS,R3    FLAG1             IS IT SRCB=U
         BNE      EM15              NO, ERROR
         SPACE
         SPACE
         SPACE    2
WS99     CALL     COMPFPT           COMPRESS FPT
         MTW,0    TESTSW            IN TESTMODE?
         BNEZ     EXIT              YES; NO CAL
         SPACE    2
*        IF LDEV ERROR, CC1=1 AND SR3 CONTAINS CONVENTIONAL
*        ERROR CODES: CODE=B7, SUBCODE=0,1,2, OR 3 THE
*        MEANINGS OF WHICH ARE SHOWN IN THE MESSAGES BC0-BC3
         SPACE
         SPACE
         CAL1,8   CALFPT            ******************
         BCR,8    GOODCAL           EXAMINE RETURN STATUS
         MTW,-1   RETFLG            SET FOR ABORTION
         SCS,10   15                (SR3 ERROR CODE)
         AND,10   =X'7'
         LW,X     10                ERROR INDEX
         EXU      BADCAL,X          TYPE MESSAGE
GOODCAL  MTW,0    ALTMODE
         BEZ      EXIT
         RETURN
ERREXIT  MTW,-1   RETFLG            SET ERROR FLAG FOR LINK
EXIT     LW,X1    PAGE              IN LINKED MODE 0=NO
         BEZ      NORMEX
         LW,R     RETFLG
         STW,R    0,X1              INTO LINK PAGE
         CAL1,8   LINKCAL           LINKED RETURN
NORMEX   EQU      %
         MTW,0    RETFLG            ZERO=NO ERROR
         BEZ      %+2
         M:XXX                      ABORT JOB
         MTW,0    EXITSW            CCI ERR FLG
         BEZ      %+2               0 OF NO ERROR
         M:EXIT   1                 ERROR RETURN TO CCI
         CAL1,9   X'0001'           NORMAL
BADCAL   M:PRINT  (MESS,BC0)
         M:PRINT  (MESS,BC1)
         M:PRINT  (MESS,BC2)
         M:PRINT  (MESS,BC3)
         M:PRINT  (MESS,BC4)
         M:PRINT  (MESS,BCX)        ILLEGAL CODE RETURNED
         M:PRINT  (MESS,BCX)        ILLEGAL CODE RETURNED
         M:PRINT  (MESS,BCX)        ILLEGAL CODE RETURNED
         SPACE
BC0      TEXTC    '***** UNRECOGNIZED STREAM ID'
BC1      TEXTC    '***** UNRECOGNIZED DEV SPECIFICATION'
BC2      TEXTC    '***** FUNCTION NOT LEGAL FOR DEVICE'
BC3      TEXTC    '***** NOT AUTHORIZED FOR REMOTE WSN'
BC4      TEXTC    '***** PERIPHERAL USE FLAG NOT SET FOR THIS DEVICE'
BCX      TEXTC    '*LDEV FPT PROC RETURNED BAD ERR CODE'
         TITLE    'ALTERNATE LDEV MODE'
         SPACE
*        IF IN BATCH MODE AND WORD 1 OF J:CCBUF IS
*        NOT JOB, A WSN HAS BEEN SPECIFIED ON THE JOB
*        CARD.
         SPACE    2
ALT      EQU      %
         LI,R     ON                X'FF' FOR PRIV CHK BYPASS
         STW,R    PRIV              INTO 'SWITCH'
         LD,R     J:DWSK            8 CHAR WSN
         STD,R    KEY               FOR KEYREAD SUBR.
         BEZ      ALT10             NO WSN THERE
         LI,R     0
         STW,R    EXITSW            ERROR SWITCH= NO
         SPACE
ALT5     MTW,1    EXITMODE          FOR EXIT IF I/O ERROR
         CALL     KEYREAD
           B      ALT7              NO SUCH KEY
           B      ALT20             GOT IT
         SPACE
ALT7     MTW,1    EXITSW            ERROR SWITCH= YES
ALT10    LI,2     BA(J:JIT+JRBID)+1  THE RBID
         LB,X     0,2               RBID INDEX
         BEZ      EXIT              NO RBID
         LD,R     SPECIAL           KEY TO RBID RECORD
         STD,R    KEY
         CALL     KEYREAD           READ RBID RECORD
           B      EM14              IMPOSSIBLE ERROR
         LD,R     RBLOG,X           THE 8 CHAR WSN
         STD,R    KEY
         BEZ      EXIT              NO WSN
         B        ALT5
         SPACE
ALT20    LI,R1    X'1000'           LIST=3 FLAG BIT
         CALL     SEARCH            RH:F2
           B      ALT40             NONE EXISTS
         LI,R1    'L1'
         CALL     DOCAL             DO THE CAL
         SPACE
ALT40    LI,R1    WS12
         STW,R1   PRIV
         LI,R1    X'2000'           LIST=P FLAG BIT
         CALL     SEARCH            RH:F2
           B      EXIT              NONE EXISTS
         LI,R1    'P1'
         CALL     DOCAL             DO THE CAL
         B        EXIT
         TITLE
*        SUBROUTINE TO SEARCH RH:F2 FOR FLAG
*        BIT AS SPECIFIED IN R1. EXIT TO CALL+1
*        IF NOT FOUND, ELSE CALL+2
         SPACE
SEARCH   ENTER
         LW,X     R:HSX
S22      LH,R     RH:F2,X
         CS,R     R1
         BE       RET2              FOUND
         AI,X     -1
         BGEZ     S22
         RETURN                     NOT FOUND
         SPACE    2
*        SUBROUTINE TO PIECE TOGETHER AN LDEV
*        FPT AS IF USER HAD GIVEN COMMAND:
         SPACE
*LDEV XX,(DEV,YY),(WSN,ZZ)
         SPACE
*        XX IS FOUND IN R1 AND IS EITHER L1 OR P1
*        YY IS THE CORRESPONDING DEV  CODE
*        ZZ IS THE WORKSTATION NAME
         SPACE
DOCAL    ENTER
         LH,R     RH:DEV,X
         AND,R    =X'FFFF'          ELIM EXT SIGN
         STW,R    DEV               INTO FPT
         STW,R1   SID               L1 OR P1
         LW,R     ALTPBITS
         STW,R    FPT               P BITS
         MTW,1    ALTMODE           SET RETURN SWITCH
         LD,R     KEY
         STD,R    WSN
         B        FIN1              GO DO SOME STUFF
*                                   AND RETURN
         SPACE
*        THE PRELIMINARY P-WORD FOR THE ALT CAL
*        HAS BITS FOR SID,RBID,DEV
         SPACE
ALTPBITS DATA     X'E0000000'
         TITLE    'ERROR ROUTINES AND MESSAGES'
         SPACE
*        SUBROUTINE TO PRINT POINTER TO COMMAND ERROR
         SPACE
PPOINT   ENTER
         MTW,0    CONTSW            HAS COMMAND BEEN CONT'D
         BNEZ     RET               YES, NO POINTER
         LW,1     CLEARP
         MBS,0    BA(BLANKS)        CLEAR OUT PLINE
         LI,R     '*'               POINTER CHARACTER
         STB,R    PLINE,IP          IP INDEX TO OFFENDER
         M:WRITE  M:LL,(BUF,PLINE),(SIZE,*CEND)
         RETURN
         SPACE
EM0      CALL     PPOINT            SYNTAX ERROR
         M:PRINT  (MESS,EM0M)
         B        ERREXIT
         SPACE
EM1      CALL     PPOINT
         M:PRINT  (MESS,EM1M)
         B        ERREXIT
         SPACE
EM2      CALL     PPOINT
         M:PRINT  (MESS,EM2M)
         B        ERREXIT
         SPACE
         SPACE
EM3      CALL     PPOINT
         M:PRINT  (MESS,EM3M)
         B        ERREXIT
         SPACE
         SPACE
EM4      M:PRINT  (MESS,EM4M)
         B        ERREXIT
            SPACE
EM5      CALL     PPOINT
         M:PRINT  (MESS,EM5M)
         B        ERREXIT
         SPACE
EM6      M:PRINT  (MESS,EM6M)
         B        ERREXIT
EM7      M:PRINT  (MESS,EM7M)
         B        ERREXIT
EM8      M:PRINT  (MESS,EM8M)
         B        ERREXIT
EM9      M:PRINT  (MESS,EM9M)
         B        ERREXIT
EM10     M:PRINT  (MESS,EM10M)
         B        ERREXIT
EM11     M:PRINT  (MESS,EM11M)
         B        ERREXIT
EM12     M:PRINT  (MESS,EM12M)
         B        ERREXIT
EM13     M:PRINT  (MESS,EM13M)
         B        ERREXIT
EM14     M:PRINT  (MESS,EM14M)
         B        ERREXIT
EM15     M:PRINT  (MESS,EM15M)
         B        ERREXIT
         PAGE
         SPACE
EM0M     TEXTC    '***** SYNTAX ERROR IN ABOVE COMMAND'
EM1M     TEXTC    '***** UNRECOGNIZED STREAM I.D.'
EM2M     TEXTC    '***** UNRECOGNIZED KEYWORD'
EM3M     TEXTC    '***** ILLEGAL VALUE OR STRING LENGTH'
EM4M     TEXTC    '***** COMMAND IS TOO LONG'
EM5M     TEXTC    '***** ILLEGAL CHARACTER IN NUMERIC FIELD'
EM6M     TEXTC    '***** UNRECOGNIZED WSN'
EM7M     TEXTC    '***** NO DEV SPECIFIED'
EM8M     TEXTC    '***** DEV CODE NOT FOUND IN :RBLOG'
EM9M     TEXTC    '***** DIRECT NOT ALLOWED FOR THIS DEVICE'
EM10M    TEXTC    '***** INSUFFICIENT PRIV.'
EM11M    TEXTC    '***** USER NOT ALLOWED ACCESS'
EM12M    TEXTC    '***** SRCB WIERDNESS'
EM13M    TEXTC    '***** IN/OUT INCONSISTANCY'
EM14M    TEXTC    '***** WSN REC :RBLOG MISSING'
EM15M    TEXTC    '***** SRCBS NOT AVAILABLE FROM DEV'
         TITLE
*        BCD TO BINARY CONVERSION SUBROUTINE
            SPACE
*        INPUT: RIGHT JUSTIFIED ZERO-FILLED IN VALUE+1
*        OUTPUT: BINARY VALUE IN VALUE+1
            SPACE
BCD2BIN  ENTER
         LI,X     0
         LI,1     4
         LI,3     0
BCD2     LB,R     VALUE+1,X         NEXT BYTE
         BEZ      BCD3
         AI,R     -X'F0'
         BLZ      EM5               ILLEGAL CHARACTER
         CI,R     9
         BG       EM5               ILLEGAL CHARACTER
         MI,3     10
         AW,3     R
BCD3     AI,X     1
         BDR,1    BCD2              LOOP FOR NEXT CHAR
         STW,3    VALUE+1           STORE RESULT
         RETURN
         SPACE    2
*        SUBROUTINE TO COMPRESS FINISHED FPT
         SPACE
COMPFPT  ENTER
         MTW,0    TESTSW            IN TESTMODE
         BEZ      %+3               DON'T PRINT
         LW,3     FPT
         CALL     HPRINT
         LI,3     HIFLAG+1
         LI,1     0
         LI,2     0
         LW,R     FPT
         STW,R    OUTFPT
CFPT2    S,R      1
         BCR,8    CFPT4             BRANCH IF ABSENT
         LW,R1    FPT+1,1
         STW,R1   OUTFPT+1,2
         SPACE
         MTW,0    TESTSW            IN TEST MODE?
         BEZ      CFPT3             YES; DON'T PRINT
         STW,3    PRBIT             HOLD
         LW,3     R1
         CALL     HPRINT
         LW,3     PRBIT
         SPACE
CFPT3    AI,2     1
CFPT4    AI,1     1
         BDR,3    CFPT2
         RETURN
         PAGE
*        SUBROUTINE TO PRINT WORD IN REG 3 IN HEX
         SPACE
*        USES AND RESTORES REGS 0-4.
*        USES 8 WORD AREA AT 'HPR' FOR STORAGE
         SPACE
HPRINT   ENTER
         LCI      5
         STM,0    HPR
         LI,4     8
HPR2     LI,2     0
         SLD,2    4
         CI,2     9
         BG       %+2
         AI,2     X'39'
         AI,2     X'B7'
         STB,2    0
         SCD,0    8
         BDR,4    HPR2
         LI,3     X'0D'
         LCF      J:JIT
         BCR,8    %+2               NO RET OF IN BATCH
         STB,3    HPR+6
         STW,0    HPR+4
         STW,1    HPR+5
         M:WRITE  M:LL,(BUF,HPR+4),(SIZE,9)
         LCI      5
         LM,0     HPR
         RETURN
HPR      EQU      PLINE+17          WORKING AREA
         TITLE    'READ ONE RECORD VIA KEY'
         SPACE
KEYREAD  ENTER
         LH,2     M:EI
         CI,2     X'20'             ALREADY OPEN
         BAZ      %+2               NO, OPEN IT
         M:CLOSE  M:EI              YES, CLOSE IT
*        MOVE WSN FROM 'KEY' (LJBF) TO LOGKEY AND
*        COMPUTE BYTE COUNT IN TEXTC FORMAT
         SPACE
         LI,X1    1
         LI,X2    0
KR02     LB,R     KEY,X2
         CI,R     X'40'
         BE       KR04
         STB,R    LOGKEY,X1
         AI,X1    1
         AI,X2    1
         B        KR02
KR04     STB,X2   LOGKEY
         SPACE
KR00     LB,R     JB:PRIV           HOLD MY PRIV.
         LI,2     X'C0'             TEMP PRIV TO READ
         STB,2    JB:PRIV           INTO JIT
KR06     M:OPEN   M:EI,(FILE,':RBLOG',':SYS'),;
                  (KEYED),(DIRECT),;
                       (IN),(ERR,RBERR),(ABN,RBERR),;
                       (BUF,RBLOG)
         STB,R    JB:PRIV           RESTORE PRIV
         M:READ   M:EI,(SIZE,LOGSIZE*4),(KEY,LOGKEY)
         M:CLOSE  M:EI
         RETURN   2                 NORMAL RETURN
         SPACE
*        RESTORE USERS PRIVELEDGE IF HE NOW HAS C0
         SPACE
XCON     LW,R     HOLDPRIV          SAVED AT INITIALIZATION
         STB,R    JB:PRIV           INTO JIT
         LC       12                SEE IF REGISTERS ARE OK
         BCS,8    0,2               NO, GO BACK AND EXIT AGAIN
         LW,1     0,1               THE EXIT INSTRUCTION
         EXU      0,1               DO IT AGAIN, FINALLY
         SPACE    3
RBERR    LW,0     HOLDPRIV          RESTORE USERS ORIGINAL PRIV
         STB,0    JB:PRIV
         STW,8    PLINE
         STW,10   PLINE+1           LIKEWISE SR3
         LB,R     10                REG R = REG SR1
         CI,R     X'43'             NONE SUCH KEY?
         BE       RET
         SLS,10   -17
         CI,10    X'4628'           IS FILE BUSY
         BNE      MERC              TROUBLE
         M:WAIT   10                SLEEP A BIT
         B        KR00              TRY OPEN PROCEDURE AGAIN
MERC     LW,8     PLINE             RESTORE SR1
         LW,10    PLINE+1           RESTORE SR3
         MTW,0    EXITMODE
         BEZ      %+2
         CAL1,9   X'101'            ERROR RETURN
         M:MERC
         END      START

