*M*      RDWRT    READ M:EI / WRITE M:EO
RDWRT    DSECT    1
VERSION  EQU      2            1=BPM,2=UTS
         PAGE
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
SR1      EQU      8
SR2      EQU      9
SR3      EQU      10
SR4      EQU      11
D1       EQU       12
D2       EQU      13
D3       EQU      14
D4       EQU      15
CEOL     EQU      2
CEOF     EQU      3
CNEXT8   EQU      4
CNBC1    EQU      5
CNBC65   EQU      6
CBLANK   EQU      7
COBTOTAL EQU      108*8             MAX BIT COUNT OF CO RECORD
MAXCLMN  EQU      140
         PAGE
         TITLE    'RDWRT'
         SYSTEM   SIG7
*
*P*      NAME:    RDWRT
*P*
*P*      PURPOSE: THIS ROUTINE ISSUES THE READ AND WRITE CALS THAT
*P*               PERFORM A FILE COPY.  ALL OF THE MULTIPLE REEL LOGIC
*P*               IS CONTAINED IN THIS ROUTINE.
*P*
*DO*
*P*
*
* INPUT
*        M:EI     INPUT DCB
*        M:EO     OUTPUT DCB
*        TOARG    OUTPUT ARGUMENT TABLE
*        ARGTBL   INPUT ARGUMENT TABLE
*        IOBUF    I/O BUFFER
* OUTPUT
*        RDFPT    READ FPT
*        WRTFPT   WRITE FPT
*        TOSWT    DEFINED -TO-SWITCH
*        COMPLETE DEVICE/FILE COPY
*
*
*FIN*
         REF      SUPERR            IGNORE ERRORS FLAG
         REF      HEX2BCD
         REF      INCRPT            INPUT ENCRYPTION SEED ADDRESS
         REF      OUTCRPT           OUTPUT ENCRYPTION SEED ADDRESS
         REF      M:SI
         REF      IOABORTS
         REF      DELETEF           CARRIAGE POSITION FLAG FOR READONE
         REF      CMBX              TO SET % POSITION FOR ERRORS
         REF      ERROR,GETPAGE,CLOSEO
         REF      M:EI,M:EO,TOARG,TOSWT,RDFPT,WRTFPT,IOBUF
         REF      RECNUM
         REF      READONE
         REF      BUFSIZE
         REF      CIBUSED,CIBLEFT,CIBTOTAL,CIWORD,RECSIZE,CISEQ
         REF      COBUSED,COBLEFT,COWORD
         REF      ATTRB,PRTBUF,CODE
         REF      KEY,CARDSEQ
         REF      BIN2BCD
         REF      TABSET
         REF      MODE
         REF      RSSAVE
         REF      LINENO
         REF      BREAK,COPYSTDF
         REF      SEQNUM
         DEF      CCTAB
         REF      SELECT,J:JIT
         REF      M:UC,M:LO
         REF      DEVICE
         REF      COPYSK
         REF      GRANCNT
         REF      PRNTBUF,UNPRINT
         REF      ANSBLK,BLKBUFF
         REF      MBS,BCD2BIN
         REF      UNBADR,BLKSIZE
         REF      NPAGE
         REF      BOG
*
         USECT    RDWRT
         LCI      7                 SAVE REGISTERS
         PSM,R5   *R7
*
*
*
         LI,R1    7                 INITIALIZE READ FPT
         LW,R2    R7
         AI,R2    RDFPT-1
         LW,R3    IRDFPT-1,R1
         STW,R3   *R2,R1
         BDR,R1   %-2
*
*
         LI,R1    WFPTSIZE          WRITE FPT SIZE
         LW,R2    R7
         AI,R2    WRTFPT-1
         LW,R3    IWRTFPT-1,R1
         STW,R3   *R2,R1
         BDR,R1   %-2
*
         STW,R0   GRANCNT           ZERO COPY ABORT FLAG
         LW,R1    DEVICE+2,R7       SET % AT INPUT
         STW,R1   CMBX,R7
         LI,R1    SETEI             OPEN DCBS IF CLOSED, SET ERR/ABN/CRPT
OPNDCB0  LI,R2    X'20'
         LW,R3    0,R1
         CH,R2    *R3
         BANZ     %+3
         LW,R2    2,R1              ERROR ADDRESS
         CAL1,1   OPNI3             OPEN IT UP
         CAL1,1   0,R1
         AI,R1    X'80005'          TO NEXT FPT
         BNC      OPNDCB0
         LW,R1    BUFSIZE,R7
         LI,R3    X'30'
         CS,R3    M:EI+5            TEST IF RANDOM FILE
         BE       %+3
         CS,R3    M:EO+5
         BNE      READ16            NO
         LI,R1    2048              SET BUFFER SIZE TO ONE PAGE
READ16   STW,R1   RDFPT+5,R7        SET SIZE OF CURRENT RD/WR BUFFER
         LI,R2    IOBUF             ADD I/O BUFFER
         AW,R2    R7
         LI,SR2   X'A'              IF ANS BLOCKING OR DEBLOCKING
         CS,SR2   M:EI              ADJUST FOR MULTIPLE BUFFERS
         BNE      READ41            NOT INPUT.
         LW,R1    BUFSIZE,R7        RESTORE ORIGINAL SIZE
         CW,R3    M:EI+5            IF UNBLOCKED, USE RANDOM BUFFER
         BAZ      READ41
         AI,R2    64                LEAVE A HOLE IF UNBLOCKING
         LW,R1    M:EI+3            IN CASE WE WANT SEQUENCING, ETC.
         SLS,R1   -17               GET MAX BLOCK SIZE FOR BUFFER
         AI,R1    0
         BNEZ     %+2
         LI,R1    2048
READ41   CS,SR2   M:EO
         BNE      READ42
         CW,R3    M:EO+5
         BAZ      READ42            NO OUTPUT BLOCKING, WRITE FROM INPUT
         CW,R1    ANSBLK+2          MAKE INPUT BUFFER AT LEAST
         BGE      %+2               LRECL
         LW,R1    ANSBLK+2
         LW,R3    ANSBLK            HOW BIG ARE THE BLOCKS
         STW,R2   ANSBLK+1          SAVE BLOCKING BUFFER ADDRESS
         AI,R3    3                 AND MOVE INPUT BUFFER ABOVE IT
         SLS,R3   -2
         AW,R2    R3
READ42   STW,R1   RDFPT+5,R7        INPUT BUFFER SIZE
         STW,R2   RDFPT+4,R7        AND LOC
         AI,R1    -2048             COMPUTE # ADDITIONAL PAGES TO GET
         SLS,R1   -2
         AW,R1    R2
         SW,R1    R7
         SLS,R1   -9
         STW,R1   NPAGE,R7
         BEZ      %+3
         CAL1,8   GETPG
         BCS,8    EOF11             CANT DO IT
READ43   EQU      %
         LI,R1    4
         CW,R1    TOARG+10,R7       LN OPTION SPECIFIED
         BNE      READ40            NO
         LI,R1    KEY
         AW,R1    R7
         STW,R1   WRTFPT+6,R7       ENTER KEY ADDRESS IN WRITE FPT
         LW,R1    =9999999
         STW,R1   TOARG+14,R7       SET MAX LN VALUE FOR COMPARE
READ40   EQU      %
         LI,R6    0                 CLEAR EOD COUNTER
         STW,R0   UNBADR            INITIALIZE FOR UNBLOCKING
         STW,R0   COWORD,R7         AND COMPRESSING
         LW,R2    ANSBLK+2          AND FOR BLOCKING
         LH,R2    BLKOVH,R2
         STW,R2   BLKBUFF
         LW,R1    SELECT,R7
         STW,R1   RSSAVE,R7         SAVE COUNT OF REC SELECTIONS
         LI,SR2   SELECT+1          INITIALIZE RS TABLE INDEX
READ4    STW,R0   RECNUM,R7         ZERO RECORD NUMBER COUNT
         STW,R0   CISEQ,R7
         STW,R0   CIWORD,R7         AND DECOMPRESSING
         LW,R2    RDFPT+4,R7        SET PROBABLE RECORD ADDRESS
         STW,R2   WRTFPT+4,R7
         SLS,R2   2
         STW,R2   WRTFPT+7,R7
*
READ0    LI,R6    0                 CLEAR EOD COUNTER
*
READ1    LW,R1    ='    '           BLANK BUFFER
         LI,R3    34
         LW,R2    RDFPT+4,R7
         STW,R1   *R2,R3
         BDR,R3   %-1
         STW,R1   0,R2              INITIALIZE FIRST WORD
         CAL1,1   RDFPT,R7          READ INPUT RECORD
READ14   EQU      %
         MTW,0    GRANCNT           IF ABORTING C DEVICE COPY, READ
         BNEZ     READ1             UNTIL ABN OCCURS
         LW,R3    M:EI+4            TRANSFER RECORD SIZE TO WRITE FPT
         SLS,R3   -17
         LI,R1    X'F'
         AND,R1   M:EI              GET ASN FROM DCB
         CI,R1    2                 IS IT DEVICE OR ANS
         BG       %+2               YES
         LW,R3    M:EI+13           NO - GET SIZE FROM RWS WORD
         AI,R3    0                 TEST FOR NULL RECORD
         BNEZ     READ33            NO
         LW,SR4   TOARG+5,R7        TEST IF HEXDUMP
         CI,SR4   6
         BE       READ33            YES, NO DUMMY BYTE
         LW,SR4   TOARG,R7
         CI,SR4   8                 TEST IF OUT TO ME,LP,CP
         BL       READ33            NO-OUTPUT NULL RECORD
         AI,R3    1                 FORCE ONE BLANK FOR OUTPUT
READ33   EQU      %
         STW,R3   WRTFPT+5,R7       SET RECORD SIZE
READ26   CI,R1    X'A'              IS INPUT FROM ANS TAPE
         BNE      %+3               NO
         STW,R3   BLKSIZE           SET TO SIZE OF INPUT
READ29   BAL,SR4  UNBLK             OUTPUT NOT ANS - GO UNBLOCK
         LI,R3    3                 IF CI, DECOMPRESS
         CW,R3    CODE,R7
         BE       DECOMP0
