         TITLE    'PCLBD - BUILD DCBS, STORE VLP'
*
*        T E L E F I L E   P R O P R I E T A R Y   P R O D U C T
*
*        THIS DOCUMENT INCLUDES DATA AND INFORMATION CONSIDERED
*        PROPRIETARY TO TELEFILE COMPUTER PRODUCTS, INC.  REPRODUCTION,
*        DUPLICATION, DISCLOSURE OR DISSEMINATION, IN WHOLE OR IN PART,
*        TO OTHERS THAN REPRESENTATIVES OF THE UNITED STATES GOVERNMENT
*        SHALL NOT BE MADE WITHOUT PRIOR WRITTEN AUTHORIZATION OF
*        TELEFILE COMPUTER PRODUCTS, INC. NOTWITHSTANDING THE FORGOING,
*        USE OF THE DATA OR INFORMATION IN WHOLE OR IN PART FOR DESIGN,
*        PROCUREMENT OF MANUFACTURE IS STRICTLY FORBIDDEN.
*
*M*      BLDCB    BUILD INPUT OR OUTPUT DCB
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
R8       EQU      8
R9       EQU      9
R10      EQU      10
R11      EQU      11
R13      EQU      13
R15      EQU      15
         PAGE
         TITLE    'PCLBD - BUILD DCB'
         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*               STORVLP STORES A VARIABLE LENGTH PARAMETER IN THE
*P*               OPEN FPT.  THIS PARAMETER MAY BE NAME, ACCOUNT,
*P*               PASSWORD, INSN, OUTSN, READ ACCOUNT, WRITE ACCOUNT,
*P*               EXECUTE ACCOUNT, OR VEHICLE.
*P*
*P*
*
*DO*
*P*
* INPUT  (BLDCB)
*
*        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 (BLDCB)
*
*        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      IOABORTS          IO ERR/ABN GIVE UP CODES
         REF      DEVICE            ARGTBL ITEMS
         REF      FILE              ARGTBL ITEMS
         REF      MODE              ARGTBL ITEMS
         REF      NCHAR             GETARG ITEMS
         REF      CMBX              GETARG ITEMS
         REF      OUTBLK            RUNNING BLOCKING PARAMETERS
         REF      SIXBACK           UNCONVERT ANSSN
         REF      OPNFPT,FPARAM
         REF      CLOSEO,TOVER,M:UC
         REF      J:JIT
         REF      CODE
         REF      TLBLSIZE
         REF      SEQUENCE
         REF      TOARG
         REF      SFARG
         REF      OPNXFPT
         REF      COPYSTDF,ARGBUF4,TLABEL
         REF      EXTBL,RDTBL,WRTBL,UNTBL
         REF      CLOSEI
         REF      SCRATCH,PRTBUF
         REF      ARGBUFF
         REF      FROMFILE
         REF      COPYPHY
         REF      UNPRINT           THIS IS UNUSED - KGC
         REF      LTSTCMBX
         REF      INSER,OUTSER      FOR DEFAULT VOL#
         REF      ANSBLK
         REF      SIXPACK
         REF      EXPIRE
         REF      IN%ARG,OUT%ARG
*
BLDCB    DSECT    1
         DEF      M:EISN
         DEF      M:EOSN
         DEF      FPTOPLB           FOR SPE TO REOPEN
         DEF      BLKFIX            COLLECT BLOCKING INFORMATION
         DEF      MAXSN
*
         LI,R15   0                 CLEAR ERROR REGS
         LI,R10   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,R9    R1                SAVE I/O SWITCH
