* SIGMA 5/7 MERGE            CN705267
*  VERSION B00
         SYSTEM   SIG7FDP
         SYSTEM   BPM
SYSPROC  SET      1
*        CONVENTIONS
* 1. A RUN-TIME VARIABLE IS SPECIFIED AS (NAME,0) OR *NAME
* 2. AN INDEXED PARAMETER IS SPECIFIED AS (NAME,X)
* 3. AN INDEXED AND RUN-TIME PARAMETER IS (NAME,0,X)OR (*NAME,X)
* 4. REGISTERS 8-10 ARE VOLATILE AND MAY NOT BE SPECIFIED AS A
*     PARAMETER LOCATION.
*
* THE FOLLOWING COMMANDS ARE AVAILABLE:
*        BCDBIN   CONVERT EBCDIC NUMBER TO BINARY
*        BINBCD   CONVERT BINARY NUMBER TO EBCDIC
*        BLANK    SET MEMORY AREA TO BLANKS
*        BNOTCH   BRANCH IF MEMORY NOT SPECIFIED CHARACTER
*        BNOBLK   BRANCH IF MEMORY NOT BLANK
*        BNOTZR   BRANCH IF MEMORY NOT ZERO
*        COMPARE  COMPARE BYTE STRINGS
*        FILLCH   SET MEMORY AREA TO SPECIFIED CHARACTER
*        MOVE     MOVE A BYTE STRING
*        ZERO     SET MEMORY AREA TO ZERO
*
*  THE FOLLOWING GLOBAL SUB-ROUTINES MAY BE CALLED:
* @%CCVAL         GET CHARACTER COUNT VALUE INTO R10
* @%SVCO          SAVE CONDITION CODES
* @%RSTC          RESTORE CONDITION CODES
* @%INDR          TEST FOR INDIRECT BIT IN R10
* @%REVCO34       EXCHANGE CONDITION CODES 3-4
* @%OPCO          TEST FOR OP CODE IN WORD POINTED TO BY R10
*
*
         PAGE
R0       EQU      0                 SAVED                               0036B
R1       EQU      1                 SAVED
R2       EQU      2                 SAVED
R3       EQU      3                 SAVED
R4       EQU      4                 SAVED
R5       EQU      5                 SAVED
R6       EQU      6                 SAVED
R7       EQU      7                 SAVED
R8       EQU      8                 VOLATILE
R9       EQU      9                 VOLATILE
R10      EQU      10                LINK
R11      EQU      11                SAVED
R12      EQU      12                MAY
R13      EQU      13                    RECEIVE
R14      EQU      14                            DECIMAL
R15      EQU      15                                    OPERANDS
SR1      EQU      R8                                                    0051B
SR2      EQU      R9                                                    D05
SR3      EQU      R10                                                   0051F
SR4      EQU      R11                                                   0051H
         PAGE
         TITLE   'BUSINESS LANGUAGE PROCEDURES'                         0057B
         DO       SYSPROC
         DEF      PROG,DATA,ENSP,PROG2
PROG     CSECT    1                                                     0057D
  FIN
*
*        @%CCVAL -GET CHARACTER COUNT VALUE IN R10
*
* CALL:  BAL,R11  @%CCVAL
*
* INPUT:  R10=    ADDRESS OF CC PARAMETER
*
*        BCS,0    CCVALUE           EXPLICIT ONLY
*  OR    BCS,0    CCVALUE,X         EXPLICIT AND INDEXED                0061A
*  OR    BCS,0    *(CCADDR)         RUN-TIME ONLY
*  OR    BCS,0    *(CCADDR),X       RUN-TIME AND INDEXED
*
* OUTPUT: R10=    CC VALUE IN BITS 24-31  (MAX 255)
*
@%CCVAL  RES      0
         ANLZ,R10 *R10              CC VALUE + INDEX TO R10
         AND,R10  L(X'FF')          8 BITS ONLY
         B        *R11
*        @%INDR  -TEST FOR INDIRECT BIT IN R10
*
* CALL:  BAL,R11  @%INDR
*
* INPUT:  R10=    INSTRUCTION TO BE TESTED
*
* OUTPUT: R10=    UNDISTURBED
*         COND CODE 4 ON = BIT 0 ON
*
@%INDR   RES      0
         OR,R10   L(X'0')           SET COND CODE
         B        *R11
*        @%SVCO   SAVE CONDITION CODES
*        @%RSTC   RESTORE CONDITION CODES
* CALL:  BAL,R10  @%SVCO
*        BAL,R10  @%RSTC
* OUTPUT: COND CODES SAVED FOR PICKUP BY @%RSTC
*                                   NOTE: CODES ARE NOT STACKED
         OPEN     SAVE
@%SVCO   RES      0
         STCF     SAVE
         B        *R10
         DO       SYSPROC
DATA     CSECT    0                                                     0097B
  FIN
SAVE     DATA     0
         DO       SYSPROC
         USECT    PROG                                                  0098B
  FIN
@%RSTC   LCF      SAVE
         B        *R10
         CLOSE   SAVE
*        @%REVCO34- XCHANGE CONDITION CODES 3-4
*
* CALL:  BAL,R10  @%REVCO34
*
* OUTPUT: CONDITION CODES 3 AND 4 EXCHANGED
*
@%REVCO34 RES     0
         BE       *R10              NO CHANGE IF 3-4 = 00
         STCF     R9                STORE
         EOR,R9   L(X'30000000')    REVERSE
         LCF      R9                PICK UP
         B        *R10              RETURN
*        @%OPCO  - LOAD WORD POINTED AT BY R10 AND TEST FOR OP CODE BITS
*
* CALL:  BAL,R11  @%OPCO
*
* INPUT: R10 =    ADDRESS OF PARAMETER
*
* OUTPUT:R10 =    PARAMETER WORD
*        COND CODE 4 ON = BITS ON IN OP CODE 1-7
*
         OPEN     SAVE
@%OPCO   RES      0
         LW,R10   *R10              GET THE WORD
         STW,R10  SAVE
         AND,R10  L(X'7F000000')    CONDITION CODE 3 ON IF ANY MATCH
         STCF     R10
         BCR,2    %+2               IS CODES 3 ON
         OR,R10   L(X'80000000')    YES- FORCE BIT 0 AND CC4 ON         0131B
         XW,R10   SAVE              GET THE SUBJECT WORD
         LCF      SAVE              GET THE CONDITION CODE
         B        *R11
         DO       SYSPROC
         USECT    DATA                                                  0133B
  FIN
SAVE     DATA     0
         DO       SYSPROC
         USECT    PROG                                                  0134B
  FIN
         CLOSE   SAVE
         PAGE
IWD      SET      1,7,4,3,17        STANDARD INSTR WORD GEN PATTERN
BCRST    CNAME    X'68'              BRANCH COND RESET
BCST     CNAME    X'69'              BRANCH COND SET
DECM     CNAME    X'7D'              DECIMAL COMPARE
DELD     CNAME    X'7E'              DECIMAL LOAD
LDBY     CNAME    X'72'              LOAD BYTE
LDWD     CNAME    X'32'              LOAD WORD
PKDC     CNAME    X'76'              PACK DECIMAL
STWD     CNAME    X'35'              STORE WORD
ZRO      CNAME    X'0'               ZERO OP CODE
*        LDBY,8   AF(1)             SAMPLE CALL
         OPEN     P,IND                                                 0144A
         PROC
P        SET      AF                PASS LEVEL 0 AF DOWNWARD
IND     SET       NUM(P)=3|((NUM(P)>1)&P(2)=0)
LF       GEN,IWD  AFA(1)|IND,NAME,CF(2),P(2)+P(3),P(1)
         PEND
         CLOSE    P,IND                                                 0150A
TRMS     CNAME                      CHECK PARAMS FOR SPECIFIED NO. TERMS
         OPEN     P,I,ALL,EACH
         PROC
P        SET      CF(2)             P= USERS AF
ALL      SET      NUM(P)>NUM(AF)    ERR IF USER HAS TOO MANY PARAMETERS
EACH     SET      0                                                     0156A
* TEST EACH PARAMETER FOR MIN-MAX NUMBER OF TERMS
I        DO       NUM(AF)
EACH     SET      EACH|(NUM(P(I))<AF(I,1))|(NUM(P(I))>AF(I,2))
         FIN
         ERROR,X'A',(ALL|EACH) 'LEVEL A- NUMBER OF PARAMETERS'          0162B
         PEND
         CLOSE    P,I,ALL,EACH
         SPACE    2                                                     0170B
VAL      CNAME    X'69'             GENERATE VALUE PARAMETER (CC)
*        VAL,1,255  AF(2)           IF EXPLICIT, RANGE IS 1-255         0165A
*        VAL,0,10   AF(1)           IF EXPLICIT, RANGE IS 0-10          0165B
         OPEN     P,IND,RNGE                                            0165C
         PROC                                                           0165D
P        SET      AF                P = CALLERS AF                      0165E
IND      SET      AFA(1)|NUM(P)=3|((NUM(P)>1)&P(2)=0)  RUN-TIME CC?     0165F
         DO       IND=0             CHECK EXPLICIT CC                   0171B
RNGE     SET      CF(2),CF(3)       MIN-MAX OF EXPLICIT CC              0165G
         ERROR,7,P(1)<RNGE(1)|P(1)>RNGE(2) 'LEVEL 7 - EXPLICIT ';       0165H
                                              ,'VALUE OUT OF RANGE'     0174B
         FIN                                                            0174D
* BUILD THE WORD                                                        0165J
LF       GEN,IWD  IND,NAME,,P(2)+P(3),P(1)                              0165K
         PEND                                                           0165L
         CLOSE    P,IND,RNGE                                            0165M
         TITLE   'BUSINESS LANGUAGE PROCEDURES'
         PAGE                                                           0188B
*        BCDBIN   CONVERT EBCDIC NUMBER TO BINARY
BCDBIN   CNAME
         OPEN     QUIT,A
         PROC
A        SET      AF                                                    0192B
         TRMS,(AF) (1,3),(1,3),(0,3) E2 MAY BE NULL                     0194B
LF       BAL,R10  @%EBCBN           TO SUB-ROUTINE
         LDBY,R8  AF(1)             BYTE OP + E1 ADDRESS
         VAL,1,10 AF(2)             BUILD CC
         GOTO,NUM(A)<3   QUIT       IF E2 NULL
         STWD,R9  AF(3)             STORE BINARY NUMBER INTO E2
QUIT     PEND                                                           0193B
         CLOSE    QUIT,A
* CONVERSION SUB-ROUTINE
         OPEN     SAVE,GETBYT,ERR
@%EBCBN  RES      0
         STD,R10  SAVE              SAVE R10-11
         ANLZ,R8  *R10              GET E1 BYTE ADDR IN R8
         AI,R10   1                 TO CC PARAM ADDR
         STW,R10  SAVE              SAVE CURRENT PARAM ADDR
         BAL,R11  @%CCVAL           GET CC IN R10
         XW,R8    R1                BYTE POINTER TO INDEX
         LI,R9    0
GETBYT   RES      0
         LB,R11   0,R1              GET BYTE IN R11
         AI,R1    1                 UPDATE TO NXT BYTE
         AND,R11  L(X'F')           DROP ZONE
         CLR,R11  L(X'9')           TEST 0-9
         BG       ERR               COND CODE 1 ON = ERROR
         MI,R9    10                COMPUTE BIN EQUIV OF PREV DIGIT     0217B
         BOV      ERR               COND CODE 2 ON = ERROR
         AW,R9    R11               ADD CURRENT DIGIT TO PREV
         BDR,R10  GETBYT            ANY MORE LEFT?
         MTW,1    SAVE              UPDATE RETURN ADDR
         STW,R8   R1                RESTORE R1
ERR      RES      0
         LW,R11   SAVE+1            RESTORE R11, PRESRVNG COND CO 1-2
         LW,R9    R9                SET CC3,4 FOR CONVERTED VALUE
         B        *SAVE
         DO       SYSPROC
         USECT    DATA
  FIN
         BOUND    8
SAVE     DATA     0,0
         DO       SYSPROC
         USECT    PROG                                                  0227F
  FIN
         CLOSE    SAVE,GETBYT,ERR
         PAGE
*        BINBCD   CONVERT BINARY NUMBER TO EBCDIC
BINBCD   CNAME
         OPEN     A                                                     0236A
         PROC                                                           0236B
        TRMS,(AF) (1,3),(1,3),(1,3) CHECK NUMBER OF PARAMETERS          0238B
LF       BAL,R10  @%BINEBC          TO CONVERSION SUB-ROUTINE           0236E
         VAL,1,10 AF(3)             BUILD CC
         LDWD,R9  AF(1)             GEN E1 WITH WORD OP
         LDBY,0   AF(2)             GEN E2 WITH BYTE OP
         PEND                                                           0236I
         CLOSE    A                                                     0236J
* CONVERSION SUB-ROUTINE
         OPEN     CONVERT,QUIT,LDZRO,LDZRORTN
@%BINEBC RES      0
         STD,R10  SAVE              R10-11
         BAL,R11  @%CCVAL           GET CC IN R10
         MTW,1    SAVE              BUMP PARAM ADDRESS POINTER
         EXU      *SAVE             DO LOAD OF E1
         MTW,1    SAVE              BUMP PARAM ADDRESS POINTER
         ANLZ,R11 *SAVE             GET E2 BYTE DISPLACEMENT
         STD,R10  SVETO             SAVE LENGTH AND ADDRESS TO BLANK
         MTW,-1   SVETO             SET NOT BLANK UNITS POSITION
         OR,R10   L(X'0')           TEST STRING LENGTH
         BEZ      QUIT              GO HOME IF ZERO LENGTH
         AW,R11   R10               GET E2 END +1
         XW,R11   R1                DESTINATION TO INDEX
CONVRT   AI,R1    -1                POINT TO RECEIVING BYTE
         LI,R8    0                 BINARY VALUE IN R9
         DW,R8    L(10)             REMAINDER IS LEAST SIGNIF DIGIT     0258B
         OR,R8    L(X'F0')          FORCE ZONING
         STB,R8   0,R1              TO DESTINATION STRING
         BDR,R10  CONVRT            ANY DIGITS LEFT IN STRING?
         STW,R11  R1                RESTORE R1                          0261B
         LD,R10   R4                SAVE DURING BLANKING
         LD,R4    SVETO             GET LENGTH & ADDRESS TO BLANK
         STW,R9   SVETO             SAVE OVERFLOW CONDITION
         LI,R9    C' '              SET BLANK FOR REPLACING
LDZRO    LB,R8    0,R5              GET NEXT BYTE
         CI,R8    C'0'              IF LEAD ZERO BLANK IT
         BNE      LDZRORTN
         STB,R9   0,R5
         AI,R5    1                 INCRIMENT TO NEXT BYTE
         BDR,R4   LDZRO             IF MORE RELOOP
LDZRORTN LD,R4    R10               RESTORE
QUIT     MTW,1    SAVE              UPDATE RETURN ADDRESS
         LD,R10   SAVE              RESTORE R10-11
         LW,R9    SVETO             RESTORE OVERFLOW
         B        *R10
         DO       SYSPROC
         USECT    DATA                                                  0266B
  FIN
         BOUND    8                                                     0266C
SAVE     DATA     0,0
         DO       SYSPROC
         USECT    PROG                                                  0266F
  FIN
         CLOSE    CONVERT,QUIT,LDZRO,LDZRORTN
         PAGE
*        FILLCH   SET MEMORY AREA TO SPECIFIED CHARACTER
*        ZERO     SET MEMORY AREA TO ZEROS
*
ZERO     CNAME    X'0'
FILLCH   CNAME    X'1'                                                  0271B
         OPEN     C,IND,LIT
         PROC
         DO       NAME=1            IF FILLCH                           0274B
         TRMS,(AF) (1,3),(1,3),(1,1)  FILL CHARACTER IS REQUIRED        0283B
C        SET      AF(3)                                                 0274F
         ELSE                                                           0274H
         TRMS,(AF) (1,3),(1,3)        3RD TERM IS IMPLIED               0286B
C        SET      NAME                                                  0274L
         FIN                                                            0274N
* DETERMINE IF E1 AND CC ARE EXPLICIT ONLY
IND      SET      AFA(1)|NUM(AF(1))>1|AFA(2)|NUM(AF(2))>1
         DO       IND               USE ELSE IF NO INDX OR RUN-TIME
* GENERATE SUB-ROUTINE LINK
LF       BAL,R10  @%CHMVE
         LDBY,0   AF(1)             BYTE OP + E1 ADDR
         VAL,1,255 AF(2)            GEN CC
         MBS,0    BA(L(C))+3        MOVE FILL CHARACTER
*                                   END SUB-ROUTINE LINK
         ELSE                       IN-LINE CODE GENERATOR
LF       STW,R1   R8                SAVE R1
LIT      SET      (AF(2)**24)+BA(AF(1))  CC TO BIT 0-7: E1 TO BIT 13-31
         LW,R1    L(LIT)
         MBS,0    BA(L(C))+3        MOVE BYTE STRING                    0295A
         STW,R8   R1                RESTORE R1
         FIN
         PEND
         CLOSE    C,IND,LIT
* CHARACTER MOVE SUB-ROUTINE
         OPEN     SAVE
@%CHMVE  RES      0
         STD,R10  SAVE              SAVE R10-11
         BAL,R11  @%CHCOM           SET UP AND DO THE MBS OPER
         LD,R10   SAVE
         AI,R10   3                 UPDATE RETURN ADDRESS
         B        *R10
         DO       SYSPROC
         USECT    DATA                                                  0320B
  FIN
         BOUND    8                                                     0320C
SAVE     DATA     0,0
         DO       SYSPROC
         USECT    PROG                                                  0320F
  FIN
         CLOSE   SAVE
* A COMMON ROUTINE IS USED BY ZERO,BLANK,FILLCH,BNOTCH AND BNOTZR
*   TO PERFORM THE REQUIRED BYTE STRING OPERATION:
*R8 WILL CONTAIN THE CONDITION CODES SET BY THE BYTE OPERATION
         OPEN     SVETO
@%CHCOM  RES      0
         STD,R10  SVETO
         ANLZ,R9  *R10              GET DEST BYTE ADDRESS
         AI,R10   1                 POINT TO CC PARAMETER
         BAL,R11  @%CCVAL           GET CC IN R10
         SLS,R10  24                LEFT JUSTIFY                        0333B
         OR,R9    R10               MERGE WITH DESTINATION
         XW,R1    R9
         MTW,2    SVETO             TO ACTUAL BYTE OPERATION
         EXU      *SVETO            DO IT
         STCF     R8                SAVE CONDITION CODES
         STW,R9   R1                RESTORE R1
         B        *SVETO+1          RETURN TO CHMVE OR CHCMP
         DO       SYSPROC
         USECT    DATA                                                  0339B
  FIN
         BOUND    8
SVETO    DATA     0,0
         DO       SYSPROC
         USECT    PROG                                                  0341B
  FIN
         CLOSE    SVETO
         PAGE
*        BNOBLK   BRANCH IF MEMORY AREA NOT BLANK
*        BNOTCH   BRANCH IF MEMORY AREA NOT SPECIFIED CHARACTER
*        BNOTZR   BRANCH IF MEMORY AREA NOT ZERO
*
BNOBLK   CNAME    X'40'
BNOTCH   CNAME    X'1'                                                  0331B
BNOTZR   CNAME    X'0'
         OPEN     C
         PROC
         DO       NAME=1            IF BNOTCH                           0335B
         TRMS,(AF) (1,3),(1,3),(1,3),(1,1)  COMPARE CHARACTER REQUI     0357B
C        SET      AF(4)                                                 0335F
         ELSE                                                           0335H
         TRMS,(AF) (1,3),(1,3),(1,3)  4TH TERM IS IMPLIED               0360B
C        SET      NAME                                                  0335L
         FIN                                                            0335N
* GENERATE SUB-ROUTINE LINK
LF       BAL,R10  @%CHCMP
         LDBY,0   AF(2)             BYTE OP + E2 ADDRESS
         VAL,1,255 AF(3)            GEN CC
         CBS,0    BA(L(C))+3        COMPARE BYTE STRING                 0341B
         BCST,3   AF(1)             BRANCH NOT EQ TO E1
         PEND
         CLOSE    C
* THE CHARACTER COMPARISON SUB-ROUTINE IS:
         OPEN     SAVE
@%CHCMP  RES      0
         STD,R10  SAVE              SAVE R10-11
         BAL,R11  @%CHCOM           SET UP AND DO THE CBS OPER
         LD,R10   SAVE              RESTORE R10-11
         AI,R10   3                 POINT TO BNE
         LCF      R8                CONDITION CODES LEFT BY CHCOM
         B        *R10
         DO       SYSPROC
         USECT    DATA                                                  0376B
  FIN
         BOUND    8
SAVE     DATA     0,0
         DO       SYSPROC
         USECT    PROG                                                  0378B
  FIN
         CLOSE    SAVE
         PAGE
*        COMPARE  COMPARE 2 BYTE STRINGS
*
*  SEE MOVE PROCEDURE
         PAGE
*        MOVE     MOVE BYTE STRING
*        COMPARE  COMPARE BYTE STRING
MOVE     CNAME    X'61'
COMPARE  CNAME    X'60'
         OPEN     A,LIT,IND
         PROC
