Retro1.org codex

CIPHER
* /---   FILE TYPE = E
* /---   BLOCK      ENTRY      00 000   85/08/08  17.36 
          IDENT  CIPHER,FETS
          TITLE  CIPHER - ENCRYPT/DECRYPT A FILE. 
          ABS 
          ENTRY  CIPHER 
          ENTRY  SSM= 
          ENTRY  SDM= 
          ENTRY  RFL= 
          SYSCOM B1          DEFINE (B1) = 1
**        CIPHER - ENCRYPT/DECRYPT A FILE.
* 
*         THIS PROGRAM ENCRYPTS/DECRYPTS A FILE ACCORDING 
*         TO A LINEAR CONGRUENTIAL CIPHER (PSEUDO-RANDOM
*         SEQUENCE).
* 
*         THIS PROGRAM IS ESSENTIALY THE SAME AS =COPYBR= 
*         FROM THE NOS DECK =COPYB=.  SEE THAT DECK FOR 
*         MUCH MORE DOCUMENTATION.
* 
*         THIS PROGRAM MUST HAVE FOUR CALLING PARAMETERS, 
*         INPUT FILE NAME, OUTPUT FILE NAME, ENCRYPT/DECRYPT
*         FLAG AND CIPHERING KEY.  NONE OF THE OTHER =COPYB=
*         PARAMETERS ARE RECOGNIZED.
* 
*         THE ENCRYPT/DECRYPT PARAMETER IS EITHER THE STRING
*         *ENCRYPT* OR *DECRYPT* (OTHER VALUES ARE REJECTED)
*         EITHER CAN BE USED TO ENCRYPT THE FILE, BUT THE 
*         OTHER MUST BE USED TO DECRYPT IT. 
* 
* /---   BLOCK      CONSTANTS  00 000   85/07/29  12.36 
          TITLE  ASSEMBLY CONSTANTS.
****      ASSEMBLY CONSTANTS. 
 
 
 DPRS     EQU    1003B       DEFAULT PRU SIZE WITH CONTROL WORDS
 BUFL     EQU    DPRS        DEFAULT WORKING STORAGE BUFFER LENGTH
 FBUFL    EQU    DPRS*4      DEFAULT CIO BUFFER LENGTH
 LBUFL    EQU    102B        ALTERNATE OUTPUT CIO BUFFER LENGTH 
 RBFL     EQU    100B        RECORD COPY WORKING BUFFER LENGTH
 SBUFL    EQU    DPRS*8      SINGLE BUFFER COPY DEFAULT BUFFER LENGTH 
 
 FETL     EQU    9           FET LENGTH 
 
 DSPS     EQU    1000B       DEFAULT S TAPE PRU SIZE FOR *COPY* 
 DLPS     EQU    2000B       DEFAULT L TAPE PRU SIZE FOR *COPY* 
 MCBS     EQU    5120        MAXIMUM BLOCK SIZE (IN CHARACTERS) 
 
 MFLF     EQU    45000B-2    MAXIMUM FIELD LENGTH FACTOR
 LOFL     EQU    20000B-2    LOWER OPTIMUM FL FOR L AND F TAPE COPIES 
****
          SPACE  4,10 
*         SPECIAL ENTRY POINTS. 
 
 SSM=     EQU    0           SUPPRESS DUMPS OF FIELD LENGTH 
 SDM=     EQU    0           SUPPRESS INITIAL DAYFILE MSG 
* /---   BLOCK      COMMONS    00 000   83/04/18  15.17 
          SPACE  4,10 
*CALL     COMCMAC 
*CALL     COMSLFM 
          QUAL   MTX
*CALL     COMSMTX 
          QUAL   *
* /---   BLOCK      FETS       00 000   83/03/30  19.11 
          TITLE  FETS.
          ORG    120B 
 FETS     BSS    0
 
 
 I        BSS    0           INPUT FILE 
 INPUT    FILEB  IBUF,FBUFL,FET=FETL
 CWF      EQU    *-I         CONTROL WORD FLAG
          CON    0           NONZERO IF CONTROL WORDS ENABLED ON INPUT
 SLF      EQU    *-I         FORMAT FLAG
          CON    0           1= S TAPE, 2= L TAPE, -1= F TAPE, 0= OTHER 
 TCF      EQU    *-I         TCOPY CONVERSION FORMAT
          CON    0           -2=SI, -1=X, 1=E, 2=B, 0=NO CONVERSION 
 PRU      EQU    *-I         PRU SIZE (IN CM WORDS) 
          CON    -1 
 NSZ      EQU    *-I         NOISE SIZE (24/BITS, 18/UBC, 18/LENGTH)
          CON    0
 TRK      EQU    *-I         TAPE TRACK AND LABEL TYPE
          CON    0           1/9-TRACK, 1/7-TRACK, 52/0, 6/LABEL TYPE 
 
 
 O        BSS    0           OUTPUT FILE
 OUTPUT   FILEB  OBUF,FBUFL,FET=FETL
          CON    0           NONZERO IF CONTROL WORDS ENABLED ON OUTPUT 
          CON    0           1= S TAPE, 2= L TAPE, -1= F TAPE, 0= OTHER 
          CON    0           1=E, 2=B, 0=NO CONVERSION
          CON    -1          PRU SIZE (IN CM WORDS) 
          CON    0           NOISE SIZE (24/BITS, 18/UBC, 18/LENGTH)
          CON    0           TAPE TRACK AND LABEL TYPE
 
 
 L        FILEB  LBUF,LBUFL  ALTERNATE OUTPUT FILE
          ORG    L
          VFD    42/0LOUTPUT,17/1,1/1 
          ORG    L+FETL 
* /---   BLOCK      STORAGE    00 000   83/03/30  19.10 
          TITLE  DATA STORAGE.
**        DATA STORAGE. 
 
 
 BTSK     CON    0           BLOCK TERMINATOR/SKIP WORD INDICATOR 
 CRI      CON    -2          CALLING ROUTINE INDICATOR
 CT       CON    1           COPY COUNT 
 EL       CON    0           ERROR LIMIT
 EORF     CON    1           CURRENT BLOCK EOR FLAG 
 ERRF     CON    0           CURRENT BLOCK ERROR FLAG 
 FUBC     CON    0           FULL BLOCK UNUSED BIT COUNT (S, L TAPES) 
 FWWB     CON    BUF1+1      FWA WORKING BUFFER 
 LVL      CON    0           EOR LEVEL NUMBER 
 LWDB     CON    0           LWA+1 DATA TRANSFERRED TO WORKING BUFFER 
 RWCB     VFD    1/1,59/0    REMAINING WORDS IN CURRENT BLOCK 
 RWTT     CON    0           REMAINING WORDS TO TRANSFER
 SBT      CON    -1          SINGLE BUFFER READ/WRITE THRESHOLD 
 SK       CON    0           SKIP FLAG
 TC       CON    1           TERMINATION CONDITION (-1=EOI,0=EOD,1=EOF) 
 UBC      CON    0           UNUSED BIT COUNT FOR CURRENT WRITE 
 UBCB     CON    0           UNUSED BIT COUNT FOR CURRENT BLOCK 
 VF       CON    0           VERIFY FLAG
 
 BC       CON    -1          BLOCK COUNT
 RC       CON    0           RECORD COUNT 
 
 ESPI     CON    0           ERROR BLOCKS SKIPPED/PROCESSED INDICATOR 
 NPDI     CON    0           NOISE BLOCKS PADDED/DELETED INDICATOR
 RSAI     CON    0           RECORD SPLIT ALLOWED INDICATOR 
 SEWI     CON    0           SKIP EOF WRITE INDICATOR 
 TLLI     CON    0           TRUNCATE LONG LINES INDICATOR
 
 BFCT     CON    0           BAD FORMAT BLOCK COUNT 
 NZCT     CON    0           NOISE BLOCK COUNT
 PBCT     CON    0           PARITY/BLOCK TOO LARGE ERROR COUNT 
 RSCT     CON    0           RECORD SPLIT COUNT 
