         SYSTEM   SIG7FDP
*        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 ZONED DECIMAL NUMBER TO BINARY
*        FBCDBIN  CONVERT FLOATING EBCDIC NUMBER IN A FIELD TO BINARY
*        BINBCD   CONVERT BINARY NUMBER TO EBCDIC
*        BLANK    SET MEMORY AREA TO BLANKS
*        BNALPH   BRANCH IF MEMORY NOT ALPHA-NUMERIC (A-Z,0-9,@,%,#,%)
*        BNOTCH   BRANCH IF MEMORY NOT SPECIFIED CHARACTER
*        BNOBLK   BRANCH IF MEMORY NOT BLANK
*        BNOTZR   BRANCH IF MEMORY NOT ZERO
*        BNTNUM   BRANCH IF MEMORY NOT NUMERIC (0-9)
*        COMPARE  COMPARE BYTE STRINGS
*        COMPCKD  COMPARE PACKED DECIMAL FIELDS
*        COMPZND  COMPARE ZONED DECIMAL FIELDS
*        FILLCH   SET MEMORY AREA TO SPECIFIED CHARACTER
*        MOVE     MOVE A BYTE STRING
*        PAKDEC   PACK A ZONED DECIMAL FIELD
*        PULL     PULL FROM JOB'S TEMP STACK INTO SPECIFIED REGISTERS
*        PUSH     PUSH SPECIFIED REGISTERSINTO JOB TEMP STACK
*        SORT     SORT A TABLE INTO ASCENDING EBCDIC SEQUENCE
*        SORTBIN  SORT A TABLE INTO ASCENDING BINARY (ALGEBRAIC) SEQUENCE
*        ZERO     SET MEMORY AREA TO ZERO
*
*  THE FOLLOWING GLOBAL SUB-ROUTINES MAY BE CALLED:
* @%CCVAL         GET CHARACTER COUNT VALUE INTO R10
* @%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
         PAGE
*
*        SETS A SYMBOL IN AF(1) TO THE VALUE IN AF(2).
*        IT IS USED TO CONTROL THE ASSEMBLY OF THE
*        SUBROUTINES USED BY THE VARIOUS PROCS SUCH
*        THAT IF THE PROC IS USED IT UTILIZES
*        THIS FUNCTION TO SET A FLAG WHICH IN TURN
*        WILL CONTROL THE ASSEMBLY OF ANY SUBROUTINES
*        ASSOCIATED WITH THAT PROC.
*
F%FLG    FNAME
         PROC
AF(1)    SET      AF(2)
         PEND
         OPEN     FLG1,FLG2
DATA     CSECT    0                                                     055B
         BOUND    8                                                     055D
SAVE     RES      10
*                                                                       055J
PROG     CSECT    1                                                     055L
*
*        @%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
*        @%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 3 ON= BITS ON IN OP CODE 1-7
*        R9  DESTROYED
*
@%OPCO   RES      0
         LW,R10   *R10              GET THE WORD
         LW,9     L(X'7F000000')
         AND,9    10                COND CODE 3 ON IF ANY MATCH
         B        *R11
         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)
       ERROR,X'7',(S:IFR(P(1))>7)&(S:IFR(P(1))<11) ;                    163B
                  'LEVEL 7- PARAMETER ADDRESS 8-10'     NO REG.8-10     163D
LF       GEN,IWD  AFA(1)|IND,NAME,CF(2),P(2)+P(3),P(1)
         PEND
         CLOSE    P,IND
         PAGE
BARG     CNAME                      GENERATE BYTE ADDRESS IF DIRECT ARG
         OPEN     A
         PROC
A        SET      AF                PASS LEVEL 0 AF DOWNWARD
         DO       AFA(1)|S:UFV(NUM(A))>1
LF       LDBY,CF(2) AF              GEN LB OPCODE WITH INDEX OR INDRCT
         ELSE
LF       GEN,8,4,20 0,CF(2),BA(AF)  GEN 0 OPCODE WITH DIRECT BYTE ADDR
         FIN
         PEND
         CLOSE    A
         PAGE
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
         PAGE
VAL      CNAME    X'69'             GENERATE VALUE PARAMETER (CC)
VALRNGE  CNAME                      VALIDATE RANGE OF EXPLICIT VALUES
*        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 ',;      0171B
                                    'VALUE OUT OF RANGE'                0171D
         FIN                                                            0174D
         DO       NAME~=0
* BUILD THE WORD                                                        0165J
LF       GEN,IWD  IND,NAME,,P(2)+P(3),P(1)                              0165K
         FIN
         PEND                                                           0165L
         CLOSE    P,IND,RNGE                                            0165M
         PAGE
*        PULL     PULL FROM JOB'S TEMP STACK INTO SPECIFIED REGISTERS
*        PUSH     PUSH SPECIFIED REGISTERS INTO JOB TEMP STACK
*                 AF1 IS SPECIFIED REGISTER (REQUIRED)
*                 AF2 IS WORD COUNT (0-15), IF OMITTED COUNT = 1
*        PUSH     6,5               PUSH REG 6-10
*        PULL     15                PULL 1 WORD INTO REG 15
PULL     CNAME    0
PUSH     CNAME    1
         PROC
         LOCAL    OP
         TRMS,(AF)  (1,1),(0,1)     AF(2) OPTIONAL
