         TITLE    'PCLRW - RDWRT, HEXDUMP'
*
*        T E L E F I L E   P R O P R I E T A R Y   P R O D U C T
*
*        THIS DOCUMENT INCLUDES DATA AND INFORMATION CONSIDERED
*        PROPRIETARY TO TELEFILE COMPUTER PRODUCTS, INC.  REPRODUCTION,
*        DUPLICATION, DISCLOSURE OR DISSEMINATION, IN WHOLE OR IN PART,
*        TO OTHERS THAN REPRESENTATIVES OF THE UNITED STATES GOVERNMENT
*        SHALL NOT BE MADE WITHOUT PRIOR WRITTEN AUTHORIZATION OF
*        TELEFILE COMPUTER PRODUCTS, INC. NOTWITHSTANDING THE FORGOING,
*        USE OF THE DATA OR INFORMATION IN WHOLE OR IN PART FOR DESIGN,
*        PROCUREMENT OF MANUFACTURE IS STRICTLY FORBIDDEN.
*
*M*      RDWRT    READ M:EI / WRITE M:EO
RDWRT    DSECT    1
*
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
R8       EQU      8
R9       EQU      9
R10      EQU      10
R11      EQU      11
R12      EQU      12
R13      EQU      13
R14      EQU      14
R15      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
         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*
         DEF      RDWRTX            ENTRY TO GET LAST CO RECORD
         DEF      LCCHARS
*
         REF      SUPERR            IGNORE ERRORS FLAG
         REF      HEX2BCD
         REF      INCRPT            INPUT ENCRYPTION SEED ADDRESS
         REF      OUTCRPT           OUTPUT ENCRYPTION SEED ADDRESS
         REF      M:C,M:EI,M:EO
         REF      IOABORTS
         REF      DELETEF           CARRIAGE POSITION FLAG FOR READ ONE
         REF      CMBX              TO SET % POSITION FOR ERRORS
         REF      ERROR
         REF      CLOSEO            UNUSED - KGC
         REF      BLKFIX
         REF      ARGBUFF           TEMP STORAGE
         REF      PRTNOF            EOD AFTER N
         REF      TOARG,TOSWT,RDFPT,WRTFPT,IOBUF
         REF      RECNUM
         REF      READONE
         REF      PRTBUF
         REF      CODE
         REF      CARDSEQ
         REF      BIN2BCD
         REF      TABSET
         REF      MODE
         REF      RSSAVE
         REF      LINENO            UNUSED - KGC
         REF      BREAK
         REF      COPYSTDF,J:JIT    UNUSED - KGC
         REF      SEQNUM            UNUSED - KGC
         REF      CCTAB
         REF      SELECT
         REF      M:UC,M:LO
         REF      DEVICE
         REF      COPYSK
         REF      GRANCNT
         REF      PRNTBUF,UNPRINT
         REF      BLKBUFF
         REF      OUTBLK
OUTREC   EQU      OUTBLK+1
OUTFMT   EQU      OUTBLK+2
         REF      BLKIN
         REF      MBS,BCD2BIN
         REF      UNBADR,BLKSIZE
         REF      NPAGE
         REF      BOG               UNUSED - KGC
*        COMPRESSING/DECOMPRESSING DATA
CIWORD   EQU      PRNTBUF+34
CIBUSED  EQU      PRNTBUF+35
CIBLEFT  EQU      PRNTBUF+36
CIBTOTAL EQU      PRNTBUF+37
CISEQ    EQU      PRNTBUF+38
RECSIZE  EQU      PRNTBUF+39
COWORD   EQU      PRNTBUF+40
COBUSED  EQU      PRNTBUF+41
COBLEFT  EQU      PRNTBUF+42
ERRCODE  EQU      PRNTBUF+43
INBLK    EQU      PRNTBUF+44
INREC    EQU      PRNTBUF+45
INFMT    EQU      PRNTBUF+46
OUTBUF   EQU      PRNTBUF+47
*
         LCI      7                 SAVE REGISTERS
         PSM,R5   *R7
         LCI      4
         LM,R1    IRDFPT
         STM,R1   RDFPT,R7
         LM,R1    IWRTFPT
         STM,R1   WRTFPT,R7
         INT,R1   M:EO+4            IF WE'VE BEEN HERE
         CI,R1    EOERR             DON'T CLOBBER COWORD
         BE       %+2
         STW,R0   COWORD
         STW,R0   GRANCNT
         LW,R1    DEVICE+2,R7       SET % AT INPUT
         STW,R1   CMBX,R7
         LW,R4    R7                INPUT CRPT FLAG DISP
         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
         LI,R3    X'400'            CHECK FOR CRPT OPTION
         AND,R3   MODE,R4
         BE       %+2
         LW,R3    5,R1              GET CRPT ADDR FROM FPT+1
         AI,R4    TOARG-DEVICE      OUTPUT SECOND
         CAL1,1   0,R1
         AI,R1    SETEO-SETEI+X'80000'
         BNC      OPNDCB0
         B        %+3
RDWRTX   LCI      7                 SAVE REGS
         PSM,R5   *R7
         LI,R2    BLKIN             SET UP INPUT DEBLOCKING
         LI,R3    X'70'             USE INPUT IF ANS TAPE
         AND,R3   M:EI+5
         SLS,R3   -4
         LW,R6    DEVICE,R7
         BAL,R10  BLKFIX
         LCI      3
         STM,R3   INBLK
         LI,R2    IOBUF             ADD I/O BUFFER
         AW,R2    R7
         MTW,0    INFMT             IF BLOCKING OR DEBLOCKING
         BE       READ41            ADJUST FOR MULTIPLE BUFFERS
         AI,R2    64                LEAVE A HOLE IF UNBLOCKING
         LW,R1    INBLK             INPUT MAX BLOCK SIZE
         AI,R1    0
         BNE      %+2
READ41   LI,R1    2048              DEFAULT BUFFER
         CW,R1    OUTREC            BUFFER MUST BE AT LEAST
         BGE      %+2               OUTPUT RECORD SIZE
         LW,R1    OUTREC
         MTW,0    OUTFMT            ARE WE BLOCKING
         BE       READ42            NO
         STB,R0   OUTBLK            CLEAR POSSIBLE BLKLAST FLAG
         STW,R2   OUTBUF            SAVE BUFFER ADDR FOR THE BLOCKER
         LW,R3    OUTBLK            PUT OUTPUT BUFFER BELOW INPUT
         AI,R3    3                 SO INPUT CAN EXPAND
         SLS,R3   -2
         AW,R2    R3
READ42   STW,R1   RDFPT+5,R7        INPUT BUFFER SIZE
         STW,R2   RDFPT+4,R7        AND LOC
         AI,R1    -2049             ROUND UP TO NEXT PAGE
         SAS,R1   -2                GET END OF BUFFER
         AW,R1    R2
         SW,R1    R7
         SLS,R1   -9
         CAL1,8   GETPG
         STW,R8   NPAGE,R7          SAVE # PAGES GOTTEN
         BCS,8    EOF11             CAN'T DO IT
         LW,R2    M:EI+10
         LI,R1    4
         CW,R1    TOARG+10,R7       LN OPTION SPECIFIED
         BNE      READ40            NO
         ANLZ,R2  KEYADR