* /---   BLOCK      TECA       00 000   83/03/30  19.11 
          SPACE  4,10 
**        TECA - TABLE OF ERROR COUNT ADDRESSES.
* 
*T        6/ EF, 18/ DMSA, 18/ OMSA, 18/ ERCA 
* 
*         EF     ERROR FLAG VALUE.
*         DMSA   DAYFILE ERROR SUMMARY MESSAGE ADDRESS. 
*         OMSA   ALTERNATE OUTPUT FILE ERROR MESSAGE ADDRESS. 
*         ERCA   ERROR COUNT ADDRESS. 
 
 
 TECA     BSS    0
          VFD    6/-1,18/IESA,18/PDED,18/PBCT  PARITY/BLOCK TOO LARGE 
          VFD    6/1,18/IESC,18/PDEF,18/BFCT   BAD FORMAT BLOCK ERROR 
 TECAL1   EQU    *-TECA 
          VFD    6/0,18/IESD,18/0,18/NZCT      NOISE BLOCKS PROCESSED 
          VFD    6/0,18/IESE,18/0,18/RSCT      RECORD SPLITS PROCESSED
 TECAL2   EQU    *-TECA 
* /---   BLOCK      ABT        00 000   83/04/18  15.21 
 ABT      SPACE  4,15 
**        ABT - ABORT ROUTINE.
* 
*         FLUSHES OUTPUT FILE BUFFER.  FLUSHES ALTERNATE OUTPUT FILE
*         BUFFER, IF NECESSARY.  ISSUES DAYFILE MESSAGES. 
* 
*         ENTRY  (B5) = FWA MESSAGE, IF ENTRY AT *ABT4*.
* 
*         USES   A - 1, 2, 6. 
*                B - 2. 
*                X - 1, 2, 6. 
* 
*         CALLS  CIO=, IES, MSG=, SNM, SYS=.
 
 
 ABT4     SX6    B5+         SAVE ABORT MESSAGE ADDRESS 
          SA1    I           SET NAME IN MESSAGE
          MX2    42 
          SA6    ABTA 
          BX1    X2*X1
          SB2    1RX
          RJ     SNM
*         EQ     ABT
 
 ABT      SA1    SK 
          NZ     X1,ABT2     IF SKIP SET
          SA1    O+CWF
          ZR     X1,ABT1     IF CONTROL WORDS DISABLED ON OUTPUT
          WRITECW O          FLUSH OUTPUT BUFFER
          EQ     ABT2        ABORT
 
 ABT1     WRITER O           FLUSH OUTPUT BUFFER
 
 ABT2     SA1    EL 
          ZR     X1,ABT3     IF EXTENDED ERROR PROCESSING NOT IN EFFECT 
          WRITER L           FLUSH ALTERNATE OUTPUT FILE BUFFER 
 ABT3     RECALL I           FORCE 1MT ERROR MESSAGES TO DAYFILE FIRST
          RJ     IES         ISSUE ERROR SUMMARY MESSAGES 
          SA2    ABTA        ISSUE ABORT MESSAGE
          MESSAGE X2,0
          ABORT 
 
 
 ABTA     CON    ABTB        ABORT MESSAGE ADDRESS
 
 ABTB     DATA   C* ERROR LIMIT EXCEEDED.*
 ABTC     DATA   C* RECORD TOO LARGE ON XXXXXXX.* 
 ABTD     DATA   C* UNRECOVERABLE ERROR ON XXXXXXX.*
* /---   BLOCK      DRN        00 000   83/03/30  20.17 
 DRN      SPACE  4,15 
**        DRN - DISPLAY RECORD NAME.
* 
*         ENTRY  (X2) = FWA RECORD.  IF (X2) .LT. 0, IT IS THE
*                     COMPLEMENT OF FWA RECORD IN INPUT CIO BUFFER. 
*                (X1) = FWA RECORD, IF ZERO LENGTH RECORD.
* 
*         EXIT   (RC) = UPDATED RECORD COUNT. 
* 
*         USES   A - 1, 2, 3, 6, 7. 
*                X - 1, 2, 3, 6, 7. 
* 
*         CALLS  MSG=.
 
 
 DRN      SUBR               ENTRY/EXIT 
          SA3    RC          INCREMENT RECORD COUNT 
          SX7    B1 
          IX6    X3+X7
          PL     X2,DRN1     IF NOT DISPLAY FROM CIO BUFFER 
          IX7    X2-X7
          BX2    -X2
 DRN1     IX1    X1-X2
          SA6    A3 
          ZR     X1,DRN2     IF ZERO LENGTH RECORD
          SA1    X2          GET RECORD NAME
          MX6    12 
          BX6    X6*X1
          LX6    12 
          SX6    X6-7700B 
          NZ     X6,DRN2     IF NOT 77 TABLE
          SA3    I+4
          SA1    A1+B1
          SX3    X3 
          PL     X7,DRN2     IF NOT DISPLAY FROM CIO BUFFER 
          SA2    I+1
          IX6    X3+X7       CHECK FOR WRAP AROUND
          NZ     X6,DRN2     IF NO WRAP AROUND
          SA1    X2 
 DRN2     MX7    42 
          BX7    X7*X1
          SA7    DRNA+1      ENTER NAME IN MESSAGE
          MESSAGE A7-B1,1    DISPLAY RECORD NAME
          EQ     DRNX        RETURN 
 
 
 DRNA     DATA   10H  COPYING 
          CON    0,0
* /---   BLOCK      END        00 000   85/07/25  15.39 
 END      SPACE  4,15 
**        END - END ROUTINE.
* 
*         FLUSHES OUTPUT BUFFER, IF NECESSARY.  FLUSHES ALTERNATE 
*         OUTPUT FILE BUFFER, IF NECESSARY.  ISSUES DAYFILE MESSAGES. 
* 
*         ENTRY  AT *END5*, IF EOI ENCOUNTERED BEFORE COPY COMPLETE.
* 
*         EXIT   TO *VFY*, IF VERIFY REQUESTED. 
* 
*         USES   A - 1, 2, 6. 
*                X - 1, 2, 6. 
* 
*         CALLS  CIO=, IES, MSG=, SYS=. 
 
 
 END5     SX6    ENDC        *EOI ENCOUNTERED* OR *FILE NOT FOUND*
          SA6    ENDA 
*         EQ     END
 
 END      SA1    SK 
          NZ     X1,END2     IF SKIP SET
          RECALL O
          SA1    O+2         CHECK *IN* = *OUT* 
          SA2    A1+B1
          IX1    X1-X2
          ZR     X1,END2     IF OUTPUT BUFFER EMPTY 
          SA2    O+CWF
          ZR     X2,END1     IF CONTROL WORD WRITE DISABLED 
          WRITECW O          FLUSH OUTPUT BUFFER
          EQ     END2        ISSUE COMPLETION MESSAGE 
 
 END1     WRITE  O           FLUSH OUTPUT BUFFER
 END2     SA1    EL 
          ZR     X1,END3     IF EXTENDED ERROR PROCESSING NOT IN EFFECT 
          WRITER L           FLUSH ALTERNATE OUTPUT FILE BUFFER 
 END3     RECALL I           FORCE 1MT ERROR MESSAGES TO DAYFILE FIRST
          RECALL O
          RECALL L
          RJ     IES         ISSUE ERROR SUMMARY MESSAGES 
          SA2    ENDA        ISSUE ENDING MESSAGE 
          MESSAGE X2,0