A        SET      AF                A = CALLERS AF
        TRMS,(AF) (1,3),(1,3),(1,3) VERIFY NUMBER OF PARAMETERS         0451B
* DETERMINE IF ANY RUN-TIME OR INDEXED VALUES
IND      SET      AFA(1)|NUM(A(1))>1|AFA(2)|NUM(A(2))>1|AFA(3)|;
                                                       NUM(A(3))>1      0545A
         DO       IND               USE ELSE IF NO INDX OR RUN-TIME
* GENERATE A SUB-ROUTINE LINK
LF       BAL,R10  @%MVEBY
         LDBY,0   AF(1)             BYTE OP + E1 ADDRESS
         LDBY,0   AF(2)             BYTE OP + E2 ADDRESS
         VAL,1,255 AF(3)            GEN CC
         GEN,IWD  0,NAME,R8,0,0     MBS OR CBS
*                                   END SUB-ROUTINE LINK
         ELSE
* GENERATE IN-LINE CODE
LIT      SET      (AF(3)**24)+BA(AF(2))  CC TO BIT 0-7: E1 TO BIT 13-31
LF       LW,R9    L(LIT)
         GEN,1,7,4,20  0,NAME,R9,BA(A(1))-BA(A(2))                      0559A
         FIN                                                            0559B
         PEND
         CLOSE    A,LIT,IND
* THE MOVE-COMPARE SUB-ROUTINE IS:
         OPEN     SAVE
@%MVEBY  RES      0
         STD,R10  SAVE
         ANLZ,R8  *SAVE             E1 ADDR TO R8
         MTW,1    SAVE              BUMP POINTER
         ANLZ,R9  *SAVE             E2 ADDR TO R9
         MTW,1    SAVE              BUMP POINTER
         LW,R10   SAVE
         BAL,R11  @%CCVAL           GET CC IN R10
         SLS,R10  24                LEFT JUSTIFY IN 0-7
         OR,R9    R10               MERGE WITH E2 ADDRESS
         LD,R10   SAVE              RESTORE R10-11
         AI,R10   1                 POINT TO BYTE STRING COMMAND
         B        *10               EXECUTE IT
         DO       SYSPROC
         USECT    DATA                                                  0488B
      FIN
         BOUND    8
SAVE     DATA     0,0
SVETO    DATA     0,0
         DO       SYSPROC
         USECT    PROG                                                  0490B
      FIN
         CLOSE    SAVE
         TITLE    'RESIDENT VARIABLE WORK AREA     *****  MCTBL  *****'
         PAGE
MCTBL    EQU      ERMS1                                                 0MG00350
         DEF      MERGE
         SREF     MINHED,MINTRL,MINUSO,MOUHED,MOUTRL,MOUSO
ERMS1    TEXT     'MERGE SUCCES',;  PART 1 OF OUTPUT MESSAGES KEYED BY  0MG00500
                  'MERGE ERROR ',;  BITS 1 AND 2 OF BYTE MESSAGE CODE   0MG00600
                  'MERGE ABORT ',;  12 CHARACTERS OF A LINE             0MG00700
                  'MERGE FILE: '
         USECT    DATA
ERMS2    TEXT     'SFULLY COMPLETED',;       PART 2 OF OUTPUT MESSAGE   0MG00800
                  'OUTPUT/WRITE',;
                  'INPUT/READ',;
                  'INPUT SEQUENCE',;                                    0MG01200
                  'ILLEGAL DECIMAL DIGIT',;                             0MG01300
                  'SPECIFICATION CARD FIELD:  ',;
                  'MEMORY ALLOCATION OVERFLOW',;                        0MG02600
                  'MERGE PROGRAM ERROR',;                               0MG02700
                  ' ',;                                                 0MG02800
                  'OPENING',;
                  'LABEL I/0 TRANSFER',;
                  '0, RECORDS: 0000000000'
*****     CHANGES TO ERMS3 MAY AFFECT MERGE2 AT PH:II & ??
ERMS3    TEXT     'NUMBER OF INPUT FILES',;                             0MG04400
                  'LOGICAL RECORD LENGTH',;                             0MG04500
                  'INPUT BLOCKING',;                                    0MG04600
                  'OUTPUT BLOCKING',;                                   0MG04700
                  'UNREADABLE RECORD DROPS',;                           0MG04800
                  'OUT OF SEQUENCE DROPS',;                             0MG04900
                  'ILLEGAL DECIMAL KEY DROPS',;                         0MG05000
                  'NUMBER OF MERGE KEYS',;                              0MG05100
                  ' PAGES REQ.: 00000, AVAIL.: 00000',;
                  ' FILE: 0',;
                  'IHDR FIELD NOT BLANK,F, OR 1-9',;
                  'OUTPUT RECORD LENGTH'
*****    DONOT CHANGE THE ORDER OF OR INSERT ANYTHING IN THE FOLLOWING:
WKFL     DATA     0                 NUMBER OF INPUT FILES
WKLN     DATA     0                 RECORD LENGTH
WKBI     DATA     0                 INPUT  BLOCKING
WKBO     DATA     0                 OUTPUT BLOCKING
WKDR     DATA     0                 DROPS UNREADABLE
WKDS     DATA     0                 DROPS SEQUENCE
WKDD     DATA     0                 DROPS DECIMAL KEY
WKUIH    DATA     0                 FLAG USER HEADER INPUT
WKUOH    DATA     0                 FLAG USER HEADER OUTPUT
WKUIT    DATA     0                 FLAG USER TRAILER INPUT
WKUOT    DATA     0                 FLAG USER TRAILER OUTPUT
WKUIC    DATA     0                 FLAG USER OWN CODE INPUT
WKUOC    DATA     0                 FLAG USER OWN CODE OUTPUT
WINBF    DATA     0                 BUFFER FACTOR INPUT
WOTBF    DATA     0                 BUFFER FACTOR OUTPUT
WKONINS  DATA     0                 BLOCK SIZE INPUT
WKONOTS  DATA     0                 BL6CK SIZE OUTPUT
WKTPLC   DATA     0                 TOP OF LOCBLK
WKTPIN   DATA     0                 TOP OF INSRT
WRAPFLG  DATA     0                 PUTOUT EOV FLAG
*****    DONOT CHANGE THE ORDER OF OR INSERT ANYTHING IN THE ABOVE:
*****
*****    BUFFERS AND LOCBLK ARE ORDERED AS FOLLOWS:
*****    FILE: OUT     LOCBLK ENTRY: 0    LOCBLK WORDS: 00 TO 07
*****    FILE: IN1     LOCBLK ENTRY: 1    LOCBLK WORDS: 08 TO 15
*****    FILE: IN2     LOCBLK ENTRY: 2    LOCBLK WORDS: 16 TO 23
*****    FILE: IN3     LOCBLK ENTRY: 3    LOCBLK WORDS: 24 TO 31
*****    FILE: IN4     LOCBLK ENTRY: 4    LOCBLK WORDS: 32 TO 39
*****    FILE: IN5     LOCBLK ENTRY: 5    LOCBLK WORDS: 40 TO 47
*****    FILE: IN6     LOCBLK ENTRY: 6    LOCBLK WORDS: 48 TO 55
*****    FILE: IN7     LOCBLK ENTRY: 7    LOCBLK WORDS: 56 TO 63
*****    FILE: IN8     LOCBLK ENTRY: 8    LOCBLK WORDS: 64 TO 71
*****    FILE: NULL    LOCBLK ENTRY: 9    LOCBLK WORDS: 72 TO 79
*****
*****    LOCBLK ENTRIES ARE ORDERED AS FOLLOWS:
*****    WORD 0:     CURRENT RECORD ADDRESS-BYTE
*****    WORD 1:     DCB ADDRESS-WORD
*****    WORD 2:     BLOCK 1 ADDRESS-BYTE
*****    WORD 3:     BLOCK 2 OR NEXT BLOCK 1(IF UNBUFFERED) ADDRESS-BYTE
*****    WORD 4:     FLAGS     BYTE 0:   0=FULL BLOCK    1=SHORT BLOCK
*****                          BYTE 1:   NULL
*****                          BYTE 2,3: BYTE 0=0 NULL    BYTE 0=1
*****                                    SHORT BLOCK RECORD COUNT
*****            FOR FILE OUT, WORD 4 CONTAINS THE ADDRESS OF THE
*****            PREVIOUSLY OUTPUT RECORD (IN THE OUTPUT BUFFER)
*****    WORD 5:     RECORDS TRANSFERED COUNT
*****    WORD 6:  TRUE RECORD BYTE LENGTH IN BUFFER # 1
*****    WORD 7:  TRUE RECORD BYTE LENGTH IN BUFFER # 2
*****             FOR FILE OUT, WORD 6 FOR CURRENT BUFFER, 7 IS WORK WRD
*****
*****    ADDRESSES OF 0 INDICATE THE FILE HAS BEEN CLOSED
*****
*****    LEN = ENTRY LENGTH OF LOCBLK
*****
         BOUND    8
LOCBLK   DO1      80                  BUFF IO CONTROL TABLE
         DATA     0
         ORG      LOCBLK+01
         DATA     F:MRGOUT
         ORG      LOCBLK+09
         DATA     F:MRGIN1
         ORG      LOCBLK+17
         DATA     F:MRGIN2
         ORG      LOCBLK+25
         DATA     F:MRGIN3
         ORG      LOCBLK+33
         DATA     F:MRGIN4
         ORG      LOCBLK+41
         DATA     F:MRGIN5
         ORG      LOCBLK+49
         DATA     F:MRGIN6
         ORG      LOCBLK+57
         DATA     F:MRGIN7
         ORG      LOCBLK+65
         DATA     F:MRGIN8
         ORG      LOCBLK+80
ERCNT    DATA,16  0                 MESSAGE CONTROL
INSRT    DATA,16  0                 SORT TABLE FILE NO. & REC. ADDRESS
         DATA,16  0
         DATA,16  0
         DATA,16  0
         DATA,8   0
MESBUF   DO1      34
         DATA     0
SPECS    DO1      60
         DATA     0
WORK     DATA,16  0
         DATA,16  0                 GENERAL TEMPORARY SAVES
SVR1     DO1      16
         DATA     0
SVR2     DO1      15                 SAVE REG LEVEL 2
         DATA     0
SVR3     DO1      15                 SAVE REG LEVEL 3
         DATA     0
J8SV     DATA     0                 SAVE REG 8 FOR ABN RTN READ
INSVE    DO1      15                IGNET SAVE SAVE REG
         DATA     0
WORKOP   DO1      15                  IGNET WORK AREA
         DATA     0
* KEY DATA AND FLAGS                                                    1186B
NUMKEYS  DATA     X'0'              NUMBER OF KEYS                      1153B
* KEY COMPARISON TABLE- 4 WORDS PER KEY : ENTRIES RIGHT JUSTIFIED       1153D
*  WORD 1- BYTE 1 = TRANSLATE IF 01                                     1153F
*               2 = DATA TYPE:  1= BINARY                               1153H
*                               2= ALPHA                                1153J
*                               3= PACKED DECIMAL                       1153L
*                               4= ZONED DECIMAL- ODD BYTE COUNT        1153N
*                               5= ZONED DECIMAL- EVEN                  1153P
*         BYTE 3-4= BYTE OFFSET OF KEY INSIDE RCD                       1172B
*  WORD 2- TYPE 1,2,5: BYTE 1 = LENGTH OF KEY                           1153R
*          TYPE  3,4 : BYTE 2 = LENGTH OF PACKED KEY                    1153T
*  WORD 3- TYPE 1 ONLY-'CW,R9 R11' OR 'CD,R8  R10'                      1153V
*  WORD 4- ASCENDING SORT: 'BL' WONWINS                                 1153X
*          DESCENDING    : 'BG' WONWINS                                 1153Z
         DO       16                                                    1154
         DATA     X'0',X'0'         WORDS 1-2                           1154B
         CW,R9    R11               WORD 3 FOR SINGLE PRECISION BIN     1154D
         BL       WONWINS           WORD 4 FOR ASCENDING SEQ            1154F
         FIN                                                            1154H
KYTBLE   RES      0                 REF POINT                           1154J
KTBSTRT  DATA     X'0'              1ST KEY TABLE ENTRY ADDRESS         1172B
TRANTAB  DATA     X'0'         BYTE ADDR OF KEY TRNSLTN WORK AREA       1214B
TTSTORE  DO1      192                TRANSLATION TABLE STRGE
         DATA     0
*
NOTEV255 DATA     X'0'              RCD MOVE- NO. BYTES NOT MODULO 255
*
         BOUND    8
KYBRSV   DO1      16
         DATA     0
ZDWRKA   DATA     '0000'
ZDSVE    DO1      7
         DATA     0
ZDWRKB   DATA     '0000'
         DO1      7
         DATA     0
TRANKSV  DO1      5
         DATA     0
INHEDAD  DATA     MINHED
INTRLAD  DATA     MINTRL
INUSAD   DATA     MINUSO
OUHEDAD  DATA     MOUHED
OUTRLAD  DATA     MOUTRL
OUSOAD   DATA     MOUSO
ENSP     RES      0
KLERM    TEXTC    'KEY 00 LENGTH'
KBNDRM   TEXTC    'KEY 00 BOUNDARY'
KYSTRTM  TEXTC    'KEY 00 START'
KDTRM    TEXTC    'KEY 00 DATA TYPE'
         TITLE    'RESIDENT CONTROL SEGMENT     *****  MERGE  *****'
         PAGE
         USECT    PROG
MERGE    EQU      PH:RES                                                0MG10150
CRGEN    CNAME                      GENERATE TABLE OF POINTERS TO ERMS2 0MG02900
         PROC                                                           0MG03000
LF       GEN,CF(2),CF(2),CF(2),CF(2)  AF                                0MG03100
         PEND                                                           0MG03200
MS2ST    CRGEN,8  000,016,028,038   STARTING BYTE IN ERMS2
         CRGEN,8  052,073,100,126
         CRGEN,8  145,146,153,171
MS2CT    CRGEN,8  016,012,010,014   LENGTH OF ERMS2
         CRGEN,8  021,027,026,019
         CRGEN,8  001,007,018,022
MS3ST    CRGEN,8  000,021,042,056   STARTING BYTE IN ERMS3
         CRGEN,8  071,094,115,140
         CRGEN,8  160,193,201,231
MS3CT    CRGEN,8  021,021,014,015   LENGTH OF ERMS3
         CRGEN,8  023,021,025,020
         CRGEN,8  033,008,030,020
PH:RES  LCI     0
        STM,0   SVR1
* TEMP CODE FOR SINGLE SEGMENT REPLACE WITH MONITOR LINKS               0MG10700
MERGE1   B        PH:I
MERGE2   B        PH:II
* REGISTERS 8-10, 12-15 USED BY BUSINESS PROCEEDURES                    0MG11475
MRTNCTL  LCI      15                LOG MESSAGE ROUTINE                 0MG11600
         STM,1    SVR2              SAVE REGISTERS                      0MG11700
         LI,1     1                 INDEX TO MESBUF BYTES
         LW,7     ERCNT             POINTER TO ERMS1
         MI,7     12
         MOVE     (ERMS1,7),(MESBUF,1),12        SET UP PART 1
         LW,3     ERCNT+1           POINTER TO MS2ST & MS2CT            0MG12200
         LB,4     MS2ST,3           POINTER TO ERMS2 START
         LB,5     MS2CT,3           POINTER TO ERMS2 LENGTH             0MG12400
         AI,1     12                                                    3MG12500
         MOVE     (ERMS2,4),(MESBUF,1),*5    SET UP PART 2              0MG12600
         AW,1     5                                                     0MG12700
         LW,3     ERCNT+2           POINTER TO PART 3
         BLZ      SKPT30            SKIP IF NO PART 3
         LB,4     MS3ST,3
         LB,5     MS3CT,3                                               0MG13033
         MOVE     (ERMS3,4),(MESBUF,1),*5    SET UP PART 3              0MG13066
         AW,1     5
SKPT30   AI,1     -1                SET UP LENGTH OF MESSAGE
         STB,1    MESBUF
         M:PRINT  (MESS,MESBUF)     MONITOR LOG                         0MG13300
         MTW,1    ERCNT+3           COUNT ERRORS                        1MG16000
         CI,7     0                 IF SUCCESS END GOTO END TASK
         BE       ENTK0                                                 0MG13500
         CI,7     24                IF ABORT GOTO END JOB
         BE       ENJB0                                                 0MG13700
         LCI      15                IF JUST MESSAGE RETURN TO           0MG13800
         LM,1     SVR2              LINE PROGRAM                        0MG13900
         B        *13               RETURN TO CALLER
ENTK0   LCI     0
        LM,0    SVR1
         M:EXIT                                                         0MG14300
ENJB0    LCI      15
         LM,1     SVR2
         M:SNAP   'DCBS',(F:MRGOUT,F:MRGIN8+58)
         LCI      0
        LM,0    SVR1
         M:XXX                                                          0MG14600
PROG1    CSECT    0
         DEF      PH:I
         TITLE    'SPECIFICATION CHECK PHASE     *****  MERGE1  *****'
         PAGE
ERMS4    TEXTC    'MERGE SPECIFICATIONS'
         BOUND    8                 GENERATE PARAMETER LIMITS           1MG00500
LMFL     GEN,32,32  1,8             INPUT FILES                         1MG00600
LMLN     GEN,32,32  1,9999          RECORD LENGTH                       1MG00700
LMBK     GEN,32,32  1,999           BLOCKING FACTOR                     1MG00800
LMDP     GEN,32,32 0,0                DROPPING FACTOR
LMKY     GEN,32,32  1,16            NUMBER OF KEYS                      1MG01000
LMTN     GEN,32,32     22,24        VALUES TO 10X
         REF      M:SI
X0       EQU      0
X1       EQU      1
X2       EQU      2
X3       EQU      3
X4       EQU      4
X5       EQU      5
X6       EQU      6
X7       EQU      7
SAVAL    DO1      16
         DATA     0
         BOUND    8
CARD     DO1      20
         DATA     0
PARTBL   DATA     '.REC'
         DATA     '.BLO'
         DATA     '.FIL'
         DATA     '.KEY'
         DATA     '.NOT'
         DATA     '.TRA'
CEOD     DATA     ' EOD'
PARJMP   B        PRE
         B        PBLO
         B        PFIL
         B        PKEY
         B        INIT2
         B        PTRA
         B        INIT4
KFLD     DO1      4
         DATA     0
SRSAV    DO1      3
         DATA     0
HF0F0    DATA    X'0F0F0'
H0FFF    DATA     X'000F0F0F'
HF1F0    DATA    X'0F1F0'
HF0      DATA    X'F0000000'
HFF00    DATA    X'FFFF0000'
H4       DATA     X'F0F4'
H12      DATA    X'0F1F2'
PAGES    DATA    C'AGES'
CBLNK    DATA    C'.   '
BLANK    DATA     C'    '
TRAN     DATA    C'TRAN'
CMRG     DATA     C' MER'
CBA      DATA     C'  BA'
TFLG     DATA     0
HDCB     DATA     C'3690'
DIS      DATA    0
CNT      DATA    0
SPECADDR GEN,32   WA(SPECS)
LPARA    DATA     C'(   '
RPARA    DATA     C')   '
COMMA    DATA     C',   '
FINOU    DATA     0
PSET     DATA     X'FF000000'
EONE     DATA     X'404040F1'
IHDR     DATA     C'IHDR'
OHDR     DATA     C'OHDR'
NSEQ     DATA     C'NSEQ'
DROP     DATA     C'DROP'
FILES    DATA     C'ILES'
PGS      DATA     C'AGES'
DCBS     DATA     C'DCBS'
REM      DATA     C' REM'
HF0F     DATA     X'0F0F'
HF       DATA     X'0F'
HFF      DATA     X'0FF'
DCBT     DATA     C'ABCD','EFGH'
STRT     DATA     0
ACC      DATA     0
OUTLEN   DATA     0                 HOLD OUT REC LENGTH
OUTLENSW DATA     0                  1 USER SPEC OUT LEN TO BE USED
PFLG     DATA     0
PFLG1    DATA     0                 SCANNER SWITCH
PFLG2    DATA     0
KDIS     DATA     50
KNUM     DATA     1
KCNT     DATA     0
BINIT25  BNE      EREAD
CDMV     GEN,32   BA(CARD)
KTMV     GEN,32   BA(TTSTORE+128)
*
ERTBL    DATA     0,E11,TRTNBERM
E11      TEXTC    'SPECIFICATION ERROR'
TRTNBERM TEXTC    'TRANSLATION TABLE LOCATION ERROR'
*
         PAGE
*
*
PH:I     RES      0
         LCI      15                SAVE ALL GENERAL
         STM,X1   SAVAL               REGISTERS
         MTW,1    ERCNT             SET UP ERROR MESSAGE JUST IN CASE
         MTW,5    ERCNT+1
         LI,X7    40                INITIALIZE KEY DISPLACEMENT
         STW,X7   KDIS
         LW,15    BLANK             INITIALIZE TO BLANKS
         LI,4     3
         LI,5     5
         BAL,9    MOV
         LW,15    BLANK
         LI,4     3
         LI,5     8
         BAL,9    MOV
         M:PRINT  (MESS,ERMS4)