READ40   STW,R2   WRTFPT+6,R7       SET KEY ADDR IN WRITE FPT
         STW,R0   UNBADR            INITIALIZE FOR UNBLOCKING
         LW,R2    OUTFMT            AND FOR BLOCKING
         STW,R0   ERRCODE           AND ERROR CODE FOR COPYALL/STD
         LH,R2    BLKOVH,R2
         STW,R2   BLKBUFF
         LW,R1    SELECT,R7
         STW,R1   RSSAVE,R7         SAVE COUNT OF REC SELECTIONS
         BNE      %+3               NO BLOCK IF NO SELECTION
         MTB,1    R1
         STS,R0   RDFPT+1,R7
         LI,R9    SELECT+1          INITIALIZE RS TABLE INDEX
READ4    STW,R0   RECNUM,R7         ZERO RECORD NUMBER COUNT
         STW,R0   CISEQ             AND DECOMPRESSING INFO
         STW,R0   CIWORD
         LW,R2    RDFPT+4,R7        SET PROBABLE RECORD ADDRESS
         STW,R2   WRTFPT+4,R7
         SLS,R2   2
         STW,R2   WRTFPT+7,R7
         LI,R1    X'20'             IF EI IS CLOSED, MUST BE RDWRTX CALL
         CH,R1    M:EI
         BAZ      RDWRTX1
*
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   MTW,0    GRANCNT           IF ABORTING C DEVICE COPY, READ
         BNE      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
         STW,R3   WRTFPT+5,R7       SET RECORD SIZE
         LW,R1    INFMT
         LH,R1    RECOVH,R1
         BE       %+3
         SW,R3    R1
         AI,R3    1
         STW,R3   BLKSIZE           SET TO SIZE OF INPUT
READ29   BAL,R11  UNBLK             OUTPUT NOT ANS - GO UNBLOCK
         LI,R3    3                 IF CI, DECOMPRESS
         CW,R3    CODE,R7
         BE       DECOMP0
READ28   LW,R3    OUTREC            IF OUT SIZE SHOULD BE FIXED,
         BE       KGC0%4
         CW,R3    WRTFPT+5,R7       FIX IT.
         BGE      %+2               BUT DONT PAD 'TIL MASSAGING IS DONE
         STW,R3   WRTFPT+5,R7
KGC0%4   LI,R3    6                 SET EOF CODE
         MTW,1    RECNUM,R7
         MTW,0    RSSAVE,R7         ANY RS OPTIONS IN EFFECT
         BE       READ2             NO
         LW,R1    R9                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   R9                LAST, SET FLAG
         B        READ2             AND WRITE
         MTW,-1   RSSAVE,R7         COUNT DOWN
         BE       EOD2              ALL DONE
         STB,R0   R9                CLEAR LAST FLAG
         AI,R9    2                 POINT INDEX TO NEXT PAIR
         CW,R2    *R9,R7            MUST FILE BE REPOSITIONED.
         BL       READ17            NO
         BE       READ2             GO WRITE RECORD
READ3    CAL1,1   PFIL              POSITION TO BOF
         B        READ4
READ17   LW,R3    *R9,R7
         AI,R3    -1                IS PRECORD NEEDED
         LI,R1    3
         CW,R1    CODE,R7           IF COMPRESSED, DECOMPRESS
         BE       WRITEX
         MTW,0    INFMT             IF BLOCKED, NO PRECORD
         BNE      WRITEX
         LI,R1    15
         AND,R1   M:EI
         CI,R1    3
         BGE      READ1             NOT DEVICES
         SW,R3    RECNUM,R7         COMPUTE NO. OF RECS TO SKIP
         BE       READ1             NONE
         LI,R2    100
READ23   CI,R3    100               IS THIS THE LAST ONE
         BG       %+2
         LW,R2    R3
         AWM,R2   RECNUM,R7
         CAL1,1   PREC2
         MTW,0    BREAK
         BNE      WRITEX
         AI,R3    -100
         BG       READ23
         B        READ1             GO READ
READ2    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,R11  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,R11  TABEXP            EXPAND TABS
READ52   BAL,R11  NBCHK             TRUNCATE BLANKS
         LW,R3    OUTREC            FIX RECORD SIZE IF FIXED
         BE       %+2
         STW,R3   WRTFPT+5,R7
         BAL,R11  COMPRESS
WRITE0   LW,R2    TOARG+6,R7        IS BIN/BCD SPECIFIED
         LB,R3    R2
         SLS,R3   3
         BNE      WRITE01           YES, (BIN=X10)GO TO SEQID'ER WITH FLAG
         LW,R2    WRTFPT+7,R7       GET FIRST BYTE OF RECORD
         LB,R2    0,R2
         LI,R3    X'4000'           SAVE FBCD STATE
         AND,R3   M:EO
         SLS,R3   -9
         AI,R3    X'10'             BIN BIT
         LI,R1    4                 CHECK STANDARD BIN VALUES
         CB,R2    BINVAL,R1
         BE       %+3
         BDR,R1   %-2
         AI,R3    -X'10'            SET BCD
         LW,R2    TOARG,R7          IF NOT CP...
         CI,R2    10
         BNE      WRITE01
         LW,R2    SETBINBCD
         CAL1,1   R2
WRITE01  LW,R1    TOARG+10,R7       TEST IF ANY SEQUENCING WANTED
         BNE      SEQID,R1          BR TO APPROPRIATE ROUTINE IF YES
WRITE2   BAL,R11  BLKTEST           TEST IF BLOCKING WANTED
         LI,R11   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
         LW,R1    TOARG+8,R7
         CW,R1    =X'00FF0000'      IS K OPTION PRESENT
         BAZ      WRITE1            NO
         LW,R5    WRTFPT+7,R7       SET BYTE ADDR FOR PRECEDERS
         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    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,R11  BIN2BCD           CONVERT TO BCD
         SLD,R2   8
         LB,R1    R2                FIRST BYTE OF VALUE
         SLS,R2   8
         OR,R2    =X'0000F04B'      EDIT NO. TO XXXX.XXX
         OR,R3    =X'F0F0F040'
         AI,R5    -9
         LI,R4    9
         STB,R4   R5
         MBS,R4   -2                MOVE IT ON
         AI,R5    -9                BACK TO START
WRITE5   LW,R1    RECNUM,R7         GET RECORD NUMBER
         BAL,R11  BIN2BCD           CONVERT TO BCD
         LW,R4    =' -  '
         LI,R1    10
         AI,R5    -1
         LB,R11   R2,R1
         STB,R11  0,R5
         BDR,R1   %-3
         XW,R5    WRTFPT+7,R7
         SW,R5    WRTFPT+7,R7
         AWM,R5   WRTFPT+5,R7
         LW,R5    WRTFPT+7,R7
         SAS,R5   -2
         STW,R5   WRTFPT+4,R7
         B        WRITE1
*
WRITE6   LD,R2    KEYX
         STD,R2   PRNTBUF
         LI,R14   PRNTBUF+1
         BAL,R11  UNPRINT           ENTER KEY IN BUFFER
         CAL1,1   PRINT1            WRITE BLANK LINE
         AI,R2    5                 LENGTH OF PRINT LINE
         AI,R14   -1                COMPUTE BUFFER ADDRESS
         CAL1,1   PRINT2            PRINT KEY