*
         LW,R6    DEVICE,R7         INITIALIZE FOR DEFAULT TABLE SEARCH
         LC       J:JIT             WHAT IS THIS FOR? - KGC
         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
         LW,R3    =X'80000'
         LW,R2    R9
         STS,R2   OPNFPT,R7         SET TESTFILE BIT IF PRESENT
         LW,R5    DEVICE+1,R7       TEST FOR REEL NO.S
         BNE      ADDRN3            PRESENT
         LI,R4    1
         AND,R4   R6
         LW,R2    SCRATCH,R4        IS SCRATCH TAPE IN USE
         BE       ADDFILE           NO
         LI,R5    1                 INDICATE ONE SER NO
         CI,R6    4
         BE       ADDRN5            LT
         CI,R6    7
         BE       ADDRN5            AT
         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
         LW,R3    SCRATCH+2,R4      GET RESOURCE TYPE TOO
         STW,R3   FPTOPLB,R7
         B        ADDRN4
ADDRN3   CI,R6    3
         BE       ADDFILE           STD FILE INPUT
ADDRN1   LI,R1    X'40006'          SERIAL # DELIMITERS
         BAL,R11  GETARG            GET REEL NO. ARGUMENT
         LW,R2    NCHAR,R7          TEST FOR NULL ARGUMENT
         BE       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,R11  SIXPACK           GO HASH 6-CHAR SN
         B        ADDRN5
*
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,R11  ERROR
         B        ADDFILE
ADDRN4   LI,R1    4                 SN=4
         BAL,R11  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    2                 GET SN COUNT THEREFROM
         LB,R1    R1,R2
         LI,R4    X'FF'             GET USERS VOL REQUEST
         AND,R4   MODE,R7
         BNE      ADDVOL6
         LW,R2    INSER             SEE IF WE CAN FIND A MATCH
         LW,R3    OUTSER            IN MOUNTED SNS AND VLP LIST
         CI,R9    1                 USE SAME MODE FIRST
         BAZ      %+2
         XW,R2    R3
         LW,R4    R1                NUMBER TO SEARCH
         BE       ADDFILE
         ANLZ,R11 ADDVOL2           ADDRESS OF SNS
         CW,R2    *R11,R4
         BE       ADDVOL6           GOT ONE
         BDR,R4   %-2
         LW,R4    R1
         CW,R3    *R11,R4
         BE       ADDVOL6
         BDR,R4   %-2
*
ADDFILE  LI,R5    1
         LW,R1    FILE+1,R7         TEST FOR FILE ARGUMENTS
         BE       ADDOPL
         STW,R1   CMBX,R7           SET CMBX OF FILE NAME
*
ADDFILE1 LI,R1    12
         BAL,R11  GETARG            GET ARGUMENT
         AI,R10   0                 RD OR WR ACCOUNTS
         BNE      ADDOPL5           YES
*
         LW,R2    NCHAR,R7          TEST FOR NULL ARGUMENT
         BE       ADDFILE2
         MTW,0    COPYSTDF,R7       IS THIS A STD FILE
         BLE      ADDFILEC          NO
         CI,R9    1                 OUPUT
         BANZ     ADDFILEC          YES
         CI,R5    2                 IS ARG AN ACCOUNT
         BG       ADDFILEC          NO, NOT FILE EITHER
         STW,R0   FILE+1,R7         CLEAR IF FILE
         BL       ADDFILEC          AND SET IF ACCOUNT
         LW,R1    LTSTCMBX
         STW,R1   FILE+1,R7
ADDFILEC LW,R1    R5
         BAL,R11  STORVLP           ADD FILE PARAMETER TO OPEN FPT
ADDFILE2 AI,R5    1
         CW,R5    FILE,R7
         BLE      ADDFILE1
         CI,R9    1
         BANZ     ADDOPL            OUTPUT
         CI,R5    2                 WAS ACCT SPECIFIED
         BG       ADDOPL            YES
         LW,R1    SFARG+3           WAS ACCT PRESENT ON COPYSTD
         BE       ADDOPL            NO
         STW,R1   CMBX,R7           POINT TO ACCT FOR COPYSTD
         B        ADDFILE1