INIT2    RES      0
         BAL,R9   SPECRD            GO READ SPECIFICATION CARDS
         LW,X7    CARD              IS CARD MERGE
         BEZ      INIT4             NO CARDS LEFT
         CW,X7    CMRG
         BE       INIT2             YES. READ AGAIN
         CW,X7    CEOD              IS IT EOD
         BE       INIT4             YES.
         BAL,R9   SPECPT            GO PRINT CARD IMAGE
         LB,X7    CARD              IS PARAM IN NEW FORMAT
         CW,X7    =C'.'
         BNE      STDPAR            NO. GO PROCESS STANDARD FORMAT
         LW,X3    BINIT25          SET BRANCH  TO
         STW,X3   %-2              BYPASS THE STANDARD
INIT25   RES      0
         LI,3     7
INIT28   RES      0
         LW,X4    CARD              FIND TYPE OF PARAMETER CARD
         CW,X4    PARTBL-1,X3
         BE       PARJMP-1,X3       GO PROCESS THIS CARD
         BDR,X3   INIT28            CHECK AGAIN
INIT3    RES      0
         SLS,X4   -16
         CH,X4    CBLNK             CHECK IF '. '
         BE       PARJMP,X1         YES. GO TO
         LI,X6    1                 SYNTAX ERROR IN PARAMETER CARD
         B        ERRTYP            GO PRINT ERROR MESSAGE
INIT4    RES      0
         LW,15    KCNT              NUMBER OF MERGE KEYS
         CI,R15   10                LESS THAN 10
         BGE      INIT6             NO.
         OR,R15   HF0F0             SET TO EBCDIC
INIT5    RES      0
         LI,X4    2
         LI,X5    48                MOVE NUMBER OF KEYS INTO
         BAL,R9   MOV               COLUMN 49-50 OF PARAMETER CARD
         B        SPCK
INIT6    RES      0
         AI,R15   -10
         OR,R15   HF1F0             SET NUMBER TO EBCDIC
         B        INIT5
         PAGE
*
*        SPECRD READS THE PARAMETER CONTROL CARDS AND SPECPT
*        PRINTS THEM ON THE M:LL DEVICE.
*             R9 = RETURN ADDRESS
*
SPECRD   RES      0
         LCI      3
         STM,R8   SRSAV             SAVE SYSTEM REG
         LI,X3    20                BLANK OUT CARD
         LI,X4    0
SPECLP   RES      0
         STW,X4   CARD-1,X3
         BDR,X3   SPECLP            CONTINUE BLANKING
         M:READ   M:SI,(BUF,CARD),(SIZE,80),(ABN,SPABN)
SPECRT   RES      0
         LCI      3
         LM,R8    SRSAV             RESTORE AND RETURN
         B        *R9
SPECPT   RES      0
         LCI      3
         STM,R8   SRSAV             SAVE SYSTEM REG
         M:WRITE  M:LL,(BUF,CARD),(SIZE,80),WAIT
         B        SPECRT
*
SPABN    RES      0
         LB,R9    R10              GET ABNORM CODE
         CI,R9    5                EOD
         BE       SPABN10          YES
         CI,R9    6                EOF
         BNE      SPECRT           NO. IGNORE ABNORMAL
SPABN10  RES      0
         LI,R9    0
         STW,R9   CARD             SET CARD TO ZERO
         B        SPECRT           RETURN
         PAGE
*
* THIS ROUTINE SCANNS THE NEW MERGE PAPAMETER CARDS AND
* PLACES THE PAPAMETER FIELDS FOUND INTO REG 14
*             X3 = BYTE DISPLACEMENT OF SCAN
*             X6 = NUMBER OF CHARACTERS SCANNED
*             R9 = ROUTINE
*             R14= DATA FIELD IF ANY
*             R15= DATA FIELD RIGHT JUSTIFIED
*             R2 = 1 END OF CARD FLAG
*
SCAN     RES      0
         LI,X6    0                 SCAN CHARACTER COUNT
         LW,14    =X'40404040'
         STW,R14  R15               BLANK OUT HOLD REGISTERS
         LI,X4    0
         LI,X2    0
SCAN10   RES      0
         LB,X4    CARD,X3           CHECK FOR  LEFT PAREN
         AI,X3    1                 UPDATE DISPLACEMENT POINTER
         CB,X4    LPARA             LEFT PAREN?
         BE       SCAN20            YES.
         CB,X4    COMMA            ANY MORE FIELDS IN THIS PARAM
         BE       SCAN20           YES.
         CI,X3    81                SCANNED ENTIRE CARD
         BGE      SCAN50            YES. GO RETURN
         B        SCAN10            GET NEXT BYTE
SCAN20   RES      0
         LB,X4    CARD,X3           CHECK FOR NUMERIC FIELD
         AI,X3    1                 UPDATE POINTER DISPLACEMENT
         CB,X4    HF0               NUMERIC?
         BL       SCAN40            NO
SCAN30   RES      0
         AI,X6    1                NUMBER OF BYTES SCANNED
         SLD,R14  8                 MAKE ROOM IN HOLD REGISTERS
         AND,X4   HFF               MASK FIRST BYTE
         OR,R15   X4                PLACE IN HOLD REG.
         B        SCAN20            GO GET MORE
SCAN40   RES      0
         CB,X4    COMMA             COMMA
         BE       SCAN70            YES.
         CB,X4    RPARA             RIGHT PAREN?
         BNE      SCAN30            NO. PLACE IN HOLD REG
SCAN50   RES      0
         LI,X2    1                 SETEND-OF-CARD FLAG
SCAN60   RES      0
         B        *R9               RETURN TO CALLER
SCAN70   RES      0
         AI,X3    -1                SET SCAN POINTER BACK
         B        *R9               RETURN TO CALLER
         PAGE
*
*    THIS ROUTINE MOVES THE MERGE PARAMETER FIELD LOCATED
*        IN REGISTER 14 AND/OR 15 TO THE STANDARD MERGE PARAMETER
*        CARD LOCATED IN SPECS.
*             X4 = BYTES TO BE MOVED
*             X5 = BYTE DISPLACEMENT INTO SPECS.
*             R9 = RETURN ADDRESS
*             R14 = DATA TO BE MOVED IF ANY
*             R15 = DATA TO BE MOVED
*
MOV      RES      0
         LI,X6    64                SET TO LAST BYTE +1 OF GEN REG
         SW,X6    X4                SET TO ACTUAL DISPLACEMENT
MOV1     RES      0
         LW,X7    SPECADDR          ADDR OF SPECS
         SLS,7    +2                TO BYTES
         AW,X7    X5                DISPLACEMENT OF MERGE PARAMETERS
         STB,X4   X7                STORE BYTE COUNT
         MBS,X6   0                 MOVE FIELD TO SPECS
         B        *R9               RETURN TO CALLER
         PAGE
*
*        PFL SCANS THE FILE CARD PICKING OUT THE FILES AND IHDR/OHDR
*        PARAMTERS IF ANY.
*
PFIL     RES      0
         LI,4     11
         LI,2     X'40'
         STB,2    *SPECADDR,4        MAKE BLANK TO START WITH
         LI,2     0
         STW,2    PFLG
         STW,2    PFLG1
         STW,2    PFLG2
         LI,X3    4                 STARTING BYTE
PFIL10   RES      0
         BAL,R9   SCAN              SCAN FIRST FIELD
         LW,R13   R15               SAVE FIELD TYPE
         BAL,R9   SCAN              SCAN SECOND FIELD
         CW,R13   FILES
         BE       PFIL30            YES
         CW,13    IHDR               IS INPUT HEADER SPEC
         BE       PFIL50            YES.
         CW,13    OHDR              IS OUTPUT HEADER SPEC
         BE       PFIL60
         CW,13    BLANK             IF 13 AND 15 BLANK ASSUME END CARD
         BNE      EREAD             ERROR
         CW,15    BLANK
         BNE      EREAD
         B        INIT2             BOTH BLANK, SO DO NEXT CARD
PFIL30   RES      0
         MTW,0    PFLG
         BGZ      EREAD
         AI,3     1
         STB,15   *SPECADDR         STORE NUM OF MERGE FILES
         MTW,1    PFLG
         B        PFIL10            GO TO NEXT SCAN
PFIL50   RES      0
         MTW,0    PFLG1
         BGZ      EREAD
         LI,4     11
         STB,R15  *SPECADDR,4       SET HDR OPTION IN COL 12
         MTW,1    PFLG1
         AI,3     1                  POINT TO NEXT CHARA FOR SCAN
         B        PFIL10            GO CHECK NEXT FIELD
*
PFIL60   MTW,0    PFLG2              HAVE WE BEEN HERE BEFORE
         BGZ      EREAD
         LI,4     12                INDEX
         STB,15   *SPECADDR,4       STORE OHDR VALUE IN POS 13 SPECS
         MTW,1    PFLG2
         AI,3     1
         B        PFIL10             GET NEXT PARAM ON CARD
         PAGE
*
*        PRE SCANS THE .REC CARD OBTAINING THE INPUT/OUTPUT RECORD LEN
*        LENGTH AND IF NO SEQUENCE CHECKING IS DESIRED
*
PRE      RES      0
         LI,15    X'40'
         LI,5     22
         STB,15   *SPECADDR,5       INTO FOR SEQ CHKING
         LI,X3    4                 INITIALIZE
         LI,X2    0
         STW,X2   PFLG
         STW,2    PFLG1
         STW,2    PFLG2
PRE10    RES      0
         CI,X2    1                 IS SCAN COMPLETED
         BE       INIT2             YES. GET NEXT CARD TYPE
         BAL,R9   SCAN              SCAN CARD FOR FIELD
         CW,R15   NSEQ              NO SEQUENCE CKING
         BE       PRE40             YES
         MTW,0    PFLG1
         BNEZ     PRE20             ASSUME OUTPUT REC LEN
         MTW,1    PFLG1
         LI,5     1                  POS 2-5
         STW,5    ACC                SAVE FOR MOVE TO SPECS
PRE100   LI,5     3                  INDEX
         LI,9     X'F0'             MASK TO MAKE 40 INTO F0
PRE11    RES      0
         LB,4     15,5              SEE THIS BYTE
         CI,4     X'40'
         BNE      %+2
         OR,15    9                 CHANGE 40 TO F0
         SLS,9    8                 SHIFT MASK
         AI,5     -1                REDUCE INDEX TO SEE NXT BYTE
         BGEZ     PRE11             GO THRU 4 TIMES
         LW,5     ACC                GET POS FOR MOVE INTO SPECS
         LI,X4    4                 BYTE COUNT
         BAL,R9   MOV               GO MOVE FIELD TO COMMON PAGE
         B        PRE10             GET NEXT FIELD
*
PRE20    MTW,0    PFLG2             HAVE WE DONE OUTPUT YET
         BNEZ     EREAD              YES SO ERROR
         MTW,1    PFLG2
         LI,5     35                POS 36-39    INTO SPECS
         STW,5    ACC
         B        PRE100
PRE40    RES      0
         MTW,0    PFLG
         BNEZ     EREAD
         LI,5     22                SET COL 23
         LI,15    X'F0'
         STB,R15  *SPECADDR,5
         MTW,1    PFLG
         B        PRE10             GET NEXT FIELD
         PAGE
*
*        PBLO SCANS THE '.BLOCK' CARD FOR INPUT/OUTPUT BLOCKING FACTOR
*        AND IF BAD BLOCKS SHOULD BE DROPPED.  IF NO INPUT/OUTPUT
*        BLOCKING IS SPECIFIED 1 IS DEFAULT.
*
PBLO     RES      0
         LI,X3    4                 STARTING BYTE
         LI,X2    0                 SET FIELD COUNTER TO ZERO
         STW,2    PFLG
         STW,2    PFLG1
PBLO10   RES      0
         CI,X2    1                 RIGHT PAREN REACHED
         BE       INIT2             YES. GO CHECK IF OUTPUT BLOCKING =0
         BAL,R9   SCAN              GO SCAN
         CW,R15   DROP              FIELD DROP
         BE       PBLO40            YES
         LW,5     PFLG
         CI,5     2                 2 HAVE ALREADY BEEN TWICE
         BGE      EREAD
         LI,X5    5                 BYTE DISPLACEMENT OF MOVE
         MTW,0    PFLG              INPUT BLOCKING FACTOR
         BEZ      PBLO30            YES
         LI,X5    8                 NO. SET FOR OUTPUT BLOCKING FACTOR
PBLO30   RES      0
         LI,4     3
         LI,9     X'F0'             MASK TO MAKE 40 INTO F0
PBLO31   RES      0
         LB,13    15,4
         CI,13    X'40'
         BNE      %+2
         OR,15    9                 CHANGE 40 TO F0
         SLS,9    8                 SHIFT MASK
         AI,4     -1                REDUCE INDEX FOR NEXT BYTE TO LEFT
         BGZ      PBLO31             GO THRU THREE TIMES
         CW,15    =X'40F0F0F0'          WAS IT BLANK
         BNE      %+2                NO
         LW,15    BLANK             MAKE IT BLANK AGAIN
         LI,X4    3                 NUMBER OF BYTES TO MOVE
         BAL,R9   MOV               GO MOVE BLOCKING FACTOR
         MTW,1    PFLG
         B        PBLO10            GO CHECK NEXT FIELD
PBLO40   RES      0
         MTW,0    PFLG1
         BNEZ     EREAD
         LI,5     23                SET BYPASS UNREADABLE RECORDS
         LI,X4    C'0'              SWITCH ON
         STB,X4   *SPECADDR,5
         MTW,1    PFLG1
         B        PBLO10            GO CHECK NEXT FIELD
         PAGE
*
*        PTRA SCANS THE '.TRAN' CARD FOR THE STARTING LOCATION
*        AND ALTERNATE VALUES TO BE PLACED IN THE TRANSLATION
*        TABLE.
*
PTRA     RES      0
         LI,X3    1
         CI,X1    6                IS THIS THE FIRST TRAN CARD
         BE       PTRA20           NO.
         BAL,R9   TRANSB           HAVE BEEN BUILT. GO BUILD
         LI,X3    4                STARTING BYTE OF SCAN
PTRA20   RES      0
         BAL,R9   SCAN             SCAN STARTING POSITION
         CI,X2    1                END OF THIS CARD
         BE       PTRA70           YES.
         LI,X4    3                NUMBER OF DIGITS TO CONVERT
         BAL,R9   HCONV            GO CONVERT R15 TO HEX
         AI,X4    -1
         STW,X4   STRT             SAVE STARTING POSITION
         BAL,R9   SCAN             SCAN FOR LENGTH
         AI,X3    1                POINT TO ALTERNATE CHARACTER STRING
         LI,X4    3                NUMBER OF DIGITS TO CONVERT
         BAL,R9   HCONV            GO CONVERT R15 TO HEX
         CI,X4    255              GREATER THAN TRANS TABLE
         BG       PTRA35           YES. ISSUE ERROR
         STW,X4   CNT              SAVE NUMBER TO MOVE
         LW,X6    CDMV             ADDRESS OF CARD
         AW,X6    X3               POINT TO STRING
         LW,X7    KTMV             ADDRESS OF TRANS TABLE
         AW,X7    STRT             POINT TO STARTING POSITION OF CHANGE
         STB,X4   X7               SET IN NUMBER TO MOVE
         AW,X4    STRT             CHECK TO INSURE THAT LENGTH +
         CI,X4    255              DISPLACEMENT DOES NOT EXCEED TABLE
         BG       PTRA35           YES IT DOES
         MBS,X6   0                ALTER TRANSLATION TABLE
         AW,X3    CNT              ADD DISPLACEMENT
         AI,X3    2                FOR SCAN
         B        PTRA20           GO CHECK THIS CARD FOR MORE
PTRA35   RES      0
         LI,X6    2                TRANSLATION TABLE ERR
         B        ERRTYP           PRINT ERROR MESSAGES
PTRA70   RES      0
         LI,X1    6                SET TO RETURN TO PTRA IF MORE CARDS
         B        INIT2
*
HCONV    RES      0
         LI,X7    0
         LI,X1    4                MAX NUMBER TO CONVERT
         SW,X1    X4               DISPLACEMENT OF DIGITS
HCONV10  RES      0
         LB,X4    R15,X1           LOAD DIGIT
         CI,X4    X'F0'            NUMERIC?
         BL       HCONV30          NO
HCONV20  RES      0
         AND,X4   HF               STRIP OFF HALF BYTE
         AW,X7    X4               ADD TO COUNTER
         CI,X1    3                ANY MORE
         BGE      HCONV25          YES.
         MI,X6    10               CONVERT TO HEX
         AI,X1    1                INCREMENT DISPLACEMENT
         B        HCONV10
HCONV25  RES      0
         LW,X4    X7               CONVERTED VALUE
         BEZ      HCONV30
         B        *R9              RETURN
HCONV30  RES      0
         CB,X4    BLANK            IS IT A BLANK
         BE       HCONV20          YES. CONTINUE PROCESSING
         LI,X6    1                SYNTAX ERROR
         B        ERRTYP
*
*
TRANSB   RES      0
         LI,X3    255
         LI,15    TTSTORE
         STW,15   TRANTAB           SET UP TRANS TABLE
TRANS10  RES      0
         STB,3    TTSTORE+128,3
         MTW,-1   3
         BGEZ     TRANS10
         B        *9
         PAGE
*
*        PKEY SCANS THE '.KEY' CARD FOR THE KEY INFORMATION.
*        THE NUMBER OF KEYS IS COUNTED AND INSERTED INTO THE
*        PARAMTER CARD LATER.
*
PKEY     RES      0
         LI,X3    1
         CI,X1    3                IS THIS THE FIRST KEY CARD
         BE       PKEY05           NO
         LI,X3    4                 STARTING BYTE OF SCAN
PKEY05   RES      0
         LI,X1    0                 SCAN COUNTER
         LI,X2    0
PKEY10   RES      0
         CI,X2    1                 RIGHT PAREN?
         BE       PKEY40            YES
         LI,X2    0
         BAL,R9   SCAN              SCAN FIELD
         LW,R13   R15
         AND,R13  HFF              CHECK FIELD
         CI,R13   X'0F0'           FOR NUMERIC
         BL       PKEY50           NO.
         AI,X1    1                SET TO STARTING BYTE OR LENGTH
         CI,X1    2                LENGTH?
         BE       PKEY30           YES
         BG       INIT3             ONLY TWO NUMERIC FIELDS
         STW,R15  KFLD+1           SAVE STARTING BYTE
         B        PKEY10           GET NEXT FIELD
PKEY30   RES      0
         SLS,R15  8
         LI,4     X'40'
         OR,15    4                 TEMP BLANK FOR KEY DIRECTION
         OR,R15   KFLD+2           PUT LENGTH WITH DIRECTION
         STW,R15  KFLD+2
         B        PKEY10
PKEY50   RES      0
         CW,R15   TRAN             TRANSLATION TABLE KEY?
         BE       PKEY60           YES.
         LI,4     1                 INDEX TO GET 2 RIGHT BYTES
         LH,4     15,4              SEE IF KEY TYPE IS SPEC
         AND,4    =X'0000FFFF'        MASK SIGN EXTENTION
         CI,4     C'AN'
         BE       PKEY70            YES
         CI,4     C'PD'
         BE       PKEY70            YES
         CI,4     C'ZD'
         BE       PKEY70            YES
         CI,4     C'BN'
         BE       PKEY70            YES
         OR,R15   KFLD+2
         STW,R15  KFLD+2           SET DIRECTION INTO LENGTH WORD
         B        PKEY10           GET NEXT KEY
PKEY60   RES      0
         LI,R15   C'T'             SET 'T' INTO
         STB,R15  KFLD+3           TRANSLATION FIELD
         B        PKEY10           GET NEXT FIELD
PKEY70   RES      0
         CW,R15   CBA              TYPE ABSOLUTE BINARY?
         BNE      PKEY75           NO.
         LI,X4    C'A'
         STB,X4   KFLD+3           SET 'A' INTO TRANSLATION FLD
PKEY75   RES      0
         SLS,R15  -8               DROP LOW ORDER CHARACTER
         STW,R15  KFLD             SAVE IN TYPE FIELD
         B        PKEY10           GET NEXT FIELD
PKEY40   RES      0
         LI,X1    3                GET TYPE BYTE
         LI,X4    C'A'             DEFAULT TO ALPHANUMBERIC/ASCEND
         LB,X2    KFLD,X1          ZERO?
         BNEZ     PKEY42           NO
         STB,X4   KFLD,X1
PKEY42   RES      0
         LB,X2    KFLD+2,X1        IS DIRECTION ZERO?
         CI,2     X'40'
         BNE      PKEY45
         STB,X4   KFLD+2,X1        DEFAULT TO ASCENDING
PKEY45   RES      0
         LI,X4    10
         LW,X5    KDIS             KEY DISPLACEMENT
         AW,X5    X4               UPDATE KEY DISPLACEMENT
         STW,X5   KDIS
         LI,X6    BA(KFLD)          ADDRESS OF KEYS TO MOVE
         AI,X6    3                 DISPLACEMENT OF KEY IN TEMP STORE
         BAL,R9   MOV1             GO MOVE CARD TO SPEC
         LI,X4    0
         STW,X4   KFLD             RESET
         STW,X4   KFLD+1           TEMPORARY KEY FILED
         STW,X4   KFLD+2           TO ZERO
         STW,X4   KFLD+3
         LW,X2    X4               RESET KEY TERMINATER
         LW,X1    X4               RESET LENGTH/START FLAG
         LW,X4    KCNT
         AI,X4    1                UPDATE NUMBER OF KEYS FOR SORT
         STW,X4   KCNT
         LB,X4    CARD,X3          ANY MORE KEYS ON THIS CARD
         CB,X4    COMMA
         BE       PKEY47           YES
         LI,X1    3                CHECK FOR ANOTHER KEY CARD
         B        INIT2
