*M*      BLDCB    BUILD INPUT OR OUTPUT DCB
BLDCB    DSECT    1
PLSECT   CSECT    1
         PAGE
VERSION  EQU      2                 1=BPM, 2=UTS
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
         PAGE
         TITLE    'BLDCB'
         SYSTEM   SIG7
*
*P*      NAME:    BLDCB
*P*
*P*
*P*      PURPOSE: BLDCB CONSTRUCTS AN OPEN FPT FOR EITHER THE M:EI OR
*P*               THE M:EO DCB, BASED UPON INPUT FLAGS, AND ISSUES AN
*P*               OPEN CAL FOR THE DCB.
*P*
*P*
*
*DO*
*P*
* INPUT
*        R1       BIT 12   TEST FILE
*                 BIT 28   INOUT MODE FLAG(0-NOT INOUT,1-INOUT MODE)
*                 BIT 29   NXTF FLAG (0-NOT NXTF,1-NXTF)
*                 BIT 30   FPARAM FLAG (0-NOT FPARAM,1-FPARAM)
*                 BIT 31   I/O SWITCH (0-INPUT,1-OUTPUT)
*        ARGTBL   TABLE OF TRANSLATED ARGUMENTS (DEVICE FILE,MODE)
*        NCHAR    LENGTH OF CURRENT ARGUMENT IN -ARGBUFF-
*        TOVER    OUTPUT VERB
* OUTPUT
*        M:EI     INPUT DCB
*        M:EO     OUTPUT DCB
*        OPNFPT   OPEN FILE PARAMETER TABLE
*        DCBADD   ADDRESS OF CURRENT DCB (M:EI,M:EO OR M:STD)
*        CMBX     COMMAND BUFFER INDEX
*
*FIN*
*
         REF      GETARG
         REF      ERROR
         REF      CALL1
         REF      CMDBUF
         REF      CMBX1             START OF COMMAND AREA
         REF      IOABORTS          IO ERR/ABN GIVE UP CODES
         REF      ARGTBL,DEVICE,FILE,MODE
         REF      NCHAR,DCBADD,CMBX
         REF      OPNFPT,FPARAM
         REF      CLOSEO,TOVER,M:UC
         REF      J:JIT
         REF      CODE
         REF      TLBLSIZE
         REF      SEQUENCE
         REF      TOARG
         REF      #DELIM
         REF      SFACCT
         REF      COPYSTDF,ARGBUF4,TLABEL
         REF      RDTBL,WRTBL
         REF      EXTBL,UNTBL
         REF      DENSITY
         REF      CLOSEI
         REF      SFTEMP
         REF      SCRATCH,PRTBUF
         REF      ARGBUFF
         REF      FROMFILE
        REF      PRNTBUF
         REF      COPYPHY
         REF      FROMCMBX
         REF      UNPRINT
         REF      LTSTCMBX
         DEF      M:EISN
         DEF      M:EOSN
         REF      INSER,OUTSER      FOR DEFAULT VOL#
*
         DEF      MAXSN
         REF      ANSBLK
         REF      SIXPACK
         REF      EXPIRE
         REF      IN%ARG,OUT%ARG
         USECT    BLDCB
         LI,D4    0                 CLEAR ERROR REGS
         LI,SR3   0
         LCI      7                 SAVE REGISTERS
         PSM,R5   *R7
*
         LW,R6    DEVICE+2,R7       SET A REASONABLE CMBX
         STW,R6   CMBX,R7           FOR ERROR MESAGES
         LW,SR2   R1                SAVE I/O SWITCH
*
         LW,R6    DEVICE,R7         INITIALIZE FOR DEFAULT TABLE SEARCH
         LC       J:JIT
         LI,R1    OPENSIZE          INITIALIZE OPEN FPT
         LW,R2    R7
         AI,R2    OPNFPT-1
         LW,R3    IOPNFPT-1,R1
         STW,R3   *R2,R1
         BDR,R1   %-2
*
         DO       VERSION=2
         LW,R3    =X'80000'
         LW,R2    SR2
         STS,R2   OPNFPT,R7         SET TESTFILE BIT IF PRESENT
         FIN
*
ADDRN    LW,R5    DEVICE+1,R7       TEST FOR REEL NO.S
         BNEZ     ADDRN3            PRESENT
         LW,R2    SCRATCH,R7        IS SCRATCH TAPE IN USE
         BEZ      ADDFILE           NO
         LI,R5    1                 INDICATE ONE SER NO
         CI,R6    4
         BE       ADDRN5            LT
         CI,R6    6                 TEST FOR FT
         BNE      ADDFILE           NO
ADDRN5   SLD,R2   -8
         STW,R2   ARGBUFF,R7        PUT SN IN ARG BUFFER
         STW,R3   ARGBUFF+1,R7
         B        ADDRN4
ADDRN3   EQU      %
         CI,R6    3
         BE       ADDFILE           STD FILE INPUT
ADDRN1   EQU      %
         LI,R1    X'40006'          SERIAL # DELIMITERS
         BAL,SR4  GETARG            GET REEL NO. ARGUMENT
         LW,R2    NCHAR,R7          TEST FOR NULL ARGUMENT
         BEZ      ADDRN2
         CI,R6    7                 IS DEVICE ANS TAPE
         BNE      ADDRN4            NO
         LW,R1    R7
         SLS,R1   2
         AI,R1    ARGBUF4+1         BYTE ADR OF SER NO
         BAL,SR4  SIXPACK           GO HASH 6-CHAR SN
         AI,R4    0                 IS SN VALID
         BE       ADDRN5            YES
         LI,R1    3                 INVALID REEL NUMBER SPEC
         B        ERRTN