*          SA1    VF
*          NZ     X1,VFY      IF VERIFY REQUESTED 
          ZR     X0,END4     IF NO WARNING MESSAGES ISSUED
          MESSAGE ENDE,3     * CHECK DAYFILE FOR ERRORS.* 
 END4     ENDRUN
 
 
 ENDA     CON    ENDB        ENDING MESSAGE ADDRESS 
 
 ENDB     DATA   C* COPY COMPLETE.* 
 ENDC     DATA   C* EOI ENCOUNTERED.* 
*         DATA   C* FILE NOT FOUND - LFN.*
          BSS    1           ALLOW ROOM FOR *FILE NOT FOUND* MESSAGE
 ENDD     DATA   C* EOF ENCOUNTERED.* 
 ENDE     DATA   C* CHECK DAYFILE FOR ERRORS.*
 
* /---   BLOCK      IES        00 000   83/03/30  20.18 
 IES      SPACE  4,10 
**        IES - ISSUE ERROR SUMMARY MESSAGES. 
* 
*         EXIT   (X0) = NUMBER OF ERROR SUMMARY MESSAGES ISSUED.
* 
*         USES   A - 1, 2, 6. 
*                B - 5, 6, 7. 
*                X - 0, 1, 2, 6.
* 
*         CALLS  INM, MSG=. 
 
 
 IES      SUBR               ENTRY/EXIT 
          SB6    B0 
          BX0    X0-X0
          SB7    TECAL2 
 IES1     GE     B6,B7,IESX  IF END OF ERROR COUNTS 
          SA2    TECA+B6
          SB6    B6+B1
          SA1    X2 
          ZR     X1,IES1     IF NO ERRORS OF THIS TYPE OCCURRED 
          AX2    36 
          SX0    X0+B1
          SB5    X2+
          RJ     INM         INSERT NUMBER IN MESSAGE 
          MESSAGE B5,3       ISSUE MESSAGE TO USERS DAYFILE 
          EQ     IES1        CONTINUE ERROR SUMMARY PROCESSING
 
 
 IESA     DATA   C* XXXXXXXXXX PARITY/BLOCK TOO LARGE ERRORS.*
 IESC     DATA   C* XXXXXXXXXX BAD FORMAT BLOCKS.*
 IESD     DATA   C* XXXXXXXXXXXXXXX NOISE BLOCKS PADDED.* 
 IESE     DATA   C* XXXXXXXXXX RECORD SPLITS OCCURRED.* 
* /---   BLOCK      INM        00 000   83/03/30  20.19 
 INM      SPACE  4,15 
**        INM - INSERT NUMBER IN MESSAGE. 
* 
*         ENTRY  (B5) = FWA MESSAGE TO BE ISSUED. 
*                (X1) = NUMBER TO BE CONVERTED FOR MESSAGE. 
* 
*         EXIT   NUMBER CONVERTED TO DECIMAL DISPLAY AND ENTERED INTO 
*                     MESSAGE.
* 
*         USES   B - 2. 
*                X - 1. 
* 
*         CALLS  CDD, SNM.
 
 
 INM      SUBR               ENTRY/EXIT 
          RJ     CDD         CONVERT NUMBER TO DECIMAL DISPLAY
          SB2    B2-B1       CLEAR BLANK FILL 
          MX1    1
          AX1    B2 
          BX1    X1*X4
          SB2    1RX
          RJ     SNM         ENTER NUMBER IN MESSAGE
          EQ     INMX        RETURN 
* /---   BLOCK      PDE        00 000   83/03/30  20.19 
 PDE      SPACE  4,15 
**        PDE - PROCESS DATA BLOCK ERROR. 
* 
*         ENTRY  (B3) = 0, IF PARITY OR BLOCK TOO LARGE ERROR.
*                     = 1, IF DATA ERROR. 
* 
*         EXIT   IF BLOCK ERROR FLAG NOT ALREADY SET, PARITY/BLOCK
*                     TOO LARGE, OR DATA ERROR COUNT INCREMENTED, AND 
*                     IF ERROR LIMIT NONZERO, ERROR MESSAGE ISSUED TO 
*                     ALTERNATE OUTPUT FILE.
*                TO *ABT*, IF ERROR LIMIT EXCEEDED. 
* 
*         USES   A - 1, 2, 3, 4, 6, 7.
*                B - 2, 3, 5, 7.
*                X - 1, 2, 3, 4, 6, 7.
* 
*         CALLS  INM, SNM, SYS=, WTC=, WTW=.
 
 
 PDE      SUBR               ENTRY/EXIT 
          SA1    ERRF 
          SA2    TECA+B3
          NZ     X1,PDEX     IF BLOCK ERROR FLAG ALREADY SET
          SA3    X2          INCREMENT CORRESPONDING ERROR COUNT
          SX6    B1 
          IX7    X3+X6
          SA4    EL 
          AX2    18 
          SA7    A3 
          ZR     X4,ABT      IF ZERO ERROR LIMIT
          SX7    X2          SAVE ERROR MESSAGE ADDRESS 
          AX2    36 
          SA7    PDEA 
          BX6    X2 
          SA6    A1          SET BLOCK ERROR FLAG 
          SB2    TECAL1-1 
          SX6    -B1
* /---   BLOCK      PDE        00 000   83/03/30  20.19 
 PDE1     SA1    TECA+B2     CALCULATE TOTAL ERROR COUNT
          SA2    X1 
          SB2    B2-B1
          IX6    X6+X2
          GE     B2,PDE1     IF MORE ERROR COUNTS 
          BX7    X4 
          NG     X4,PDE2     IF UNLIMITED ERROR PROCESSING
          IX7    X6-X4
 PDE2     SA7    A7+B1       SAVE ABORT INDICATOR 
          NZ     X6,PDE3     IF NOT FIRST ERROR 
          WRITE  L,*         PRESET STANDARD WRITE
          WRITEW L,PDEC,B1+B1  WRITE HEADER LINE
          WRITEW X2,CCDR,8
          DATE   PDEC 
          CLOCK  PDEC+1 
          WRITEW X2,PDEC,5
 PDE3     SA2    PDEA        GET ERROR MESSAGE ADDRESS
          SB3    B0 
          SB2    X2 
          SB7    PDECL
          SB5    PDEC 
 PDE4     SA2    B2+B3       MOVE MESSAGE TO BUFFER 
          BX6    X2 
          SA6    B5+B3
          SB3    B3+B1
          LT     B3,B7,PDE4  IF MORE WORDS IN MESSAGE 
          SA1    BC          BLOCK COUNT
          RJ     INM         INSERT NUMBER IN MESSAGE 
          WRITEC L,B5 
          SA1    PDEB        GET ABORT INDICATOR
          NG     X1,PDEX     IF ERROR LIMIT NOT REACHED 
          EQ     ABT         ABORT
 
 
 PDEA     CON    0           ERROR MESSAGE ADDRESS
 PDEB     CON    0           ABORT INDICATOR
 
 PDECL    EQU    6
 PDEC     BSS    0           HEADER LINE AND MESSAGE BUFFER 
          CON    10H1- ERROR S
          CON    10HUMMARY -
          BSSZ   PDECL-2
 
 PDED     DATA   C* PARITY/BLOCK TOO LARGE ERROR IN BLOCK XXXXXXXXXX.*
 PDEF     DATA   C* ILLEGAL FORMAT IN BLOCK XXXXXXXXXX.*
* /---   BLOCK      PEF        00 000   83/03/30  20.19 
 PEF      SPACE  4,20 