LF       RES      0
         DO       (NUM(AF)=2)&(AF(2)~=1)
OP       SET      X'A'
         LCI      AF(2)             IF MULTIPLE COUNT
         ELSE
OP       SET      X'8'              SINGLE WORD
         FIN
         GEN,IWD  1,OP+NAME,AF(1),0,0   PUSH OR PULL THRU REG 0
         PEND
         PAGE                                                           0188B
*        BCDBIN   CONVERT ZONED DECIMAL NUMBER TO BINARY
FLG1     SET      0
BCDBIN   CNAME    F%FLG(FLG1,1)
         OPEN     QUIT
         PROC
         TRMS,(AF) (1,2),(1,2),(0,2)  E2 MAY BE NULL
LF       BAL,R10  @%EBCBNN
         BARG,R8  AF(1)             BYTE OP +E1 ADDRESS
         VAL,1,10 AF(2)               BUILD CC
         GOTO,NUM(AF)<3  QUIT       IF E2 NULL
         STWD,R9  AF(3)               STORE BINARY NUMBER INTO E2
QUIT     PEND
         CLOSE    QUIT
         DO       FLG1
* CONVERSION SUB-ROUTINE
         OPEN     GETBYT,NCAD,POSTIV,GOING,ENT,FINISH,BRANCH,DISISN
         OPEN     OVER,ILLG,LMT,FLMT,CHECK
@%EBCBNN RES       0
         STD,2    SAVE+2
         STD,10   SAVE              SAVE R10-11
         LW,8     *10               GET E1 ADDR INTO R8
         ANLZ,8   8
         AI,10    1                 TO CC PARAM ADDR
         MTW,2    SAVE              BUMP RETURN ADDR
         BAL,11   @%CCVAL           GET CC IN R10
         XW,8     1                 BYTE POINT TO INDEX
         LI,2     0                 SW FOR NEGATIVE
         LI,3     0                 ZERO INDEX
         LI,9     0                 CLEAR ACC
GETBYT   LB,11    0,1               GET BYTE IN R11
         CLM,11   LMT               COMPARE D0-D9
         BCS,9    POSTIV            NOT A NEGATIVE OVERPUNCH
         B        NCAD,2            SET NEGATIVE CHAR ADDR
NCAD     STW,1    3                 SAVE NEGATIVE DIGIT ADDR
         LI,2     1                 SET OVERPUNCH SW ON
         B        GOING
POSTIV   CLM,11   FLMT               TEST F0-F9
         BCS,9    ILLG              TO ILLEG DIGIT
GOING    AND,11   L(X'F')           DROP ZONE
         MI,9     10                COMPUTE BIN EQUIV OF PREV DIGIT
         BOV      OVER
         AW,9     11                ADD CURRENT DIGIT TO PREV
         BOV      OVER              CHECK OVERFLOW
ENT      AI,1     1                 UPDATE TO NXT BYTE
         BDR,10   GETBYT            ANY MORE LEFT
FINISH   LW,11    SAVE+1
         XW,8     1                 RESTORE R1
         AI,8     -1                GET LAST DIGIT ADDR
         CW,8     3                 TEST LAST DIGIT OVERPUNCH
         BNE      CHECK             CHECK OVERPUNCH ADDR
         LI,3     3
BRANCH   B        DISISN,3          DICISION POINT
CHECK    CI,3     X'7'              CHECK OVERPUNCH ADDR
         BE       BRANCH
         CI,3     X'0'              CHECK OVERPUNCH ADDR
         BE       BRANCH
         B        ILLG
DISISN   LD,2     SAVE+2
         AI,9     0                 CLEAR CC1-2
         B        *SAVE
         LD,2     SAVE+2
         AI,9     0                 CLEAR CC1-2
         LCW,9    9                 COMPLEMENT FOR NEGATIVE
         B        *SAVE
         LD,2     SAVE+2
         LCI      4                 SET CC2 ON -- OVERFLOW
         B        *SAVE
         LI,9     0                 NO RESULT
         LD,2     SAVE+2
         LCI      8                 SET CC1 ON -- ILLEG DIGIT
         B        *SAVE
OVER     LI,3     7
         B        ENT
ILLG     LI,3     10
         B        BRANCH
         BOUND    8
LMT      DATA     X'D0',X'D9'
FLMT     DATA     X'F0',X'F9'
         CLOSE    GETBYT,NCAD,POSTIV,GOING,ENT,FINISH,BRANCH,DISISN
         CLOSE    OVER,ILLG,LMT,FLMT,CHECK
         FIN
         PAGE
*        FBCDBIN  CONVERT FLOATING EBCDIC NUMBER IN A FIELD TO BINARY
FLG1     SET      0
FBCDBIN   CNAME   F%FLG(FLG1,1)
         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,20 AF(2)             FIELD LENGTH
         GOTO,NUM(AF)<3  QUIT
         STWD,R9  AF(3)             STORE BINARY NUMBER INTO E2
QUIT     PEND                                                           0193B
         CLOSE    QUIT,A
         DO       FLG1
* CONVERSION SUB-ROUTINE
         OPEN     TSBLK,ENTR,CHKNGTV,CHKPSTV,GETBYT,GOING,ENT,FINISH
         OPEN     BRANCH,DISISN,ILLG,FLMT,MAX