PKEY47   RES      0
         AI,X3    1                POINT TO NEXT CHARACTER
         B        PKEY10           GET NEXT KEY THIS CARD
         PAGE
*
*        THIS ROUTINE MOVES THE STANDARD MERGE PARAMETER CARD
*        TO A SPECS. IT CHECKS THE NUMBER OF MERGE
*        KEYS AND READS ANY ADDITIONAL CARDS NEEDED.
*
STDPAR   RES      0
         BAL,R9   STDMOV           MOVE FIRST CARD TO SPECS
         LI,X2    24               CHECK THE
         LH,R12   CARD,X2          NUMBER OF
         AND,R12  =X'FFFF'
         LI,R13   1                KEYS
         CW,R12   H4               MORE THAN 3 KEYS?
         BL       SPCK             NO. ONLY ONE CARD
         LI,X6    1                SET INDEX COUNTER
         CW,R12   H12              MORE THAN 11 KEYS?
         BL       STDPAR1          NO. ONLY TWO CARDS
         AI,X6    1                INCREMENT INDEX
STDPAR1  RES      0
         LI,1     20                 WORDS PER 80 BYTE CARD
         AW,X1    SPECADDR
         STW,1    SPECADDR
         BAL,R9   SPECRD           GET NEXT CARD
         LW,X7    CARD
         CW,X7    CEOD             EOD?
         BE       SPCK
         BAL,R9   SPECPT           NO. PRINT CARD
         BAL,R9   STDMOV           MOVE CARD TO SPECS
         BDR,X6   STDPAR1          LOOP BACK
         B        SPCK             FINISHED READING PARAMETER CARDS
STDMOV   RES      0
         LW,X5    SPECADDR         ADDRESS OF SPECS AREA
         SLS,5    +2                TO BYTES
         LW,X4    CDMV             BYTE ADDRESS OF CARD
         LI,X3    80               80 CHARACTERS LENGTH
         STB,X3   X5
         MBS,X4   0                MOVE CARD TO SPECS
         B        *R9              RETURN TO CALLER
         PAGE
ERRTYP   RES      0
         LW,R9    ERTBL,X6          ADDRESS OF ERROR MESSAGE
         M:PRINT  (MESS,*R9)
         B        INIT2
EREAD    RES      0
         LI,X6    1                SYNTAX ERROR
         B        ERRTYP
N        EQU      1
CKLM     CNAME                      SET UP FOR SPCKLM                   1MG03500
         PROC                                                           1MG03600
LF       LI,3     AF(1)             SET ADDRESS OF LIMITS               1MG03700
         LI,4     AF(3)             SET ERMS3 POINTER                   1MG00800
         LI,6     AF(4)>0           BLANK NOT ALLOWED=1 BLANK OK=0 (N=1)1MG00900
         LI,2     CF(2)             SET LENGTH OF FIELD                 1MG04000
         BAL,5    SPCKLM            RETURN BRANCH TO CHECK              1MG04100
         STW,9    AF(2)             SAVE VALUE                          1MG04200
         PEND                                                           1MG04300
SPCK     LI,1     0                 SET TO COL. 1                       1MG04400
         CKLM,1   LMFL,WKFL,0,N     CHECK NUMBER OF INPUT FILES         1MG04500
         LI,1     1                 SET TO COL. 2                       1MG04600
         CKLM,4   LMLN,WKLN,1,N     CHECK RECORD LENGTH                 1MG04700
         LI,1     0
         STW,1    LMLN                MAKE RANGE 0000-9999
         LI,1     35                POINT TO POS 36-39
         CKLM,4   LMLN,OUTLEN,11
         LI,1     5                 SET TO COL. 6                       1MG04800
         CKLM,3   LMBK,WKBI,2       CHECK INPUT BLOCKING                1MG04900
         LI,1     8                 SET TO COL. 9                       1MG05000
         CKLM,3   LMBK,WKBO,3       CHECK OUTPUT BLOCKING               1MG05100
         LW,3     L(C'HHHH')
         LW,4     L(C'FFFF')
         LI,1     11                SET TO COL. 12                      1MG05300
         LI,13    SPCKAB            INCASE WE GO MRTNCTL
         LI,2     10                ERMS3 INDEX FOR RIGHT MSG
         STW,2    ERCNT+2
         LB,2     SPECS,1
         CI,2     X'40'
         BE       SPCKAB            NOT SPECIFIED
         CI,2     X'00'
         BE       SPCKAB            NOT SPECIFIED
         CI,2     C'9'
         BG       MRTNCTL
         CI,2     C'1'
         BL       SPCKAA
         MTW,-1   WKUIH                                                 1MG05700
         B        SPCKAB
SPCKAA   CB,4     SPECS,1
         BNE      MRTNCTL
         MTW,1    WKUIH
SPCKAB   MTW,0    MINTRL            IS TRAILER OWN CODE SPECIFIED
         BEZ      %+5
         LW,3     WKBI              SET INDICATING MONITOR FORMAT       1MG06500
         CB,3     L(C'    ')                                            1MG06600
         BE       %+2                                                   1MG06700
         MTW,-1   WKUIT
         MTW,0    MOUTRL             ARE OUT TRAILERS PRES
         BEZ      %+5
         LW,3     WKBO              SET INDICATING MONITOR FORMAT       1MG07200
         CB,3     L(C'    ')                                            1MG07300
         BE       %+2                                                   1MG07400
         MTW,-1   WKUOT                                                 1MG07500
         MTW,0    MINUSO            IS IN OWN CODE PRES
         BEZ      %+2
         MTW,-1   WKUIC                                                 1MG07900
         MTW,0    MOUSO             IS OUT OWN CODE PRES
         BEZ      %+2
         MTW,-1   WKUOC                                                 1MG08300
         LI,1     22                SET TO COL. 23                      1MG08400
         CKLM,1   LMDP,WKDR,4       CHECK UNREADABLE RECORD DROPS       1MG08500
         LI,1     48                SET TO COL. 49                      1MG09000
         CKLM,2   LMKY,NUMKEYS,7,N  CHECK NUMBER OF MERGE KEYS
         LW,2     WORK
         BEZ      KEYVR             RECHECK FOR ASSUMED READS
         STW,2    NUMKEYS
         TITLE    'EDIT KEY SPECIFICATIONS'
         PAGE
KEYVR    RES      0
         MTW,0    OUTLEN            HAS OUT LEN BEEN SPEC
         BNEZ     KEYVER1
         LW,8     WKLN              MAKE AS INPUT
         STW,8    OUTLEN
         B        %+2               DONT SET ON SW
KEYVER1  MTW,1    OUTLENSW          SET ON TO SHOW SPEC
         LW,9     OUTLEN            GET OUTPUT LENGTH
         LI,R8    0
         DW,R8    L(255)            DIVIDE MODULO 255 FOR MVERCRD
         STB,R8   NOTEV255                   ROUTINE
W        SET      SPECS             POINT AT MERGE SPECIFICATIONS
         LW,R2    NUMKEYS
         LI,R5    -4                CALC ADDR OF 1ST KEY TABLE          1502B
         MW,R5    R2                        ENTRY                       1502D
         AI,R5    KYTBLE                                                1502F
         STW,R5   KTBSTRT                                               1502H
         LI,R1    51                TO KEY 1 START BYTE
         LI,R4    1                 CURRENT KEY NUMBER                  1332B
* R1 = BYTE POINTER TO THE ITEM TO BE EDITED                            1292F
* R2 = TOTAL NUMBER OF KEYS TO BE EDITED                                1292H
* R3 = KEY TABLE OFFSET = R2 X(-4)                                      1506B
* R4 = CURRENT KEY NUMBER                                               1336D
*                                                                       1292K
* VALIDATE KEY START AND LENGTH                                         9617
KYLOOP   RES      0                                                     9618
         LI,R3    -4                                                    1511B
         MW,R3    R2                KEY TABLE OFFSET                    1340D
         BCDBIN   (W,R1),4          START BYTE TO R9                    9619
         BCS,12   KYSTRT            ERROR?                              9620
         AI,R9    -1                KEY BYTE OFFSET                     9700
         BLZ      KYSTRT            NEG = ERROR                         9700B
         AND,R9   L(X'3FFF')        CAN'T BE MORE THAN 9999 ANYWAY      1345B
         STW,R9   KYTBLE,R3                                             1345D
TOKYL    AI,R1    4                 TO KEY LENGTH                       9703
         BCDBIN   (W,R1),3,WORK     LENGTH TO R9 AND WORK
         BCS,12   KLUNK             LNTH IS ILLEGAL DIGIT               2263B
         CI,R9    1                                                     2263D
         BL       KLUNK             LNTH IS ZERO                        2263F
         AW,R9    KYTBLE,R3         ADD BYTE OFFSET                     1352B
         CW,R9    WKLN              WITHIN LOGICAL RECORD?
         BG       KBNDR                                                 9708
TOKYD    AI,R1    3                 TO KEY DIRECTION                    9709
         LB,R7    W,R1                                                  9710
         CI,R7    'D'               DESCENDING?                         1656B
         BNE      TOKTY             NO                                  1656D
* SET DESCENDING FLAG FOR THIS KEY                                      9715
         LW,R7    DESCIN            BG  FOR DESCENDING WINNER           1362B
         STW,R7   KYTBLE+3,R3       TO KEY TABLE WORD 4                 1362D
         B        TOKTY                                                 1362F
DESCIN   BG       WONWINS                                               1362H
* GET KEY DATA TYPE                                                     9719B
TOKTY    AI,R1    -8                TO KEY DATA TYPE                    9720
         LB,R5    W,R1                                                  2352B
         CI,R5    'B'               BINARY?                             2352D
         BE       DOBY                                                  9802
* ALLOW TRANSLATION OF NON-BINARY KEY                                   9803
         AI,R1    9                 TO TRANSLATE OPTION                 9804
         LB,R7    W,R1                                                  9805
         CI,R7    'T'                                                   9806
         BNE      KYAN                                                  9807
         LW,R7    L(X'01000000')    TRANSLATE FLAG                      1375B
         AWM,R7   KYTBLE,R3                                             1375D
* USER'S TRANSLATION SET TO HIGH CORE                                   2362B
         LW,R7    TRANTAB                                               2362D
         BNEZ     KYAN              TABLE ALREADY IN                    2362F
         LI,R7    -64                                                   2362H
         LW,R14   L(X'00010203')    INITIALIZE TRANS TABLE TO STANDARD
         M:TRAP   (IGNORE,BOTH)     TURN OFF ARITH TRAPS
         STD,8    SVR3              SAVE FOR RESTORE
NEWEND   STW,R14  TTSTORE+192,R7           EBCDIC SEQUENCE
         AW,R14   L(X'04040404')
         BIR,R7   NEWEND
         M:TRAP   (RESTORE,SVR3)    RESTORE TRAPS
         LI,R15   TTSTORE
         STW,R15  TRANTAB                                               2363D
         M:PRINT  (MESS,TRANMS)
* READ TRANSLATION SET                                                  2363F
RDTRNSET RES      0                                                     2363H
         M:READ   M:SI,(BUF,*TRANTAB),(SIZE,80),(ABN,KYAN),;
                  (BTD,0)                                               0966D
         M:WRITE  M:LL,(BUF,*TRANTAB),(SIZE,80),(BTD,0),WAIT
         LI,R7    64                COL 65-67 = START POS IN TABLE      2363L
         BCDBIN   (*TRANTAB,R7),3,R7                                    2363N
         CI,R7    193               PREVENT FALLING OFF HIGH END        2363P
         BG       TRNTBER
         AI,R7    511
         MOVE     *TRANTAB,(*TRANTAB,R7),64  RELOCATE THE USER SET      2363V
         B        RDTRNSET                                              2363X
* TRANSLATION TABLE LOCATION IS TOO HIGH
TRNTBER  RES       0
         M:PRINT  (MESS,TRNTBERM)
         MTW,1    ERCNT+3
         B        RDTRNSET
TRNTBERM TEXTC    'TRANSLATION TABLE LOCATION ERROR'
TRANMS   TEXTC    'USER TRANSLATION TABLE'
* IS KEY ALPHA-NUMERIC                                                  9814
KYAN     RES      0                                                     2366B
         CI,R5    'A'                                                   2366D
         BE       ALNUKY            YES                                 9816
         CI,R5    'P'               PACKED DECIMAL?                     2368B
         BE       PKDCKY                                                9818
         CI,R5    'Z'               ZONED DECIMAL?                      2370B
         BNE      KDTR              JUNK TYPE                           9820
* ZONED DECIMAL KEY                                                     9821
         LW,R7    WORK              GET SAVED KEY LENGTH
         CI,R7    31                MAX 31 DIGITS                       9902
         BG       KLER                                                  9903
* IS ZONED LENGTH ODD OR EVEN?                                          1395B
         AND,R7   L(X'1')                                               1395D
         BEZ      EVNCNT                                                1395F
         LW,R7    L(X'00040000')    ODD ZONED COUNT TYPE CODE           1395H
         LW,R9    WORK              COMPUTE PACKED LENGTH
         SLS,R9   -1                                                    1395L
         AI,R9    1                 PCK LNTH = COUNT/2 + 1              1395N
         B        PKDCOM            FINISH UP LIKE PACKED DEC           1395P
EVNCNT   LW,R7    L(X'00050000')    EVEN ZONED DECIMAL TYPE CODE        1395T
         LW,R9    WORK
         B        ALPHCOM           FINISH UP LIKE ALPHA                1395V
* SET UP BINARY KEY COMPARISON DATA                                     9907
DOBY     RES      0                                                     9908
         LW,R7    L(X'00010000')    BINARY TYPE CODE                    1400B
         LW,R9    WORK              GET SAVED KEY LENGTH
         CI,R9    8                 MAX 64 BITS                         1400F
         BG       KLER                                                  1400H
         CI,R9    4                 MORE THAN 32 BITS?                  1400J
         BLE      ALPHCOM           NO- FINISH UP LIKE ALPHA            1400L
         LW,R8    DBLEC             PLACE DOUBLE-WORD COMPARE IN        1400N
         STW,R8   KYTBLE+2,R3             KEY TABLE WRD 3               1400P
         B        ALPHCOM                                               1400R
DBLEC    CD,R8    R10                                                   1586B
* SET UP ALPHA-NUMERIC KEY DATA                                         9918
ALNUKY   RES      0                                                     9919
         LW,R7    L(X'00020000')    ALPHA TYPE CODE                     1410B
         LW,R9    WORK              GET SAVED KEY LENGTH
         CI,R9    255               MAX 255 CHARACTERS                  1410F
         BG       KLER                                                  1410H
ALPHCOM  RES      0                 STORE TYPE 1,2,5 CODE AND LNGTH     1410J
         AWM,R7   KYTBLE,R3         TO KEY TABLE WORD 1                 1410L
         SLS,R9   24                LNGTH TO BYTE 1                     1410N
         STS,R9   KYTBLE+1,R3       TO KEY TABLE WORD 2                 1410P
         B        TONXK                                                 1410R
* SET UP PACKED DECIMAL KEY DATA                                        9925
PKDCKY   RES      0                                                     9926
         LW,R7    L(X'00030000')    PACKED DECIMAL TYPE CODE            1417B
         LW,R9    WORK              GET SAVED KEY LENGTH
         CI,R9    16                MAX 31 PACKED DIGITS + SIGN         1417F
         BG       KLER                                                  1417H
PKDCOM   RES      0                 STORE TYPE 3-4 CODE AND LNGTH       1417J
         AWM,R7   KYTBLE,R3         TO KEY TABLE WORD 1                 1417L
         AND,R9   L(X'F')           4 BIT LENGTH                        1417N
         SLS,R9   20                TO BITS 8-11                        1417P
         STS,R9   KYTBLE+1,R3       TO KEY TABLE WORD 2                 1417R
* CHECK FOR NEXT KEY SPECIFICATION                                      9937
TONXK    RES      0                                                     9938
         AI,R4    1                 BUMP CURRENT KEY NUMBER             1427B
         LI,R1    10                                                    1427D
         MW,R1    R4                COMPUTE BYTE POINTER TO NEXT        1427F
         AI,R1    41                     KEY SPECIFICATION
         BDR,R2   KYLOOP            IS THERE ANOTHER KEY?               9943
* ALL KEYS PROCESSED                                                    9944
         LW,R15   TRANTAB           GET BYTE DISPLACEMENT
         SLS,R15  2
         STW,R15  TRANTAB
         B        MEMCAL
* PRINT KEY SPECIFICATION ERRORS
KENO     CNAME                      PROC TO PLACE CURRENT KEY NUMBER
         PROC                           IN SPECIFIED MESSAGE
LF       BAL,R15  @%KYNO
         BCS,0    AF(1)             'TEXTC' LOCATION
         PEND
@%KYNO   RES      0
         LW,R14   *R15              GET MESSAGE ADDRESS                 1627B
         LI,R7    5                 POINT TO KEY NO IN ADDRESS          1627D
         BINBCD   R4,(*R14,R7),2    CONVRT CUR KEY NO-  PUT IN MESS     1627F
         AI,R15   1                 BUMP RETURN ADDR
         B        *R15
*
KLUNK    RES      0                 KEY LENGTH IS JUNK                  2379B
         LI,R5    TOKYD                                                 2379D
         B        KLERCOM                                               2379F
KLER     RES      0                 LENGTH WRONG FOR THIS DATA TYPE     2379H
         LI,R5    TONXK                                                 2379J
KLERCOM  RES      0                                                     2379L
         KENO     KLERM             GET KEY NO INFO MESSAGE
         M:PRINT  (MESS,KLERM)
         MTW,1    ERCNT+3           ERROR FLAG
         B        *R5                                                   2383B
KBNDR    RES      0
         KENO     KBNDRM            GET KEY NO INFO MESSAGE
         M:PRINT  (MESS,KBNDRM)
         MTW,1    ERCNT+3           ERROR FLAG
         B        TOKYD             RESUME EDIT
KYSTRT   RES      0
         KENO     KYSTRTM           GET KEY NO INFO MESSAGE
         M:PRINT  (MESS,KYSTRTM)
         MTW,1    ERCNT+3           ERROR FLAG
         B        TOKYL             RESUME EDIT
KDTR     RES      0
         KENO     KDTRM             GET KEY NO INFO MESSAGE
         M:PRINT  (MESS,KDTRM)
         MTW,1    ERCNT+3           ERROR FLAG
         B        TONXK             RESUME EDIT
SPCKLM   BNOBLK   NUMVAL,(SPECS,1),*2   IS FIELD BLANK IF NOT CHECK VAL.1MG14900
         BNOTZR   SPCER,6,4             IS BLANK OK IF NOT ERROR        1MG15000
         LI,9     0                 SET BLANK VALUE
         B        *5                (R5)= RETURN ADDRESS                1MG15200
NUMVAL   RES      0
         BCDBIN   (SPECS,1),*2      (R2)= LENGTH OF FIELD
         BCS,12   SPCER             PARTIAL ILLEGAL CHARACTER CHECK
         CLM,9    *3                (R3)= ADDRESS OF LIMITS             1MG15400
         BCR,9    MUL10             SEE IF VALUE NEEDS 10X
SPCER    STW,4    ERCNT+2           (R4)= ERMS3 POINTER                 1MG15800
         BAL,13   MRTNCTL           LINK TO LOGGER
         B        *5                (R5)= RETURN ADDRESS                1MG16100
MUL10    CLM,1    LMTN              10X ONLY COLS. 23-25
         BCS,9    *5
         MI,9     10
         CI,9     0
         BNE      *5
         LW,9     L(X'7FFFFFFF')
         B        *5
         TITLE    'MEMORY ALLOCATION ROUTINE'
         PAGE
LEN      SET      8                 ENTRY LENGTH OF LOCBLK
MEMCAL   RES      0
         LW,3     DCBTABLE          GET DCB 1 ADDR TO START
         STW,3    DCBADDR
         LI,3     0                 INITIALIZE INDEX
         LI,5     3                 INITIALIZE INDEX
         LI,6     5                 INITIALIZE INDEX
         BAL,8    GETWORD0           GET DEVICE TYPE
         CI,4     X'A'              A FOR ANSI
         BNE      MEMCALA           NO GO TO LOOP, CHECK ALL INPUTS
         BAL,8    GETWORD3          SEE ABD SAVE BLOCK SIZE
         BAL,8    GETWORD5          SEE ANSI TYPE
         STW,4    ANSISWIN          SAVE ANSI TYPE
MEMCALA  BAL,8    MEMCHK            EXAMINE DCB 2
         BAL,8    MEMCHK            EXAMINE DCB 3
         BAL,8    MEMCHK            EXAMINE DCB 4
         BAL,8    MEMCHK            EXAMINE DCB 5
         BAL,8    MEMCHK            EXAMINE DCB 6
         BAL,8    MEMCHK            EXAMINE DCB 7
         BAL,8    MEMCHK            EXAMINE DCB 8