WRITE1   LW,R2    WRTFPT+5,R7       WRITE NULL RECORD
         BNE      WRITE11           ONLY IF NOT DEVICE
         LI,R2    3                 OR CONSECUTIVE FILE
         AND,R2   M:EO
         CI,R2    2
         BG       WRITE11-1
         BANZ     WRITE11
         LW,R2    M:EO+5
         CI,R2    X'20'
         BANZ     WRITE11
         MTW,1    WRTFPT+5,R7       WONT WORK, WRITE 1 BYTE
WRITE11  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
         AWM,R3   WRTFPT+7,R7       SET NEW BTD, BA(BUF)
         LW,R2    WRTFPT+7,R7       NEW WA(BUFFER)
         SLS,R2   -2
         STW,R2   WRTFPT+4,R7
         LCW,R3   R3
         AWM,R3   WRTFPT+5,R7       IS THERE MORE TO DO
         BG       WRITE1            YUP
WRITEX   CW,R10   PFIL              ARE ON LAST REC OF TAPE
         BE       IOERR1            YUP, GIVE 1C ABN NOW
         LW,R4    RDFPT+4,R7        SET OUT TO IN
         STW,R4   WRTFPT+4,R7
         SLS,R4   2
         STW,R4   WRTFPT+7,R7
         INT,R2   COWORD            IF COMPRESSING, FINISH
         BDR,R2   COMPNXT           THIS RECORD
         BCS,8    EOF8              LAST RECORD JUST DONE
         BAL,R11  BRCHK             CHECK BREAK FLAG
         LW,R2    RSSAVE,R7         IF SELECTING..
         BDR,R2   %+3               AND LAST RANGE..
         MTB,0    R9                AND LAST OF IT..
         BNE      COMPLAST          QUIT.
         MTW,0    CIWORD            IF DECOMPRESSING,
         BNE      DECOMPR           EXTRACT THE NEXT RECORD
READN    MTW,0    UNBADR            ARE WE UNBLOCKING ANS
         BNE      READ29
         B        READ0
*
EOF7     LCH,R3   M:EI+4            ADJUST RECNUM
         SAS,R3   -1
         AWM,R3   RECNUM,R7
RDABN    LB,R3    R10               GET ABNORMAL CODE
         CI,R3    6                 EOF ENCOUNTERED
         BE       EOD2              YES
         CI,R3    5                 EOD THEN
         BNE      EOF1              NO
EOD1     LI,R5    3
         CS,R5    M:EO              ONLY WRITE EODS TO DEVICES
         BNE      EOD2              NO
         LW,R1    MODE+3,R7
         CI,R1    X'FF'             TEST FOR DEOD OPTION
         BANZ     EOD2              YES
         LI,R5    6                 IS THIS HEXDUMP
         CW,R5    TOARG+5,R7
         BE       %+3               YES, WRITE MESSAGE
         CAL1,1   WEOF              NO, WRITE TAPEMARK/!EOD
         B        EOD2
         CAL1,1   FPTEOD            YES-INDICATE --EOD-- ENCOUNDED
EOD2     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
         BNE      EOF5+2            YES
         B        READ1
*
EOF1     CI,R3    7                 TEST FOR LOST DATA
         BNE      EOR
         MTW,0    OUTREC            IF TRUNCATING OUTPUT, BUF IS
         BNE      *R8               ADEQUATE
         LW,R8    NPAGE,R7          GET MORE MEMORY
         AI,R8    1
         SLS,R8   3
         PSW,R9   *R7               SAVE R9
         CAL1,8   =X'88000008'
         PLW,R9   *R7
         AWM,R8   NPAGE,R7
         CI,R8    0                 DID WE GET SOME PAGES
         BNE      EOF2              YES
         LI,R1    33                SET ERROR CODE
         B        IOERR0
EOF11    LI,R1    33                ERROR-ADDITIONAL PAGE NOT AVAILABLE
         STW,R0   CMBX,R7           NO INITIAL MEMORY
         LI,R11   ERROR1            SET RETURN
*        ERROR0 GOES TO ERROR TO REPORT AN ERROR UNLESS DOING
*        COPYALL OR COPYSTD, FORWHICH A CODE IS CREATED IN R10 (OR LEFT THERE)
ERROR0   MTW,0    COPYSK            COPYALL OR STD
         BE       ERROR             NO, REPORT NORMALLY
         AI,R1    0                 IO ERROR OR PCL ERROR
         BE       %+3               IO..CODE IN R10 ALREADY
         LW,R10   R1                PCL..CREAT CODE IN R10
         SLS,R10  24
         STW,R10  ERRCODE           SAVE CODE IN CASE OF SUPERR
         B        *R11
EOF2     LW,R2    RDFPT+5,R7        OLD BUFFER SIZE
         SLS,R8   11                CONVERT PAGES TO BYTES
         AW,R2    R8                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,R8    RDFPT+5,R7
         CI,R8    X'8000'           PERMIT ONLY X'7FFF' MAX RECORD
         BLE      EOF3
         LI,R1    38                ERROR-RECORD SIZE LARGER THAN 15 BIT
IOERR0   BAL,R11  ERROR0
         MTW,0    SUPERR            IF SUPRESSION, IGNORE
         BNE      READ14            THE PROBLEM
ERROR1   MTW,1    GRANCNT           KILL THE COPY
         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
         CAL1,1   PREC              POSITION BACK ONE RECORD
         B        READ1
EOF5     MTW,0    RSSAVE,R7         ANY RS OPTIONS
         BE       COMPLAST          NO, FINISH UP
         LW,R3    RECNUM,R7         GET NO. OF LAST REC
         AI,R9    1                 POSITION TO Y VALUE
         CW,R3    *R9,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
         MTW,0    COPYSK            IF COPYALL/STD, NO MSG
         BNE      EOF6
         PSW,R9   *R7
         LW,R9    RECNUM,R7
         SCS,R9   16
         BNE      %+2
         LI,R9    X'8000'
         LI,R5    EODMSG
         BAL,R11  PRTNOF
         PLW,R9   *R7
         LW,R3    RECNUM,R7
EOF6     MTW,-1   RSSAVE,R7         COUNT DOWN
         BE       COMPLAST          ALL DONE
         STB,R0   R9                CLEAR END FLAG
         AI,R9    1                 POSITION TO X VALUE
         CW,R3    *R9,R7            TEST IF IN FILE
         BL       EOF5              NO..ANOTHER MESSAGE
         LW,R3    DEVICE,R7         IF FT, NO PFIL
         CI,R3    6
         BNE      READ3
         B        READ4
*
EOR      CI,R3    X'1C'             TEST FOR END OF REEL
         BNE      IOERR1
         LI,R3    EOCVOL2
         BAL,R11  ULBLCHK           TEST FOR TRAILER LABEL
         LI,R1    3
         CS,R1    M:EI
         BNE      KGC1%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      *R8               NOT ENOUGH, GET THIS REC, THEN 1C
KGC1%4   CAL1,1   EICVOL            ADVANCE TO NEXT INPUT TAPE REEL
         BDR,R10  *R8               CLOBBER R10 AND CONTINUE
*
WRTABN   LB,R1    R10               GET ABNORMAL CODE
         CI,R1    X'1C'             TEST FOR END OF REEL
         BNE      EOERR
         BAL,R2   56ERRCHK          SHOULD WE CHANGE TO 56ERR
         LW,R1    TOARG,R7
         CI,R1    6                 OUTPUT TO DEVICE TAPE
         BE       %+3               YES, WRITE FILEMARKS
         AI,R8    -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        *R8               CONTINUE READING AND WRITING