*
ADDVOL6  STW,R4   FPTVOL,R7         SET THE VOL IN FPT
         CW,R4    R1                IS IT REASONABLE
         BLE      ADDFILE
         LI,R1    10                TOO BIG VOL OPTION
         BAL,SR4  ERROR
         B        ADDFILE
ADDRN4   EQU      %
         LI,R1    4                 SN=4
         BAL,SR4  STORVLP
ADDRN2   BDR,R5   ADDRN1
         LW,R1    VLPOPEN,R7        GET LAST CONTROL WORD
         CI,R1    X'10000'          ONLY FILE (NO ENTRY) OR SN POSSIBLE
         BANZ     %+2               (SO LIMIT IF NO SNS FOR VOL IS 0)
ADDVOL2  LW,R1    VLPOPEN+9,R7
         LI,R2    1                 GET SN COUNT THEREFROM
         LB,R1    R1,R2
         LI,R4    X'FF'             GET USERS VOL REQUEST
         AND,R4   MODE,R7
         BNEZ     ADDVOL6
         LW,R2    INSER             SEE IF WE CAN FIND A MATCH
         LW,R3    OUTSER            IN MOUNTED SNS AND VLP LIST
         CI,SR2   1                 USE SAME MODE FIRST
         BAZ      %+2
         XW,R2    R3
ADDVOL1  LW,R4    R1                NUMMER TO SEARCH
         BEZ      ADDFILE
         ANLZ,SR4 ADDVOL2           ADDRESS OF SNS
         CW,R2    *SR4,R4
         BE       ADDVOL6           GOT ONE
         CW,R3    *SR4,R4
         BE       ADDVOL6
         BDR,R4   %-4
*
ADDFILE  LI,R5    1
         LW,R1    FILE+1,R7         TEST FOR FILE ARGUMENTS
         BEZ      ADDOPL
ADDFILEB EQU      %
         STW,R1   CMBX,R7           SET CMBX OF FILE NAME
*
ADDFILE1 RES
         LI,R1    12
         BAL,SR4  GETARG            GET ARGUMENT
         AI,SR3   0                 RD OR WR ACCOUNTS
         BNEZ     ADDOPL5           YES
*
         LW,R2    NCHAR,R7          TEST FOR NULL ARGUMENT
         BEZ      ADDFILE2
         MTW,0    COPYSTDF,R7       IS THIS A STD FILE
         BLEZ     ADDFILEC          NO
         CI,R5    2                 IS ARG AN ACCOUNT
         BNE      ADDFILEC          NO
         CI,SR2   1                 INPUT
         BANZ     ADDFILEC          NO
         LW,R1    LTSTCMBX
         STW,R1   SFACCT,R7         SAVE CMBX VALUE FOR ACCT
ADDFILEC EQU      %
ADDFILE3 LW,R1    R5
ADDFILE4 BAL,SR4  STORVLP           ADD FILE PARAMETER TO OPEN FPT
ADDFILE2 AI,R5    1
         CW,R5    FILE,R7
         BLE      ADDFILE1
         CI,SR2   1
         BANZ     ADDOPL            OUTPUT
         CI,R5    2                 WAS ACCT SPECIFIED
         BG       ADDOPL            YES
         LW,R1    SFACCT,R7         WAS ACCT PRESENT ON COPYSTD
         BEZ      ADDOPL            NO
         STW,R1   CMBX,R7           POINT TO ACCT FOR COPYSTD
         B        ADDFILE1
*
ADDOPL   EQU      %
         CI,SR2   1
         BAZ      ADDOPL3           INPUT
         LI,SR3   RDTBL+1           ADR OF RD ACCT TABLE
         LW,SR1   RDTBL             ARE RD ACCTS PRESENT
         BNEZ     ADDOPL4           YES
ADDOPL8  EQU      %
         LI,SR3   WRTBL+1      ADR OF WR ACCT TABLE
         LW,SR1   WRTBL        ARE WR ACCTS PRESENT
         BNEZ     ADDOPL4      YES
ADDOPLA  EQU      %
         LI,SR3   EXTBL+1      ADR OF EX ACCT TABLE.
         LW,SR1   EXTBL        ARE WR ACCTS PRESENT.
         BNEZ     ADDOPL4      YES
ADDOPLB  EQU      %
         LW,SR1   UNTBL        ARE UN ACCTS PRESENT
         BEZ      ADDOPL3      VEHICLE ACCT NOT PRESENT.
         LI,SR3   UNTBL+1
ADDOPL4  LW,R2    *SR3              GET CMBX VALUE OF 1ST ACCT
         STW,R2   CMBX,R7
         LI,R5    2                 SET TO INDICATE ACCT
         B        ADDFILE1
ADDOPL5  LW,R2    NCHAR,R7          NULL FIELD
         BEZ      ADDOPL7           YES
         LI,R1    6                 CODE FOR READ ACCT
         CI,SR3   RDTBL+1           ARE WE ADDING READ ACCTS
         BE       ST%VLP       YES.
         LI,R1    7            CODE FOR WR ACCT.
         CI,SR3   WRTBL+1      WRITE ACCTS
         BE       ST%VLP       YES
         LI,R1    8            CODE FOR EXECUTE ACCT.
         CI,SR3   EXTBL+1      ARE WE ADDING EXECUTE ACCOUNTS.
         BE       ST%VLP       YES
         LI,R1    9            CODE FOR VEHICLE ACCT.