MEMCALW  LW,4     F:MRGOUT,3         SEE IF OUTPUT IS ANSI
         SLS,4    +28
         SLS,4    -28
         CI,4     X'A'
         BNE      MEMCALX
         LW,4     F:MRGOUT,6         GET WORD 5
         SLS,4    +24
         SLS,4    -28
         CI,4     2                 2 ANSI DEC
         BE       DECABORT          DECIMAL ANSI ABORT
         CI,4     0                 NO ANS TYPE GIVEN
         BE       DECABORT
         STW,4    ANSISWOU
         LW,4     F:MRGOUT,5          BITS 0-14 HAVE BLK-SIZE
         SLS,4    -17
         STW,4    BLKSIZEO          SAVE OUT ANS BLS-SIZE BYTE
         LW,3     4
         DW,3     OUTLEN
         STW,3    WKBO              ONLY FOR MEMORY CALC (OUT-BKL + 1)
MEMCALX  RES      0
         LI,4     0
         LI,6     0
         LW,3     WKLN              INPUT  MIN. SIZE UNBLOCKED          2MG00400
         LW,5     OUTLEN
         CW,6     WKBI              IF MONITOR NO BLOCKING
         BE       %+2
         MW,3     WKBI              INPUT MIN. SIZE                     2MG00900
         CW,6     WKBO              IF MONITOR NO BLOCKING
         BE       %+2
         MW,5     WKBO              OUTPUT MIN. SIZE                    2MG01200
         STW,3    WKONINS           SAVE INDIVIDUAL BLOCK LENGTH
         STW,5    WKONOTS
         LW,8     ANSISWIN          IS IT ANSI BVAR
         CI,8     3
         BNE      %+3               NO
         LW,3     BLKSIZE            BLK SIZE OF ANS BVAR
         STW,3    WKONINS           USE THAT BYTE VALUE FOR BUFF SIZE
         LW,8     ANSISWOU             IS OUTPUT ANSI BVAR
         CI,8     3
         BNE      %+3                NO
         LW,5     BLKSIZEO           HAS OUT ANS BLK SIZE
         STW,5    WKONOTS           USE THAT BYTE VAL FOR BUFF SIZE
         MW,3     WKFL              INPUT SIZE ALL FILES
         STW,3    WORK                                                  2MG01300
         STW,5    WORK+1                                                2MG01400
         AW,5     3                 TOTAL MIN. SIZE                     2MG01500
         SLD,4    21                GET 1X PAGES
         STD,4    WORK+2
         SLD,4    1                 GET 2X PAGES
         CI,5     0                 ANY PARTIAL PAGE
         BE       %+2
         AI,4     1                 IF EXTRA WORDS ADD ONE PAGE
         LW,8     4
         OR,8     L(X'08'**24)      PSEUDO M:GP
         CAL1,8   8
         STD,8    WORK+4
         BCS,8    %+4               IF SHORT SEE WHAT CAN FIT
         MTW,1    WINBF
         MTW,1    WOTBF
         B        TOTERCK
         LD,4     WORK+2            CHECK IF MINIMUM CORE
         CI,5     0                 ANY PARTIAL PAGE
         BE       %+2
         AI,4     1
         CW,4     8                 COMPARE REQ. TO AVAIL.
         BLE      ENFCOR
         LI,2     2                 SET ERMS1                           2MG02300
         LI,3     6                 SET ERMS2                           2MG02400
         STD,2    ERCNT                                                 2MG02600
         LI,2     8                 SET ERMS3
         LI,3     1                 BYTE OFFSET FOR REQ. PAGES
         STW,2    ERCNT+2
         BINBCD   WORK+2,(ERMS3+43,3),5   PUT REQ.   PAGES IN MESSAGE
         BINBCD   WORK+4,ERMS3+47,5    PUT AVAIL. PAGES IN MESSAGES
         B        MRTNCTL           ***** DEPENDENT ON ERMS3 TEXT ***** 2MG03100
ENFCOR   SLD,4    11                GET BYTE SIZES
         SLS,8    11
         SW,8     4                 FIND ANY OVERAGE
         LW,4     WKBI              BUFFERING
         CW,4     WKBO              OUTPUT GET 1ST TRY IF EQUAL IN
         BL       %+2               BLOCKING TO INPUT  OUTPUT WINS
         LI,6     1
         CW,8     WORK,6
         BGE      %+4               IF IT FITS SKIP OTHER TRY
         EOR,6    L(1)              SET TO LOSSER
         CW,8     WORK,6            IF LOSSER DOESNT FIT NO PARTIAL
         BL       %+2               BUFFERING
         MTW,1    WINBF,6           SET BUFFER FOR PARTIAL
         SW,8     WORK,6            FIND TURN BACK WORDS
         SLS,8    -11               FIND TURN BACK PAGES
         OR,8     L(X'09'**24)      PSEUDO M:FP
         CAL1,8   8
TOTERCK  LW,6     ERCNT+3           GET ERROR COUNT
         BEZ      NOERRS            IF 0 SKIP ABORT
         LI,6     2                 SET TO ABORT                        2MG03400
         LI,7     8                                                     2MG03500
         STD,6    ERCNT                                                 2MG03600
         LI,15    -1
         STW,15   ERCNT+2
         B        MRTNCTL           M:XXX                               2MG03800
NOERRS   RES      0
         M:CLOSE  M:SI
         LW,9     WORK+5
         LW,5     WKFL
         MI,5     LEN
         STW,5    WKTPLC            SAVE TOP OF LOCBLK
         SLS,9    2                 GET BUF BYTE ADDRESS
         LI,1     0
         LI,2     0
         LI,3     0
         LI,4     0
         STW,9    LOCBLK            SET OUTPUT BUF ADDRESS
         STW,9    LOCBLK+2
         AW,9     WKONOTS           GET NEXT BUF ADDRESS
         STW,9    LOCBLK+3          SET NEXT BUF ADDRESS IN OUTPUT ENTRY
         STD,2    LOCBLK+4
         STD,2    LOCBLK+6
         LW,5     WOTBF
         AW,9     WKONOTS           ASSUME MAX BUF
         B        %+1,5
         SW,9     WKONOTS           IF LESS SUBTRACT 1 BUF
         LW,5     WINBF
NXLOC    AI,1     LEN               GET NEXT INPUT ENTRY
         AI,4     LEN/2
         STW,2    LOCBLK,1          SET INPUT BUF ADDRESS
         STW,9    LOCBLK+2,1
         AW,9     WKONINS           GET NEXT BUF ADDRESS
         STW,9    LOCBLK+3,1        SET NEXT BUF ADDRESS IN INPUT ENTRY
         STD,2    LOCBLK+4,4
         STD,2    LOCBLK+6,4
         AW,9     WKONINS           ASSUME MAX BUF
         B        %+1,5
         SW,9     WKONINS           IF LESS SUBTRACT 1 BUF
         CW,1     WKTPLC
         BLE      NXLOC             IF MORE FILES LOOP
         B        MERGE2
GETWORD0 LW,4     *DCBADDR,3
         SLS,4    +28
         SLS,4    -28               WORD 4 HAS ANSWER
         B        *8
*
GETWORD3 LW,4     *DCBADDR,5
         SLS,4    -17               GET BLK-SIZE
         CW,4     BLKSIZE           0 1ST TIME
         BL       %+2
         STW,4    BLKSIZE           SAVE LARGER BLKSIZE
         B        *8
*
GETWORD5 LW,4     *DCBADDR,6
         SLS,4    +24
         SLS,4    -28
         CI,4     2                 2 ANSI DEC
         BE       DECABORT          ERROR  ANSI DECIMAL NOT SUPPORTED.
         CI,4     0                  0 FOR NO ANS TYPE GIVEN
         BE       DECABORT
         B        *8
*
UPDCBADR RES      0
         LW,4     COUNT             DCB INDEX VAL
         LW,4     DCBTABLE,4           GET NEW ADDR
         STW,4    DCBADDR           COMPUTED NEW DCB ADDR
         B        *8
*
MEMCHKA  DATA     0
MEMCHK   STW,8    MEMCHKA           SAVE RETURN
         LW,4     COUNT             NUMBER OF TIMES THRU, START 1, 9 MAX
         AI,4     1
         CW,4     WKFL
         BE       MEMCALW
         STW,4    COUNT
         BAL,8    UPDCBADR          INCREMENT DCB ADDR, TO EXAMINE NEXT
         BAL,8    GETWORD0          SEE WORD ZERO FOR TYPE BITS 28-31
         CI,4     X'A'              A FOR ANSI
         BE       MEMCHKB           YES
         MTW,0    ANSISWIN          NO. SEE IF ANY PREVIOUS ANSI
         BEZ      MEMCHKC
         B        ANSIMIX           YES THERE IS AN INPUT TYPE MIX ERROR
MEMCHKB  BAL,8    GETWORD3          GET BLK SIZE BITS 0-14
         BAL,8    GETWORD5          GET ANSI TYPE   BITS 24-27
         CW,4     ANSISWIN          SEE IF ALL ANSI-TYPES ARE THE SAME
         BNE      ANSIMIX           NO, TRYING TO USE MIX OF ANSI  ERROR
MEMCHKC  B        *MEMCHKA          EXIT
*
ANSIMIX  LI,8     E1
         STW,8    ERMES
         B        ERRABORT
*
DECABORT LI,8     E2
         STW,8    ERMES
ERRABORT LCI      15
         STM,1    SVR2
         M:PRINT  (MESS,*ERMES)
         B        ENJB0
*
E1       TEXTC    'INPUT FILES NOT COMPATABILE'
E2       TEXTC    'ANSI DECIMAL OR UNSPECIFIED FORMAT'
ERMES    DATA     0
ANSISWIN DATA     0                 ANSI TYPE FOR INPUT
ANSISWOU DATA     0                 ANSI TYPE FOR OUTPUT
DCBADDR  DATA     0                 WORD ADDR  OF DCB BEING EXAMINED
DCBTABLE DATA,4   F:MRGIN1,F:MRGIN2,F:MRGIN3,F:MRGIN4,F:MRGIN5,;
                  F:MRGIN6,F:MRGIN7,F:MRGIN8
BLKSIZE  DATA     0                 SIZE (BYTE) OF BLOCK OF ANSI FILE
BLKSIZEO DATA     0                 BYTE SIZE OUT ANS BLK
COUNT    DATA     0                 NUM OF TIMES THRU MEMCHK
PROG2    CSECT    0
         DEF      PH:II
         TITLE    'DCBS F:MRG'
         PAGE
TPIN     EQU      INSRT+17               UTS CHANGE
*        THE FOLLOWING MERGE DCB'S HAVE BEEN CHANGED FOR UTS
F:MRGOUT DSECT    1
F:MRGOUT M:DCB    (FILE,'                               '),;
                  (CONSEC),(SEQUEN),(OUT),(PASS),(SAVE),;
                  (WRITE),(READ),(SN,96),(SYNON),;
                  (BCD),(ABN,OUTOPAB),(ERR,OUTOPAB),(TRIES,10)
ZAPOUT   RES      0
         ORG      F:MRGOUT+1
         DATA     X'00040000'
         ORG      ZAPOUT
F:MRGIN1 DSECT    1
F:MRGIN1 M:DCB    (FILE,'                               '),;
                  (CONSEC),(SEQUEN),(IN),(PASS),(SAVE),;
                  (SN,12),(BCD),(TRIES,40),(ABN,INOPAB),(ERR,INOPAB)
F:MRGIN2 DSECT    1
F:MRGIN2 M:DCB    (FILE,'                               '),;
                  (CONSEC),(SEQUEN),(IN),(PASS),(SAVE),;
                  (SN,12),(BCD),(TRIES,40),(ABN,INOPAB),(ERR,INOPAB)
F:MRGIN3 DSECT    1
F:MRGIN3 M:DCB    (FILE,'                               '),;
                  (CONSEC),(SEQUEN),(IN),(PASS),(SAVE),;
                  (SN,12),(BCD),(TRIES,40),(ABN,INOPAB),(ERR,INOPAB)
F:MRGIN4 DSECT    1
F:MRGIN4 M:DCB    (FILE,'                               '),;
                  (CONSEC),(SEQUEN),(IN),(PASS),(SAVE),;
                  (SN,12),(BCD),(TRIES,40),(ABN,INOPAB),(ERR,INOPAB)
F:MRGIN5 DSECT    1
F:MRGIN5 M:DCB    (FILE,'                               '),;
                  (CONSEC),(SEQUEN),(IN),(PASS),(SAVE),;
                  (SN,12),(BCD),(TRIES,40),(ABN,INOPAB),(ERR,INOPAB)
F:MRGIN6 DSECT    1
F:MRGIN6 M:DCB    (FILE,'                               '),;
                  (CONSEC),(SEQUEN),(IN),(PASS),(SAVE),;
                  (SN,12),(BCD),(TRIES,40),(ABN,INOPAB),(ERR,INOPAB)
F:MRGIN7 DSECT    1
F:MRGIN7 M:DCB    (FILE,'                               '),;
                  (CONSEC),(SEQUEN),(IN),(PASS),(SAVE),;
                  (SN,12),(BCD),(TRIES,40),(ABN,INOPAB),(ERR,INOPAB)
F:MRGIN8 DSECT    1
F:MRGIN8 M:DCB    (FILE,'                               '),;
                  (CONSEC),(SEQUEN),(IN),(PASS),(SAVE),;
                  (SN,12),(BCD),(TRIES,40),(ABN,INOPAB),(ERR,INOPAB)
         USECT    PROG2
         TITLE    'KEY COMPARISON SUB-ROUTINE- KEYBLD'                  1269B
         PAGE                                                           1269D
* COMPARE THE KEY FIELDS OF 2 RECORDS AND RETURN AN INDICATION          0101
*  OF WHICH IS THE WINNER                                               0102
*                                                                       0103
* ENTRY PARAMETERS- REG 6 = RECORD 1 MEMORY START BYTE                  0104
*                   REG 7 = RECORD 2 MEMORY START BYTE                  0105
* EXIT RESULTS    - REG 12 = RETURN ADDRESS IF ONE WINS
*                   REG 13 = RETURN ADDRESS IF TWO IS ILLEGAL
*                   REG 14 = RETURN ADDRESS IF ONE IS ILLEGAL
*                   REG 15 = RETURN ADDRESS IF TWO WINS
*                   OTHER REGISTERS UNCHANGED                           1293D
KEYBLD   RES      0                                                     0111
         LCI      0                                                     1236B
         STM,R0   KYBRSV            SAVE REGISTERS                      0113
         LW,R2    NUMKEYS                                               1325B
         LW,R3    KTBSTRT           1ST KEY TBLE ENTRY ADDR             1238B
         B        CALKLOC                                               0114H
* START KEY COMPARISON-  R2 = NUMBER OF KEYS LEFT TO COMPARE            0115
*                        R3 = KEY TABLE ENTRY START ADDR (WORD)         0115B
STRTKMP  RES      0                                                     0116
         AI,R3    4                 POINT TO NEXT KEY IN TABLE          1331B
* GET KEY BYTE LOCATIONS IN THE TWO PLAYER RECORDS                      0120
CALKLOC  RES      0
         AND,R6    L(X'7FFFF')      BYTE ADDRESSES OF PLAYERS
         AND,R7    L(X'7FFFF')
         LI,R4     1                 HALF WORD OFFSET
         AH,R6    *R3,R4            KEY OFFSET IN RECORD TO PLAYER      0201
         AH,R7    *R3,R4                       ADDRESSES                0202
* IS THIS KEY BINARY?                                                   0203
         CB,R4    *R3,R4            TEST BYTE 1 FOR TYPE CODE 01        0204
         BE       S:BINK            ASSEMBLE BINARY- GO TO BINRYK       0205
         LW,R5    1,R3              GET KEY LENGTH FROM ENTRY TABLE     1338B
* KEY TRANSLATION REQUIRED?                                             0206
         CB,R4    *R3               TEST BYTE 0 FOR TRANSL CODE 01      0207
         BE       S:TRANK           MOVE KEYS AND TRANSLATE             1341B
ENDTRAN  RES      0                                                     1341D
* PACK ZONED DECIMAL?                                                   0209
         LB,R1    *R3,R4            GET TYPE CODE                       0210
         CI,R1    3                                                     0210
         BG       S:ZONDK           4-5= ZONED DECIMAL                  0211
         BL       ALPHKMP           02= ALPHA                           0212
* LOAD PACKED DECIMAL KEY                                               0213
         OR,R5    DLINST            PACKED LENGTH TO DCML LOAD INST     0300
         EXU      R5                LOAD R6 FIELD TO DECA               0301
         BID      ILLWON                                                0301B
ZPCMP    AND,R5   L(X'F'**20)       PULL OUT LENGTH AGAIN               0302
         OR,R5    DCINST            INTO DECIMAL COMPARE                0303
         EXU      R5                COMPARE R7 FIELD TO DECA            0304
         BID      ILLTWO                                                0305
         B        WINTEST                                               0306
DLINST   DL,0     0,R6                                                  0307
DCINST   DC,0     0,R7                                                  0308
* ALPHA KEYS                                                            0309
ALPHKMP  RES      0                                                     0310
         OR,R7    R5                SET UP A BYTE OPER LNGTH            0311
         CBS,R6   0                                                     0312
WINTEST  EXU      3,R3              BL OR BG ASCEND:DESCEND SEQ         1280B
* PLAYER 1 DID NOT WIN                                                  0381
         BNE      TWOWINS           DID PLAYER 2 WIN?                   0382
         LD,R6    KYBRSV+6          RESTORE PLAYER BEGIN ADDR           0383
         BDR,R2   STRTKMP           TRY NEXT KEY                        0384
* PLAYER 1 WINS                                                         0391
WONWINS  RES      0                                                     0392
         LCI      0                                                     1287B
         LM,R0    KYBRSV                                                0401
         B        *12
* PLAYER 2 WINS                                                         0403B
TWOWINS  RES      0                                                     0403D
         LCI      0                                                     1293B
         LM,R0    KYBRSV                                                0403H
         B        *15
* ILLEGAL DECIMAL KEYS                                                  0404
ILLWON   LCI      0                 R6 ILLEGAL
         LM,R0    KYBRSV
         B        *14
ILLTWO   LCI      0                 R7 ILLEGAL
         LM,R0    KYBRSV
         B        *13
*                                                                       0500
* S:BINK- COMPARE BINARY KEYS                                           0501
*  REG 3= KEY TABLE ENTRY START ADDR (WORD)                             0502
*      6= KEY 1 START BYTE LOCATION                                     0503
*      7= KEY 2 START BYTE LOCATION                                     0504
S:BINK   RES      0                                                     0505
         BAL,R1   SHFBIN            JUSTIFY R7 PLAYER IN R8-9           0506
         STD,R8   R10               MOVE PLAYER 2 TO R10-11             0507
         STW,R6   R7                DO PLAYER 1                         0508
         BAL,R1   SHFBIN                                                0509
         EXU      2,R3              CW OR CD INSTR IN KEY TABLE         0510
         B        WINTEST                                               0511
*                                                                       0512
SHFBIN   RES      0                                                     0513
         STW,R7   R4                KEY ADDR TO BYTE STRING SOURCE      0514
         LI,R5    32                BA(R8) TO DESTINATION               1331B
         OR,R5    1,R3              GET BYTE LENGTH INTO DEST REG       0516
         MBS,R4   0                 BINRY KEY LEFT JUSTIFIED IN R8      0517
         SLS,R5   3                 CONVERT ENDING BYTE TO BIT ADDR
         AI,R5    -320              GET RIGHT SHIFT VALUE
         SAD,R8   0,R5              SHIFT TO R9                         0520
         B        *R1                                                   0521
*                                                                       0600
* S:ZONDK- PACK AND COMPARE ZONED DECIMAL KEYS                          0601
*  REG 1= TYPE CODE: (4= ODD BYTE COUNT) (5= EVEN BYTE COUNT)           0601B
*      3= KEY TABLE ENTRY START ADDR (WORD)                             0602
*      5= LENGTH FROM KEY TABLE WORD 2 (PCKD IF TYPE 4)                 0603
*      6= KEY 1 START BYTE LOCATION                                     0605
*      7= KEY 2 START BYTE LOCATION                                     0606
S:ZONDK  RES      0                                                     0607
         CI,R1    4                 EVEN OR ODD BYTE COUNT              0608
         BNE      EVNZO                                                 0609
         LW,R1    1,R3              GET LENGTH AGAIN                    0609B
* PACK ODD COUNT FIELDS                                                 0610
PKODDK   OR,R5    PCKINS            PACK R7 PLAYER INSTR                0611
         EXU      R5                PCK,0  0,R7                         0611B
         BID      ILLTWO                                                0612
         OR,R1    DSTINS                                                0612H
         EXU      R1                DECML STORE PLAYER 2 KEY            0612J
         STW,R6   R7                                                    0613
         EXU      R5                PACK R6 PLAYER INTO DECA            0614
         BID      ILLWON                                                0615
         LI,R7    BA(ZDSVE)         LOC OF SAVED PLAYER 2               0616
         B        ZPCMP             FINISH UP IN PACKED DEC ROUTINE     0617