*
EIERR    LB,R1    R10               TEST FOR LAST REEL
         CI,R1    X'56'
         BE       READ14            YES, DO THE LAST RECORD
         CI,R1    X'57'
         BE       READ14            END OF RANDOM FILE
         CI,R1    X'42'
         BNE      IOERR1
         LI,R15   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      *R11              NO
         MTW,0    GRANCNT           IS COPY ABORTD
         BNE      *R11              YES, GET OUT
         LI,R8    READ1             RETURN LOC TO RESUME READ
         CW,R1    TOARG,R7          ONLY TRANSFER TO SAME TAPETYPE
         BNE      *R11              NO
         MTB,0    *M:EI+2           WAS A TRAILER LABEL READ
         BE       *R11              NO
         LCI      3
         LM,R1    0,R3              MOVE FPT TO DATA AREA
         STM,R1   IOBUF+250,R7
         LW,R1    RDFPT+4,R7
         STW,R1   IOBUF+253,R7      LABEL ADDR FOR CLOSE
         BIR,R2   %+3
         STW,R1   IOBUF+252,R7      ADDR FOR CVOL
         BAL,R2   56ERRCHK          BUT DONT CVOL TO SCRATCH.
         CAL1,1   IOBUF+250,R7      DO CLOSE OR CLOSE VOLUME
         B        *R11
56ERR    GEN,8,24 X'56',M:EO
56ERRCHK LW,R1    TOARG+1,R7        CVOL TO SCRATCH IS OK IF
         BE       0,R2              IT'S ALL SCRATCH,
         CB,R1    M:EO+11           BUT NOT OTHERWISE
         BG       0,R2
         LW,R10   56ERR
         LI,R13   4                 AND ABORT THE BATCH USER
EOERR    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
         BL       READ1             IGNORE ALL BUT 05,06 READING C DEVICE
         LH,R2    IOABORTS          IS THIS A SEVERE ERROR
         LH,R15   R10
         CH,R15   IOABORTS,R2
         BNE      %+2
         LI,R13   3                 SET SEVERITY 3
         BDR,R2   %-3
RETURNE  BAL,R11  ERROR0            REPTRO ERRRO
RETURN   LW,R15   ERRCODE           SET ERRCODE OR ZERO
         LI,R3    CLOSE2
         BAL,R11  ULBLCHK           TEST FOR TRAILER LABEL
         MTW,0    GRANCNT           WAS COPY ABORTED
         BNE      %+2               YES
         CI,R13   2                 OTHER ERROR PERHAPS
         BL       RETURNX           NO, OR SECOND RETURN FROM SI DEVICE
         LW,R1    M:EO
         CW,R1    =X'00200000'      IS OUTPUT FILE OPEN
         BAZ      RETURN2           NO
         AND,R1   CLOSE2+2          MAKE SAVE BIT FROM ASN
         LI,R2    X'1FFFF'          IF NOTHING EVER WRITTEN
         AND,R2   M:EO+2            ..
         BE       %+3               RELEASE EMPTY FILE
         MTW,0    SUPERR            IF SUPRESSING, SAVE IT
         BNE      RETURN2
         CAL1,1   FPTREL            RELEASE BAD RAD FILE
         STW,R0   TOSWT,R7          OUTPUT NO LONGER DEFINED
RETURN2  CAL1,1   EIEQSI            IF EI IS SI, DONT READ REST OF FILE
         MTB,-1   GRANCNT           SET FLAG NEGATIVE
         AI,R8    0                 AS COMMANDS
         BNE      READ1
RETURNX  LW,R8    NPAGE,R7          FREE EXTRA PAGES
         BE       %+2
         CAL1,8   =X'89000008'
         STW,R0   NPAGE,R7
         LCI      7
         PLM,R5   *R7
         B        *R11
*
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     GEN,8,24 X'10',M:EI        READ REVERSE
         DATA     X'90000030',IOERR1,0 0 BYTES (PREC FAILS ON AT)
PREC2    GEN,8,24 X'1D',M:EI
         DATA     X'C0000000'
         PZE      *R2               #RECS IN R2
         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      *R14              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      *R3
         PZE      *INCRPT           INPUT ENCRYPTUIN
*
SETEO    DATA     X'06000000'+M:EO
         DATA     X'E0000000'
         DATA     EOERR             ABNORMAL ADDRESS
         DATA     EOERR             ERROR ADDRESS
         PZE      *R3
         PZE      *OUTCRPT          OUTPUT ENCRYPTION
*
EIEQSI   GEN,8,24 X'2B',M:EI
         DATA     M:C
*
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
         DATA     X'F1000018'       EXISTENCE FLAGS
         DATA     IOERR1            ERROR ADDRESS
         DATA     RDABN             ABNORMAL ADDRESS
*
IWRTFPT  DATA     X'11000000'+M:EO
         DATA     X'FC000050'       EXISTANCE FLAGS
         DATA     EOERR             ERROR ADDRESS
         DATA     WRTABN            ABNORMAL ADDRESS
FPTEOD   GEN,8,24 17,M:EO
         DATA     X'34000000'
         DATA     EODMSG,18
         DATA     0                 NO DISPLACEMENT
EODMSG   TEXT     '--EOD--ENCOUNTERED AFTER %%
'
PFIL     GEN,8,7,17      X'1C',0,M:EI
         DATA     X'10'
FPTREL   GEN,8,24 X'15',M:EO
         DATA     X'80000010'
         PZE      *R1
         PAGE
*TEST IF BLOCKING WANTED FOR ANS.  IF SO, ADD RECORD TO OUTPUT BLOCK.
EOF8     LI,R11   RETURN            LAST EXIT
         MTB,-1   OUTBLK            FORCE RECORD TO OVERFLOW
BLKTEST  EQU      %
         LW,R3    OUTBUF
         SLS,R3   2
         LW,R2    OUTFMT            GET BLOCKING TYPE
         BE       *R11              NONE
         LH,R1    RECOVH,R2         GET COUNT SIZE
         AW,R1    WRTFPT+5,R7
         AW,R1    BLKBUFF           ADD CURRENT DISPLACEMENT
         CW,R1    OUTBLK            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
         BAL,R4   VCVT-1,R2
         LW,R4    OUTBUF
         LW,R5    BLKBUFF
         XW,R5    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,R5   WRTFPT+5,R7
         LB,R3    OUTBLK            IF FOMR BLKLAST, RETURN
         BNE      *R11              AFTER LAST BLOCK
         LH,R1    BLKOVH,R2         START PAST FIRST COUNT
         STW,R1   BLKBUFF           RESET DISPLACEMENT
         B        BLKTEST
BLK09    LW,R1    OUTBLK            TRUNCATE RECORDS THAT WON'T FIT
         BL       *R11              BLKLAST WITH NOTHING TO DO
BLK10    SW,R1    BLKBUFF           RESTORE RECORD SIZE
         AW,R3    BLKBUFF           GET BUFFER POINTER
         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
         BL       KGC%5
         MTB,-4   3
         MBS,R2   0                 MOVE 252 AT A TIME
         AI,R1    -252
         BGE      %-3
KGC%5    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
KGCA%5   DW,R2    VCVTD,R4
         AI,R3    '0'
         STB,R3   0,R1
         AI,R1    1
         SLD,R2   -32
         BDR,R4   KGCA%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    LW,R1    INFMT             ARE WE DEBLOCKING
         B        UNBTAB,R1