ST%VLP   EQU      %
         BAL,SR4  STORVLP           ADD RD OR WR ACCT TO OPEN FPT
ADDOPL7  BDR,SR1  ADDFILE1          LOOP ON NUMBER OF ACCTS
         CI,SR3   RDTBL+1           READ ACCT
         BE       ADDOPL8           YES - GO TEST FOR WR
         CI,SR3   WRTBL+1      WRITE ACCOUNT?
         BE       ADDOPLA      YES--GO TEST FOR EX
         CI,SR3   EXTBL+1      EXECUTE ACCOUNT
         BE       ADDOPLB      YES--GO TEST FOR UNDER
ADDOPL3  EQU      %
         LI,R1    X'FF'
         AND,R1   MODE+1,R7         GET 7T/9T/ASCI/EBCD
         LW,R2    IN%ARG,R7
         CI,SR2   1            CHECK FOR INPUT.
         BAZ      %+2          INPUT.
         LW,R2    OUT%ARG,R7   LOAD OUTPUT DEVICE.
         AI,R2    0                 IF NONZERO, USE IT
         BNEZ     ADDOPL1
         CI,R6    6                 IF FT, DEFAULT 9T
         BNE      %+2
         LI,R2    '9T'
         CI,R1    3                 IF NOT 7T, DEFAULT TO 9T
         BNE      ADDOPL1
         DO1      VERSION=2
         LI,R2    '7T'
         DO1      VERSION=1
         LI,R2    X'8900'           TYPE CODE FOR 7T
ADDOPL1  STW,R2   FPTOPLB,R7        PUT OP LABEL IN FPT
         DO       VERSION=1
         AND,R2   R3
         CI,R2    X'8A00'           TEST IF TYPE CODE
         BG       ADDOPL2           NO
         LI,R1    X'10000'
         STS,R1   FPTOPLB,R7        SET BIT15 FOR TYPE CODE
         FIN
*
ADDOPL2  EQU      %
         AI,R1    -16               ASCI/EBCD
         BLZ      %+2               NOPE
         STW,R1   FPTCCF,R7         PUT AWAY
         CI,SR2   1                 TEST IF CREATING INPUT DCB.
         BAZ      NXT%PAR1          YES.
         LW,R1    DENSITY
         BEZ      NXT%PAR1     NO
         STW,R1   FPTDEN,R7         PUT IN FPT IF 800
NXT%PAR1 EQU      %
         LB,R1    DVASN,R6          GET ASN
         STS,R1   OPNFPT+1,R7       SET FILE OR LABEL EXISTANCE FLAG
*
INPUT    CI,SR2   1                 CREATING INPUT DCB
         BANZ     OUTPUT            NO
         LI,R1    M:EI
         CAL1,1   RESETFPT          RESET M:EI DCB
         STW,R1   DCBADD,R7
         STS,R1   OPNFPT,R7
         LW,R1    ANSBLK+3
         STW,R1   FPTCNCT,R7        SET CONCAT/SPARE LEST ANS
         LI,R1    TLBLSIZE          BYTE SIZE OF TLABEL
         SLS,R1   24                LABEL BUFFER
         STW,R1   TLABEL
         STW,R0   TLABEL+1          RESET RANDOM ID
INPUT1   EQU      %
*
         CI,SR2   2                 FPARAM OPTION INPUT DCB
         BAZ      INXTF             NO
         LI,R1    FPARAM            STORE FPARAM ADDRESS IN FPT
         AW,R1    R7
         STW,R1   FPTFPRM,R7
*
INXTF    CI,SR2   4                 NEXT FILE OPTION INPUT DCB
         BAZ      OPEN5             NO
         MTW,0    COPYPHY
         BNEZ     %+3               LABELED TAPE IN PHYS ORDER
         CI,R6    4
         BE       INXTF2            LABELED TAPE IN SORT ORDER
         LB,R2    FROMFILE          RANGE START SPECIFIED
         BEZ      INXTF2            NO
         LI,R3    X'FF00'           CLEAR CURRENT NAME
         STS,R2   VLPOPEN,R7
         LCI      4                 MOVE FROM FIELD TO ARG BUFFER
         LM,R1    FROMFILE
         STM,R1   ARGBUFF,R7
         LM,R1    FROMFILE+4
         STM,R1   ARGBUFF+4,R7
         LI,R1    1                 INDICATE FILE NAME
         BAL,SR4  STORVLP           PUT IN VLP
         B        OPEN5
INXTF2   EQU      %
INXTF3   LI,R1    X'400'            SET NXTF FLAG IN FPT
         STS,R1   OPNFPT+1,R7
*
OPEN5    CI,SR2   8                 INOUT MODE
         BAZ      OPEN1             NO
         MTW,3    FPTMODE,R7        SET  INOUT
         B        OPEN1
*
OUTPUT   EQU      %
         LI,R1    M:EO
         CAL1,1   RESETFPT          RESET M:EO DCB