READ28   EQU      %
         LI,R3    6                 SET EOF CODE
         MTW,1    RECNUM,R7
         DO1      VERSION=2
         MTW,1    RDFPT+6,R7        INC BLOCK FOR RANDOM
         MTW,0    RSSAVE,R7         ANY RS OPTIONS IN EFFECT
         BEZ      READ2             NO
         LW,R1    SR2               GET X-Y POINTER
         LW,R2    RECNUM,R7    GET CURRENT REC. NO.
         CW,R2    *R7,R1       COMPARE WITH X VALUE
         BL       READ17            NOT IN RANGE
         AI,R1    1                 STEP TO Y VALUE
         CW,R2    *R7,R1       COMPARE
         BL       READ2             IN RANGE
         BG       %+3               OUT, CHECK NEXT
         MTB,-1   SR2               LAST, SET FLAG
         B        READ2             AND WRITE
         MTW,-1   RSSAVE,R7         COUNT DOWN
         BEZ      EOD2              ALL DONE
         STB,R0   SR2               CLEAR LAST FLAG
         AI,SR2   2                 POINT INDEX TO NEXT PAIR
         CW,R2    *SR2,R7      MUST FILE BE REPOSITIONED.
         BL       READ17            NO
         BE       READ2             GO WRITE RECORD
READ3    LW,R1    DEVICE,R7
         CI,R1    8
         BE       DEVERR            NO BACKSPACE ON ME
         CI,R1    1                 IS INPUT FROM CR
         BE       DEVERR            YES - ERROR
         CI,R1    7                 IS INPUT FROM ANS TAPE
         BE       DEVERR            YES - ERROR
         CAL1,1   PFIL              POSITION TO BOF
         B        READ4
READ17   LW,R3    *SR2,R7
         AI,R3    -1                IS PRECORD NEEDED
         LI,R1    3
         CW,R1    CODE,R7           IF COMPRESSED, DECOMPRESS
         BE       WRITEX
         CS,R1    M:EI              TEST ASN
         BLE      READ1             NOT FILE OR LABEL - DONT PRECORD
         LI,R1    X'A'              CHECK FOR ANS
         CS,R1    M:EI
         BE       WRITEX            CONTINUE UNBLOCKING IF REQUIRED
READ17A  EQU      %
         LI,R1    X'30'
         CS,R1    M:EI+5            TEST IF ORG IS RANDOM
         BNE      READ25            NO
         DO1      VERSION=2
         STW,R3   RDFPT+6,R7        SET BLOCK FOR NEXT READ
         STW,R3   RECNUM,R7         UPDATE RECORD NUMBER
         B        READ1
READ25   EQU      %
         SW,R3    RECNUM,R7         COMPUTE NO. OF RECS TO SKIP
         BEZ      READ1             NONE
READ23   CI,R3    32767             ONLY ONE PREC REQUIRED
         BLE      READ24            YES
         LW,R2    R3                SAVE NO. RECS YET TO SKIP
         LI,R3    32767             PREC COUNT
         CAL1,1   PREC2
         AWM,R3   RECNUM,R7         BUMP RECORD COUNT
         LW,R3    R2
         AI,R3    -32767            COMPUTE NO. RECS YET TO SKIP
         B        READ23
READ24   EQU      %
         CAL1,1   PREC2             POSITION TO RECORD WANTED
         AWM,R3   RECNUM,R7         BUMP RECNUM BY PREC NUM
         B        READ1             GO READ
READ2    EQU      %
         LW,R3    WRTFPT+5,R7  LOAD RECORD LENGTH.
         CI,R3    140               IS THE RECORD A REASONABLE LENGHT
         BG       READ52            NO, DONT TRY THIS STUFF
         BAL,SR4  NCCHK             CHECK FOR NC OPTION
         LW,R1    TOARG+8,R7
         CI,R1    X'FF00'           WAS TX OPTION SPECIFIED
         BAZ      READ52            NO
         LW,R1    WRTFPT+4,R7       GET BUFFER ADDRESS
         SW,R1    R7                AS A DISPLAVEMENT
         BAL,SR4  TABEXP            EXPAND TABS
READ52   EQU      %
         BAL,SR4  NBCHK             TRUNCATE BLANKS
         BAL,SR4  COMPRESS
WRITE0   LW,R2    WRTFPT+7,R7       CHECK FIRST BYTE FOR BIN/BCD
         LB,R2    0,R2
         LI,R3    X'10'             WORD1 OF SETBIN CAL
         LI,R1    4                 CHECK STANRARD BIN VALUES
         CB,R2    BINVAL,R1
         BE       %+3
         BDR,R1   %-2
         LI,R3    0                 WROD1 OF SETBCD CAL
         LW,R2    TOARG,R7          IF NOT CP...
         CI,R2    10
         BNE      WRITE01
         LW,R2    TOARG+6,R7        ..OR BIN/BCD EXPLICITLY
         MTB,0    R2                SPECIFIED, DONT SET BIN/BCD IN DCB
         BNEZ     WRITE01
         LW,R2    SETBINBCD
         CAL1,1   R2
WRITE01  RES
         LW,R1    TOARG+10,R7       TEST IF ANY SEQUENCING WANTED
         BNEZ     SEQID,R1          BR TO APPROPRIATE ROUTINE IF YES
WRITE2   EQU      %
         BAL,SR4  BLKTEST           TEST IF BLOCKING WANTED
         LI,SR4   WRITEX            NO, SET RETURN FROM HEXDUMP
         LI,R5    6
         CW,R5    TOARG+5,R7        IS THERE AN 'X' PRESENT
         BE       HEXDUMP           YES, GO DO IT
WRITE3   LW,R1    TOARG+8,R7
         CW,R1    =X'00FF0000'      IS K OPTION PRESENT
         BAZ      WRITE1            NO
         LI,R3    X'F0'
         LI,R2    X'20'
         CS,R2    M:EI+5            IS FILE KEYED
         BNE      WRITE5            NO
         LI,R1    X'F'              MUST BE FILE OR LABEL
         AND,R1   M:EI
         CI,R1    3
         BGE      WRITE5
         LW,R1    WRTFPT+4,R7       IWONT WORK IF
         SW,R1    R7                NOT AT IOBUF
         CI,R1    IOBUF
         BNE      WRITE5
         LW,R1    M:EI+10           KEY ADDRESS
         LB,R2    M:EI+12           GET KEY MAX
         CI,R2    3                 IS IT A 3-BYTE KEY
         BNE      WRITE6            NO
         LW,R3    0,R1
         AND,R3   =X'FFFFFF'        GET KEY
         CW,R3    =9999999          IS IT REALLY AN EDIT KEY
         BG       WRITE6            NO, USE UNPRINT
         LW,R1    R3
         BAL,SR4  BIN2BCD           CONVERT TO BCD
         SLD,R2   8
         LB,R1    R2                FIRST BYTE OF VALUE
         SLS,R2   8
         OR,R1    =X'40604000'
         OR,R2    =X'0000F04B'      EDIT NO. TO XXXX.XXX
         OR,R3    =X'F0F0F040'
         STW,R1   LINENO,R7         PUT IN BUFFER
         STW,R2   LINENO+1,R7
         STW,R3   LINENO+2,R7
         LW,R1    RECNUM,R7         GET RECORD NUMBER
         BAL,SR4  BIN2BCD           CONVERT TO BCD
         STW,R2   SEQNUM,R7
         STW,R3   SEQNUM+1,R7       PUT NUMBER IN BUFFER
         LI,R1    2
         STW,R1   WRTFPT+7,R7       ADD BTD
         MTW,-5   WRTFPT+4,R7       CHANGE BUFFER ADDRESS
         LI,R1    18                INCREMENT WRITE COUNT
         AWM,R1   WRTFPT+5,R7
         B        WRITE1
*
WRITE6   EQU      %
         LD,R2    KEYX
         STW,R2   PRNTBUF,R7        SET UP LINE FOR PRINTING KEY
         STW,R3   PRNTBUF+1,R7
         LI,D3    PRNTBUF+1
         AW,D3    R7
         BAL,SR4  UNPRINT           ENTER KEY IN BUFFER
         CAL1,1   PRINT1            WRITE BLANK LINE
         AI,R2    5                 LENGTH OF PRINT LINE
         AI,D3    -1                COMPUTE BUFFER ADDRESS
         CAL1,1   PRINT2            PRINT KEY
         B        WRITE1
WRITE5   LW,R1    RECNUM,R7         GET RECORD NUMBER
         BAL,SR4  BIN2BCD           CONVERT TO BCD
         LW,R1    ='  - '           HYPHEN
         STB,R3   R1                LAST BYTE TO R1
         SLD,R2   -8                 POSITION OTHER BYTES
         LW,R4    WRTFPT+4,R7       STORE BELOW BUFFER
         STW,R2   -3,R4
         STW,R3   -2,R4
         STW,R1   -1,R4
         LI,R1    3
         STW,R1   WRTFPT+7,R7       BTD
         MTW,-3   WRTFPT+4,R7       CHANGE BUFFER ADDRESS
         LI,R1    9                 INCREMENT WRITE COUNT
         AWM,R1   WRTFPT+5,R7
*
WRITE1   EQU      %
         CAL1,1   WRTFPT,R7         WRITE THE RECORD
         LW,R2    TOARG,R7
         CI,R2    9                 IS OUTPUT TO LP
         BNE      WRITEX            NOPE, ALL DONE
         LI,R3    X'100'
         CW,R3    M:EO       CHECK IF VFC OPTION SPECIFIED.
         BANZ     WRITEX
         LI,R3    132               SHOULD BE LW,R3 M:EO+4
         SLS,R3   0                 SLS,R3 -17
         SW,R2    R3                ARE WE DONE YET
         BLEZ     WRITEX            YES
         STW,R2   WRTFPT+5,R7       SET NEW WRITE SIZE
         LCW,R3   R3
         AWM,R3   WRTFPT+7,R7       SET NEW BTD, BA(BUF)
         LW,R3    WRTFPT+7,R7
         SLS,R3   -2
         STW,R3   WRTFPT+4,R7       AND WA(BUFFER)
         B        WRITE1            TRY AGAIN
WRITEX   EQU      %
         LW,R4    RDFPT+4,R7        SET OUT TO IN
         STW,R4   WRTFPT+4,R7
         SLS,R4   2
         STW,R4   WRTFPT+7,R7
         BAL,SR4  BRCHK             CHECK BREAK FLAG
         INT,R2   COWORD,R7         IF COMPRESSING, FINISH
         BDR,R2   COMPNXT           THIS RECORD
         BCS,8    EOF8              LAST RECORD JUST DONE
         LW,R2    RSSAVE,R7         IF SELECTING..
         BDR,R2   %+3               AND LAST RANGE..
         MTB,0    SR2               AND LAST OF IT..
         BNEZ     RETURN            QUIT.
         MTW,0    CIWORD,R7         IF DECOMPRESSING,
         BNEZ     DECOMPR           EXTRACT THE NEXT RECORD
READN    MTW,0    UNBADR            ARE WE UNBLOCKING ANS
         BNEZ     READ29
         B        READ0
*
RDABN    LB,R3    SR3               GET ABNORMAL CODE
         CI,R3    5                 TEST FOR EOD
         BE       EOD1              EOD FOUND
         CI,R3    6                 EOF ENCOUNTERED
         BNE      EOF1              NO