@%EBCBN  RES      0
         STD,R10  SAVE              SAVE R10-11
         STD,2    SAVE+2
         STW,1    SAVE+4
         ANLZ,1   *R10              GET E1 BYTE ADDR IN R1
         AI,R10   1                 TO CC PARAM ADDR
         STW,R10  SAVE              SAVE CURRENT PARAM ADDR
         BAL,R11  @%CCVAL           GET CC IN R10
         MTW,1     SAVE             UPDATE RETURN ADDRESS
         LI,2     X'80'             FOR TESTING OVERFLOW
         LI,3     0                 CLEAR INDEX
         LI,9     0                 CLEAR ACCUMULATER
         LI,8     0
TSBLK    LB,11    0,1               LOAD IN DIGIT
         CI,11    X'40'             CHECK BLANK
         BNE      CHKNGTV           TO CHECK NEGATIVE
ENTR     AI,1     1                 UPDATE POINTR
         BDR,10   TSBLK             ANYMORE DIGIT
         LI,3     6                 BLANK FIELD
         B        FINISH
CHKNGTV  CI,11    X'60'             CHECK NEGATIVE CHAR
         BNE      CHKPSTV           TO CHECK POSITIVE
         LI,3     3                 SET NEGATIVE CODE
         B        ENTR              TO NXT DIGIT
CHKPSTV  CI,11    X'4E'             CHECK PLUS SIGN
         BE       ENTR              TO NXT DIGIT
GETBYT   LB,11    0,1
         CI,11    X'40'
         BE       FINISH            TERM OF STRING
         CLM,11   FLMT              TEST F0-F9
         BCS,9    ILLG              NOT A POSITIVE DIGIT
GOING    AND,11   L(X'F')           DROP ZONE
         MW,8     L(10)             BIN EQUIV OF PREV DIGIT
         AI,9     0                 TEST OVERFLOW
         BLZ      ILLG+1
         AI,8     0                 TEST OVERFLOW
         BNEZ     ILLG+1
         AD,8     11
         AI,9     0                 TEST OVERFLOW
         BLZ      ILLG+1
ENT      AI,1     1                 UPDATE TO NXT BYTE
         BDR,10   GETBYT            ANYMORE LEFT
FINISH   LW,11    SAVE+1            RESTORE
         LW,1     SAVE+4
         AI,9     0                 CLEAR CC1-2
BRANCH   B        DISISN,3          DICISION POINT
DISISN   LD,2     SAVE+2
         LW,9     9                 SET CC3-4
         B        *SAVE
         LD,2     SAVE+2
         LCW,9    9                 COMPLEMENT FOR NEGATIVE
         B        *SAVE
         LD,2     SAVE+2
         LCI      4                 SET CC2 -- BLANK FIELD
         B        *SAVE
         LD,2     SAVE+2
         LCI      8                 SET CC1 -- ILLEG DIGIT
         B        *SAVE
ILLG     LI,9     0                  ZERO RESULT
         LI,3     9                 SET INDEX
         B        FINISH
         BOUND    8
FLMT     DATA     X'F0',X'F9'
         CLOSE    TSBLK,ENTR,CHKNGTV,CHKPSTV,GETBYT,GOING,ENT,FINISH
         CLOSE    BRANCH,DISISN,ILLG,FLMT,MAX
         FIN
         PAGE
*        BINBCD   CONVERT BINARY NUMBER TO ZONED DECIMAL NUMBER
FLG1     SET      0
BINBCD   CNAME    F%FLG(FLG1,1)
         PROC
         TRMS,(AF) (1,2),(1,2),(1,2)  CHECK NUMBER OF PARAMETERS
LF       BAL,R10  @%BINBC
         VAL,1,10 AF(3)               BUILD CC
         BARG,0   AF(2)             ADDRESS OF BYTE STRING
         LDWD,9   AF(1)             LOAD BINARY VALUE
         PEND
         DO       FLG1
*  CONVERSION SUB-ROUTINE
         OPEN     POSI,SIG7,PSTVBK
         OPEN     CONVRT,QUIT,DVR,LOOP1,LOPBACK,POSITIVE,TABLE,QUIT2
@%BINBC  RES      0
         LCI      5
         STM,1    SAVE+2
         STD,R10  SAVE                R10-11
         BAL,R11  @%CCVAL             GET CC IN R10
         MTW,1    SAVE                BUMP PARAM ADDRESS POINTER
         LW,11    *SAVE             BYTE STRING START TO 11
         ANLZ,11  11
         MTW,1    SAVE                BUMP PARAM ADDRESS POINTER
         EXU      *SAVE               9 = BINARY VALUE
         BGEZ     POSI                TEST POSITIVE
         LCW,9    9                   COMPLEMENT NEGATIVE VALUE
         BOV      QUIT
         LI,8     X'DF'               NEGATIVE SIGN MASK
         B        %+2
POSI     LI,8     X'FF'       POSITIVE SIGN MASK
         PUSH     8           SAVE MASK
         AW,11    10          START + LENGTH
         AI,11    -1          11 = BYTE STRING END
         PUSH     11          SAVE SIGN BYTE ADDRESS
         XW,11    1           1 = STRING ADDRESS