NO%RESO  EQU      %
         LI,R1    M:EO
         STW,R1   DCBADD,R7
         STS,R1   OPNFPT,R7
         LW,R1    MODE+1,R7
         CW,R1    =X'00FF0000'      WAS EXP OPTION SPECIFIED
         BAZ      OUTPUTC           NO
         LCI      3
         LM,R1    EXPIRE,R7
         STM,R1   ARGBUFF,R7        PUT DATE IN ARGUMENT BUFFER
         LI,R1    5
         BAL,SR4  STORVLP           PUT ENTRY IN VLP
OUTPUTC  EQU      %
*
         LB,R3    M:EI+12
         STW,R3   FPTKMAX,R7        SET MAX KEY LENGTH
         LI,R3    X'F0'             SET OUTPUT ORGANIZATION TO THAT
         AND,R3   M:EI+5            OF INPUT ORGANIZATION
         SLS,R3   -4
         CI,R6    7
         BE       OUTPUTK           ANS TAPE
*
         CI,R3    3                 TEST IF RANDOM
         BNE      OUTPUT1           NO
         LW,R4    M:EI+20           RSTORE  FROM  DCB
         CI,R6    4                 GOING TO LABELED TAPE
         BNE      OUTPUT9           NO
         LCI      2
         LM,R2    RFILE
         STM,R2   TLABEL            PUT RANDOM ID IN TLABEL
         STW,R4   TLABEL+2          ENTER RLIM IN LABEL BUFFER
         B        OUTPUT8           LEAVE ORG CONSEC
OUTPUT9  EQU      %
         STW,R4   FPTRSTR,R7        SET RSTORE FOR RANDOM
OUTPUT1  EQU      %
         STW,R0   FPTTLBL,R7        NO LABEL IF NOT RANDOM
         CI,R6    5                 IS OUTPUT TO A DEVICE
         BG       OUTPUT8           YES
         LI,R1    3
         CW,R1    TOARG+5,R7        IS INPUT COMPRESSED
         BE       OUTPUT8           YES
         CW,R1    CODE,R7           IS OUTPUT COMPRESSED
         BE       OUTPUT8           YES, MAKE CONSEC
         LI,R1    X'A'              IS INPUT ANS
         CS,R1    M:EI
         BE       OUTPUT8           YES, OUTPUT IS CONSEC
         STW,R3   FPTORG,R7         NO, SET OUTORG TO INORG
         B        OUTPUT8
OUTPUTF  RES
         SLS,R3   -17               MOVE VALUE  TO REG
         AI,R5    -1                TO NEXT PARAMETER
         CS,R1    M:EI              IS   VALUE REAL
         BE       %+2               YES
         LI,R3    0                 NO
         MTW,0    ANSBLK,R5         IS THERE A USER SPECIFICATION
         BEZ      %+2
         LW,R3    ANSBLK,R5         YES, GET  IT
         AI,R3    0                 DO  WE HAVE ONE NOW
         BNEZ     %+2
         LW,R3    OUTPUTD,R5         NO,  GET DEFAULT
         STW,R3   ANSBLK,R5
         B        *SR4
OUTPUTD  DATA     2048              DEFAULT BLKSIZE
         DATA     128               DEFAULT RECSIZE
         DATA     4                 DEFAULT FMT (UNFORMATTED)
OUTPUTK  EQU      %
         STW,R0   FPTTLBL,R7        NO TLABEL FOR ANS OUT
         LI,R1    X'A'              TO CHECK INPUT DCB FOR ANS
         LI,R5    3                 R3 HAS INPUT FMT
         BAL,SR4  OUTPUTF+1         GET PROPER VALUE
         STW,R3   D4                SAVE IN D4
         LW,R3    M:EI+18           INPUT RECSIZE
         BAL,SR4  OUTPUTF
         STW,R3   R4
         LW,R3    M:EI+3            INPUT BLKSIZE
         BAL,SR4  OUTPUTF
         CI,D4    2                 CHECK COMBINATIION
         BANZ     OUTPUTE           VARIABLE RECS, ANYTHING IS OK
         BL       %+3
         LI,R4    1                 UNFORMATTED, SET BLKSIZE TO 0
         LI,R3    0
         LI,R2    0                 PREPARE TO DIVIDE
         DW,R2    R4
         LI,R1    54                ERROR CODE IF REMAINDER
         AI,R2    0
         BNEZ     ERRTN
         MW,R3    R4                RESTORE VALUE
OUTPUTE  STW,R3   FPTBLK,R7         SET BLKSIZE IN OPNFPT
         STW,R4   FPTLRCL,R7        RECSIZE
         STW,D4   FPTORG,R7         AND FMT
OUTPUT8  RES
         LW,R1    SEQUENCE,R7       TEST IF LN OR NLN SPECIFIED
         CI,R1    1
         BLE      OUTPUT2           NO
         BANZ     OUTPUT2           NO
         SLS,R1   -1
         STW,R1   FPTORG,R7         SET ORGANIZATION
         CI,R1    2                 TEST IF LN
         BNE      OUTPUT2           NO
         LI,R1    3
         STW,R1   FPTKMAX,R7        SET EDIT FILE KEYMAX
OUTPUT2  EQU      %
*
         LI,R1    4
         CW,R1    TOARG,R7          IS INPUT FROM LABEL TAPE
         BNE      OUTPUTA           NO
         LI,R3    7
         LI,R2    1
         CS,R2    OPNFPT+1,R7       IS OUTPUT TO A FILE
         BNE      OUTPUTA           NO
         LW,R1    TLABEL+1
         CW,R1    RFILE+1           IS FILE RANDOM
         BNE      OUTPUTA           NO
         LI,R1    3
         STW,R1   FPTORG,R7         SET RANDOM ORG
         LW,R1    TLABEL+2
         STW,R1   FPTRSTR,R7        SET FILE SIZE TOO
