*M*  DEVDMP  -  DEVICE DUMP STANDALONE UTILITY PROGRAM
*P*  NAME:  DEVDMP
*P*
*P*  PURPOSE:  THE DEVDMP PROCESSOR PRODUCES A DEVICE COPY
*P*            OF THE RAD OR PACK.  THAT IS, INDIVIDUAL SECTORS
*P*            ARE COPIED TO TAPE IN THE ORDER THAT THEY ACTUALLY OCCUR.
*P*
*P*            DEVDMP IS USEFUL FOR SAVING/RESTORING THE SYSTEM
*P*            SWAPPER OR A FILE DEVICE WHEN IT IS NECCESSARY TO USE
*P*            SUCH A DEVICE FOR PREVENTIVE MAINTENANCE.  THIS ALLOWS
*P*            FOR A QUICK RELOAD OF THE SYSTEM WITHOUT A LENGTHY
*P*            FILE RESTORE PROCESS.
         SYSTEM    SIG7FDP
         TITLE    'PROCS AND EQUATES USED BY PROGRAM'
*                                                                       DTD00010
**                PROCEDURES AND COMS                                   DTD00010
*                                                                       DTD00010
         SPACE    2
*
*                 PROCEDURE TO MANIPULATE BITS.
*                 CALLED BY:
*        SETBIT   LOCATION,BIT,BIT     SETS SPECIFIED BIT(S) IN WORD
*        OFFBIT   LOCATION,BIT,BIT     RESETS SPECIFIED BIT(S) IN WORD
*        FLIPBIT  LOCATION,BIT,BIT     INVERTS SPECIFIED BIT(S) IN WORD
*        TESTBIT  LOCATION,DESTINATION,BIT BIT  TEST FOR ONES IN THE
*                                      SPECIFIED BIT(S)
*                 WHERE: LOCATION   IS SYMBOLIC ADDRESS OF WORD
*                        DESTINATION IS ADDRESS TO BRANCH TO IF ANY OF
*                                    THE SPECIFIED BITS CONTAIN A 1 BIT
*                        BIT        IS THE BIT NUMBER OF THE BITS TO BE
*                                   TESTED. 0-31 ARE VALID BIT NUMBERS.
*                                   ANY NUMBER OF BITS MAY BE SPECIFIED.
*
SETBIT   CNAME    848,1,1,73
OFFBIT   CNAME    848,1,1,75
FLIPBIT  CNAME    848,1,1,72
TESTBIT  CNAME    1684,2,2,49
         PROC
         LOCAL    B,I,C,D
LF       EQU      %
B        SET      0
I        DO       NUM(AF)-NAME(3)
C        SET      B|(1**(31-AF(I+NAME(3))))
B        SET      C
         FIN
         DO       NAME(4)=75
D        SET      ~C
         ELSE
D        SET      C
         FIN
         LW,+CF(2) AF(1)
         GEN,8,4,20  NAME(4),CF(2),L(D)
         DO       NAME(1)=848
         GEN,12,20 NAME(1)|CF(2),AF(NAME(2))
         ELSE
         GEN,12,20 NAME(1),AF(NAME(2))
         FIN
         PEND
*                COM  TO SET CONDITION CODES AND PUSH,PULL,STORE OR
*                LOAD MULTIPLE REGISTERS
*                 CALLED BY.
*        PUSHREG  NUMBER OF REGS,1ST REG,STACK POINTER (PSM)
*        PULLREG  NUMBER OF REGS,1ST REG,STACK POINTER (PLM)
*        STOREM   NUMBER OF REGS,1ST REG,ADDRESS       (STM)
*        LOADM    NUMBER OF REGS,1ST REG,ADDRESS       (LM)
PUSHREG  COM,8,4,16,4,8,4,20  2,2,AF(1),0,11,AF(2),AF(3)
PULLREG  COM,8,4,16,4,8,4,20  2,2,AF(1),0,10,AF(2),AF(3)
STOREM   COM,8,4,16,4,8,4,20  2,2,AF(1),0,43,AF(2),AF(3)
LOADM    COM,8,4,16,4,8,4,20  2,2,AF(1),0,42,AF(2),AF(3)
*
*
*                COM TO GENERATE I/O COMMAND DOUBLE WORDS. CALLED BY.
*
*        IOPCW    ORDER CODE,DATA ADDRESS(WORD),FLAGS,COUNT
*
IOPCW    CNAME                                                          DTD00010
         PROC                                                           DTD00010
         ERROR,15,NUM(AF)<4 'LESS THAN 4 FIELDS SPECIFIED'
         ERROR,15,NUM(AF)>4 'MORE THAN 4 FIELDS SPECIFIED'
         DO       NUM(AF)=4                                             DTD00010
         BOUND    8                                                     DTD00010
LF       GEN,8,24,8,24  AF(1),BA(AF(2)),AF(3),AF(4)                     DTD00010
         ELSE                                                           DTD00010
         FIN                                                            DTD00010
         PEND                                                           DTD00010
IOREQ    COM,8,4,20   AF(1),AF(2),AF(3)
XXX      COM,8,24 AF(1),AF(2)
*
**                PROCEDURE FOR TIO'S
*
TIONEW   CNAME
         PROC
LF       EQU      %
         LI,R10   X'30'
         TIO,R0   AF
         BDR,R10  %
         BCS,M12  %-3
         PEND
         PAGE                                                           DTD00010
*                                                                       DTD00000
**                EQUATES                                               DTD00000
*                                                                       DTD00000
R0       EQU      0                 GENERAL REGISTERS                   DTD00000
RO       EQU      0
R1       EQU      1                                                     DTD00000
R2       EQU      2                                                     DTD00000
R3       EQU      3                                                     DTD00000
R4       EQU      4                                                     DTD00000
R5       EQU      5                                                     DTD00000
R6       EQU      6                                                     DTD00000
R7       EQU      7                                                     DTD00000
R8       EQU      8                                                     DTD00000
R9       EQU      9                                                     DTD00000
R10      EQU      10                                                    DTD00000
R11      EQU      11                                                    DTD00000
R12      EQU      12                                                    DTD00000
R13      EQU      13                                                    DTD00000
R14      EQU      14                                                    DTD00000
R15      EQU      15                                                    DTD00000
BSR      EQU      0                 I/O ORDERS                          DTD00000
RD1      EQU      1                                                     DTD00000
RD2      EQU      2                                                     DTD00000
WRT1     EQU      3                                                     DTD00000
WRT2     EQU      4                                                     DTD00000
WTE      EQU      5                                                     DTD00000
SET0     EQU      6                                                     DTD
REW      EQU      7                                                     DTD
ERG      EQU      8                                                     DTD
FSF      EQU      9                                                     DTD
WTM      EQU      10                                                    DTD
FSR      EQU      11
CHK1     EQU      0                                                     DTD
CHK2     EQU      7                                                     DTD
NOCYL    EQU      202
NOCYL70  EQU      412               7270-7275
NOTRK    EQU      20                7242-7260-7270(7275 HAS 19)
T        EQU      4                 GENERAL                             DTD
D        EQU      5                                                     DTD
ALLOW    EQU       39
NOALLOW  EQU      55
KEYBOARD EQU      1                                                     DTD
X1       EQU      1                 INDEX REGISTERS                     DTD
X2       EQU      2                                                     DTD
X3       EQU      3                                                     DTD
X4       EQU      4                                                     DTD
X5       EQU      5                                                     DTD
X6       EQU      6                                                     DTD
X7       EQU      7                                                     DTD
M1       EQU      1                                                     DTD
M2       EQU      2                                                     DTD
M3       EQU      3                                                     DTD
M4       EQU      4                                                     DTD
M8       EQU      8                                                     DTD
M11      EQU      11                                                    DTD
M12      EQU      12                                                    DTD
M14      EQU      14                                                    DTD
HDR1TDV  EQU      X'1E2'
HDR2TDV  EQU      X'1E1'
         TITLE    'PROGRAM CONTROL WORD  ---INDICATE--- '
*        BIT    0 *
*               1  *  JOB SWITCH. WHEN '0000' A COPY COMMAND IS
*               2  *  OUTSTANDING.  WHEN '0001' A RESTORE COMMAND IS
*               3 *   OUTSTANDING.
*                 MEANING WHEN =1.
*               4 TAPE READ TO BUFFER 1 IN PROGRESS.
*               5 TAPE READ TO BUFFER 2 IN PROGRESS.
*               6 TAPE WRITE FROM BUFFER 1 IN PROGRESS.
*               7 TAPE WRITE FROM BUFFER 2 IN PROGRESS.
*               8 DISC OPERATION USING BUFFER 1.
*               9 DISC OPERATION USING BUFFER 2.
*              10 USE LP FOR MSGES
*              11 END OF COMMAND INPUT RECEIVED.
*              12 CONTINUATION CHARACTER IN COMMAND INPUT STRING.
*              13 OPERATOR REQUESTED BOOT AFTER END OF RUN
*              14 KEY-IN ERROR DETECTED.
*              15 PROCESSING FLAWED TRACK
*              16 ACCEPT NEW DISC ADDRESSES DURING RESTORE/COMPARE
*              17 EOF ON TAPE DETECTED.
*              18 A 'DC' COMMAND STRING HAS BEEN KEYED-IN.
*              19 PROGRAM AND BOOT HAVE BEEN WRITTEN ON TAPE
*              20 CURRENT COMMAND HAS COMPLETED
*              21 COMMAND INPUT IS TO COME FROM THE CARD READER
*              22 TAPE ERROR RECOVERY IN PROGRESS
*              23 CHECK WRITE IN PROGRESS
*              24 EXECUTING I/O CAL1,6
*              25 DISC/TAPE I/O OVERLAP IS POSSIBLE
*              26 DATE HAS BEEN ENTERED
*              27 TAPE ERROR RECOVERY FOR BOOT/PGM/DIR
*              28 BOOT-WRITE IN PROGRESS
*              29 DIRECTORY-WRITE IN PROGRESS
*              30 A RAD MODEL NUMBER HAS BEEN KEYED-IN.
*              31 A JOB COMMAND (COPY OR RESTORE) HAS BEEN KEYED-IN.
*
         TITLE    'INITILIZE SYSTEM FOR RUN'
         ORG      512                                                 DTD
LOAD2    EQU      %                                                   DTD
         LW,R1    X55               INITILIZE
         STW,R1   X'55'             COIUNTER 4
         LI,R1    0                 ZERO CLOCK COUNTER
         STW,R1   TIME
BEGIN    LI,R1    0
         STW,R1   IND
         LW,R1  X'26'               IF RESTART DONT RESET
         CW,R1    RGO               DATE INDICATOR WE HAVE ALREADY
         BNE      BEGIN1
         SETBIT   IND,26            SET    DATE ENTERED
BEGIN1   LPSD,M11 START             SET INITIAL PSD
PROG     EQU      %
         LW,R1    RGO               ALLOW RESET AND RUN
         STW,R1   X'26'
         TIO,0    *TYPEDEV          CHECK IF TELETYPE ADDR VALID
         BCR,8    %+5               B IV VALID
         BCR,4    %+4               B IF VALID
         WAIT                       NOT VALID , ACCEPT NEW ADDR IN R0
         STW,R0   TYPEDEV           STORE NEW ADDR
         B        %-5               VERIFY NEW ADDR
         LI,R1    4144              ARM AND
         WD,R1    4608              ENABLE INTERRUPTS
         LCI      12      INITILIZE-         TRAPS
         LM,R1    X40
         LCI      4
         STM,R1   64                X'40',X'41',X'42' AND X'43'
         STW,R5   70                X'46'
         LCI      2
         STM,R6   72                X'48' AND X'49'
         STW,R9   86                X'56'
         LCI      3
         STM,R10  91                X'5B',X'5C' AND X'5D'
         LOADM    4,2,BREP          SRT UP DISC
         STOREM   4,2,BUF2CW1       BUFFER 2
         LI,R2    8                 GET 'EOM' CHARACTER
         LI,R3    -1
         STB,R2   BLANK,R3          STORE 'EOM' IN INPUT AREA
         BAL,R15  PRESET            INITILIZE DEFAULT OPTIONS           DTD
         LI,R6    BA(MSGX1)         GET ADDR OF MSG TO BE TYPED         DTD
         BAL,R15  COMTYPE           GO TYPE MSG                         DTD
         TESTBIT  IND,BYDATE,26
         LI,R6    BA(MSGDATE)       MSG ADDR
         BAL,R15  COMTYPE           TYPE 'ENTER DATE--'
         BAL,R15  COMREAD           ACCEPT TYPE-IN
         SETBIT   IND,26            SET    DATE ENTERED
         LD,R2    INPUT             GET KEY-IN
         STD,R2   SAVEDATE          STORE
         STD,R2   DTEHOLD           FOR USE
BYDATE   EQU      %
         LI,R6    BA(MSGX2)         GET ADDR OF MSG TO BE TYPED         DTD
         BAL,R15  COMTYPE           GO TYPE MSG                         DTD
         TITLE    'COMMAND SCANNER'
CONTPRMS EQU      %
         TESTBIT  INDICATE,KARD1,21 BRANCH IF CARD READER INPUT
         BAL,R15  COMREAD           USE TELE TYPE TO GET COMMDS
CONT1    EQU      %
*                                                                       DTD
*                 BEGIN DECODING PARAMETERS                             DTD
*                                                                       DTD
         OFFBIT   INDICATE,11,12    RESET COMMD FLAGS
         LI,X1    0                 SCAN FOR POSSIBLE 'CANCEL' (EOM)
         LB,R2    INPUT             SPECIAL TEST TO DETECT NEW LINE
         CI,R2    21                CHARACTER IN 1ST KEY-IN PSN.
         BE       END               BRANCH IF SO
SCAN     LB,R2    INPUT,X1          GET 1 CHARACTER
         CI,R2    8                 TEST FOR EOM
         BE       SETUP-1           PROCESS LINE
         CI,R2    21                TEST FOR TERM OF TYPE-IN  (X'15')
         BE       SETUP-1           BRANCH IF YES
         CI,R2    64                TEST FOR BLANK
         BE       FIND3             BRANCH IF BLANK
SCAN1    EQU      %
         AI,X1    1                 INCREMENT INDEX
         B        SCAN              SCAN ENTIRE TYPE-IN
         LI,X1    0
SETUP    BAL,R15  BLNKWRK           CLEAR WORK AREA
         TESTBIT  INDICATE,END,11   TEST FOR END CHAR RECEIVED
         TESTBIT  INDICATE,CONTPRMS,12 TEST FOR CONTINUE CHAR RECEIVED
SETUPCHR LI,X4    0
         LB,R2    INPUT,X1          GET 1 CHARACTER
         CI,R2    C','              TEST FOR COMMD SEPARATOR  (COMMA)
         BE       FIND              BRANCH IF SO
         CI,R2    ';'               TEST FOR CONT CHAR
         BE       FIND1             YES-BRANCH
         CI,R2    21                TEST FOR NL (END TYPE-IN) CHARACTER
         BE       FIND2             YES-BRANCH
         CI,R2    64                TEST FOR BLANK
         BE       FIND2
         STB,R2   WORK,X4           STORE CHARACTER IN WORK AREA
         AI,X4    1                 INCREMENT
         AI,X1    1                 INDEXES
         B        SETUPCHR+1        MOVE COMMD TILL DELIMITER DETECTED
FIND1    SETBIT   INDICATE,12       SET CONTINUE CHAR RECEIVED
         B        FIND              GO DECODE COMMD
FIND2    SETBIT   INDICATE,11       SET END OF KEY-IN RECEIVED
         B        FIND              GO DECODE COMMD
FIND3    EQU      %
         TESTBIT  INDICATE,FIND4,21 BRANCH IF CARD INPUT
         B        SCAN1             INPUT IS FROM TELE-TYPE
FIND4    EQU      %
         CI,X1    0                 TEST FOR BLANK CARD
         BE       END                 BRANCH IF SO
         LI,X4    7                 GET INDEX
         STB,X1   LOGCW,X4          STORE IN COMMD AS BYTE CNT
         LI,R0    DA(LOGCW)         COMMD ADDR
         SIO,R0   *TYPEDEV          TYPE COMMD FROM CARD RDR
         BIOSNS   %-1
         TIO,R0   *TYPEDEV          WAIT FOR TYPE TO FIN
         BCS,M4   %-1
         LI,X1    0                 CLEAR INDEX
         B        CR                PROVIDE CARRIAGE RETURN
CR       LI,R6    BA(CRMSG)         PROVIDE
         BAL,R15  COMTYPE           DOUBLE CARRIAGE
         B        SETUP             RETURN TO SCAN NEXT COMMD
         TITLE    'FUNCTION DECODER'
FIND     EQU      %
         STW,X1   X1SAV             SAVE SCAN POINTER
         LH,R2    INPUT             GET 1ST HALF-WORD OF 1ST COMMD
         CI,R2    X'FC3D9'          TEST FOR CARD INPUT
         BE       KARDA             BRANCH IF SO
         LB,R2    WORK              GET 1ST DIGIT OF THIS COMMD
         CI,R2    C'C'              TEST FOR -C- COPY OR COMP           DTD
         BE       COPYCOMP          BRANCH IF SO                        DTD
         CI,R2    C'D'              TEST FOR -D- DT OR DC               DTD
         BE       DDISCRIM          BRANCH IF SO                        DTD
         CI,R2    C'R'              TEST FOR -R-  RAW OR REST           DTD
         BE       RESTRTN           BRANCH IF SO
         CI,R2    C'X'              TEST FOR X = ACCEPT NEW DISC ADDR
         BE       NEWDCX            BRANCH IF SO
         CI,R2    C'M'              TEST FOR -M-  MT                    DTD
         BE       DECODETP          BRANCH IF SO                        DTD
         CI,R2    C'#'              TEST FOR -#-  #7202                 DTD
         BE       SETMODEL          BRANCH IF SO                        DTD
         CI,R2    C'P'              TEST FOR PRINT DIRECTORY COMMD
         BE       PNTDIR            BRANCH IF SO
         CI,R2    'E'               TEST FOR :
         BE       TRIG%CP           BR IF HE WANTS CP RTNS
         CI,R2    'G'
         BE       MARK%GRP          BR IF END OF GROUP
         CI,R2    'B'
         BE       SET%BOOT          BR IF BOOT COMMD
         B        GPARAM            INVALID COMMAND
COPYCOMP LH,R2    WORK              TEST
         CI,R2    X'FC3D6'          FOR COPY
         BE       COPYRTN           BRANCH IF SO                        DTD
         CI,R2    X'FC3D4'          FOR CMPR
         BE       COMPARE           BRANCH IF SO
         B        GPARAM            INVALID SKIP                        DTD
COPYRTN  OFFBIT   INDICATE,1,2,3    SET  SWITCH FOR COPY CMMD
         SETBIT   INDICATE,31       INDICATE JOB RECEIVED
         B        NR1
TRIG%CP  LI,R15   16
         WD,R15   X'1700'           TRIGGER CP
         B        NR1               GET NEXT PARAM
*
SET%BOOT EQU    %
         SETBIT   INDICATE,13       SET AUTO BOOT
         LI,R6    BA(WORK)+2        SET PTR TO DEV ADDR
         LI,R1    4
         BAL,R15  CPTOHEX           CONVERT TO HEX
         STW,R9   BOOTDEV           STORE
         B        NR1               GET NEXT COMMAND
COMPARE  OFFBIT   INDICATE,1,2,3
         SETBIT   INDICATE,2,31
         B        NR1               GET NEXT COMMAND
NEWDCX   EQU      %
         SETBIT   IND,16            SET TO ACCEPT NEW DISC ADDR'S
         B        NR1               GET NEXT COMMAND
