*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*
         DEF      RDWRTX            ENTRY TO GET LAST CO RECORD
         REF      SUPERR            IGNORE ERRORS FLAG
         REF      HEX2BCD
         REF      INCRPT            INPUT ENCRYPTION SEED ADDRESS
         REF      OUTCRPT           OUTPUT ENCRYPTION SEED ADDRESS
         REF      M:C
         REF      IOABORTS
         REF      DELETEF           CARRIAGE POSITION FLAG FOR READONE
         REF      CMBX              TO SET % POSITION FOR ERRORS
         REF      ERROR
         REF      CLOSEO
         REF      BLKFIX
         REF      ARGBUFF           TEMP STORAGE
         REF      PRTNOF            EOD AFTER N
         REF      M:EI,M:EO,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
         REF      BREAK,COPYSTDF
         REF      SEQNUM
         REF      CCTAB
         DEF      LCCHARS
         REF      SELECT,J:JIT
         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
*        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
*
         USECT    RDWRT
         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 WEVE BEEN HERE
         CI,R1    EOERR             DONT 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
         BEZ      %+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 INPPUT IF ANSTAPE
         AND,R3   M:EI+5
         SLS,R3   -4
         LW,R6    DEVICE,R7
         BAL,SR3  BLKFIX
         LCI      3
         STM,R3   INBLK
         LI,R2    IOBUF             ADD I/O BUFFER
         AW,R2    R7
         MTW,0    INFMT             IF BLOCKING OR DEBLOCKING
         BEZ      READ41            ADJUST FOR MULTIPLE BUFFERS
         AI,R2    64                LEAVE A HOLE IF UNBLOCKING
         LW,R1    INBLK             INPUT MAX BLOCK SIZE
         AI,R1    0
         BNEZ     %+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
         BEZ      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,SR1  NPAGE,R7          SAVE # PAGES GOTTEN
         BCS,8    EOF11             CANT 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   EQU      %
         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
         BNEZ     %+3               NO BLOCK IF NO SELECTION
         MTB,1    R1
         STS,R0   RDFPT+1,R7
         LI,SR2   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   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
         STW,R3   WRTFPT+5,R7       SET RECORD SIZE
         LW,R1    INFMT
         LH,R1    RECOVH,R1
         BEZ      %+3
         SW,R3    R1
         AI,R3    1
         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      %
         LW,R3    OUTREC            IF OUT SIZE SHOULD BE FIXED,
         BEZ      %+4
         CW,R3    WRTFPT+5,R7       FIX IT.
         BGE      %+2               BUT DONT PAD UNTIL MASSAGING IS DONE
         STW,R3   WRTFPT+5,R7
         LI,R3    6                 SET EOF CODE
         MTW,1    RECNUM,R7
         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    RES
         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
         MTW,0    INFMT             IF BLOCKED, NO PRECORD
         BNEZ     WRITEX
         LI,R1    15
         AND,R1   M:EI
         CI,R1    3
         BGE      READ1             NOT DEVICES
READ17A  EQU      %
         SW,R3    RECNUM,R7         COMPUTE NO. OF RECS TO SKIP
         BEZ      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
         BNEZ     WRITEX
         AI,R3    -100
         BGZ      READ23
         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
         LW,R3    OUTREC            FOX RECORD SIZE IF FIXED
         BEZ      %+2
         STW,R3   WRTFPT+5,R7
         BAL,SR4  COMPRESS
WRITE0   RES
         LW,R2    TOARG+6,R7        IS BIN/BCD SPECIFIED
         LB,R3    R2
         SLS,R3   3
         BNEZ     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 STANRARD 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  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
         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,SR4  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   RES
         LW,R1    RECNUM,R7         GET RECORD NUMBER
         BAL,SR4  BIN2BCD           CONVERT TO BCD
         LW,R4    L(' -  ')
         LI,R1    10
         AI,R5    -1
         LB,SR4   R2,R1
         STB,SR4  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   EQU      %
         LD,R2    KEYX
         STD,R2   PRNTBUF
         LI,D3    PRNTBUF+1
         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
WRITE1   EQU      %
         LW,R2    WRTFPT+5,R7       WRITE NULL RECORD
         BNEZ     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  RES
         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
         BGZ      WRITE1            YUP