EOD1     EQU      %
         LI,R5    6
         CW,R5    TOARG+5,R7        DOING A HEX DUMP
         BNE      EOD2              NO
         LI,R5    3
         CS,R5    M:EI              HEXDUMP FROM A DEVICE
         BNE      EOD2              NO
         LW,R1    MODE+3,R7
         CI,R1    X'FF'             TEST FOR DEOD OPTION
         BANZ     EOD2              YES
         LI,R2    18                MESSAGE SIZE
         LI,R1    M:EO              DCB ADDRESS
         CAL1,1   FPTEOD            YES-INDICATE --EOD-- ENCOUNDED
EOD2     EQU      %
         AW,R6    R3                3 HAS 5 OR 6, 6 HAS 0 OR 1
         CI,R6    5                 SO 6 IS 6 OR 7 UNLESS FIRST EOD
         BG       EOF5
         MTW,0    RSSAVE,R7         ANY MORE RECORD SELECTIONS
         BNEZ     EOF5+2            YES
         LW,R1    MODE+3,R7
         CI,R1    X'FF'             DEOD OPTION
         BANZ     READ1             YES, NO FILE MARK
         LI,R1    3                 ONLY WRITE MARKS TO DEVICES
         CS,R1    M:EO
         BNE      READ1
         CAL1,1   WEOF              WRITE EOD
         B        READ1
*
EOF1     EQU      %
         CI,R3    7                 TEST FOR LOST DATA
         BNE      EOR
         LW,SR4   ANSBLK+2          IF WERE OUTPUT BLOCKING(FMT(F)),
         CI,SR4   1                 THE BUFFER IS BIG ENOUGH
         BE       *SR1
         BAL,SR4  GETPAGE           GET ADDITIONAL BUFFER PAGE
         CI,SR1   0                 DID WE GET SOME PAGES
         BNE      EOF2              YES
         LI,R1    33                SET ERROR CODE
         B        IOERR0
EOF11    EQU      %
         LI,R1    33                ERROR-ADDITIONAL PAGE NOT AVAILABLE
         STW,R0   CMBX,R7           NO INITIAL MEMORY
         BAL,SR4  ERROR
         B        RETURN
EOF2     EQU      %
         LW,R2    RDFPT+5,R7        OLD BUFFER SIZE
         SLS,SR1  11                CONVERT PAGES TO BYTES
         AW,R2    SR1               NEW BUFFER SIZE
         LI,R1    X'F'
         AND,R1   M:EI              GET ASN FROM DCB
         CI,R1    2                 IS IT DEVICE OR ANS
         BLE      EOF4              NO
         LW,SR1   RDFPT+5,R7
         CI,SR1   X'8000'           PERMIT ONLY X'7FFF' MAX RECORD
         BLE      EOF3
         LI,R1    38                ERROR-RECORD SIZE LARGER THAN 15 BIT
IOERR0   RES
         BAL,SR4  ERROR
         MTW,0    SUPERR            IF SUPRESSION, IGNORE
         BNEZ     READ14            THE PROBLEM
         B        RETURN
EOF3     CI,R2    X'7FFF'
         BL       EOF4              IF BUFFER LARGER THAN 15 BITS
         LI,R2    X'7FFF'           SET AT 15 BITS
EOF4     STW,R2   RDFPT+5,R7
         STW,R2   BUFSIZE,R7
         CAL1,1   PREC              POSITION BACK ONE RECORD
         B        READ1
EOF5     MTW,0    RSSAVE,R7         ANY RS OPTIONS
         BEZ      COMPLAST          NO, FINISH UP
         LW,R3    RECNUM,R7         GET NO. OF LAST REC
         CW,R3    *SR2,R7           COMPARE WITH X VALUE
         BL       EOF7              ERROR-ENTIRE SELECTION NOT IN FILE
         AI,SR2   1                 POSITION TO Y VALUE
         CW,R3    *SR2,R7           LAST REC NO. VS Y VALUE
         BGE      EOF6              WITHIN FILE
         LI,R5    6
         CW,R5    TOARG+5,R7        DOING A HEX DUMP
         BE       EOF6              YES - DON'T REPEAT MESSAGE
         LI,R2    19
         LI,R1    M:UC
         LC       BOG
         BCS,12   %+3               BRANCH IF ONLINE OR GHOST
         LI,R2    18                BATCH - DON'T PRINT NL CHAR
         LI,R1    M:LO
         CAL1,1   FPTEOD            PRINT 'EOD ENCOUNTERED'
EOF6     MTW,-1   RSSAVE,R7         COUNT DOWN
         BEZ      COMPLAST          ALL DONE
         AI,SR2   1                 POSITION TO X VALUE
         CW,R3    *SR2,R7           TEST IF IN FILE
         BGE      READ3             YES - RE-READ FILE
EOF7     LI,R1    41                ERROR - NOT IN FILE
         BAL,SR4  ERROR
         AI,SR2   1                 POSITION TO Y VALUE
         B        EOF6              TRY NEXT RS PAIR
*
EOF8     RES
         BAL,SR4  BLKLAST
         B        RETURN
EOR      CI,R3    X'1C'             TEST FOR END OF REEL
         BNE      IOERR1
         LI,R3    EOCVOL2
         LI,R4    2
         BAL,SR4  ULBLCHK           TEST FOR TRAILER LABEL
         LI,R1    3
         CS,R1    M:EI
         BNE      %+4               IF FT DONT REREAD ANY TAPES
         LB,R1    M:EI+11           GET CURRENT VOL IN DCB
         CW,R1    DEVICE+1,R7       HOW MANY DO WE HAVE
         BGE      IOERR1            NOT ENOUGH
         CAL1,1   EICVOL            ADVANCE TO NEXT INPUT TAPE REEL
         B        *SR1               CONTINUE TO READ
*
WRTABN   LB,R1    SR3               GET ABNORMAL CODE
         CI,R1    X'1C'             TEST FOR END OF REEL
         BNE      EOERR
         LW,R1    TOARG,R7
         CI,R1    6                 OUTPUT TO DEVICE TAPE
         BE       %+3               YES, WRITE FILEMARKS
         AI,SR1   -1                BACK UP TO WRITE CAL
         B        %+3
         CAL1,1   WEOF              DOUBLE EOF
         CAL1,1   WEOF              WRITE EOD
         CAL1,1   EOCVOL            CLOSE CURRENT OUTPUT VOLUME
         B        *SR1              CONTINUE READING AND WRITING
*
DEVERR   LI,R1    27                INVALID RS SPEC FOR DEVICE
         B        IOERR1+1          REPORT ERROR
EIERR    LB,R1    SR3               TEST FOR LAST REEL
         CI,R1    X'56'
         BE       READ14            YES, DO THE LAST RECORD
IOERR3   CI,R1    X'42'
         BNE      IOERR1
         LI,D4    0
         LI,R1    X'30'
         CS,R1    M:EI+5
         BE       RETURN            END OF RANDOM FILE
         B        IOERR1
*
ULBLCHK  LW,R1    DEVICE,R7
         CI,R1    4                 IS INPUT FROM LT
         BE       %+3               YES
         CI,R1    7                 INPUT FROM ANS TAPE
         BNE      *SR4              NO
         LI,SR1   READ1                    RETURN LOC TO RESUME READ
         LW,R1    TOARG,R7
         CI,R1    4                 IS OUTPUT TO LT
         BE       %+3               YES
         CI,R1    7                 OUTPUT TO ANS TAPE
         BNE      *SR4              NO
         LW,R1    RDFPT+4,R7        ADDRESS OF READ BUFFER
         LW,R1    0,R1
         CW,R1    ='    '           WAS A TRAILER LABEL READ
         BE       *SR4              NO
         LCI      3
         LM,R1    0,R3               MOVE FPT TO DATA AREA
         STM,R1   IOBUF+250,R7
         LW,R1    RDFPT+4,R7
         LW,R3    R7
         AW,R3    R4                COMPUTE ADR OF LABEL ENTRY
         STW,R1   IOBUF+250,R3      ENTER BUFFER ADDRESS
         CAL1,1   IOBUF+250,R7      DO CLOSE OR CLOSE VOLUME
         B        *SR4
EOERR    EQU      %
         STW,R0   TOSWT,R7          CLEAR DEFINED OUTPUT
         LW,R1    TOARG+2,R7        SET OUTPUT % POSITION
         STW,R1   CMBX,R7
*
IOERR1   LI,R1    0                 FLAG I/O ERROR
         MTW,1    GRANCNT           SET ABORT FLAG
         BLZ      READ1             IGNORE ALL BUT 05,06 READING C DEVICE
         LH,R2    IOABORTS          IS THIS A SEVERE ERROR
         LH,D4    SR3
         CH,D4    IOABORTS,R2
         BNE      %+2
         LI,D2    3                 SET SEVERITY3
         BDR,R2   %-3
         MTW,0    COPYSK            TEST IF COPYALL
         BEZ      %+3               NO
         LW,D4    SR3               GET ERR/ABN CODE
         B        RETURN1
         BAL,SR4  ERROR
*
RETURN   RES
         LI,D4    0
RETURN1  EQU      %
         LI,R3    CLOSE2
         LI,R4    3
         BAL,SR4  ULBLCHK           TEST FOR TRAILER LABEL
         MTW,0    GRANCNT           WAS COPY ABORTED
         BNEZ     %+2               YES
         CI,D2    2                 OTHER ERROR PERHAPS
         BL       RETURNX           NO, OR SECOND RETURN FROM SI DEVICE
         LW,R1    TOARG,R7
         CI,R1    3                 GOING TO RAD FILE
         BE       %+3               YES
         CI,R1    5                 GOING TO DISK PACK
         BNE      RETURN2           NO
         LW,R1    M:EO
         CW,R1    =X'00200000'      IS OUTPUT FILE OPEN
         BAZ      RETURN2           NO
* DON'T RELEASE IF FUN IS INOUT
         LW,R1    M:EO+1            GET FUN
         CW,R1    =X'00080000'      IS IT INOUT?
         BANZ     RETURN2           YES, DON'T RELEASE
         MTW,0    RECNUM,R7         IF NO RECORDS READ
         BEZ      %+3               RELEASE EMPTY FILE
         MTW,0    SUPERR            IF SUPRESSING, SAVE IT
         BNEZ     RETURN2
         CAL1,1   FPTREL            RELEASE BAD RAD FILE
RETURN2  CAL1,1   EIEQSI            IF EI IS SI, DONT READ REST OF FILE
         MTB,-1   GRANCNT           SET FLAG NEGATIVE
         AI,SR1   0                 AS COMMANDS
         BNEZ     READ1
RETURNX  LCI      7
         PLM,R5   *R7
         B        *SR4
*
WEOF     DATA     X'02000000'+M:EO
EICVOL   GEN,8,7,17      X'03',0,M:EI
         DATA     0