OUTPUTA  EQU      %
         CI,SR2   4
         BANZ     OUTPUT6           NXTF BIT SET
         LI,R2    2                 IF FILE OR LABEL OUT,
         LI,R3    X'F'              AND IN, CHECK FOR FPARAM
         CS,R2    OPNFPT+1,R7       MOVE
         BL       OPEN2             DEVICE OR ANS, NO MOVE
         CS,R2    M:EI
         BL       OPEN2             DITTO
         LW,R1    MODE+3,R7         TEST IF FA OR NFA SPECIFIED
         CI,R1    X'FF00'
         BAZ      OUTPUT4           NEITHER
         CI,R1    X'0300'
         BANZ     OUTPUT3           FA
         B        OPEN2             NFA
OUTPUT4  LI,R2    VLPOPEN+1
         AW,R2    R7                ADR OF FILE NAME IN VLP
         LB,R3    M:EI+23
         CB,R3    *R2               COMPARE M:EI AND M:EO FILE NAMES
         BNE      OPEN2
         LB,R1    M:EI+23,R3
         CB,R1    *R2,R3
         BNE      OPEN2
         BDR,R3   %-3
OUTPUT3  AI,SR2   2                 SAME - SET FPARAM BIT
OUTPUT6  EQU      %
         CI,SR2   2                 TRANSFER VLP TO OUTPUT DCB
         BAZ      OPEN2             NO
         PAGE
         LI,R1    1                 SET BYTE DISP. REG'S FOR VLP TRANS.
         LI,R2    2
         LI,R3    3
         LI,SR3   FPARAM            GET FPARAM ADDRESS
         AW,SR3   R7
         LI,SR4   15                IF NOT FILE/LABEL INPUT
         AND,SR4  M:EI              GET NAME FROM DCB(ANS)
         CI,SR4   3                 OR NOT AT ALL(DEVICE)
         BE       OPEN2
         BL       %+2
         LI,SR3   M:EI+22
*
TRANFP1  LI,SR4   VLPOPEN           VARIBLE LIST PARAMETER ADDRESS
         AW,SR4   R7
         LB,R4    *SR3              GET NEXT FPARAM CODE
         CI,R4    11                 IF SYNON, SET INOUT
         BNE      %+2
         MTW,4    FPTMODE,R7        SEE OPEN4 FOR EXCUSE FOR MTW,4
         CI,R4    7
         BE       TRANFP5           DONT TRANSFER SN
         CI,R4    4                 NAME-ACCT-PASS-EXPIRE
         BE       TRANFP5           DON'T MOVE EXPIRE
         BG       TRANFP2           NO
         CI,SR2   4                 NXTF OPTION GIVEN
         BAZ      TRANFP5           NO-DONT CHANGE N.A.P FROM COMMAND
*
TRANFP2  CB,R4    *SR4              FPARAM CODE = FPT CODE
         BE       TRANFP3           YES
         LB,R6    *SR4,R1           GET LEI OF FPT CODE
         STB,R0   *SR4,R1
         LB,R5    *SR4,R3           INCREMENT TO NEXT FPT ENTRY
         AW,SR4   R5
         AI,SR4   1
         CI,R6    0                 TEST FOR LAST ENTRY
         BE       TRANFP2           NOT LAST ENTRY
*
         LW,R4    *SR3              TRANSFER NEW CODE WORD TO END OF FPT
         STW,R4   *SR4
         STB,R1   *SR4,R1           SET LEI
         LB,R4    *SR3,R3
         B        TRANFP4           GO TRANSFER PARAMETER
*
TRANFP3  LB,R4    *SR4,R2           IS FPT ENTRY EMPTY
         BNEZ     TRANFP5           NO-DONT TRANSFER PARAMETER
         LB,R4    *SR3,R2           TRANSFER NO. OF SIGNIFICANT WORDS
         CB,R4    *SR4,R3           ROOM FOR THIS ENTRY
         BLE      %+2               YES
         LB,R4    *SR4,R3           NO-TRUNCATE DOWN TO WHATS AVIALIBLE
         STB,R4   *SR4,R2
TRANFP4  LW,R5    *SR3,R4           TRANSFER PARAMETER
         STW,R5   *SR4,R4
         BDR,R4   %-2
*
TRANFP5  LB,R4    *SR3,R1
         BNEZ     OPEN2             END OF FPARM LIST
         LB,R4    *SR3,R3           INCREMENT TO NEXT FPARAM ENTRY
         AW,SR3   R4
         AI,SR3   1
         B        TRANFP1
         PAGE