WRITEX   EQU      %
         CW,SR3   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,SR4  BRCHK             CHECK BREAK FLAG
         LW,R2    RSSAVE,R7         IF SELECTING..
         BDR,R2   %+3               AND LAST RANGE..
         MTB,0    SR2               AND LAST OF IT..
         BNEZ     COMPLAST          QUIT.
         MTW,0    CIWORD            IF DECOMPRESSING,
         BNEZ     DECOMPR           EXTRACT THE NEXT RECORD
READN    MTW,0    UNBADR            ARE WE UNBLOCKING ANS
         BNEZ     READ29
         B        READ0
*
EOF7     LCH,R3   M:EI+4            ADJUST RECNUM
         SAS,R3   -1
         AWM,R3   RECNUM,R7
RDABN    LB,R3    SR3               GET ABNORMAL CODE
         CI,R3    6                 EOF ENCOUNTERED
         BE       EOD2              YES
         CI,R3    5                 EOD THEN
         BNE      EOF1              NO
EOD1     EQU      %
         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     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
         B        READ1
*
EOF1     EQU      %
         CI,R3    7                 TEST FOR LOST DATA
         BNE      EOR
         MTW,0    OUTREC            IF TRUNCATING OUTPUT, BUF IS
         BNEZ     *SR1              ADEQUATE
         LW,SR1   NPAGE,R7          GET MORE MEMORY
         AI,SR1   1
         SLS,SR1  3
         PSW,SR2  *R7               SAVE SR2
         CAL1,8   =X'88000008'
         PLW,SR2  *R7
         AWM,SR1  NPAGE,R7
         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
         LI,SR4   ERROR1            SET RETURN
*        ERROR0 GOES TO ERROR TO REPORT AN ERROR UNLESS DOING
*        COPYALL OR COPYSTD, FORWHICH A CODE IS CREATED IN SR3 (OR LEFT THERE)
ERROR0   MTW,0    COPYSK            COPYALL OR STD
         BEZ      ERROR             NO, REPORT NORMALLY
         AI,R1    0                 IO ERROR OR PCL ERROR
         BEZ      %+3               IO..CODE IN SR3 ALREADY
         LW,SR3   R1                PCL..CREAT CODE IN SR3
         SLS,SR3  24
         STW,SR3  ERRCODE           SAVE CODE IN CASE OF SUPERR
         B        *SR4
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  ERROR0
         MTW,0    SUPERR            IF SUPRESSION, IGNORE
         BNEZ     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
         BEZ      COMPLAST          NO, FINISH UP
         LW,R3    RECNUM,R7         GET NO. OF LAST REC
         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
         MTW,0    COPYSK            IF COPYALL/STD, NO MSG
         BNEZ     EOF6
         PSW,SR2  *R7
         LW,SR2   RECNUM,R7
         SCS,SR2  16
         BNEZ     %+2
         LI,SR2   X'8000'
         LI,R5    EODMSG
         BAL,SR4  PRTNOF
         PLW,SR2  *R7
         LW,R3    RECNUM,R7
EOF6     MTW,-1   RSSAVE,R7         COUNT DOWN
         BEZ      COMPLAST          ALL DONE
         STB,R0   SR2               CLEAR END FLAG
         AI,SR2   1                 POSITION TO X VALUE
         CW,R3    *SR2,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,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      *SR1              NOT ENOUGH, GET THIS REC, THEN 1C
         CAL1,1   EICVOL            ADVANCE TO NEXT INPUT TAPE REEL
         BDR,SR3  *SR1              CLOBBER SR3 AND CONTINUE
*
WRTABN   LB,R1    SR3               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,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
*
EIERR    LB,R1    SR3               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
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
         MTW,0    GRANCNT           IS COPY ABORTD
         BNEZ     *SR4              YES, GET OUT
         LI,SR1   READ1                    RETURN LOC TO RESUME READ
         CW,R1    TOARG,R7          ONLY TRANSFER TO SAME TAPETYPE
         BNE      *SR4              NO
         MTB,0    *M:EI+2           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
         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        *SR4
56ERR    GEN,8,24 X'56',M:EO
56ERRCHK LW,R1    TOARG+1,R7        CVOL TO SCRATCH IS OK IF
         BEZ      0,R2              IT'S ALL SCRATCH,
         CB,R1    M:EO+11           BUT NOT OTHERWISE
         BG       0,R2
         LW,SR3   56ERR
         LI,D2    4                 AND ABORT THE BATCH USER
EOERR    EQU      %
         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