EOCVOL   DATA     X'03000000'+M:EO
         DATA     0
EOCVOL2  GEN,8,24 X'03',M:EO
         DATA     X'40000000'
CLOSE2   GEN,8,24 X'15',M:EO
         DATA     X'C0000000'
         DATA     2
*
PREC     DATA     X'1D000000'+M:EI
         DATA     X'10'
PREC2    GEN,8,24 X'1D',M:EI
         DATA     X'C0000000'
         PZE      *R3               C(R3)=NO. OF RECORDS
         DATA     EOF7              ABNORMAL
         BOUND    8
KEYX     TEXT     'KEY=    '
PRINT1   GEN,8,24 X'11',M:EO
         DATA     X'34000010'
         DATA     CITAB+1           BUFFER
         DATA     2                 SIZE
         DATA     0                 BTD
PRINT2   GEN,8,24 X'11',M:EO
         DATA     X'34000010'
         PZE      *D3               BUFFER
         PZE      *R2               SIZE
         DATA     0                 BTD
GETPG    DATA     X'88000001'
*
SETEI    DATA     X'06000000'+M:EI
         DATA     X'E0000000'
         DATA     EIERR             ABNORMAL ADDRESS
         DATA     EIERR             ERROR ADDRESS
         PZE      *INCRPT           INPUT ENCRYPTUIN
*
SETEO    DATA     X'06000000'+M:EO
         DATA     X'E0000000'
         DATA     EOERR             ABNORMAL ADDRESS
         DATA     EOERR             ERROR ADDRESS
         PZE      *OUTCRPT          OUTPUT ENCRYPTION
*
EIEQSI   GEN,8,24 X'2B',M:EI
         DATA     M:SI
*
OPNI3    GEN,8,24 X'94',R3          OPEN DCB IN 3
         DATA     X'C0000000'       ERR/ABN
         PZE      *R2
         PZE      *R2
*
IRDFPT   DATA     X'10000000'+M:EI
         DO1      VERSION=2
         DATA     X'F1000018'       EXISTENCE FLAGS
         DO1      VERSION=1
         DATA     X'F0000018'  EXISTENCE FLAGS.
         DATA     IOERR1            ERROR ADDRESS
         DATA     RDABN             ABNORMAL ADDRESS
         DATA     0                 BUFFER ADDRESS
         DATA     0                 BUFFER SIZE
         DATA     0                 BLOCK
*
IWRTFPT  DATA     X'11000000'+M:EO
         DATA     X'FC000050'       EXISTANCE FLAGS
         DATA     EOERR             ERROR ADDRESS
         DATA     WRTABN            ABNORMAL ADDRESS
         DATA     0                 BUFFER ADDRESS
         DATA     0                 BUFFER SIZE
         GEN,1,31 1,M:EI+10         KEY ADDRESS
         DATA     0                 NO BYTE DISPLACEMENT
WFPTSIZE EQU      %-IWRTFPT         WRITE FPT SIZE
FPTEOD   GEN,8,7,17      X'91',0,R1
         DATA     X'34000000'
         DATA     %+3               BUFFER
         PZE      *R2               SIZE
         DATA     0                 NO DISPLACEMENT
         TEXT     '--EOD--ENCOUNTERED
'
PFIL     GEN,8,7,17      X'1C',0,M:EI
         DATA     X'10'
FPTREL   GEN,8,24 X'15',M:EO
         DATA     X'80000000'
         DATA     1
         PAGE
*TEST IF BLOCKING WANTED FOR ANS.  IF SO, ADD RECORD TO OUTPUT BLOCK.
BLKLAST  MTB,-1   ANSBLK            MAKE BLOCK TOO SMALL
BLKTEST  EQU      %
         LW,R3    ANSBLK+1
         SLS,R3   2
         AW,R3    BLKBUFF           SET UP BUFFER ADDR
         LW,R2    ANSBLK+2          GET BLOCKING TYPE
         CI,R2    3                 1,2,OR 3 IS BLOCKING
         BAZ      *SR4
         LH,R1    RECOVH,R2         GET COUNT SIZE
         BNEZ     BLK1
         LW,R1    M:EO+18           FIXED, SET RECORD SIZE
         SLS,R1   -17
         STW,R1   WRTFPT+5,R7
         B        %+2
BLK1     AW,R1    WRTFPT+5,R7
         AW,R1    BLKBUFF           ADD CORRENT DISPLACEMENT
         CW,R1    ANSBLK            WILL THE NEW ONE FIT
         BLE      BLK10             YES
         LW,R1    BLKBUFF           NO, SET SIZE II BUFFER
         CH,R1    BLKOVH,R2         IS IT FIRST IN BLOCK
         BE       BLK09             YES, TRUNCATE IT
         LW,R3    ANSBLK+1          BUFFERR ADDR
         SLS,R3   2
         BAL,R4   VCVT-1,R2
         LW,R4    ANSBLK+1
         LW,R1    BLKBUFF           RESTORE SIZE
         XW,R1    WRTFPT+5,R7
         XW,R3    WRTFPT+7,R7
         XW,R4    WRTFPT+4,R7
         CAL1,1   WRTFPT,R7
         STW,R4   WRTFPT+4,R7
         STW,R3   WRTFPT+7,R7
         STW,R1   WRTFPT+5,R7
         LB,R3    ANSBLK            IF ANSBLK IS NON-ZERO, RETURN
         BNEZ     *SR4              AFTER LAST BLOCK
         LH,R1    BLKOVH,R2         START PAST FIRST COUNT
         STW,R1   BLKBUFF           RESET DISPLACEMENT
         B        BLKTEST
BLK09    LW,R1    ANSBLK            USE MAX LENGTH RECORD FOR TOO BIG ONES
BLK10    SW,R1    BLKBUFF           RESTORE RECORD SIZE
         AWM,R1   BLKBUFF           AND UPDATE IT
         BAL,R4   VCVT,R2           ENTER IN BLOCK IF V,D
         SH,R1    RECOVH,R2         ADJUST SIZE
         AH,R3    RECOVH,R2         AND ADDRESS
         LW,R2    WRTFPT+7,R7       BA(RECORD)
         AI,R1    -256              MOVE TO BLOCK
         BLZ      %+5
         MTB,-4   3
         MBS,R2   0                 MOVE 252 AT A TIME
         AI,R1    -252
         BGEZ     %-3
         STB,R1   R3
         MBS,R2   0
         B        WRITEX            GO TO NEXT INPUT RECORD
BLKOVH   DATA     0,4
RECOVH   DATA     0,X'40004'
VCVT     B        0,4               IF BLKSIZE, NOTHING FOR F,D
         B        0,R4              FIXED, NOTHING TO DO
         NOP
         LCI      4
         PSM,R1   *R7               SAVE A FEW REGS
         XW,R1    R3
         AI,R2    -1
         BDR,R2   VCVTB             WANTS TO BE BINARY
         LI,R4    4                 DECIMAL, FOUR DIGITS
         DW,R2    VCVTD,R4
         AI,R3    '0'
         STB,R3   0,R1
         AI,R1    1
         SLD,R2   -32
         BDR,R4   %-5
VCVTX    LCI      4
         PLM,R1   *R7
         B        0,R4              FOR RECORD MOVE
VCVTD    EQU      %-1
         DATA     1,10,100,1000
VCVTB    SCS,R3   -8
         STB,R3   0,R1
         SCS,R3   8
         AI,R1    1
         STB,R3   0,R1
         B        VCVTX
         PAGE
*UNBLOCK ANS INPUT
UNBLK    LI,R1    X'70'
         LS,R1    M:EI+5            GET FORMAT CODE
         SLS,R1   -4
         B        UNBTAB,R1
UNBTAB   B        UNBF              F FORMAT
         B        UNBF              F FORMAT
         B        UNBD              D FORMAT
         B        UNBV              V FORMAT
         B        *SR4              U FORMAT - NO UNBLOCKING
*
UNBF     LW,R3    M:EI+18
         SLS,R3   -17               GET LRCSZ FROM DCB
         STW,R3   WRTFPT+5,R7       PUT IN WRITE FPT
         LW,R1    UNBADR            GET CURRENT DISPLACEMENT
         ANLZ,R1  IMEI              COMPUTE BYTE ADDRESS
UNBF1    STW,R1   WRTFPT+7,R7       IS BTD
         SLS,R1   -2
         STW,R1   WRTFPT+4,R7       WORD ADDR
UNBF2    AW,R3    UNBADR
         CW,R3    BLKSIZE           COMPARE DISP WITH BLK SIZE
         BL       %+2               NOT THRU UNBLOCKING
         LI,R3    0                 INDICATE END OF BLOCK
         STW,R3   UNBADR            UPDATE FOR NEXT WRITE
         LW,R1    WRTFPT+5,R7       IF ITS A SHORT RECORD,
         CI,R1    255
         BG       *SR4              MOVE IT TO A WORD BOUNDARY
         LI,R2    IOBUF
         AW,R2    R7
         STW,R2   WRTFPT+4,R7
         LW,R3    WRTFPT+4,R7
         SLD,R2   2
         XW,R2    WRTFPT+7,R7
         STB,R1   R3
         MBS,R2   0
         B        *SR4
*
UNBD     LW,R1    UNBADR            ARE WE AT BEG OF BLOCK
         BNEZ     UNBD2             NO
         LW,R1    RDFPT+4,R7
         SW,R1    R7
         SLS,R1   2                 BYTE DISP OF BLK HEADER
         LI,R2    4                 SIZE
         PSW,SR4  *R7
         BAL,SR4  BCD2BIN           CONVERT BLK SIZE TO BINARY
         PLW,SR4  *R7
         CW,R3    BLKSIZE
         BNE      UNBD3             MUST BE RECORDD SIZE
         LI,R1    4                 FIRST DISP
         STW,R1   UNBADR
UNBD2    ANLZ,R1  IMEI
         SCS,R1   -2
         SW,R1    R7                COMPUTE R7 DISP
         SCS,R1   2
         LI,R2    4                 SIZE
         PSW,SR4  *R7
         BAL,SR4  BCD2BIN           CONVERT REC SIZE TO BINARY
         PLW,SR4  *R7
         ANLZ,R1  IR7               COMPUTE RECORD ADDRESS
UNBD3    STW,R3   WRTFPT+5,R7       PUT SIZE IN WRITE FPT
         MTW,-4   WRTFPT+5,R7       ADJUST FOR COUNT
         B        UNBF1
*
UNBV     LW,R1    UNBADR            ARE WE AT BEG OF BLOCK
         BNEZ     UNBV2             NO
         LH,R2    *M:EI+2           GET BLOCKSIZE ROM BLOCK
         CW,R2    BLKSIZE
         BNE      UNBV2             NO HEADER HERE
         LI,R1    4                 DISP TO FIRST RECORD
         STW,R1   UNBADR