**        PEF - PROCESS END OF FILE.
* 
*         GENERATES AN EOF ON OUTPUT WITH OR WITHOUT CONTROL WORDS
*         UNLESS ONE OF THE FOLLOWING CONDITIONS EXIST -
*                1.  SKIP FLAG IS SET.
*                2.  PO=M OPTION (SKIP EOF WRITE) IS SELECTED.
*                3.  LAST DOUBLE EOF (FOR TC=EOD COPY) IS ENCOUNTERED.
*                4.  FOR A COPY WITH A FILE COUNT SPECIFIED (COPYBF 
*                    OR COPY/TCOPY WITH TC=EOF PARAMETER), WHEN EOI 
*                    IS ENCOUNTERED ON INPUT AND NO DATA TRANSFER HAS 
*                    OCCURRED SINCE PREVIOUS EOF. 
*         THE COPY COUNT IS DECREMENTED WHEN APPLICABLE.
* 
*         ENTRY  (X0) .LT. 0, IF EOI ENCOUNTERED. 
*                (X5) = 0, IF EMPTY FILE ENCOUNTERED. 
* 
*         EXIT   (X0) .LT. 0, IF EOI ENCOUNTERED. 
*                (CT) = 0, IF COPY COMPLETE.
* 
*         USES   A - 1, 2, 3, 4, 6. 
*                B - 2. 
*                X - 0, 1, 2, 3, 4, 6.
* 
*         CALLS  CIO=, MSG=, WTW=.
 
 
 PEF3     WRITEF O           GENERATE EOF AND FLUSH BUFFER
 PEF4     SA1    TC          GET TERMINATION CONDITION
          NG     X0,PEFX     IF EOI ENCOUNTERED 
* /---   BLOCK      PEF        00 000   83/03/30  20.19 
          NG     X1,PEFX     IF COPY TO EOI 
          SB2    X0+
          NZ     X1,PEF5     IF COPY TO FILE COUNT
          EQ     B2,B1,PEFX  IF EMPTY FILE NOT ENCOUNTERED
 PEF5     SX1    B1          DECREMENT COPY COUNT 
          SA2    CT 
          IX6    X2-X1
          SA6    A2+
 
 PEF      SUBR               ENTRY/EXIT 
          SA2    TC 
          SA4    SK 
          SA1    BC          INCREMENT BLOCK COUNT
          SA3    CT 
          SB2    X2 
          NG     X0,PEF2     IF EOI ENCOUNTERED 
          SX0    B1 
          IX6    X1+X0
          SA6    A1 
          NZ     X5,PEF1     IF DATA TRANSFERRED
          NZ     B2,PEF1     IF NOT COPY TO DOUBLE EOF
          SA2    RC 
          IX1    X3-X0
          ZR     X2,PEF1     IF NO RECORDS COPIED 
          SX0    B1+B1
          NZ     X1,PEF1     IF NOT LAST DOUBLE EOF 
          SA1    =10H SKIPPING   SKIP LAST EOF
          BX0    X0-X0
          LX6    X1 
          SA6    PEFB 
 PEF1     SA1    RC          ADVANCE RECORD COUNT 
          SX6    B1 
          IX6    X1+X6
          SA6    A1+
          MESSAGE  PEFB,1    DISPLAY EOF MESSAGE
          ZR     X0,PEF5     IF LAST DOUBLE EOF ENCOUNTERED 
          SA3    SEWI        SKIP EOF WRITE INDICATOR 
          NZ     X3,PEF4     IF PO=M OPTION SELECTED
          SA2    O+CWF
          NZ     X4,PEF4     IF SKIP SET
          ZR     X2,PEF3     IF CONTROL WORD WRITE DISABLED 
          WRITEW O,PEFA,B1+B1 WRITE CONTROL WORD EOF
          EQ     PEF4        DECREMENT COPY COUNT 
 
 PEF2     NZ     X4,PEFX     IF SKIP SET
          LE     B2,PEFX     IF NOT COPY TO FILE COUNT
          ZR     X5,PEFX     IF NO DATA TRANSFERRED 
          EQ     PEF1        WRITE EOF
 
 
 PEFA     VFD    60/0        CONTROL WORD EOF 
          VFD    12/17B,48/0
 
 PEFB     DATA   C*  COPYING EOF.*
* /---   BLOCK      COMMONS    00 000   83/04/20  09.43 
          SPACE  4,10 
**        COMMON DECKS. 
 
 
*CALL     COMCCDD 
 WRIF$    EQU    1           SELECT *RE-ISSUE CURRENT WRITE*
*CALL     COMCCIO 
*CALL     COMCRDW 
*CALL     COMCSFN 
*CALL     COMCSNM 
*CALL     COMCSYS 
*CALL     COMCWTC 
*CALL     COMCWTW 
* /---   BLOCK      BUFFERS    00 000   83/04/20  11.38 
          SPACE  4,10 
**        COPY/COPYBF/COPYEI BUFFERS. 
 
 
          USE    BUFFERS
 LBUF     BSS    0           ALTERNATE OUTPUT FILE CIO BUFFER 
 
*         SINGLE BUFFER COPY ALLOCATIONS. 
 
 SBUF     EQU    LBUF+LBUFL  SINGLE CIO BUFFER
 SRFL     EQU    SBUF+SBUFL  FL FOR SINGLE BUFFER COPY
 
*         DOUBLE BUFFER COPY ALLOCATIONS. 
 
 BUF1     EQU    LBUF+LBUFL  WORKING STORAGE BUFFER 
 IBUF1    EQU    BUF1+BUFL   INPUT FILE CIO BUFFER
 OBUF1    EQU    IBUF1+FBUFL OUTPUT FILE CIO BUFFER 
 RFL1     EQU    OBUF1+FBUFL FL FOR DOUBLE BUFFER COPY
*          ERRNG  TCOPY-BUF1  IF LBUF OVERFLOWS INTO TCOPY
* /---   BLOCK      CIPHER     00 000   85/07/30  16.41 
          TITLE  CIPHER - MAIN LOOP.
 CIPHER   SPACE  4,15 
**        CIPHER - MAIN LOOP - COPY ALL RECORDS FROM ONE
*                FILE TO ANOTHER AND ENCRYPT/DECRYPT. 
* 
*         EXIT   TO *END*, IF COPY COMPLETE.
*                TO *END5*, IF EOI ENCOUNTERED. 
 
 
 CIPHER   BSS    0
          RJ     PRS         PRESET PROGRAM 
 
 CBR1     BSS    0
*         INITIALIZE LINEAR CONGRUENTIAL CIPHER (PSEUDO-
*         RANDOM SEQUENCE) FOR EACH RECORD, SO THEY CAN BE
*         READ IN ANY ORDER.  ALSO, ADVANCE ONE OF THE
*         SEEDS TO PREVENT THEM FROM MOVING IN LOCKSTEP.
          SA1    KEY
          SX2    65539
          BX6    X1 
          DX7    X1*X2
          SA6    S1TAB
          SA7    S2TAB
          SA2    =31167285
          SX3    69069
          SB6    STABLTH
 CBR2     BSS    0
          DX6    X6*X2
          SA6    A6+B1
          DX7    X7*X3
          SA7    A7+B1
          SB6    B6-B1
          GT     B6,B0,CBR2 
 
          READ   I           BEGIN READ 
          RECALL O
          WRITE  O,*         PRESET WRITE FUNCTION
          READW  I,BUF,RBFL 
          RJ     CPR         COPY RECORD
          NG     X0,END5     IF EOI ENCOUNTERED 
          EQ     CBR1        -- KEEP COPYING UNTIL EOI
* /---   BLOCK      CPR        00 000   85/07/29  13.07 
          TITLE  RECORD COPY ROUTINES.
 CPR      SPACE  4,15 