RETURNE  BAL,SR4  ERROR0            REPTRO ERRRO
RETURN   RES
         LW,D4    ERRCODE           SET ERRCODE OR ZERO
         LI,R3    CLOSE2
         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    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            ..
         BEZ      %+3               RELEASE EMPTY FILE
         MTW,0    SUPERR            IF SUPRESSING, SAVE IT
         BNEZ     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,SR1   0                 AS COMMANDS
         BNEZ     READ1
RETURNX  RES
         LW,SR1   NPAGE,R7          FREE EXTRA PAGES
         BEZ      %+2
         CAL1,8   =X'89000008'
         STW,R0   NPAGE,R7
         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     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      *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      *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,SR4   RETURN            LAST EXIT
         MTB,-1   OUTBLK            FORCE RECORD TO OVERFLOW
BLKTEST  EQU      %
         LW,R3    OUTBUF
         SLS,R3   2
         LW,R2    OUTFMT            GET BLOCKING TYPE
         BEZ      *SR4              NONE
         LH,R1    RECOVH,R2         GET COUNT SIZE
BLK1     AW,R1    WRTFPT+5,R7
         AW,R1    BLKBUFF           ADD CORRENT 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
         BNEZ     *SR4              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 WONT FIT
         BLZ      *SR4              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
         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    LW,R1    INFMT             ARE WE DEBLOCING
         B        UNBTAB,R1
UNBTAB   B        *SR4              NO
         B        UNBF              F FORMAT
         B        UNBD              D FORMAT
         B        UNBV              V FORMAT
*
UNBF     RES                        FIXED SIZE RECS
         LW,R3    INREC             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
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
         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
         BEZ      %+3               NO REC OPTION
         CI,R1    255
         BLE      UNBF3
         LW,R1    WRTFPT+5,R7       IF ITS A SHORT RECORD,
         CI,R1    255
         BG       *SR4              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        *SR4
*
UNBD     LW,R1    UNBADR            ARE WE AT BEG OF BLOCK
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
         CI,R5    X'40000'          YES-EXIT
         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      RES
         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
         BEZ      *SR4              NOT SET
         LW,R1    TOARG,R7          IF OUTPUT TO ME,
         CI,R1    8                 BREAK OUT OF FILE
         BE       %+3               EEVEN IF COPYALL//STD
         MTW,0    COPYSK
         BNEZ     *SR4              COPYALL
         PSW,SR4  *R7
         LI,R2    BRKMSG
         LI,SR4   24
         CAL1,1   WRTMSG            WRITE 'ENTER X...'
         LW,R1    RECNUM,R7
         BAL,SR4  BIN2BCD
         LCW,R4   R4
         SLS,R4   3
         SLD,R2   64,R4
         LCI      2
         STM,R2   ARGBUFF,R7
         ANLZ,R2  %-1
         LI,SR4   8
         CAL1,1   WRTMSG
         LW,R3    BREAK
         LI,R2    BRKMSG
         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
         CW,R3    BREAK             DID WE GET BREAK
         BLE      %+3
         CI,R1    'X'
         BNE      *SR4              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      *SR4              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,SR4  ERROR0
         MTW,0    SUPERR
         BNEZ     RC220             IGNORE IT
         LW,R1    0,R5              PRINT FIRST WORD CONTENT
         BAL,SR4  HEX2BCD
         LCI      2
         STM,R2   PRTBUF+5,R7
         LW,R1    CISEQ             PUT EXPECTED SEQ
         SLS,R1   20
         BAL,SR4  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,SR2   32
         LW,SR4   WRTFPT+4,R7       SET CIWORD
         AI,SR4   1
         XW,SR4   CIWORD
         LB,R6    SR4
         LI,D4    PRTBUF            INIT OUT BUFFER ADDR
         AW,D4    R7
         LW,R1    CIBLEFT           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           INITIALIZE CONTROL REGS
         LW,R4    CIBLEFT
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           SAVE REGS
         STW,R4   CIBLEFT
         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,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,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          ARE THERE ENOUGH LEFT
         BLE      DEC65             YES
         STW,R1   CIBLEFT           SAVE OUTPUT PTR
         STB,R6   SR4               AND CURRENT CALL
         STW,SR4  CIWORD
         LCI      7
         PLM,R5   *R7
         B        READN             GET NEXT INPUT RECORD
*
DEC65    LI,R2    0                 INITIALIZE RESULT REGISTER
         LW,R5    CIWORD            GET CURRENT INPUNT 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            UPDAE PONTER
         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 RES
         MTW,0    COPYSK            IF NOT COPYALL, DONT COMPLAST
         BEZ      EOF8              UNTIL RDWRTX CALL