CONVRT   LI,8     0           BINARY VALUE IN R9
         DW,8     L(10)       REMAINDER IS DECIMAL DIGIT
         OR,8     L(X'F0')    FORCE ZONING
         STB,8    0,1         TO DESTINATION STRING
         AI,1     -1          DECREMENT RECEIVING BYTE
         BDR,10   CONVRT
         PULL     1           RECOVER SIGN ADDRESS
         LB,10    0,1         GET LEAST SIGNIFICANT DIGIT
         PULL     8           GET MASK
         AND,10   8           SET SIGN
         STB,10   0,1         RESTORE DIGIT
         STW,R11  R1          RESTORE R1
QUIT     MTW,1    SAVE        UPDATE RETURN ADDRESS
         LD,R10   SAVE        RESTORE R10-11
         LCI      5
         LM,1     SAVE+2
         CI,R9    -1          SET OVERFLOW IF ANY VALUE LEFT
         B        *R10
         CLOSE    POSI,SIG7,PSTVBK
         CLOSE    CONVRT,QUIT,DVR,LOOP1,LOPBACK,POSITIVE,TABLE,QUIT2
         FIN
         PAGE
*        BLANK    SET MEMORY AREA TO BLANKS
*        FILLCH   SET MEMORY AREA TO SPECIFIED CHARACTER
*        ZERO     SET MEMORY AREA TO ZEROS
*
FLG1     SET      0
BLANK    CNAME    X'40',F%FLG(FLG1,1)
ZERO     CNAME    X'0',F%FLG(FLG1,1)
FILLCH   CNAME    X'1',F%FLG(FLG1,1)                                    0271B
         OPEN     C,IND,LIT
         PROC
         DO       NAME(1)=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(1)                                               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
         BARG,0   AF(1)             BYTE OR 0 OP + E1 ADDRESS
         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
         DO       FLG1
* CHARACTER MOVE SUB-ROUTINE
@%CHMVE  RES      0
         PUSH     10,2              SAVE 10-11
         BAL,R11  @%CHCOM           SET UP AND DO THE MBS OPER
         PULL     10,2              GET 10-11
         AI,R10   3                 UPDATE RETURN ADDRESS
         B        *R10
         FIN
* 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
@%CHCOM  RES      0
         STD,10   SAVE
         LW,R9    *R10              PUT INTO R9 IN CASE OF ZRO OPCODE
         ANLZ,R9  R9                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    SAVE              POINT TO ACTUAL BYTE OPERATION
         EXU      *SAVE             DO IT
         STCF     R8                SAVE CONDITION CODES
         XW,R9    R1                RESTORE R1                          0355B
         B        *SAVE+1           TO CHMVE OR CHCMP
         PAGE
*        BNOBLK   BRANCH IF MEMORY AREA NOT BLANK
*        BNOTCH   BRANCH IF MEMORY AREA NOT SPECIFIED CHARACTER
*        BNOTZR   BRANCH IF MEMORY AREA NOT ZERO
*
FLG1     SET       0
BNOBLK   CNAME    X'40',F%FLG(FLG1,1)
BNOTCH   CNAME    X'1',F%FLG(FLG1,1)                                    0331B
BNOTZR   CNAME    X'0',F%FLG(FLG1,1)
         OPEN     C
         PROC
         DO       NAME(1)=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(1)                                               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
         DO       FLG1
* THE CHARACTER COMPARISON SUB-ROUTINE IS:
@%CHCMP  RES      0
         PUSH     10,2              SAVE 10-11
         BAL,R11  @%CHCOM           SET UP AND DO THE CBS OPER
         PULL     10,2              GET 10-11
         AI,R10   3                 POINT TO BNE
         LCF      R8                CONDITION CODES LEFT BY CHCOM
         B        *R10
         FIN
         PAGE
*        COMPCKD  COMPARE PACKED DECIMAL FIELDS
*        COMPZND  COMPARE ZONED DECIMAL FIELDS
FLG1     SET      0
FLG2     SET      0
COMPCKD  CNAME    X'01',F%FLG(FLG1,1)
COMPZND  CNAME    0,F%FLG(FLG1,1),F%FLG(FLG2,1)
         OPEN     A,E1R,E2R,NX1,NX2
         PROC
A        SET      AF                A = CALLERS AF
E1R      SET      0                                                     0485A
E2R      SET      0                                                     0485B
         DO       NUM(A)=4          VERIFY 4 PARAMETER STATEMENT
         DO       NUM(A(1))=0       VERIFY IMPLICIT E1
        TRMS,(AF) (0,0),(0,0),(1,3),(1,3)  E1 IN R12-15                 0397B
E1R      SET      1
         ELSE
        TRMS,(AF) (1,3),(1,3),(1,3),(1,3) STRAIGHT 4 PARAM LIST         0400B
         DO       S:IFR(A(1,1))=12  IS E1 ACTUAL ADDR 12
E1R      SET      1                 E1 IN R12-15                        431D
         ELSE                                                           431F
         DO       S:IFR(A(3,1))=12  IS E2 ACTUAL ADDR 12
E2R      SET      1                 E2 IN R12-15                        431J
         FIN                                                            431L
         FIN                                                            431N
         FIN                        END 4 PARAMETER CHECK
*
         ELSE                       VERIFY 2 PARAM STATEMENT
        TRMS,(AF) (1,3),(1,3)       E2  IN R12-15                       0404B
E2R      SET      1
         FIN                        END 2 PARAM CHECK