*
ADDOPL   CI,R9    1
         BAZ      ADDOPL3           INPUT
         LI,R10   RDTBL+1           ADR OF RD ACCT TABLE
         LW,R8    RDTBL             ARE RD ACCTS PRESENT
         BNE      ADDOPL4           YES
ADDOPL8  LI,R10   WRTBL+1           ADR OF WR ACCT TABLE
         LW,R8    WRTBL             ARE WR ACCTS PRESENT
         BNE      ADDOPL4           YES
ADDOPLA  LI,R10   EXTBL+1           ADR OF EX ACCT TABLE.
         LW,R8    EXTBL             ARE WR ACCTS PRESENT.
         BNE      ADDOPL4           YES
ADDOPLB  LW,R8    UNTBL             ARE UN ACCTS PRESENT
         BE       ADDOPL3           VEHICLE ACCT NOT PRESENT.
         LI,R10   UNTBL+1
ADDOPL4  LW,R2    *R10              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
         BE       ADDOPL7           YES
         LI,R1    6                 CODE FOR READ ACCT
         CI,R10   RDTBL+1           ARE WE ADDING READ ACCTS
         BE       ST%VLP            YES.
         LI,R1    7                 CODE FOR WR ACCT.
         CI,R10   WRTBL+1           WRITE ACCTS
         BE       ST%VLP            YES
         LI,R1    8                 CODE FOR EXECUTE ACCT.
         CI,R10   EXTBL+1           ARE WE ADDING EXECUTE ACCOUNTS.
         BE       ST%VLP            YES
         LI,R1    9                 CODE FOR VEHICLE ACCT.
ST%VLP   BAL,R11  STORVLP           ADD RD OR WR ACCT TO OPEN FPT
ADDOPL7  BDR,R8   ADDFILE1          LOOP ON NUMBER OF ACCTS
         CI,R10   RDTBL+1           READ ACCT
         BE       ADDOPL8           YES - GO TEST FOR WR
         CI,R10   WRTBL+1           WRITE ACCOUNT?
         BE       ADDOPLA           YES--GO TEST FOR EX
         CI,R10   EXTBL+1           EXECUTE ACCOUNT
         BE       ADDOPLB           YES--GO TEST FOR UNDER
ADDOPL3  LI,R1    X'FF'
         AND,R1   MODE+1,R7         GET 7T/9T/ASCI/EBCD
         LW,R2    IN%ARG,R7
         CI,R9    1                 CHECK FOR INPUT.
         BAZ      %+2               INPUT.
         LW,R2    OUT%ARG,R7        LOAD OUTPUT DEVICE.
         AI,R2    0                 IF NONZERO, USE IT
         BNE      ADDOPL1
         LW,R2    FPTOPLB,R7        IF SCRATCH TAPE, RES IS HERE
         BNE      KGC0%4            SO DONT DEFAULT IT
         CI,R6    6                 IF FT, DEFAULT 9T
         BNE      %+2
         LI,R2    '9T'
KGC0%4   CI,R1    3                 IF NOT 7T, DEFAULT TO 9T
         BNE      ADDOPL1
         LI,R2    '7T'              BPM TYPE CODE IS X'8900'
ADDOPL1  STW,R2   FPTOPLB,R7        PUT OP LABEL IN FPT
ADDOPL2  AI,R1    -16               ASCII/EBCDIC
         BL       %+2               NOPE
         STW,R1   FPTCCF,R7         PUT AWAY
         LI,R1    X'2000'           CHECK FOR DENSITY OPTION
         CW,R1    MODE+1,R7
         BAZ      NXT%PAR1          YES.
         LW,R1    ANSBLK+4          DENSITY VALUE
         STW,R1   FPTDEN,R7         PUT IN FPT IF 800
NXT%PAR1 LB,R1    DVASN,R6          GET ASN
         CI,R1    3                 ONLY IF DEVICE SET DEVICE PART
         BNE      %+2               OF FPT
         AI,R1    X'1000'
         STS,R1   OPNFPT+1,R7       SET FILE OR LABEL EXISTANCE FLAG
         LW,R1    MODE,R7
         CI,R1    X'800'            WAS JOB SPECIFIED
         BAZ      %+2
         MTW,1    FPTDISP,R7        YES