UNBV2    LB,R3    *M:EI+2,R1        HIGH ORDER BYTE OF COUNT
         AI,R1    1
IMEI     LB,R2    *M:EI+2,R1
         STB,R2   R3
         SCS,R3   8
         AI,R1    3                 INCREMENT TO DATA
         ANLZ,R1  IMEI
         B        UNBD3
IR7      MTB,0    *R7,R1            FOR ANLZING AFTER BCD2BIN
         PAGE
NCCHK    LW,R5    TOARG+9,R7
         CW,R5    =X'00100000'      CR SPECIFIED
         BANZ     *SR4              YES-EXIT
         LW,R1    DEVICE,R7
         CI,R1    8                 INPUT FROM TERMINAL
         BE       NCC4              YES
         CI,R5    X'20000'          NC OPTION PRESENT
         BAZ      *SR4              NO-EXIT
NCC4     LW,R5    WRTFPT+4,R7       GET LOCATION OF OUTPUT BUFFER
NCCHKX   AI,R3    0                 NULL RECORD
         BEZ      *SR4              YES
         AI,R3    -1
         LB,R1    *R5,R3            GET LAST BYTE OF RECORD
         CI,R1    X'15'             TEST IF CARRIAGE RETURN
         BE       NCC2              YES
         CI,R1    X'0D'
         BNE      NCC1
NCC2     LI,R1    ' '
         STB,R1   *R5,R3            STORE BLANK OVER CR
         MTW,-1   WRTFPT+5,R7       SCRUB LAST CHARACTER
NCC1     AI,R3    1                 RESTORE RECORD SIZE
         B        *SR4              EXIT
*
NCS      LW,R1    WRTFPT+5,R7       RECORD SIZE
         LW,R2    WRTFPT+4,R7       ADDR OF OUTPUT RECORD
         CI,R1    80                IS RECORD BCD
         BLE      NCS1              YES
         STW,R0   27,R2             ZERO BINARY SEQUENCE FIELD
         STW,R0   28,R2
         STW,R0   29,R2
         B        WRITE2
NCS1     LW,R1    ='    '           BLANK OUT SEQUENCE FIELD
         STW,R1   18,R2
         STW,R1   19,R2
         B        WRITE2
*
CS       BAL,SR4  SEQOUT            CONSTRUCT SEQUENCE INFO
         LW,R1    WRTFPT+5,R7
         BNEZ     CS%1
         LW,R2    WRTFPT+7,R7
         LW,R1    X'40'        ADJUSTMENT FOR ZERO LENGTH RECORD.
         STB,R1   0,R2
         B        CS2
CS%1     EQU      %
         CI,R3    0                 IS IT BIN OR BCD
         BEZ      CS2               BCD
         BAL,SR4  SEQOUTB           SEQUENCE BINARY
         B        WRITE2            GO TO WRITE
CS2      LW,R1    CARDSEQ,R7        PUT SEQUENCE INFO IN OUTPUT BUFFER
         LW,R2    WRTFPT+4,R7
         STW,R1   18,R2
         LW,R1    CARDSEQ+1,R7
         STW,R1   19,R2
         LI,R2    80                SIZE OF BCD RECORD
         STW,R2   WRTFPT+5,R7
         B        WRITE2
*
LN       BAL,SR4  LINENUM           CONSTRUCT WRITE KEY
         BCS,8    WRITE2            GO TO WRITE
         B        RETURN            ERROR
*
SEQID    EQU      %-1
         B        NCS               NCS
         B        WRITE2            NLN
         B        CS                CS
         B        LN                LN
         PAGE
BRCHK    MTW,0    BREAK             TEST FOR BREAK
         BEZ      *SR4              NOT SET
         LW,R1    TOARG,R7          IF OUTPUT TO ME,
         CI,R1    8                 BREAK OUT OF FILE
         BE       %+5               EVEN IF MULTIFILE COPY
         MTW,0    COPYSK
         BNEZ     *SR4              COPYALL
         MTW,0    COPYSTDF,R7
         BNEZ     *SR4              COPYSTD
         PSW,SR4  *R7
         LI,SR4   20                LENGTH OF MESSAGE
         CAL1,1   WRTMSG            WRITE 'ENTER X...'
         BAL,SR4  READONE
         MTB,0    DELETEF           ARE WE AT LEFT SIDE OF PLATEN
         BEZ      %+3               YES
         LI,SR4   1                 NO, WRITE A CR/LF
         CAL1,1   WRTMSG
         PLW,SR4  *R7
         MTW,-1   BREAK
         CI,R1    'X'
         BNE      *SR4              CONTINUE
         MTW,1    GRANCNT           SET ABORT FLAG
         B        RETURN            ABORT COPY
*
WRTMSG   GEN,8,24 X'11',M:UC
         DATA     X'34000000'
         DATA     BRKMSG
         PZE      *SR4              SIZE IN 11
         DATA     0
BRKMSG   GEN,8,24 X'15','--E'
         TEXT     'NTER X TO ABORT'
         PAGE
SETBINBCD GEN,8,24 X'22',M:EO
BINVAL   DATA     X'003C1C38',X'18000000'    STANDARD BINARY CODES
         PAGE
DECOMP0  LCI      7                 ENTRY FROM NEW CI RECORD
         PSM,R5   *R7
         LW,SR3   WRTFPT+4,R7       BUFFER ADDRESS
         SW,SR3   R7                AS DISPLACEMENT
         LW,R6    WRTFPT+5,R7       CHECK SIZE
         CI,R6    80
         BLE      %+3               ERROR
         CI,R6    120
         BLE      RC212             OK
         LI,R6    -1                SET CISEQ RIGHT FLAG
RC290    LI,R1    42
         BAL,SR4  ERROR
         MTW,0    SUPERR
         BNEZ     RC220             IGNORE IT
         LW,R1    *SR3,R7           PUT OUT FIRST WORD THRU LO
         BAL,SR4  HEX2BCD
         LCI      2
         STM,R2   PRTBUF+5,R7
         LW,R1    CISEQ,R7          AND EXPECTED SEQ#
         CI,R6    X'E0000'          IF 6 IS A BYTE ADDRESS
         BANZ     %+2               CISEQ IS RIGHT
         MTB,-1   R1                OTHERWISE, IT'S BEEN BUMPED
         BAL,SR4  HEX2BCD
         AI,R2    ' I'-'00'
         LW,R1    RC291
         LCI      3
         LM,R3    RC291+1
         LCI      5
         STM,R1   PRTBUF,R7
         ANLZ,R1  %-1
         CAL1,1   RC292
         LCI      7
         PLM,R5   *R7
         B        RETURN
RC291    TEXT     'SEQ D/SEQ/CKSUM='
RC292    GEN,8,24 17,M:LO
         DATA     X'34000010'
         PZE      *R1
         DATA     28,0
RC212    LW,R6    R7
         SLS,R6   2
         LB,R3    *SR3,R6           CHECK ID
         AND,R3   L(X'1F')
         CI,R3    X'18'
         BNE      RC290
         LB,R4    CISEQ,R6
         MTB,1    CISEQ,R6          CHECK SEQ
         LI,R3    1
         LW,R6    SR3               RECORD ADDRESS
         AW,R6    R7
         CB,R4    *R6,R3
         BNE      RC290
*
         LI,R3    2                 COMPUTE CHECKSUM
         LB,R5    *R6,R3            ORIGINAL TO R5
         LI,R4    0
         STB,R4   *R6,R3            ZERO BYTE IN RECORD
         LI,R3    3
         LB,R4    *R6,R3            GET BYTE COUNT IN R4
         AI,R4    -1                DECREMENT
         LB,R2    *R6               START SUM IN R2
         LB,R3    *R6,R4
         AW,R2    R3                ADD EACH BYTE
         BDR,R4   %-2               ITERATE
         AND,R2   L(X'FF')
         CW,R5    R2                CHECK ORIGINAL AGAINST NEW
         BNE      RC290
*
RC220    LI,R4    X'FF'             SET UP BIT COUNT FOR THIS
         AND,R4   *SR3,R7           RECORD
         SLS,R4   3
         STW,R4   CIBTOTAL,R7
         LI,R4    32                INITIALIZE CONTROL WORDS
         LI,SR2   32
         LW,SR4   WRTFPT+4,R7       SET CIWORD
         AI,SR4   1
         XW,SR4   CIWORD,R7
         LB,R6    SR4
         LI,D4    PRTBUF            INIT OUT BUFFER ADDR
         AW,D4    R7
         LW,R1    CIBLEFT,R7        GET OUTPUT BYTE#
         AI,SR4   0                 ARE WE STARTED YET
         BNEZ     DEC60             IN MIDDLE OF OUTPUT
         B        DEC05
         PAGE
* SUBROUTINE DECOMPR RECONSTRUCTS A SYMBOLIC RECORD FROM COMPRESSED
* INPUT.
DECOMPR  LCI      7
         PSM,R5   *R7
         LW,SR2   CIBUSED,R7        INITIALIZE INPUT CONTROL WORDS
         LW,R4    CIBLEFT,R7
DEC05    LI,R1    0                 START IN BYTE ZERO
         LI,D4    PRTBUF-1
         AW,D4    R7
         LI,R2    35
         LW,R3    ='    '           BLANK OUTPUT BUFFER
         STW,R3   *D4,R2
         BDR,R2   %-1
         AI,D4    1
DEC10    LI,R6    6                 GET 6 BIT BYTE
         BAL,SR4  DEC60
         CI,R2    6                 IF CONTROL BYTE (0-6)
         BLE      DEC20,R2          EXECUTE JUMP TABLE
         CI,R2    44                IF NOT CONTROL, EXTRACT 8-BIT
         BL       DEC15             EBCDIC CODE FROM APPROPRIATE
         AI,R2    -43               TABLE.
         LB,R5    SCCTAB,R2
         B        %+2
DEC15    LB,R5    CITAB,R2
         STB,R5   *D4,R1            PUT CODE IN OUTPUT BUFFER
         AI,R1    1                 ITERATE
*                                   ** CONTROL BYTE TABLE **
DEC20    B        DEC10             PADDING
         B        DEC10             UNASSIGNED
         B        DEC30             EOL
         B        DEC35             EOF
         B        DEC40             NEXT 8 BIT
         B        DEC45             NEXT COUNT+1
         B        DEC50             NEXT COUNT +65
*
DEC30    STW,SR2  CIBUSED,R7        RESTORE CONTROL WORDS
         STW,R4   CIBLEFT,R7
         LCI      7
         PLM,R5   *R7
         STW,R1   WRTFPT+5,R7       SET SIZE
         STW,D4   WRTFPT+4,R7
         SLS,D4   2
         STW,D4   WRTFPT+7,R7
         B        READ28