*
NX1      SET      AFA(2)|(NUM(A(2))>1)  SET NON-EXPLICIT CC1 FLAG
NX2      SET      AFA(4)|(NUM(A(4))>1)  SET NON-EXPLICIT CC2 FLAG
         DO       NAME(1)
* BUILD COMPCKD CALL
LF       RES      0
         DO       (NX1=0)&(E1R=0)      VERIFY EXPLICIT CC
         VALRNGE,1,16 AF(2)
         FIN
         DO       (NX2=0)&(E2R=0)
         VALRNGE,1,16 AF(4)
         FIN
*
         DO        (NX1|NX2)=0      BOTH CC'S ARE EXPLICIT
         DO       (E1R|E2R)=0       AND NEITHER NUMBER IN 12-15
         DELD,AF(2)&X'F'  AF(1)     LOAD E1
         FIN
         DO       E2R               IF E2 IN 12-15
         DECM,AF(2)&X'F'  AF(1)     COMPARE WITH E1 IN MEMORY
         BAL,10   @%REVCO34         AND REVERSE COND CODE 3-4
         ELSE
         DECM,AF(4)&X'F' AF(3)      COMPARE WITH E1 IN MEMORY
         FIN
*
         ELSE                       CC1 AND/OR CC2 IS RUN-TIME VALUE
         BAL,10   @%PKCMP           TO SUB-ROUTINE
         DO       E1R|E2R           IF E1 OR E2 IN 12-15
         B        @%NEXT            BYPASS ILLEGAL DIGIT CHECK
         ELSE                       SET UP E1
         DO       NX1=0
         DELD,AF(2)&X'F' AF(1)      LOAD E1 FROM MEMORY
         ELSE                       OR
         ZRO      AF(1)             BUILD RUN-TIME
         DO       (NUM(AF(2))=2)&(AF(2,2)~=0)  IS CC1 INDEXED ONLY
A(2)     SET      L(AF(2,1)),AF(2,2),0  SET UP CC AS AN INDIRECT LITERAL
         FIN
         BCST     AF(2)
         FIN
         FIN
* SET A NEW LIST TO COMPARE AGAINST AF1 IF E2 WAS ALREADY RESIDENT-IF
*  E2 IN MEMORY, COMPARE AGAINST AF3.
A        SET     (AF(3-(2*E2R))),(AF(4-(2*E2R))),(NX1&E2R)|(NX2&(E2R=0))
         DO       AFA(3-(2*E2R),1)
A(1)     SET      A(1),0            FORCE 0 ELEMENT IF INDIRECT
         FIN
         DO       AFA(4-(2*E2R),1)
A(2)     SET      A(2),0
         FIN
         DO       A(3)=0            IS CC EXPLICIT
         DECM,A(2)&X'F'  A(1)       YES- COMPARE DIRECTLY
         ELSE
         ZRO      A(1)              BUILD RUN TIME
         DO       (NUM(A(2))=2)&(A(2,2)~=0)  IS CC INDEXED ONLY
A(2)     SET       L(A(2,1)),A(2,2),0
         FIN
         BCST     A(2)
         FIN
         DO       E2R               IF E2 IN 12-15
         BAL,10   @%REVCO34         REVERSE COND CODE 3-4
         FIN
         FIN
*
*
         ELSE
* BUILD COMPZND CALL
* GENERATE LINK TO SUB-ROUTINE
         DO      (E1R|E2R)=0        IF NEITHER IN 12-15
LF       @%PAKDEC (AF(3)),(AF(4))   PACK E2                             0410B
         BAL,R10  @%DKASV           SAVE E2
         ELSE                       OR
LF       BAL,R10  @%SVRG            IF E1 OR E2 ALREADY PACKED          446B
         FIN
*
         DO       E1R=0             IF E1 WAS NOT IN 12-15
         @%PAKDEC (AF(1)),(AF(2))   PACK IT                             0417B
         ELSE                       OR IF E1 WAS IN 12-15               0507D
         @%PAKDEC (AF(3)),(AF(4))   PACK E2                             0419B
         FIN
*
         BID      %+2                                                   0535B
*
         DC,0     @%SVE             COMPARE 12-15 TO SAVED OPERAND
*
         DO       E1R               IF E1 WAS IN 12-15
         BAL,R10  @%REVCO34         EXCHANGE CONDITION CODES 3-4
         FIN
         FIN
         PEND
         CLOSE    A,E1R,E2R,NX1,NX2
         DO       FLG1
* THE DECIMAL ACCUMULATOR SAVE ROUTINE IS:
         OPEN     SVRG
@%DKASV  RES      0
         BLD      SVRG              TEST ILLEGAL DIGIT
         LI,R15   0                 FORCE ILLEGAL DIGIT INTO SAVE AREA
@%SVRG   RES      0                                                     468B
SVRG     LCI      4
         STM,R12  @%SVE             STORE REG 12-15
         B        *R10              RETURN
         USECT    DATA                                                  0438B
@%SVE    RES      4                                                     0438D
         USECT    PROG                                                  0438F
         CLOSE    SVRG
* THE PACKED DECIMAL COMPARISON ROUTINE IS:
         OPEN     SETDEC,ERROUT,OPRTN