RESTRTN  EQU      %
         OFFBIT   INDICATE,1,2,3    CLEAR SWITCH
         SETBIT   INDICATE,3,31     TURN ON -JOB RECEIVED AND RESTORE-
NR1      EQU      %
         LW,X1    X1SAV             RETRIEVE SCAN POINTER
         AI,X1    1
         B        SETUP             GO GET NEXT PARAM                   DTD
KARDA    EQU      %                 SET UP FOR CARD INPUT
         OFFBIT   INDICATE,11,12    IGNORE END OR CONTINUE CHARACTERS
         SETBIT   INDICATE,21       SET CARD INPUT SWITCH
         LI,R6    BA(INPUT)+2       SET PTR TO DEV ADDR
         LB,R2    0,R6
         CI,R2    C'A'              CHECK IF ADDR ENTERED
         BL       KADEF             NO   FIND DEFAULT
         LI,R1    4
         BAL,R15  CPTOHEX           CONVERT TO HEX
         STW,R9   CARDDEV
         B        CONTPRMS
KADEF    EQU      %
         LW,R0    X'25'             GET BOOT DEV ADDR
         CI,R0    X'80'             CHECK IF MULTI-DEV CONTROLLER
         BANZ     CONTPRMS          YES - USE  03
         STW,R0   CARDDEV           NO USE BOOT DEV
         B        CONTPRMS
DDISCRIM LH,R2    WORK              GET 1ST 2 CHARACTERS                DTD
         CI,R2    X'FC4C3'          TEST FOR DC
         BE       SETDC             BRANCH IF SO                        DTD
         CI,R2    X'FC4D5'          IS THHS A 560 DEVICE
         BE       SETDN             BRANCH IF YES
         B        GPARAM            INVALID PARAM BRANCH                DTD
*
         OPEN     M1,M2,M3,M4,M11
SETMODEL EQU      %
         LI,R2    0
         LI,R5    3
         LB,R4    WORK,X5           GET
         STB,R4   R3                TWO
         SLD,R2   8                 LOW
         LB,R4    WORK+1            ORDER
         STB,R4   R3                DIGITS
         SLD,R2   8                 OF MODEL NBR
         CI,R2    '12'              TEST FOR #7212
         BE       M11
         CI,R2    '14'              TEST FOR 3214
         BE       MM14
         CI,R2    '32'              TEST FOR #7232
         BE       M21
         CI,R2    '02'              TEST FOR #7202
         BE       M2
         CI,R2    '03'              TEST FOR #7203
         BE       M3
         CI,R2    '04'              TEST FOR #7204
         BE       M4
         CI,R2     '42'         TEST FOR PAK
         BE       M42
         CI,R2    '60'              7260
         BE       M60               YUP
         CI,R2    '70'              7270
         BE       M70               YUP
         CI,R2    '75'              7275
         BE       M75               YUP
         CI,R2    '77'              TEST FOR 3275
         BE       M77
         CI,R2    '82'              TEST FOR 3282
         BE       M82
         B        GPARAM            INVALID BRANCH
M2       LW,R0    M7202MSK          STORE CURRENT MODEL NUMBER
STORERO  STW,R0   MODEL
         SETBIT INDICATE,30
         B        NR1
M3       LW,R0    M7203MSK
         B        STORERO
M4       LW,R0    M7204MSK
         B        STORERO
M11      LW,R0    M7211MSK
         B        STORERO
MM14     LW,R0    M3214MSK
         B        STORERO
M21      LW,R0    M7221MSK
         B        STORERO
M42      LW,R0    M7242MSK
         B        STORERO
M60      LW,R0    M7260MSK
         B        STORERO
M70      LW,R0    M7270MSK
         B        STORERO
M75      LW,R0    M7275MSK
         B        STORERO
M77      LW,R0    M3277MSK
         B        STORERO
M82      LW,RO    M3282MSK
         B        STORERO
         CLOSE    M1,M2,M3,M4,M11
MARK%GRP EQU      %                 END OF GROUP PUSH MODEL NUMBER
         TESTBIT  INDICATE,OK30,30  BR IF MODEL NBR ENTERED
         LI,R6    BA(NOMODMSG)
         B        %MER
OK30     TESTBIT  INDICATE,OK18,18  BR IF DC ADR ENTERED
         LI,R6    BA(NODMSG)
%MER     BAL,R15  COMTYPE
         B        BYDATE            FORGET COMMDS
OK18     LI,R0    0
         XW,R0    MODEL
         PSW,R0   JOBSTACK          PLACE IN JOB STACK
         OFFBIT   INDICATE,18,30    RESET MODEL AND DC ENTERED
         B        NR1               CONTINUE
SETDC    EQU      %
         PUSHREG  0,0,SUBSTACK      SAVE 16 REGS
         BCS,M2   STKERROR          *TEST*
         LI,R2    0
         STW,R2   DXCNT             CLEAR SWITCH
          LI,X1     2              SET INDEX BEYOND 'DC'
         LI,R6    BA(WORK)+2        SET PTR TO ADDR
         LI,R1    4
         BAL,R15  CPTOHEX           CONVERT TO HEX
         STW,R9   INTERM            STORE
         CI,R9    X'80'             TEST FOR SHARED CONTROLLER
          BAZ       GP1            BAD NEWS IF NOT
         TIO,0    *R9               DONT PUT THIS DISC IN STACK
         BCS,12   AA1               IF UN AVAILABLE
         PSW,R9   JOBSTACK          SAVE DISC ADDR
         MTW,1     DXCNT             SET DISC UNIT PUSHED
A1       EQU      %
         LB,R8    0,R6
         CI,R8    C' '
         BNE      CX
         B        DX
SETDN    EQU      %
         PUSHREG  0,0,SUBSTACK      SAVE REGISTERS
         BCS,M2   STKERROR
         LW,R2    DENSW
         CI,R2    0                 DOES MT PRECEED DN CMMND
         BLE      DEV001            BRANCH IF NO
         LI,R2    0
         STW,R2   DENSW             RESET DENSITY SWITCH
         B        DEV005
DEV001   LI,R6    BA(TYP001)        GET BA OF MESSAGE
         BAL,R15  COMTYPE           TYPE MT MUST PRECEED DN
         PULLREG  0,0,SUBSTACK
         B        GPARAM+4          RETYPE CMMND
DEV005   EQU      %
         LI,R6    BA(WORK)+2        POINT TO BA OF CHARACTER
         LI,R1    2                 SET NO OF CHARACTERS
         BAL,R15  CPTOHEX           CONVERT TO HEX
         CI,R9    X'80'             CHECK FOR 800 BPI
         BNE      DEV010
         AI,R6    1                 INCREMENT CHAR COUNT
         LI,R0    DA(M800CW)        GET CCW FOR 800 BPI
         B        DEV015            GO SET MODE TO 800 BPI
DEV010   CI,R9    X'16'             CHECK FOR 1600 BPI
         BNE      GP2
         AI,R6    2
         LI,R0    DA(M1600CW)
DEV015   SIO,R0   *TAPEDEV          SET MODE
         BIOSNS   %-1
         TIONEW   *TAPEDEV
         PULLREG  0,0,SUBSTACK      RESTORE REGISTERS
         B        NR1
A1GX     EQU      %
         LI,R6    BA(MSGX7)         TYPE--
         BAL,R15  COMTYPE           DISC UNIT UNAVAILABLE -ONDD
         BAL,R15  PRTHEX
         STW,R11   WORK
         LI,R6    BA(WORKT)+3
         BAL,R15  COMTYPE
         TIONEW   *TYPEDEV
         STOREM   3,R2,WORK
         B        *R14
AA1      PUSHREG  0,R0,SUBSTACK
         LOADM    3,R2,WORK
         BAL,R14    A1GX
         PULLREG  0,R0,SUBSTACK
         B        A1                CONTINUE
GX1      PUSHREG  0,R0,SUBSTACK
         LW,R5    R6
         LOADM    3,R2,WORK
          BAL,R14  A1GX
         PULLREG  0,0,SUBSTACK
         B        GX                CONTINUE
CX       AI,X1    1                 BUMP INDEX PAST -
         LI,R1    4
         BAL,R15  CPTOHEX           CONVERT TO HEX
         LW,R5    R9
         CW,R5    INTERM            TEST FOR FROM LARGER THAN TO
         BL       GP1               BRANCH IF SO
         LW,R6    R5                TEST FOR GREATER
         SW,R6    INTERM            THAN
         CI,R6    15                15 RADS
         BGE      GP1               BRANCH IF SO
         LW,R6    INTERM            GET BEGIN ADDR
GX       AI,R6    1                 INCREMENT
         CW,R6    R5                TEST FOR LAST ADDR IN STACK
         BG       DX                BRANCH IF SO
         TIO,0    *R6               DONT PUT THIS DISC IN STACK
         BCS,12   GX1               IF UNAVAILABLE
         PSW,R6   JOBSTACK          PUSH THIS ADDR IN STACK
         MTW,1    DXCNT             SET DISC UNIT PUSHED
         B        GX                GO INCREMENT ADDR
GP1      EQU      %
         LW,R1    GP1DC             PLACE 'DC  ' IN ERROR MSG
         STW,R1   WORK              FOR TYPING
         B        %+3
GP2      LW,R1    GP2DN
         STW,R1   WORK
         PULLREG  0,0,SUBSTACK      RESTORE REGS
         B        GPARAM            GO TYPE ERROR MSG
DX       EQU      %
         LW,R2    DXCNT
         BEZ      BYDX              BRANCH IF NO DISC PUSHED IN STACK
         SETBIT   INDICATE,18       SET 'DC' ENTERED
         LW,R6    STACK1+2          GET FIRST DISC ADDR IN STACK
         STW,R6   DISCDEV           STORE AS CURRENT DISC DEV.
BYDX     EQU      %
         PULLREG  0,0,SUBSTACK      RESTORE REGS
         B        NR1
DECODETP LH,R2    WORK              GET 1ST 2 CHARACTERS OF PARAM       DTD
         CI,R2    X'FD4E3'          TEST FOR -MT-
         BNE      GPARAM            BRANCH IF INVALID
         LI,R6    X'FF'
         STW,R6   DENSW             SET DENSITY SWITCH
         LI,R6    BA(WORK)+2
         LI,R1    4
         BAL,R15  CPTOHEX
         STW,R9   TAPEDEV
         B        NR1               EXIT                                DTD
PNTDIR   PUSHREG  0,0,SUBSTACK      SAVE REGS
         BCS,M2   STKERROR          ***TEST**BRANCH IF PUSH ABORTED
         SETBIT   INDICATE,24,19    INDICATE DIRECT. IN CORE, & SET0
         IOREQ    T,REW,0           REWIND TAPE
         IOREQ    T,FSR,0           SPACE OVER BOOT
         IOREQ    T,FSR,0           SPACE OVER PROGRAM
         LI,R0    DA(RDDIR)         CW ADDR TO READ DIRECTORY
PDRD     EQU      %
         IOREQ    T,SET0,PDRTRY     READ DIRECTORY
         IOREQ    T,WTE,PDRTRY      WAIT FOR END ACTION
         IOREQ    T,FSR,0           SPACE OVER TM
         OFFBIT   INDICATE,24
         LI,R6    BA(DIRMSG1)       MSG ADDR
         BAL,R15  COMTYPE           TYPE 'DIRECTORY OF CONTENTS'
         LI,R6    BA(DIRMSG2)
         BAL,R15  COMTYPE           TYPE 'TAPE CREATED--MM/DD/YY'
         LI,R6    BA(CNTDIR)+3      MSG ADDR
         BAL,R15  COMTYPE           TYPE DATE PORTION OF ABOVE MSG
PWRD     PLW,R9   DIRSTACK          PULL WORD FROM STACK
         BCS,M2   DIRCOM            BRANCH IF LAST WORD PULLED
         LW,R9    R9                TEST FOR MODEL NBR FLAG
         BCS,1    PRT%MOD           BR IF MODEL NBR
         BAL,R15  PRTHEX            CONVERT RAD UNIT ADDRESS FOR TYPING
         LI,R6    1
         STW,R11  DIRMSG5,R6        STORE CONVERTED ADDR IN MSG
         LI,R6    BA(DIRMSG5)       TYPE
         BAL,R15  COMTYPE           ADDR
         TIONEW   *TYPEDEV
         B        PWRD              BRANCH TO TYPE NEXT JOB
PRT%MOD  EQU      %
         LI,R6    5
         STH,R9   DIRMSG4,X6        MODEL NBR TO MSG
         LI,R6    BA(DIRMSG4)
         BAL,R15  COMTYPE           TYPE
         B        PWRD              CONTINUE
PDRTRY   EQU      %
         LI,R0    DA(SENSECW)
         IOREQ    T,SET0            SENSE
         IOREQ    T,BSR,0
         LI,R0    DA(SETCORR)
         IOREQ    T,SET0,0          SET CORRECTION
         B        PDRD              GO RETRY
DIRCOM   PULLREG  0,0,SUBSTACK      RESTORE REGS
         AI,X1    1                 INCREMENT PAST COMMA
         B        CR                RETURN
KARD1    EQU      %
         TESTBIT  INDICATE,BEGIN,11  ABORT IF ERROR ON CARD
         TIO,R1   *CARDDEV          TEST CARD READER
         BCS,4    DEADCR            BRANCH IF NOT AVAIL
         LC       R1                GET STATUS BITS 0-3 FOR TEST
         BCS,4    DEADCR            BRANCH IF BUSY
         BCR,1    DEADCR            BRANCH IF MANUAL
*                                   NOTE-2120 CARD READER RESETS TO
*                                   MANUAL MODE WHEN BUSY
         LI,R0    DA(RDCOMMD)       COMMD
         SIO,R0   *CARDDEV          READ
         BIOSNS   KARD1             BRANCH IF START RAD
KARD3    TIO,R1   *CARDDEV
         TESTBIT  R1,KARD3,1        BRANCH IF READER BUSY
         B        CONT1             GO DECODE THIS CARD
DEADCR   EQU      %
         OFFBIT   INDICATE,21       RESET CARD INPUT
         LI,R6    BA(MSGBCR)
         BAL,R15  COMTYPE           TYPE 'CR BAD'
         B        BYDATE
END      TESTBIT  INDICATE,ENDER,14 BRANCH IF KEY-IN ERROR
         B        GOEND             NO ERRORS BRANCH
ENDER    OFFBIT   INDICATE,14       TURN OFF KEY-IN ERROR
         B        CONTPRMS          GET NEW PARAM
GOEND    EQU      %
         LW,R0    INDICATE
         CI,R0    1
         BCR,4    GOEND2            BR IF JOB NOT RECEIVED
         LI,R0    0
         MSP,R0   JOBSTACK          TEST FOR NO DC OR # KEY-IN
         BCS,1    STACK%EMPTY       BR IF SO
         LW,R1    *JOBSTACK         TEST FOR # NOT YET PUSHED
         BLZ      SET04             BR IF NO MODEL
* WE HAVE DISC IN JOBSTACK AND MODEL NBR AT LOCATION MODEL
MOD%NOW  XW,R0    MODEL             CLEAR MODEL AND GET KEY-IN
         BEZ      SET04
         PSW,R0   JOBSTACK          SET IN STACK
         B        JOBTAB            GO RUN
STACK%EMPTY  EQU  %
         LW,R1    DISCDEV           SET DISC DEFAULT IN STACK
         PSW,R1   JOBSTACK
         B        SET04
SET04    EQU      %
         LW,R0    MODEL
         BNEZ     MOD%NOW+1
         LW,0     M7204MSK          NO MODEL SUPPLIED
         B        MOD%NOW+1         USE DEFAULT
GOEND2   EQU      %
         TESTBIT  INDICATE,BEGIN,21 BRANCH IF CARD READER IS INPUT
         B        BYDATE            GO GET JOB (COPY,COMP OR REST)
JOBTAB   EQU      %
         LW,R2    TIME
         STW,R2   PRETIME
         LB,X2    INDICATE          GET JOB CODE FROM INDICATE
         SLS,X2   -4                SHIFT TO LSD
         B        JOBTABLE,X2       BRANCH TO JOB TABLE
JOBTABLE EQU      %
         B        JOBDT             EXIT FOR COPY
         B        JOBREST                    RESTORE
         B        JOBREST           COMPARE
         TITLE    'CALL PSD AND ENTRY POINTS'
****                                                                    DTD
*  ***            CALL DIRECTOR                                         DTD
****                                                                    DTD
         BOUND    8
C1OLDPSD DATA,8   0                                                     DTD
C1NEWPSD GEN,8,7,17,8,24  7,0,CALL1,5,0
C2OLDPSD DATA,8   0                                                     DTD
C2NEWPSD GEN,8,7,17,8,24  7,0,CALL2,5,0
         SPACE    2                                                     DTD
*                 BRANCH TABLE FOR CALL 1 FUNCTIONS                     DTD
CALL1    EQU      %
         B       T:BSR        0     BACKSPACE RECORD
         B       T:RD1        1     READ TAPE TO BUFFER 1
         B       T:RD2        2     READ TAPE TO BUFFER 2
         B       T:WRT1       3     WRITE TAPE FROM BUFFER 1
         B       T:WRT2       4     WRITE TAPE FROM BUFFER 2
         B       T:WTE        5     WAIT FOR TAPE COMPLETION
         B       T:SET0       6     DO COMMAND LIST POINTED TO THRU R0
         B       T:REW        7     REWIND TAPE
         B       T:ERG        8     SET ERASE
         B       T:FSF        9     FORWARD SPACE FILE
         B       T:WTM       10     WRITE TAPE MARK
         B       T:FSR       11     FORWARD SPACE RECORD
         SPACE    3                                                     DTD
*                 BRANCH TABLE FOR CALL 2 FUNCTIONS                     DTD
CALL2    EQU      %
         B       D:CHK1       0     CHECKWRITE BUFFER 1
         B       D:RD1        1     READ DISC TO BUFFER 1
         B       D:RD2        2     READ DISC TO BUFFER 2
         B       D:WRT1       3     WRITE DISC FROM BUFFER 1
         B       D:WRT2       4     WRITE DISC FROM BUFFER 2
         B       D:WTE        5     WAIT FOR DISC COMPLETION
         B       D:SET0       6     DO COMMAND LIST POINTED TO THRU R0
         B       D:CHK2       7     CHECKWRITE BUFFER 2
         TITLE    'CALL 1 ROUTINES. TAPE OPERATIONS'
T:SET0   EQU     %
         LW,R7    *C1OLDPSD         SAVE
         STW,R7   TAPEREC           ERROR RETURN ADDR
         MTW,M1   C1OLDPSD          INCREMENT RETURN
         B        RWCOMSIO          GO INSSUE COMMAND
T:BSR    EQU     %
         BAL,R15  RTNTIO            TEST STATUS
         LI,R0    DA(BSRCW)         GET COMMND ADDR                     DTD
         B        COMSIO            GO ISSUE COMMND                     DTD
T:FSR    EQU     %
         BAL,R15  RTNTIO            TEST STATUS
         LI,R0    DA(FSRCW)         GET COMMD ADDR
         B        COMSIO            GO ISSUE COMMD
T:REW    EQU     %
         BAL,R15  RTNTIO            TEST STATUS
         TDV,R13  *TAPEDEV          GET TAPE POSITION                   DTD
         TESTBIT  R13,CAL1RET,5     BRANCH IF TAPE AT LOAD POINT
         LI,R0    DA(REWCW)         GET COMMD ADDR
         B        COMSIO            TAPE NOT AT L.P. REWIND ON LINE     DTD
T:ERG    EQU     %
         BAL,R15  RTNTIO            TEST STATUS
         LI,R0    DA(ERGCW)         COMMD ADDR
         B        COMSIO            GO ISSUE COMMD                      DTD