*
DEC35    STW,SR2  CIBUSED,R7        RESTORE CONTROL WORDS
         STW,R4   CIBLEFT,R7
         LCI      7
         PLM,R5   *R7
         LI,R3    5                 SIMULATE EOD
         B        EOD1
*
DEC40    LI,R6    8                 GET 8 BIT CODE FROM IOBUF
         BAL,SR4  DEC60
         STB,R2   *D4,R1            PUT IN OUTPUT BUFFER
         AI,R1    1
         B        DEC10             ITERATE
*
DEC45    LI,R6    6                 USE 6 BIT COUNT
         BAL,SR4  DEC60
         AI,R2    1                 +1
DEC47    LI,R5    ' '
         STB,R5   *D4,R1            EXPAND BLANK FIELD IN BUFFER
         AI,R1    1
         BDR,R2   %-2
         B        DEC10             ITERATE
*
DEC50    LI,R6    6                 USE 6 BIT COUNT
         BAL,SR4  DEC60
         AI,R2    65                +65
         B        DEC47
*
DEC60    AW,SR2   R6                EXTRACT (R6) BITS
         CW,SR2   CIBTOTAL,R7       ENOUGH LEFT IN CURRENT RECORD
         BLE      DEC65             YES
         STW,R1   CIBLEFT,R7        SAVE OUTPUT POINTER
         STB,R6   SR4               AND CURRENT CALL
         STW,SR4  CIWORD,R7
         LCI      7
         PLM,R5   *R7
         B        READN             GET NEXT INPUT RECORD
*
DEC65    LI,R2    0                 INITIALIZE RESULT REGISTER
         LW,R5    CIWORD,R7         GET BUFFER POINTER
         LW,R3    0,R5              PICK UP CURRENT WORD
         SW,R4    R6                CHECK IF R3 CONTAINS TOTAL BYTE
         BGEZ     DEC67             BR IF YES
         AW,R6    R4                COMPUTE NO. OF BITS IN R3
         SLD,R2   0,R6              AND SHIFT TO R2
         AI,R5    1
         STW,R5   CIWORD,R7         INCREMENT BUFFER POINTER
         LW,R3    0,R5              GET WORD FROM BUFFER
         LCW,R4   R4                GET NO. BITS NEEDED FROM R3
         SLD,R2   0,R4              SHIFT INTO R2
         AI,R4    -32               COMPUTE BITS LEFT IN CURRENT WORD
         LCW,R4   R4
         B        DEC70
DEC67    SLD,R2   0,R6              SHIFT TOTAL BYTE TO R2
DEC70    STW,R3   0,R5              PUT CURRENT WORD BACK
         B        *SR4              EXIT
*
         PAGE
* SUBROUTINE COMPRESS PRODUCES A COMPRESSED OUTPUT RECORD AND WRITES IT.
COMPLAST LI,SR4   EOF8+X'80000'     SET LAST FLAG
COMPRESS LI,R1    3                 ARE WE COMPRESSING AT ALL
         CW,R1    TOARG+5,R7
         BNE      *SR4              NO
         LCI      7
         PSM,R5   *R7
         LI,SR1   0                 SET BLANK COUNT ZERO
         LW,SR2   COBUSED,R7        PICK UP CONTROL WORDS
         LW,R4    COBLEFT,R7
         LW,R1    WRTFPT+5,R7       SIZE OF RECORD
         STW,R1   RECSIZE,R7        SAVED
         LW,D4    WRTFPT+4,R7       ADDR
         LI,R1    3                 BTD
         AND,R1   WRTFPT+7,R7
         AWM,R1   RECSIZE,R7
         LW,R5    COWORD,R7         ARE WE INITIALIZED
         BNEZ     CMP10             YES
         STW,D4   COBUSED,R7        NO, GO DO IT
         STW,R1   COBLEFT,R7
         LI,R1    -1
CMPBI7   STW,R1   PRNTBUF,R7        (SET SEQUENCE TO FF)
         B        COMPNXT0
CMP10    MTB,0    SR4               IS THIS THE LAST
         BEZ      CMP11             NO
         LW,R1    =X'20000000'      CHANGE ID TO 18 FROM 38
         STS,R0   PRNTBUF,R7
         LI,R5    CEOF              EDIT EOF CONTROL BYTE
         LI,R6    6                 IN 6 BITS
         BAL,SR4  CMP60
         LI,R6    0                 SPECIAL CODE
         LI,R5    X'F0'
         B        WRITECO
CMP5     STW,R4   COBLEFT,R7        RESTORE CONTROL WORDS
         STW,SR2  COBUSED,R7
         LCI      7
         PLM,R5   *R7
         B        WRITEX
*
CMP11    LB,R5    *D4,R1            GET NEXT BYTE
         CI,R5    X'C0'             CHECK FOR A-Z,0-9
         BLE      CMP15             CANT BE IF LESS THAN X'C0'
         AND,R5   =X'3F'
         LB,R5    COTAB,R5          GET 6 BIT COMPRESSED CODE
         BNEZ     CMP12
         LB,R5    *D4,R1            ZERO, USE ORIGINAL 8 BITS
         B        CMP17
*
CMP12    LI,R6    6                 SET BIT COUNT
         BAL,SR4  CMP60             ENTER IN OUTPUT BUFFER
CMP13    AI,R1    1                 POSITION TO NEXT BYTE
         CW,R1    RECSIZE,R7        STOP AT END OF RECORD
         BL       CMP11
         LW,R5    TOARG+6,R7        IF NB, DONT EXPAND RECORD
         CW,R5    =X'00FF0000'
         BANZ     CMP14
         CI,R1    80
         BGEZ     CMP14             OUTPUT NOT LESS THAN 80 BYTES
         AI,SR1   80                PAD TO 80 BYTES
         SW,SR1   R1
         LI,R1    80
CMP14    LI,R5    CEOL              ADD EOL TO RECORD
         LI,R6    6
         BAL,SR4  CMP60
         B        CMP5
*
CMP15    LB,R6    SCCTAB            NOT A-Z,0-9
         CB,R5    SCCTAB,R6
         BE       CMP20             CHECK SPECIAL 6 BIT CODES
         BDR,R6   %-2
         CI,R5    ' '
         BE       CMP25             BLANK
CMP17    STW,R5   ATTRB,R7          8-BIT CHAR MUST BE OUTPUT
         LI,R5    CNEXT8
         LI,R6    6
         BAL,SR4  CMP60             OUTPUT 6 BIT CONTROL CHARACTER
         LW,R5    ATTRB,R7
         LI,R6    8
         BAL,SR4  CMP60             OUTPUT 8 BIT CHARACTER
         B        CMP13             ITERATE
*
CMP20    AI,R6    43                FOUND IN SCCTAB
         LW,R5    R6                CODE IS INDEX+43
         B        CMP12
CMP25    AI,SR1   1                 ACCUMULATE BLANK
         B        CMP13
*
*
CMP60    RES
         AI,SR1   0                 IS BLANK COUNT ZERO
         BEZ      CMP70             YES
         LI,R5    CBLANK
         LI,R6    6                 ENTER BLANK IN 6 BITS
         AI,SR1   -1
         BEZ      CMP68             ONLY ONE BLANK
         LI,R5    CNBC1
         CI,SR1   63
         BLE      CMP67             <=64 BLANKS, ENTER COUNT+1
         LI,R5    CNBC65            ENTER COUNT+65
         AI,SR1   -64               ADJUST COUNT
CMP67    BAL,SR4  CMP70             OUTPUT CONTROL BYTE
         LW,R5    SR1               GET COUNT
CMP68    BAL,SR4  CMP70             OUTPUT COUNT
         LI,SR1   0                 SET NO. OF BLANKS TO ZERO
         B        CMP13+1           REDO ORIGINAL BYTE
*
*
CMP70    LW,R2    R5                POSITION BYTE IN EVEN REGISTER
         AW,SR2   R6                INCREMENT TOTAL BIT COUNT
         CI,SR2   COBTOTAL
         BG       WRITECO           WONT FIT, WRITE THIS ONE
CMP73    LW,R5    COWORD,R7         GET BUFFER POINTER
         SW,R4    R6
         BGEZ     CMP75             BYTE WILL FIT IN CURRENT CO WORD
         LI,R3    0
         SLD,R2   0,R4              ADJUST NUMBER OF BITS WHICH WILL FIT
         AWM,R2   0,R5              ENTER IN CO WORD
         MTW,1    COWORD,R7
         AWM,R3   1,R5              PUT OVERFLOW BITS IN NEXT WORD
         AI,R4    32                NUMBER OF BITS LEFT IN CO WORD
         B        *SR4              EXIT
CMP75    SLS,R2   0,R4              POSITION BYTE
         AWM,R2   0,R5              ENTER IN CO WORD
         B        *SR4              EXIT
         PAGE
*        STRIP TRAILING BLANKZ IF NB REQUESTED
NBCHK    LW,R2    TOARG+6,R7
         CW,R2    =X'00FF0000'
         BAZ      *SR4
         LW,R2    WRTFPT+7,R7       BA(RECORD)
         AW,R2    WRTFPT+5,R7       END OF RECORD
         LI,R3    ' '
         AI,R2    -1
         CB,R3    0,R2
         BE       %-2
         SW,R2    WRTFPT+7,R7       RESTORE SIZE
         AI,R2    1
         STW,R2   WRTFPT+5,R7
         B        *SR4
         PAGE
* SUBROUTINE WRITECO APPENDS CONTROL INFO. TO BUFFER AND WRITES
* COMPRESSED RECORD.
WRITECO  RES
         SW,SR2   R6                RESTORE ORIGINAL BYTE COUNT
         AI,SR2   7                 COMPUTE NO. OF BYTES
         SLS,SR2  -3                FROM BIT COUNT
         STS,SR2  PRNTBUF,R7        SET BYTE COUNT
         ANLZ,D3  CMPBI7            ADDRESS OV BUFFER
         SLS,R6   1
         STB,R6   R5                SAVE CMP70 INPUT
         SCS,R5   -8
         OR,SR4   R5
         STW,SR4  COWORD,R7
         STW,R1   COBLEFT,R7
         STB,SR1  D4                SAVE BLANK COUNT
         STW,D4   COBUSED,R7
         LB,R5    *D3
         LW,R2    SR2
         AI,R2    -1
         LB,R6    *D3,R2            GET ALL BYTES
         AW,R5    R6                FORM CHECKSUM
         BDR,R2   %-2
         LI,R6    2
         STB,R5   *D3,R6            PUT IN BUFFER
         LI,R1    108
         STW,R1   WRTFPT+5,R7       SET OUTPUT RECORD
         STW,D3   WRTFPT+4,R7       DESRIPTION
         STW,R0   WRTFPT+7,R7
         LCI      7
         PLM,R5   *R7
         B        WRITE0