OPEN2    EQU      %
         LI,R1    TOVERABN          SET ABN FOR TO/INTO
         STW,R1   OPNFPT+4,R7
         LI,R3    X'E'              IF NOT TO FILE, SKIP ON TEST
         CW,R3    OPNFPT+1,R7
         BANZ     OPEN4
         CW,R3    M:EI
         BANZ     %+2               IF FILE IN, CLOSE TO PERMIT
         BAL,SR4  CLOSEI            REPLACEMENT
         LW,R1    TOVER,R7          IIF INTO, OPEN INOUT AND SPF
         CI,R1    18
         BE       OPENC
         MTW,0    J:JIT             BATCH MODE
         BGEZ     OPEN4             YES-NO ON-OVER TESTING
         CI,SR2   4                 COPYALL
         BANZ     OPEN4             YES-SKIP TO-OVER TESTING
         CI,R1    12                OVER SPECIFIED
         BE       OPEN4             YES, O.K.
         LW,R1    COPYSTDF,R7       COPYSTD
         BNEZ     OPEN4             YES - OK
         CAL1,1   OPNFPT,R7         OPEN IN
         XW,R1    OPNFPT+1,R7       NOW OPEN FOR REAL
         CAL1,1   OPNFPT,R7
         BAL,SR4  CLOSEO            FOUND IT IS THERE-CLOSE IT
         LI,R1    36
         B        ERRTN             GIVE UP
OPENC    LI,R1    4
         STW,R1   FPTMODE,R7
         CAL1,1   OPNFPT,R7
         CAL1,1   SPEOF
         B        OPEN3
SPEOF    GEN,8,24 X'1D',M:EO
         DATA     0
TOVERABN EQU      %
         STW,R1   OPNFPT+1,R7       RESTORE FLAGS WORD
         LB,R1    SR3
         CI,R1    3                 FILE NOT PRESENT
         BNE      IOERR1            NO-SOME OTHER PROBLEM
OPEN4    RES
         LI,R1    IOERR1
         STW,R1   OPNFPT+4,R7       RESTORE ABNORMAL ADDRESS
         LI,R3    2                 PROLLY OUTPUT MODE
         LW,R1    DEVICE,R7         DEVICE TYPE
         CI,R1    3                 OUTPUT TO RAD
         BE       %+3               YES
         CI,R1    5                 OUTPUT TO DP
         BNE      OPEN6             NO- SET OUTPUT MODE
         CI,SR2   4                 COPYALL TO RAD
         BAZ      OPEN6             NO-OPEN-OUT-MODE
         MTW,-1   FPTMODE,R7        ADDING A SYNONYM
         BEZ      OPEN6             NO, OPEN OUTPUT
         B        OPEN1             OPEN DCB FOR SYNONYM
OPEN6    EQU      %
         STW,R3   FPTMODE,R7
         PAGE
OPEN1    LW,R1    OPNFPT,R7         SAVE FIRST WORD FOR OPNNXT
         STW,R1   CMDBUF+1,R7
         LI,R1    6                 ADD DEVICE PART IF NOT TO FILE
         CW,R1    OPNFPT+1,R7
         BAZ      OPEN7             FILE, NO DEVICE INFO
         LI,R1    X'1000'           ADD DEVICE FLAG
         STS,R1   OPNFPT+1,R7
         LI,R1    VLPOPEN           FIND END OF VLPS
         AW,R1    R7
VLPSRCH  LI,R2    X'100FF'
         AND,R2   0,R1
         AW,R1    R2
         AI,R1    1
         CI,R2    X'10000'
         BAZ      VLPSRCH
         AI,R1    -X'10000'
         LW,R2    Y03               MAKE SPACE,BITS FPT
         STW,R2   0,R1
         LW,R3    =X'00360020'      BIN DEFAULT IF NOT SPECIFIED
         LW,R2    CODE,R7           CODE=4 IF FBCD(H)
         CI,R2    4
         BNE      %+2
         AI,R3    4                 SET ITS BIT
         LI,R4    X'FF'             GET PK/UPK
         AND,R4   MODE+3,R7
         BNEZ     NOBINBCD          BIN REQUIRED FOR PK/UPK
         LI,R2    MODE+MODE+MODE+MODE GET BIN/BCD
         LB,R2    *R7,R2
         AI,R2    -1                IS IT BCD
         BNEZ     %+2
         AI,R3    -X'20'            YES, RESET BIN BIT
NOBINBCD AI,R4    -6                IS IT UNPACKED
         BNEZ     %+2               NO
         AI,R3    X'10'             YES, SET ITS BIT
         LI,R2    MODE+MODE+MODE+MODE+12   GET SSP/DSP/VFC
         LB,R2    *R7,R2
         BNEZ     %+4
         CI,R6    9                 IF LP, FORCE SSP
         BNE      %+3               ZERO FOR OTHERS
         LI,R2    7
         AI,R2    -6                SSP=7,DSP=8,VFC=9
         STW,R2   1,R1              SET SPACING
         AI,R2    -3                UNLESS VFC
         BNEZ     %+3
         STW,R2   1,R1              REST SPACING
         AI,R3    2                 SET VFC
         STW,R3   2,R1
OPEN7    CAL1,1   OPNFPT,R7         DO ADJUST DCB CAL
         CI,D2    1                 IF NOT EXECUTING COMMAND
         BG       OPEN3             DONT OPEN
         LI,R1    X'F0FF'           KEEP ONLY NXTF BIT
         STS,R0   OPNFPT+1,R7       AND THEN OPN CAL
         CAL1,1   OPNFPT,R7
*
OPEN3    EQU      %
         CI,SR2   1
         BAZ      OPEN9             INPUT
         LW,R1    DEVICE,R7
         CI,R1    4                 IS DEVICE LT
         BE       OPENB
         CI,R1    6                 OR FT
         BNE      OPEN9             NO