*
         CI,R9    1                 CREATING INPUT DCB
         BANZ     OUTPUT            NO
         LI,R1    M:EI
         CAL1,1   RESETFPT          RESET M:EI DCB
         STS,R1   OPNFPT,R7
         LW,R1    OPNFPT,R7         SAVE FIRST WORD FOR OPNNXT
         STW,R1   OPNXFPT
         LI,R1    X'800'            CHECK FORR CAT OPTION
         CW,R1    MODE+1,R7
         BAZ      %+3
         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
         CI,R9    2                 FPARAM OPTION INPUT DCB
         BAZ      INXTF             NO
         LI,R1    FPARAM            STORE FPARAM ADDRESS IN FPT
         AW,R1    R7
         STW,R1   FPTFPRM,R7
         STW,R0   FPARAM,R7
*
INXTF    CI,R9    X'404'            CHECK NEXT FILE OPTION
         BAZ      OPEN5             NO
         MTW,0    COPYPHY
         BNE      %+3               LABELED TAPE IN PHYS ORDER
         CI,R6    4
         BE       INXTF2            LABELED TAPE IN SORT ORDER
         LH,R2    FROMFILE          RANGE START SPECIFIED
         CI,R2    X'FEFF'
         BAZ      INXTF2            NO, OR SAME AS NONE.
         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,R11  STORVLP           PUT IN VLP
         B        OPEN5
INXTF2   LI,R1    X'400'            SET NXTF FLAG IN FPT
         STS,R1   OPNFPT+1,R7
*
OPEN5    CI,R9    8                 INOUT MODE
         BAZ      OPEN1             NO
         MTW,3    FPTMODE,R7        SET  INOUT
         B        OPEN1
*
OUTPUT   LI,R1    M:EO
         CAL1,1   RESETFPT          RESET M:EO DCB
         LI,R1    M:EO
         STS,R1   OPNFPT,R7
         LW,R1    MODE,R7
         CI,R1    X'100'            WAS EXPIRE SPECIFIED
         BAZ      OUTPUTC           NO
         LCI      3
         LM,R1    EXPIRE,R7
         STM,R1   ARGBUFF,R7        PUT DATE IN ARGUMENT BUFFER
         LI,R1    5
         BAL,R11  STORVLP           PUT ENTRY IN VLP
OUTPUTC  LI,R3    3                 IF DEVICE, NONE OF THIS MATTERS
         CS,R3    OPNFPT+1,R7
         BE       OUTPUT8
         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
*
         LW,R4    M:EI+20           GET RSTORE FROM INPUT DCB
         LW,R2    TLABEL+1          UNLESS IS RANDOM ON LT
         CW,R2    RFILE+1
         BNE      %+3
         LI,R3    3                 RANDOM LT FILE, GET RSTORE
         LW,R4    TLABEL+2          FROM LABEL
         CI,R3    3                 TEST IF RANDOM
         BNE      OUTPUT1           NO
         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  STW,R4   FPTRSTR,R7        SET RSTORE FOR RANDOM
OUTPUT1  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  SLS,R3   -17               MOVE VALUE TO REG
         AI,R5    -1                TO NEXT PARAMETER
         LI,R1    X'A'              IS INPUT DCB ANS
         CS,R1    M:EI              IS VALUE REAL
         BNE      %+3
         CI,R6    7
         BE       %+2               YES
         LI,R3    0                 NO
         LI,R1    1                 IS THERE A USER SPECIFICATION
         SLS,R1   9,R5
         CW,R1    MODE+1,R7
         BAZ      %+2
         LW,R3    *R2,R5            GET IT
         AI,R3    0                 DO WE HAVE ONE NOW
         BNE      *R11
         LCI      8
         CI,R15   1                 CHECK FOR FMT(F)
         B        *R11