UNBTAB   B        *R11              NO
         B        UNBF              F FORMAT
         B        UNBD              D FORMAT
         B        UNBV              V FORMAT
*
UNBF     LW,R3    INREC             FIXED SIZE RECORDS - GET SIZE
         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
         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
         LI,R1    120               IF RECORD IS OR WILL BE SMALL
         LW,R2    TOARG+10,R7       PUT IT AT IOBUF
         CI,R2    3
         BE       UNBF3             WILL BE 80 OR 120
         LW,R1    OUTREC
         BE       %+3               NO REC OPTION
         CI,R1    255
         BLE      UNBF3
         LW,R1    WRTFPT+5,R7       IF ITS A SHORT RECORD,
         CI,R1    255
         BG       *R11              MOVE IT TO A WORD BOUNDARY
UNBF3    CW,R1    WRTFPT+5,R7       MOVE MIN(R1,RECSIZE)
         BLE      %+2
         LW,R1    WRTFPT+5,R7
         STW,R1   WRTFPT+5,R7
         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
         LCW,R1   R1                BLANK REST OF BUFFER
         AI,R1    -1
         SLS,R1   24
         OR,R1    R3
         MBS,R0   BA(='    ')
         B        *R11
*
UNBD     LW,R1    UNBADR            ARE WE AT BEG OF BLOCK
         ANLZ,R1  IMEI
         SCS,R1   -2
         SW,R1    R7                COMPUTE R7 DISP
         SCS,R1   2
         LI,R2    4                 SIZE
         PSW,R11  *R7
         BAL,R11  BCD2BIN           CONVERT REC SIZE TO BINARY
         PLW,R11  *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
         BNE      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
         CI,R5    X'40000'          YES-EXIT
         BANZ     *R11              YES-EXIT
         LW,R1    DEVICE,R7
         CI,R1    8                 INPUT FROM TERMINAL
         BE       NCC4              YES
         CI,R5    X'20000'          NC OPTION PRESENT
         BAZ      *R11              NO-EXIT
NCC4     LW,R5    WRTFPT+4,R7       GET LOCATION OF OUTPUT BUFFER
         AI,R3    0                 NULL RECORD
         BE       *R11              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        *R11              EXIT
*
NCS      LW,R2    WRTFPT+4,R7       ADDR OF OUTPUT RECORD
         CI,R3    X'10'             IS RECORD BCD
         BAZ      NCS1              YES
         STW,R0   27,R2             ZERO BINARY SEQUENCE FIELD
         STW,R0   28,R2
         STW,R0   29,R2
BINCSX   LI,R1    120               SET SIZE
         STW,R1   WRTFPT+5,R7
         B        WRITE2
NCS1     LW,R1    ='    '           BLANK OUT SEQUENCE FIELD
         STW,R1   18,R2
         STW,R1   19,R2
BCDCSX   LI,R1    80                SET SIZE
         B        BINCSX+1
*
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
         B        BCDCSX            SET SIZE
*
SEQID    EQU      %-1
         B        NCS               NCS
         B        WRITE2            NLN
         B        CS                CS
         B        LINENUM           LN
         PAGE
BRCHK    MTW,0    BREAK             TEST FOR BREAK
         BE       *R11              NOT SET
         LW,R1    TOARG,R7          IF OUTPUT TO ME,
         CI,R1    8                 BREAK OUT OF FILE
         BE       %+3               EVEN IF COPYALL//STD
         MTW,0    COPYSK
         BNE      *R11              COPYALL
         PSW,R11  *R7
         LI,R2    BRKMSG
         LI,R11   24
         CAL1,1   WRTMSG            WRITE 'ENTER X...'
         LW,R1    RECNUM,R7
         BAL,R11  BIN2BCD
         LCW,R4   R4
         SLS,R4   3
         SLD,R2   64,R4
         LCI      2
         STM,R2   ARGBUFF,R7
         ANLZ,R2  %-1
         LI,R11   8
         CAL1,1   WRTMSG
         LW,R3    BREAK
         LI,R2    BRKMSG
         BAL,R11  READONE
         MTB,0    DELETEF           ARE WE AT LEFT SIDE OF PLATEN
         BE       %+3               YES
         LI,R11   1                 NO, WRITE A CR/LF
         CAL1,1   WRTMSG
         PLW,R11  *R7
         MTW,-1   BREAK
         CW,R3    BREAK             DID WE GET BREAK
         BLE      %+3
         CI,R1    'X'
         BNE      *R11              CONTINUE
         MTW,1    GRANCNT           SET ABORT FLAG
         B        COMPLAST          FINISH COPY
*
WRTMSG   GEN,8,24 X'11',M:UC
         DATA     X'34000000'
         PZE      *R2
         PZE      *R11              SIZE IN 11
         DATA     0
BRKMSG   TEXT     '
--X OR BRK TO ABORT AT '
         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,R5    WRTFPT+4,R7       BUFFER ADDRESS
         LW,R6    WRTFPT+5,R7       CHECK SIZE
         CI,R6    80
         BLE      %+3               ERROR
         CI,R6    120
         BLE      RC212             OK
RC290    LI,R1    42
         BAL,R11  ERROR0
         MTW,0    SUPERR
         BNE      RC220             IGNORE IT
         LW,R1    0,R5              PRINT FIRST WORD CONTENT
         BAL,R11  HEX2BCD
         LCI      2
         STM,R2   PRTBUF+5,R7
         LW,R1    CISEQ             PUT EXPECTED SEQ
         SLS,R1   20
         BAL,R11  HEX2BCD
         AI,R2    ' '-'0'
         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 ID/SEQ/CHKS='
RC292    GEN,8,24 17,M:LO
         DATA     X'34000010'
         PZE      *R1
         DATA     28,0
RC212    LB,R3    *R5               CHECK ID
         CI,R3    X'38'
         BE       %+3
         CI,R3    X'18'
         BNE      RC290
         LW,R4    CISEQ
         LI,R3    1
         CB,R4    *R5,R3
         BNE      RC290
*
         LI,R4    X'FF'             GET BYTE COUNT
         AND,R4   0,R5
         AI,R4    -1                DECREMENT
         LB,R2    *R5               ADD IN R2
         LB,R3    *R5,R4
         AW,R2    R3                ADD EACH BYTE
         BDR,R4   %-2               ITERATE
         LI,R3    2
         LB,R4    *R5,R3
         SW,R2    R4                DONT ADD IT IN SUM
         CB,R2    *R5,R3
         BNE      RC290
*
RC220    LI,R4    X'FF'             SET UP BIT COUNT FOR THIS
         AND,R4   *R5               RECORD
         MTW,1    CISEQ             SET SEQ FOR NEXT ONE
         SLS,R4   3
         STW,R4   CIBTOTAL
         LI,R4    32                INITIALIZE CONTROL WORDS
         LI,R9    32
         LW,R11   WRTFPT+4,R7       SET CIWORD
         AI,R11   1
         XW,R11   CIWORD
         LB,R6    R11
         LI,R15   PRTBUF            INIT OUT BUFFER ADDR
         AW,R15   R7
         LW,R1    CIBLEFT           GET OUTPUT BYTE#
         AI,R11   0                 ARE WE STARTED YET
         BNE      DEC60             IN MIDDLE OF OUTPUT
         B        DEC05
         PAGE