T:FSF    EQU     %
         BAL,R15  RTNTIO            TEST STATUS
         LI,R0    DA(FSFCW)         COMMD ADDR                          DTD
         B        COMSIO            ISSURE COMMD                        DTD
T:WTM    EQU     %
         BAL,R15  RTNTIO            TEST STATUS
         LI,R0    DA(WTMCW)         COMMD ADDR                          DTD
         B        COMSIO            ISSUE COMMD                         DTD
T:WTE    EQU     %
         BAL,R15  RTNTIO            TEST STATUS
         TDV,R11  *TAPEDEV          GET TDV STATUS
CAL1RET  LPSD,0   C1OLDPSD          RETURN
T:RD1    EQU     %
         LW,R7    *C1OLDPSD         GET ERROR RECOVERY RTN ADDR FROM CAL
         STW,R7   TAPEREC           SAVE
         BAL,R15  RTNTIO            GET TAPE STATUS
         SETBIT   INDICATE,4        SET READ TO BUFFER 1 IN PROGRESS
         LI,R0    DA(RDBUF1CW)      COMMD ADDR                          DTD
         B        RWCOMSIO          GO ISSUE SIO                        DTD
T:RD2    EQU     %
         LW,R7    *C1OLDPSD         GET ERROR RECOVERY RTN ADDR FROM CAL
         STW,R7   TAPEREC           SAVE
         BAL,R15  RTNTIO            GET TAPE STATUS
         SETBIT   INDICATE,5        SET READ TO BUFFER 2 IN PROGRESS
         LI,R0    DA(RDBUF2CW)      COMMD ADDR                          DTD
         B        RWCOMSIO          GO ISSUE SIO                        DTD
T:WRT1   EQU     %
          LW,R7     *C1OLDPSD      GET ERR RETURN ADDR
          STW,R7    TAPEREC           FROM CAL1-OLD-PSD
          BAL,R15   RTNTIO         ...THEN GET DEVICE STATUS
         TDV,R11  *TAPEDEV          GET TDV STATUS
         TESTBIT  R11,NEWREEL,6     BRANCH IS END-OF-REEL
         SETBIT   INDICATE,6        SET WRITE FROM BUFFER 1 IN PROGRESS
         LI,R0    DA(WRTB1CW)       COMMD ADDR
         B        RWCOMSIO          GO ISSUE SIO
T:WRT2   EQU     %
          LW,R7     *C1OLDPSD      GET ERR RETURN ADDR
          STW,R7    TAPEREC           FROM CAL1-OLD-PSD
          BAL,R15   RTNTIO         ...THEN GET DEVICE STATUS
         TDV,R11  *TAPEDEV          GET TDV STATUS
         TESTBIT  R11,NEWREEL,6     BRANCH IF END-OF-REEL
         SETBIT   INDICATE,7        SET WRITE FROM BUFFER 2 IN PROGRESS
         LI,R0    DA(WRTB2CW)       COMMD ADDR
         B        RWCOMSIO          GO ISSUE SIO
*
NEWREEL  LI,R0    DA(WTMCW)         GET WRITE TM COMMD
         SIO,R0   *TAPEDEV          WRITE 1 TAPE MARK
         TIONEW   *TAPEDEV
         LI,R0    DA(EORCW)         GET TRAILER LAB COMMD
         SIO,R0   *TAPEDEV          WRITE '!!EOR
         TIONEW   *TAPEDEV
         LI,R0    DA(WTMCW)         WRITE TAPE MARK COMMD
         LI,R7    -2                SET TO WRITE 2 TAPE MARKS
NEWSIO   SIO,R0   *TAPEDEV          WRITE TAPE MARK
         TIONEW   *TAPEDEV
         BIR,R7   NEWSIO            WRITE TAPE MARK TWICE
         LI,R6    BA(MSGY4)         MSG ADDRESS
         BAL,R15  COMTYPE           TYPE 'END OF REEL. ASSIGN NEW TAPE'
         LI,R0    DA(OFFLINE)
         SIO,R0   *TAPEDEV          REWIND THIS TAPE OFF LINE
         BAL,R15  COMREAD           ACCEPT NEW TAPE ASSIGNMENT
         LI,R6    BA(INPUT)         SET PTR TO INPUT
         LB,R0    0,R6              EXAMINE FIRST CHAR
         CI,R0    C'M'              CHECK FOR MTXXX
         BNE      %+2               NO-BRANCH
         AI,R6    2                 YES-ADJUST POINTER
         LI,R1    4
         BAL,R15  CPTOHEX           CONVERT TO HEX
         STW,R9   TAPEDEV           STORE
         MTW,M14  C1OLDPSD          DECREMENT RETURN TO POINT TO CAL1
         OFFBIT   IND,25                 TURN OVERLAP OFF
         LW,R0    TAPEDEV           CHECK IF TAPE AND
         LI,R1    X'1F00'            DISC ARE ON THE
         CS,R0    DISCDEV             SAME IOP
         BE       NEWTP
         SETBIT   IND,25            NO - SET OVERLAP ON
NEWTP    EQU     %
         TDV,R5   *TAPEDEV          GET DEVICE STATUS
         TESTBIT  R5,REISSUE,5      BRANCH IF AT LOAD POINT
         LI,R0    DA(REWCW)         REWIND COMMD
         B        COMSIO            BRANCH TO REWIND NEW TAPE
REISSUE  EQU      %
         LPSD,0   C1OLDPSD          RETURN TO CAL1
         TITLE    'CALL 2 ROUTINES. DISC OPERATIONS'
*                                   DISC ROUTINES
*
D:CHK1   EQU     %
         TESTBIT  INDICATE,WRT1ACK,8,9 BRANCH IF DISC BUSY
         SETBIT   INDICATE,8,23     SET BUFFER 1 BUSY & CHK-WRT
         LW,R0    BUF1WRD4
         STW,R0   DISCDEV           PLACE DISC ADDR IN DEV TABLE
         LW,R0    %+4               GET ORDER AND DATA ADDRESS
         STW,R0   BUF1CW2           STORE IN COMMD LIST
         LI,R0    DA(BUF1CW1)       ADDR OF COMMD LIST
         B        %+2
         GEN,8,24 5,BA(BUF1DATA)    CHECK-WRITE BUFFER 1
         STW,R0   CWSAV             SAVE R0
         B        DISC              GO ISSUE SIO
WRT1ACK  EQU      %
         LI,R2    D:CHK1            SET RETURN TO RETRY
         B        DISCWAIT
D:CHK2   EQU     %
         TESTBIT  INDICATE,WRT2ACK,8,9  BRANCH IF DISC BUSY
         SETBIT   INDICATE,9,23     SET BUFFER 2 BUSY & CHK-WRT
         LW,R0    BUF2WRD4
         STW,R0   DISCDEV           PLACE DISC ADDR IN DEV TABLE
         LW,R0    %+4               GET ORDER AND DATA ADDRESS
         STW,R0   BUF2CW2           STORE IN COMMD LIST
         LI,R0    DA(BUF2CW1)       ADDR COMMAND LIST
         B        %+2
         GEN,8,24  5,BA(BUF2DATA)   CHECK-WRITE BUFFER 2
         STW,R0   CWSAV             SAVE R0
         B        DISC              GO ISSUE SIO
WRT2ACK  EQU      %
         LI,R2    D:CHK2            SET RETURN TO RETRY
         B        DISCWAIT
D:RD1    EQU     %
         TESTBIT  INDICATE,RDISC1,8,9 BRANCH IF DISC BUSY
         SETBIT   INDICATE,8        SET DISC BUSY
         LW,R0    %+4               GET ORDER CODE AND DATA ADDR
         STW,R0   BUF1CW2           STORE IN COMMD LIST
         LI,R0    DA(BUF1CW1)       ADDR OF COMMD LIST
         B        %+2
         GEN,8,24  18,BA(BUF1DATA)    READ RAD INTO BUFFER 1
         STW,R0   CWSAV             SAVE R0
         B        DISC              GO ISSUE SIO
RDISC1   EQU      %
         LI,R2    D:RD1             SET RETURN TO RETRY
         B        DISCWAIT
D:RD2    EQU     %
         TESTBIT  INDICATE,RDISC2,8,9  BRANCH IF DISC BUST
         SETBIT   INDICATE,9        SET DISC BUSY
         LW,R0    %+4               GET ORDER CODE AND DATA ADDR
         STW,R0   BUF2CW2           STORE IN COMMAND LIST
         LI,R0    DA(BUF2CW1)       ADDR OF COMMD LIST
         B        %+2
         GEN,8,24  18,BA(BUF2DATA)   READ RAD INTO BUFFER 2
         STW,R0   CWSAV             SAVE R0
         B        DISC              GO ISSUE SIO
RDISC2   EQU      %
         LI,R2    D:RD2             SET RETURN TO RETRY
         B        DISCWAIT
D:WRT1   EQU     %
         TESTBIT  INDICATE,WRT1A,8,9 BRANCH IF DISC BUSY
         SETBIT   INDICATE,8          SET DISC BUSY
         LW,R0    BUF1WRD4
         STW,R0   DISCDEV
         LW,R0    %+4               GET ORDER CODE AND DATA ADDR
         STW,R0   BUF1CW2           STORE IN COMMD LIST
         LI,R0    DA(BUF1CW1)       ADDR OF COMMD LIST
         B        %+2
         GEN,8,24  1,BA(BUF1DATA)   WRITE FROM BUFFER 1
         STW,R0   CWSAV             SAVE R0
         B        DISC              GO ISSUE SIO
WRT1A    EQU      %
         LI,R2    D:WRT1            SET RETURN TO RETRY
         B        DISCWAIT          GO WAIT FOR DISC TO FREE UP
D:WRT2   EQU     %
         TESTBIT  INDICATE,WRT2A,8,9  BRANCH IF DISC BUSY
         SETBIT   INDICATE,9          SET DISC BUSY
         LW,R0    BUF2WRD4
         STW,R0   DISCDEV
         LW,R0    %+4               GET ORDER CODE AND DATA ADDR
         STW,R0   BUF2CW2           STORE IN COMMD LIST
         LI,R0    DA(BUF2CW1)       ADDR OF COMMD LIST
         B        %+2
         GEN,8,24  1,BA(BUF2DATA)   WRITE FROM BUFFER 2
         STW,R0   CWSAV             SAVE R0
         B        DISC              GO ISSUE SIO
WRT2A    EQU      %
         LI,R2    D:WRT2            SET RETURN TO RETRY
         B        DISCWAIT          GO WAIT FOR DISC TO TERM
D:WTE    EQU     %
WTEDSK   EQU      %                 WAIT FOR DISC TO TERM
         TESTBIT  INDICATE,WTEDSK1,8,9  BRANCH IF DISC BUSY
         MTW,M1   C2OLDPSD          INCREMENT RETURN
         LPSD,0   C2OLDPSD          NO--DISC FREE RETURN
WTEDSK1  LI,R2    WA(WTEDSK)        DISC BUSY SET RETURN FOR NEW TEST
DISCWAIT EQU      %                 WAIT FOR DISC INTERRUPT
          WD,R0     ALLOW
         WAIT     0
TIO:     LW,R13   *85               GET CLOCK
         AI,R13   2                 ADD 2   MILLISEC.
         CW,R13   *85
         BG       %-1               WAIT BEFORE TIO
         TIO,R13  *DISCDEV
         BCS,12   TIO:              BR TO WAIT IF BSY
         B        *R2               RETURN
*
D:SET0   EQU     %
DISC     EQU      %                 PERFORM DESIRED OPERATION
         LW,R9    DISCDEV
         CW,R9    RDISC
         BNE      TYPDV
         LW,R9    DDEV
         STW,R9   DISCDEV
DVP1     EQU     %
         LW,R0    CWSAV             RESTORE R0
         LW,R3    *C2OLDPSD         GET ERROR RECOVERY ADDR
         STW,R3   DISCREC           SAVE RECOVERY ADDR
         SIO,R0   *DISCDEV          ISSUE ORDER
         BCS,M4   TSTBSYD           TEST FOR NO ADDRESS RECOGINITION
         BCR,M12  GOODDISC          EXIT IF GOOD START
         BCS,M8   BUSYY1            WAIT IF SELECTOR IOP BYSY
*        WE WILL NEVER FALL THRU THE ABOVE BRANCH TABLE
TSTBSYD  BCR,M8   BUSYY1            FALL THROUGH IF NO ADDR RECOG
         LI,R6    BA(MSGX7)         GET MESSAGE ADDR
         BAL,R15  COMTYPE           TYPE 'DISC UNIT UNAVAILABLE'
         LW,R9    DISCDEV           GET DISC UNIT
         BAL,R15  PRTHEX            ADDRESS
         STW,R11  WORK              CONVERTED
         LI,R6    BA(WORKT)+3       AND
         BAL,R15  COMTYPE           TYPED FOLLOWING MSG
         LI,R6    BA(MSGX6)         GET 2ND MESSAGE ADDR
         BAL,R15  COMTYPE           TYPE 'JOB ABORTED'
         B        BYLABL            ABORT
BUSYY1   BAL,R2   DISCWAIT          GO WAIT FOR BUSY TO CLEAR
         B        DISC              NOW TRY OPERATION
GOODDISC EQU      %
         LW,R0    DISCDEV
         STW,R0   DDEV
         MTW,M1   C2OLDPSD          INCREMENT RETURN
         LPSD,0   C2OLDPSD          RETURN
TYPDV    EQU      %
         STW,R9   RDISC
         TESTBIT  IND,OVRRD,16
         BAL,R15  PRTHEX
         LI,R15    21
         STB,R15   R11
         STW,R11  WORK
         LI,R6    BA(WORKT)+3
         BAL,R15  COMTYPE           TYPE NEW DISC ADDR
OVLP1    EQU      %
         OFFBIT   INDICATE,25           TURN OFF OVERLAP BIT
         LW,R0    TAPEDEV           CHECK IF TAPE AND
         LI,R1    X'1F00'            DISC ARE ON THE
         CS,R0    DISCDEV             SAME IOP
         BE       DVP1
         SETBIT   INDICATE,25       NO - SET OVERLAP BIT
         B        DVP1
OVRRD    EQU      %
         BAL,R15  PRTHEX
         LI,R15   X'15'
         STB,R15  R11
         STW,R11  WORK
         LI,R6    BA(WORKT)+3
         BAL,R15  COMTYPE
         LI,R6    BA(REQDC)
         BAL,R15  COMTYPE
         BAL,R15  COMREAD
         LI,R6    BA(INPUT)
         LI,R1    4
         BAL,R15  CPTOHEX
         STW,R9   DISCDEV
         B        OVLP1
         TITLE    'SUB-ROUTINES'
* *
*   *             SUB-ROUTINE TO NOTIFY OPERATOR OF DEFECTIVE PARAM
* *
GPARAM   EQU      %
         LI,R6    BA(MSGX9)         GET MSG ADDR
         BAL,R15  COMTYPE           TYPE CANNOT DECODE PARAM'
         LI,R6    BA(WORKT)+3       MSG ADDR
         BAL,R15  COMTYPE           TYPE PARAM THAT CANNOT BE DECODED
         SETBIT   INDICATE,14       SET TYPE-IN ERROR
         TIONEW   *TYPEDEV
         AI,X1    1                 BUMP INDEX PAST CURRENT COMMA
         B        CR                GO TO NEXT COMMD
         SPACE    3
* *
*   *             SUB-ROUTINE TO MOVE BLANKS TO WORK AREA
* *
BLNKWRK  EQU      %
         LOADM    3,6,BLANK         GET 3 WORDS OF BLANKS
         STOREM   3,6,WORK          STORE IN WORK AREA
         STOREM   3,6,WORK+3
         STOREM   3,6,WORK+6
         B        *R15              RETURN
         SPACE    3
* *
*   *             SUB-ROUTINE TO CONVERT 4 BYTES OF HEX DIGITS TO 8
*   **            8BYTES OF PRINTABLE EBCDIC. THE 4 BYTES TO CONVERT
*   *             ARE IN REG 9. 8 BYTES OF EBCDIC WILL BE IN R10 & R11
* *
PRTHEX   EQU      %
         PUSHREG  14,12,SUBSTACK
         BCS,M2   STKERROR          *TEST*
         LI,X1    0                 SET
         LI,X2    8                 INDEXES
XD1      LI,R8    0                 CLEAR R8
         SLD,R8   4                 GET MSD FROM R9 INTO R8 LSD
         CI,R8    9                 TEST FOR NUMERIC
         BG       %+2               BRANCH IF A-F
         AI,R8    57                ADD 57 AND 183 IF NUMERIC
         AI,R8    183               ADD 183 FOR ALPHA
         STB,R8   R10,X1            STORE RESULTS IN R10 & R11
         AI,X1    1                 BUMP OUTPUT INDEX
         BDR,X2   XD1               CONVERT 8 DIGITS FOR PRINTING
         STD,R10  WORK
         PULLREG  14,12,SUBSTACK
         B        *R15              RETURN
         TITLE    'SET UP DEFAULT VALUES'
PRESET   EQU      %                 SET DEFAULT OPTIONS + INITILIZE
         LI,R1    4144              ARM & ENABLE
         WD,R1    4608              ALL INTERRUPTS
         LI,R1    0
         STW,R1   BUF1WRD2
         STW,R1   DDEV
         STW,R1   RDISC
         STW,R1   BUF2WRD2          CLEAR SEEK ADDR
         LOADM    7,1,M7204
         STOREM   7,1,LOSEEK        SET TO MOD 7204 RAD
         STW,R1   RETRYTP           ZERO
         STW,R1   TAPECOUT
         STW,R1   DISCOUNT
         STW,R1   DRTRY
         LOADM    2,2,PDISC         SET
         STOREM   2,2,DISCDEV       I/O ADDR
         LW,R2    X'25'             LOOK AT BOOT DEV ADR
         CI,R2    X'80'             CHECK IF MULTI-DEV CONTR
         BAZ      %+2               NO - LEAVE DEFAULT TAPE AT 80
         STW,R2   TAPEDEV           YES - PUT BOOT DEV TO DEFAULT TAPE
         LD,R2    PJOBSTK           SET
         STD,R2   JOBSTACK          JOB STACK
         LD,R2    PWRKSTK           POINTERS
         STD,R2   WRKJOBSK          TO EMPTY STACKS
         LD,R2    ALTSUB
         STD,R2   SUBSTACK
         B        *R15              RETURN
         SPACE    3
         TITLE    'SEEK ADDRESS INCREMENT ROUTINES'
**
* **              SEEK ADDRESS INCREMENT RTN FOR MOD.S 2,3 AND4
**
*                 WHEN THIS ROUTINE IS ENTERED REG 14 CONTAINS ADDR OF
*                 BUFFER THE INCREMENTED ADDR IS TO BE PLACED.
*                 REG. 15 CONTAINS THE RETURN ADDRESS
INC234   EQU      %
         PUSHREG  3,R1,SUBSTACK
         LW,R2    CURRSEEK          GET LAST USED SEEK ADDR
         AW,R2    INCREMNT          INCREMENT
         CW,R2    HISEEK            CHECK IF ALL DISC DONE
         BGE      STOP              YES STOP
         LW,R1    COUNT             NO  SET UP DISC
         LI,R3    X'4E'                 COMMANDS
         B        PSTCNT1
**
* *               SEEK ADDRESS INCREMENT RTN FOR MODEL 7212
*
INC11    EQU      %
         PUSHREG  3,R1,SUBSTACK
         LW,R3    =127*256*256      LOAD MASK
         LW,R2    CURRSEEK          GET LAST USED SEEK
         AW,R2    INCREMNT          INCREMENT
         CS,R2    =82*256*256       TEST IF TRACK OVERFLOW
         BGE      TRKINC            YES
         CW,R2    =(63**23)+(78**16)  CHECK IF ON LAST TAPE RECORD
         BNE      INCCNT            NO  CONTINUE
         LI,R1    4*1024            YES LOAD SHORT COUNT
         B        PSTCNT            CONTINUE