**        CPR - COPY RECORD.
* 
*         ENTRY  (X1) = FIRST BLOCK READ STATUS.
*                (B6) = LWA+1 DATA TRANSFERRED TO WORKING BUFFER. 
* 
*         EXIT   (X0) .LT. 0, IF EOI. 
*                (X0) = 0, IF EOR.
*                (X0) .GT. 0, IF EOF. 
* 
*         USES   A - 1, 2.
*                X - 0, 1, 2, 5.
* 
*         CALLS  CIO=, DRN, MSG=, RDW=, WTW=. 
 
 
 CPR4     MESSAGE PEFB,1     DISPLAY EOF MESSAGE
          SA1    RC          ADVANCE RECORD COUNT 
          SX0    B1+         SET EOF STATUS 
          SA2    SK 
          IX6    X1+X0
          SA6    A1 
          NZ     X2,CPRX     IF SKIP SET
          WRITEF O           GENERATE EOF 
 
 CPR      SUBR               ENTRY/EXIT 
          SX0    X1+B1
          BX5    X1 
          NG     X0,CPRX     IF EOI ENCOUNTERED 
          ZR     X0,CPR4     IF EOF ENCOUNTERED 
          SX2    BUF
          RJ     DRN         DISPLAY RECORD NAME
 CPR1     SA2    SK 
          NZ     X2,CPR2     IF SKIP SET
          SB7    BUF
          RJ     CRYPT       *** ENCRYPT/DECRYPT BUFFER *** 
          SB7    B6-BUF 
          WRITEW O,BUF,B7 
 CPR2     SX0    B0+         SET EOR STATUS 
          NZ     X5,CPR3     IF EOR 
          READW  I,BUF,RBFL  READ NEXT CHUNK OF INPUT 
          BX5    X1 
          PL     X1,CPR1     IF NOT EOF OR EOI
          SX0    X1+B1       CHECK FOR EOI
          PL     X0,CPR4     IF EOF 
 CPR3     SA2    SK 
          NZ     X2,CPRX     IF SKIP SET
          WRITER O           END RECORD 
          EQ     CPRX        RETURN WITH EOR OR EOI STATUS
* /---   BLOCK      CRYPT      00 000   85/08/30  15.25 
 CRYPT    TITLE  CRYPT - ENCRYPT/DECRYPT A BUFFER.
**        CRYPT - ENCRYPT/DECRYPT A BUFFER. 
* 
*         USES A LINEAR CONGRUENTIAL CIPHER (PSEUDO-RANDOM
*         SEQUENCE) WHERE THE KEY IS THE INITIAL SEED VALUE.
*         THE RESULT IS 'X'O'RED INTO THE PLAINTEXT.  SINCE 
*         THE RESULT OF THE DOUBLE-PRECISION MULTIPLY IS
*         ONLY 48 BITS, TWO SUCH OPERATIONS ARE DONE IN 
*         PARALLEL TO COVER THE ENTIRE 60 BIT WORD. 
* 
*         BACKGROUND'; 'KNUTH, 'VOL. 2, PP 1-33.  THIS IS 
*         ALGORITHM 'M BY 'MAC'LAREN AND 'MARSAGLIA ['J'A'C'M 12
*         (1965), 83-89; 'C'A'C'M 11 (1968), 759].  'I CHOSE IT 
*         OVER ALGORITHM 'B BY 'BAYS AND 'DURHAM BECAUSE 'I 
*         HAVE TO PRODUCE TWO 48-BIT QUANTITIES TO COVER THE
*         THE ENTIRE WORD AND 'I FELT THAT USING ONE AS THE 
*         INDEX INTO THE SHUFFLE TABLE OF THE OTHER PREVENTS
*         THE TOP BITS OF THE WORD FROM BEING RELATED TO THE
*         SLOT INDEX. 
* 
*         THE TWO MULTIPLIERS'; ONE WAS THE ONE SUGGESTED 
*         IN 'KNUTH AS IDEAL FOR 48-BITS OF PRECISION, THE
*         OTHER WAS THE ',BEST OF ALL POSSIBLE MULTIPLIERS.', 
*         THE TWO MULTIPLIERS ARE RELATIVELY PRIME';
*                69069 = 3*7*11*13*23 
*             31167285 = 3*3*3*5*19*29*419
* 
*         A PSEUDO-RANDOM SEQUENCE ALONE IS VULNERABLE TO 
*         ATTACK BY KNOWN/CHOSEN PLAINTEXT, SO 'I HAVE ALSO 
*         MODIFIED THIS ALGORITHM TO RUN AS A STREAM CIPHER 
*         BY 'X'O'RING SOME OF THE DATA INTO THE NEXT SEED. 
* 
*         ENTRY  (B6) = LWA+1 OF THE DATA TO BE CIPHERED. 
*                (B7) = FWA OF DATA TO BE CIPHERED. 
* 
*         USES   A - 2, 3, 4, 6, 7. 
*                X - 0, 2, 3, 4, 6, 7.
*                B - 2, 3, 7. 
* 
* /---   BLOCK      CRYPT      00 000   85/08/13  11.05 
 CRYPT    PS
          LE     B6,B7,CRYPT  -- NOTHING WAS READ IN
          SB3    42D
          SA3    SEED1       X3 = 'X(N) 
          SA4    SEED2       X4 = 'X(N)'7 
          SA2    =31167285
          BX0    X2          X0 = A 
 
 CRYPT1   BSS    0
          DX3    X3*X0       'X(N+1) _ ('X(N) * A) MOD 2**48
          SX6    69069       X6 = A'7 
          DX4    X4*X6       'X(N+1)'7 _('X(N)'7 * A'7) MOD 2**48 
          AX2    X3,B3       J'7 _ 'X(N+1) DIV (2**42)
          SA2    S2TAB+X2    'Y'7 _ 'V[J'7]'7       <READ MEMORY> 
          BX7    X4          'X(N+1)'7   <TO STORAGE REGISTER>
          SA7    A2          'V[J'7]'7 _ 'X(N+1)'7 <STORE IN MEM> 
          BX6    X2          X6 = 'Y'7         <FOR USE LATER>
          AX2    X4,B3       J _ 'X(N+1)'7 DIV (2**42)
          BX7    X3          'X(N+1)    <TO STORAGE REGISTER> 
          SA2    S1TAB+X2    'Y _ 'V[J]          <READ MEMORY>
          SA7    A2          'V[J] _ 'X(N+1)    <STORE IN MEM>
          BX7    X4          X7 _ COPY OF 'X(N+1)'7 
          AX7    44D         X7 _ 'X(N+1)'7 DIV (2**44) 
          SB2    X7+19       B2 NOW PSEUDO-RANDOM (19..34)
          LX2    B2          LEFT SHIFT (END-AROUND) 'Y BY B2 
          BX6    X2-X6       X6 = 'Y XOR 'Y'7 
          SA2    B7          READ NEXT WORD FROM BUFFER 
          BX7    X2-X6       X7 = WORD XOR ('Y XOR 'Y'7)
          SB7    B7+B1       INCREMENT BUFFER ADDRESS 
          SA7    A2          STORE ENCRYPTED WORD IN BUFFER 
*                            CODE FOR STREAM CIPHER 
 CRYPTA   EQU    *O          ADDRESS OF  MXI JK  INSTRUCTION
 CRYPTAS  EQU    *P-15D      SHIFT FOR JK PORTION OF INSTR
          MX6    52B         MASK FOR LOW-ORDER BITS
 CRYPTB   EQU    *O          ADDRESS CONTAINING AND INSTR 
 CRYPTBS  EQU    *P-12D      SHIFT TO 'XJ IN  BXI -XK*XJ
          BX6    -X6*X0      X2 OR X7 REPLACES X0 IN *PRS*
          BX3    X3-X6       DEFLECT A FEW BITS IN 'X(N+1)
          BX4    X4-X6       DEFLECT A FEW BITS IN 'X(N+1)'7
* 
          LT     B7,B6,CRYPT1  -- IF NOT END OF BUFFER, LOOP
          BX6    X3 
          SA6    A3          STORE CURRENT 'X(N) IN MEMORY
          BX6    X4 
          SA6    A4          STORE CURRENT 'X(N)'7 IN MEMORY
          EQ     CRYPT
 
 
 KEY      EQU    ARGR+3      PLAY IT WHERE IT LIES
 STABLTH  EQU    100B        K
 S1TAB    BSS    STABLTH     'V[0..K-1] 
 SEED1    DATA   0           'X (INITIALLY SET TO 'V[K])
 S2TAB    BSS    STABLTH     'V'7[0..K-1] 
 SEED2    DATA   0           'X'7 (INITIALLY SET TO 'V[K]'7)