* SUBROUTINE DECOMPR RECONSTRUCTS A SYMBOLIC RECORD FROM COMPRESSED
* INPUT.
DECOMPR  LCI      7
         PSM,R5   *R7
         LW,R9    CIBUSED           INITIALIZE CONTROL REGS
         LW,R4    CIBLEFT
DEC05    LI,R1    0                 START IN BYTE ZERO
         LI,R15   PRTBUF-1
         AW,R15   R7
         LI,R2    35
         LW,R3    ='    '           BLANK OUTPUT BUFFER
         STW,R3   *R15,R2
         BDR,R2   %-1
         AI,R15   1
DEC10    LI,R6    6                 GET 6 BIT BYTE
         BAL,R11  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   *R15,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,R9   CIBUSED           SAVE REGS
         STW,R4   CIBLEFT
         LCI      7
         PLM,R5   *R7
         STW,R1   WRTFPT+5,R7       SET SIZE
         STW,R15  WRTFPT+4,R7
         SLS,R15  2
         STW,R15  WRTFPT+7,R7
         B        READ28
*
DEC35    STW,R0   CISEQ             RESET FOR BATCH FILES
         STW,R0   CIWORD
         LCI      7
         PLM,R5   *R7
         LI,R3    5                 SIMULATE EOD
         LI,R6    0
         B        EOD1
*
DEC40    LI,R6    8                 GET 8 BIT CODE FROM IOBUF
         BAL,R11  DEC60
         STB,R2   *R15,R1           PUT IN OUTPUT BUFFER
         AI,R1    1
         B        DEC10             ITERATE
*
DEC45    LI,R6    6                 USE 6 BIT COUNT
         BAL,R11  DEC60
         AI,R2    1                 +1
DEC47    LI,R5    ' '
         STB,R5   *R15,R1           EXPAND BLANK FIELD IN BUFFER
         AI,R1    1
         BDR,R2   %-2
         B        DEC10             ITERATE
*
DEC50    LI,R6    6                 USE 6 BIT COUNT
         BAL,R11  DEC60
         AI,R2    65                +65
         B        DEC47
*
DEC60    AW,R9    R6                EXTRACT (R6) BITS
         CW,R9    CIBTOTAL          ARE THERE ENOUGH LEFT
         BLE      DEC65             YES
         STW,R1   CIBLEFT           SAVE OUTPUT PTR
         STB,R6   R11               AND CURRENT CALL
         STW,R11  CIWORD
         LCI      7
         PLM,R5   *R7
         B        READN             GET NEXT INPUT RECORD
*
DEC65    LI,R2    0                 INITIALIZE RESULT REGISTER
         LW,R5    CIWORD            GET CURRENT INPUT POINTER
         LW,R3    0,R5              PICK UP CURRENT WORD
         SW,R4    R6                CHECK IF R3 CONTAINS TOTAL BYTE
         BGE      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            UPDATE 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        *R11              EXIT
         PAGE
* SUBROUTINE COMPRESS PRODUCES A COMPRESSED OUTPUT RECORD AND WRITES IT.
COMPLAST MTW,0    COPYSK            IF NOT COPYALL, DONT COMP LAST
         BE       EOF8              UNTIL RDWRTX CALL
RDWRTX1  LI,R11   EOF8+X'80000'     SET LAST FLAG
COMPRESS LI,R1    3                 ARE WE COMPRESSING AT ALL
         CW,R1    TOARG+5,R7
         BNE      *R11              NO
         LCI      7
         PSM,R5   *R7
         LI,R8    0                 SET BLANK COUNT ZERO
         LW,R9    COBUSED           GET POINTERS
         LW,R4    COBLEFT
         LW,R1    WRTFPT+5,R7       SIZE OF RECORD
         STW,R1   RECSIZE
         LW,R15   WRTFPT+4,R7       ADDR
         LI,R1    3                 BTD
         AND,R1   WRTFPT+7,R7
         AWM,R1   RECSIZE
         LW,R5    COWORD            ARE WE INITIALIZED
         BNE      CMP10             YES
         STW,R15  COBUSED           NO, GO DO IT
         STW,R1   COBLEFT
         LI,R1    -1
         STW,R1   PRNTBUF           SET SEQUENCE TO FF
         B        COMPNXT0
CMP10    MTB,0    R11               IS THIS THE LAST
         BE       CMP11             NO
         LI,R1    X'18'             CHANGE ID FROM 38 TO 18
         STB,R1   PRNTBUF
         LI,R5    CEOF              EDIT EOF CONTROL BYTE
         LI,R6    6                 IN 6 BITS
         BAL,R11  CMP60
         LI,R6    X'4000'           SPECIAL FLAG (SEE WRITEX)
         B        CMP70             GETS TO SIGN BIT OF COWORD
*
CMP11    LB,R5    *R15,R1           GET NEXT BYTE
         CI,R5    X'C0'             CHECK FOR A-Z,0-9
         BLE      CMP15             CANT BE IF LESS THAN X'C0'
         LB,R5    COTAB-48,R5       GET 6BIT CODE
         BNE      CMP12
         LB,R5    *R15,R1           ZERO, USE ORIGINAL 8 BITS
         B        CMP17
*
CMP20    AI,R6    43                FOUND IN SCCTAB
         LW,R5    R6                CODE IS INDEX+43
CMP12    LI,R6    6                 SET BIT COUNT
         BAL,R11  CMP60             ENTER IN OUTPUT BUFFER
CMP13    AI,R1    1                 POSITION TO NEXT BYTE
         CW,R1    RECSIZE           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
         BGE      CMP14             OUTPUT NOT LESS THAN 80 BYTES
         AI,R8    80                PAD TO 80 BYTES
         SW,R8    R1
         LI,R1    80
CMP14    LI,R5    CEOL              ADD EOL TO RECORD
         LI,R6    6
         BAL,R11  CMP60
         STW,R9   COBUSED           SAVE POINTERS
         STW,R4   COBLEFT
         LCI      7
         PLM,R5   *R7
         B        WRITEX
*
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    AI,R5    CNEXT8**8         OUTPUT AS 14 BITS
         LI,R6    14
         BAL,R11  CMP60             OUTPUT 8 BIT CHARACTER
         B        CMP13             ITERATE
*
CMP25    AI,R8    1                 ACCUMULATE BLANK
         CI,R8    128               MAX 128 PER CODE
         BL       CMP13
         LI,5     X'1BF'            PUT OUT 127 NOW
         LI,6     12
         B        CMP68             AND REDO THIS ONE
*
CMP60    AI,R8    0                 IS BLANK COUNT ZERO
         BE       CMP70             YES
         LI,R5    CBLANK
         LI,R6    6                 ENTER BLANK IN 6 BITS
         AI,R8    -1
         BE       CMP68             ONLY ONE BLANK
         LI,R5    CNBC1
         CI,R8    63
         BLE      CMP67             <=64 BLANKS, ENTER COUNT+1
         LI,R5    CNBC65            ENTER COUNT+65
         AI,R8    -64               ADJUST COUNT
CMP67    BAL,R11  CMP70             OUTPUT CONTROL BYTE
         LW,R5    R8                GET COUNT
CMP68    BAL,R11  CMP70             OUTPUT COUNT
         LI,R8    0                 SET NO. OF BLANKS TO ZERO
         B        CMP13+1           REDO ORIGINAL BYTE