INCCNT   EQU      %
         LW,R1    COUNT             SET UP DISC COMMANDS
PSTCNT   LI,R3    X'1E'
PSTCNT1  STB,R3   R1
         STW,R1   *R14
         AI,R14   1
         STW,R2   CURRSEEK          STORE NEW SEEK ADDR
         STW,R2   *R14
         B        CONT
TRKINC   EQU      %
         AW,R2    =128*256*256-82*256*256   FIX SEEK ADDR
         CW,R2    HISEEK            CHECK IF DISC ALL DONE
         BGE      STOP              YES STOP
         B        INCCNT            NO  CONTINUE
STOP     EQU      %
         SETBIT   IND,20            SET BIT THAT DISC COMPLETED
CONT     PULLREG  3,1,SUBSTACK      RESTORE REGS
         B        *15               RETURN
**
* *               SEEK ADDRESS INCREMENT ROUTINE FOR MODEL 7232
**
INC21    EQU      %
         PUSHREG  3,R1,SUBSTACK
         LW,R2    CURRSEEK          GET LAST USED SEEK
         AW,R2    INCREMNT          INCREMENT
         CW,R2    HISEEK            CHECK IF ALL DISC DONE
         BGE      STOP              YES STOP
         B        INCCNT            NO CONTINUE
*
**  7242 SEEK ADDR INCREMENT ROUTINE
**  ALSO WORKS FOR 7260 AND 7270 AND 7275
*
INC60    EQU      %
INC70    EQU      %
INC75    EQU      %
INC42    EQU      %
INC77    EQU      %
INC82    EQU      %
         PUSHREG  3,R1,SUBSTACK
         LW,R2    CURRSEEK          PICK UP LAST USED SEEK
         LI,R3    255*256           LOAD MASK
         AW,R2    INCREMNT          INCREMENT SEEK
         LW,R1    HISEEK            SPECIAL
         CW,R1    M7275+1           FOR 7275
         BE       INC75X            BECAUSE OF TRACKS/CYL=19
         CW,R1    M3275+1           CHECK FOR DISK 33
         BE       INC77X            BRANCH IF YES
         CW,R1    M3282+1           CHECK FOR DISK 66?
         BE       INC82X            BRANCH IF YES
         CS,R2    =20*256           CHECK IF TRACK OVERFLOW
         BL       INCCNT            NO-EXIT
         AW,R2    =256*256-20*256   FIX SEEK ADDR
INC42X   EQU      %
         CW,R2    HISEEK            CHECK IF THRU
         BL       INCCNT            NOT THRU - CONTINUE
         B        STOP              THRU
INC75X   EQU      %
INC77X   EQU      %
INC82X   EQU      %
         CS,R2    =19*256           CHECK IF TRACK OVERFLOW
         BL       INCCNT            NO-EXIT
         AW,R2    =256*256-19*256   FIX SEEK ADDRESS
         B        INC42X            AND RESUME IN COMMON CODE
         TITLE    'TAPE SUBROUTINES'
*                 TAPE SUB-ROUTINES
*
RTNTIO   EQU      %                 TEST TAPE STATUS
         PUSHREG  0,0,SUBSTACK      SAVE REGS
         BCS,M2   STKERROR          *TEST*
         MTW,M1   C1OLDPSD          INCREMENT RETURN
RTIO     EQU      %
         LI,R10   X'30'
         LI,R13   0
         TIO,R13  *TAPEDEV          ISSUE TIO
         BCR,M12  TIOOK             BRANCH IF AVAILABLE
         BDR,R10  %
         BCS,M8   TSB               BRANCH IF POSSIBLE SIOP BUSY
         BCS,M4   TIOOK             BRANCH IF DEVICE BUSY
TSB      BCR,M4   RTIO              BRANCH IF SOIP IS BUSY
         B        BADTIO            BRANCH--NO ADDR RECOG.
TIOOK    EQU      %
         LB,R7    R13               GET BITS 0-7 FROM TIO REG TO TEST
         CI,R7    128               TEST FOR BUSY OR INTERRUPT PENDING
         BCS,M4   TIOWAIT           BRANCH IF SO
         CI,R7    16                TEST FOR AUTO MODE
         BCS,M4   TIOO              BRANCH IF SO
BADTIO   LI,R6    BA(MSGY2)         MSG ADDR
         BAL,R15  COMTYPE           NOTIFY OPERATOR TAPE NOT AVAILABLE
         LI,R6    4096              DISABLE
         WD,R6    X'1300'           COUNTER 4
TIOWAIT  EQU      %
         WD,R0    ALLOW             ALLOW TAPE TO INTERRUPT
         WAIT     0                 WAIT
         LI,R6    4144              ENABLE
         WD,R6    4608              ALL INTERRUPTS
         B        RTIO              RETRY TIO
TIOO     EQU      %
         TIO,R11  *TAPEDEV          ASSURE TAPE IS FREE
         BCS,M12  RTIO              BRANCH IF NOT
         PULLREG  0,0,SUBSTACK      RESTORE REGS
         B        *R15              RETURN
COMSIO   EQU      %                 ISSUE COMMD IN REG 0
         STW,R0   TAPER0            SAVE COMMD ADDR.
         SIO,R0   *TAPEDEV
         BIOSNS   %-1               ASSURE GOOD START
         TIONEW   *TAPEDEV
FREEDEV  LPSD,0   C1OLDPSD          RETURN
         SPACE    2
RWCOMSIO EQU      %                 COMMON SIO RTN FOR TAPE READ/WRITE
         STW,R0   TAPER0            SAVE COMMD ADDR.
         LI,R7    -10               SET DISC CHECKWRITE ERROR COUNT
         STW,R7   CWRTERR            TO -10
         SIO,R7   *TAPEDEV          ISSUE COMMD
         BIOSNS   BTW               BRANCH IF SIO NO GOOD
         BCR,M12  RWRET             RETURN IF START SUCCESSFUL
         LI,R6    BA(MSGY2)         MSG ADDR
         BAL,R15  COMTYPE           GO TYPE TAPE UNIT NOT READY
         LI,R6    4096              ARM AND DISABLE
         WD,R6    X'1300'           COUNTER 4
         WAIT     0                 WAIT FOR OPERATOR
         LI,R6    4144              ARM AND ENABLE
         WD,R6    4608              ALL INTERRUPTS
         B        RWCOMSIO
RWRET    LPSD,0   C1OLDPSD          RETURN
TAPER0   DATA     0
BTW      EQU      %
         LB,R7    R7                GET BITS 0-7 IN PSN TO TEST
         CI,R7    128               TEST FOR INTRRUPT PENDING
         BCS,M4   BTWTE             BRANCH IF SO
         LI,R6    96                GET MASK
         AND,R7   R6                CLEAR ALL BITS EXCEPT BITS 1 AND 2
         CI,R7    96                TEST DEVICE BUSY
         BE       BTWTE             BRANCH IF SO
         HIO,R7   *TAPEDEV          HALT TAPE
         B        RWCOMSIO          RETRY
BTWTE    WD,R0    ALLOW             ALL TAPE
         WAIT     0                 TO
         B        RWCOMSIO          RETRY
         TITLE    'COMMON TYPE/KEYBOARD ROUTINES'
COMTYPE  PUSHREG  0,0,SUBSTACK      SAVE REGS
         BCS,M2   STKERROR          *TEST*
         TIONEW   *TYPEDEV
         LB,R14   R0,R6             GET TEXT COUNT
         LI,X7    7                 INDEX
         STB,R14  TYPECW,X7         STORE COUNT IN CW
         AI,R6    1                 INCREMENT BYTE ADDR PAST COUNT BYTE
         OR,R6    TYPEORDR          OR IN ORDER CODE
         STW,R6   TYPECW            STORE ORDER CODE AND BYTE ADDR IN CW
         PULLREG  0,0,SUBSTACK      RESTORE REGS
         LI,R0    DA(TYPECW)        CW ADDR
         SIO,R0   *TYPEDEV          TYPE MSG
         BIOSNS   %-1
         TIONEW   *TYPEDEV          WAIT FOR COMPLETION
         B        *R15
COMREAD  EQU      %                 ACCEPT KEY-IN RTN
         PUSHREG  0,0,SUBSTACK
REREAD   EQU      %
         LW,R0    BLANK             GET WRD BLANKS
         LI,R1    0                 SET INDEX
         LI,R2    20                BLANK 2/ WORDS
COMSTW   STW,R0   INPUT,R1          BLANK INPUT AREA
         AI,R1    1
         BDR,R2   COMSTW
         TIONEW   *TYPEDEV
         LI,R0    DA(READCW)        CW ADDR
         SIO,R0   *TYPEDEV          ALLOW OPERATOR TO TYPE
         BCR,M12  %+2               BRANCH ON GOOD START
         B        %-2               GET GOOD START
         TIONEW   *TYPEDEV
         LI,R1    80                SET NO OF CHAR
         LI,R2    BA(INPUT)+79      SET PTR AT END OF LINE
LNSCAN   EQU      %                 SCAN CHAR FOR ~
         LB,R0    0,R2
         CI,R0    C'~'
         BE       FIXLN             BRANCH IF ~ FOUND
         AI,R2    -1
         BDR,R1   LNSCAN            CONTINUE SCAN
LNCHK    EQU      %
         LB,R0    INPUT             CHECK FIRST CHAR
         CI,R0    X'15'             IF NEW-LINE
         BE       NOIN               OR
         CI,R0    X'08'             EOM
         BE       NOIN               BRANCH
         PULLREG  0,0,SUBSTACK      RETURN TO
         B        *R15               CALLER
FIXLN    EQU      %
         LI,R3    0                 SET TO BEG OF INPUT AREA
         LI,R4    80
         SW,R4    R1                SET TO CHAR CNT PAST ~
         AI,R2    1                 SET TO FIRST REAL CHAR
MVLN     EQU      %
         LB,R0    0,R2              ADJUST
         STB,R0   INPUT,R3           LINE
         AI,R3    1                   TO
         AI,R2    1                    START
         BDR,R4   MVLN                  CORRECTLY
         LI,R0    C' '              BLANK
BLLN     STB,R0   INPUT,R3           FILL
         AI,R3    1                   REMAINDER
         CI,R3    40                   OF
         BL       BLLN                  LINE
         B        LNCHK
NOIN     EQU      %                 NO CHAR RECEIVED
         LI,R6    BA(NOINP)          GIVE  ?  PROMPT
         BAL,R15  COMTYPE             AND TRY
         B        REREAD               AGAIN
         TITLE    'WRITE PROGRAM AND BOOT TO TAPE'
WRTBOOT  EQU      %
         STW,R15  BOOTRET           SAVE RETURN
         SETBIT   INDICATE,24       CAL1,6 IN USE
         IOREQ    T,REW,0           REWIND TAPE
TY1      EQU      %
RR       EQU      15
         TDV,RR   *TAPEDEV
         LC       RR
         BCS,4    WRT%OK            BR IF WRITE PERMITTED
         LI,R6    BA(MSGXX)         TYPE 'TAPE WRITE PROTECTED'
         BAL,R15  COMTYPE
         LI,R6    BA(MSGX6)         TYPE '  ABORT'
         BAL,R15  COMTYPE
         B        ENDJOBS       TYPE ENDING DATA
WRT%OK   EQU      %
          SETBIT    INDICATE,28    SET BOOT-WRT BIT
         LI,R0    DA(BOOTPGM)       WRITE
          IOREQ     T,SET0,BTDIRERR
          IOREQ     T,WTE,BTDIRERR
          OFFBIT    INDICATE,4,5,6,7   RESET BOOT-WRT
          OFFBIT    INDICATE,22,24,27,28   & CAL1,6 BITS
         B        *BOOTRET          RETURN
BOOT     LI,R0    24                DOUBLE-WORD ADDRESS OF CW
         LW,R1    46                EXCHANGE INSTRUCTIONS AT END OF LOAD
         STW,R1   42                STORE BRANCH TO PROGRAM AT LOAD
         B        39                BRANCH TO ISSUE LOADS SIO
         B        LOAD2             EXIT TO LOADED PROGRAM
         DATA     0
         GEN,8,24,8,24  2,256,14,20000
BTDIRERR  RES       0
          TESTBIT   INDICATE,BOOTER1,27  CK FOR RETRY
          SETBIT    INDICATE,27    TN ONERROR INDICATOR
BOOTER1   RES       0
          LI,R6     1              CK FOR  MAX TRIES
          AW,R6     RETRYTP        BUMP RETRY CT
          CI,R6     8
          BE        BOOTER3        ...BRANCH IF TRIED OUT
          STW,R6    RETRYTP        SAVE COUNT
          IOREQ     T,BSR,0        BACKSPACE
          IOREQ     T,ERG,0        SET ERASE
          TESTBIT   INDICATE,TY1,28
          TESTBIT   INDICATE,DIRXTY,29
          LI,R6     BA(MSGY5)
          BAL,R15   COMTYPE
          B         BYLABL
BOOTER3   RES       0
          LI,R6     BA(MSGX4)
          BAL,R15   COMTYPE
          LI,R6     BA(MSG::001)
          BAL,R15   COMTYPE
          B         ENDJOBS
WRTDIR   EQU      %
         STW,R15  BOOTRET           SAVE REG 15
         SETBIT   INDICATE,24       CAL1,6 IN USE
         LI,R1    8
         STW,R1   CNTDIR
         LD,R2    DTEHOLD           PUT DATE
         STD,R2   DATEDIR           IN DIRECTORY
          SETBIT    INDICATE,29    SET DIR-WRT BIT
         LI,R0    DA(WRDIRTRY)
DIRXTY   EQU      %
          IOREQ     T,SET0,BTDIRERR
          IOREQ     T,WTE,BTDIRERR
         IOREQ    T,WTM,0
          OFFBIT    INDICATE,4,5,6,7  RESET DIR-WRT
          OFFBIT    INDICATE,22,24,27,29   & CAL1,6 BITS
         B        *BOOTRET          RETURN
         TITLE    'CONVERT 1 WORD OF HEX TO PRINTABLE DECIMAL'
PRTDEC   EQU      %
         PUSHREG  3,2,SUBSTACK
         LI,R2    7                 SET INDEX TO STORE IN BYTE 7
         LI,R3    8                 EXECUTE 8 TIMES
         LI,R4    0                 CLEAR REMAINDE REG
DECX     DW,R4    TEN               DIVIDE BY 10 (CONVERT TO BASE 10)
         AI,R4    240               SET EBCDIC ZONE (F)
         STB,R4   DBLWRD,X2         STORE IN OUTPUT
         LI,R4    0                 CLEAR REMAINDER
         AI,X2    -1                REDUCE OUTPUT INDEX
         CW,R5    R4                TEST FOR ZERO QUOTENT
         BE       PAD               GO PAD HI-ORDER PSNS WITH BLANKS
         BDR,R3   DECX              CONVERT UP TO 8 OUTPUT DIGITS
         PULLREG  3,2,SUBSTACK
         B        *R15              RETURN
PAD      EQU      %
         AI,R3    -1                REDUCE PASS COUNT
         LI,R4    64                GET BLANK PAD CHARACTER
PAD1     STB,R4   DBLWRD,X2         STORE IN NEXT AVAILABLE OUTPUT PSN
         AI,X2    -1                DECREMENT OUTPUT INDEX
         BDR,R3   PAD1              PAD ALL HI-ORDER PSNS
         PULLREG  3,2,SUBSTACK
         B        *R15              RETURN
         TITLE    'INTERRUPT DECODER'
INTERR   EQU      %                 ACCEPT I/O INTERRUPTS
         PUSHREG  0,0,SUBSTACK
         AIO,R1   0                 ACCEPT INTERRUPT
         BCS,M8   FALTINTR          BRANCH IF NO INTERRUPT PRESENT
         STCF     CCHOLD            SAVE CONDITION CODE
         STW,R1   R1SAVE            SAVE INTERRUPT
         LI,R3    X'3FFF'
         LS,R3    R1SAVE            LOAD INTERUPT DEVICE ONLY
         CW,R3    DISCDEV           TEST FOR DISC INTERRUPT
         BE       DISCHAND
         CW,R3    TAPEDEV           TEST FOR TAPE INTERRUPT
         BE       TAPEHAND
         B        FALTINTR
LPSDRET  PULLREG  0,0,SUBSTACK
         LPSD,M3  IOINTOLD          RETURN
CCHOLD   DATA     0                 CONDITION CODE SAVE AREA
R1SAVE   DATA     0
R1SAVED  DATA     0                 LAST DISC INTERRUPT
R1SAVET  DATA     0                 LAST TAPE INTERRUPT
R2SAVE   DATA     0                 REGISTER 2 SAVE AREA
R12SAV   DATA     0                 REGISTER 12 SAVE AREA
         TITLE    'TAPE INTERRUPT SERVICING ROUTINES'
TAPEHAND EQU      %                 SERVICE TAPE INTERRUPT
         STW,R1   R1SAVET           SAVE INTERRUPT **FOR DEBUG ONLY**
         TESTBIT  INDICATE,OKTAPE,4,5,6,7,24  BRANCH IF TAPE BUSY
         B        LPSDRET           NO TAPE OPER IN PROGRESS - RETURN
OKTAPE   CW,R1    TPAIO             TEST FOR ERROR
         BCS,M4   TAPERROR          BRANCH IF UNUSUAL END INTERRUPT
TPENDTP  EQU      %
         OFFBIT   INDICATE,4,5,6,7,22 TURN OFF TAPE BUSY & RETRY BITS
         LI,R0    0
         STW,R0   RETRYTP           ZERO TAPE RETRY COUNT
         B        LPSDRET           EXIT
TAPERROR EQU      %                 ERROR RECOVERY
         TESTBIT  INDICATE,TPER22,22 BRANCH IF THIS WAS A RETURY
         MTW,1    TAPECOUT          ADD 1 TO ERROR COUNT
         SETBIT   INDICATE,22       SET RETRY BIT
TPER22   EQU      %
         LW,R5    K1FFFF            GET LOAD SELECTIVE MASK
         LS,R5    TAPEREC           GET ERROR RECOVERY ADDR
         BCR,M3   TAPERRTN          BRANCH IF NO ADDR PROVIDED
         OFFBIT   INDICATE,4,5,6,7,22 TURN OFF TAPE BUSY & RETRY BITS
         B        ABINT             EXIT TO USER ERROR RECOVERY
TAPERRTN EQU      %
         TESTBIT  INDICATE,LPSDRET,24  BRANCH IF CAL1,6
         TDV,R3   *TAPEDEV          GET STATUS
         LB,R6    R3                GET BITS 0-7 FOR TEST
         CI,R6    128
         BCS,4    NORMRTRY
         CI,R6    32
         BCS,M4   TPWRTPR           BRANCH ON WRITE PROTECT VIOLATION
         CI,R6    16
         BCS,M4   TPEOF             BRANCH ON END-OF-FILE
         STW,R2   R2SAVE            SAVE REGISTER 2
         STW,R12  R12SAV            SAVE REGISTER 12
         TDV,R2   *TAPEDEV          GET DEVICE STATUS
         AND,R2   =X'FFFFFF'        ISOLATE CCD ADDRESS
         SLS,R2   3                 GET BYTE ADDRESS
         LB,R12   0,R2              GET ORDER CODE IN R12
         LW,R2    R2SAVE            RESTORE REG 2
         CI,R12   X'02'             IS THIS A READ OPERATION
         BNE      DVD001            BRANCH IF NOT
         CI,R6    8
         BCS,M4   NOCORR            BRANCH ON UNCORRECTABLE READ ERROR