OUTPUTK  STW,R0   FPTTLBL,R7        NO TLABEL FOR ANS OUT
OUTPUT8  LI,R10   OUTPUTB           RETURN FROM BLKFIX
         LI,R2    ANSBLK            ADDR OF SPECIFICATIONS
BLKFIX   CI,R3    0                 SET 0 TO 1
         BNE      %+2
         LI,R3    1
         LI,R5    3                 R3 HAS INPUT FMT
         BAL,R11  OUTPUTF+1         GET PROPER VALUE
         BCR,8    KGC1%4
         CI,R6    7                 IS THIS ANS
         BNE      %+2
         LI,R3    4                 YES, SET U FMT FOR DEFAULT
KGC1%4   STW,R3   R15               SAVE IN D4
         LW,R3    M:EI+18           INPUT RECSIZE
         CI,R15   1                 IF NOT F FMT
         BE       %+2               DONT FIX THE RECORD SIZE
         LI,R3    0
         BAL,R11  OUTPUTF
         BNE      %+2               IF THERE OR FMT NOT F
         LI,R3    128               DONT SET REC
         STW,R3   R4
         LW,R3    M:EI+3            INPUT BLKSIZE
         BAL,R11  OUTPUTF
         BCR,8    %+2               IF NOT THERE,
         LI,R3    2048              SET DEFAULT BLKSIZE
         LI,R5    3                 SCRUB FMT TO NECESSARY PART
         AND,R5   R15               WHAT'S IN 15???? - KGC 5/14/85
         LI,R2    0                 SET = CCS
         CI,R15   1                 CHECK BLK/REC IF FMT(F)
         BNE      BLKFIXX
         DW,R2    R4
         LI,R1    54                ERROR CODE IF REMAINDER
         MW,R3    R4                RESTORE VALUE
BLKFIXX  AI,R2    0
         B        *R10
OUTPUTB  BNE      ERRTN             BAD BLK/REC FOR FMT(F)
         CI,R6    7                 IF NOT ANS, NO FPT VALUES
         BNE      KGC2%4
         STW,R3   FPTBLK,R7         SET BLKSIZE IN OPNFPT
         STW,R4   FPTLRCL,R7        RECSIZE
         STW,R15  FPTORG,R7         AND FMT
KGC2%4   LCI      3
         STM,R3   OUTBLK            SET VALUES FOR RDWRT
         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  CI,R9    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,R9    2                 SAME - SET FPARAM BIT
OUTPUT6  CI,R9    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,R10   FPARAM            GET FPARAM ADDRESS
         AW,R10   R7
         LI,R11   15                IF NOT FILE/LABEL INPUT
         AND,R11  M:EI              GET NAME FROM DCB(ANS)
         CI,R11   3                 OR NOT AT ALL(DEVICE)
         BE       OPEN2
         BL       %+2
         LI,R10   M:EI+22
         MTW,0    *R10              IF NO FPARAMS,
         BE       OPEN2             DONT MOVE THEM
*
TRANFP1  LI,R11   VLPOPEN           VARIABLE LIST PARAMETER ADDRESS
         AW,R11   R7
         MTB,0    *R10,R2           IS THERE ANYTHING HERE
         BE       TRANFP5           NO, SKIP IT
         LB,R4    *R10              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       KGC3%4            NOT NAME/ACCT/PSWD
         CI,R9    4                 NXTF OPTION GIVEN
         BAZ      TRANFP5           NO-DONT CHANGE N.A.P FROM COMMAND
         B        TRANFP2
KGC3%4   LW,R6    MODE+3,R7         CHECK FOR NFA OPTION
         CI,R6    X'400'
         BANZ     TRANFP5           YUP, INGORE ALL BUT N.A.P
         CI,R4    9                 IF FILE ATTRS, PUT IN FPT
         BNE      TRANFP2
         LW,R5    *R10,R2           GET LRDL0,SLIDES,SPARE
         SLS,R5   -8
         STW,R5   FPTNEWX,R7
         INT,R5   *R10,R2
         STW,R5   FPTSPARE,R7