*
CMP70    LW,R2    R5                POSITION BYTE IN EVEN REGISTER
         AW,R9    R6                INCREMENT TOTAL BIT COUNT
         CI,R9    COBTOTAL
         BG       WRITECO           WONT FIT, WRITE THIS ONE
         LW,R5    COWORD            GET BUFFER WORD POINTER
         SW,R4    R6
         BGE      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            INCR POINTR
         AWM,R3   1,R5              PUT OVERFLOW BITS IN NEXT WORD
         AI,R4    32                NUMBER OF BITS LEFT IN CO WORD
         B        *R11              EXIT
CMP75    SLS,R2   0,R4              POSITION BYTE
         AWM,R2   0,R5              ENTER IN CO WORD
         B        *R11              EXIT
         PAGE
*        STRIP TRAILING BLANKZ IF NB REQUESTED
NBCHK    LW,R2    TOARG+6,R7
         CW,R2    =X'00FF0000'
         BAZ      LCUCCHK           NO NB, TRY CASE CONVERSION
         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
LCUCCHK  LW,R2    TOARG+7,R7
         LB,R2    R2
         AI,R2    -19
         BL       *R11
         LW,R3    WRTFPT+7,R7       REC BYTE ADDR
         LW,R4    WRTFPT+5,R7       REC SIZE
LCUC1    LB,R1    0,R3
         CLM,R1   LCUCS,R2
         BCS,9    %+3
         AH,R1    LCUCD,R2
         STB,R1   0,R3
         AI,R3    1
         BDR,R4   LCUC1
BIR11    B        *R11
         BOUND    8
LCUCS    DATA     'A','Z'
LCCHARS  DATA     'a','z'
LCUCD    DATA,2   'a'-'A','A'-'a'
         PAGE
* SUBROUTINE WRITECO APPENDS CONTROL INFO. TO BUFFER AND WRITES
* COMPRESSED RECORD.
WRITECO  SW,R9    R6                RESTORE ORIGINAL BYTE COUNT
         AI,R9    7                 COMPUTE NO. OF BYTES
         SLS,R9   -3                FROM BIT COUNT
         STS,R9   PRNTBUF           SET BYTE COUNT
         LI,R14   PRNTBUF
         ANLZ,R11 BIR11             SCRUB JUNK FROM R11
         SLS,R6   17                MOVE COUNT TO 0-14
         OR,R11   R6
         STW,R11  COWORD
         STW,R1   COBLEFT
         STH,R5   COBLEFT           SAVE CHAR TOO
         STB,R8   R15               SAVE BLANK COUNT
         STW,R15  COBUSED
         LB,R5    *R14
         LW,R2    R9
         AI,R2    -1
         LB,R6    *R14,R2           GET ALL BYTES
         AW,R5    R6                FORM CHECKSUM
         BDR,R2   %-2
         LI,R6    2
         STB,R5   *R14,R6           PUT IN BUFFER
         LI,R1    108
         STW,R1   WRTFPT+5,R7       SET OUTPUT RECORD
         STW,R14  WRTFPT+4,R7       DESCRIPTION
         SLS,R14  2
         STW,R14  WRTFPT+7,R7       SET BTD
         LCI      7
         PLM,R5   *R7
         B        WRITE0
*
COMPNXT  LCI      7
         PSM,R5   *R7
COMPNXT0 MTH,1    PRNTBUF           INCR SEQUENCE
         LI,R4    X'38'
         STB,R4   PRNTBUF           SET ID
         STH,R0   PRNTBUF,R4        CLEAR REST OF BUF (TO BYTE 113)
         BDR,R4   %-1               CLEAR BUFFER
         LI,R4    32
         LI,R9    32
         LW,R15   COBUSED           RESTORE POINTERS
         INT,R1   COBLEFT
         LH,R5    COBLEFT           SAVED CHAR
         LI,R11   PRNTBUF+1         FIRST OUTPUT BIT ADDR
         XW,R11   COWORD
         BE       CMP11             FIRST TIME IN
         LW,R6    R11               NO, GET COUNT AND BYTE
         SLS,R6   -17
         LB,R8    R15
         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
         MTB,3    R1
KEYADR   STW,R1   TOARG+11,R7       SAVE IT
         LW,R1    TOARG+13,R7       INCREMENT FOR NEXT KEY
         AWM,R1   TOARG+12,R7
         B        WRITE2            RETURN TO WRITE
LINE20   LI,R1    46
         B        RETURNE           UNCONDITIONAL GIVEUP
         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,R8    TABSET+4,R7       GET TAB TABLE ADDRESS
         LI,R2    X'05'
         LI,R9    ' '
         MTW,-1   WRTFPT+5,R7       DISPLACEMENT OF LAST CHAR IN RECORD
         BL       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        *R11
*
TAB10    STB,R9   *R1,R6            STORE BLANK OVER TAB CHAR
         AI,R8    0                 WERE TABS SPECIFIED
         BE       TAB6              NO
TAB12    LB,R3    *R8,R5            GET TAB VALUE
         BNE      TAB15
TAB13    LI,R8    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
         BE       TAB5              NONE
         AW,R3    R4                INCREMENT TO NEW LAST CHAR
         STW,R3   WRTFPT+5,R7       SET NEW RECORD SIZE
TAB19    LB,R10   *R1,R4            GET LAST CHAR OF RECORD
         STB,R9   *R1,R4            BLANK THIS CHAR IN RECORD
         STB,R10  *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.
CS       PSW,R3   *R7
         LW,R1    TOARG+12,R7       GET SEQUENCE NUMBER
         CW,R1    TOARG+14,R7
         BLE      SEQOUT1
         LI,R1    0                 GR THAN MAX - REVERT TO 0
         STW,R1   TOARG+12,R7
SEQOUT1  BAL,R11  BIN2BCD           CONVERT TO BCD
         OR,R3    ='0000'
         STW,R3   CARDSEQ+1,R7      ENTER LAST 4 CHARS
         LW,R1    TOARG+11,R7       SIZE OF NONNUMERIC 1ST WORD
         MI,R1    -8                SET TO GEN MASK
         LW,R3    ='0000'
         SLS,R3   -4,R1
         STS,R2   CARDSEQ,R7
         LW,R1    TOARG+13,R7
         AWM,R1   TOARG+12,R7       INCREMENT SEQUENCE NUMBER
         PLW,R3   *R7
         CI,R3    X'10'             IS THIS BINARY OR BCD
         BAZ      CS2               BCD
* SUBROUTINE SEQOUTB CONVERTS SEQUENCE INFO IN LOCATION CARDSEQ TO
* BINARY FORMAT AND ENTERS IT IN THE LAST 3 WORDS OF THE OUTPUT
* BUFFER.
         LW,R11   WRTFPT+4,R7
         AI,R11   30                POINT TO END OF RECORD
         LI,R8    CARDSEQ+2
         AW,R8    R7                LOCATION OF CARDSEQ
         LI,R1    -8                8 CHARS
         LI,R5    -12               STORED INTO 12
SEQ100   LB,R4    *R8,R1            CHAR TO CONVERT
         LW,R2    R4
         AI,R2    -1
         SLS,R2   -3
         LB,R2    HOLES,R2
         LI,R3    #ANOMS