DVD001   EQU      %
         TESTBIT  R3,NORMRTRY,9
         LW,R12   R12SAV            RESTORE REGISTER 12
         CI,R6    2
         BCS,M4   TPEOR             BRANCH ON END OF TAPE -WRITE
*                 ERROR CANNOT BE ISOLATED PREPARE TO ABORT
         LI,R6    8                 GET STATUS LENGTH
         STW,R6   WORKT             STORE. WORK NOW IS A TEXTC COUNT =8
         LW,R9    R1SAVE            GET AIO STAUTS
         LI,R6    BA(MSGY5)         GET MSG ADDR
         BAL,R15  COMTYPE           TYPE 'UNDEFINED I/O ERROR'
         BAL,R15  PRTHEX            CONVERT AIO STATUS FOR PRINTING
         LI,R6    BA(MSGY6)         GET MSG ADDR
         BAL,R15  COMTYPE           TYPE 'AIO STATUS-'
         LI,R6    BA(WORKT)+3       MSG ADDR
         BAL,R15  COMTYPE           TYPE            'XXXXXXXX'
         LI,R6    BA(MSGY7)         GET MSG ADDR
         BAL,R15  COMTYPE           TYPE 'TDV STATUS-'
         LW,R9    R3                GET TDV STATUS
         BAL,R15  PRTHEX            CONVERT FOR PRINTING
         LI,R6    BA(WORKT)+3       MSG ADDR
         BAL,R15  COMTYPE           TYPE            'XXXXXXXX'
         TIO,R9   *TAPEDEV          GET TIO STATUS
         BAL,R15  PRTHEX            CONVERT FOR TYPING
         LI,R6    BA(MSGYA8)        MSG ADDR
         BAL,R15  COMTYPE           TYPE 'TIO STATUS'
         LI,R6    BA(WORKT)+3
         BAL,R15  COMTYPE           TYPE ACTUAL STATUS
         LI,R6    BA(MSGX6)         GET MSG ADDR
         BAL,R15  COMTYPE           TYPE 'JOB ABORTED'
         LI,R6    4                 RESTORE COUNT OF 4
         STW,R6   WORKT             TO WORK FIELD
         B        BYLABL            ABORT
TPWRTPR  LI,R6    BA(MSGY3)         GET MSG ADDR
         MTW,-1   TAPECOUT          WRITE PROTECT VIOLATION NOT ERROR
         BAL,R15  COMTYPE           TYPE 'TAPE UNIT FILE PROT---
         LI,R6    4096              ARM AND DISABLE
         LI,R6    4096+16           COUNTER AND CP
         WD,R6    X'1300'           COUNTER 4
         WAIT     0                 WAIT
         LI,R6    4144              ARM AND ENABLE
         WD,R6    4608              ALL INTERRUPTS
         LW,R0    TAPER0            RESTORE COMMD ADDR.
         B        TPX1              GO RE-ISSUE COMMD
TPEOF    LI,R0    DA(REOFCW)        GET ADDR OF COMMD TO READ TRAILER
         MTW,-1   TAPECOUT          EOF IS NOT TAPE ERROR
         SIO,R0   *TAPEDEV          READ TRAILER
         BIOSNS   %-1
         TIONEW   *TAPEDEV
         LB,R5    WORK              TEST FOR END OF REEL
         CI,R5    C'*'              TEST FOR END OF REEL
         BE       NEWREELT          BRANCH IF SO
         SETBIT   INDICATE,17       SET END OF FILE INDICATOR
         OFFBIT   INDICATE,4,5,6,7  SET TAPE NOT BUSY
         B        LPSDRET           RETURN
TPEOR    EQU      %
         MTW,-1   TAPECOUT          END OF REEL IS NOT TAPE ERROR
         B        TPENDTP           GO EXIT
NEWREELT LI,R6    BA(MSGY4)         GET MSG ADDR
         BAL,R15  COMTYPE           TYPE 'END OF REEL. ASSIGN NEW TAPE'
         LI,R0    DA(OFFLINE)
         SIO,R0   *TAPEDEV          REWIND THIS TAPE OFF LINE
         BAL,R15  COMREAD           GET NEW TAPE ADDR
         LI,R6    BA(INPUT)         SET PTR TO INPUT
         LB,R0    0,R6              EXAMINE FIRST BYTE
         CI,R0    C'M'              CHECK IF MT ENTERED
         BNE      %+2                NO
         AI,R6    2                  YES-ADJUST PTR
         LI,R1    4
         BAL,R15  CPTOHEX           CONVERT TO HEX
         LW,R5    R9
         STW,R5   TAPEDEV           STORE NEW TAPE ADDR FOR USE
         TDV,R5   *TAPEDEV          GET TAPE STATUS
         BCS,M12  NEWREELT          BRANCH IF NO RECOGINITION
         TESTBIT  R5,NOREWD,5       BRANCH IF AT LOAD POINT
         LI,R0    DA(REWCW)         REWIND
         SIO,R0   *TAPEDEV          NEW
         BIOSNS   %-1               TAPE
         TIONEW   *TAPEDEV
NOREWD   TESTBIT  INDICATE,REDOB1,4   BRANCH IF USING BUFFER 1
         LI,R0    DA(RDBUF2CW)      NO--SET UP FOR READ BUFFER 2
         B        TPX1              PREPARE TO REISSUE COMMD
NOCORR   EQU      %
         LI,R6    1
         AWM,R6   RETRYTP
         SLS,R6   3
         CW,R6    RETRYTP
         BE       TOBADTP
         LI,R0    DA(BSRCW)         BACK SPACE
         SIO,R0   *TAPEDEV          TAPE
         BIOSNS   %-1
         TIONEW   *TAPEDEV
         B        NOCORRA
REDOB1   LI,R0    DA(RDBUF1CW)      SET UP FOR READ BUFFER 1
         B        TPX1              PREPARE TO REISSUE READ
NORMRTRY EQU      %
         LW,R12   R12SAV            RESTORE REGISTER 12
         LI,R6    1                 ADD ONE
         AWM,R6   RETRYTP           TO RETRY COUNT
         SLS,R6   3                 GET COUNT OF 8
         CW,R6    RETRYTP           COMPARE RETRY COUNT TO 8
         BE       TOBADTP           BRANCH IF WE HAVE RETRIED 7 TIMES
         TESTBIT  INDICATE,REWRT,6,7  BRANCH IF WRITE COMMD
         LI,R0    DA(SENSECW)       SET  SENSE
         SIO,R0   *TAPEDEV
         BIOSNS   %-1
         LI,R0    DA(BSRCW)         BACKSPACE TAPE ONE RECORD
         SIO,R0   *TAPEDEV
         BIOSNS   %-1
         TIONEW   *TAPEDEV
         LI,R0    DA(SETCORR)       SET  CORRECTION
         SIO,R0   *TAPEDEV
         BIOSNS   %-1
NOCORRA  TESTBIT  INDICATE,STBUF2,5  BRANCH IF READ WAS BUF 2
         LI,R0    DA(RDBUF1CW)      LOAD R0 FOR READ TO BUFFER 1
         B        TPX1              BRANCH TO PREPARE TO RE-ISSUE READ
STBUF2   LI,R0    DA(RDBUF2CW)      LOAD R0 FOR READ TO BUFFER 2
TPX1     EQU      %                 ISSURE COMMD
         SIO,R0   *TAPEDEV
         BIOSNS   %-1
         B        LPSDRET
TOBADTP  EQU      %                 RETRY COUNT EXPIRED
         LI,R6    BA(MSGX4)         MSG ADDR
         BAL,R15  COMTYPE           TYPE 'UNRECOVERABLE TAPE ERROR
         TESTBIT  INDICATE,BDWRT,6,7 BRANCH IF WRITE OPERATION
         LI,R6    BA(MSGX5)         MSG ADDR
         BAL,R15  COMTYPE           TYPE 'READ OPERATION
         B        TPIODIAG          BRANCH TO TYPE STATUS
BDWRT    LI,R6    BA(MSGX5A)        MSG ADDR
         BAL,R15  COMTYPE           TYPE 'WRITE OPERATION
TPIODIAG LW,R9    R1SAVE            GET AIO STATUS
         BAL,R15  PRTHEX            CONVERT HIO STATUS TO GRAPHIC
         LI,R9    8                 SET MSG LENGTH IN WORK
         STW,R9   WORKT             AREA TO 8 BYTES
         LI,R6    BA(MSGY6)         MSG ADDR
         BAL,R15  COMTYPE           TYPE 'AIO STATUS-'
         LI,R6    BA(WORKT)+3       MSG ADDR
         BAL,R15  COMTYPE           TYPE AIO STATUS
         LI,R6    BA(MSGY7)         MSG ADDR
         BAL,R15  COMTYPE           TYPE 'TDV STATUS-'
         LW,R9    R3                GET TDV STATUS
         BAL,R15  PRTHEX            CONVERT FOR TYPING
         LI,R6    BA(WORKT)+3       MSG ADDR
         BAL,R15  COMTYPE           TYPE TDV STATUS
         TIO,R9   *TAPEDEV          GET TIO STATUS
         LI,R6    BA(MSGYA8)        MSG ADDR
         BAL,R15  COMTYPE           TYPE 'TIO STATUS'
         BAL,R15  PRTHEX            CONVERT TIO STATUS FOR TYPING
         LI,R6    BA(WORKT)+3
         BAL,R15  COMTYPE           TYPE ACTUAL STATUS
         LI,R6    4                 SET WORK AREA
         STW,R6   WORKT             COUNT BACK TO 4
         TESTBIT  IND,URE,4,5
ABTP     EQU      %
         LI,R6    BA(MSGX6)         MSG ADDR
         BAL,R15  COMTYPE           TYPE 'JOB ABORTED'
         B        BYLABL            ABORT
REWRT    EQU      %
         LI,R0    DA(BSRCW)         BACKSPACE TAPE ONE RECORD
         SIO,R0   *TAPEDEV
         BIOSNS   %-1               LOOP IF SIO NOT ACCEPTED
         TIONEW   *TAPEDEV
         LI,R0    DA(ERGCW)         SET
         SIO,R0   *TAPEDEV          ERASE
         BIOSNS   %-1
         TESTBIT  INDICATE,SWRTXB2,7  BRANCH IF WE ARE WRITTING BUF 2
         LI,R0    DA(WRTB1CW)       SET UP TO RE-WRITE BUT 1
         B        TPX1              BRANCH TO ISSUE SIO
SWRTXB2  LI,R0    DA(WRTB2CW)       SET UP TO RE-WRITE BUF 2
         B        TPX1
FALTINTR LI,R6    BA(MSGY8)         MSG ADDR
         BAL,R15  COMTYPE           TYPE 'SPURIOUS INTERRUPT'
         LW,R9    R1                GET AIO REG
         BAL,R15  PRTHEX            CONVERT FOR TYPING
         LI,R6    8                 SET MSG
         STW,R6   WORKT             LENGTH TO 8
         LI,R6    BA(WORKT)+3
         BAL,R15  COMTYPE           TYPE CONTENTS OF AIO REG
         LI,R6    4                 SET MSG LENGTH
         STW,R6   WORKT             BACK TO 4
         B        LPSDRET
URE      EQU      %
         LI,R6    BA(ASMS)
         BAL,R15  COMTYPE
         BAL,R15  COMREAD
         LI,R6    BA(INPUT)
         LB,R0    0,R6
         CI,R0    C'X'
         BE       ABTP
         CI,R0    C'M'
         BNE      %+2
         AI,R6    2
         LI,R1    4
         BAL,R15  CPTOHEX
         CI,R9    0
         BE       ABTP
         B        LPSDRET
*
*
*
         TITLE    'DISC INTERRUPT SERVICING ROUTINES'
DISCHAND EQU      %                 SERVICE DISC INTERRUPTS
         STW,R1   R1SAVED           SAVE INTERRUPT **FOR DEBUG ONLY**
         TESTBIT  INDICATE,OKDISC,8,9  BRANCH IF DISC BUSY
         B        LPSDRET           NO-RETURN AND IGNORE INTERRUPT
OKDISC   EQU      %
         TDV,R3   *R1
         CW,R3    =1**30            TEST IF FLAW BIT OF TDV IS SET
         BANZ     FLAWHANDLER       YES
         OFFBIT   IND,15
FLAWSKIP EQU      %
         TESTBIT  IND,BF1,8
         STW,R3   HDR2TDV           STORE TDV IN BUF 2 SLOT
         B        BF
BF1      EQU      %
         STW,R3   HDR1TDV
BF       EQU      %
         LCF      CCHOLD
         BCS,M4   DISCERRO
         OFFBIT   INDICATE,8,9,23   SET DISC NOT BUSY
         LI,R0    0
         STW,R0   DRTRY             ZERO DISC RETRY COUNT
         B        LPSDRET           EXIT
DISCERRO EQU      %                 ERROR RECOVERY
         LW,R5    K1FFFF            GET LOAD SELECTIVE MASK
         LS,R5    DISCREC           GET ERROR RECOVERY ADDR
         BCR,M3   DISCERTN          BRANCH IF NO ADDR PROVIDED
         OFFBIT   INDICATE,8,9,23   SET DISC NOT BUSY
         LW,R7    DRTRY             GET RETRY COUNT
         BCS,2    EXI1              BRANCH IF NOT ZERO
         MTW,1    DISCOUNT          ADD 1 TO TOTAL ERRORS
EXI1     EQU      %
         AI,R7    1                 BUMP COUNT
         CI,R7    8                 THIS LAST TRY
         BE       DSTATUS           GO TYPE ERROR MSG
         STW,R7   DRTRY             STORE NEW RETRY COUNT
         B        ABINT             EXIT TO USER ERROR RECOVERY
DISCERTN EQU      %
         LB,R6    R3                GET BITS 0-7 FOR TEST
         CI,R6    128
         BCS,M4   RUNDISC           BRANCH ON OVER RUN
         CI,R6    32
         BCS,M4   NOSECT            BRANCH ON INVALID SEEK ADDR
         CI,R6    16
         BCS,M4   WRPRDSC           BRANCH ON WRITE PROTECT VIOLATION
         TESTBIT  R1,RUNDISC,9      BRANCH IF PARITY ERROR
         LI,R6    BA(MSGY5)         MSG ADDR
         BAL,R15  COMTYPE           TYPE 'UNDEFINED I/O ERROR'
DSTATUS  LW,R9    R1                GET STATUS
         BAL,R15  PRTHEX            CONVERT FOR TYPING
         LI,R6    8                 SET COUNT FOR
         STW,R6   WORKT             MSG TO 8
         LI,R6    BA(MSGY6)         MSG ADDRESS
         BAL,R15  COMTYPE           TYPE 'AIO STATUS-
         LI,R6    BA(WORKT)+3       MSG ADDR
         BAL,R15  COMTYPE           TYPE            'XXXXXXXX'
         LI,R6    BA(MSGYA8)        MSG ADDR
         BAL,R15  COMTYPE           TYPE 'TIO STATUS'
         TIO,R9   *DISCDEV          GET TIO STATUS
         BAL,R15  PRTHEX            CONVERT FOR TYPING
         LI,R6    BA(WORKT)+3
         BAL,R15  COMTYPE           TYPE ACTUAL STATUS
         LI,R6    4                 RESET WORK AREA
         STW,R6   WORKT             COUNT TO 4
         TESTBIT  INDICATE,ERCHKWRT,23  BRANCH IF CHK-WRT IN PROGRESS
         B        BYA10
ERCHKWRT EQU      %
         LI,R6    BA(MSGYA10)
         BAL,R15  COMTYPE           TYPE '-CHECK WRITE OPERATION'
BYA10    EQU      %
         LI,R6    BA(MSGX6)         MSG ADDR
         BAL,R15  COMTYPE           TYPE 'JOB ABORTED
         B        BYLABL            ABORT
RUNDISC  EQU      %
         TESTBIT  INDICATE,ADDCNTR,23  DONT COUNT CHECK-WRITE ERRORS
         LW,R6    DRTRY             GET RETRY COUNT
         BCS,M2   ADDCNTR           BRANCH IF RETRY COUNT GREATER THAB 0
         MTW,M1   DISCOUNT          BO RETRY COUNT ADD 1 TO TOTAL ERRORS
ADDCNTR  EQU      %
         MTW,M1   DRTRY             *             RETRY COUNT
         LW,R6    DRTRY             TEST FOR
         CI,R6    8                 RETRY COUNT = 8
         BE       DDONE             BRANCH WHEN WE HAVE RETIRED 7 TIMES
         TESTBIT  INDICATE,DOBUF2,9 BRANCH IF WE ARE USING BUFFER 2
         LI,R0    DA(BUF1CW1)       SET TO USE BUFFER 1
         B        DSCGO             GO ISSUE ORDER
DOBUF2   LI,R0    DA(BUF2CW1)       SET TO USE BUFFER 2
DSCGO    SIO,R0   *DISCDEV          REISSUE ORDER
         BIOSNS   %-1               ASSURE GOOD START
         B        LPSDRET           RETURN
DDONE    LI,R6    BA(MSGX8)         MSG ADDR
         BAL,R15  COMTYPE           TYPE 'UNRECOVERABLE ERROR ONDISC
         B        DSTATUS           GO TYPE STATUS
NOSECT   LI,R6    BA(MSGY9)         MSG ADDR
         BAL,R15  COMTYPE           TYPE 'INVALID SECTOR ADDR'
         TESTBIT  INDICATE,DKSEC1,8  BRANCH IF BUF 1 IN USE
         LW,R9    BUF2WRD2          GET SEEK ADDR
ABTNOSEC BAL,R15  PRTHEX            CONVERT TO PRINTABLE GRAPHICS
         STW,R10  WORK              STORE RESULT FOR TYPING
         LI,R6    BA(WORKT)+3       MSG ADDR
         BAL,R15  COMTYPE           TYPE SEEK ADDR
         LI,R6    BA(MSGX6)         ABORT MSG ADDR
         BAL,R15  COMTYPE           TYPE 'JOB ABORTED'
         B        BYLABL            ABORT
DKSEC1   LW,R9    BUF1WRD2          GET SEEK
         B        ABTNOSEC          BRANCH TO NOTIFY OPERATOR
WRPRDSC  LI,R6    BA(MSGY10)        MSG ADDR
         BAL,R15  COMTYPE           TYPE 'RAD WRITE PROTECTED. CLEAR WAI
         TESTBIT  INDICATE,WRD1,8    BRANCH IF BUF 1 IN USE
         LI,R0    DA(BUF2CW1)       SET R0 FOR REISSUE BUFFER 2 COMMDS
         LW,R9    BUF2WRD2          GET SEEK ADDR
WRABT    BAL,R15  PRTHEX            CONVERT FOR PRINTING
         STW,R10  WORK              STORE RESULT
         STW,R0   BOOTRET           SAVE R0
         LI,R6    BA(WORKT)+3       ADDR OF MSG
         BAL,R15  COMTYPE           TYPE SEEK ADDR
         LI,R6    4096              ARM AND DISABLE
         WD,R6    X'1300'           COUNTER 4
         WAIT     0                 WAIT
         LI,R6    4144              ARM AND ENABLE
         WD,R6    4608              ALL INTERRUPTS
         LW,R0    BOOTRET           RESTORE R0
         SIO,R0   *DISCDEV          RE-ISSUE CW
         BIOSNS   %-1
         B        LPSDRET           RETURN
WRD1     LI,R0    DA(BUF1CW1)       SET R0 FOR REISSUE BUFFER 1 COMMDS
         LW,R9    BUF1WRD2          GET SEEK ADDR
         B        WRABT             GO DECODE
         TITLE    'ABNORMAL INTERRUPT EXIT ROUTINE'