*
COMPNXT  LCI      7
         PSM,R5   *R7
COMPNXT0 ANLZ,SR4 CMPBI7
         MTH,1    *SR4              INCR SEQUENCE
         LI,R4    X'38'
         STB,R4   *SR4
         STH,R0   *SR4,R4
         BDR,R4   %-1               CLEAR BUFFER
         LI,R4    32
         LI,SR2   32
         LW,D4    COBUSED,R7
         AI,SR4   1                 FIRST OUTPUT BIT ADDR
         LW,R1    COBLEFT,R7
         XW,SR4   COWORD,R7
         BEZ      CMP11             FIRST TIME IN
         LW,R6    SR4               NO, GET COUNT AND BYTE
         LB,R5    R6
         STB,R0   R6
         SLS,R6   -17
         LB,SR1   D4
         B        CMP70
         PAGE
SCCTAB   TEXTC    '.<(+|&%*);~-/,%ž>:''='    SPECIAL 6-BIT CHARACTERS
CITAB    EQU      %-1
         TEXT     '    0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'
COTAB    DATA,1   0,18,19,20,21,22,23,24,25,26,0,0,0,0,0,0,;
                  0,27,28,29,30,31,32,33,34,35,0,0,0,0,0,0,;
                   0,0,36,37,38,39,40,41,42,43,0,0,0,0,0,0,;
                   8,9,10,11,12,13,14,15,16,17,0,0,0,0,0,0
         PAGE
* SUBROUTINE LINENUM CONSTRUCTS A WRITE KEY FROM THE CURRENT
* LINE NUMBER.
LINENUM  LW,R1    TOARG+12,R7
         CW,R1    TOARG+14,R7
         BG       LINE20            GR THAN MAX
         OR,R1    =X'03000000'      CONSTRUCT KEY
         STW,R1   KEY,R7
         LW,R1    TOARG+13,R7       INCREMENT FOR NEXT KEY
         AWM,R1   TOARG+12,R7
         LCI      8
         B        *SR4              EXIT
LINE20   PSW,SR4  *R7
         LI,R1    46
         BAL,SR4  ERROR
         PLW,SR4  *R7
         LCI      0                 ERROR FLAG
         B        *SR4
         PAGE
* SUBROUTINE TABEXP EXPANDS EMBEDDED TAB CHARACTERS IN A RECORD
* WHENEVER THE OUTPUT OPTION TX IS SPECIFIED. R1 CONTAINS BUFFER
* DISPLACEMENT RELATIVE TO R7.
TABEXP   LCI      7
         PSM,R5   *R7
         AW,R1    R7                COMPUTE ACTUAL BUFFER ADDRESS
         LI,R5    0                 START AT FIRST TAB
         LI,R6    0                 START AT FIRST CHAR IN BUFFER
         LW,SR1   TABSET+4,R7       GET TAB TABLE ADDRESS
         LI,R2    X'05'
         LI,SR2   ' '
         MTW,-1   WRTFPT+5,R7       DISPLACEMENT OF LAST CHAR IN RECORD
         BLZ      TAB8              NULL RECORD
TAB5     CB,R2    *R1,R6            TEST FOR TAB CHARACTER
         BE       TAB10
TAB6     AI,R6    1                 POSITION TO NEXT CHAR IN BUFFER
         CW,R6    WRTFPT+5,R7
         BLE      TAB5
TAB8     MTW,1    WRTFPT+5,R7       SET TRUE RECORD SIZE
         LCI      7                 END OF BUFFER - EXIT
         PLM,R5   *R7
         B        *SR4
*
TAB10    STB,SR2  *R1,R6            STORE BLANK OVER TAB CHAR
         AI,SR1   0                 WERE TABS SPECIFIED
         BEZ      TAB6              NO
TAB12    LB,R3    *SR1,R5           GET TAB VALUE
         BNEZ     TAB15
TAB13    LI,SR1   0                 NO MORE VALUES
         B        TAB6
TAB15    AI,R3    -1                IS THIS TAB POSITION GREATER THAN
         CW,R3    R6                POSITION OF TAB CODE
         BG       TAB17
         AI,R5    1                 NO - TRY NEXT TAB POSITION
         CI,R5    16
         BL       TAB12
         B        TAB13             MAX NUM OF TABS
TAB17    AI,R6    1                 INCREMENT TO NEXT CHAR IN BUFFER
         LW,R4    WRTFPT+5,R7       DETERMINE LAST CHAR POSITION
         SW,R3    R6                COMPUTE NUMBER OF BLANKS TO INSERT
         BEZ      TAB5              NONE
         AW,R3    R4                INCREMENT TO NEW LAST CHAR
         STW,R3   WRTFPT+5,R7       SET NEW RECORD SIZE
TAB19    LB,SR3   *R1,R4            GET LAST CHAR OF RECORD
         STB,SR2  *R1,R4            BLANK THIS CHAR IN RECORD
         STB,SR3  *R1,R3            MOVE CHAR UP TO NEW POSITION
         AI,R3    -1
         AI,R4    -1
         CW,R4    R6                GO TO CHAR JUST ABOVE TAB BLANK
         BGE      TAB19
         LW,R6    R3                INC CHAR POSITION TO LAST MOVED
         AI,R5    1                 INC TAB TABLE POINTER
         B        TAB5              LOOK FOR MORE TABS
         PAGE
* SUBROUTINE SEQOUT CONSTRUCTS SEQUENCE INFORMATION IN LOCATION
* CARDSEQ.
SEQOUT   LCI      9
         PSM,R3   *R7
         LW,R1    TOARG+12,R7       GET SEQUENCE NUMBER
         CW,R1    TOARG+14,R7
         BLE      SEQOUT1
         LW,R1    TOARG+11,R7       NCHAR IN SEQ ID
         LW,R2    CARDSEQ,R7
         AND,R2   ANDTBL,R1
         OR,R2    ORTBL,R1
         STW,R2   CARDSEQ,R7        RESET 1ST WORD OF SEQ INFO
         LI,R1    0                 GR THAN MAX - REVERT TO 0
         STW,R1   TOARG+12,R7
SEQOUT1  BAL,SR4  BIN2BCD           CONVERT TO BCD
         OR,R3    ORTBL
         STW,R3   CARDSEQ+1,R7      ENTER LAST 4 CHARS
         AI,R4    -4
         BLEZ     SEQOUT2
         LI,R3    3                 GR THAN 4 CHARS
         LI,R5    CARDSEQ
         AW,R5    R7
         LB,R1    R2,R3             ENTER REST OF NUMBER
         STB,R1   *R5,R3
         AI,R3    -1
         BDR,R4   %-3               LOOP ON SIGNIFICANT DIGITS -4
SEQOUT2  LW,R1    TOARG+13,R7
         AWM,R1   TOARG+12,R7       INCREMENT SEQUENCE NUMBER
         LCI      9
         PLM,R3   *R7
         B        *SR4              EXIT
ANDTBL   DATA     0,X'FF000000',X'FFFF0000',X'FFFFFF00',X'FFFFFFFF'
ORTBL    DATA     X'F0F0F0F0',X'00F0F0F0',X'0000F0F0',X'000000F0',0
         PAGE
* SUBROUTINE SEQOUTB CONVERTS SEQUENCE INFO IN LOCATION CARDSEQ TO
* BINARY FORMAT AND ENTERS IT IN THE LAST 3 WORDS OF THE OUTPUT
* BUFFER.
SEQOUTB  LCI      4
         PSM,R5   *R7
         LW,R5    WRTFPT+4,R7
         AI,R5    30                POINT TO END OF RECORD
         LW,R6    WRTFPT+5,R7       CLEAR TRAILING BYTES
         AI,R6    -120
         BGEZ     %+3
         STB,R0   *R5,R6
         BIR,R6   %-1
         LI,SR1   CARDSEQ+2
         AW,SR1   R7                LOCATION OF CARDSEQ
         LI,R1    -8                8 CHARS
         LI,R3    -12               TURNS INTO 12
SEQ100   RES
         LB,R2    *SR1,R1           GET BYTE FROM CARDSEQ
         LH,R2    CCTAB,R2          GET CONVERTED VALUE
         AND,R2   =X'00000FFF'      MASK OUT FLAG BITS
         SCS,R2   -4                PREPARE FOR STORE
         CI,R1    1                 IS THIS FIRST OR SECOMD
         BAZ      SEQ101            OF PAIR
         SCS,R2   -4
         AI,R3    -1
         LB,R4    *R5,R3
         AW,R2    R4
SEQ101   STB,R2   *R5,R3
         AI,R3    1
         SCS,R2   8
         STB,R2   *R5,R3
         AI,R3    1
         BIR,R1   SEQ100
         LI,R1    120
         STW,R1   WRTFPT+5,R7       SET RECORD SIZE IN FPT
         LCI      4
         PLM,R5   *R7
         B        *SR4              EXIT
*
         PAGE