@%PKCMP  RES      0
         STD,10   SAVE
         LW,8     L(X'7E000000')    DECML LOAD OP CODE
         BAL,11   SETDEC            SET UP FIRST OPERATION IN R10
         EXU      10                DO IT
         BID      ERROUT            IF ILLEGAL
@%NEXT   RES      0
         MTW,1    SAVE              TO NEXT PARAMETER
         LW,8     L(X'7D000000')    DECML COMPARE OP CODE
         LW,10    SAVE              GET ADDR OF NEXT PARAMETER
         BAL,11   SETDEC            SET UP 2ND OPERATION IN R10
         EXU      10                DO IT
         STCF     9                 SAVE THE CONDITION CODES
         MTW,1    SAVE              TO EXIT POINT
         LD,10    SAVE              RESTORE 10-11
         LCF      9                 CONDITION CODES
         B        *10               RETURN
*
ERROUT   LI,15    0                 FORCE ILLEGAL DIGIT INTO 15
         B        @%NEXT
*
SETDEC   RES      0                 10= ADDR OF NEXT PARAMETER
         PUSH     11
         BAL,11   @%OPCO            TEST PARAM FOR OP CODE
         BCS,2    OPRTN             COND CODE 3 = YES
         OR,8     10                MERGE PARAM ADDR WITH OP CODE
         MTW,1    SAVE              TO CC PARAMETER
         LW,10    SAVE              GET IT
         BAL,11   @%CCVAL
         SLS,10   20                POSITION COUNT
         OR,10    8                 SWITCH COMPLETE INSTR TO R10
OPRTN    RES      0
         PULL     11
         B        *11               GO TO EXECUTE INSTR
*
         CLOSE    SETDEC,ERROUT,OPRTN
         FIN
         PAGE
*        MOVE     MOVE BYTE STRING
*        COMPARE  COMPARE BYTE STRING
FLG1     SET      0
MOVE     CNAME    X'61',F%FLG(FLG1,1)
COMPARE  CNAME    X'60',F%FLG(FLG1,1)
         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
         BARG,0   AF(1)             BYTE OR 0 OP + E1 ADDRESS
         BARG,0   AF(2)             BYTE OR 0 OP + E2 ADDRESS
         VAL,1,255 AF(3)            GEN CC
         GEN,IWD  0,NAME(1),R8,0,0  MBS OR CBS
*                                   END SUB-ROUTINE LINK
         ELSE
* GENERATE IN-LINE CODE
LIT      SET      (A(3)**24)+BA(A(2))  CC TO BIT 0-7 : E2 TO BIT 13-31
LF       LW,R9    L(LIT)
         GEN,1,7,4,20  0,NAME(1),R9,BA(A(1))-BA(A(2))                   0559A
         FIN                                                            0559B
         PEND
         CLOSE    A,LIT,IND
         DO       FLG1
* THE MOVE-COMPARE SUB-ROUTINE IS:
@%MVEBY  RES      0
         STD,R10  SAVE
         LW,R8    *SAVE             PUT INTO R8 IN CASE OF ZRO OPCODE
         ANLZ,R8  R8                E1 ADDR TO R8
         MTW,1    SAVE              BUMP POINTER
         LW,R9    *SAVE             PUT INTO R9 IN CASE OF ZRO OPCODE
         ANLZ,R9  R9                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
         FIN
         PAGE
*        PAKDEC   PACK A ZONED DECIMAL FIELD
FLG1     SET      0
         DO       FLG2              SET BY COMPZND
@%PAKDEC CNAME    F%FLG(FLG1,1)
         FIN
PAKDEC   CNAME    F%FLG(FLG1,1)
         OPEN     A
         PROC
A        SET      AF                A = CALLERS AF
        TRMS,(AF) (1,3),(1,3)       VERIFY NUMBER OF PARAMETERS         0501B
*
         DO       (NUM(A(2))=1)&(AFA(2)=0)&A(2)                         0614B
*           IF CC: NOT INDXD   &  NOT *   & ODD  = GEN IN-LINE PACK     0614D
LF       PKDC,((AF(2)**-1)+1)&X'F'  AF(1)  CF2 = CC/2 +1
         ELSE
* CC IS RUN-TIME, INDEXED, OR EVEN-GO TO SUB-ROUTINE
LF       BAL,R10  @%PCK
         BARG,0   AF(1)             BYTE OP + E1 ADDRESS
         VAL,1,31 AF(2)             GEN CC
         FIN
         PEND
         CLOSE    A
         DO       FLG1
* THE PACKING SUB-ROUTINE IS:
         OPEN     PACKER                                                552B
@%PCK    RES      0
         PUSH     10,2                                                  0626B
         LW,R8    *R10              E1 BYTE ADDR TO R8
         ANLZ,R8  R8
         AI,R10   1                 BUMP PARAM ADDR POINTER
         BAL,R11  @%CCVAL           GET CC IN R10
         AND,R10  L(31)             MAX VALUE 31 BYTES                  0633B
         LW,R15   L(X'F0F0F0F0')    SET HOLD AREA TO EBCDIC ZERO
         LI,R14   -8
         XW,R14   R1                                                    0609A
         STW,R15  PACKER+8,R1                                           0609B
         BIR,R1   %-1                                                   0609C
         STW,R14  R1                RESTORE R1                          0609D
         LI,R9    BA(PACKER+8)-1    BYTE 32 OF HOLD AREA                0640B
         SW,R9    R10               GET RECEIVING BYTE
         STD,R2   R12               SAVE R2-3                           0642B
         STD,R8   R2                FROM-TO ADDR TO R2 AS BYTE DISPLCM
         STW,R10  R14               SAVE CC VALUE
         MOVE     (0,2),(0,3),*14   MOVE FIELD TO HOLD AREA
         STD,R12  R2                RESTORE 1-2
         PULL     10,2                                                  0644B
         AI,R10   2                 UPDATE RETURN ADDR
         PACK,0   PACKER            PACK ENTIRE HOLD AREA
         B        *R10
         USECT    DATA                                                  0535B
         BOUND    8                                                     578B