ABINT    EQU      %                 EXIT TO ERROR RECOVERY
         LB,R3    IOINTOLD
         STB,R3   R5                CC TO PSD
         STW,R5   IOINTOLD          STORE IN I/O OLD PSD
         B        LPSDRET
FLAWHANDLER EQU  %
         TESTBIT  IND,FLAWSKIP,15
         SETBIT   IND,15
         LD,R0    IOINTOLD          GET IO INT PSD
         PUSHREG  2,0,SUBSTACK      STORE IN STACK
         LPSD,M3  FLLPSD            CLEAR IO INT LEVEL
FLLPSDX  EQU     %
         TESTBIT  IND,FLAW2,9       CHECK IF FLAW WAS BUFFER 2
FLAW1    EQU     %                  NO
         LW,R1    =X'00FFFFFF'      LOAD MASK
         LI,R0    BA(BUF1WRD2)      SET UP
         STS,R0   CWHDRR             FLAW I/O
         STS,R0   CWHDRRX
         LI,R0    BA(BUF1DATA)        COMMAND
         LB,R3    BUF1CW1+2               PREVIOUS
FLAW     EQU      %
* IF NOT 7242 OR 7270, USE ALTERNATE ROUTINE (FLAW60).
         LW,R1    INCREMNT
         CW,R1    M7242+4
         BNE      FLAW60
*
         STB,R3   R0                       OPERATION
         STW,R0   BUFCMDLST+2          LISTS
         AI,R0    6*1024                FOR BUFFER 1,
         STW,R0   BUFCMDLST+6            REPEAT OF
         LI,R0    DA(CWHDRR)        SET UP TO READ HEADER
         SIO,R0   *DISCDEV
         BIOSNS   %-1
         TIONEW   *DISCDEV
         LI,R1    BA(HDRDATA1)
         LI,R2    BA(FLSEEK1)+1
         LB,R0    0,R1              CHECK IF FIRST TRACK FLAWED
         BEZ      NOFL1         NO
         AI,R1    5             YES LOAD ALTERNATE
         BAL,R14  LDFL               TO SEEK
FL2CK    EQU     %
         LI,R1    BA(HDRDATA2)
         LI,R2    BA(FLSEEK2)+1
         LB,R0    0,R1              CHECK IF SECOND TRACK FLAWED
         BEZ      NOFL2         NO
         AI,R1    5             YES LOAD ALTERNATE
         BAL,R14  LDFL               TO SEEK
FLCOMP   EQU     %
         LI,R0    DA(BUFCMDLST)
         WD,0     NOALLOW           INHIBIT INTERUPTS
         SIO,R0   *DISCDEV          REPEAT USER I/O REQUEST
         BIOSNS   %-1
         PULLREG  2,0,SUBSTACK      GET USER PSD
         STD,R0   LPSDLOC
         PULLREG  0,0,SUBSTACK      PULL REGS
         LPSD,0   LPSDLOC           RETURN TO USER
FLAW2    EQU     %                  FLAW WAS BUFFER 2
         LW,R1    =X'00FFFFFF'      LOAD MASK
         LI,R0    BA(BUF2WRD2)      SET UP
         STS,R0   CWHDRR             FLAW I/O
         LI,R0    BA(BUF2DATA)        COMMAND
         LB,R3    BUF2CW1+2            LISTS
         B        FLAW
NOFL1    EQU     %
         AI,R1    2                 NO FLAW ON FIRST TRACK
         BAL,R14  LDFL               USE ORIGINAL SEEK
         B        FL2CK
NOFL2    EQU     %
         AI,R1    2                 NO FLAW ON SECOND TRACK
         BAL,R14  LDFL               USE ORIGINAL SEEK
         B        FLCOMP
LDFL     EQU     %
         LW,R0    HISEEK            SPECIAL FOR
         CW,R0    M7242+1           7270 AND 7275
         BNE      LDFLX             BECAUSE #CYL=412
         LB,R0    0,X1
         CI,R0    NOCYL
         BGE      FLAERR            ALT CYL OUT OF RANGE
         STB,R0   0,X2
         AI,X1    1
         AI,X2    1
         LB,R0    0,X1
         CI,R0    NOTRK
         BGE      FLAERR            ALT TRACK OUT OF RANGE
         STB,R0   0,X2
         B        *R14
LDFLX    EQU      %                 GET ALT. SEEK FOR 7270/7275
         LB,R0    0,X1              ALT CYL(LOW 8 BITS)
         AI,X1    1
         LB,R3    0,X1              ALT TRACK (AND HIGH BIT OF CYL)
         CI,R3    X'80'             HIGH ORDER BIT OF ALT CYL
         BAZ      %+3               NOT SET
         AND,R3   =X'7F'            SET- TURN IT OFF
         OR,R3    =X'100'           AND SET IT WHERE IT BELONGS
         CI,R0    NOCYL70           ALT CYL IN RANGE
         BGE      FLAERR            NO-ERROR
         SLS,X2   -1                CHANGE TO HALFWORD INDEX
         STH,R0   0,X2              ALT CYL
         LW,R0    M7275+4           SEE IF 7275
         CW,R0    INCREMNT
         BE       %+3               B/ ITS 7275
         CI,R3    NOTRK             7270-20 TRACKS PER CYL
         B        %+2
         CI,R3    NOTRK-1           7275-ONLY 19 TRACKS/CYL
         BGE      FLAERR            ALT TRACK OUT OF RANGE
         SLS,R3   8                 SHIFT INTO PLACE
         AI,X2    1
         STH,R3   0,X2
         B        *14
FLAW60   EQU      %                 ALT. ROUTINE FOR NON-7242 TYPES
         STB,R3   R0                ORDER(READ OR WRITE)
         STW,R0   BUFCMDLSTX+2      IOCD(WORD 1)
         LI,R0    DA(CWHDRRX)       SET UP TO READ HEADER
         SIO,R0   *DISCDEV
         BIOSNS   %-1
         TIONEW   *DISCDEV
         LI,R1    BA(HDRDATA1)
         LI,R2    BA(FLSEEK1)+1
         LB,R0    0,R1              SEE IF TRACK IS REALLY FLAWED
         BEZ      FLAERR            NO-ERROR
         AI,R1    5
         BAL,R14  LDFL              SET UP ALT. SEEK
         LI,R0    DA(BUFCMDLSTX)    REPEAT USER REQUEST USING ALT SEEK
         B        FLCOMP+1
         TITLE    'END-OF-JOB ROUTINE'
ENDJOBS  EQU      %                 END-OF-JOB ROUTINE
BYLABL   EQU      %
         LI,R1    4144              ARM & ENABLE &RESET INHIBITS
         WD,R1    4608              FOR
         WD,R0    ALLOW             ALL INTERRUPTS
         TESTBIT  INDICATE,BYLAB,2,3  DONT WRITE TAPE MARKS ONE RESTORE
*                                    AND COMPARE JOBS
         IOREQ    T,WTM,0      COPY-WRITE-- TAPE MARK
         LI,R0    DA(EORWRT)             -- END OF FILE LABEL
         IOREQ    T,SET0,0                -- AND
         IOREQ    T,WTM,0                -- DOUBLE
         IOREQ    T,WTM,0                -- TAPE MARKS
BYLAB    LI,R0    DA(REWCW)         REWIND TAPE
         IOREQ    T,SET0,0
         LW,R9    BUF1WRD2          FIND LAST SEEK ADDR USED
         CW,R9    BUF2WRD2
         BG       USE1              BRANCH IF BUF 1 SEEK HI
         LW,R9    BUF2WRD2          BUF 2 WAS LAST USED
USE1     EQU      %                 REG 9 HAS LAST USED SEEK ADDR
         BAL,R15  PRTHEX            CONVERT LAST SEEK FOR TYPING
         LI,R6    BA(MSGYA9)        MSG ADDR
         BAL,R15  COMTYPE           PRINT 'LAST USED SEEK ADDR-'
         LI,R6    8
         STW,R6   WORKT             SET TEXTC FOR 8 BYTES
         LI,R6    BA(WORKT)+3       DATA ADDR
         BAL,R15  COMTYPE           TYPE ACTUAL SEEK ADDR
         LI,R6    4
         STW,R6   WORKT             SET TEXTC TO J BYTES
          PAGE
*
*  PRINT ERROR MESSAGES IF ANY
*  BEFORE GIVING ACCOUNTING INFORMATION
*
           LW,R9     TAPECOUT       GET TAPE ERROR COUNT
         BAL,R15  PRTHEX            CONVERT FOR TYPING
         STW,R11  MSGTPER1          STORE IN MESSAGE
         LI,R6    BA(MSGTPER)       TYPE 'TOTAL TAPE ERRORS XXXX
         BAL,R15  COMTYPE
         LW,R9    DISCOUNT
         BAL,R15  PRTHEX            CONVERT FOR TYPING
         STW,R11  MSGDCER1          STORE IN MSG
         LI,R6    BA(MSGDCER)       TYPE
         BAL,R15  COMTYPE           'TOTAL DISC ERRORS XXXX
          PAGE
         LW,R5    TIME              GET CURRENT TIME
         SW,R5    PRETIME           SUBTRACT TIME JOB STARTED
         LI,R4    0                 TIME IS IN MILLI-SECONDS
         DW,R4    THOUSAND          GET TOTAL SECONDS
         LI,R4    0
         DW,R4    SIXTY             GET MINUTES AND SECONDS
         BAL,R15  PRTDEC            CONVERT TO PRINTABLE DECIMAL
         LI,R1    7                 STORE
         LI,R2    3                 MINUTES
STWMIN1  LB,R3    DBLWRD,R1         IN
         STB,R3   JT1,R2            OUT PUT
         AI,R1    -1                MESSAGE
         BDR,R2   STWMIN1           FOR TYPING
         LW,R5    R4                PUT SECONDS IN R5
         BAL,R15  PRTDEC            CONVERT TO PRINTABLE DECIMAL
         LI,R3    3                 PLACE
         LI,R2    1                 SECONDS
         LH,R4    DBLWRD,R3         INTO
         STH,R4   JT2,R2            MESSAGE
         LI,R6    BA(JBTIME)-1      FOR PRINTING
         BAL,R15  COMTYPE           TYPE
         LW,R5    TIME              GET CURRENT COUNTER 4. THIS IS
         LI,R4    0                 TIME IN MILLI-SECONDS SINCE PROGRAM
         DW,R4    THOUSAND          WAS BOOTED.
         LI,R4    0                 THIS IS TYPED AS
         DW,R4    SIXTY             TOTAL COMPUTER
         BAL,R15  PRTDEC            TIME
         LI,R1    7
         LI,R2    3
STWMIN2  LB,R3    DBLWRD,R1
         STB,R3   ACC1,R2
         AI,R1    -1
         BDR,R2   STWMIN2
         LW,R5    R4
         BAL,R15  PRTDEC
         LI,R3    3
         LI,R2    1
         LH,R4    DBLWRD,R3
         STH,R4   ACC2,R2
         LI,R6    BA(ACCTIME)-1
         BAL,R15  COMTYPE
         TESTBIT  INDICATE,BOOTDC,13
         B        BEGIN
BOOTDC   LI,R0    DA(AUTO)
         SIO,0    *BOOTDEV
         TIONEW   *BOOTDEV
         B        X'2A'
STKERROR LI,R6    BA(STKMSG)        *TEST*
         BAL,R15  COMTYPE           *
         TIONEW   *TYPEDEV
STKMSG   TEXTC    '
STACK OVERFLOW FORCE TRAP'
         TITLE    'DOUBLE WORD CONSTANTS'
***
*  *              CONSTANTS
***
         BOUND    8
IOINTOLD DATA,8   0
IONEWPSP GEN,8,7,17,8,24  7,0,INTERR,7,0
CPOLDPSD DATA,8   0
CPNEWPSD GEN,8,7,17,8,24   7,0,CPMRTN,7,0
REOFCW   IOPCW    2,WORK,0,8
RDBUF1CW IOPCW    2,BUF1WRD1,X'1E',12304  READ TAPE INTO BUFFER  1
RDBUF2CW IOPCW    2,BUF2WRD1,X'1E',12304  *    *    *    *       2
WRTB1CW  IOPCW    1,BUF1WRD1,X'1E',12304  WRITE TAPE FROM BUFFER 1
WRTB2CW  IOPCW    1,BUF2WRD1,X'1E',12304  *    *    *    *       2
LPCDWT   IOPCW    1,WORK,0,0
REWCW    IOPCW    51,REWCW,0,1
OFFLINE  IOPCW    35,BSRCW,0,1      REWIND OFF LINE ORDER
ERGCW    IOPCW    99,ERGCW,0,1
BSRCW    IOPCW    75,BSRCW,00,1
SENSECW  IOPCW    4,SENSEDTA,0,1
SETCORR  IOPCW    3,SENSEDTA,0,1
WTMCW    IOPCW    115,WTMCW,0,1
START    GEN,8,24,8,24     7,PROG,0,0
TIMEUP   DATA,8   0
         GEN,8,24,8,24  7,XTME,7,0
ERRORPSD DATA,8   0
         GEN,8,24,8,24  7,DUMP,7,0
FSFCW    IOPCW    83,FSFCW,0,1
FSRCW    IOPCW    67,FSRCW,0,1
EORCW    IOPCW    1,OEORF,0,16
RDDIR    IOPCW    2,CNTDIR,14,500
WRDIRTRY IOPCW    1,CNTDIR,14,500
EORWRT   IOPCW    1,OEORR,0,16
RDCOMMD  IOPCW    6,INPUT,0,80
AUTO     IOPCW    X'03',ZERO,X'20',4
         IOPCW    2,X'A0',0,1024
LOGCW    IOPCW    5,INPUT,0,0
TYPECW   IOPCW    5,TYPECW,0,1
READCW   IOPCW    134,INPUT,0,50
BOOTPGM  IOPCW    1,BOOT,46,32
         IOPCW    1,256,14,20000
M800CW   IOPCW    X'0B',MOD800,0,1
MOD800   GEN,8,24  X'48',0
M1600CW  IOPCW    X'0B',MOD1600,0,1
MOD1600  GEN,8,24  X'88',0
DENSW    DATA     0
DJOBSW   DATA     0
         BOUND    8
SUBSTACK DATA     REGSTACK,X'80808000'
ALTSUB   DATA     REGSTACK,X'80808000'
BUFCMDLST   EQU  %
         XXX      X'03',BA(FLSEEK1)
         XXX      X'22',4
         XXX      X'12',BA(BUF1DATA)
         XXX      X'2E',6*1024
         XXX      X'03',BA(FLSEEK2)
         XXX      X'22',4
         XXX      X'12',BA(BUF1DATA)+6*1024
         XXX      X'1E',6*1024
BUFCMDLSTX XXX    3,BA(FLSEEK1)
         XXX      X'22',4
         XXX      X'12',BA(BUF1DATA)
         XXX      X'1E',11*1024
CWHDRR   EQU     %
         XXX      X'03',BA(BUF1WRD2)
         XXX      X'22',4
         XXX      X'0A',BA(HDRDATA1) READ HEADER
         XXX      X'0E',2*6*8
CWHDRRX  XXX      3,BA(BUF1WRD1)
         XXX      X'22',4
         XXX      X'0A',BA(HDRDATA1)  READ HEADER
         XXX      X'0E',11*8
LPSDLOC  RES      2
FLLPSD   EQU     %
         XXX      X'7',FLLPSDX
         XXX      0,0
FLSEEK1  DATA     0
FLSEEK2  DATA     0
HDRDATA1 RES,1    6*8
HDRDATA2 RES,1    6*8
OEORR    TEXT     ' EOF            '
OEORF    TEXT     '*EOR            '
SAVEDATE DATA,8   0
DTEHOLD  DATA,8   0
         BOUND    8
REGSTACK EQU      %
*        ZERO     STACK
         LIST     0
         DO1      X'80'
         DATA     0
         LIST     1
         RES      1
WORKT    DATA     4
WORK     DATA     0,0,0
         DATA     0,0,0,0,0,0
DBLWRD   EQU      WORK
RETRYTP  DATA     0
JOBSTACK DATA     STACK1
         GEN,4,12,4,12   8,30,8,0
WRKJOBSK DATA     STACK2
         GEN,4,12,4,12   8,30,8,0
PJOBSTK  DATA     STACK1
         GEN,4,12,4,12   8,30,8,0
PWRKSTK  DATA     STACK2
         GEN,4,12,4,12   8,30,8,0
         BOUND    8
STACK2   EQU      %
         DO       30
         DATA     0
         FIN
         TITLE    'WORD CONSTANTS'
XTME     LPSD,M3  TIMEUP
LOSEEK   DATA     0
HISEEK   DATA     X'1FFF0000'
COUNT    DATA     11520
FIRSTSEK DATA     0
INCREMNT DATA     32**16
COUNTSEC DATA     360
INCSEK   DATA     INC234
M7202    DATA     0,X'07FF0000',32*360,0,32*256*256,360,INC234
M7203    DATA     0,X'0FFF0000',32*360,0,32*256*256,360,INC234
M7204    DATA     0,X'1FFF0000',32*360,0,32*256*256,360,INC234
M7211    DATA     0,(63**23)+(81**16),12*1024,0,12*256*256,1024,INC11
M7221    DATA     0,X'1FFB0000',12*1024,0,16*256*256,1024,INC21
M7242    DATA     0,(199**16)+(19**8),12*1024,0,2**8,1024,INC42
M7260    DATA     0,(199**16)+(19**8),11*1024,0,1**8,1024,INC60
M7270    DATA     0,(399**16)+(19**8),12*1024,0,2**8,1024,INC70
M7275    DATA     0,(399**16)+(18**8),11*1024,0,1**8,1024,INC75
M3275    DATA     0,(403**16)+(18**8),12*1024,0,1**8,1024,INC77
M3282    DATA     0,(807**16)+(18**8),12*1024,0,1**8,1024,INC82
M3214    DATA     0,(255**20)+(10**16),11*1024,0,16*256*256,1024,INC21
ZERO     DATA     0
RDISC    DATA     0
X1SAV    RES      1
IND      EQU     %
INDICATE DATA,4   0                 PROGRAM STATUS INDICATOR
BOOTDEV  DATA     0
CURRSEEK RES      1
CWRTERR  DATA     0
INTERM   DATA     0
X40      XPSD,0   ERRORPSD
X41      XPSD,0   ERRORPSD
X42      XPSD,0   ERRORPSD
X43      XPSD,0   ERRORPSD
X46      XPSD,0   ERRORPSD
X48      XPSD,4   C1OLDPSD          6
X49      XPSD,4   C2OLDPSD
X55      MTW,2    TIME              9
X56      XPSD,0   ERRORPSD
X5B      XPSD,0   TIMEUP
X5C      XPSD,0   IOINTOLD
X5D      XPSD,0   CPOLDPSD
TIME     DATA     0
TAPEREC  DATA     0
DISCREC  DATA     0
TAPECOUT DATA     0
SENSEDTA DATA     0
DISCOUNT DATA     0
DRTRY    DATA     0
DISCDEV  DATA     0
TAPEDEV  DATA     0
TYPEDEV  DATA     KEYBOARD
CARDDEV  DATA     3
PRINTDEV DATA     2
THOUSAND DATA     1000
SIXTY    DATA     60
CRMSG    DATA     X'02151500'
M7202MSK DATA     '0202'
M7203MSK DATA     '0303'
M7204MSK DATA     '0404'
M7211MSK DATA     '1212'
M3214MSK DATA     '1414'
M7221MSK DATA     '3232'
M7242MSK DATA     '4242'
M7260MSK DATA     '6060'            7260
M7270MSK DATA     '7070'            7270
M7275MSK DATA     '7575'            7275
M3277MSK DATA     '7777'
M3282MSK DATA     '8282'
MODEL    DATA     0
GP1DC    DATA     'DCXX'
GP2DN    DATA     'DNXX'
DXCNT    DATA     0
CWSAV    DATA     0
DDEV     DATA     0
PDISC    DATA     240,128
PRETIME  DATA     0
LSTSEEK  DATA     X'1F80'
BOOTRET  DATA     0
TEN      DATA     10
TPAIO    DATA     X'B8480000'
BREP     IOPCW     3,BUF2WRD2,34,4
         DATA     0
         DATA     X'1E000000'