* /---   BLOCK      BUFFERS    00 000   83/03/30  19.21 
**        COMMON DECKS. 
 
 
*CALL     COMCSRT 
          SPACE  4,10 
**        COPYBR/COPYX BUFFERS. 
 
 
 BUF      BSS    0           WORKING STORAGE BUFFER 
 IBUF     EQU    BUF+RBFL    INPUT FILE CIO BUFFER
 OBUF     EQU    IBUF+FBUFL  OUTPUT FILE CIO BUFFER 
 RFL=     EQU    OBUF+FBUFL  FIELD LENGTH FOR COPYBR AND COPYX
* /---   BLOCK      NEW PRS    00 000   85/08/13  10.49 
          TITLE  PRESET.
**        PRS - PRESET FOR EXECUTION. 
* 
 
 PRS      SUBR               ENTRY/EXIT 
          SB1    1           (B1) = 1, THROUGHOUT PROGRAM 
          MX0    42D         MASK FOR FILE NAMES
          SA1    ACTR        ARGUMENT COUNT 
          SB7    X1 
          ZR     B7,PRS9     -- NO ARGUMENTS
 
*         PROCESS INPUT FILE NAME.
 
          R=     A5,ARGR     FIRST PARAM = INPUT FILE NAME
          SA2    I
          BX7    X0*X5
          SX3    X2 
          ZR     X7,PRS1     -- NO INPUT FILE 
          BX7    X7+X3
          SA7    A2          STORE NEW INPUT FILE NAME
 
*         PROCESS OUTPUT FILE NAME. 
 
 PRS1     BSS    0
          SB7    B7-B1       DECR ARG CNT 
          ZR     B7,PRS9     -- NO ARGS REMAINING, NO KEY 
          SA5    A5+B1       NEXT ARG = OUTPUT FILE NAME
          SA2    O
          BX7    X0*X5
          SX3    X2 
          ZR     X7,PRS2     -- NO OUTPUT FILE
          BX7    X7+X3
          SA7    A2          STORE NEW OUTPUT FILE NAME 
 
*         PROCESS ENCRYPT/DECRYPT FLAG
 
 PRS2     BSS    0
          SB7    B7-B1       DECR ARG CNT 
          ZR     B7,PRS9     -- NO ARGS LEFT, NO KEY
          SA5    A5+B1       NEXT ARG = ENCRYPT/DECRYPT 
          BX5    X0*X5       HOLD IT TO 7 CHARS 
          SA2    =7LENCRYPT 
          SA3    =7LDECRYPT 
          BX2    X2-X5
          BX3    X3-X5
          SX6    7           'XJ = 7 IF ENCRYPTING
          ZR     X2,PRS2.1   -- IF ARG WAS *ENCRYPT*
          SX6    2           'XJ = 2 IF DECRYPTING
          NZ     X3,PRS9.1   -- IF ARG WAS NOT *DECRYPT*
 PRS2.1   BSS    0
          LX6    CRYPTBS     SHIFT TO 'XJ IN  BXI -XK*XJ
          SA2    CRYPTB      READ WORD TO BE PLANTED
          BX6    X2+X6       UNION
          SA6    A2          STORE MODIFIED INSTRUCTION WD
 
* /---   BLOCK      NEW PRS    00 000   85/08/13  11.02 
*         PROCESS CIPHERING KEY.
 
          SB7    B7-B1       DECR ARG CNT 
          ZR     B7,PRS9     -- NO MORE ARGS, NO KEY
          SA5    A5+B1       NEXT ARG = CIPHERING KEY 
          MX3    48          MASK FOR 8 CHARS 
          BX1    X5*X3
          ZR     X7,PRS9     -- THE KEY IS ZERO 
          MX0    6           MASK FOR CHARACTER 
 PRS3     BX6    X1          X6 = LAST GOOD VALUE 
          LX1    54D         SHIFT NEXT CHAR
          BX2    X0*X1       MASK OFF TOP CHAR
          ZR     X2,PRS3     -- KEEP LOOPING IF NOT TOO FAR 
          CX7    X6          COUNT NUMBER OF BITS IN KEY
          SX3    32771D      INITIAL SCRAMBLE FOR LUCK
          DX6    X6*X3
          SA6    A5          SHOULD BE *KEY*
          SB7    A5-KEY      CHECK TO BE SURE A5=KEY
          NZ     B7,*+400000B 
          SA2    CRYPTA      READ WORD TO BE PLANTED
          MX6    -3B         RANGE OF 0..7
          BX7    -X6*X7 
          LX7    CRYPTAS     SHIFT TO JK IN  MXI JK 
          BX7    X7-X2       XOR TO FORM NEW MASK WIDTH 
          SA7    A2          STORE UPDATED WORD 
 
          SB7    4           NUMBER OF DELIMITERS BEFORE KEY
          SA3    COMMAS 
          SA4    NINES
          SA5    SPACES 
          MX0    6
          SA1    CCDR 
 
 PRS4     LX0    54D
          PL     X0,PRS5
          SA1    A1+B1
 PRS5     LE     B7,B0,PRS6  -- IF TERMINATING LINE 
          BX6    X0*X1       CURRENT CHAR 
          BX7    X0*X4       ',9',
          ZR     X6,PRS9     -- PREMATURE END-OF-LINE 
          IX7    X7-X6       ',9', - CURRENT CHAR 
          PL     X7,PRS4     -- NOT A DELIMITER 
          BX7    X0*X5       SPACE
          IX7    X7-X6       SPACE - CURRENT CHAR 
          ZR     X7,PRS4     -- IGNORE SPACES 
          BX1    -X0*X1      CLEAR OUT CHAR 
          BX7    X0*X3       COMMA
          BX1    X1+X7       REPLACE DELIMITER WITH COMMA 
          BX6    X1 
          SA6    A1 
          SB7    B7-B1       DECR DELIMITER COUNT 
          EQ     PRS4        -- GET NEXT CHAR 
 
 PRS6     BSS    0
          SA4    PERIODS
          BX1    -X0*X1      CLEAR CURRENT CHAR 
          BX4    X0*X4       ',.',
          BX6    X1+X4       CURRENT CHAR REPLACED W/.
 PRS7     BSS    0
          LX0    54D
          NG     X0,PRS8     -- LAST CHAR IN WORD 
          BX6    -X0*X6      CLEAR CHAR 
          EQ     PRS7 
 
 PRS8     BSS    0
          SA6    A1 
          MX6    0
          SA6    A1+B1       CLEAR ENTIRE WORD
 
          MESSAGE CCDR
 
* /---   BLOCK      NEW PRS    00 000   85/08/08  09.47 
          SA0    I           INPUT FILE 
          RJ     CDT         CHECK IF CONTROL WORDS ALLOWED 
          SA0    O           OUTPUT FILE
          RJ     CDT         CHECK IF CONTROL WORDS ALLOWED 
          RJ     SFM         SET FILE MODE
          RJ     CFN         CHECK FILE NAMES 
          RJ     CIC         CHECK INDETERMINATE COPY 
          SX7    0
          SA7    I+CWF       DISABLE CONTROL WORD READ
          SA7    O+CWF       DISABLE CONTROL WORD WRITE 
          EQ     PRSX        -- EXIT
 
 PRS9     BSS    0           NO KEY SPECIFIED 
          MESSAGE CCDR       SEND UNALTERED CONTROL CARD
          MESSAGE PRSA       NO KEY SPECIFIED 
          ABORT 
 
 PRS9.1   BSS    0           ENCRYPT/DECRYPT NOT SPECIFIED
          MESSAGE CCDR       SEND UNALTERED CONTROL CARD
          MESSAGE PRSB       ENCRYPT/DECRYPT NOT SPECIFIED
          ABORT 
 
 PRSA     DIS    ,* NO KEY SPECIFIED.*
 PRSB     DIS    ,* ENCRYPT/DECRYPT NOT SPECIFIED.* 
 
 NINES    DATA   0L9999999999 
 SPACES   DATA   10H
 COMMAS   DATA   10L,,,,,,,,,,
 PERIODS  DATA   10L..........