*
TRANFP2  CB,R4    *R11              FPARAM CODE = FPT CODE
         BE       TRANFP3           YES
         LB,R6    *R11,R1           GET LEI OF FPT CODE
         STB,R0   *R11,R1
         LB,R5    *R11,R3           INCREMENT TO NEXT FPT ENTRY
         AW,R11   R5
         AI,R11   1
         CI,R6    0                 TEST FOR LAST ENTRY
         BE       TRANFP2           NOT LAST ENTRY
*
         LW,R4    *R10              TRANSFER NEW CODE WORD TO END OF FPT
         STW,R4   *R11
         STB,R1   *R11,R1           SET LEI
         LB,R4    *R10,R3
         B        TRANFP4           GO TRANSFER PARAMETER
*
TRANFP3  LB,R4    *R11,R2           IS FPT ENTRY EMPTY
         BNE      TRANFP5           NO-DONT TRANSFER PARAMETER
         LB,R4    *R10,R2           TRANSFER NO. OF SIGNIFICANT WORDS
         CB,R4    *R11,R3           ROOM FOR THIS ENTRY
         BLE      %+2               YES
         LB,R4    *R11,R3           NO-TRUNCATE DOWN TO WHATS AVAILABLE
         STB,R4   *R11,R2
TRANFP4  LW,R5    *R10,R4           TRANSFER PARAMETER
         STW,R5   *R11,R4
         BDR,R4   %-2
*
TRANFP5  LB,R4    *R10,R1
         BNE      OPEN2             END OF FPARM LIST
         LB,R4    *R10,R3           INCREMENT TO NEXT FPARAM ENTRY
         AW,R10   R4
         AI,R10   1
         B        TRANFP1
         PAGE
OPEN2    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,R11  CLOSEI            REPLACEMENT
         LW,R3    TOVER,R7          CHECK TO/OVER/INTO
         CI,R3    18
         BNE      %+3               NO INTO
         LI,R1    4
         STW,R1   FPTMODE,R7        INTO-TRY INOUT OPEN
         CI,R9    4                 COPYALL
         BANZ     OPEN4             YES-SKIP TO-OVER TESTING
         CI,R3    12                IS OVER SPECIFIED
         BE       OPEN4             YES, O.K.
         LW,R1    COPYSTDF,R7       COPYSTD
         BNE      OPEN4             YES - OK
         CAL1,1   OPNFPT,R7         OPEN IN
         XW,R1    OPNFPT+1,R7       NOW OPEN FOR REAL
         CAL1,1   OPNFPT,R7
         CI,R3    18                IF INTO AND FILE IS THERE,
         BE       KGC4%4            SPACE TO END
         BAL,R11  CLOSEO            FOUND IT IS THERE-CLOSE IT
         LI,R1    36
         B        ERRTN             GIVE UP
KGC4%4   CAL1,1   SPEOF
         B        OPEN3
*
SPEOF    GEN,8,24 28,M:EO
         DATA     0
*
TOVERABN STW,R1   OPNFPT+1,R7       RESTORE FLAGS WORD
         LB,R1    R10
         CI,R1    3                 FILE NOT PRESENT
         BNE      IOERR1            NO-SOME OTHER PROBLEM
OPEN4    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,R9    4                 COPYALL TO RAD
         BAZ      OPEN6             NO-OPEN-OUT-MODE
         MTW,-1   FPTMODE,R7        ADDING A SYNONYM
         BE       OPEN6             NO, OPEN OUTPUT
         B        OPEN1             OPEN DCB FOR SYNONYM
OPEN6    STW,R3   FPTMODE,R7
         PAGE