RGO      B        LOAD2
TYPEORDR GEN,8,24  5,0
         TITLE    'TEXT AND TYPE OUT MESSAGES'
MSGX1    TEXTC    '
SYSTEM SAVE/RESTORE    VERSION    '
         ORG      %-1
         TEXT     ' A00'
MSGX2    TEXTC    '
KEY-IN COMMANDS
'
MSGX4    TEXTC    '
UNRECOVERABLE TAPE ERROR'
MSGX5    TEXTC    ' - READ OPERATION'
MSGX5A   TEXTC    ' - WRITE OPERATION'
MSGX6    TEXTC    '
  -ABORT***'
MSGX7    TEXTC    '
DISC UNIT UNAVAILABLE -'
MSGX8    TEXTC    '
UNRECOVERABLE ERROR ON DISC'
MSGX9    TEXTC    '
CANNOT DECODE COMMAND '
         BOUND    8
INPUT    EQU      %
         DO       20
         TEXT     '    '
         FIN
BLANK    TEXT     '            '
DIRMSG1  TEXTC    '
DIRECTORY OF CONTENTS'
DIRMSG2  TEXTC    '
TAPE CREATED--'
DIRMSG4  TEXTC    '
MODEL 7200 RAD(S)'
DIRMSG5  TEXTC    '
  00F0'
MSGDATE  TEXTC    '
KEY IN DATE. (DD MM YY)- '
REQDC    TEXTC    '  WILL BE REPLACED BY  ? '
NOINP    DATA,1   2,X'15',C'?',0
ASMS     TEXTC    '
 ASSIGN NEW TAPE UNIT NUMBER '
MSGY2    TEXTC    '
TAPE UNIT NOT READY. CLEAR WAIT WHEN READY'
MSGY3    TEXTC    '
TAPE UNIT WRITE PROTECTED. CLEAR WAIT WHEN READY'
MSGY4    TEXTC    '
END OF REEL. ASSIGN NEW TAPE-- (NDD)'
MSGY5    TEXTC    '
UNDEFINED I/O ERROR'
MSGY6    TEXTC    '
AIO STATUS-'
MSGY7    TEXTC    '
TDV STATUS-'
MSGY8    TEXTC    '
SPURIOUS INTERRUPT-- '
MSGY9    TEXTC    '
INVALID SECTOR ADDR -'
MSGYA8   TEXTC    '
TIO STATUS-'
MSGYA9   TEXTC    '
LAST USED SEEK ADDR-- '
MSGYA10  TEXTC    ' -CHECK WRITE OPERATION'
MSGY10   TEXTC    '
RAD WRITE PROTECTED. CLEAR WAIT WHEN READY -'
         DATA     44
JBTIME   TEXT     '
TIME FOR THIS JOB  '
JT1      TEXT     ' 000 MINUTES'
JT2      TEXT     '  00 SECONDS'
         DATA     44
ACCTIME  TEXT     '
TOTAL COMPUTER TIME'
ACC1     TEXT     ' 000 MINUTES'
ACC2     TEXT     '  00 SECONDS'
MSGTPER  TEXTC    '
TOTAL TAPE ERRORS      '
MSGBCR   TEXTC    '
CR BAD'
MSG::001 TEXTC    ' -WHILE WRITING BOOT RECORDS'
MSG::002 TEXTC    '
UNABLE TO RECOGNIZE DISC TYPE'
MSGTPER1 EQU      MSGTPER+5
MSGXX    TEXTC    'TAPE WRITE PROTECTED'
MSGDCER  TEXTC    '
TOTAL DISC ERRORS      '
MSGDCER1 EQU      MSGDCER+5
NOMODMSG TEXTC    'ABORT--NO MODEL NBR BEFORE GROUP'
NODMSG   TEXTC    'ABORT--NO DISC ADR BEFORE GROUP'
MSG421   TEXTC    '
ERROR READING HDRS'
TYP001   TEXTC    '
MT MUST PRECEED DN IN CMMND LIST
'
         TITLE    'COPY ROUTINE ---DISC TO TAPE'
JOBDT    EQU      %
         OFFBIT   IND,16,19
         LD,R2    JOBSTACK          MOVE STACK POINTER OUT TO DIRECTORY
         STD,R2   DIRSTACK          TO BE WRITTEN ON TAPE
         LI,R2    0
         STW,2    MODEL
MVETABLE EQU      %                 REVERSE JOBS IN STACK SO THEY WILL
         PLW,R2   JOBSTACK          BE EXECUTED IN EXACTLY THE SAME
         BCS,2    STRE:LST          BR ON LAST DEV.
         LW,R2    R2                TEST FOR MODEL NBR
         BLZ      SAVE%M            BR TO SAVE MOD NBR
         PSW,R2   WRKJOBSK          LOOP THIS RTN TILL STACK
         B        MVETABLE          EMPTY
         SPACE    2
SAVE%M   XW,R2    MODEL             STORE NEW MODEL & PICK UP LST
         BEZ      MVETABLE          BR IF ZERO
         PSW,R2   WRKJOBSK          SAVE MODEL NBR
         B        MVETABLE          CONTINUE MOVE
STRE:LST LW,R2    MODEL
         PSW,R2   WRKJOBSK          SAVE IN STACK
         LI,R2    0
         STW,R2   MODEL
         PLW,R2   WRKJOBSK          GET MODEL NBR FROM STACK
BK42     EQU      %
         CW,R2    M7202MSK
         BE       MX2               BRANCH IF 7202
         CW,R2    M7203MSK
         BE       MX3               BRANCH IF 7203
         CW,R2    M7204MSK
         BE       MX4               BRANCH IF 7204
         CW,R2    M7211MSK
         BE       MX11              BRANCH IF 7211
         CW,R2    M3214MSK          CHECK FOR 3214
         BE       MX14
         CW,R2    M7221MSK
         BE       MX21              BRANCH IF 7221
         CW,R2    M7242MSK
         BE       MX42
         CW,R2    M7260MSK
         BE       MX60
         CW,R2    M7270MSK
         BE       MX70
         CW,R2    M7275MSK
         BE       MX75
         CW,R2    M3277MSK          CHECK FOR 3275
         BE       MX77
         CW,R2    M3282MSK          CHECK FOR 3282
         BE       MX82
          LI,R6     BA(MSG::002)
          BAL,R15   COMTYPE
          B         ENDJOBS
MX2      LOADM    7,2,M7202
MXSTORE  STOREM   7,2,LOSEEK        PLACE FACTOR TABLE IN PLACE
         LW,R2    DJOBSW            IS THIS A RESTORE FUNC
         BEZ      JOBDTGO1          BRANCH IF NO
         LI,R2    0
         STW,R2   DJOBSW            RESET RESTORE FUNC FLAG
         B        JOBRES01
         NOP
MX3      LOADM    7,2,M7203
         B        MXSTORE
MX4      LOADM    7,2,M7204
         B        MXSTORE
MX11     LOADM    7,2,M7211
         B        MXSTORE
MX14     LOADM    7,2,M3214
         B        MXSTORE
MX21     LOADM    7,2,M7221
         B        MXSTORE
MX42     LOADM    7,2,M7242
         B        MXSTORE
MX60     LOADM    7,2,M7260
         B        MXSTORE
MX70     LOADM    7,2,M7270
         B        MXSTORE
MX75     LOADM    7,2,M7275
         B        MXSTORE
MX77     LOADM    7,2,M3275
         B        MXSTORE
MX82     LOADM    7,2,M3282
         B        MXSTORE
JOBDTGO1 EQU      %
         OFFBIT   INDICATE,20       RESET END SWITCH
         PLW,R2   WRKJOBSK          GET WORD FROM WORKING JOB STACK
         BCS,2    ENDJOBS           END IF STACK EMPTY
         LW,R2    R2
         BCR,2    BK42
         STW,R2   DISCDEV           STORE WORD AS DISC ADDR
         OFFBIT   IND,25                TURN OFF OVERLAP BIT
         LW,R0     TAPEDEV          CHECK IF TAPE AND
         LI,R1    X'1F00'            DISC ARE ON THE
         CS,R0     DISCDEV            SAME IOP
         BE       JOBDTGO
         SETBIT   IND,25            NO - SET OVERLAP BIT
         B        JOBDTGO
JOBSCH   EQU      %
         TESTBIT  INDICATE,SCH1,4,5,6,7,8,9  BRANCH IF I/O BUSY
         B        JOBDTGO1
SCH1     EQU      %                 CLEAR I/O INTERRUPTS
         WAIT     0
         B        JOBSCH
JOBDTGO  EQU      %
         TESTBIT  INDICATE,ONTAPE,19
         BAL,R15  WRTBOOT           WRITE PROG TO TAPE
         BAL,R15  WRTDIR            WRITE DIRECTORY TO TAPE
         SETBIT   INDICATE,19       SET INDICATOR FOR PROG ON TAPE
ONTAPE   EQU      %
         LI,R1    0                 SET CURRETN SEEK TO ZERO
         LW,R2    DISCDEV           SET UP CURRENT
         STW,R2   BUF1WRD4          DISC ADDRESS
         STW,R2   BUF2WRD4          IN BUFFERS
         STW,R1   BUF1WRD3          CLEAR MODEL
         STW,R1   BUF2WRD3          NBR INDICATOR
         LW,R2    FIRSTSEK
         STW,R2   CURRSEEK
         STW,R2   BUF1WRD2
         LW,R2    COUNT             SET COUNT
         LI,X3    1
         STH,R2   BUF1WRD1,X3       STORE IN OUTPUT
         IOREQ    D,RD1,0           READ DISC INTO BUFFER 1
         IOREQ    D,WTE,0           WAIT FOR TERM
DTTE     EQU      %
         IOREQ    T,WRT1,0          WRITE TAPE FROM 1
         TESTBIT  IND,DTTF,25       NO WAIT IF OVERLAP
         IOREQ    T,WTE,0           WAIT
DTTF     EQU      %
         LI,R14   BUF2WRD1          SET UP TO INCREMENT DISC SEEK
         BAL,R15  *INCSEK           INCREMENT
         TESTBIT  IND,JOBSCH,20     CHECK IF DISC THRU
         IOREQ    D,RD2,0           READ DISC TO 2
         IOREQ    D,WTE,0           WAIT
         IOREQ    T,WRT2,0          WRITE TAPE FROM 2
         TESTBIT  IND,DTTH,25       NO WAIT IF OVER LAP
         IOREQ    T,WTE,0           WAIT
DTTH     EQU      %
         LI,R14   BUF1WRD1          SET UP TO INCREMENT DISC SEEK
         BAL,R15  *INCSEK           INCREMENT
         TESTBIT  IND,JOBSCH,20     CHECK IF DISC THRU
         IOREQ    D,RD1,0           READ DISC TO 1
         IOREQ    D,WTE,0           WAIT
         B        DTTE              LOOP BACK
FLAERR   EQU     %
TYPE%1   LI,R6    BA(MSG421)
         BAL,R15  COMTYPE           TYPE 'ERROR READING HDRS
         LI,R6    BA(MSGX6)
         BAL,R15  COMTYPE           TYPE '***ABORT
         B        ENDJOBS
         TITLE    'RESTORE ROUTINE ---TAPE TO DISC'
*****                                                             ******
*    *                                                           *     *
********          RESTORE TAPE TO DISC                          ********
*    *                                                           *     *
*****                                                             ******
JOBREST  EQU      %
         LI,R2    X'FF'
         STW,R2   DJOBSW            SET JOB RESTORE FLAG
         B        MVETABLE-2        GO SET CNTL TABLE
JOBRES01 EQU      %
         IOREQ    T,REW,0           REWIND AND POSITION
         IOREQ    T,FSF,0           TAPE TO 1ST DATA BLOCK
         IOREQ    T,WTE,0
         OFFBIT   IND,17
         OFFBIT   IND,25                TURN OFF OVERLAP BIT
         IOREQ    T,RD1,0           READ TAPE TO 1
         IOREQ    T,WTE,0           WAIT
         LW,R2    TAPEDEV           CHECK IF TAPE AND
         LI,R3    X'1F00'            DISC ARE ON THE
         CS,R2    BUF1WRD4            SAME IOP
         BE       TTD
         SETBIT   IND,25            NO - SET OVERLAP BIT
TTD      EQU      %             RESTORE TAPE TO DISC
         TESTBIT  IND,CMPRTN,2      TEST IF COMPARE OR RESTORE
TTDE     EQU      %
         TESTBIT  IND,ENDJOBS,17    TEST FOR EOF FROM TAPE
         IOREQ    D,WRT1,0          WRITE DISC FROM 1
         TESTBIT  IND,TTDF,25       NO WAIT IF OVERLAP
         IOREQ    D,WTE,0           WAIT
TTDF     EQU      %
         IOREQ    T,RD2,0           READ TAPE TO 2
         IOREQ    T,WTE,0           WAIT
         TESTBIT  IND,ENDJOBS,17    TEST FOR EOF FROM TAPE
         IOREQ    D,WRT2,0          WRITE DISC FROM 2
         TESTBIT  IND,TTDH,25       NO WAIT IF OVERLAP
         IOREQ    D,WTE,0           WAIT
TTDH     EQU      %
         IOREQ    T,RD1,0           READ TAPE TO 1
         IOREQ    T,WTE,0           WAIT
         B        TTDE              LOOP BACK
         TITLE    'COMPARE ROUTINE --- TAPE TO DISC'
*
*        COMPARE ROUTINE  (CMPR)
*
CMPRTN   EQU      %
TCDA     EQU      %
         TESTBIT  IND,ENDJOBS,17    TEST FOR EOF ON TAPE
         IOREQ    T,RD2,0           READ TAPE TO 2
         TESTBIT  IND,TCDB,25       NO WAIT IF OVERLAP
         IOREQ    T,WTE,0           WAIT
TCDB     EQU      %
         IOREQ    D,CHK1,TCD1       CHECKWRITE DISC AGAINST 1
         IOREQ    D,WTE,TCD1        WAIT
         IOREQ    T,WTE,0           WAIT FOR TAPE
         TESTBIT  IND,ENDJOBS,17    TEST FOR EOF ON TAPE
         IOREQ    T,RD1,0           READ TAPE TO 1
         TESTBIT  IND,TCDD,25       NO WAIT IF OVERLAP
         IOREQ    T,WTE,0           WAIT
TCDD     EQU      %
         IOREQ    D,CHK2,TCD2       CHECKWRITE DISC AGAINST 2
         IOREQ    D,WTE,TCD2        WAIT
         B        TCDA              LOOP BACK
TCD1     EQU      %
         MTW,1    CWRTERR           COUNT CHECKWRITE ERROR
         BLZ      TCDB               CONTINUE IF LESS THAN 10
         B        CMPR%02             ERROR IF 10
TCD2     EQU      %
         MTW,1    CWRTERR           COUNT CHECKWRITE ERROR
         BLZ      TCDD               CONTINUE IF LESS THAN 10
         B        CMPR%02             ERROR IF 10
CMPR%02   RES       0
          LI,R6     BA(CMPR%03)
          LI,R15    ENDJOBS        TYPE CHECK-WRITE ERROR MESSAGE
          B         COMTYPE        AND EXIT TO ENJOB ROUTINE
CMPR%03   TEXTC     '

*** CHECK-WRITE ERROR...VERIFICATION ABORTED ***'
         TITLE    'CONTROL PANEL ROUTINES'
****
*   *             ENTRY FROM INTERRUPT AT CONSOLE
****                                               CONTROL PANEL MONITOR
CPMRTN   STOREM   0,0,CPSAVER
         LOADM    4,R10,PI          PLACE REASON FOR DUMP ON
         STOREM   4,R10,PIP         HEADING LINE
CPHERE   EQU      %
         HIO,R0   *TYPEDEV
         BAL,R15  CPTYPE
         BAL,R15  CPREAD
         LI,R6    BA(CPINPUT)+1     SET PTR TO SECOND CHARACTER
         LB,R1    CPINPUT
         CI,R1    C'D'              CHECK FOR DUMP
         BE       DMPRTN
         CI,R1    C'P'              CHECK FOR PRINT
         BE       DMPRTN
         CI,R1    C'L'              CHECK FOR LPXXX
         BE       CPLORTN
         LOADM    0,0,CPSAVER
         LPSD,M3  CPOLDPSD
****
*   *             ENTRY ON ILLEGAL TRAP
****
DUMP     EQU      %
         STOREM   0,0,CPSAVER       SAVE REGS
         LI,R0    DA(TYPDMP)
         HIO,R0   *TYPEDEV
         SIO,R0   *TYPEDEV          TYPE ERROR MSG
         BIOSNS   %-1
         LW,R9    ERRORPSD          GET TRAPPED PSD AND CONVERT IT FOR
         BAL,R15  TOPRINT           PRINTING ON THE CONSOLE TELE-TYPE
         STOREM   2,R10,ERRMSG1A    AND ON THE HEADING LINE OF THE
         STOREM   2,R10,PIP         POST MORTEM DUMP
         LW,R9    ERRORPSD+1
         BAL,R15  TOPRINT
         STOREM   2,R10,ERRMSG1B
         STOREM   2,R10,PIP+2
         LI,R6    BA(ERRMSG1)+2
         BAL,R15  COMTYPE           GO TYPE TRAP PSD
         TIONEW   *TYPEDEV
         LI,R1    BYLABL            SET UP FOR RETURN TO THE
         STW,R1   CPOLDPSD          END OF JOB ROUTINE
         B        CPHERE            GO TO MONITOR
         TITLE    'POST MORTEM DUMP ROUTINE'
*
*
**
* *               POST MORTEM DUMP REQUEST -DMP-
**
DMPRTN   EQU      %
         LB,R0    0,R6
         AI,R6    1
         CI,R0    C' '              CHECK FOR DELIMITER
         BLE      CPDNXT            DELIMITER FOUND
         B        DMPRTN            CONTINUE SEARCH
CPDNXT   EQU      %
         LB,R0    0,R6
         CI,R0    C' '              CHECK FOR DELIMITER
         BLE      CPCOUNT
         CI,R0    C'A'              CHECK FOR 'A'
         BE       CHKALL             CHECK FOR ALL
         B        DUMPX             USE SUPPLIED LIMITS
CPCOUNT  EQU      %
         AI,R6    1
         CI,R6    BA(CPINPUT)+15    CHECK IF ALL BUFFER CHECKED
         BLE      CPDNXT            NO - CONTINUE
         B        DMPALL            YES - NO LIMITS , DUMP ALL
CHKALL   EQU      %
         AI,R6    1
         LB,R0    0,R6              LOAD CHAR AFTER 'A'
         AI,R6    -1
         CI,R0    C'L'              CHECK IF IT IS AN L
         BNE      DUMPX             NO , ASSUME HEX LIMITS SUPPLIED
DMPALL   EQU      %
         LI,R14   ENDLAB            YES-GET HI-CORDE ADDR
         STW,R14  CPEND             STORE IN HI-LIMIT
         LI,R14   32                GET LO-CORE LIMIT
         STW,R14  CPBEG             STORE IN BEGIN ADDR
         B        CPGO              GO DUMP THIS AREA OF CORE
