*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      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      RDTBL,WRTBL
         REF      EXTBL,UNTBL
         REF      CLOSEI
         REF      SCRATCH,PRTBUF
         REF      ARGBUFF
         REF      FROMFILE
         REF      COPYPHY
         REF      UNPRINT
         REF      LTSTCMBX
         DEF      M:EISN
         DEF      M:EOSN
         DEF      FPTOPLB           FOR SPE TO REOPEN
         DEF      BLKFIX            COLLECT BLOCKING INFORMATION
         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
         LI,R4    1
         AND,R4   R6
         LW,R2    SCRATCH,R4        IS SCRATCH TAPE IN USE
         BEZ      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   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
         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,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    2                 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
         BDR,R4   %-2
         LW,R4    R1
         CW,R3    *SR4,R4
         BE       ADDVOL6
         BDR,R4   %-2
*
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,SR2   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 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    SFARG+3           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
         LW,R2    FPTOPLB,R7        IF SCRATCH TAPE, RES IS HERE
         BNEZ     %+4               SO DONT DEFAULT IT
         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
         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 EQU      %
         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
*
INPUT    CI,SR2   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
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
         STW,R0   FPARAM,R7
*
INXTF    CI,SR2   X'404'            CHECK NEXT FILE OPTION
         BAZ      OPEN5             NO
         MTW,0    COPYPHY
         BNEZ     %+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,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
         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,SR4  STORVLP           PUT ENTRY IN VLP
OUTPUTC  EQU      %
*
         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  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
         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
         BNEZ     *SR4
         LCI      8
         CI,D4    1                 CHECK FOR FMT(F)
         B        *SR4
OUTPUTK  EQU      %
         STW,R0   FPTTLBL,R7        NO TLABEL FOR ANS OUT
OUTPUT8  RES
         LI,SR3   OUTPUTB           RETURN FROM BLKFIX
         LI,R2    ANSBLK            ADDR OF SPECIFICATIONS
BLKFIX   RES
         CI,R3    0                 SET 0 TO 1
         BNE      %+2
         LI,R3    1
         LI,R5    3                 R3 HAS INPUT FMT
         BAL,SR4  OUTPUTF+1         GET PROPER VALUE
         BCR,8    %+4
         CI,R6    7                 IS THIS ANS
         BNE      %+2
         LI,R3    4                 YES, SET U FMT FOR DEFAULT
         STW,R3   D4                SAVE IN D4
         LW,R3    M:EI+18           INPUT RECSIZE
         CI,D4    1                 IF NOT F FMT
         BE       %+2               DONT FIX THE RECORD SIZE
         LI,R3    0
         BAL,SR4  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,SR4  OUTPUTF
         BCR,8    %+2               IF NOT THERE,
         LI,R3    2048              SET DEFAULT BLKSIZE
         LI,R5    3                 SCRUB FMT TO NECESSARY PART
         AND,R5   D4
         LI,R2    0                 SET = CCS
         CI,D4    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        *SR3
OUTPUTB  RES
         BNEZ     ERRTN             BAD BLK/REC FOR FMT(F)
         CI,R6    7                 IF NOT ANS, NO FPT VALUES
         BNE      %+4
OUTPUTE  STW,R3   FPTBLK,R7         SET BLKSIZE IN OPNFPT
         STW,R4   FPTLRCL,R7        RECSIZE
         STW,D4   FPTORG,R7         AND FMT
         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  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
         MTW,0    *SR3              IF NO FPARAMS,
         BEZ      OPEN2             DONT MOVE THEM
*
TRANFP1  LI,SR4   VLPOPEN           VARIBLE LIST PARAMETER ADDRESS
         AW,SR4   R7
         MTB,0    *SR3,R2           IS THERE ANYTHING HERE
         BEZ      TRANFP5           NO, SKIP IT
         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       %+4               NOT NAME/ACCT/PSWD
         CI,SR2   4                 NXTF OPTION GIVEN
         BAZ      TRANFP5           NO-DONT CHANGE N.A.P FROM COMMAND
         B        TRANFP2
         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    *SR3,R2           GET LRDL0,SLIDES,SPARE
         SLS,R5   -8
         STW,R5   FPTNEWX,R7
         INT,R5   *SR3,R2
         STW,R5   FPTSPARE,R7
*
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,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,SR2   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
         BNEZ     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       %+4               SPACE TO END
         BAL,SR4  CLOSEO            FOUND IT IS THERE-CLOSE IT
         LI,R1    36
         B        ERRTN             GIVE UP
         CAL1,1   SPEOF
         B        OPEN3
SPEOF    GEN,8,24 28,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    RES
         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
         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, RESET PACKED 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
         LI,R3    X'200'            FORCE EXCLUSIVE OPEN
         STS,R3   FPTMODE,R7
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
         AND,R1   OPNFPT+1,R7       SAVE WHAT IT WAS
         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    7                 OR AT
         BE       OPENB
         CI,R1    6                 OR FT
         BNE      OPEN9             NO
OPENB    EQU      %
         MTW,0    DEVICE+1,R7       WAS SN SPECIFIED
         BNEZ     OPEN9             YES
         LI,R1    1
         AND,R1   DEVICE,R7
         MTW,0    SCRATCH,R1
         BNEZ     OPEN9             NO
         LW,R2    M:EOSN
         STW,R2   SCRATCH,R1
         LW,R3    ='    '
         LW,SR4   FPTOPLB,R7        GET RESOURCE TYPE
         STW,SR4  SCRATCH+2,R1
         AI,R1    0
         BE       %+2               NO SIXBACK HERE.
         BAL,SR4  SIXBACK
         AI,R3    X'1500'-'  '
         MTW,0    J:JIT
         BGEZ     OPEN9             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
         USECT    PLSECT
SNFPT    GEN,8,24 X'11',M:UC
         DATA     X'34000010'
         PZE      *R1
         DATA     30                LENGHT
         DATA     1                 BTD
         USECT    BLDCB
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   RES
         LH,SR4   SR3               ERRORS
         CI,SR4   X'5700'           TRY COPYALL RANDOMS DC AND DP
         BNE      IOERR3
         LI,R5    4                 IS IT COPYALL
         AND,R5   SR2
         MW,R5    FPTRSTR,R7        AND RANDOM
         BEZ      IOERR3            NO.
         MTW,0    FPTOPLB,R7        HAVE WE TRIED OUR BEST
         BEZ      IOERR2            YES
         STW,R0   FPTOPLB,R7
         STS,R1   OPNFPT+1,R7       RESTORE FLAGS
         B        OPEN7
IOERR3   RES
         LH,R1    IOABORTS
         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       SVLP7             AND MEBBE *FILE
         AI,R2    1
SVLP6    RES
         MBS,R2   0
         LCI      2
         PLM,R5   *R7
         B        *SR4
*
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
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
         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      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'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