CCTAB    EQU      %
******  THE FIRST BIT IN EACH HALF WORD IS A FLAG BIT.  IF SET IT  ******
******  INDICATES A NON-PRINTABLE EBCDIC CODE NUMBER.              ******
******  THE RIGHTMOST 12 BITS ARE THE EQUIVALENT BINARY CARD CODE  ******
******  EBCDIC CODES RANGE FROM X'00' TO X'FF'                    ******
*                         ******                                        *
         DATA,2   X'8B03',X'8901',X'8881',X'8841',X'8821',X'8811'
         DATA,2   X'8809',X'8805',X'8803',X'8903',X'8883',X'8843'
         DATA,2   X'8823',X'8813',X'880B',X'8807',X'8D03',X'8501'
         DATA,2   X'8481',X'8441',X'8421',X'8411',X'8409',X'8405'
         DATA,2   X'8403',X'8503',X'8483',X'8443',X'8423',X'8413'
         DATA,2   X'840B',X'8407',X'8703',X'8301',X'8281',X'8241'
         DATA,2   X'8221',X'8211',X'8209',X'8205',X'8203',X'8303'
         DATA,2   X'8283',X'8243',X'8223',X'8213',X'820B',X'8207'
         DATA,2   X'8F03',X'8101',X'8081',X'8041',X'8021',X'8011'
         DATA,2   X'8009',X'8005',X'8003',X'8103',X'8083',X'8043'
         DATA,2   X'8023',X'8013',X'800B',X'8007',X'0000',X'8B01'
         DATA,2   X'8A81',X'8A41',X'8A21',X'8A11',X'8A09',X'8A05'
         DATA,2   X'8A03',X'8902',X'8882',X'0842',X'0822',X'0812'
         DATA,2   X'080A',X'0806',X'0800',X'8D01',X'8C81',X'8C41'
         DATA,2   X'8C21',X'8C11',X'8C09',X'8C05',X'8C03',X'8502'
         DATA,2   X'8482',X'0442',X'0422',X'0412',X'040A',X'0406'
         DATA,2   X'0400',X'0300',X'8681',X'8641',X'8621',X'8611'
         DATA,2   X'8609',X'8605',X'8603',X'8302',X'8C00',X'0242'
         DATA,2   X'0222',X'8212',X'020A',X'8206',X'8E00',X'8F01'
         DATA,2   X'8E81',X'8E41',X'8E21',X'8E11',X'8E09',X'8E05'
         DATA,2   X'8E03',X'8102',X'0082',X'0042',X'0022',X'0012'
         DATA,2   X'000A',X'8006',X'8B02',X'8B00',X'8A80',X'8A40'
         DATA,2   X'8A20',X'8A10',X'8A08',X'8A04',X'8A02',X'8A01'
         DATA,2   X'8A82',X'8A42',X'8A22',X'8A12',X'8A0A',X'8A06'
         DATA,2   X'8D02',X'8D00',X'8C80',X'8C40',X'8C20',X'8C10'
         DATA,2   X'8C08',X'8C04',X'8C02',X'8C01',X'8C82',X'8C42'
         DATA,2   X'8C22',X'8C12',X'8C0A',X'8C06',X'8702',X'8700'
         DATA,2   X'8680',X'8640',X'8620',X'8610',X'8608',X'8604'
         DATA,2   X'8602',X'8601',X'8682',X'8642',X'8622',X'8612'
         DATA,2   X'860A',X'8606',X'8F02',X'8F00',X'8E80',X'8E40'
         DATA,2   X'8E20',X'8E10',X'8E08',X'8E04',X'8E02',X'8E01'
         DATA,2   X'8E82',X'8E42',X'8E22',X'8E12',X'8E0A',X'8E06'
         DATA,2   X'8A00',X'0900',X'0880',X'0840',X'0820',X'0810'
         DATA,2   X'0808',X'0804',X'0802',X'0801',X'8A83',X'8A43'
         DATA,2   X'8A23',X'8A13',X'8A0B',X'8A07',X'8600',X'0500'
         DATA,2   X'0480',X'0440',X'0420',X'0410',X'0408',X'0404'
         DATA,2   X'0402',X'0401',X'8C83',X'8C43',X'8C23',X'8C13'
         DATA,2   X'8C0B',X'8C07',X'8282',X'8701',X'0280',X'0240'
         DATA,2   X'0220',X'0210',X'0208',X'0204',X'0202',X'0201'
         DATA,2   X'8683',X'8643',X'8623',X'8613',X'860B',X'8607'
         DATA,2   X'0200',X'0100',X'0080',X'0040',X'0020',X'0010'
         DATA,2   X'0008',X'0004',X'0002',X'0001',X'8E83',X'8E43'
         DATA,2   X'8E23',X'8E13',X'8E0B',X'8E07'
         TITLE    'H E X D U M P'
HEXDUMP  RES      0
*P*      NAME:    HEXDUMP
*P*
*P*      PURPOSE: CONVERTS AN INPUT DATA RECORD INTO A HEXADECIMAL DUMP
*P*               FORMAT AND WRITES IT.  THIS ROUTINE IS CALLED FROM THE
*P*               RDWRT ROUTINE IF THE X FORMAT CONVERSION HAS BEEN
*P*               SPECIFIED.
*P*
         LCI      11
         PSM,R5   *R7
*
         CAL1,1   FPTVFC            RESET VFC
         LI,D3    PRNTBUF
         AW,D3    R7                GET ADDRESS OF BUFFER
         CAL1,1   FPTSKIP           PRINT BLANK LINE
         LI,R1    15                PRINT KEY IF FILE
         AND,R1   M:EI              OR LABEL
         CI,R1    2
         BG       PRTREC#           NO  - PRINT REC NUMBER
         LI,R3    X'30'
         LI,R2    X'20'
         CS,R2    M:EI+5            IS FILE KEYED
         BNE      PRTREC#           NO - PRINT REC NUMBER
         LI,R1    20
         LW,R2    BLNKT             BLANK PRINT BUFFER
         STW,R2   *D3,R1
         BDR,R1   %-2
         LW,R2    KEYT
         LW,R1    M:EI+10
         BAL,SR3  UNPRINT0          ENTER KEY IN BUFFER
         B        RECSIZ            PRINT RECORD SIZE
PRTREC#  LW,R1    RECNUM,R7
         LI,R2    RECT
         LI,R6    0                 START AF FRONT OF LINE
         BAL,SR4  BIN2BCD0          CONVERT REC# TO BCD
RECSIZ   LW,R1    WRTFPT+5,R7       PRINT RECORD SIZE
         LI,R2    DASHT
         BAL,SR4  BIN2BCD0          GO-CONVERT SIZE TO EBCDIC
         LI,R2    BYTEST
         BAL,SR4  MOVTXTC
         CAL1,1   PRINT             PRINT REC NO OR KEY AND SIZE
         LW,D4    WRTFPT+5,R7       SIZE
         BEZ      RETURN3           NULL RECORD
         CAL1,1   FPTSKIP           SKIP A LINE
        LI,R1    33
         LW,R2    BLNKT             * BLANK PRNTBUF
         STW,R2   *D3,R1
         BDR,R1   %-1
         LW,SR2   %                 SET POS BDR REG FOR TERMINAL
         LW,R1    TOARG,R7
         CI,R1    8                 IS OUTPUT TO A TERMINAL
         BE       %+2               YES
         LW,SR2   *%                NEG FOR LP OR OTHER THING
         LW,R5    WRTFPT+7,R7       BYTE ADDRESS OV RECORD
         LI,SR1   0                 RESET ASTERISK FLAG
DUMP2    EQU      %
         MTW,0    BREAK             BREAK KEY HIT
         BEZ      %+4               NO
         CAL1,8   FPTWAIT           WAIT FOR SECOND BREAK
         MTW,-1   BREAK             YES-CLEAR BREAK
         B        RETURN3           RETURN
         LW,R1    R5
         SW,R1    WRTFPT+7,R7
         SLS,R1   -2                MAKE WORD DISPLACEMENTS
         BAL,SR4  HEX2BCD           CONVERT ADDRESS TO BCD
         SLD,R2   24
         OR,R3    BLNKT             GET RID OF LEADING ZEROES IN ADDRESS
         STD,R2   *D3               PUT ADDRESS INTO PRNT BUFFER
*
         LI,R4    4                 LOAD PRNTBUF POINTER
         LI,R6    92                START OF EBCD FOR LP
         BIR,SR2  %+2
         LI,R6    50
         LI,D1    4                 FOUR BYTES PER WORD
DUMP1    LB,R1    0,R5
         AI,R5    1
         PSW,R4   *R7
         BAL,SR4  HEX2BCD           GET HEX
         PLW,R4   *R7
         STH,R3   R3                SIGN EXTEND
         LH,R3    R3
         CH,R3    *D3,R4            CHECK FOR SAME AS LAST LINE
         BE       %+2
DUMP10   STH,R0   SR1               CLEAR SKIP FLAG
         STH,R3   *D3,R4
         MTH,0    CCTAB,R1          IS THIS PRINTABLE CHAR
         BGE      %+2
         LI,R1    '.'               NO, MAKE DOT
         STB,R1   *D3,R6
         AI,R6    1                 INCR BUFF PTRS
         AI,R4    1
         BDR,D1   DUMP3             HAVE WE DONE A WORD
         LI,D1    4
         AI,R4    1                 YES, SKIP 2 SPACES
         CI,R4    24                ARE WE HALF DONE
         BNE      %+3               NO
         AI,R4    1                 YES, SKIP MORE
         BDR,SR2  PRNT              AND PRINT IF TERMINAL
         CI,R4    45                MEBBE ALL DONE WITH LINE
         BGE      PRNT
DUMP3    BDR,D4   DUMP1             NO, TO NEXT BYTE
         LI,R3    '  '              NONE LEFT, BLANK REST OF BUFFER
         LI,R1    ' '
         B        DUMP10
*
PRNT     BDR,D4   %+2               COUNT BYTES
         STH,R0   SR1               AND PRINT THE LAST LINE ANYWAY
         BIR,SR1  PRNT2             STILL SKIPPING
         CI,SR1   X'FFFE'           FIRST OR NO
         BAZ      PRNT1             YES, NO *
         LI,R1    5
         LI,R2    '*'
         STB,R2   *D3,R1
PRNT1    CAL1,1   PRINT
         LI,SR1   X'F0000'          SET INITIAL FLAG VALUE
PRNT2    AI,D4    0
         BGZ      DUMP2
RETURN3  LCI      11
         PLM,R5   *R7
         LI,R0    0
         B        *SR4
*
*        MOVTXTC MOVES TEXTC AT WA(R2) TO *D3,R6 BYTES
*        AND ADJUSTS R6
MOVTXTC  LB,R3    *R2               GET COUNT
         ANLZ,R2  %-1
         AI,R2    1
         LB,SR3   0,R2
         STB,SR3  *D3,R6
         AI,R6    1
         BDR,R3   %-4
         B        *SR4
*
UNPRINT0 RES
*MOVE TEXT IN R2 + = AND NAME AT *R1 TO *D3
*        SET R6 TO NEXT CSPACE
         STW,R2   *D3
         LI,R2    '='
         AI,D3    1
         STB,R2   *D3
         BAL,SR4  UNPRINT
         LW,R6    R2
         AI,R6    5
         AI,D3    -1
         B        *SR3
*        MOVE TEXTC AT *R2 AND NUMMER IN R1
*        TO *D3,R6..PACKING NUMMER AND ADJUST R6
BIN2BCD0 RES
         PSW,SR4  *R7               SAVE RETURN
         BAL,SR4  MOVTXTC
         BAL,SR4  BIN2BCD
         LI,R1    8                 8 DIGS MAX
B2B2     SCD,R2   8
         STB,R3   *D3,R6
         CI,R3    X'B0'             NUMMER OR BLANK
         BAZ      %+2
         AI,R6    1
         BDR,R1   B2B2
         PLW,SR4  *R7
         B        *SR4
FPTVFC   GEN,8,7,17      X'05',0,M:EO
         DATA     0
PRINT    GEN,8,7,17 X'11',0,M:EO
         DATA     X'34000010'
         PZE      *D3               BUFFER ADDRESS
         PZE      *R6               LENGTH
         DATA     0                 DISPLACEMENT
KEYT     TEXT     'KEY '
BLNKT    TEXT     '    '
RECT     TEXTC    'REC # '
DASHT    TEXTC    '  -  '
BYTEST   TEXTC    ' BYTES'
FPTSKIP  GEN,8,24 17,M:EO
         DATA     X'30000010'
         DATA     BLNKT,1
FPTWAIT  GEN,8,24 15,1              WAIT FOR SECOND BREAK
         END