DUMPX    EQU      %                 USER HAS PROVIDED DUMP LIMITS.
         LI,R1    8                 SET CHAR CNT TO 8
         BAL,R15  CPTOHEX           CONVERT LO LIMIT
         STW,R9   CPBEG             STORE
         LI,R1    8                 SET CHAR CNT TO 8
         BAL,R15  CPTOHEX           CONVERT TO BINARY
         STW,R9   CPEND             SET THIS VALUE AS HI-LIMIT
         LW,R14   CPBEG             SET POINTER TO LO-LIMIT
CPGO     EQU      %                 BEGIN DUMP
         OFFBIT   EORSW,1           TURN OFF DUPLICATE LINE SWITCH
         LW,R6    CPZEROS           GET WORD ' 000'
         STW,R6   PGNBR+1           STORE AS PAGE NUMBER IN HEADING LINE
         BAL,R13  SKIPER            EJECT PAPER AND PRINT HEADING
         LW,R9    CPREGS            GET WORD 'REGS' FOR LABEL ON LISTING
         STW,R9   CPADDR1           STORE 'REGS' INADDR COLUMN OF
         STW,R9   CPADDR2           DUMP
         LI,R5    8                 COUNT FOR 8 REGS ON LINE
         LI,X6    0                 INPUT INDEX TO 0
         LI,X7    0                 OUTPUT INDEX TO 0
CPRO     EQU      %                 DUMP REGS 0-7.
         LW,R9    CPSAVER,X6        GET REGISTER
         BAL,R15  TOPRINT           CONVERT FOR PRINTING
         LCI      2
         STM,R10  CPDATA1+1,X7      PLACE ON PRINT LINE 'BUFFER 1'
         AI,X6    1                 STEP TO NEXT REG
         AI,X7    3                 GO TO NEXT COLUMN ON DUMP    *OUTPUT
         BDR,R5   CPRO              CONVERT  8 REGS
         BAL,R15  CPRINT1           PRINT LINE 1 FROM BUFFER 1
*
         LI,R5    8                 DUMP 8 MORE REGS
         LI,X7    0                 OUTPUT INDEX TO 0
CPR1     EQU      %                 DUMP REGS  8-15
         LW,R9    CPSAVER,X6        GET REGISTER
         BAL,R15  TOPRINT           CONVERT FOR PRINTING
         LCI      2
         STM,R10  CPDATA2+1,X7      PLACE ON PRINT LINE 'BUFFER 2'
         AI,X6    1                 STEP TO NEXT REG             * INPUT
         AI,X7    3                 GO TO NEXT COLUMN ON DUMP    *OUTPUT
         BDR,R5   CPR1              CONVERT 8 REGS
         BAL,R15  CPRINT2           PRINT LINE 2 FROM BUFFER 2
*
CPLINE1  EQU      %                 BEGIN MEMORY DUMP
         LI,R5    8                 8 WORDS PER LINE
         LI,X7    0                 OUTPUT INDEX IO0
         LW,R9    R14               GET ADDR FOR THIS LINE
         BAL,R15  TOPRINT           CONVERT FOR PRINTING
         STW,R11  CPADDR1           STORE IN ADDR COLUMN
CPLINE1A EQU      %                 SET UP PRINT LINE IN BUFFER 1
         LW,R9    *R14              GET 1 WORD TO CONVT
         BAL,R15  TOPRINT           CONVERT
         LCI      2
         STM,R10  CPDATA1+1,X7      STORE IN PRINT LINE
         AI,X7    3                 BUMP--OUTPUT INDEX
         AI,R14   1                       INPUT INDEX
         CW,R14   CPEND             ARE WE AT HI-LIMIT
         BCS,M2   CPDONE1           BRANCH IF SO
         BDR,R5   CPLINE1A          PUT 8 WORDS IN LINE
         BAL,R15  CPRINT1           GO PRINT THIS LINE
         LI,R5    8                 SET FOR 8 WORDS PER LINE
         LI,X7    0                 OUTPUT INDEX
         LW,R9    R14               GET CURRENT ADDR
         BAL,R15  TOPRINT           CONVERT
         STW,R11  CPADDR2           STORE IN ADDR COLUMN OF PRINT LINE
*                          SET UP LINE IN BUFFER 2
CPLINE2  EQU      %
         LW,R9    *R14              GET WORD OF DATA
         BAL,R15  TOPRINT           CONVERT FOR PRINTING
         LCI      2
         STM,R10  CPDATA2+1,X7      STORE IN PRINT LINE
         AI,X7    3                 BUMP--OUTPUT INDEX
         AI,R14   1                       INPUT
         CW,R14   CPEND             ARE WE AT HI-LIMIT
         BCS,M2   CPDONE2           BRANCH IF SO
         BDR,R5   CPLINE2           PUT 8 WORDS ON PRINT LINE
         BAL,R15  CPRINT2           GO PRINT THIS LINE
         B        CPLINE1           GO SET UP A LINE IN BUFFER 1
*                 COME HERE WHEN HI-LIMIT REACHED AND WE ARE USING
*                 BUFFER 1. WE WILL BLANK FILL ANY UNUSED PRINT POSITION
*                           IN THE LINE.
CPDONE1  EQU      %
         LOADM    2,R10,CPBLANKS    GET BLANKS
CPD1A    LCI      2
         STM,R10  CPDATA1+1,X7      STORE BLANKS IN NEXT 8 PSN'S
         AI,X7    3
         BDR,R5   CPD1A             FILL LINE
         BAL,R15  CPRINT1           GO PRINT LINE
         B        TSTDONE
*                 COME HERE WHEN HI-LIMIT REACHED AN WE ARE USING
*                 BUFFER 2. WE WILL BLANK FILL ANY UNUSED PRINT POSITION
*                 IN THE LINE.
CPDONE2  EQU      %
         LOADM    2,R10,CPBLANKS    GET BLANKS
CPD2A    EQU      %
         LCI      2
         STM,R10  CPDATA2+1,X7      STORE BLANKS IN NEXT 8 PSN'S
         AI,X7    3
         BDR,R5   CPD2A             FILL COMPLETE LINE
         BAL,R15  CPRINT2           NOW GO PRINT THIS LINE
TSTDONE  TESTBIT  EORSW,HOME,1      WAS LAST ADDR PRINTED
         B        CPHERE            GO TO MONITOR
HOME     BAL,15   EORSME            GO PRINT HI-LIMIT LINE
         B        CPHERE            GO TO MONITOR
         TITLE    'ASSIGN PRINTER AND LINES/PAGE ROUTINES'
*
*
****
*   *             SET PRINTER ADDR REQUEST -LO-
****
CPLORTN  EQU      %
         LI,R6    BA(CPINPUT)+2     SET PTR TO NEW ADDR
         LI,R1    4
         BAL,R15  CPTOHEX           CONVERT TO HEX
         STW,R9   PRINTDEV          STORE
         B        CPHERE            GO TO MONITOR
         TITLE    'DATA CONVERSION SUBROUTINES'
*
*
*
TOPRINT  EQU      %                 CONVERT BINARY FOR PRINTING (EBCDIS)
*                       AT ENTRY  R9 BINARY NUMBER TO CONVERT
*                        AT EXIT
*                          R10 & R11 EBCDIC EQUIVALENT
         LI,X1    0                 INDEX
         LI,X2    8                 COUNT OF DIGITS TO OUTPUT
TOPRINT1 EQU      %                 BEGIN CONVERSION
         LI,R8    0                 CLEAR WORK REG
         SLD,R8   4                 GET HI-ORDER DIGIT FROM R9
         CI,R8    9                 TEST FOR ALPHA (A-F)
         BG       %+2               YES-BRANCH
         AI,R8    57                NO--ADD EXTRA FACTO FOR NUMERIC
         AI,R8    183               ADD ALPHA FACTOR
         STB,R8   R10,X1            STORE DIGIT IN OUTPUT REG
         AI,X1    1                 STEP INDEX
         BDR,X2   TOPRINT1          CONVERT 8 DIGITS
         B        *R15              RETURN
*
*
*
CPTOHEX  EQU      %                 CONVERT FROM EBCDIC TO BINARY
*                       AT ENTRY  R1 DIGIT COUNT
*                                 R6 ADDRESS OF DIGIT
*                       AT EXIT
*                                 R9 RIGHT JUSTIFIED BINARY NBR
         LI,R5    8                 SET DIGITS NOT CONVERTED
         LI,R9    0                 PRESET RESULT TO  ZERO
CPPH     EQU      %
         LB,R8    0,R6              GET NEXT CHARACTER
         CI,R8    C'-'              TEST FOR - FIELD DELIMITER
         BE       CPPHO6
         CI,R8    X'08'             TEST FOR EOM FIELD DELIMITER
         BE       CPPHO6
         CI,R8    C' '              CHECK FOR BLANK DELIMITER
         BE       CPPHO6
         CI,R8    C','              TEST FOR , FIELD DELIMITER
         BE       CPPHO6
         CI,R8    X'15'             TEST FOR  NEW-LINE  FIELD DELIMITER
         BE       CPPHO6
         CI,R8    C'.'              TEST FOR . FIELD DELIMITER
         BE       CPPHX
         CI,R8    240               TEST FOR NUMERIC
         BGE      %+2               BRANCH IF DIGIT (0-9)
         AI,R8    X'A'-C'A'         CONVERT TO HEX
         SCS,R8   -4                MOVE DIGIT
         SCD,R8   4                  INTO LO END OF R9
         AI,R5    -1                DECREMENT DIGITS NOT CONVERTED
         AI,R6    1                 INCREMENT CHARACTER POINTER
         BDR,R1   CPPH              CONTINUE PROCESSING
         B        *R15              RETURN
CPPHO    EQU      %
         CI,R5    8                 CHECK IF ANY DIGITS PROCESSED
         BE       CPPHD             NO- RESTART
         B        *R15              RETURN
CPPHX    EQU      %
         AI,R6    1                 INCREMENT CHARACTER POINTER
         LB,R8    0,R6              PICK UP NEXT CHARACTER
         CI,R6    C'.'              CHECK FOR MORE  PERIODS
         BE       CPPHX             YES
         B        CPPHO             NO MORE
CPPHO6   EQU      %
         AI,R6    1                 INCREMENT CHARACTER POINTER
         B        CPPHO
CPPHD    EQU      %
         BDR,R1   CPPH
         B        *R15              RETURN
*
*
         TITLE    'TELE-TYPE SUBROUTINES'
*
CPREAD   EQU      %                 READ TELE TYPE
         STOREM   4,1,CPRDX1        SAVE REGS
         LOADM    4,1,CPBLANKS      BLANK
         STOREM   4,1,CPINPUT       KEY-IN AREA
         LOADM    4,1,CPRDX1        RESTORE REGS
         TIONEW   *TYPEDEV
         LI,R0    DA(CPREDCW)
         SIO,R0   *TYPEDEV          READ TELETYPE
         BIOSNS   %-1
         TIONEW   *TYPEDEV
         B        *R15              RETURN
CPTYPE   EQU      %                 TYPE PROMPT CHARACTER 'CP'
         TIONEW   *TYPEDEV
         LI,R0    DA(CPTYPCP)
         SIO,R0   *TYPEDEV
         BIOSNS   %-1
         B        *R15
         TITLE    'PRINTER SUBROUTINES'
*
*
CPRINT1  EQU      %                 PRINT LINE FROM BUFFER 1
         LI,R0    DA(CPLN1)
         B        CPRINT1A
CPRINT2  EQU      %                 PRINT LINE FROM BUFFER 2
         LI,R0    DA(CPLN2)
CPRINT1A EQU      %                 PREPARE TO PRINT
         STW,R0   CPSR0             SAVE COMMD LIST ADDR
         LW,R13   LINCT             GET CURRENT LINE COUNT
LINES    EQU      %
         CI,R13   35                TEST FOR FULL PAGE
         BL       CPRNT             NO--GO PRINT
         BAL,R13  SKIPER            YES-GO ADVANCE PAPER AND PRINT HDR
CPRNT    EQU      %
         STOREM   3,R1,CPRDX1       SAVE REGS
         TIONEW   *PRINTDEV
         LI,X2    0                 INDEX TO 0
         LI,R3    23                WORD COUNT TO 23
EORLOOP  EQU      %                 EXCLUSIVE OR BUFFER 1 AND 2 TOGETHER
*                                   TO TEST FOR IDENTICAL LINES
         LW,R1    CPDATA1+1,X2      GET WORD FROM BUFFER 1
         EOR,R1   CPDATA2+1,X2      TEST IT AGAINST BUFFER 2
         BCS,M3   EORPRT            BRANCH IF NO MATCH
         AI,X2    1                 INCREMENT INDEX
         BDR,R3   EORLOOP           TEST 23 WORDS
         SETBIT   EORSW,1           INDICATE IDENTICAL LINES HAVE BEEN
*                                   DETECTED
         LOADM    3,1,CPRDX1        RESTORE REGS
         B        *R15              RETURN WITHOUT PRINTING THIS LINE
*
EORPRT   EQU      %                 BUFFERS NOT IDENTICAL PRINT
         TESTBIT  EORSW,EORSME,1    BRANCH IF WE HAVE SKIPPED IDENTICAL
*                                   LINES.
EOROK    EQU      %                 READY TO PRINT LINE
         LW,R0    CPSR0             RESTORE R0
         TIONEW   *PRINTDEV
         SIO,R0   *PRINTDEV         PRINT DATA LINE
         BIOSNS   %-1
         MTW,1    LINCT             ADD 1 TO LINE COUNT
         LOADM    3,1,CPRDX1        RESOTRE REGS
         B        *R15              RETURN
*
EORSME   EQU      %                 COME HERE TO PRINT 'SAME' LINE
         LI,R0    DA(EORSKP)        COMMD ADDR
         SIO,R0   *PRINTDEV         PRINT '***SAME AS ABOVE****'
         BIOSNS   %-1
         OFFBIT   EORSW,1           TURN OFF DUPLICATE LINE SWITCH
         MTW,1    LINCT             ADD 1 TO LINE COUNT
         B        EOROK             GO PRINT LINE
*
*
*
SKIPER   EQU      %                 ADVANCE PAPER & MAINTAIN PG NBR
         STOREM   2,7,CPRDX1        SAVE REGS
         LI,X7    7                 INDEX
         LI,R11   3                 COUNT
CPLABEL1 EQU      %
         LB,R8    PGNBR,X7          GET LO-ORDER DIGIT OF PAGE NBR
         AI,R8    1                 ADD 1
         CI,R8    250               TEST FOR GREATER THAN 9
         BE       CPLABEL2          YES-BRANCH TO INCREMENT 10TH PSN
         STB,R8   PGNBR,X7          NO--STORE INCREMENTED DIGIT BACK
         B        CPLABEL3          GO PREPARE TO ADVANCE PAPER
CPLABEL2 EQU      %                 ZERO DIGIT AND MOVE NEXT HI-ORDER
         LI,R8    240               EBCDIC 0
         STB,R8   PGNBR,X7          STORE
         AI,X7    -1                STEP TO NEXT HI-ORDER DIGIT
         BDR,R11  CPLABEL1          INCREMENT UP TO 3 DIGIT NBR
         LW,R8    CPZEROS           RESET PAGE COUNT TO ZERO
         STW,R8   PGNBR+1           AFTER 999
         B        SKIPER            GO INCREMENT
CPLABEL3 EQU      %                 ADVANCE PAPER
         TIONEW   *PRINTDEV
         LI,R0    DA(FORMAT)
         LOADM    2,7,DTEHOLD       SET DATE IN HEADER
         STOREM   2,7,CPPRTDTE
         SIO,R0   *PRINTDEV         ADVANCE PAPER AND PRINT HEADER
         LI,R8    0
         STW,R8   LINCT             ZERO LINE COUNT FOR NEW PAGE
         LOADM    2,7,CPRDX1        RESTORE REGS
         B        *R13              RETURN
         TITLE    'LITERALS, MESSAGES, WORK AREAS AND I/O COMMANDS'
*
**                LITERALS, MESSAGES AND WORK AREAS
*
CPLN1    IOPCW    1,CPADDR1,0,124
CPLN2    IOPCW    1,CPADDR2,0,124
CPREDCW  IOPCW    134,CPINPUT,0,20
CPTYPCP  IOPCW    5,CPCW,0,3
FORMAT   IOPCW    5,PGNBR,0,44
TYPDMP   IOPCW    5,DMPMSG,0,16
EORSKP   IOPCW    1,SME,0,32
CPINPUT  DATA,16  0                 KEY-IN ARE FOR MONITOR -CP-
LITERALS RES      256
*
K1FFFF   DATA     X'0001FFFF'       LOAD SELECTIVE MASK TO GET ADR
CPCW     TEXT     '
CP'             PROMPT CHARACTERS
EORSW    DATA     0                 SWITCH BYTE
LINCT    DATA     0                 LINES PER PAGE COUNTER
CPZEROS  TEXT     ' 000'            INITIAL PAGE NBR
CPSR0    DATA     0                 R3 SAVE ARE FOR PRINT ROUTINE
CPBEG    DATA     0                 LO-LIMIT FOR POST MORTEM
CPEND    DATA     0                 HI-LIMIT FOR POST MORTEM
CPSAVER  EQU      %                 REGISTER SAVE AREA FOR
         DO       16                PANEL INTERRUPTS AND
         DATA     0                 ILLEGAL TRAPS
         FIN
CPREGS   TEXT     'REGS'
CPBLANKS TEXT     '                '
PI       TEXT     'PANEL INTERRUPT '
DMPMSG   TEXT     '
ERROR DUMP CORE'
SME      TEXT     '****** SAME AS ABOVE LINE ******'
CPRDX1   DATA,16  0                 TEMPORARY REGISTER STORAGE
ERRMSG1  DATA,1   0,0,17,21
ERRMSG1A TEXT     '        '
ERRMSG1B TEXT     '        '
PGNBR    TEXT     '1PG# 000        '
CPPRTDTE TEXT     '            '
PIP      TEXT     '                '
*                 PRINT BUFFER LINE 1
CPADDR1  TEXT     '    '
CPDATA1  EQU      %
         DO       15
         TEXT     '        '
         FIN
CPADDR2  TEXT     '    '
CPDATA2  EQU      %
         DO       15
         TEXT     '        '
         FIN
         BOUND    8
BUF1CW1  IOPCW     3,BUF1WRD2,34,4
BUF1CW2  DATA     0
BUF1WRD1 GEN,8,24   78,0
BUF1WRD2 DATA     0
BUF1WRD3 DATA     0
BUF1WRD4 DATA     0
BUF1DATA EQU      %
         ORG      %+3080
*                 BUFFER 1 IS USED AS A WORK AREA FOR READ/WRITE OF
*                 DIRECTORY OF CONTENTS.
*                 THE FOLLOWING EQUATES ARE USED FOR THIS PURPOSE.
*                 THESE EQUATES PROVIDE THE FOLLOWING CORE MAP--
*
*        BOUND    4
*CNTDIR  DATA,1   0,0,0,21
*DATEDIR DATA,8   0
*DIRSTACK DATA    STACK1
*        GEN,4,12,4,12  8,100,8,0
*STACK1  RES      100
*
CNTDIR   EQU      BUF1DATA+2
DATEDIR  EQU      BUF1DATA+3
DIRSTACK EQU      BUF1DATA+5
STACK1   EQU      BUF1DATA+7
         BOUND    8
BUF2CW1  IOPCW    3,BUF2WRD2,36,2
BUF2CW2  DATA     0
BUF2WRD1 GEN,8,24   76,0
BUF2WRD2 DATA     0
BUF2WRD3 DATA     0
BUF2WRD4 DATA     0
BUF2DATA EQU      %
         ORG      %+3080
ENDLAB   EQU      %
         ORG      LITERALS
         END      LOAD2