KGCA%4   CB,R4    ANOMS,R3
         BNE      %+3
         LB,R2    HOLES1,R3
         LI,R3    X'F83'**2-1
         BIR,R3   KGCA%4
         SLD,R2   -2
         SLS,R2   4
         SLD,R2   2
         SLS,R3   -2
         LCW,R4   R4
         AND,R4   =X'8007'
         SLS,R4   -14,R4
         XW,R2    R4
         OR,R2    R4
         LS,R2    R4
         SCS,R2   -4                PREPARE FOR STORE
         CI,R1    1                 IS THIS FIRST OR SECOMD
         BAZ      SEQ101            OF PAIR
         SCS,R2   -4
         AI,R5    -1
         LB,R4    *R11,R5
         AW,R2    R4
SEQ101   STB,R2   *R11,R5
         AI,R5    1
         SCS,R2   8
         STB,R2   *R11,R5
         AI,R5    1
         BIR,R1   SEQ100
         B        BINCSX
*
HOLES    DATA     X'81834143',X'21230103'
         DATA     X'A182C142',X'6122E102'
         DATA     X'A0A2C0C2',X'6062E0E2'
         DATA     X'80A340C3',X'206300E3'
         DATA     X'00102030',X'40506061'
         DATA     X'6A708089',X'90999FA0'
         DATA     X'A9B0B9C0',X'C9D0D9E0'
         DATA     X'E1E9F0F9'
ANOMS    DATA     X'B3D373F3',X'00804030'
         DATA     X'C0E0B2A1',X'D2C1C272'
         DATA     X'61F2E1A0',X'8160412A'
         DATA     X'71212001'
HOLES1   EQU,0    %
#ANOMS   EQU      BA(ANOMS)-BA(%)
         PAGE     'H E X D U M P'
*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
*P*               THE RDWRT ROUTINE IF THE X FORMAT CONVERSION HAS BEEN
*P*               SPECIFIED.
*P*
HEXDUMP  LCI      11
         PSM,R5   *R7
*
         CAL1,1   FPTVFC            RESET VFC
         LI,R14   PRNTBUF
         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   *R14,R1
         BDR,R1   %-2
         LW,R2    KEYT
         LW,R1    M:EI+10
         BAL,R10  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,R11  BIN2BCD0          CONVERT REC# TO BCD
RECSIZ   LW,R1    WRTFPT+5,R7       PRINT RECORD SIZE
         LI,R2    DASHT
         BAL,R11  BIN2BCD0          GO-CONVERT SIZE TO EBCDIC
         LI,R2    BYTEST
         BAL,R11  MOVTXTC
         CAL1,1   PRINT             PRINT REC NO OR KEY AND SIZE
         LW,R15   WRTFPT+5,R7       SIZE
         BE       RETURN3           NULL RECORD
         CAL1,1   FPTSKIP           SKIP A LINE
         LI,R1    33
         LW,R2    BLNKT             * BLANK PRNTBUF
         STW,R2   *R14,R1
         BDR,R1   %-1
         LW,R9    %                 SET POS BDR REG FOR TERMINAL
         LW,R1    TOARG,R7
         CI,R1    8                 IS OUTPUT TO A TERMINAL
         BE       %+2               YES
         LW,R9    *%                NEG FOR LP OR OTHER THING
         LW,R5    WRTFPT+7,R7       BYTE ADDRESS OV RECORD
         LI,R8    0                 RESET ASTERISK FLAG
DUMP2    MTW,0    BREAK             BREAK KEY HIT
         BE       KGC2%4            NO
         CAL1,8   FPTWAIT           WAIT FOR SECOND BREAK
         MTW,-1   BREAK             YES-CLEAR BREAK
         B        RETURN3           RETURN
KGC2%4   LW,R1    R5
         SW,R1    WRTFPT+7,R7
         SLS,R1   -2                MAKE WORD DISPLACEMENTS
         BAL,R11  HEX2BCD           CONVERT ADDRESS TO BCD
         SLD,R2   24
         OR,R3    BLNKT             GET RID OF LEADING ZEROES IN ADDRESS
         STD,R2   *R14              PUT ADDRESS INTO PRNT BUFFER
*
         LI,R4    4                 LOAD PRNTBUF POINTER
         LI,R6    92                START OF EBCD FOR LP
         BIR,R9   %+2
         LI,R6    50
         LI,R12   4                 FOUR BYTES PER WORD
DUMP1    LB,R1    0,R5
         AI,R5    1
         PSW,R4   *R7
         BAL,R11  HEX2BCD           GET HEX
         PLW,R4   *R7
         STH,R3   R3                SIGN EXTEND
         LH,R3    R3
         CH,R3    *R14,R4           CHECK FOR SAME AS LAST LINE
         BE       %+2
DUMP10   STH,R0   R8                CLEAR SKIP FLAG
         STH,R3   *R14,R4
         LI,R3    1                 IS THIS PRINTABLE CHAR
         SCS,R3   0,R1
         SCS,R1   -5
         AND,R3   CCTAB,R1
         SCS,R1   5
         BNE      %+2               YES
         LI,R1    '.'               NO, MAKE DOT
         STB,R1   *R14,R6
         AI,R6    1                 INCR BUFF PTRS
         AI,R4    1
         BDR,R12  DUMP3             HAVE WE DONE A WORD
         LI,R12   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,R9   PRNT              AND PRINT IF TERMINAL
         CI,R4    45                MAYBE ALL DONE WITH LINE
         BGE      PRNT
DUMP3    BDR,R15  DUMP1             NO, TO NEXT BYTE
         LI,R3    '  '              NONE LEFT, BLANK REST OF BUFFER
         LI,R1    ' '
         B        DUMP10
*
PRNT     BDR,R15  %+2               COUNT BYTES
         STH,R0   R8                AND PRINT THE LAST LINE ANYWAY
         BIR,R8   PRNT2             STILL SKIPPING
         CI,R8    X'FFFE'           FIRST OR NO
         BAZ      PRNT1             YES, NO *
         LI,R1    5
         LI,R2    '*'
         STB,R2   *R14,R1
PRNT1    CAL1,1   PRINT
         LI,R8    X'F0000'          SET INITIAL FLAG VALUE
PRNT2    AI,R15   0
         BG       DUMP2
RETURN3  LCI      11
         PLM,R5   *R7
         LI,R0    0
         B        *R11
*
*        MOVTXTC MOVES TEXTC AT WA(R2) TO *R14,R6 BYTES
*        AND ADJUSTS R6
MOVTXTC  LB,R3    *R2               GET COUNT
         ANLZ,R2  %-1
         AI,R2    1
         LB,R10   0,R2
         STB,R10  *R14,R6
         AI,R6    1
         BDR,R3   %-4
         B        *R11
*
*MOVE TEXT IN R2 + = AND NAME AT *R1 TO *R14
*        SET R6 TO NEXT CSPACE
*
UNPRINT0 STW,R2   *R14
         LI,R2    '='
         AI,R14   1
         STB,R2   *R14
         BAL,R11  UNPRINT
         LW,R6    R2
         AI,R6    5
         AI,R14   -1
         B        *R10
*        MOVE TEXTC AT *R2 AND NUMMER IN R1
*        TO *R14,R6..PACKING NUMBER AND ADJUST R6
BIN2BCD0 PSW,R11  *R7               SAVE RETURN
         BAL,R11  MOVTXTC
         BAL,R11  BIN2BCD
         LI,R1    8                 8 DIGS MAX
B2B2     SCD,R2   8
         STB,R3   *R14,R6
         CI,R3    X'B0'             NUMBER OR BLANK
         BAZ      %+2
         AI,R6    1
         BDR,R1   B2B2
         PLW,R11  *R7
         B        *R11
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      *R14              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