OPENB    EQU      %
         MTW,0    DEVICE+1,R7       WAS SN SPECIFIED
         BNEZ     OPEN9             YES
         MTW,0    SCRATCH,R7        IS THIS 1ST OPEN FOR SCRATCH
         BNEZ     OPEN9             NO
         LW,R1    M:EOSN            GET SCRATCH SN
         STW,R1   SCRATCH,R7        SAVE SCRATCH SER NO
         DO       VERSION=2
         MTW,0    J:JIT
         BGEZ     OPEN9             BATCH MODE - SKIP MESSAGE
         STW,R1   PRTBUF+6,R7       OUTSN TO PRINT BUFFER
         LW,R1    =X'15000000'
         STW,R1   PRTBUF+7,R7       ADD CR
         LCI      6
         LM,R1    SERNO
         STM,R1   PRTBUF,R7         MOVE MESSAGE TO PRINT BUFFER
         LI,R1    PRTBUF
         AW,R1    R7                ADDRESS OF PRINT BUFFER
         CAL1,1   SNFPT             PRINT MESSAGE WITH SER NO
         USECT    PLSECT
SNFPT    GEN,8,24 X'11',M:UC
         DATA     X'34000010'
         PZE      *R1
         DATA     28                LENGTH
         DATA     1                 BTD
         USECT    BLDCB
         FIN
OPEN9    EQU      %
*
RETURN   LCI      7                 RESTORE REGISTERS
         PLM,R5   *R7
         B        *SR4
*
IOERR2   LW,R1    *R7
         STW,SR3  -1,R1             PUT ERROR ABNORMAL CODE IN
         B        RETURN            RETURNED SR3
*
IOERR1   LH,R1    IOABORTS          TERMINATE COPYALL/STD ON CERTAIN
         LH,SR4   SR3               ERRORS
         CH,SR4   IOABORTS,R1
         BNE      %+2
         LI,D2    3
         BDR,R1   %-3
         MTW,0    COPYSTDF,R7       IF COPYING MANY FILES,
         BLZ      IOERR2            RETURN ERROR IN SR3 ONLY
         CI,SR2   4                 WAS RANGE SPEC PRESENT
         BANZ     IOERR2
ERRTN    EQU      %
         BAL,SR4  ERROR
         B        IOERR2
*
STORVLP  RES
         LCI      2                 SAVE REGS
         PSM,R5   *R7
         LI,R2    -3                HANDY BYTE INDEXES
         LI,R3    3
         LI,R4    0                 INITIALIZE FOR LOOP
         LI,R6    VLPOPEN
         AW,R6    R7
         LH,R5    SVLP9,R1          GET CODE/SIZE
SVLP1    AW,R6    R4
         CB,R5    *R6               IS THIS IT
         BE       SVLP4
         LB,R4    *R6,R3            SIZE OF THIS ONE
         AI,R6    1
         MTB,0    *R6,R2            IS IT LAST
         BEZ      SVLP1             NO
         STB,R0   *R6,R2            YES, EXTEND
         AW,R6    R4                GET TO END
         LI,R2    X'10000'          SET FLAG
         STB,R5   R2                AND CODE
         STW,R2   0,R6
SVLP4    LW,R4    0,R6
         CI,R4    X'10000'          ONLY ADD TO THE LAST ONE
         BANZ     %+3               UNLESS THERE ARE NO ACTIVE WORDS
         CI,R4    X'FF00'           AS IN FILENAME
         BANZ     SVLP8
         AND,R5   %-2               SCRUB TO SIZE BYTE
         AW,R4    R5                INCREMENT ACTIVE ENTRIES
         LI,R3    2
         LB,R3    *R6,R3            COMPUTE WHERE TO PUT IT
         AW,R3    R6
         AI,R3    1
         SW,R3    R7                WILL IT FIT
         CI,R3    248+OPNFPT        MAX START
         BGE      SVLP8             NO
         AW,R3    R7
         XW,R4    0,R6
         SLS,R5   -8                INCR TOTAL ALSO IF NOT FILE
         CI,R5    8
         BE       %+2
         AWM,R5   0,R6
         LI,R2    ARGBUFF           SOURCE ADDR
         AW,R2    R7
         SLD,R2   2
         SLS,R5   2
         STB,R5   R3
         CI,R5    8                 IF ACCT OR SNS, NO TEXTC
         BG       %+2
         AI,R2    1
         MBS,R2   0
         LCI      2
         PLM,R5   *R7
         B        *SR4
SVLP8    LI,R1    40
         LCI      2
         PLM,R5   *R7
         B        ERROR
SVLP9    DATA,2   0,X'801'          FILE
         DATA,2   X'202'            ACCT
         DATA,2   X'203'            PASSWORD
         DATA,2   X'107'            SERIAL#S
         DATA,2   X'204'            EXPIRE
         DATA,2   X'205'            READ
         DATA,2   X'206'             WRITE
         DATA,2   X'214'            EXECUTE
         DATA,2   X'315'            VEHICLE
*
RFILE    DATA     X'0C000000'       TAPE HEADER FOR RANDOM FILE
         TEXT     'RFIL'
*                      E           A          BCD          BIN
MAXSN    EQU      50                MAX NUMBER OF SERIAL NUMBERS
*
         DO       VERSION=2
SERNO    TEXT     ' OUTPUT SERIAL NUMBER = '
         FIN
*                  CRPRDC   LTDPFTAT   MELPCPPP
DVASN    DATA     X'30301',X'2010305',X'3030303'
*
         BOUND    4
IOPNFPT  DATA     X'14000000',X'E000'  ADJUST DCB FPT
         DATA     X'D73D5C00'
         DATA     IOERR1            ERROR ADDRESS
         DATA     IOERR1            ABNORMAL ADDRESS