* /---   BLOCK      CDT        00 000   83/03/30  19.53 
 CDT      SPACE  4,15 
**        CDT - CHECK DEVICE TYPE.
* 
*         ENTRY  (A0) = FWA FET.
* 
*         EXIT   ((A0)+CWF) .NE. 0, IF CONTROL WORDS ALLOWED. 
*                ((A0)+SLF)  = -1, IF F FORMAT TAPE.
*                            = 1, IF S FORMAT TAPE. 
*                            = 2, IF L FORMAT TAPE. 
*                ((A0)+NSZ) = NOISE SIZE IN FRAMES, IF TAPE FILE. 
*                ((A0)+TRK) = TRACK AND LABEL TYPE, IF TAPE FILE. 
*                ((A0)+PRU) = PRU SIZE, IF F FORMAT TAPE. 
*                WARNING MESSAGE ISSUED IF INPUT FILE NOT FOUND.
* 
*         USES   A - 1, 2, 3, 6, 7. 
*                B - 2, 5.
*                X - 0, 1, 2, 3, 6, 7.
* 
*         CALLS  GPS, SNM.
* 
*         MACROS FILINFO, MESSAGE.
 
 
 CDT4     RJ     GPS         CHECK FOR TERMINAL FILE
          SA3    A0+B1       GET DEVICE TYPE
          MX2    -11
          LX3    12 
          BX3    -X2*X3 
          SX7    X3-2RTT
          SX2    A0-I 
          ZR     X7,CDTX     IF TERMINAL FILE 
          NZ     X2,CDT5     IF NOT INPUT FILE
          SA1    A0          GET INPUT FILE NAME
          SB5    -CDTA       * FILE NOT FOUND - LFN.* 
          BX1    X0*X1
          SB2    1RX
          SB3    ENDC        REPLACE * EOI ENCOUNTERED.* MESSAGE
          RJ     SNM         SET NAME IN MESSAGE
 CDT5     SX7    B1+         ENABLE CONTROL WORDS 
          SA7    A0+CWF 
 
 CDT      SUBR               ENTRY/EXIT 
          SA1    A0          SET FILE NAME IN PARAMETER BLOCK 
          MX0    42 
* /---   BLOCK      CDT        00 000   83/03/30  19.53 
          SA2    CDTB 
          BX1    X0*X1
          SX2    X2 
          BX6    X1+X2
          SA6    A2 
          FILINFO  CDTB      GET FILE INFORMATION 
          SA1    CDTB+1      GET DEVICE TYPE AND STATUS 
          BX3    X1 
          AX3    48 
          ZR     X3,CDT4     IF FILE NOT FOUND
          SX2    X3-2RNE
          LX1    59-15
          NG     X1,CDT5     IF FILE ON MASS STORAGE
          LX1    59-19-59+15
          LX7    X1,B1
          ZR     X2,CDT5     IF NULL EQUIPMENT
          NG     X1,CDT2     IF 9-TRACK TAPE
          PL     X7,CDTX     IF NOT 7-TRACK TAPE
 CDT2     MX6    2
          SA2    CDTB+FIPBL+1  GET LABEL TYPE 
          MX0    -6 
          LX2    -12
          BX6    X6*X1       GET TRACK BITS 
          SA3    A2-B1       GET TAPE FORMAT
          BX2    -X0*X2 
          SA1    A2+B1       GET BLOCK SIZE AND NOISE SIZE
          LX3    -6 
          BX6    X6+X2
          LX1    -6 
          SA6    A0+TRK      SAVE TRACK BITS AND LABEL TYPE 
          BX3    -X0*X3 
          BX6    -X0*X1 
          SA6    A0+NSZ      SAVE NOISE SIZE
          SX2    X3-/MTX/TFS
          SX7    B1 
          ZR     X2,CDT3     IF S TAPE
          SX7    B1+B1
          SX2    X3-/MTX/TFL
          ZR     X2,CDT3     IF L TAPE
          SX7    -1 
          SX2    X3-/MTX/TFF
          NZ     X2,CDT5     IF NOT F TAPE
          LX1    -18
          SX6    X1 
          SA6    A0+PRU      SET F TAPE PRU SIZE
 CDT3     SA7    A0+SLF      SET S/L/F TAPE INDICATOR 
          EQ     CDT5        SET CONTROL WORD FLAG
 
 
 CDTA     DATA   C* FILE NOT FOUND - XXXXXXX.*
 
 CDTB     VFD    42/0,6/CDTBL,12/1  *FILINFO* PARAMETER BLOCK 
          BSS    FIPBL-1
          CON    FMTK        TAPE FORMAT KEYWORD
          CON    LTYK        TAPE LABEL TYPE KEYWORD
          CON    BSZK        TAPE BLOCK SIZE, NOISE SIZE KEYWORD
 CDTBL    EQU    *-CDTB 
* /---   BLOCK      CFN        00 000   83/03/30  19.54 
 CFN      SPACE  4,10 
**        CFN - CHECK FILE NAMES. 
* 
*         EXIT   SKIP FLAG SET IF INPUT FILE NAME SAME AS OUTPUT
*                     FILE NAME.
*                TO *PER1*, IF ALTERNATE OUTPUT FILE NAME CONFLICT. 
* 
*         USES   A - 1, 2, 3, 4, 6, 7.
*                B - 5. 
*                X - 0, 1, 2, 3, 4, 6, 7. 
 
 
 CFN      SUBR               ENTRY/EXIT 
          SA1    I           COMPARE FILE NAMES 
          SA4    O
          MX0    42 
          BX1    X0*X1
          SA3    L
          BX4    X0*X4
          SA2    =10H SKIPPING   SET SKIP FLAG AND MESSAGE
          BX7    X1-X4
          LX6    X2 
          NZ     X7,CFN1     IF INPUT .NE. OUTPUT FILE NAME 
          SX7    B1 
          SA6    DRNA 
          SA7    SK 
          SA6    PEFB 
 CFN1     SA2    SEWI        SKIP EOF WRITE INDICATOR 
          SB5    PERE        * FILE NAME CONFLICT.* 
          ZR     X2,CFN2     IF PO=M NOT SELECTED 
          SA6    PEFB 
 CFN2     SX6    A3          SET ALTERNATE OUTPUT FILE POINTER
          BX3    X0*X3
          SX7    A4          SET OUTPUT FILE POINTER
          BX6    X6+X3
          SA2    EL          CHECK IF ALTERNATE OUTPUT FILE TO BE USED
          BX7    X7+X4
          R=     A6,ARGR
          BX1    X1-X3
          SA7    A6+B1
          ZR     X2,CFNX     IF ERROR LIMIT = 0 
          ZR     X1,PER1     IF ALTERNATE OUTPUT = INPUT FILE NAME
          BX7    X4-X3
          ZR     X7,PER1     IF ALTERNATE OUTPUT = OUTPUT FILE NAME 
          EQ     CFNX        RETURN 
* /---   BLOCK      CIC        00 000   83/03/30  19.54 
 CIC      SPACE  4,15 