PCKINS   PACK,0   0,R7                                                  0618
DSTINS   DST,0    ZDSVE                                                 0619
* MOVE EVEN COUNT ZONED FIELDS TO WORK AREA AND THEN PACK               0700
*  R5= LENGTH OF BYTE STRING IN BIT 0-7                                 0700B
EVNZO    RES      0                                                     0701
         OR,R5    L(BA(ZDWRKA)+1)   SET UP MOVE TO AN AREA WITH A       0703
         STW,R7   R4                      HIGH ORDER DECML ZERO         0704
         MBS,R4   0                 MOVE PLAYER 2                       0705
         LW,R5    1,R3              GET LENGTH                          1435B
         OR,R5    L(BA(ZDWRKB)+1)                                       1435D
         STW,R6   R4                                                    0707
         MBS,R4   0                 MOVE PLAYER 1                       0708
         LI,R6    BA(ZDWRKB)        SUBSTITUTE WORK AREA ADDRESSES
         LI,R7    BA(ZDWRKA)
         LW,R5    1,R3              GET LENGTH
         SLS,R5   -5                LNGTH /2                            0710
         AW,R5    L(X'1'**20)       = L/2 +1 = PACKED LNTH              0711
         AND,R5   L(X'F'**20)       BIT 8-11 ONLY                       0712
         STW,R5   R1                FOR LATER DECIMAL STORE             0712B
         B        PKODDK            FINISH UP AS ODD COUNT KEYS         0713
*                                                                       0001
* S:TRANK- TRANSLATE KEYS TO USER CHARACTER SET (NO BINARY KEYS)        0002
*  ENTRY PARAMETERS:                                                    0002B
*  REG 3= KEY TABLE START ADDR(WORD)                                    0003
*      5= KEY TABLE WORD 2 (KEY LENGTH IN BYTE 1 OR 2)                  0003B
*      6= KEY 1 START ADDR(BYTE)                                        0004
*      7= KEY 2 START ADDR(BYTE)                                        0005
*  EXITRESULTS:                                                         0006
*  REG 1-5 = UNCHANGED                                                  0007
*       6  = ADDR OF TRANSLATED KEY 1 (BYTE)                            0008
*       7  = ADDR OF TRANSLATED KEY 2 (BYTE)                            0009
*  NOTE: KEYS 1 AND 2 ARE MOVED CONSECUTIVELY (AND TRANSLATED) INTO     0010
*         A 128 WORD WORK AREA LOCATED 192 WORDS DOWN FROM THE          0011
*         HIGH END OF MEMORY.                                           0012
*        THE USER TRANSLATION TABLE IS A 64 WORD TABLE LOCATED 64       0014
*              WORDS DOWN FROM HIGH END OF MEMORY                       0015
S:TRANK  RES      0                                                     0017
         LCI      5                                                     0018
         STM,R1   TRANKSV           SAVE R1-5                           0019
* SET UP KEY LNGTH FOR MOVE BYTE STRING OPERATION                       0020
         AND,R5   L(X'FFFF'**16)                                        0021
         LI,R4    1                                                     0100
         LB,R1    *R3,R4            GET TYPE CODE                       0101
         CI,R1    2                 ALPHA                               0102
         BLE      MVTKY             YES- GO TO MBS                      0103
         CI,R1    5                 ZONED DECIMAL- EVEN BYTE LNGTH?     0104
         BE       MVTKY             YES- GO TO MBS                      0105
* KEY IS PACKED DECIMAL OR ZONED ODD COUNT LENGTH                       0105B
         CI,R5    0                 IS LENGTH IMPLIED 16?               0106
         BNE      %+2               NO                                  0107
         OR,R5    L(1**24)          YES- TURN ON BIT 7                  0108
         SLS,R5   4                 SHIFT TO MBS POSITION               0109
         CI,R1    3                 PACKED DECIMAL?                     0110
         BE       MVTKY             YES- BYTE LENGTH IS FIELD LNTH      0111
         SLS,R5   1                 ZONED DECIMAL: EXPAND PACKED        0112
         SW,R5    L(1**24)            COUNT TO 2L-1                     0113
* MOVE AND TRANSLATE THE KEYS                                           0114
MVTKY    RES      0                                                     0115
         STW,R6   R14               GET KEY 1 SOURCE LOCATION           0115B
         LW,R15   TRANTAB           GET KEY 1 DESTINATION ADDR          0116
         STW,R15  R6                NEW KEY 1 LOCATION                  0117
         OR,R15   R5                GET KEY FIELD LENGTH                0118
         MBS,R14  0                 MOVE KEY 1                          0119
         STW,R7   R14               GET KEY  2 SOURCE LOCATION          0120
         STW,R15  R7                NEW KEY 2 LOCATION                  0200
         OR,R15   R5                LENGTH                              0201
         MBS,R14  0                 MOVE KEY 2                          0202
* TRANSLATE THE RELOCATED FIELDS                                        0203
         LW,R14   TRANTAB           BASE ADDR OF WORK AREA              0204
         LW,R15   TRANTAB           KEY 1 LOCATION                      0205
         OR,R15   R5                LENGTH                              0206
         TBS,R14  512               TRANS TABLE IS 128 WORDS UP         0207
         OR,R15   R5                R15 NOW POINTS AT KEY 2             0208
         TBS,R14  512               TRANS KEY 2                         0209
*                                                                       0210
         LCI      5                                                     0211
         LM,R1    TRANKSV           RESTORE R1-5                        0212
         B        ENDTRAN                                               0213
         TITLE    'PH:II MAIN CONTROL'
         PAGE
PH:II    LI,1     1                 TOP OF INSRT (-RESERVE FOR SQUASH)
         LI,2     -8                DOUBLE WORD BOTTOM OF INSRT
         LI,6     LEN               SET FIRST READ POINTER
         LI,12    INLP2             ONE WINS RETURN
         LI,13    COMER2            ERROR RETURNS (KEYBLD)
         LI,14    COMER1
SETUP1   BAL,15   INGET             GET INITIAL DATA
         STD,6    INSRT,1           SETUP SORT TABLE
INGETER  AI,6     LEN
         AI,1     1                 DOUBLE WORD INCRIMENT
         CW,6     WKTPLC
         BLE      SETUP1            IF MORE ENTRIES LOOP
         LW,3     ERCNT+3           CHECK FOR INITIALIZATION ERRORS
         BEZ      OUTLP1
         LI,2     2                 IF ERRORS ABORT
         LI,3     8
         STD,2    ERCNT
         LI,2     -1
         STW,2    ERCNT+2
         B        MRTNCTL
OUTLP1   LW,3     2
         AI,3     1                 GET NEXT DOUBLE WORD POINTER
OUTLP1A  LD,4     TPIN-1,2          GET CONTESTANTS  IF 0 SKIP
         CI,5     0
         BE       OUTLP2