OPEN1    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'360030'        BIN,PK IS DEFAULT
         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+2,R7
         BNE      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
         BNE      %+2
         AI,R3    -X'20'            YES, RESET BIN BIT
NOBINBCD AI,R4    -6                IS IT UNPACKED
         BNE      %+2               NO
         AI,R3    -X'10'            YES, RESET PACKED BIT
         LI,R2    MODE+MODE+MODE+MODE+12   GET SSP/DSP/VFC
         LB,R2    *R7,R2
         BNE      KGC5%4
         CI,R6    9                 IF LP, FORCE SSP
         BNE      %+3               ZERO FOR OTHERS
         LI,R2    7
KGC5%4   AI,R2    -6                SSP=7,DSP=8,VFC=9
         STW,R2   1,R1              SET SPACING
         AI,R2    -3                UNLESS VFC
         BNE      %+3
         STW,R2   1,R1              RESET SPACING
         AI,R3    2                 SET VFC
         STW,R3   2,R1
         LI,R3    X'200'            FORCE EXCLUSIVE OPEN
         STS,R3   FPTMODE,R7
OPEN7    CAL1,1   OPNFPT,R7         DO ADJUST DCB CAL
         CI,R13   1                 IF NOT EXECUTING COMMAND
         BG       OPEN3             DONT OPEN
         LI,R1    X'F0FF'           KEEP ONLY NXTF BIT
         AND,R1   OPNFPT+1,R7       SAVE WHAT IT WAS
         STS,R0   OPNFPT+1,R7       AND THEN OPEN CAL
         CAL1,1   OPNFPT,R7
OPEN3    CI,R9    1
         BAZ      RETURN            INPUT
         LW,R1    DEVICE,R7
         CI,R1    4                 IS DEVICE LT
         BE       OPENB
         CI,R1    7                 OR AT
         BE       OPENB
         CI,R1    6                 OR FT
         BNE      RETURN            NO
OPENB    MTW,0    DEVICE+1,R7       WAS SN SPECIFIED
         BNE      RETURN            YES
         LI,R1    1
         AND,R1   DEVICE,R7
         MTW,0    SCRATCH,R1
         BNE      RETURN            NO
         LW,R2    M:EOSN
         STW,R2   SCRATCH,R1
         LW,R3    ='    '
         LW,R11   FPTOPLB,R7        GET RESOURCE TYPE
         STW,R11  SCRATCH+2,R1
         AI,R1    0
         BE       %+2               NO SIXBACK HERE.
         BAL,R11  SIXBACK
         AI,R3    X'1500'-'  '
         MTW,0    J:JIT
         BGE      RETURN            BATCH MODE - SKIP MESSAGE
         LCI      2
         STM,R2   PRTBUF+6,R7
         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
*
PLSECT   CSECT    1
SNFPT    GEN,8,24 X'11',M:UC
         DATA     X'34000010'
         PZE      *R1
         DATA     30                LENGTH
         DATA     1                 BTD
         USECT    BLDCB
RETURN   LCI      7                 RESTORE REGISTERS
         PLM,R5   *R7
         B        *R11
*
IOERR2   LW,R1    *R7
         STW,R10  -1,R1             PUT ERROR ABNORMAL CODE IN
         B        RETURN            RETURNED R10
*
IOERR1   LH,R11   R10               ERRORS
         CI,R11   X'5700'           TRY COPYALL RANDOMS DC AND DP
         BNE      IOERR3
         LI,R5    4                 IS IT COPYALL
         AND,R5   R9
         MW,R5    FPTRSTR,R7        AND RANDOM
         BE       IOERR3            NO.
         MTW,0    FPTOPLB,R7        HAVE WE TRIED OUR BEST
         BE       IOERR2            YES
         STW,R0   FPTOPLB,R7
         STS,R1   OPNFPT+1,R7       RESTORE FLAGS
         B        OPEN7