PACKER   RES      8                                                     578D
         USECT    PROG                                                  578F
         CLOSE    PACKER                                                578H
         FIN
         PAGE
*        BNALPH   BRANCH IF MEMORY AREA NOT ALPHA-NUMERIC EBDIC
*                 A-Z 0-9 % @ # %   OR TRAILING BLANKS
*        BNTNUM   BRANCH IF MEMORY AREA NOT NUMERIC EBDIC   0-9
*
BNALPH   CNAME    X'3'
BNTNUM   CNAME    X'7'
@%TRFLG  SET      1                 FLAG PREVENTS DUP CODE EACH CALL
         OPEN     TGEN,TRAN,ZZ,ERTN,TP
TGEN     CNAME
         PROC
LF       GEN,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8      AF
         PEND
         PROC
         TRMS,(AF)  (1,3),(1,3),(1,3)   VERIFY NUMBER OF PARAMETERS
LF       BAL,R10  @%TRNCHK
         LDBY,0   AF(2)             BYTE OP + E2 ADDRESS
         VAL,1,255  AF(3)           GEN CC
         LI,R8    NAME              SET UP MASK
         B        AF(1)             BRANCH NOT LEGAL TO E1
         DO       @%TRFLG=1
@%TRFLG  SET      0
         B        ZZ
@%TRNCHK STD,R10  SAVE
         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 CC
         OR,R9    R10               MERGE WITH DESTINATION
         MTW,2    SAVE
         EXU      *SAVE             GET THE MASK VALUE
TP       SLS,R8   22
         AI,R8    TRAN              SET UP MASK AND SOURCE ADDRESS
         SLS,R8   2
         LD,R10   SAVE              RESTORE R11 AND SET TO RETURN
         AI,R10   2
         TTBS,R8  0
         BCR,1    *R10              IF NO ERROR RETURN
         LW,R11   L(X'0D'**24)
         AND,R11  R8                CHECK FOR GARBAGE OR WRONG SET
         BCS,2    ERTN              ERROR RETURN IF YES
         EXU      *SAVE             CHECK CNAME
         CI,R8    7                 IF NUMCERIC BLANK ILLEGAL
         BE       ERTN              ERROR RETURN
         LI,R8    X'D'              MASK TO TRAP NON BLANKS
         B        TP                RERUN
ERTN     LW,R10   L(X'FFFFF')       MASK OUT COUNT
         AND,R9   10
         LD,R10   SAVE              RESTORE FOR RETURN
         AI,R10   1
         EXU      *R10              ERROR RETURN
*****    GARBAGE        REPRESENTED BY BITS  ONE
*****    BLANK          REPRESENTED BY BITS  TWO
*****    ALPHA-NUMERIC  REPRESENTED BY BITS  FOUR OR EIGHT
*****    NUMERIC        REPRESENTED BY BITS  EIGHT
         BOUND    8
TRAN     TGEN     1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1
         TGEN     1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1
         TGEN     1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1
         TGEN     1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1
         TGEN     2,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1
         TGEN     1,1,1,1,1,1,1,1,1,1,1,4,1,1,1,1
         TGEN     1,1,1,1,1,1,1,1,1,1,1,1,4,1,1,1
         TGEN     1,1,1,1,1,1,1,1,1,1,1,4,4,1,1,1
         TGEN     1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1
         TGEN     1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1
         TGEN     1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1
         TGEN     1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1
         TGEN     1,4,4,4,4,4,4,4,4,4,1,1,1,1,1,1
         TGEN     1,4,4,4,4,4,4,4,4,4,1,1,1,1,1,1
         TGEN     1,1,4,4,4,4,4,4,4,4,1,1,1,1,1,1
         TGEN     8,8,8,8,8,8,8,8,8,8,1,1,1,1,1,1
ZZ       RES      0
         FIN
         PEND
         CLOSE    TGEN,TRAN,ZZ,ERTN,TP
         PAGE
SORT     CNAME
SORTBIN  CNAME    X'1'
@%SFLLIN SET      1
         OPEN     RELOC,RSTX,NORLC,CMPUMP,BINS,EBCD,WINNER,DCRMNT
         OPEN     NEWLEFT,JUMP,SWAP,SWALL,SWP,SWBCD,NXTHI,QUITS,A
         OPEN     REGSVX,SRTADX,TSIZX,HIADX,ZZ,SKIP
         PROC
* CHECK  NUMBER OF PARAMETERS
         TRMS,(AF)  (1,2),(1,2),(1,2),(1,2),(1-NAME,2),(0,2)