RDWRTX1  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           GET POINTERS
         LW,R4    COBLEFT
         LW,R1    WRTFPT+5,R7       SIZE OF RECORD
         STW,R1   RECSIZE
         LW,D4    WRTFPT+4,R7       ADDR
         LI,R1    3                 BTD
         AND,R1   WRTFPT+7,R7
         AWM,R1   RECSIZE
         LW,R5    COWORD            ARE WE INITIALIZED
         BNEZ     CMP10             YES
         STW,D4   COBUSED           NO, GO DO IT
         STW,R1   COBLEFT
         LI,R1    -1
         STW,R1   PRNTBUF           SET SEQUENCE TO FF
         B        COMPNXT0
CMP10    MTB,0    SR4               IS THIS THE LAST
         BEZ      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,SR4  CMP60
         LI,R6    X'4000'           SPECIAL FLAG (SEE WRITEX)
         B        CMP70             GETS TO SIGN BIT OF COWORD
*
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'
         LB,R5    COTAB-48,R5       GET 6BIT CODE
         BNEZ     CMP12
         LB,R5    *D4,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,SR4  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
         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
CMP5     STW,SR2  COBUSED           SSVE 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,SR4  CMP60             OUTPUT 8 BIT CHARACTER
         B        CMP13             ITERATE
*
CMP25    AI,SR1   1                 ACCUMULATE BLANK
         CI,SR1   128               MAX 128 PER CODE
         BL       CMP13
         LI,5     O'677'            PUT OUT 127 NOW
         LI,6     12
         B        CMP68             AND REDO THIS ONE
*
*
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            GET BUFFER WORD 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            INCR POINTR
         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      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
         BLZ      *SR4
         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
BISR4    B        *SR4
         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  RES
         SW,SR2   R6                RESTORE ORIGINAL BYTE COUNT
         AI,SR2   7                 COMPUTE NO. OF BYTES
         SLS,SR2  -3                FROM BIT COUNT
         STS,SR2  PRNTBUF           SET BYTE COUNT
         LI,D3    PRNTBUF
         ANLZ,SR4 BISR4             SCRUB JUNK FROM SR4
         SLS,R6   17                MOVE COUNT TO 0-14
         OR,SR4   R6
         STW,SR4  COWORD
         STW,R1   COBLEFT
         STH,R5   COBLEFT           SAVE CHAR TOO
         STB,SR1  D4                SAVE BLANK COUNT
         STW,D4   COBUSED
         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
         SLS,D3   2
         STW,D3   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,SR2   32
         LW,D4    COBUSED           RESTORE POINTERS
         INT,R1   COBLEFT
         LH,R5    COBLEFT           SAVED CHAR
         LI,SR4   PRNTBUF+1         FIRST OUTPUT BIT ADDR
         XW,SR4   COWORD
         BEZ      CMP11             FIRST TIME IN
         LW,R6    SR4               NO, GET COUNT AND BYTE
         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
         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   RES
         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,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.
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,SR4  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
SEQOUT2  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.
SEQOUTB  LW,SR4   WRTFPT+4,R7
         AI,SR4   30                POINT TO END OF RECORD
         LI,SR1   CARDSEQ+2
         AW,SR1   R7                LOCATION OF CARDSEQ
         LI,R1    -8                8 CHARS
         LI,R5    -12               STORED INTO 12
SEQ100   RES
         LB,R4    *SR1,R1           CHAR TO CONVERT
         LW,R2    R4
         AI,R2    -1
         SLS,R2   -3
         LB,R2    HOLES,R2
         LI,R3    #ANOMS
         CB,R4    ANOMS,R3
         BNE      %+3
         LB,R2    HOLES1,R3
         LI,R3    X'F83'**2-1
         BIR,R3   %-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    *SR4,R5
         AW,R2    R4
SEQ101   STB,R2   *SR4,R5
         AI,R5    1
         SCS,R2   8
         STB,R2   *SR4,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   RES
#ANOMS   EQU      BA(ANOMS)-BA(%)
         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
         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
         LI,R3    1                 IS THIS PRINTABLE CHAR
         SCS,R3   0,R1
         SCS,R1   -5
         AND,R3   CCTAB,R1
         SCS,R1   5
         BNEZ     %+2               YES
         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