IOERR3   LH,R1    IOABORTS
         CH,R11   IOABORTS,R1
         BNE      %+2
         LI,R13   3
         BDR,R1   %-3
         MTW,0    COPYSTDF,R7       IF COPYING MANY FILES,
         BL       IOERR2            RETURN ERROR IN R10 ONLY
         CI,R9    4                 WAS RANGE SPEC PRESENT
         BANZ     IOERR2
ERRTN    BAL,R11  ERROR
         B        IOERR2
         PAGE
STORVLP  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
         BE       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       SVLP7             AND MAYBE *FILE
         AI,R2    1
SVLP6    MBS,R2   0
         LCI      2
         PLM,R5   *R7
         B        *R11
*
SVLP7    LW,R4    ARGBUFF,R7        CHECK FOR *N
         SLD,R4   -16
         CI,R4    X'25C'
         BNE      SVLP6             NOPE
         LW,R4    J:JIT             YUP, GET SYSID
         SLD,R4   -24
         MTB,3    R5
         STW,R5   ARGBUFF,R7
         B        SVLP6
SVLP8    LI,R1    40
         LCI      2
         PLM,R5   *R7
         B        ERROR
*                 LENGTH,VLPNO
SVLP9    DATA,2   0                 FILLER
         DATA,2   X'0801'           FILE NAME
         DATA,2   X'0202'           ACCOUNT
         DATA,2   X'0203'           PASSWORD
         DATA,2   X'0107'           SERIAL#S
         DATA,2   X'0204'           EXPIRE
         DATA,2   X'0205'           READ
         DATA,2   X'0206'           WRITE
         DATA,2   X'0214'           EXECUTE
         DATA,2   X'0315'           VEHICLE
*
RFILE    DATA     X'0C000000'       TAPE HEADER FOR RANDOM FILE
         TEXT     'RFIL'
*                      E           A          BCD          BIN
MAXSN    EQU      50                MAX NUMBER OF SERIAL NUMBERS
*
SERNO    TEXT     ' OUTPUT SERIAL NUMBER = '
*                  CRPRDC   LTDPFTAT   MELPCPPP
DVASN    DATA     X'30301',X'2010305',X'3030303'
*
         BOUND    4
IOPNFPT  DATA     X'14000000',X'E000'  ADJUST
         DATA     X'F77DDC00'
         DATA     IOERR1            ERROR ADDRESS
         DATA     IOERR1            ABNORMAL ADDRESS
FPTD     CNAME
         PROC
LF       EQU      %-IOPNFPT+OPNFPT
         DATA     AF
         PEND
         DATA     0                 BUFFER 0 FOR RDWRT TO KNOW ITS WORK
FPTBLK   FPTD     120               RECL OR BLKSIZE
FPTORG   FPTD     1                 ORG OR FMT..DFLT CONSEC
         DATA     2                 ACCESS..DIRECT
FPTMODE  FPTD     1                 MODE
FPTDISP  FPTD     2                 SAVE
FPTFPRM  FPTD     0                 FPARAM ADDRESS
FPTTLBL  FPTD     TLABEL            TAPE LA
FPTKMAX  FPTD     3                 MAX KEY LENGTH
FPTOPLB  FPTD     0                 DEVICE TYPE
FPTVOL   FPTD     1
FPTNEWX  FPTD     0
FPTCNCT  FPTD     0                 CONCAT
FPTSPARE EQU      FPTCNCT
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      DO1      8                 KEY BUFFER
         TEXT     '    '
F:STD    DSECT    1
         DATA     1                 FILE
         GEN,15,17 8,0              OUTIN
         GEN,8,24 10,0              10 RETRIES
         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'F005'           RESETS ALL DEVICE PARAMS UNLESS ANS ALREADY
         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 11,0
         GEN,8,24 20,0
         GEN,8,8,16 21,1,0
         DATA     X'4000000'        OPEN RESETS ALL BUT LINES/PAGE
         DATA     0
         USECT    BLDCB
         END