LF       LI,R9    ((NUM(AF)=6)**8)+NAME
         BAL,R10  @%SORTLN
         BCST,0   AF(1)
         VAL,1,X'FFFFFF'  AF(2)
         VAL,1,X'FFFFFF'  AF(3)
         VAL,1,X'FFFFFF'  AF(4)
         GOTO,(NAME=1)&((AF(5)=0)|(NUM(AF)=4)) SKIP
         VAL,1,255        AF(5)
         GOTO,1   A
SKIP     BOUND    1
         VAL,1,255        AF(5)+NAME
A        BOUND    1
         DO       NUM(AF)=6
         BCST,0   AF(6)
         FIN
* GENERATE SORT SUB-ROUTINE ON FIRST CALL
         DO       @%SFLLIN=1
@%SFLLIN SET      0
         B        ZZ
@%SORTLN LCI      9
         STM,1    REGSVX
         LW,6     10
         ANLZ,2   *6
         ANLZ,3   1,6
         ANLZ,4   2,6
         MW,3     4
         ANLZ,5   3,6
         ANLZ,10  4,6
         CI,9     X'100'
         BL       NORLC
*  MOVE THE SOURCE TABLE TO OUTPUT TABLE
         ANLZ,1   5,6
         AI,6     1
         STW,3    REGSVX+9
         AI,3     -1
         BLZ      NORLC
         LW,7     *2,3
         STW,7    *1,3
         BDR,3    %-2
         LW,7     *2
         STW,7    *1
         STW,1    2
         LW,3     REGSVX+9
NORLC    CW,3     4
         BLE      QUITS
         SW,3     4
*DO THE SORT
         AI,5     -1     RJ=OFFST
         LI,1     X'01'
         AND,1    9
         BNEZ     DCRMNT
* BCD SORT - CONVERT TO BYTE FACTORS
         SLD,2    2
         SLS,4    2      R4=ISIZE
         SLS,10   24   R10=LNGTH
DCRMNT   AW,2     5
         STW,2    SRTADX
         AW,3     2
         STW,3    TSIZX
         STW,2    HIADX
         B        CMPUMP,1
CMPUMP   B        EBCD
* BINARY COMPARISON ON 1 WORD KEY
         LW,3     *2
         CW,3     *2,4
         B        WINNER
* EBCDIC COMPARE  ON SPECIFIED KEY LENGTH
EBCD     STW,2    8
         STW,2    9
         AW,9     4
         OR,9     10
         CBS,8    0
WINNER   BG       SWAP
NXTHI    AW,2     4
         CW,2     TSIZX
         BGE      QUITS
         STW,2    HIADX
         B        CMPUMP,1
*
* LEFT PLAYER LOSES- SWAP ITEMS AND SEEK LEFT WITH WINNER
SWAP     STW,2    3
         SW,3     5
         LW,7     4
         B        %+1,1
         B        SWBCD
SWALL    STW,3    8
         AW,8     7
         AI,7     -1
SWP      LW,9     *3,7
         XW,9     *8,7
         STW,9    *3,7
         MTW,-1   7
         BGEZ     SWP
* SEEK LEFT AFTER SWAP
         SW,2     4
         CW,2     SRTADX
         BGE      CMPUMP,1
LSTRYT   LW,2     HIADX
         B        NXTHI
SWBCD    SLS,3    -2
         SLS,7    -2
         B        SWALL
QUITS    LW,10    6
         AI,10    5
         LCI      7
         LM,R1    REGSVX
         B        *10
REGSVX   RES      10
SRTADX   RES      1
TSIZX    RES      1
HIADX    RES      1
RELOC    EQU      %
ZZ       RES      0
         FIN
         PEND
         CLOSE    RELOC,RSTX,NORLC,CMPUMP,BINS,EBCD,A,ZZ,WINNER,SWP
         CLOSE    NXTHI,NEWLEFT,JUMP,SWAP,SWALL,SWBCD,DCRMNT,OUITS
         CLOSE    REGSVX,SRTADX,TSIZX,HIADX,SKIP
         CLOSE    FLG1,FLG2
CALL     CNAME
         PROC
         LOCAL    I,J
I        SET      NUM(AF)
LF(1)    BAL,X7   AF(1)
         DO1      I>1
         B        %+I
I        SET      I-1
         DO1      I>0
LF(2)    EQU      %
J        DO       I
         GEN,1,31 AFA(J+1),AF(J+1)
         FIN
         PEND
SAVE     CNAME
         PROC
         LOCAL    I,J
I        SET      NUM(AF)
LF       B        %+(I+3)
         PLW,7    *6
J        DO       I
         PLW,AF(J) *6
         FIN
         B        0,7
J        DO       I
         PSW,AF(I-(J-1)) *6
         FIN
         PSW,7    *6
         PEND
RETURN   CNAME
         PROC
         DO       NUM(AF)>1
         ERROR,0,1 'EXTRA FIELD(WARNING ONLY)'
         FIN
         DO       NUM(AF)>0
LF       B        AF(1)+1
         ELSE
         ERROR,7,1 'RETURN SYMBOL MISSING'
         FIN
         PEND
X1       EQU      1
X2       EQU      2
X3       EQU      3
X4       EQU      4
X5       EQU      5
X6       EQU      6
X7       EQU      7
X8       EQU      8
X9       EQU      9
X10      EQU      10
X11      EQU      11
X12      EQU      12
X13      EQU      13
A        EQU      14
Q        EQU      15
         END