FPTD     CNAME
         PROC
LF       EQU      %-IOPNFPT+OPNFPT
         DATA     AF
         PEND
FPTBLK   FPTD     120               RECL OR BLKSIZE
FPTORG   FPTD     1                 ORG OR FMT..DFLT CONSEC
         DATA     2                 ACCESS..DIRECT
FPTMODE  FPTD     1                 MODE
FPTFPRM  FPTD     0                 FPARAM ADDRESS
FPTTLBL  FPTD     TLABEL            TAPE LA
FPTKMAX  FPTD     3                 MAX KEY LENGTH
FPTOPLB  FPTD     0                 DEVICE TYPE
FPTVOL   FPTD     1
FPTCNCT  FPTD     0                 CONCAT
FPTRSTR  FPTD     0                 RSTORE OR LRECL
FPTLRCL  EQU      FPTRSTR
FPTDEN   FPTD     0                 DENSITY
FPTCCF   FPTD     0                 CODE CONVERSION
*
VLPOPEN  EQU      %-IOPNFPT+OPNFPT  OPEN VLP POINTER
         DATA     X'1010008'        FILE NAME
         DATA     X'100000'
OPENSIZE EQU      %-IOPNFPT
M:EI     DSECT    1
         GEN,8,16,8      96,0,3     SIZE,0,ASSIGNMENT
         GEN,15,17       1,X'10'    FUN=IN,OP LABEL=EI
         DATA     X'0A000000'       10 RETRIES
         GEN,15,17       120,0      MAX RECORD SIZE
         DATA     0
         DATA     X'80000011'       SAVE,CONSECUTIVE,SEQUENTAIL
         DATA     M:EI+22           VFP LIST PRINTER
         DO1      3
         DATA     0
         DATA     KB                KEY BUFFER
         DO1      11
         DATA     0
         DATA     X'01000008'       FILE NAME
         DO1      8
         TEXT     '    '
         DATA     X'02000002'       ACCT. NUMBER
         DO1      2
         TEXT     '    '
         DATA     X'03000002'       PASS WORD
         DO1      2
         TEXT     '    '
         DATA     X'04000002'       EXPIRATION DATE
         DO1      2
         TEXT     '    '
* FOLLOWING ENTRY IS USED BY TESTFILE TO RETURN PERTINENT INFORMATION
* FOR FILES ON A REVIEW COMMAND.
         DATA     X'11000101'
         DATA     0
         DATA     X'0B000008'       SYNON
         DO1      8
         TEXT     '    '
         GEN,8,8,16 7,1,MAXSN       SN
M:EISN   RES      MAXSN
KB       EQU      %
         DO1      8                 KEY BUFFER
         TEXT     '    '
M:EO     DSECT    1
         GEN,8,16,8      96,0,3     SIZE,0,ASSIGNMENT
         GEN,15,17       2,X'11'    FUN=OUT,OP LABEL=EO
         DATA     X'0A000000'       10 RETRIES
         GEN,15,17       120,0      MAX RECORD SIZE
         DATA     0
         DATA     X'80000011'       SAVE,CONSECUTIVE,SEQUENTAIL
         DATA     M:EO+22           VFP LIST POINTER
         DO1      3
         DATA     0
         DATA     KBO               KEY BUFFER
         DO1      11
         DATA     0
         DATA     X'01000008'       FILE NAME
         DO1      8
         TEXT     '    '
         DATA     X'02000002'       ACCT. NUMBER
         DO1      2
         TEXT     '    '
         DATA     X'03000002'       PASS WORD
         DO1      2
         TEXT     '    '
         DATA     X'04000002'       EXPIRATION DATE
         DO1      2
         TEXT     '    '
         DATA     X'5000036'        MAX 27 ACCTS
         RES      54
         DATA     X'6000036'
         RES      54
         DATA     X'14000036'
         RES      54
         DATA     X'15000036'
         RES      54
         DATA     X'0B000008'       SYNON
         DO1      8
         TEXT     '    '
         GEN,8,8,16 7,1,MAXSN       SN
M:EOSN   RES      MAXSN
KBO      EQU      %
         DO1      8                 KEY BUFFER
         TEXT     '    '
F:STD    DSECT    1
         DATA     1                 FILE
         GEN,15,17 8,0              OUTIN
         GEN,8,24 10,0              10 RETURES
         DATA     0,0
         DATA     X'40000011'       REL,CONSEC,SEQUEN
         DO1      4                 NO VLPS
         DATA     0
         DATA     KBS               KEY BUFFER
         DO1      11
         DATA     0
KBS      EQU      %
         DO1      8                 KEY BUFFER
         TEXT     '    '
RESETFPT DSECT    1
         GEN,8,24   X'94',R1
         DATA     X'F000'
         DATA     0
         GEN,8,24 2,0
Y03      GEN,8,24 3,0
         GEN,8,24 4,0
         GEN,8,24 5,0
         GEN,8,24 6,0
         GEN,8,24 7,0
         GEN,8,24 20,0
         GEN,8,8,16 21,1,0
         GEN,1,1,1,1,1,1,1,1,1,23 1,0,1,1,1,1,1,1,1,0
         DO1      9
         DATA     0
         GEN,9,1,1,1,1,1,1,1,16   0,1,1,1,1,1,1,1,0
         DATA     0
         USECT    BLDCB
         END