INLP1    LD,6     TPIN-1,3
         CI,7     0
         BE       INLP2
         LW,6     5
         BAL,15   KEYBLD            COMPARE
         LD,6     TPIN-1,2     IF TWO WINS, EXCHANGE       /SIG7-1217/*C5267
         LD,4     TPIN-1,3    ENTRIES SO THAT THE          /SIG7-1217/*C5267
         STD,4    TPIN-1,2    WINNER STAYS IN              /SIG7-1217/*C5267
         STD,6    TPIN-1,3    REGISTERS 4 AND 5.           /SIG7-1217/*C5267
INLP2    BIR,3    INLP1             1 WINS RETURN  INNER LOOP
         CI,3     0
         BE       INLP1
OUTLP2   BIR,2    OUTLP1            OUTER LOOP
SQUASH   LI,1     0                 PACK INSERT TO BOTTOM OF AREA
         LI,2     -1
         LI,3     0
SQUASH1  LD,4     TPIN-1,1          GET OUTER LOOP ENTRY
         CI,5     0                 0=NULL FILE
         BNE      INCON             IF VALID INCRIMENT BOTTOM COUNT
         LD,4     TPIN-1,2          IF INVALID MOVE INNER LOOP ENTRY UP
         STD,4    TPIN-1,1          1 AND 0 OLD POSITION
         STD,2    TPIN-1,2
OTCON    AI,2     -1
         CI,2     -8
         BGE      SQUASH1           INNER LOOP REPEAT
         AI,1     1
         STW,1    WKTPIN            SAVE POINTER TO TOP OF INSRT
         BLEZ     MPUTOUT
         BGZ      MPUTCLS
INCON    AI,1     -1                INCRIMENT BOTTOM COUNT
         LW,2     1                 RESET INNER LOOP IN CASE IT LAGS
         B        OTCON
SELECT   LI,12    MPUTOUT           ONE WINS NO NEED TO RETURN
         LI,13    COMER4            ERROR RETURNS (KEYBLD)
         LI,14    COMER3
         LW,1     WKTPIN            TOP OF INSRT
INLP3    LD,6     TPIN+1,1          GET CONTESTANTS   REC2 TO R7
         LD,4     TPIN-1,1          REC1 TO R6
         LW,6     5
         BAL,15   KEYBLD            COMPARE
         LD,4     TPIN-1,1          IF TWO WINS EXCHANGE ENTRIES
         LD,6     TPIN+1,1
         STD,4    TPIN+1,1
         STD,6    TPIN-1,1
         BIR,1    INLP3             LOOP IF MORE
         TITLE    'OUTPUT CONTROLER'
         PAGE
MPUTOUT  LW,1     WKTPIN            GET WINNER
         AW,1     1                 GET WORD ADDRESS POINTER
         LI,13    COMER5            OUT OF SEQUENCE AND ILLEGAL
         LI,14    FORGET            ILLEGAL BUT OK
         LI,15    COMER5            OUT OF SEQUENCE
         LW,6     LOCBLK+4          SEQUENCE CHECK
         BEZ      %+3               NOT FIRST TIME
         LW,7     TPIN,1
         BAL,12   KEYBLD            COMPARE
FORGET   LW,6     TPIN,1
         LW,7     TPIN-1,1          % GET LOCBLK POINTER
         CW,6     LOCBLK+3,7        % WHICH BUFFER IS WINNER FROM
         BL       %+3               %
         LW,7     LOCBLK+7,7        % GET BUFFER # 2 SIZE
         B        %+2               %
         LW,7     LOCBLK+6,7        % GET BUFFER # 1 SIZE
         LW,15    WKLN
         CW,15    OUTLEN            IS INPUT SIZE GIVEN SAME AS OUT SZE
         BE       %+3               BLANK/ZERO WILL BE SET TO =
         LW,7     OUTLEN              USE WHAT USER SPECIFIED
         B        FORGET1
         CW,7     WKLN              IS SIZE = TO INPUT GIVEN
         BL       %+2               NO, MUST BE VARIABLE SO USE IT
         LW,7     WKLN              IF GREATER USE SIZE GIVEN,ELSE =
FORGET1  STW,7    LOCBLK+6            CURR REC SIZE FOR OUTPUT
         BAL,15   PUTOUT            OUTPUT OK RECORD
PUTRTN   LW,6     TPIN-1,1
         BAL,15   INGET
         STW,7    TPIN,1
         CI,7     0
         BE       SQUASH            IF EOF ELIMINATE FROM INSRT
         CI,1     0                 IF ONLY ONE FILE JUST OUTPUT
         BLZ      SELECT
         B        MPUTOUT
MPUTCLS  B        ENDOUT            FLUSH PARTIAL BLOCKS
OCLOZD   LI,2     3                 SET UP RECORD COUNT MESSAGES
         LI,3     11
         STD,2    ERCNT
         LI,2     -1
         STW,2    ERCNT+2
         LI,1     0
         LI,2     0
         LI,3     3
RECNT    BINBCD   (LOCBLK+5,1),(ERMS2+45,3),10
TOTCNT   BAL,13   MRTNCTL           PRINT MESSAGE
         MTB,1    ERMS2+42,3        INCRIMENT FILE NO. FOR NEXT MESSAGE
         AI,1     LEN
         AW,2     LOCBLK+5,1
         CI,1     8*LEN
         BLE      RECNT             RELOOP FOR MORE FILES
         LI,4     X'E3'
         STB,4    ERMS2+42,3        PUT T IN FILE NUMBER
         BINBCD   2,(ERMS2+45,3),10
         CI,1     9*LEN             PUTOUT TOTAL INPUT COUNT
         BLE      TOTCNT            RELOOP FOR TOTALS
FINUP    LI,2     0                 SET EXIT MESSAGE
         LI,3     0
         STD,2    ERCNT
         B        MRTNCTL           M:EXIT
         TITLE    'DATA INPUT ROUTINE'
         PAGE                                                           0000
* GET NEXT RECORD FROM A SPECIFIED FILE                                 0001
* ENTRY- REG 6 =  DISPLACEMENT IN FILE CONTROL TABLE OF POINTERS TO     0002
*                 FILE  TO BE ACCESSED                                  0003
*        REG 15=  RETURN ADDRESS                                        0004
* EXIT - RECORD COUNT AND CUR RCD IN CONTROL TABLE UPDATED              0005
*        REG 7 =  CUR RCD ADDR OR 000 IF EOF                            0006
*        ALL OTHER REGISTERS UNCHANGED                                  0007
INGET    RES      0                                                     0010
         LCI      15                                                    0011
         STM,1    INSVE             SAVE REGISTERS                      0012
DELRTN   RES      0                 OWN-CODE RETURN TO DROP RCD         0012B
         LW,15    INSVE+5                                               0013
         AI,15    LOCBLK            15= ADDR OF FILE CONTROL TABLE      0014
         LI,1     1                                                     0015
         LW,14    *15,1             14= DCB ADDRESS                     0016
* IS FILE OPEN                                                          0017
         LW,1     *14               DCB WORD 0                          0018
         AND,1    L(X'1'**21)       FCD BIT ON = OPEN                   0019
         BNEZ     BMPCUR                                                0020
* FILE CLOSED- DO HEADER CHECK AND BUFFER FILL                          0200
         LW,1     WKUIH             IS THERE A HEADER                   0201
         BEZ      FILWUN            NO
         LW,12    INHEDAD           GET MINHED ADDR                     0202B
         BAL,13   RDHDTR            DO THE HEADER                       0203
* READ FIRST BLOCK OF RECORDS                                           0204
FILWUN   RES      0                                                     0205
         LI,2     2                                                     0206
         LW,1     *15,2             GET BLOCK 1 ADDR                    0207
         LW,2     ANSISWIN
         CI,2     3                 ANSI BVAR
         BNE      FILWUN1
         AI,1     8                 GO PAST BLK/REC CTL WORDS
         STW,1    *15               PUT IN PLACE FOR 1ST REC
         AI,1     -8                BACK TO BEGIN FOR BUFFER
         B        %+2
FILWUN1  STW,1    *15               1ST REC ADDR
         LI,2     3                 CONVERT BYTE ADDR TO WORD+BTD       0208A
         AND,2    1                 GET BYTE DISPLACEMENT               0208B
         SLS,1    -2                TO WORD ADDRESS                     0208D
         M:READ   *14,(BUF,*1),(BTD,*2),(SIZE,*WKONINS),;               0210
                  (ERR,INRDERR),(ABN,CKINEND),WAIT                      0211
         MTW,0    SW414C             ERR ON BLK COUNT ON LST READ
         BEZ      %+3
         LW,10    SW414C            RESTORE 10 GO TO ERR FOR CHK
         B        INRDERR
         BAL,13   SHRTBLK           TEST SHORT LENGTH BLOCK             0212
         LW,12    INUSAD                                                0213B
         BEZ      CNTFST            NO OWN CODE SPEC
         LI,7     DELRTN            RCD DROP ADDR                       0213F
         BAL,13   USINLNK                                               0215
CNTFST   RES      0                                                     0216
         LI,1     5                                                     0217
         MTW,1    *15,1             ADD TO RECORD COUNT                 0218
* IS THERE A SECOND BUFFER?                                             0219
         LW,1     WINBF                                                 0220
         BEZ      RESREG            NO-EXIT                             0221
         LI,2     3                                                     0300
         LW,1     *15,2             GET BLOCK 2 ADDR                    0301
         AND,2    1                 CONVERT BYTE ADDR TO WORD + BTD     0302
         SLS,1    -2                                                    0302B
         M:READ   *14,(BUF,*1),(BTD,*2),(SIZE,*WKONINS),NOWAIT          0303
         B        RESREG            EXIT WHILE READING                  0304
* READ USER HEADER AND TRAILERS                                         0305
* ENTRY- REG 13= RETURN ADDR                                            0306
*             14= DCB ADDR                                              0307
*             15= FILE CONTROL TABLE LOCATION                           0308
*             12= HDR OR TRLR OWN-CODE ADDRESS                          0309
* EXIT -  REG 12-15 UNCHANGED                                           0310
RDHDTR   RES      0                                                     0311
         LCI      4                                                     0312
         STM,12   WORKOP            SAVE 12-15                          0313
         LI,1     255                                                   0314
         STB,1    TTSTORE           MAXIMUM HEADER-TRLR LENGTH          0315
         LW,1     WKBI              MONITOR FORMATTED FILE?             0316
         BEZ      OPNHED            YES- OPEN WITH TLABEL               0317
* READ USER FORMATTED FILE BLOCK                                        0318
         M:READ   *14,(BUF,TTSTORE),(BTD,1),(SIZE,255),;                0319
                  (ERR,HDRDERR),WAIT
         LI,1     4                                                     0321
         LW,1     *14,1             DCB WORD 4- ACTUAL RCD SIZE         0322
         SLS,1    -17                                                   0323
         STB,1    TTSTORE                                               0400
         B        USHDLNK           TO OWN-CODE LINK                    0401
* OPEN MONITOR FORMATTED FILE                                           0402
OPNHED   RES      0                                                     0403
         M:OPEN   *14,(TLABEL,TTSTORE),(ABN,INOPAB)                     0404
         M:CHECK  *14,(ERR,HDRDERR)                                     0404B
USHDLNK  RES      0                 LINK TO USER OWN-CODE               0405
         LW,7     INSVE+5           GET FILE CONTROL TABLE OFFSET       0406
         DW,7     L(LEN)            GET FILE NUMBER                     0407
         STW,7    4                 4= FILE NUMBER                 2267B
         LI,7     LBRTN             7= DUMMY RETURN                2267D
         LI,6     BA(TTSTORE)       ADDR OF LABEL BUFFER                0408
         LI,5     LBRTN             SET RETURN ADDRESS FOR OWN-CODE
         MTW,0    12                ANY SPECIFIED
         BEZ      USHDLNKA          NO
         LI,13    INHEDAD           INPUT HEADER OWN CD ADDR
         CW,12    13                INPUT OR OUTPUT IN REG 12
         BE       USHDLNKA-1          PROCESS HEADER
         B        *WORKOP           GO DO TRAILER OWN CODE
         B        LBRTN
         B        *WORKOP           GO DO HEADER OWN CODE
USHDLNKA LI,5     11
         LB,12    SPECS,5
         CI,12    X'C6'
         BNE      LBTRN1            SO IT IS 1-9
         M:PFIL   *14,(EOF)         SKIP REST OF HEADER FILE
         B        LBRTN
LBTRN1   RES      0
         CI,12    X'F2'
         BL       LBRTN
         AND,12   =X'0000000F'
         AI,12    -1                HAVE ALREADY DONE FIRST ONE
         M:PRECORD *14,(N,*12)
LBRTN    RES      0                                                2269B
         LCI      4                                                     0410
         LM,12    WORKOP            RESTORE 12-15                       0411
         B        *13               RETURN                              0412
* CHECK FOR SHORT LENGTH BLOCK                                          0500
* ENTRY- REG 13=  RETURN ADDRESS                                        0501
*            14=  DCB ADDR                                              0502
*            15=  FILE CONTROL TABLE LOCATION                           0503
* EXIT- CONTROL TABLE UPDATED IF SHORT                                  0504
*        REG 13-15 UNCHANGED                                            0505
SHRTBLK  RES      0                                                     0506
         LI,1     3                 % GET CURRENT BUFFER ADDRESS
         LW,8     *15               %
         LI,3     6                 % SET SIZE POINTER FOR BUFFER # 1
         CW,8     *15,1             % IF CURRENT RECORD IS IN BUFFER # 2
         BL       %+2               % RESET POINTER TO # 2
         AI,3     1                 %
         LI,1     4                 %
         LW,9     *14,1             %
         SLS,9    -17               % GET BYTE LENGTH
         STW,9    *15,3             % SAVE IN PROPER BUFFER
         LW,8     ANSISWIN
         CI,8     3                 ANSI BVAR
         BE       FULBLK1
         STW,9    LOCBLK+7          % SAVE RECORD LENGTH FOR OWN-CODE
         CW,9     WKONINS           % IF LENGTH EQUAL BLOCK THEN FULL OR
         BE       FULBLK            %
         CW,9     WKLN              % IF LENGTH LESS THAN 1 REC THEN FUL
         BL       FULBLK            % UNBLOCKED VARIABLE LENGTH
         LI,8     0                 %
         DW,8     WKLN              % IF NOT FULL OR VARIABLE  FIND # R
         CI,8     0                 % IF BLOCKED VARIABLE THEN ERROR
         BE       FULBLK+1                                 /SIG7-1748/*D4985
         LI,8     -1                % SET NO DKIP FLAG
         STW,8    LOCBLK+7          %
         B        MULTERR           % PRINT ERROR
FULBLK   LI,9     0                 % IF FULL BLOCK CANCEL SHORT FLAG
         STW,9    *15,1             %
         B        *13               RETURN                              0516
FULBLK1  SLS,6    -3                DIVIDE BY EIGHT
         AI,6     -1
         STW,9    BLKARS,6          SAVE READ RECORD LENGTH FOR FILE
         AI,6     1
         SLS,6    +3
         B        FULBLK
* RESTORE REGISTERS AND EXIT FROM INGET                                 0517
RESREG   RES      0                                                     0518
         LCI      15                                                    0519
         LM,1     INSVE                                                 0520
         LW,7     LOCBLK,6          CUR RCD ADDR FROM CONTROL TABLE     0521
         B        *15                                                   0522
* LINK TO USER OWN-CODE                                                 0600
* ENTRY- REG 12=  USER OWN-CODE ADDRESS                                 0601
*            13=  NORMAL RETURN ADDRESS                                 0602
*            14=  DCB ADDRESS                                           0603
*            15=  FILE CONTROL TABLE LOCATION                           0604
*        REG  7=  RETURN ADDRESS TO DROP RCD                            0605
* EXIT-  REG 14-15 UNCHANGED                                            0606
USINLNK  RES      0                                                     0607
         LCI      3                                                     0608
         STM,13   WORKOP            SAVE REG                            0609
         LW,6     *15               GET CUR RCD ADDR                    0610
         LW,1     INSVE+5           GET FILE CONTROL TABLE OFFSET  2304B
         DW,1     L(LEN)                                           2304D
         STW,1    4                 4= FILE NUMBER                 2304F
         LW,8     LOCBLK+7          % GET TRUE RECORD SIZE
         BAL,5    *12               TO USER                             0611
         LW,13    WKBI              % IF BLOCKED RECORDS NO CHANGE
         CW,13    WKBO              % ALLOWED
         BNE      LENOK             %
         CI,13    1                 %
         BG       LENOK             %
         CW,8     WKLN              % IF NEW LENGTH IS LONGER THAN MAX
         BLE      %+2               % RESET TO MAX ALLOWED
         LW,8     WKLN              %
         LW,14    *WORKOP+2         % GET CURRENT BUFFER ADDRESS
         LI,5     3                 %
         LI,6     6                 % SET SIZE POINTER TO BUFFER # 1
         CW,14    *WORKOP+2,5       % IF CURRENT RECORD IS IN BUFFER # 2
         BL       %+2               % RESET POINTER TO # 2
         AI,6     1                 %
         STW,8    *WORKOP+2,6       % SAVE IN PROPER BUFFER
LENOK    LCI      3                 %
         LM,13    WORKOP            RESTORE REG                         0613
         B        *13                                                   0614
* VARIOUS ERROR ROUTINES                                                0615
INOPAB   RES      0                                                     0616
         LI,6     X'41'
         CB,6     10
         BNE      INOPAB3
INOPAB1  LI,6     1
         LB,6     10,6              SEE SUBCODE
         SLS,6    -1
         CI,6     X'05'
         BE       INOPAB2
         CI,6     X'06'
         BNE      INOPAB4
INOPAB2  STW,10   SW414C
         B        *8                SAVE AND EXIT FOR CHK LATER
INOPAB3  LI,6     X'4C'
         CB,6     10
         BE       INOPAB1
INOPAB4  STW,15   9
         AI,9     -LOCBLK                                               0617B
         LI,8     9                 ABNORMAL OPEN POINTER               0618
         BAL,15   DROPER            TO MESSAGE GENERATOR                0619
         M:ERR                                                          0620
* ABNORMAL READ RETURN                                                  0712
CKINEND  RES      0                                                     0713
         LI,1     6                                                     0714
         CB,1     10                MONITOR FORMAT END-OF-FILE          0715
         BE       ENDIN                                                 0716
         LI,1     5                                                     0717
         CB,1     10                USER FORMAT END-OF-FILE             0718
         BE       TRLTST                                                0719
         B        *8                ALLOW OTHER ABN- RTRN THRU SR1      0720
* USER LABEL READ ERROR                                                 0800
HDRDERR  RES      0                                                     0801
         STW,15   9                                                     0802
         AI,9     -LOCBLK                                               0803
         LI,8     10                LABEL ERR POINTER                   0804
         BAL,15   DROPER            TO MESSAGE GENERATOR                0805
         M:ERR                                                          0806
*                                                                       0807
*                                                                       0808
* REPLACE A SELECTED RECORD FROM THE SAME FILE                          0809
*        REG 14 = DCB ADDRESS                                           0810
*            15 = FILE CONTROL TABLE ADDRESS                            0811
BMPCUR   RES      0                                                     0812
         LW,4     *15               CUR RCD ADDR IS SELECTED RECORD     0812
         LW,1     ANSISWIN
         CI,1     3                 ANSI BVAR
         BNE      BMPCUR1           NO
         AI,4     -4                BACK TO PREV WORD (RECLEN)
         LW,2     4                 CURR REC ADDR LESS CTL WORD
         SAD,2    -2                BITS TO R3
         SCS,3    2                 BITS TO R SIDE
         AND,3    =X'03'
         LB,13    *2,3              2 IS NOW WORD ADDR
         SLS,13   +8
         STW,13   SAVEIT
         AI,3     1                 UP INDEX
         LB,13    *2,3
         AW,13    SAVEIT
* TO RECONSTRUCT LENGTH FOR ANSI V (NECCESSARY) DUE TO BYTE ADDR
         AW,4     13                UP TO BEGIN OF NEXT REC
         LI,1     3
         LI,3     6
         LW,2     *15
         CW,2     *15,1
         BL       %+2
         AI,3     1
         AI,13    -4
         STW,13   *15,3             STORE REC LENGTH
         STW,13   LOCBLK+7
         AI,4     4                 PAST NEXT REC-CTL WORD FOR STORE
         STW,4    *15
         AI,4     -4
         SLS,6    -3                 DIVIDE BY EIGHT
         AI,6     -1
         STW,6    1                  SAVE INDEX
         AI,6     1
         SLS,6    +3                RESTORE LOCBLK INDEX
         AI,13    4                 UP LENGTH FOR CTL WORD
         AW,13    BLKSIZ,1           ACCUM BLK SIZE FOR THIS FILE
         STW,13   BLKSIZ,1           SAVE THE INCREMENT
         CW,13    BLKARS,1          ARE WE = TO BLK SIZE READ FOR FILE
         BL       INLIM             NO SO JUST PROCESS
*   HAVE READ AND PROCESSED A FULL BLOCK OF ANSI V RECORDS
         LI,3     4                 INITIALIZE BLK CTL LENGTH
         STW,3    BLKSIZ,1          RESET ACCUM BLKSIZ TO FOUR
         LI,3     3                 INDEX
         CW,4     *15,3             BUFFER TWO ADDR
         BG       VERLSTON           WE HAVE BEEN WITH BLK 2
*     OVER TOP OF BLK ONE, SINCE WE ADD LENGTH WE ARE EITHER
*    GREATER THAN BLK 2  START ADDR  OR LESS OR EQUAL IN WHICH
*    CASE WE HAVE BEEN ON BLOVK ONE
         LW,1     WINBF             IS THERE A BLOCK TWO
         BEZ      BMPCUR10           NO
         LI,1     3                 INDEX
         LW,1     *15,1             BLK TWO ADDR
         AI,1     8                 PAST BLK AND REC CTL WORDS
         STW,1    *15               RESET TO CURR REC  ADDR
         B        BMPCURA
BMPCUR10 LI,1     2                 INDEX
         LW,1     *15,1             BLOCK 1 ADDR
         AI,1     8                 PAST BLK AND REC CTL WORDS
         STW,1    *15               RESET CURR REC ADDR
         B        RDBLKON
* FOR ANSI V WILL NEVER (HOPEFULLY) TAKE BRANCH AT NXTBUF
BMPCUR1  AW,4     WKLN              4 TENTATIVE NEXT REC ADDR
         STW,4    *15               BACK INTO FILE CONTROL TABLE        0813B
         LI,1     3                                                     0814
         CW,4     *15,1             COMPARE TO BLOCK 2 ADDR             0815
         BL       INLIM             ADDR IS INSIDE BLOCK LIMIT          0816
         BG       NXTBUF            TEST END OF ALL INPUT BUFFERS       0817
* BLOCK 1 EXHAUSTED                                                     0818
         LW,1     WINBF             IS THERE A BLOCK 2?                 0819
         BEZ      RDBLKON           NO- REFILL 1                        0820
* VERIFY LAST BLOCK 2 INPUT OPERATION                                   0900
BMPCURA  RES      0
         BAL,13   CHKBLK            DO WE WANT TO CHECK ?
         M:CHECK  *14,(ERR,INRDERR),(ABN,CKINEND)
         MTW,0    SW414C             ERR ON BLK COUNT ON LST READ
         BEZ      %+3
         LW,10    SW414C            RESTORE 10 GO TO ERR FOR CHK
         B        INRDERR
         BAL,13   SHRTBLK                                               0902
* REFILL BLOCK 1                                                        0903
RDBLKON  RES      0                                                     0904
         LI,2     2                                                     0905
         LW,1     *15,2             GET BLOCK 1 ADDR                    0906
         LI,2     3                 CONVERT BYTE ADDR TO WORD+BTD       0907
         AND,2    1                 GET BYTE DISP                       0908
         SLS,1    -2                TO WORD ADDRESS                     0909
         M:READ   *14,(BUF,*1),(BTD,*2),(SIZE,*WKONINS),NOWAIT          0910
* ARE WE BELOW NEXT FILE'S BUFFER?                                      0911
NXTBUF   RES      0                                                     0912
         LW,1     *15               GET NEW ADDRESS                     0913
         LI,2     LEN+2
         CW,1     *15,2             COMPARE TO NEXT FILE BLOCK          0915
         BGE      VERLSTON          OVER THE TOP- BACK TO BLOCK 1       0916
* CHECK SHORT BLOCK FLAG                                                0917
INLIM    RES      0                                                     0918
         LI,1     4                                                     0919
         LW,2     *15,1                                                 0920
         BEZ      USAXES            NO SHORT BLOCK RCD COUNT            0921
         MTW,-1   *15,1             REDUCE THE COUNT                    1000
         BGZ       USAXES    RECORD ADDR IS VALID
         BLZ      DELRTN
         LI,1     7                 INDEX
         MTW,0    *15,1             ZERO IF SINGLE BUFFERED
         BNEZ     %+2
         B        BMPCURA            SHORT BLK EXHAUSTED
         LI,1     4                 INDEX
         MTW,-1   *15,1             MAKE NEGATIVE
* ANY USER ACCESS TO INPUT?                                             1002
USAXES   RES      0                                                     1003
         LW,12    INUSAD
         BEZ      COUNTIN                                               1005
         LI,7     DELRTN            RCD DROP ADDR                       1006B
         BAL,13   USINLNK                                               1007
* GOT IT!                                                               1008
COUNTIN  RES      0                                                     1009
         LI,1     5                                                     1010
         MTW,1    *15,1             ADD TO RECORD COUNT                 1011
         B        RESREG                                                1012
*                                                                       1013
* RESET TO BLOCK 1- VERIFY LAST INPUT OPERATION                         1014
VERLSTON RES      0                                                     1015
         LI,1     2                 GET BLOCK 1 ADDR                    1016
         LW,1     *15,1                                                 1017
         LW,13    ANSISWIN
         CI,13    3                 ANSI BVAR
         BNE      %+2
         AI,1     8
         STW,1    *15               TO CUR RCD ADDR                     1018
         BAL,13   CHKBLK            DO WE WANT TO CHECK ?
         M:CHECK  *14,(ERR,INRDERR),(ABN,CKINEND)                       1019
         MTW,0    SW414C             ERR ON BLK COUNT ON LST READ
         BEZ      %+3
         LW,10    SW414C            RESTORE 10 GO TO ERR FOR CHK
         B        INRDERR
         BAL,13   SHRTBLK                                               1020
         LW,1     WINBF             IS THERE A BLOCK 2?                 1100
         BEZ      INLIM             NO
* REFILL BLOCK 2                                                        1102
         LI,2     3                                                     1103
         LW,1     *15,2             GET BLOCK 2 ADDR                    1104
         AND,2    1                 GET BYTE DISP                       1106
         SLS,1    -2                TO WORD ADDRESS                     1107
         M:READ   *14,(BUF,*1),(BTD,*2),(SIZE,*WKONINS),NOWAIT          1108
         B        INLIM             CONTINUE WHILE READING
* INPUT READ ERROR                                                      1110
INRDERR  RES      0                                                     1111
         LI,2     X'41'             CHECK READ ERROR CODE               1112
         CB,2     10                                                    1113
         BNE      INRDERR1
         LI,2     1
         LB,2     10,2               SEE SUBCODE
         SLS,2    -1                7 BITS HAVE CODE
         CI,2     X'05'              EOF ?
         BE       TRLTST
* ANSI TAPES GET 41 XX (SUBCDE) WHEN BLK COUNT ON INPUT NOT EQUAL
* AND USER HAS ABCERR ON INPUT ASSIGN CARD
*  SUBCODE HAS EOF RETURN. FOR D00 UTS WILL CHANGE FROM 41 TO 4C
         B        ERRCDTST          REGULAR 41
INRDERR1 LI,2     X'4C'             ANS BLOCK COUNT ERR CODE
         CB,2     10
         BE       INRDERRA
         M:ERR                      OTHER ERROR                         1115
INRDERRA LI,2     1                 INDEX
         LB,2     10,2              GET SUB CODE
         SLS,2    -1                LEFT 7 BITS OF BYTE HAVE SUBCDE
         CI,2     X'05'              USER EOF
         BE       TRLTST
         CI,2     X'06'             MON EOF
         BE       ENDIN
         B        *8                IGNORE
ERRCDTST RES      0                                                     1116
         LCI      8                                                     1117
         STM,8    WORKOP            SAVE 8-15                           1118
MULTERR  RES      0                                                     1118B
         LI,8     2                 READ ERROR POINTER                  1119
         STW,15   9                                                     1120
         AI,9     -LOCBLK           FILE CONTROL TABLE OFFSET           1121
* GET RECORD ADDRESS FROM DCB                                           1200
         LI,1     X'C0'                                                 1201
         AND,1    *14               HANDLER BTD                         1202
         SLS,1    -6                                                    1203
         LI,2     7                                                     1204
         LW,10    *14,2             QBUF- HANDLER BUFFER ADDR           1205
         AND,10   L(X'1FFFF')                                           1206
         SLS,10   2                                                     1207
         AW,10    1                 10= QBUF BYTE ADDRESS               1208
         BAL,15   DROPER            MESSAGE GENERATOR                   1209
* USER ELECTS TO DROP THE BLOCK AND CONTINUE                            1209B
         LCI      2                                                     1210
         LM,14    WORKOP+6          RESTORE REG 14-15                   1211
         LW,8     LOCBLK+7          % IF ILLEGAL VARIABLE DO NOT SKIP
         BLZ      %+2               % RECORD
         M:PRECORD *14,(N,1),FWD
         M:READ   *14,NOWAIT,(SIZE,*WKONINS)   REDO LAST READ
         LW,1     LOCBLK+7          % IF ERROR FROM SIZE RETURN TO
         BLZ      SHRTBLK           % SHORT BLOCK CHECK ON NEXT READ
         LI,1     -1
         B        *WORKOP,1         RETURN TO THE ORIGINAL M:CHECK
*                                                                       1214
* MONITOR FORMATTED FILE EXHAUSTED                                      1215
ENDIN    RES      0                                                     1216
         M:CLOSE  *14,REM,SAVE                                          1217
* FILE EXHAUSTED AND CLOSED-  SETCUR RCD ADDR TO 00                     1218
ZERCUR   RES      0                                                     1219
         LI,1     0                                                     1220
         STW,1    *15               TO FILE CONTROL TABLE               1221
         B        RESREG                                                1222
* USER FORMATTED FILE- END OF REEL                                      1300
TRLTST   RES      0                                                     1301
         LCI      1
         STM,8    WORKOP+8          SAVE RETURN ADDR IN SR 1
         LW,12    INTRLAD           ANY REEL TRAILERS ?
         BNEZ     GETRLR            YES                                 1303
RWNDIN   RES      0                                                     1304
         M:SETDCB *14,(ERR,TSTVSW)                                      1305
         M:REW    *14                                                   1306
         M:CVOL   *14               TEST NEXT INSN                      1307
TSTVSW   RES      0                                                     1308
         LI,2     X'56'                                                 1309
         CB,2     10                END OF FILE                         1310
         BE       ZERCUR
* PROCESS NEXT REEL                                                     1312
         M:SETDCB *14,(ERR,0)                                           1313
         LW,1     WKUIH             IS THERE A HEADER                   1314
         BEZ      NXTREL            NO- GET A BLOCK                     1315
         LW,12    INHEDAD           USER OWN-CODE ADDR                  1316
         BAL,13   RDHDTR            READ AND CHECK THE TRAILER          1317
* BEGIN READING DATA ON NEXT REEL                                       1318
NXTREL   RES      0                                                     1319
         M:READ   *14,NOWAIT,(SIZE,*WKONINS)  REDO LAST READ
         LI,1     -1
         B        *WORKOP+8,1       RETURN TO THE ORIGINAL M:CHECK
*                                                                       1402
* PROCESS USER FORMATTED REEL TRAILER                                   1403
GETRLR   RES      0                                                     1404
         LW,12    INTRLAD           USER OWN-CODE ADDR                  1405
         BAL,13   RDHDTR                                                1406
         B        RWNDIN                                                1407
*                                                                       1408
         TITLE    'DATA OUTPUT ROUTINE'
         PAGE
* PUT SELECTED RECORD IN OUTPUT FILE- BLOCK USER FORMATTED RECORDS      0100
*                                                                       0101
* ENTRY- REG 6 =  BYTE ADDRESS OF RECORD TO BE WRITTEN                  0102
*            15=  RETURN ADDRESS                                        0103
*                                                                       0104
* EXIT-  RECORD MOVED TO OUTPUT BUFFER                                  0105
*        BYTE ADDRESS OF RELOCATED RECORD IN LOCBLK+4                   0106
*        ALL REGISTERS UNCHANGED                                        0106B
* NOTE:  THE MERGE OUTPUT FILE IS CONTROLLED THRU                       0107
*        FILE TABLE ENTRY 00 AT 'LOCBLK'                                0108
*                                                                       0109
PUTOUT   RES      0                                                     0110
         LCI      15                                                    0110B
         STM,1    INSVE             SAVE REGISTERS                      0111
* IS OUTPUT FILE OPEN                                                   0116
         LW,1     *LOCBLK+1         DCB WORD 0                          0117
         AND,1    L(X'1'**21)       FCD BIT ON = OPEN                   0118
         BNEZ     CALNXTO                                               019
* FILE CLOSED- INITIALIZE BUFFER ADDR AND CHECK HEADERS                 0120
         LW,12    OUHEDAD           GET MOUHED ADDR                     0202
         BEZ      CALNXTO           NO OWN CODE ADDR
         LI,4     0                 FILE NUMBER                         0203B
         LI,7     HTRTN             7= DUMMY RETURN
         BAL,5    *OUHEDAD          LINK TO MOUHED                      0204
HTRTN    BAL,5    WRUSRHT           R6= ADDR OF LABEL BUFFER            0205
         LI,5     12
         LB,7     SPECS,5
         CI,7     C'F'              F MEANS DO PFIL
         BNE      CALNXTO
         M:WEOF   *LOCBLK+1
         B        CALNXTO
*                                                                       0207
* WRITE USER HEADERS AND TRAILERS                                       0300
*        REG 5 =  RETURN ADDRESS                                        0301
*            6 =  ADDRESS OF HEADER-TRAILER BUFFER                      0302
WRUSRHT  RES      0                                                     0303
         LB,4     0,6               GET LABEL LENGTH FROM 1ST BYTE      0305B
         AI,6     1                 BUMP TO ADDRESS OF LABEL ITSELF     0305D
         LW,2     6                 GET BYTE DISPLACEMENT               0305F
         AND,2    L(X'3')                                               0305H
         SLS,6    -2                ADDR TO WORD RESOLUTION             0305J
         LW,10    F:MRGOUT            WORD 1 OF DCB
         AND,10   =X'0000000F'       MASK ALL BUT DEVICE TYPE
         CI,10    2                 2 FOR LAB TAPE
         BE       MVOULBL
* WRITE DIRECTLY FROM USER BUFFER                                       0307B
    M:WRITE *LOCBLK+1,(BUF,*6),(BTD,*2),(SIZE,*4),WAIT                  0312
         B        *5                RETURN                              0313
* RELOCATE LABEL ON WORD BOUNDARY AND OPEN WITH TLABEL OPTION           0314
MVOULBL  RES      0                                                     0315
         STB,4    TTSTORE                                               0400
         MOVE     (*6,2),(TTSTORE,1),*4                                 0401
     M:OPEN *LOCBLK+1,(TLABEL,TTSTORE)                                  0402
         B        *5                                                    0403
*                                                                       0404
* COMPUTE ENDING ADDR+1 OF RECEIVING BUFFER                             0415
CALNXTO  RES      0                                                     0416
         LW,7     ANSISWOU
         CI,7     3                 ANSI BVAR
         BL       CALNXTO2          NOT ANS U OR V
         CI,7     4                 ANS U
         BE       CALNXTO2
         LW,6     INSVE+5            CURR REC TO BE OUTPUTTED
         AI,6     -4                BACK TO REC LEN WORD
         SAD,6    -2                GET INDEX BITS
         SCS,7    2                 RIGHT JUSTIFIED
         AND,7    =X'03'            JUST INDEX BITS, NOTHING ELSE
         LB,1     *6,7              GET LEFT BYTE OF LENGTH (2BYTES)
         SLS,1    8                 SET UP FOR ADD
         STW,1    SAVEIT            SAVE FOR ADD
         AI,7     1                 UP INDEX TO GET RIGHT BYTE OF LEN
         LB,1     *6,7
         AW,1     SAVEIT              RECONSTRUCT LENGTH
         AI,1     -4                JUST WANT DATA REC SIZE
         MTW,0    OUTLENSW          HAS OUT LEN BEEN SPEC
         BEZ      %+2               NO
         LW,1     OUTLEN            YES, USE IT FOR ALL REC
         STW,1    LOCBLK+6            SAVE FOR MOVE + CALC
         LW,7     FIRSTSW1
         BNEZ     CALNXTOA
         MTW,1    FIRSTSW1          SET OFF
         LW,7     LOCBLK+2
         STW,7    BLKSAVE           SAVE BEG OF BUFFER ADDR
CALNXTOA LW,7     FIRSTSW           INITALIZED 1, 1 AFTER EACH WRITE
         BEZ      CALNXTO1
         LI,7     4                 4 BYTES FOR BLK-CTL-WORD
CALNXTO1 AI,7     4                 4 BYTES FOR REC-CTL WORD
         AW,7     LOCBLK            OUT BUFFER ADDR
CALNXTOB AW,7     LOCBLK+6
         STW,7    WORKOP
         CW,7     LOCBLK+3          BLK 2 ADDR
         BLE      USAXO
         CW,7     LOCBLK+LEN+2
         BG       CALNXTOC           OVER NEXT FILE BUFF
         LW,1     LOCBLK+4           PREVIOUSLY WRITTEN RECORD
         CW,1     LOCBLK+3             BUFF #2 ADDR
         BGE      USAXO             WORKING IN BUFFER #2 OK
         LW,1     LOCBLK+2
         LW,2     WOTBF
         BNEZ     %+3               WE ARE DOUBLE BUFFERED
         STW,1    LOCBLK            RESET TO BLK 1, SINGLE BUFF
         B        CALNXTOD
         LW,2     LOCBLK+3
         STW,2    LOCBLK
         B        CALNXTOD
CALNXTOC LW,1     LOCBLK+3
         LW,4     LOCBLK+2
         STW,4    LOCBLK
CALNXTOD RES      0
         LW,14    LOCBLK+1
         BAL,13   CHKBLK            DO WE WANT TO CHK BLK
         M:CHECK  *LOCBLK+1,(ABN,NDOUREE),(ERR,OUTOERR)
         LI,2     3
         AND,2    1
         SLS,1    -2
         STW,2    SAVE2
         STW,1    SAVE1
         LI,1     1                 INDEX
         LW,8     BLKLEN            BLOCLENGTH
       SLS,8      +16              LEFT JUSTIFY
         LW,7      BLKCOUNT          BLOCK COUNT
         STH,7    8,1              PUT BLKCNT IN R HALF
         STW,8    BLKLEN
         LI,1     4                 LENGTH
         LI,2     BA(BLKLEN)
         LW,3     BLKSAVE           BEG BUFF ADDR BYTE
         STB,1    3                  PUT LENGTH FOR MBS
         MBS,2    0                 MOVE BLK-CTL-WRD TO BEG OF BUFF
         LW,2     BLKCOUNT
         AI,2     1                 UP FOR NEXT BLK TO BE WRITTEN
         STW,2    BLKCOUNT
         MTW,1    FIRSTSW            SET IT ON
         LW,7     BLKLEN
         SLS,7    -16               R JUST FOR WRITE (LENGTH)
         LW,2     SAVE2
         LW,1     SAVE1
         LW,8     SAVE1
         SLS,8    2
         CW,8     LOCBLK+2           BUFFER #1
         BE       XXX2
XXX1     LW,8     LOCBLK+2
         B        XXX3
XXX2     LW,8     WOTBF
         BEZ      XXX1
         LW,8     LOCBLK+3
XXX3     STW,8    BLKSAVE
         M:WRITE  *LOCBLK+1,(BUF,*1),(BTD,*2),(SIZE,*7),NOWAIT
         LW,8     WOTBF
         BNEZ     USAXO              DOUBLE BUFF
* SINGLE BUFF CHECK US NOW
         LW,14    LOCBLK+1
         BAL,13   CHKBLK            DO WE WANT TO CHK BLK ?
         M:CHECK  *LOCBLK+1,(ABN,NDOUREE),(ERR,OUTOERR)
         B        USAXO
CALNXTO2 LW,7     LOCBLK
         AW,7     OUTLEN
         STW,7    WORKOP
* WILL CURRENT RECORD FILL THE CURRENT BLOCK                            0419
CALNXTO5 CW,7     LOCBLK+3          BLK 2 ADDR
         BE       TSTLSTO           YES- CHECK LAST WRITE               0500
         CW,7     LOCBLK+LEN+2      NEXT FILE START ADDRESS
         BL       USAXO             NO- MOVE CURRENT RECORD
TSTLSTO  RES      0                                                     0503
         LW,14    LOCBLK+1
         BAL,13   CHKBLK            DO WE WANT TO CHK BLK ?
         M:CHECK  *LOCBLK+1,(ABN,NDOUREE),(ERR,OUTOERR)
* CHECK USER ACCESS TO OUTPUT RECORDS                                   0504B
USAXO    RES      0                                                     0504C
         LW,10    OUSOAD                                                0504F
         BEZ      RELOUT
         LI,4     0                 4= FILE NUMBER                      0504H
         LW,6     INSVE+5           6= RECORD BYTE ADDRESS              0504I
         LI,7     PUTXIT            7= DROP RCD RETURN ADDR             0504J
         LW,8     LOCBLK+6          % 8= RECORD LENGTH
         BAL,5    *OUSOAD           LINK TO MOUSO                       0504K
         LW,2     WKBO              % IF BLOCKED RECORDS NO CHANGE
         CW,2     WKBI              % ALLOWED
         BNE      RELOUT            %
         CI,2     1                 %
         BG       RELOUT            %
         CW,8     OUTLEN
         BLE      %+2               % RESET TO MAX ALLOWED
         LW,8     OUTLEN
         STW,8    LOCBLK+6          %
* MOVE OUTPUT RECORD TO BUFFER                                          0505
RELOUT   RES      0                                                     0506
         LW,2     ANSISWOU
         CI,2     3                 ANSI BVAR
         BNE      RELOUT2
         MTW,0    FIRSTSW           WAS LAST REC WRITTEN (NEW-BUFF)
         BEZ      RELOUT1
         LW,2     LOCBLK            CURR BUFF BYTE ADDR
         AI,2     4                 UP 4 BYTES,START PAST BLK-CTL-WRD
         STW,2    LOCBLK
         LI,2     4
         STW,2    BLKLEN            HAS LEN OF BLK FOR ANSI-V
         MTW,-1   FIRSTSW           SET OFF
RELOUT1  LW,2     BLKLEN
         AI,2     4                 FOR REC-LEN CTL WORD
         AW,2     LOCBLK+6          REC LENGTH
         STW,2    BLKLEN            SAVE FOR LATER MOVE
         LI,1     4                 FOR REC LEN CONTROL WORD
         AW,1     LOCBLK+6          LENGTH
         SLS,1    +16               LEFT JUSTIFY RECORD LENGTH
         STW,1    RECLEN
         LI,2     BA(RECLEN)
         LW,3     LOCBLK            CURR BUFF BYTE ADDR
         LI,1     4                  4 LENGTH OF WORD TO BE MOVED
         STB,1    3
         MBS,2    0                 MOVE IT, 3 HAS UPDATED ADDR
         STW,3    LOCBLK            SAVE IT FOR ACTUAL REC MOVE
         LW,2     INSVE+5            OUT REC BYTE ADDR
         LW,3     LOCBLK            CURR BUF BYTE ADDR
         STW,3    LOCBLK+4          SAVE FOR SEQ CHK
         LW,1     LOCBLK+6          LENGTH OF REC
         STW,1    REMLEN            SAVE FOR MOVE
RELOUT1A SW,1     L(255)
         BGZ      RELOUT1B            GREATER THAN 255
         LW,1     REMLEN            255 OR LESSS
         STB,1    3
         MBS,2    0
         STW,3    LOCBLK            SAVE UPDATED ADDR
         MTW,1    LOCBLK+5          UP OUT REC COUNT
         B        PUTXIT
RELOUT1B OR,3     L(255**24)
         MBS,2    0                  MOVE 255
         LW,1     REMLEN
         SW,1     L(255)
         STW,1    REMLEN
         B        RELOUT1A
RELOUT2  LW,2     INSVE+5             1 = OUT REC BYTE ADDR
         LW,3     LOCBLK            2= CUR BUF BYTE ADDR                0508
         STW,3    LOCBLK+4          SAVE FOR SEQ CHECK OF REPLCMNT
         OR,3     NOTEV255          GET CHAR NOT EVEN MULT OF 255       0509
RMOV     MBS,2    0                 MOVE A PIECE                        0510
         CW,3     WORKOP            END OF BUFFER
         BGE      UPDCURB           YES                                 0512
         OR,3     L(255**24)        NO- MOVE A 255 CHAR PIECE           0513
         B        RMOV                                                  0514
UPDCURB  RES      0                                                     0515
         STW,3    LOCBLK            UPDATE CURRENT BUFFER ADDRESS       0516
         MTW,1    LOCBLK+5          ADD TO RCD COUNT                    0517
* WRITE BLOCK 1 WHEN CUR BUF = BLOCK 2                                  0518
         CW,3     LOCBLK+3
         BNE      ENDBTO                                                0520
         LW,1     LOCBLK+2          GET BLOCK 1 ADDR               0600
         LW,8     WOTBF             IS THERE A BLOCK 2
         BNEZ     BLKAD             YES
* RESET CUR BUF ADDR TO BLOCK 1
RSTBWUN  RES      0
         LW,4     LOCBLK+2          GET BLOCK 1 ADDR
         STW,4    LOCBLK
BLKAD    RES      0                                                0600B
         LI,2     3                 CONVERT TO WORD AND BTD        0601
         AND,2    1                 BTD                            0602
         SLS,1    -2                WORD RESOLUTION                0603
         LW,7     LOCBLK+6          % GET RECORD SIZE
         CW,7     OUTLEN            IF SHORTER THAN 1 REC
         BL       %+2               % VARIABLE LENGTH
         LW,7     WKONOTS           %
         M:WRITE  *LOCBLK+1,(BUF,*1),(BTD,*2),(SIZE,*7),NOWAIT
         LW,8     WOTBF             IS THERE A SECOND BUFFER
         BNEZ     PUTXIT            YES
* SINGLE BUFFER ONLY- CHECK IMMEDIATELY
         LW,14    LOCBLK+1
         BAL,13   CHKBLK            DO WE WANT TO CHK BLK ?
         M:CHECK  *LOCBLK+1,(ABN,NDOUREE),(ERR,OUTOERR)
* RESTORE REGISTERS AND EXIT                                       0611
PUTXIT   RES      0                                                0612
         LCI      15                                               0613
         LM,1     INSVE                                            0614
         B        *15               RETURN                         0615
* WRITE BLOCK 2 WHEN CUR BUF = NEXT FILE ADDR                      0616
ENDBTO   RES      0                 3= CUR BUF ADDR                0617
         CW,3     LOCBLK+LEN+2      NEXT FILE START ADDRESS
         BNE      PUTXIT                                           0619
         LW,1     LOCBLK+3          BLOCK 2 ADDR                   0620
         B        RSTBWUN           RESET TO BLOCK 1 AND WRITE BL 2
BLKARS   DO1      8
         DATA     0
BLKSIZ   DO1      8
         DATA     4                  BLK CTL WORD LENGTH
SAVE2    DATA     0
SW414C   DATA     0                 HOLD R10 FOR ERR ON DCB READ
SAVE14   DATA     0                 HOLD R14
SAVE1    DATA     0
FIRSTSW  DATA     X'01'             SET TO ONE
BLKLEN   DATA     0                 HOLDS BLK-LEN FOR ANSI-BLK-VAR
RECLEN   DATA     0                 HOLDS REC-LEN FOR ANSI BLK-VAR
REMLEN   DATA     0                 REC LEN CNT ANS V REC MOVE OUT BUF
BLKCOUNT DATA     0                 BLK COUNT FOR ANS V
FIRSTSW1 DATA     0                 USED TO INITIALIZE FOR BLK-CTL-WORD
SAVEIT   DATA     0                 HOLDS REC LEN FOR ANSI V
BLKSAVE  DATA     0                 HOLDS BEG BUFF ADDR FOR BLK-CTL-WORD
* ABNORMAL WRITE RETURN                                            0700
NDOUREE  RES      0                                                0701
        STW,8   J8SV
         LI,2     X'1C'                                            0702
         CB,2     10                END OF TAPE                    0703
        BNE     *J8SV
FINOUT   RES      0                 USER FORMATTED FILES ONLY      0705
         M:WEOF   *LOCBLK+1         EOR MARK                       0706
         LW,12    OUTRLAD           GET MOUTRL ADDR                0709
         BEZ      CLOZRL            NO OWN CODE SPECIFIED
         LI,4     0                 4= FILE NUMBER                 0710B
         LI,7     HTRTN2            7= DUMMY RETURN                0710D
         BAL,5    *OUTRLAD          LINK TO MOUTRL                 0711
HTRTN2   BAL,5    WRUSRHT           6= ADDR OF TRAILER BUFFER      0712
         M:WEOF   *LOCBLK+1                                        0713
CLOZRL   LW,1     WRAPFLG           END OF JOB FLAG ON             0714
         BNEZ     CLOZALL           YES- NO NEW REEL REQUIRED      0715
* REWIND AND SET UP ANOTHER OUTPUT VOLUME                          0716
         M:REW    *LOCBLK+1                                        0717
         M:CVOL   *LOCBLK+1                                        0718
         LW,4     OUHEDAD
        BEZ     *J8SV
         LI,4     0                   FILE NUMBER
         LI,7     HTRTN3              7= DUMMY RETURN
         LI,5     HTRTN3            SET RETURN ADDRESS FOR OWN-CODE
         B        *OUHEDAD          EXEC OUT OWN CODE HEADERS
HTRTN3  RES       0
         BAL,5    WRUSRHT           6= ADDR OF LABEL BUFFER        0802
         LI,5     11
         LB,8     SPECS,5
         CI,8     C'F'              F MEANS DO A PFIL
         BNE      *J8SV
         M:WEOF   *LOCBLK+1
        B       *J8SV
* WRAP UP OUTPUT FILE AT END OF MERGE                              0804
ENDOUT   RES      0                                                0805
         MTW,0    ANSISWOU
         BNEZ     ENDOUT1           ANSI TYPR
         LW,7     WKBO              USER FORMATTED FILE            0806
         BEZ      CLOZALL           NO                             0807
ENDOUT1  LW,7     LOCBLK            CHECK FOR PARTIAL BLK
         CW,7     LOCBLK+2          CUR BUF = BLOCK 1 ADDR         0809
         BE       LSTEOR            YES- EVEN                      0810
         LW,1     LOCBLK+2          GET BLOCK 1 ADDR               0810B
         CW,7     LOCBLK+3          CUR BUF = BLOCK 2 ADDR         0811
         BE       LSTEOR            YES- EVEN                      0812
         BL       BLKSTART          CURRENT BLOCK IS 1             0813
         LW,1     LOCBLK+3          GET BLOCK 2 ADDR               0814
BLKSTART RES      0                 1= ADDR OF SHORT LENGTH BLOCK  0815
         SW,7     1                 7= BLOCK LENGTH                0816
         LI,2     3                                                0817
         AND,2    1                 2= BTD                         0818
         SLS,1    -2                1= WORD ADDRESS                0819
         LW,8     ANSISWOU
         CI,8     3                 ANSI BVAR
         BNE      BLKST1
         LI,7     1                 INDEX
         LW,9     BLKLEN
         SLS,9    +16               LEFT JUST
         LW,10    BLKCOUNT
         STH,10   9,7               PUT BLK-CNT IN R HALF
         STW,9    BLKLEN
         LI,10    4                 LENGTH
         LI,8     BA(BLKLEN)
         LW,9     BLKSAVE             BEG BUFF ADDR BYTE
         STB,10   9                 PUT LENGTH FOR MBS
         MBS,8    0
         LW,7     BLKLEN
         SLS,7    -16               R JUST LENGTH FOR MOVE
BLKST1   RES      0
        M:WRITE   *LOCBLK+1,(BUF,*1),(BTD,*2),(SIZE,*7),;
                 (ERR,OUTOERR),WAIT
LSTEOR   RES      0                                                0901
         MTW,1    WRAPFLG                                          0902
         B        FINOUT                                           0903
*                                                                  0904
CLOZALL  RES      0                                                0905
         M:CLOSE  *LOCBLK+1,SAVE,(REM)                     /SIG7-1368/*D4985
         B        OCLOZD                                           0907
*                                                                  0908
OUTOPAB  RES      0                 ABNORMAL RETURN ON OPEN        0909
         LI,2     2                 ERROR MESSAGE POINTERS
         LI,3     9
         STD,2    ERCNT
         STW,3    ERCNT+2
         LI,1     '0'
         STB,1    ERMS3+50
         B        MRTNCTL           TO ABORT
OUTOERR  RES      0                 ERROR RETURN ON OUTPUT
         LI,2     2                 MESSAGE POINTERS
         LI,3     1
         STD,2    ERCNT
         LI,2     -1
         STW,2    ERCNT+2
         B        MRTNCTL
*                                                                  0912
         TITLE    'ALLOWABLE ERROR HANDLER'
CHKBLK0  DATA     0                 HOLD RETURN ADDR
CHKBLK   STW,13   CHKBLK0           SAVE RETURN ADDR
         LW,13    14                GET DCB ADDR
         AI,13    7                 POINT TO WORD 7
         MTB,0    *13               SEE BITS 00-07 WORD 7
         BNE      *CHKBLK0          GO DO CHECK
         AI,13    -5                POINT TO WORD 2
         LH,2     *13               GET BUTS 00-15
         AND,2    =X'00FE'           MASK ALL BUT TYC 8-14
         CI,2     2                 00-02 NORMAL TYC
         BLE      %+2
         B        *CHKBLK0             GO DO CHECK
         MTW,1    CHKBLK0           UP RETURN ADDR TO SKIP CHK
         B        *CHKBLK0          GO TO INST PAST CHK
         PAGE
DROPER   STW,8    ERCNT+1           SET PART I POINTER
         LCI      15                SAVE REGISTERS
         STM,1    SVR3
         LW,6     10
         LW,1     9                 GET POINTER TO LOCBLK
         AI,1     LOCBLK
         LW,1     6,1               GET ACTUAL RECORD SIZE
         LI,3     9
         STW,3    ERCNT+2           SET PART 3 POINTER
         DW,9     L(LEN)
         BINBCD   9,ERMS3+50,1      SET FILE NUMBER IN MESSAGE
         LI,2     1                 MOVE RECORD TO BUFFER
         STW,2    ERCNT             SET PART 1 TO ERROR
         LW,8     ERCNT+1
         CI,8     9
         BGE      NOREC             IF OPEN OR CLOSE NO RECORD PRINT
         CI,1     131
         BLE      %+2               IF LENGTH GR THAN 131
         LI,1     131               SET MAX LENGTH
         STB,1    MESBUF
         MOVE     (0,6),(MESBUF,2),*1
         M:PRINT  (MESS,MESBUF)     LOG BLOCK DATA
         LW,3     ERCNT+1
         MTW,-1   WKBI,3            DECREMENT ERROR ALLOWANCE
         BGZ      %+2
         MTW,1    ERCNT             IF 0 SET ABORT
NOREC    BAL,13   MRTNCTL           LOG MESSAGE CONCIDER ABORT
         LCI      15                RESOTE REGISTERS
         LM,1     SVR3
         CI,8     9
         BGE      INGETER
         B        *15
         TITLE    'COMPARE ERROR ROUTINES'
         PAGE
COMER1   LW,4     2                 SET UP ERRORS ARE THE SAME
         B        %+2
COMER2   LW,4     3
         BAL,5    COMER
         B        OUTLP1A
COMER3   LW,4     1                 RUNNING ERRORS ARE THE SAME
         B        %+3
COMER4   LW,4     1
         AI,4     1
         BAL,5    COMER
         LW,2     WKTPIN
         BEZ      SQUASH
        LI,12   INLP2
        LI,13   COMER2          TOURNY MUST BE RESORTED SINCE THE
        LI,14   COMER1          REPLACEMENT RECORD MAY BE OUT OF ORDER
        B       OUTLP1
COMER    LI,8     4                 COMMON ILLEGAL DIGIT ROUTINE
         AW,4     4                 GET WORD ADDRESS POINTER
         LW,9     TPIN-1,4
         LW,10    TPIN,4
         BAL,15   DROPER            LOG ERROR
         LW,6     TPIN-1,4
         BAL,15   INGET             GET REPLACEMENT
         LW,7     LOCBLK,6
         STW,7    TPIN,4
         B        *5                RETURN TO PH:III CONTROL
COMER5   LI,8     3                 OUT OF SEQUENCE ERROR
         LW,9     TPIN-1,1
         LW,10    TPIN,1
         BAL,15   DROPER            LOG ERROR
         B        PUTRTN            SKIP OUTPUT
         END      MERGE