**        CIC - CHECK FOR INDETERMINATE COPY. 
* 
*         EXIT   WARNING MESSAGE ISSUED IF S, L, OR F TAPE COPY.
*                L TAPE PRU SIZE LIMITED IF COPYBF OR COPYEI CALL.
*                TO *PER*, IF F TAPE PRU SIZE .GT. WORKING BUFFER SIZE. 
* 
*         USES   A - 1, 2, 3, 6.
*                B - 2, 3, 4. 
*                X - 0, 1, 2, 3, 6. 
* 
*         CALLS  SYS=.
 
 
 CIC      SUBR               ENTRY/EXIT 
          SA1    I+SLF
          SA2    O+SLF
          NZ     X1,CIC1     IF S, L, OR F TAPE INPUT 
          ZR     X2,CICX     IF OUTPUT NOT S, L, OR F TAPE
 CIC1     SA3    CRI         GET CALLING ROUTINE INDICATOR
          SB4    X2 
          SB2    X3 
          SB3    X1+
          LE     B2,CIC5     IF COPYBR OR COPYX CALL
          SX6    BUFL-3      LIMIT L TAPE PRU SIZE TO WORKING BUFFER
          LE     B3,B1,CIC2  IF INPUT NOT L TAPE
          SA6    I+6         SET MLRS FIELD IN INPUT FET
 CIC2     LE     B4,B1,CIC3  IF OUTPUT NOT L TAPE 
          SA6    O+6         SET MLRS FIELD OF OUTPUT FET 
 CIC3     SB5    PERB        * BLOCK SIZE TOO LARGE ON LFN.*
          GE     B3,CIC4     IF INPUT NOT F TAPE
          SA2    I+PRU       GET INPUT FILE PRU SIZE
          IX2    X6-X2
          SA1    I
          NG     X2,PER      IF F TAPE PRU SIZE EXCEEDS WORKING BUFFER
 CIC4     GE     B4,CIC5     IF OUTPUT NOT F TAPE 
          SA3    O+PRU       GET OUTPUT FILE PRU SIZE 
          SA1    O
          IX3    X6-X3
          NG     X3,PER      IF F TAPE PRU SIZE EXCEEDS WORKING BUFFER
 CIC5     MESSAGE CICA,3     * COPY INDETERMINATE.* 
          EQ     CICX        RETURN 
 
 
 CICA     DATA   C* COPY INDETERMINATE.*
* /---   BLOCK      GPS        00 000   83/03/30  19.56 
 GPS      SPACE  4,10 
**        GPS - GET PRU SIZES.
* 
*         ENTRY  (A0) = FWA FET.
* 
*         EXIT   (A0+PRU) = PRU SIZE, IF NOT PREVIOUSLY SET.
* 
*         USES   A - 1, 4, 6. 
*                X - 1, 4, 6. 
* 
*         CALLS  CIO=.
 
 
 GPS      SUBR               ENTRY/EXIT 
          SA4    A0+PRU 
          PL     X4,GPSX     IF PRU SIZE ALREADY SET
          OPEN   A0,READNR,R
          SA1    A0+4        GET PRU SIZE 
          LX1    -18
          SX6    X1 
          SA6    A4 
          EQ     GPSX        RETURN 
* /---   BLOCK      PER        00 000   83/03/30  19.56 
 PER      SPACE  4,10 
**        PER - PRESET ERROR PROCESSOR. 
* 
*         ENTRY  (B5) = FWA MESSAGE, IF ENTRY AT *PER* OR *PER1*. 
*                (X1) = FILE NAME, IF ENTRY AT *PER*. 
* 
*         USES   B - 2, 5.
*                X - 1, 2.
* 
*         CALLS  MSG=, SNM, SYS=. 
 
 
 PER2     SB5    PERA        * ARGUMENT ERROR.* 
          EQ     PER1        ISSUE ERROR MESSAGE
 
 PER      MX2    42          SET NAME IN MESSAGE
          SB2    1RX
          BX1    X2*X1
          RJ     SNM
 PER1     MESSAGE B5,0
          ABORT 
 
 
 PERA     DATA   C* ARGUMENT ERROR.*
 PERB     DATA   C* BLOCK SIZE TOO LARGE ON XXXXXXX.* 
 PERC     DATA   C* BLOCK SIZE TOO SMALL ON XXXXXXX.* 
 PERD     DATA   C* COPY FL ABOVE USER LIMIT.*
 PERE     DATA   C* FILE NAME CONFLICT.*
 PERF     DATA   C* ILLEGAL COPY.*
 PERG     DATA   C* INVALID NOISE SIZE ON XXXXXXX.* 
 PERH     DATA   C* UNLABELED TAPE REQUIRED - XXXXXXX.* 
 PERI     DATA   C* UNRECOGNIZED TERMINATION CONDITION.*
 PERJ     DATA   C* UNRECOGNIZED BACKSPACE CODE.* 
 PERK     DATA   C* BLOCK SIZE NOT APPLICABLE.* 
 PERL     DATA   C* PROCESSING OPTION NOT APPLICABLE.*
* /---   BLOCK      SFM        00 000   83/03/30  20.01 
 SFM      SPACE  4,10 
**        SFM - SET FILE MODE.
* 
*         EXIT   CODED MODE SET ON INPUT, OUTPUT, OR BOTH FILES,
*                     IF REQUESTED. 
* 
*         USES   A - 1, 2, 6. 
*                B - 2. 
*                X - 1, 2, 6. 
 
 
 SFM      SUBR               ENTRY/EXIT 
          SA2    CM          GET MODE INDICATOR 
          ZR     X2,SFMX     IF CODED MODE NOT REQUESTED
          SB2    X2 
          SX2    B1+B1
          GT     B2,B1,SFM1  IF SECOND FILE ONLY
          SA1    I
          BX6    -X2*X1 
          SA6    A1 
 SFM1     EQ     B2,B1,SFMX  IF FIRST FILE ONLY 
          SA1    O
          BX6    -X2*X1 
          SA6    A1 
          EQ     SFMX        RETURN 
* /---   BLOCK      TABLES     00 000   83/04/27  12.42 
          SPACE  4,10 
**        PRESET DATA STORAGE.
 
 
 BS       CON    0           BLOCK SIZE 
 CC       CON    0           CHARACTER COUNT
 CF       CON    0           CONVERSION FORMAT
 CM       CON    0           CODED MODE (-1=BOTH,0=NEITHER,1=1ST,2=2ND) 
 DCT      CON    1L1         DISPLAY CODE COPY COUNT
 MAXFL    CON    0           CURRENT MAXIMUM FIELD LENGTH 
 MCC      CON    0           MAXIMUM CHARACTER COUNT
 PO       CON    0           PROCESSING OPTIONS 
 STAT     VFD    30/-1,30/0  FIELD LENGTH STATUS WORD 
 
*         THE ORDER OF THE FOLLOWING MUST BE PRESERVED. 
 
 WBL      CON    BUFL        WORKING BUFFER LENGTH
 IBL      CON    FBUFL       INPUT BUFFER LENGTH
 OBL      CON    FBUFL       OUTPUT BUFFER LENGTH 
* /---   BLOCK      COMMONS    00 000   83/04/18  16.37 
          SPACE  4,10 
**        COMMON DECKS. 
 
 
*CALL     COMCARM 
*CALL     COMCCPA 
*CALL     COMCDXB 
*CALL     COMCLFM 
*CALL     COMCPOP 
*CALL     COMCUSB 
          SPACE  4,10 
**        PRESET BUFFERS. 
 
 
 PASB     EQU    *           POSITIONAL ARGUMENT STRING BUFFER
          ERRNG  RFL=-PASB-200  CHECK FOR BUFFER OVERFLOW FL
* /---   BLOCK      END        00 000   83/04/20  21.13 
*         TEMP BUFFER UNTIL PLACED ON DST 
 
          BSSZ   RFL=-* 
 
          SPACE  4,10 
          END