         SYSTEM   SIG7FDP
         SYSTEM   BPM
PGMSEG0  CSECT    0
*
         PAGE
*
         USECT    PGMSEG0
*  REFERENCES TO EXTERNALS USED IN THE BLOCKERS,DEBLOCKERS AND
*        IN THE PHYSICAL INPUT/OUTPUT ROUTINES ARE DEFINED BELOW
*
         REF      F:SORTIN,F:SORTOUT
         REF      F:SCRF1,F:SCRF2,F:SCRF3,F:SCRF4
         REF      F:SCRF5,F:SCRF6,F:SCRF7,F:SCRF8
         REF      F:SCRF9,F:SCRF10,F:SCRF11,F:SCRF12,F:SCRF13,F:SCRF14
         REF      F:SCRF15,F:SCRF16,F:SCRF17
         REF      UTSCPVSW
         DEF      STRNGBRK
         DEF      FIT0,FIT1,FIT2,FIT3,FIT4,FIT5,FIT6,FIT7,BCT0
         DEF      FIT8
         DEF      CPER,CRSF,STEP,STFP,STFP2
         DEF      TRKSB,TRKSZ
         DEF      STCAD,OUTAD,PMSRCD,RCDLN,RCDAD,MSRCAD
         DEF      WTERR,WTABN,RDERR,RDABN
         DEF      HTBUFIN
         DEF      TBUFSW
         DEF      CNVRT,PRAMLOC,SINTMP
         DEF      S:SORTP,DC1,SC50,SC6
         DEF      DECSAV,MASKS
         DEF      ZTRANA,ZTRAND,PTRANA,PTRAND,ATRANA,ATRAND
         DEF      BNCMPA,BNCMPD,BNABSA,BNABSD,BNEBC
         DEF      BINEBC,WORK,SORTSV,EBCBN
         DEF      KRASC,NUSO,OCSAV,C1R,E1R,OSO
         DEF      NHED,NTRL,OHED,OTRL
         DEF      RRN0,INEOF,MTC0,MTC1,MTC2,MTC3,SRTMIN
         DEF      RWMOV,IN1,OU1,CI1,CO1,S:IN,S:OUT
         DEF      SEQRCD,SEQLNG,ILT0,ILT2
         DEF      SLICEFL,OUTSEQK,OCSEQ,OUTOWNCD,SPECRD
         DEF      DEVSTP,EVDEA,EVDED
         DEF      DECTRP,FWRD,INPORD                       /SIG7-2254/*D4985
         DEF      RLKCM,S:SORTC
         DEF      COMPSTOP
         DEF      SIN1R
         DEF      DUMPMEM
         DEF      CPGSAV
* LEAVE ABOVE DEF IN FOR DMS
         REF      KTT0,CALLSW
         DEF      BLKCTLSY          OUT BLK-CTL-WORDS SIZE ANSI-V 0-99
         DEF      BLKCTLSZ          IN  BLK-CTL-WORDS SIZE ANSI-V 0-99
         DEF      MEMPROSW
         DEF      OPINT
         DEF      KTTL
         DEF      ENDSNAP
         DEF      ANSISWIN          IN ANSI TYPE SWITCH
         DEF      ANSISWOU          OU ANSI TYPE SWITCH
         DEF      KLNGC
         DEF      COMPR
         DEF      EXAMEN
         DEF      NUMPGS
         DEF      DYNMEM
         REF      SCR0
         REF      SCR1,PHASE3,PHASE4
         REF      M:SI
         DEF      RSTOR,EXTRD,EXTWT,EXTOP,EXTNTBLE
         SREF     S:INHED,S:INUSO,S:INTRL,S:OUHED,S:OUSO,S:OUTRL
         REF      STEPCODE
* CODE DELETED
*
         PAGE
*
SORTSV   RES      15
KTTL     DATA     150                                      /SIG7-5406/*F4985
         BOUND    8
MASKS    DO1      33
         DATA     0
BCT0     RES      0                 BCT0 31 WORDS
         LOCAL    ILIST
ILIST    DO       32
         LIST     ILIST=1
         DATA,4   0
         FIN
         LIST     1
KRASC    DATA     %+1
COMPR    RES      400
ALFTRN1  DO1      64                   TRANS PREDICTED WINNER HERE
         DATA     0
ALFTRN2  DO1      64                 TRANS PREDICTED LOSER HERE
         DATA     0
FIT0     DATA,4   0,0,0,0,0,0,0,0,0
INEOF    DATA,4   0,0
FIT1     DATA,4   0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
FIT2     DATA,4   0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
FIT3     DATA,4   0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
FIT4     DATA,4   0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
FIT5     DATA,4   0,WA(F:SCRF1),WA(F:SCRF2),WA(F:SCRF3),WA(F:SCRF4)
         DATA,4   WA(F:SCRF5),WA(F:SCRF6),WA(F:SCRF7),WA(F:SCRF8)
         DATA,4   WA(F:SCRF9),WA(F:SCRF10),WA(F:SCRF11),WA(F:SCRF12)
         DATA,4   WA(F:SCRF13),WA(F:SCRF14),WA(F:SCRF15),WA(F:SCRF16)
         DATA,4   WA(F:SCRF17)
FIT6     DATA,4   0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
FIT7     DATA,4   0,0,0,0,0,0
FIT8     DATA,4   0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
ILT0     DATA,4   0,ILT101,ILT102,ILT103,ILT104,ILT105,ILT106
         DATA,4   ILT107,ILT108,ILT109,ILT110,ILT111,ILT112
         DATA,4   ILT113,ILT114,ILT115,ILT116,ILT117
ILT2     DATA     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
RRN0     DATA,4   0,RRN101,RRN102,RRN103,RRN104,RRN105,RRN106
         DATA,4   RRN107,RRN108,RRN109,RRN110,RRN111,RRN112
         DATA,4   RRN113,RRN114,RRN115,RRN116,RRN117
ILT101   DATA,4   0,0,0,0,0,0,0,0,0
ILT102   DATA,4   0,0,0,0,0,0,0,0,0
ILT103   DATA,4   0,0,0,0,0,0,0,0,0
ILT104   DATA,4   0,0,0,0,0,0,0,0,0
ILT105   DATA,4   0,0,0,0,0,0,0,0,0
ILT106   DATA,4   0,0,0,0,0,0,0,0,0
ILT107   DATA,4   0,0,0,0,0,0,0,0,0
ILT108   DATA,4   0,0,0,0,0,0,0,0,0
ILT109   DATA,4   0,0,0,0,0,0,0,0,0
ILT110   DATA,4   0,0,0,0,0,0,0,0,0
ILT111   DATA,4   0,0,0,0,0,0,0,0,0
ILT112   DATA,4   0,0,0,0,0,0,0,0,0
ILT113   DATA,4   0,0,0,0,0,0,0,0,0
ILT114   DATA,4   0,0,0,0,0,0,0,0,0
ILT115   DATA,4   0,0,0,0,0,0,0,0,0
ILT116   DATA,4   0,0,0,0,0,0,0,0,0
ILT117   DATA,4   0,0,0,0,0,0,0,0,0
RRN101   DATA,4   0,0,0,0,0,0,0,0,0
RRN102   DATA,4   0,0,0,0,0,0,0,0,0
RRN103   DATA,4   0,0,0,0,0,0,0,0,0
RRN104   DATA,4   0,0,0,0,0,0,0,0,0
RRN105   DATA,4   0,0,0,0,0,0,0,0,0
RRN106   DATA,4   0,0,0,0,0,0,0,0,0
RRN107   DATA,4   0,0,0,0,0,0,0,0,0
RRN108   DATA,4   0,0,0,0,0,0,0,0,0
RRN109   DATA,4   0,0,0,0,0,0,0,0,0
RRN110   DATA,4   0,0,0,0,0,0,0,0,0
RRN111   DATA,4   0,0,0,0,0,0,0,0,0
RRN112   DATA,4   0,0,0,0,0,0,0,0,0
RRN113   DATA,4   0,0,0,0,0,0,0,0,0
RRN114   DATA,4   0,0,0,0,0,0,0,0,0
RRN115   DATA,4   0,0,0,0,0,0,0,0,0
RRN116   DATA,4   0,0,0,0,0,0,0,0,0
RRN117   DATA,4   0,0,0,0,0,0,0,0,0
MTC0     DATA     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
MTC1     DATA     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
MTC2     DATA     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
MTC3     DATA     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
RSTOR    DATA     0,0,0,0,0,0,0,0,0
STCAD    DATA     0                 BEGIN OF STT TOURN TABLE
MSRCAD   DATA     0                 BEGIN OF MASS REC STORAGE
OUTAD    DATA     0                 ADDR OF LAST REC WROTE
PMSRCD   DATA     0                 ORIG SAVED MASS REC STOR ADDR
RCDLN    DATA     0
RCDAD    DATA     0
TRKSZ    DATA     1536
TRKSB    DATA     6144
         LIST     1
         BOUND    8
KLNGC    DATA,4   55
SIN1R    DATA     0
PRAMLOC  DATA     0
         DATA     0
OCSAV    DO1      16                OWN CODE REG SAVE DATA
         DATA     0
OCSAV1   DO1      16                OWN CODE REG SAVE READER
         DATA     0
HTBUFIN  DO1      64                HOLD AREA FOR IN HEADER/TRL IF PRES
         DATA     0
ACTSAV   DO1      5                  IO REG SAVE
         DATA     0
CACTSV   DO1      4                                        /SIG7-1687/*D4985
         DATA     0
DACTSAV  DO1      4                                        /SIG7-0735/*C
         DATA     0
TEMPHOLD DATA     0,0
DECSAV   DO1      3
         DATA     0
TCT0     DATA     0                 IN/OUT INDEX  FOR DBLKR/BLKR
CNVRT    DO1      2
         DATA     0
BFLOC    DO1      1
         DATA     0
BFSIZE   DATA     0
BFSIZE1  DATA     0                 COMPUTED BUF SIZE FOR WRITES
OUTBUF   DATA     1                 1 = BUF 1, 2 = BUF 2
CPER     DATA     0
FWRD     DATA     0
SEQRCD   DATA     0
SEQLNG   DATA     0
BNEBC    EQU      BINEBC
SORTSD   DATA     0
NUMPGS   DATA     0
DUMPMEM  DATA     0                 HAS 1 FOR USER DUMP,THEN ADDR
ENDSNAP  DATA     0                 HOLD END OF EACH OVERLAY FOR SNAP
CRSF     DATA     0                1 IF CO-RESIDENT ELSE 0
CPGSAV   DATA     0                 COM PAGE ADDR FOR SNAP /SIG7-4174/*E4985
OWNCDLEN DATA     0                 IF 1, CAME FROM OWN CD TO SQ CHK
FIRSTSW  DATA     0                 LETS BLKR/DEBLKR KNOW IF 1ST TIME
BLKCTLSY DATA     0                 OUT BLK-CTL WORDS SIZE ANSI 0-99
BLKCTLSZ DATA     0                 IN  BLK-CTL WORDS SIZE ANSI 0-99
BUFSAV   DATA     0                 BEG-BUF-ADDR FOR BLK-CTL-WRDS MOVE
LENCTL1  DATA     0                 BLK-SIZE ANSI (BYTE)
LENCTL2  DATA     0                 REC-SIZE ANSI (BYTE)
ANSISWIN DATA     0                 INPUT-ANSI 0=NO,1=UNDEF,2=BVAR,3FIX
ANSISWOU DATA     0                 OUTPT-ANSI 0=NO,1=UNDEF,2=BVAR,3FIX
BLKCNT   DATA     X'FFFFFFFF'       BLK CNT FOR ANSI V
SAVEIT   DATA     0                 HOLDS REC LEN FOR ANSI V
SAVER1   DATA     0
SAVE5    DATA     0                 HOLD R5 FOR DEBLOCKER
TBUFSW   DATA     0                 IF 1, USE 1 TBUF
SAVE8    DATA     0                 HOLD REG 8 FOR ERR/ABN RETURN ADDR
WORK     DATA     0
FMAN     DATA     0
INSERTSW DATA     0                 WHEN NON 0 INSERTING   /SIG7-1883/*D4985
IO57M:DO DATA     0                 IF 1 IO 57 WITH M:DO TO A FILE
IO57M:LL DATA     0                 1 MEANS M:LL TO A FILE
SLICEFL  DATA     0                                                    R
RLKCM    DATA     0
STRNGBRK DATA     0                 HOLD 4X #REC IN TOURN
OUSW     DATA,4   0                 0 NEVER IN OU1 BEFORE
INSW     DATA     0                 TELLS IN OPEN IF FIRST TIME THRU
EOFSW    DATA     0                 1 FOR INPUT EOF, 0 NO EOF
DYNMEM   DATA     0                 ADDR OF BEGIN OF MEM FOR DUMP
ENDSW    DATA     0                   1 MEANS NORMAL END
INBUF    DATA     1                 1 OR 2, FREE BUF FOR NEXT DEBLKNG
STOPCOMP B        *9                HAS B *9 OR 1ST WORD OF LAST COMP
COMPSTOP DATA     0                 HOLD ADDR OF 1ST WRD OF LAST/COMP
MEMPROSW DATA     0                 1 MEANS POSS MEM PRO ABORT BIGR OUT
SNUM     DATA     0
ABNSAVE  DATA     0,0,0             HOLD R8,9,10 FOR ABN
ERRSAVE  DATA     0,0,0             HOLD R8,9,10 FOR ERR
ERRINTER DATA     0,0,0             HOLD R8,9,10 FOR INTER DCB
ABNINTER DATA     0,0,0             HOLD R8,9,10 FOR INTER DCB
SINTMP   DO1      5
         DATA     0
INPORD   DATA     0                                        /SIG7-2254/*D4985
*        LINES 122,123,124  REMOVED FOR UTS
*
SRTMIN   DATA     0
ERRCD    DATA     0
INXOPEN  DATA     0                 POS INTO OPEN FPT OF UNIQUE FILE NM
INXOPEN1 DATA     0                 POS INTO INTOP OPEN FPT OF FILE NME
EXTNTBLE DO1      357
         DATA     0                  21 WORDS PER DCB 1-17
* THE TABLE WILL LOOK LIKE THIS
* POS 00,21,42 ECT HAVE ORIG FILE NAME, ALL OTHERS ARE EXTENT FILE NAME
* FOR EXTENT 1 DCB1, BYTE1=00,BITS8-16=001, BITS 17-31= PROG-ID FROM JIT
* FOR EXTENT 20 DCB17,BYTE1=00,BITS8-16=164, BITS 17-31=PROG-ID FROM JIT
* THE TABLE WILL DO UP TO 20 EXTENTS FOR ALL 17 DCBS
* BIT 0 ON EXTENT DONE FOR A WRITE THIS JOB, NEVER TURNED OFF
* BIT 1 ON ORIG FILE NAME EVERY 11 TH POS INTO TABLE  00,11,22,33
* BIT 2 ON   MEANS CLOSE WITH SAVE  FILE HAS MORE THAN 1 STRING.
EXTOP91  DATA     0                 HOLD REG 6
EXTOP92  DATA     0                 SWITCH TESTED IN EXTDCB10
EXTOP93  DATA     0                 HOLD REG 7
EXTDCB91 DATA     0                 SAVE ORIG INDEX (REG6)
EXTDCB92 DATA     0                 WHERE FILE NAME PUT BY EXTWT/EXTRD
EXTDCB93 DATA     0                 COMPUTED INDEX INTO EXTNTBLE
EXTDCB94 DATA     0                 GRAN COUNT OF WHERE REC IS FOR DCB
EXTADDR  DATA     0                 WORD DCB ADDR
EXTGRAN  DATA     0                 GRAN VALUE FOR IO
EXTRD91  DATA     0                 1 DO A  CLOSE SAVE
CLSLUPSW DATA     0                 1 TELLS EXTDCB20 TO SKIP CLOSE/SAVE
         PAGE
*
X0       EQU        0
X1       EQU        1
X2       EQU        2
X3       EQU        3
X4       EQU        4
X5       EQU        5
X6       EQU        6
X7       EQU        7
R8       EQU        8
R9       EQU        9
RA       EQU        10
RB       EQU        11
RC       EQU        12
RD       EQU        13
RE       EQU        14
RF       EQU        15
R10      EQU       10
R11      EQU       11
R12      EQU       12
R13      EQU       13
R14      EQU       14
R15      EQU       15
R0       EQU      R8
R1       EQU      R9
SR1      EQU      8
SR2      EQU      9
SR3      EQU      10
DCLR     AD,0     ZDTRN1
         AD,0     ZDTRN2
PDTRN1   EQU      ALFTRN1
PDTRN2   EQU      ALFTRN2
ALFTRAN1 EQU      ALFTRN1
ALFTRAN2 EQU      ALFTRN2
S:SORTP  EQU      DC1
SORTP    EQU      S:SORTP
ZDTRN1   EQU      ALFTRN1
ZDTRN2   EQU      ALFTRN2
CACTSAV  EQU      CACTSV
*
         PAGE
*
SKBB     TEXTC    'BLOCK DROPPED'
*
E1       TEXTC    'BLOCK LENGTH ABNORMAL'
E2       TEXTC    'I/O ERROR CODE:        '
EE       TEXTC    'ILLEGAL DECIMAL KEY'
EF       TEXTC    'MEMORY OVERFLOW'
E1A      TEXTC    'MAXIMUM GRANULE USAGE FOR DCB      :           '
E1B      TEXTC    'TRANSLATION TABLE LOCATION ERROR'
E1C      TEXTC    'REG 9 DEFINES LIMIT'
E1D      TEXTC    'ILLEGAL OWN-CODE ACTION REQUEST'
E1E      TEXTC    'DISK SATURATED OR UNABLE TO SWITCH TO',;
                  ' NEXT VOLUME'
E1F      TEXTC    'RSTORE VALUE TOO SMALL FOR I/O'
E20      TEXTC    'INSUFFICIENT INFORMATION: INPUT,OUTPUT OR INTER DCB'
E21      TEXTC    'INPUT OR OUTPUT FILE ALREADY OPEN'
E22      TEXTC    'HDR FIELD NOT BLANK,F, OR 1-9'
E23      TEXTC    'SEQUENCE ERROR IN OUTPUT FILE'
E24      TEXTC    'OPERATOR ERRORED OR ABORTED JOB'
E25      TEXTC    'SPECIFICATION ERROR'
E26      TEXTC    'ANSI DECIMAL OR UNSPECIFIED FORMAT'
E27      TEXTC    'RECORD LENGTH ABNORMAL'
E28      TEXTC    'IN-OUT COUNT (WITH DELETES) NOT EQUAL'  SIG7-8751
SRTMES   TEXTC    'RANDOM'
EXTMESSG TEXTC    'NUMBER OF FILE EXTENTS FOR DCB         : OF',;
                  '         GRANULES EACH'
         PAGE
*
ERTBL    DATA,4   E1,E2,0,EE,EF,0,E1A,E1B,E1C
         DATA,4   E1D,E1E,E1F,E20,E21,E22,E23,E24
         DATA,4   E25,E26,E27,E28                          SIG7-8751
*
         PAGE
*
STV0     DATA,4   UBDN1             UNBLK DEBLOCKER
         DATA,4   BFDN1             BLKED DEBLOCKER
         DATA,4   MFDN1             MANGE DEBLOCKER
         DATA,4   BVDVN1            ANS TYPE V DEBLOCKER
         DATA,4   UBB1              UNBLK BLOCKER
         DATA,4   BFVB1             BLOCKED BLOCKER
         DATA,4   BVBV              ANS TYPE V BLOCKER
*
*
NHED     DATA,4   S:INHED           IF THESE ROUTINES ARE
OHED     DATA,4   S:OUHED                         NOT SUPPLIED
NTRL     DATA,4   S:INTRL           THE CORRESPONDING ENTRIES IN
OTRL     DATA,4   S:OUTRL                         THIS TABLE
NUSO     DATA,4   S:INUSO           WILL BE ZERO
OSO      DATA,4   S:OUSO
*
         PAGE
*
*        SORT IS ALWAYS CALLED AS A SUBROUTINE, EITHER BY THE SORT
*        PREPROSSER OR BY AN ACTUAL USER PROCESSER PROGRAM: COBOL-
*        MANAGE-FORTRAN-DMS-METASYMBOL-ECT.
*
         PAGE
S:SORTC  RES      0
         LCI      15               SAVE ALL REGISTERS
         STM,X1   SORTSV
         LB,15    X'2B'
         SLS,15   -4
         CI,15    6                  6 FOR UTS
         BL       S:SORTC1
         CI,15    7
         BG       S:SORTC1
         CI,15    6                 UTS
         BE       S:SORTC1-1
         LH,15    X'2B'             FOR CPV ONLY IF HERE
         AND,15   =X'FF'            SEE RELEASE VERSION NUMBER
         CI,15    X'30'             CPV C00 OR LATER
         BL       S:SORTC1-1
         MTW,1    UTSCPVSW          WILL BE 2 FOR CPV C00 OR LATER
         MTW,1    UTSCPVSW          UTS/CPV SET ON
S:SORTC1 RES      0
         LI,15    0                INITIALIZE SELECTED TABLES
         LI,2     X'53'             CLEAR OUT TABLE FOR NXT SORT
         STW,15   FIT0-1,X2
         BDR,X2   %-1
         LI,2     X'29'              CLEAR FIT6,7,8
         STW,15   FIT6-1,X2
         BDR,X2   %-1
         LI,X2    17
         STW,15   ILT2-1,X2
         BDR,X2   %-1
         LI,X2    373
         STW,15   ILT101,X2
         BDR,X2   %-1              LOOP THROUGH ILT TABLES
         LI,2     65
         STW,15   MASKS,X2         LOOP THROUGH BCT0 AND MASK TBLES
         BDR,X2   %-1
         STW,15   INEOF
         STW,15   INEOF+1
         LI,15    COMPR            ADDRESS OF CMP RUTINE
         STW,15   KRASC
         LI,15    150
         STW,15   KTTL
         LI,15    55
         STW,15   KLNGC
         LI,4     13                INDEX INTO COM PAGE
         LB,11    *6,4              SEE BYTE 14
         CI,11    X'F2'             DOES USER WANT 2
         BE       S:SORTC2           YES USE 2 TBUF
         LI,11    X'F2'             DEFAULT TO 2 (BETTER)
         STB,11   *6,4               PUT INTO POS 14
S:SORTC2 RES      0
         BAL,11   INUM             GET NUMBER OF INTERM DCBS TO USE
         LI,X1    1                SET CO-RESIDENT SORT FLAG
         STW,X1   CRSF             TO INDICATED THAT THIS SORT
*                                  IS CALLED FROM A COBOL PROGRAM
*                                  AND IT CO-RESIDENT
         B        SO2              GO EXECUTE THE SORT.
         PAGE
*
DC1      LCI      15                SAVE ALL GENERAL
         STM,X1   SORTSV                REGISTERS
* UPON ENTRY TO THE RANDOM PROCESSOR
* R6 ADDR OF COM PAGE OF SORT SPECS
* R5 L HALF =1 CALLED BY STAND ALONE SORT
* R5 RIGHT HALF = 1 TRANS TABLE ALREADY BUILT
         STW,X6   FMAN
         STW,6    CPGSAV             SAVE COM PG ADDR      /SIG7-4174/*E4985
         LI,X1    0                SET CO-RESIDENT SORT FLAG OFF
         STW,X1   CRSF
         STW,5    CALLSW
         LH,11    5
         CI,11    0
         BNEZ     DC10              NOT ZERO , MAIN PROG CALLED
         LI,7     13                INDEX
         LB,5     *6,7                 DID USER SPECIFY 2
         CI,5     X'F2'
         BE       DC10               YES, SO DONT DEFAULT TO 1
         LI,5     X'F2'             DEFAULT TBUF TO 2
         STB,5    *6,7              SET TO POS 14 IN C PAGE
DC10     RES      0
         LI,7     24                SEE IF USER WANTS A DUMP
         LB,7     *CPGSAV,7          SEE IF DUMP IS DESIRED
         CI,7     C'D'               D FOR DUMP
         BNE      %+2
         MTW,1    DUMPMEM           SET ON FOR P0 TO TEST
         BAL,11   INUM
         M:PRINT  (MESS,SRTMES)
*
         PAGE
         LI,X1    1
         M:SETDCB F:SORTOUT,(ERR,RDERRDCB),(ABN,RDABNDCB)
         M:SETDCB F:SORTIN,(ERR,RDERRDCB),(ABN,RDABNDCB)
SO2      RES      0
         MTW,0    UTSCPVSW          IS IT UTS OR CPV
         BEZ      SO20              NO
         M:XCON   EXITCTL
SO20     RES      0
         LW,15    *X'4F'             UNIQUE PROG ID FOR EXTABLE
         AND,15   =X'00007FFF'         DROP LEFT BIT OF PROG-ID
         OR,15    =X'00B20000'      164 IN BIT 8-16 POS 357 (20X17)
         LI,2     357               INDEX
SO201    RES      0
         STW,15   EXTNTBLE-1,2        STORE IN VALUE
         SW,15    =X'8000'          SUBR 1 FROM BIT 16
         BDR,2    SO201             STORE IN NEXT LOWER VALUE IN TABLE
         LI,2     1                 OPEN FPT HAS AT LEAST 2 WORDS
         LI,5     X'800'            START WITH PRES BIT 20
         LW,15    OPENFPT+1         GET WORD IN FPT
SO21     RES      0
         AND,15   5
         BEZ      %+2
         MTW,1    2                 PRES BIT ON, SO UP INDEX
         SLS,5    1                  SHIFT MASK FOR NEXT BIT TEST
         CI,5     0                 HAVE WE TESTED ALL BITS
         BNE      SO21              NO
SO22     LW,5     OPENFPT,2          INDEX NOW POINTS TO VAR PARAMS
         SLS,5    -24
         CI,5     1                 1 IS NAME PARAM
         BE       SO24
         AI,2     1
         CI,2     32                ASSUME END
         BNE      SO22
SO23     RES      0
         LI,7     17                ABORT
         B        SC50              ABORT CANT FIND NAME
SO24     RES      0
         AI,2     1                 POINT TO NAME FIELD ITSELF
         STW,2    INXOPEN           SAVE FOR LATER
         LI,2     1                 SET INDEX INTO FPT
         LI,5     X'800'            POINT TO PRES BIT 20
         LW,15    INTOPFPT+1        GET WORD IN FPT
SO25     RES      0
         AND,15   5                 SEE IF PRES BIT IS ON
         BEZ      %+2               NO
         MTW,1    2                 UP INDEX     VALUE
         SLS,5    1                 SHIFT MASK TO SEE NEXT BIT
         CI,5     0                 AT END TESTED ALL BITS
         BNE      SO25              NO
SO26     RES      0
         LW,5     INTOPFPT,2        GET BEGIN OF VAR PARAMS
         SLS,5    -24               SEE THE BYTE ID
         CI,5     1                 1 MEANS NAME
         BE       SO27              GOT IT
         AI,2     1                 UP INDEX
         CI,2     32                ASSUME END
         BNE      SO26              TRY AGAIN
         B        SO23               ABORT
SO27     RES      0
         AI,2     1                 POINT TO NAME FIELD ITSELF
         STW,2    INXOPEN1          SAVE FOR LATER USE
         BAL,11   INTOP             OPEN INTER DCBS WITH ORIG FILE/NAME
SO3      RES      0
*
         PAGE
*
         BAL,X5   SCR0              EXECUTE PHASE 0
         LW,X7    CPER              ANY ERRORS
         BCS,X3   SC50              YES: TAKE RRROR EXIT
*
         BAL,X5   SCR1              GO EXECUTET PHASE ONE
         LW,X7    CPER              ANY PAHASE ONE ERRORS  /SIG7-1162/*C4985
         BCS,X3   SC50              YES: TAKE ERROR EXIT
*
         B        PHASE3
*
C1R      B        PHASE4
E1R      RES      0
SC6      RES      0
         LI,6     0
         LW,9     BCT0+1             REC IN COUNT
         LW,8     BCT0+2            OUT REC COUNT
         AW,8     BCT0+22           OUT DELETED            SIG7-8751
         SW,8     BCT0+31             OUT INSERT COUNT
         LW,7     BCT0+2            NUM OF RECS
         CW,9     8                                        SIG7-8751
         BE       SC7
         LI,6     1
         LW,7     CRSF
         BEZ      SO8               NO
SC7      RES      0
         STW,6    SAVE5             TEMP STORE
,STFP    M:FP     0
         MTW,1    ENDSW             SET ON FOR NORMAL EOJ
         BAL,7    CLSLUP             CLOSE INTER DCBS
         LCI      15
         LM,1     SORTSV
         LW,6     SAVE5              RESTORE
         LW,7     BCT0+2            OUT COUNT
         MTW,0    CRSF              IS IT CO-RES
         BNEZ     *11               YES
         B        *1                RETURN TO ROOT
SO8      RES      0
         LI,7     X'14'             INDEX                  SIG7-8751
         B        SC50               ERROR ABORT           SIG7-8751
*
EXITCTL0 RES      0
         LCI      15
         STM,15   SORTSV            CLSLUP CLOBBERS REGS
         BAL,7    CLSLUP            CLOSE INTER DCBS
         LCI      15
         LM,15    SORTSV            SHOW USER REGS GIVING XCON ABORT COD
         MTW,0    DUMPMEM           DO IT HAVE AN ADDR
         BEZ      EXITCTL-1
         AI,1     18
         STW,1    SAVER1            SNAP REG BEFORE XCON
         AI,1     -18
         M:SNAP   'SAVE REG',(*1,*SAVER1)
         M:SNAP   'MEMORY',(SORTSV,*ENDSNAP)
         M:SNAP   'MEMORY',(*DYNMEM,*DUMPMEM)
         M:TRTN   XCON
EXITCTL  STW,8    6                 8 IS DEST BY M:XCON
         M:XCON   0
         LW,8     6
         CI,8     0
         BEZ      EXITCTL-1         GET OUT
         CI,8     X'80'             M:ERR
         BE       EXITCTL-1
         CI,8     X'40'             M:XXX
         BE       EXITCTL-1
         AND,12   =X'40000000'        BIT 1 FROM M:LDTRC
         BNEZ     EXITCTL-1
         MTW,6    STEPCODE          SIGNAL ERROR TO USER
         AND,8    =X'00000030'       OPER ABORT OR ERROR
         BEZ      EXITCTLA          NO SO TEST FOR OTHERS
         LI,7     16
         B        SC50              GO ABORT
EXITCTLA RES      0
         LW,8     6
         AND,8    =X'00000004'       IS BIT 29 ON LIMITS
         BNEZ     EXITCTL4           YES
         LW,8     6                 RESTORE FOR FURTHER TESTS
         AND,8    =X'00000003'       BIT 30 IO, BIT 31 TRAP
         BEZ      EXITCTL0          RE DO ABORT
         AND,8    =X'00000001'        BIT 31 TRAP
         BEZ      EXITCTL1
         LH,6     CALLSW
         BEZ      %+2
         B        EXITCTL0
         M:SNAP   'REGS'
         MTW,0    DUMPMEM           DO IT HAVE AN ADDR
         BEZ      EXITCTLB
         AI,1     18
         STW,1    SAVER1
         AI,1     -18
         M:SNAP   'SAVE REG',(*1,*SAVER1)
         M:SNAP   'MEMORY',(SORTSV,*ENDSNAP)
         M:SNAP   'MEMORY',(*DYNMEM,*DUMPMEM)
EXITCTLB RES      0
         BAL,7    CLSLUP            CLOSE INTER DCBS
         LCI      15
         LM,1     SORTSV            RESTORE REGS AT ENTRY TO SRP
         LI,6     4                 TELL USER IT TRAPPED
,STFP2   M:FP     0
         MTW,0    CRSF
         BNEZ     *11
         B        *1                RETURN TO ROOT
EXITCTL1 RES      0
         LW,9     10
         CI,9     X'54'
         BE       EXITCTL0
         CI,9     X'57'
         BNE      %+2
         BAL,8    EXITCTL5           SEE IF M:DO TO A FILE
         M:XCON   EXITCTL           SET IT BACK ON
         LI,8     0
         STW,8    STEPCODE          CLEAR MAY NOT BE ABORTING
         SLS,10   24
         LI,1     1
         SLS,11   1                 FORMAT CORRECTLY FOR PRINT
         STB,11   10,1              MAKE SUBCODE
         CI,9     X'40'            IS IT AN ERROR
         BGE      EXITCTL2         YES
         BAL,8    RDABN
         B        EXITCTL-1
EXITCTL2 RES      0
         BAL,8    RDERR            GO TO ERROR HANDLERS
         B        EXITCTL-1
EXITCTL4 RES      0
         LI,1     1
         LI,10    X'B3'             MAKE UP CODE, XCON WONT
         SLS,10   24                 ERROR CODE
         STW,10   ERRCD
         M:PRINT  (MESS,E1C)
         LI,7     1                 PRINT ERROR
         B        SC50              ABORT
EXITCTL5 RES      0
         LW,6     M:DO
         AND,6    =X'F'             GET DCB DEV TYPE
         CI,6     1                 1 FOR A FILE
         BNE      EXITCTL6
         MTW,1    IO57M:DO          SET FOR SPECIAL CASE
EXITCTL6 RES      0
         LW,6     M:LL               SEE 1ST WORD OF DCB
         AND,6    =X'F'             SEE DEVICE TYPE
         CI,6     1
         BNE      *8
         MTW,1    IO57M:LL          SET SW TO A FILE
         B        *8
*
CLSLUP   RES      0
         MTW,0    ENDSW              ARE WE AT EOJ
         BEZ      PHS60             NO
         MTW,0    CRSF
         BNEZ     CLSLUP0            SKIP MESSAGE
PHS60    RES      0
         LI,1     1
         LH,5     BCT0+27,1         NUM OF INTER DCBS
         STW,5    PHS69
         LI,14    0
         LI,5     1                 SET INDEX TO POINT TO WORD 1 DCB1
PHS61    LW,15    EXTNTBLE,5        SEE WORD 1 OF THIS DCB       -
         BLZ      PHS63             YES       BIT 0 = 1
PHS62    RES      0
         AI,5     21                POINT TO WORD 1 NEXT DCB
         MTW,1    1
         CW,1     PHS69             HAVE WE EXAMINED ALL USED DCBS
         BLE      PHS61             NO
         LI,1     1                 RESET SACRED INDEX
         B        CLSLUP0           ALL DONE
PHS63    MTW,1    14                COUNT THIS EXTENT
         MTW,1    5                 UP INDEX
         CI,14    21                 HAVE WE DONE 20 EXTENTS FOR DCB
         BE       PHS64             YES SO RESET AND GO TO NEXT DCB
         LW,15    EXTNTBLE,5        SEE NEXT WORD FOR THE DCB
         BLZ      PHS63             YES SO SEE NEXT WORD OF DCB
PHS64    LH,15    RSTOR,1           NO, SO DONE WITH THIS DCB
         AND,15   =X'FFFF'          NUMBER OF GRANUELS
         STW,15   CNVRT+1
         LI,15    0
         STW,15   CNVRT
         STW,5    PHS68
         STW,14   PHS67
         BAL,5    BINEBC
         LCI      2
         LM,14    CNVRT
         STM,14   EXTMESSG+11        STORE NUM OF GRAN
         LI,15    0
         STW,15   CNVRT
         LW,14    PHS67             GET NUM OF EXTENTS FOR DCB
         STW,14   CNVRT+1
         BAL,5    BINEBC
         LCI      2
         LM,14    CNVRT
         STM,14   EXTMESSG+8        STORE NUM OF EXTENTS
         LI,14    0
         STW,14   CNVRT
         STW,1    CNVRT+1           DCB NUMBER IN REG 1
         BAL,5    BINEBC
         LCI      2
         LM,14    CNVRT
         LI,5     16
         STH,15   EXTMESSG,5        STORE NUM OF DCBS
         LW,14    PHS67
         LW,5     PHS68
         MTW,0    IO57M:LL          SEE IF SET
         BNEZ     %+2
         M:PRINT  (MESS,EXTMESSG)       PRINT EXTENT MESSG FOR THE DCB
         SW,5     14                REDUCE TABLE INDEX TO WORD 1/DCB
         LI,14    0                 CLEAR FOR NEXT LOOP
         B        PHS62              SEE NEXT DCB
*
PHS67    DATA     0                 HOLD REG 14
PHS68    DATA     0                 HOLD REG 5
PHS69    DATA     0                 COUNT OF NUM OF INTER DCBS
*
CLSLUP0  RES      0
         LW,5     FIT5
         LW,9     FIT5,5
         M:CLOSE  *9,(SAVE)         SAVE FOR LATER CLOSE
         BDR,5    CLSLUP0+1
         MTW,1    CLSLUPSW          ON, TO SKIP CLOSE IN EXTDCB20
         LW,5     FIT5              NUM OF INTER DCBS
         LI,4     1                 POINT TO DCB 1
         LI,6     0                  POINT TO DCB1 IN EXTNTBLE
         LI,3     0                 INITIALIZE LOOP COUNTER
CLSLUP1  RES      0
         LW,15    EXTNTBLE,6         GO CLOSE ORIG FILE NAME
         B        CLSLUP4A
CLSLUP2  RES      0
         AI,4     1                 POINT TO NEXT DCB
         AI,6     21                UP EXTNTBLE POINTER
         BDR,5    CLSLUP1           SEE NEXT DCB
         MTW,-1   CLSLUPSW          SET OFF
         B        CLSLUP6           CLOSE IN/OUT DCBS IF NESS
CLSLUP4  RES      0
         LW,15    EXTNTBLE,6         GET EXTENT NAME
         BGEZ     CLSLUP5           NO MORE FOR THIS DCB, OUT OF LOOP
CLSLUP4A RES      0
         STW,15   EXTDCB92          SAVE NAME
         LW,15    FIT5,4            DCB ADDR
         STW,15   EXTADDR
         LH,15    RSTOR,4            PICK UP ORIG RSTORE REQ
         AND,15   =X'FFFF'            MASK SIGN EXT IF ANY
         STW,15   EXTGRAN
         BAL,15   EXTDCB20          OPEN FILE WITH EXT OR ORIG NAME
         M:SETDCB *EXTADDR,(ERR,CLSLUP4B),(ABN,CLSLUP4B)  BYPASS ERRS
         M:CLOSE  *EXTADDR,(REL)
CLSLUP4B RES      0                 FILE MAY NOT BE THERE SO SKIP ERR
         M:SETDCB *EXTADDR,(ERR,0),(ABN,0)
         AI,6     1                 SEE NEXT FILE NAME FOR THIS DCB
         AI,3     1                  UP LOOP COUNTER
         CI,3     22                21 TIMES THRU MAX
         BL       CLSLUP4           OK, GO THRU LOOP AGAIN
CLSLUP5  RES      0
         SW,6     3                 GET 6 BACK TO POWER OF 21
         LI,3     0                 RESET LOOP INDEX VALUE
         B        CLSLUP2            EXAMINE NEXT DCB
*
CLSLUP6  RES      0
         MTW,0    CRSF              IS IT CO-RES
         BNEZ     *7                SKIP GRANULE USAGE MSG
         BAL,6    CLOSEIN           CLOSE INPUT
         LW,5     =X'00200000'      TEST FCD
         LI,6     F:SORTOUT
         AND,5    *6
         BEZ      PHS70
         M:CLOSE  *6,(SAVE),(REM)
PHS70    RES      0
         LI,6     1                 INDEX
PHS71    RES      0
         LW,4     FIT8,6            GET GRAN VALUE
         LI,15    0
         STW,15   CNVRT
         STW,4    CNVRT+1           GRAN VALUE TO BE CONVERTED
         BAL,5    BINEBC            CONVERT
PHS72    RES      0
         LCI      2
         LM,14    CNVRT
         STM,14   E1A+10            STORE NUMBER OF GRANULES
         LI,15    0
         STW,15   CNVRT
         STW,6    CNVRT+1            STORE DCB NUMBER
         BAL,5    BINEBC
         LW,15    CNVRT+1            GET CONVERTED DCB #
         STW,15   E1A+8             STORE IN MSG
         MTW,0    IO57M:LL          SEE IF SET
         BNEZ     %+2
         M:PRINT  (MESS,E1A)
         AI,6     1                 INCR INDEX
         CW,6     FIT5              NUM OF DCBS
         BLE      PHS71             INDEX NOT OVER, LOOP AGAIN
         B        *7                TO CLSLUP CALLER
CLDCBADR DATA     0                 HOLD DCB ADDR
CLRETURN DATA     0                 HOLD RETURN ADDR
CLOSEIN  RES      0
         STW,6    CLRETURN          SAVE RETURN ADDR
         LI,6     F:SORTIN          GET DCB ADDR
         STW,6    CLDCBADR          SAVE FOR CLOSE OPERATION
         LW,6     *6                GET WORD 0 OF THE DCB
         AND,6    =X'00200000'       TEST FCD TO SEE IF ON
         BEZ      *CLRETURN         NOT ON SO OUT
         LI,6     F:SORTIN
         AI,6     5                 COMPUTE WORD 5 ADDR
         LB,6     *6                 GET FIL1 FIELD WORD 5
         AND,6    =X'000000C0'      MASK OUT OTHER THAN
         CI,6     X'80'             80 MEANS SAVE OPTION
         BNE      %+2               RELEASE WAS WANTED
         MTW,1    CLOSEIN0+2        CHANGE REL (1) TO SAVE (2)
,CLOSEIN0 M:CLOSE  *CLDCBADR,(REM),(REL)
         B        *CLRETURN         INPUT CLOSE AS USER WANTED
         PAGE                                              /SIG7-1162/*C4985
*        THIS IS THE TERMINATING ERROR HANDLER             /SIG7-1162/*C4985
*        AT ENTRY:                                         /SIG7-1162/*C4985
*                 R7 CONTAINS HEX ERROR CODE               /SIG7-1162/*C4985
*        THE PROPER MESSAGE IS PRINTED AND REGISTER 6      /SIG7-1162/*C4985
*        IS SET.                                           /SIG7-1162/*C4985
*                                                          /SIG7-1162/*C4985
SC50     RES      0
         LW,4     ERTBL,7           MESS POINTER
         MTW,6    STEPCODE          SIGNAL ERROR TO USER
         LI,6     0
         LI,5     0
         LW,13    =C'    '
         CI,7     1                IS IT I/0 ERROR
         BNE      SC12             NO.
SC8      RES      0                 YES
         LB,14    ERRCD
         SAD,14   -4                GET FIRST HEX DIGIT OF CODE IN 14
SC9      RES      0
         CI,14    9                 IS IT NUMERIC
         BG       SC10              NO:  GO SET TO PRINT ALPHA
         AI,14    X'F0'             YES:  SET TO PRINT NUMERIC INFO
         B        SC11
SC95     RES      0
         LB,14    ERRCD,X5         GET SUBCODE
         SLS,14   -1               ADJUST CODE
         B        SC9-1            GO SET FOR PRINTING
*
SC10     RES      0
         AI,14    X'B7'             CONVERT  A-F FOR PRINT C1-C6
SC11     RES      0
         STB,14   13,6
         AI,6     1
         SAD,14   4
         AND,14   =X'F'
         CI,6     2                 IS DIGIT NUMBER 2
         BL       SC9               YES:  GO PROCESS DIGIT NUMBER 2
         AI,5     1                 STEP BYTE PICKUP INDEX
         CI,6     2                 IS IT DIGIT NUMBER 3
         BE       SC95              YES:  GO GET DIGITS 3 + 4
         CI,6     4
         BL       SC9               YES:  GO PROCESS DIGIT NUMBER 4
SC12     RES      0
         STW,13   E2+5              STORE 4 BYTE OF ALPHA ERROR CODE
         CB,10    ERRCD
         BNE      %+2
         LW,10    ERRCD
         MTW,0    IO57M:LL          SEE IF SET
         BNEZ     %+2
         M:PRINT  (MESS,*4)
         MTW,0    IO57M:DO           IS IT THIS SPECIAL CASE
         BNEZ     SC52              YES SO SKIP SNAPS
         M:SNAP 'DCB',(F:SORTIN,F:SCRF17+58)
         LW,5     CPGSAV            BASE OF COM PAGE       /SIG7-4174/*E4985
         BEZ      SC51             NO COMMON PAGE TO DUMP
         AI,5     256                                      /SIG7-4174/*E4985
         M:SNAP 'COM PAGE',(*CPGSAV,*5)                    /SIG7-4174/*E4985
SC51     RES      0
         M:SNAP   'TABLES',(SORTSV,SKBB-1)
         M:SNAP   'IN - OUT',(BCT0+1,BCT0+2)
SC52     RES      0
         STW,X7   CPER              SAVE ERR CODE          /SIG7-1162/*C4985
         BAL,7    CLSLUP             CLOSE INTER DCBS
         LCI      15                RESTORE REGS           /SIG7-1162/*C4985
         LM,X1    SORTSV                                   /SIG7-1162/*C4985
         LW,X7    CPER                                     /SIG7-1162/*C4985
         LI,X6    3                                        /SIG7-1162/*C4985
         CI,X7    17                SPEC ERRR              /SIG7-1162/*C4985
         BE       SO5                                      /SIG7-1162/*C4985
         LI,X6    5                                        /SIG7-1162/*C4985
         CI,X7    4                 MEM OFLOW              /SIG7-1162/*C4985
         BE       SO5                                      /SIG7-1162/*C4985
         LI,X6    6                                        /SIG7-1162/*C4985
         CI,X7    9                 ILL OWN-CODE           /SIG7-1162/*C4985
         BE       SO5                                      /SIG7-1162/*C4985
         LI,X6    8                                        /SIG7-1162/*C4985
         CI,X7    3                 ILL DEC KEY            /SIG7-1162/*C4985
         BE       SO5                                      /SIG7-1162/*C4985
         LI,X6    9                                        /SIG7-1162/*C4985
         CI,X7    15                SEQ ERROR              /SIG7-1162/*C4985
         BE       SO5                                      /SIG7-1162/*C4985
         LI,6     1                 IN-OUT COUNT NOT EQUAL SIG7-8751
         CI,7     X'14'                                    SIG7-8751
         BE       SO5                                      SIG7-8751
         LI,X6    2                 DEFAULT TO I/O ERR     /SIG7-1162/*C4985
SO5      LW,7     BCT0+2            NUM OF RECS
         MTW,0    IO57M:DO          IS IT THIS SPECIAL CASE
         BNEZ     SC53              YES SO SKIP SNAPS
         MTW,0    DUMPMEM           DO IT HAVE AN ADDR
         BEZ      %+3
         M:SNAP   'MEMORY',(SORTSV,*ENDSNAP)
         M:SNAP   'MEMORY',(*DYNMEM,*DUMPMEM)
SC53     RES      0
,STEP    M:FP     0
         MTW,0    CRSF
         BNEZ     *11               IT IS CO-RES
         B        *1                RETURN TO ROOT
         PAGE
*        THIS ROUTINE GETS THE NUMBER OF INTERMEDIATE DCBS
*        FROM THE USERS PARAMETER LIST.
INUM     RES      0
         LI,X4    9
         LW,X4    *6,X4            6= ADDRESS OF PARAM LIST
         AND,X4   =X'FF'           MASK OUT NUMBER OF DCBS
         CI,4     X'40'
         BNE      %+3
         LI,4     6                 6 IS NEW DEFAULT
         B        INUM20
         CI,4     0
         BNE      %+3
         LI,4     6                 6 IS NEW DEFAULT
         B        INUM20            DEFAULT TO 8
         CI,4     X'F6'             6 IS MIN FOR RANDOM SORT
         BGE      INUM10           YES.
         CI,4     X'C9'
         BGE      INUM30            ERROR SO TEMP DEFAULT TO 17
         CI,4     X'C1'
         BL       INUM30            ERROR TEMP DEFAULT TO 17
         AND,X4   =X'F'
         AI,4     9                 A=10,B=11 ECT
         B        INUM20
INUM10   RES      0
         CI,4     X'F9'
         BG       INUM30            ERROR DEFAULT TO 17
         AND,X4   =X'F'            REG 4 = NUMBER OF DCBS TO PROCESS
INUM20   RES      0
         LI,1     1
         STH,4    BCT0+27,1         SET IN TABLE
         STW,4    FIT5              SET IN TABLE
         STW,4    ILT0              STORE IN TABLE
         B        *11               EXIT
INUM30   RES      0
         LI,4     17                DEFAULT TO 17
         B        INUM20            LET SPEC CHK IN P0 CATCH ERR/ABORT
*
*        THIS ROUTINE CHECKS TO SEE IF MORE THAN ONE
*        CO-RESIDENT SORT HAS BEEN CALLED. IF NO
*        IT SAVES THE RSTORE PARAMETER IN THE DCBS AND OPENS
*        THEM WITH A NORMAL OPEN (OPINT).
INTOP    RES      0
         LW,4     FIT5              NUM OF INTER DCBS
         LW,X3    SNUM             IS THIS THE FIRST CO-RES SORT
         BNEZ     *11               OUT
         MTW,1    SNUM             SET FLAG
         MTW,0    UTSCPVSW          IS IT UTS OR CPV
         BEZ      INTOP05
         LI,X5    41               INDEX INTO DCBS FOR RSTORE
         B        INTOP10
INTOP05  RES      0
         LI,5     43                RSTORE IN WORD 21 OF DCB FOR BPM BUG
INTOP10  RES      0
         LW,X3    FIT5,X4          DCB ADDRESS
         LH,X3    *3,X5            GET RSTORE PARAMETER
         STH,X3   RSTOR,X4         SAVE IT
         BDR,X4   INTOP10          GET THE REST IF ANY
         B        *11
*
*        THIS ROUTINE OPEN THE INTERMEDIATE DCBS NORMALLY
OPINT    RES      0
         LH,X5    RSTOR,X4         GET RSTORE PARAM
         AND,X5   =X'FFFF'
         LW,X3    FIT5,X4          GET DCB ADDRESS
         LW,7     4                 DCB
         AI,7     -1                DCB1 IS 0 ENTRY IN TABLE ECT
         MI,7     21                21 ENTRIES PER DCB
         LW,2     EXTNTBLE,7         GET UNIQUE FILE NAME
         OR,2     =X'40000000'      SET BIT 1=1 FOR ORIG FILE NAME FLAG
         STW,2    EXTNTBLE,7         SET INTO TABLE
         AND,2    =X'00FFFFFF'      JUST WANT FILE NAME NOW
         OR,2     =X'03000000'      3 SIG BYTES
         LW,7     INXOPEN1          INDEX INTO FPT FOR FILE/NAME
         STW,2    INTOPFPT,7          STORE UNIQUE NAME INTO FPT
,INTOPFPT M:OPEN  *3,(RANDOM),(OUTIN),(SAVE),(RSTORE,*5),;
                  (DIRECT),;
                  (ERR,RDERR),(ABN,RDABN),(FILE,'ZZZ')
         M:SETDCB *X3,(ERR,ERRINT),(ABN,ABNINT)
         BDR,X4   OPINT            DO THE REST IF ANY
         B        *11
         PAGE
*
*  THESE ROUTINES SET THE FIRST ENTRY CONDITIONS FOR READING
*        AND WRITING FILES.  THEY PERFORM A LOGICAL OPEN FOR
*        THE CALLING ROUTINE-NOT A MONITOR OPEN.
*
*  AT ENTRY TO IN1:
* REG 11 IS THE RETURN ADDR
         PAGE
*
IN1R     DATA     0
*
IN1      STW,11   IN1R              SAVE RETURN ADDR
         LW,11    DRPHOOK2         SET I/0 07 TO RETURN HERE
         STW,11   DROPBLK3
         MTW,0    INSW              0 FIRST TIME THRU
         BNEZ     IN2B
         MTW,0    BCT0+12           IS THIS A SLICE FILE
         BEZ      %+2               NO
         MTW,1    SLICEFL           YES SET SW TO 1
         LW,11    F:SORTIN          WORD 0 OF DCB
         AND,11   =X'00200000'          SEE BIT 10 FCD
         BEZ      IN1A
         LI,7     13                IN DCB ALREADY OPEN,SO ABORT
         B        SC50
IN1A     LI,11    F:SORTIN          ADDR OF IN DCB
         STW,11   SORTSD             FOR LATER IO
         LW,11    ANSISWIN          IS INPUT ANSI
         CI,11    2                 ANS BVAR
         BNE      IN1B
         LI,11    3                 INDEX FLAG FOR ANS BVAR
         B        IN1D               STORE INDEX FLAG
IN1B     LW,11    BCT0+18            IN BLOCKING FACTOR
         CI,11    1                 UNBLOCKED
         BNE      IN1C
         LI,11    0                 INDEX FLAG FOR UNBLOCKED
         B        IN1D              STORE INDEX FLAG
IN1C     LI,11    1                 INDEX FLAG FOR BLOCKED
IN1D     STW,11   TCT0              STORE INDEX FLAG
         LI,1     3                 SET INDEX
         LB,11    BCT0+19,1           SEE TYPE CODES
         LI,1     1                 RESET SACRED INDEX
         CI,11    C'M'              MEANS MANAGE INPUT
         BNE      IN2                NO
         LI,11    2                  INDEX FLAG FOR MANAGE
         STW,11   TCT0              STORE INDEX FLAG
         MTW,-1   FMAN              SET COM PAGE ADDR LESS BY 1 WORD
         LI,11    X'FFFF'           MASK
         AND,11   *FMAN             * GET MAN OFFSET TO BE USED BY
         STW,11   FMAN              * DEBLOCKER FOR MANAGE
         MTW,-1   FIRSTSW           LET MANAGE DEBLOCKER TEST FIRST TM
IN2      LH,11    BCT0+30           INPUT BUF SIZE
         AND,11   =X'FFFF'
         SLS,11   2                 TO BYTES
         STW,11   BFSIZE
         LW,11    INBUF             TELLS WHAT BUF TO USE
         CI,11    1
         BNE      IN2A
         LW,11    FIT7              USE BUF 1
         STW,11   BFLOC
         B        IN2B
IN2A     LW,11    FIT7+1            BUF 2
         STW,11   BFLOC
IN2B     MTW,0    NHED              DO HEADER LABELS EXIST
         BEZ      IN9               NO, SO SKIP PROCESSING
         LI,12    HTBUFIN           BUFFER AREA FOR HEADER
         LW,11    *SORTSD            SEE DEV-TYPE
         AND,11   =X'F'
         CI,11    2                 LABELLED TAPE
         BLE      IN4
         MTW,0    ANSISWIN           IS IT ANSI INPUT
         BEZ      IN2D               NO
         LI,11    80                MAX LABEL SIZE FOR ANSI
         B        IN4A              GO PROCESS
IN2D     RES      0
         LI,13    256
         M:READ   *SORTSD,(BUF,*12),(SIZE,*13),(BTD,1),(ERR,RDERR),;
                  (ABN,RDABN)
         LI,1     8                 SET INDEX
         LH,11    *SORTSD,1         GET ARS FROM DCB
         SLS,11   -1
         STB,11   *12               STORE LABEL LENGTH
         LI,1     1                 RESET SACRED INDEX
IN3      LCI      15
         STM,1    OCSAV1            SAVE ALL REGS
         LW,6     12                INPUT BUF ADDR IN WORDS
         SLS,6    2                  TO BYTES
         BAL,5    S:INHED           EXEC USER OWN CODE
         LCI      15
         LM,1     OCSAV1            RESTORE REGS
         LI,12    0                 FOR DROPBLK TO CHK IF NECESSARY
         B        IN9
IN4      LI,11    X'FF'             SET TO MAX LABEL SIZE
IN4A     STB,11   *12               STORE IN LABEL AREA
         M:OPEN   *SORTSD,(IN),(TLABEL,*12)
         B        IN3               NOW EXEC OWN CODE
IN9      LI,6     12                INDEX
         LB,9     *PRAMLOC,6        SEE HOW TO SKIP HEADER IF NECESS
         CI,9     X'40'             40 MEANS NO SKIP
         BE       IN9C
         CI,9     X'C6'
         BNE      IN9A
         M:PFIL   *SORTSD,(EOF)       SKIP BLOCKS OF HEADERS
         B        IN9C
IN9A     RES      0
         AND,9    =X'0000000F'         MASK TO MAKE BINARY
         STH,9    IN9B+2,1          STORE 1-9 IN FPT
,IN9B    M:PRECORD *SORTSD,(N,1)         ( MAY BE CHANGED
IN9C     RES      0
* INCASE IO ERROR OR WAIT ON 1ST BLK OF NEXT REEL
         LW,9     SAVE8             ORIG CHK RETURN ADDR IN RDABN
         STW,9    TEMPHOLD
         LW,9     DACTSAV+2           REG 9 RETURN FROM ORIG CHK
         STW,9    TEMPHOLD+1
         BAL,9    ORDF              READ 1ST BLOCK THIS VOL
         BAL,9    OCHKA             CHECK THAT READ
         BAL,9    ZEROIT            CLEAR SAVED 8.9,10
         LW,9     TEMPHOLD
         STW,9    SAVE8
         LW,9     TEMPHOLD+1
         STW,9    DACTSAV+2
         BAL,9    PR9               GET ARS OF JUST READ
         LW,11    DRPHOOK1         RESET HOOK
         STW,11   DROPBLK3         AS CHECK WAS OK TO GET THIS FAR
         MTW,0    INSW
         BNEZ     *IN1R             NOT FIRST TIME THRU, WAS VOL-EXIT
         MTW,1    INSW              SET SW OFF FOR GOOD
         LW,11    FIT7+1            WILL ALWAYS READ INTO BUF 2
         STW,11   BFLOC
         MTW,0    EOFSW             DID WE HIT EOF 1ST READ?
         BNEZ     *IN1R              YES SO GET OUT
         BAL,9    ORDF              READ BUF 2
         B        *IN1R             EXIT
         PAGE
*
*
*                     THIS REGION PERFORMS LEGALITY CHECK
*
* THIS ROUTINE OPEN OUTPUT FILES/VOLUMES DURING THE FINAL MERGE
* IT SET THE TCT0 ENTRY TO SELECT THE PROPER BLOCKER, EXECUTES
* HEADER OWN CODE IF PRESENT. IT SETS CURRENT OUTPUT BUFFER THE FIRST
* TIME THRU THIS ROUTINE.
OU1R     DATA,4   0                 HOLD RETURN ADDR
*
OU1      STW,15   OU1R                SAVE RETURN ADDR
         MTW,0    OUSW              IS THIS FIRST TIME THRU
         BNEZ     OU2               NO
         MTW,1    OUSW               SET OFF
         LW,8     BCT0+15           FIRST BUFF ALWAYS BUF 1
         STW,8    BCT0+26           CURR BUFFER (INITIALIZED)
         LW,8     OHED
         BNEZ     OU1A
         B        OU2               OWN CODE NOT SPEC SO SKIP
OU1A     RES      0
         LW,8     F:SORTOUT         SEE DEV-TYPE
         AND,8    =X'F'
         CI,8     2                 LABELLED TAPE
         BE       OU1B
         CI,8     X'A'              ANS TAPE
         BNE      OU2               NO
OU1B     RES      0
         LW,8     WRITE1C           SPECIAL WRITE FOR ANS/LAB TAPE
         STW,8    CO1BA-1
         STW,8    PW1E
OU2      LI,8     6                 TYPE CODE INDEX
         LW,9     ANSISWOU
         CI,9     2                 ANSI BVAR
         BE       OU3
         LI,8     5                 TYPE CODE INDEX
         LW,9     BCT0+17           OUT BLOCK FACTOR
         CI,9     1
         BNE      OU3
         LI,8     4                 TYPE CODE INDEX
OU3      STW,8    TCT0              SET TYPE CODE FOR BLOCKER
         LI,9     F:SORTOUT         ADDR OF OUT DCB
         STW,9    SORTSD
         LW,9     OHED
         BNEZ     OU5               OUT OWN CODE PRES
         LW,9     SORTSV+6           LABEL LEN + ADDR, IF ANY
         BNEZ     OU4               FROM COM PAGE ON USER LINK
         B        *OU1R
OU4      LB,8     *9                GET LENGTH BITS 00-07
         BEZ      *OU1R             NONE , SO EXIT
         B        OU7
OU5      LCI      15
         STM,1    OCSAV1            SAVE REGS
         BAL,5    S:OUHED           EXECUTE USER OWN CODE
         LB,7     0,6                GET LABEL LEN FROM USER
         SLS,6    -2
         STW,6    BFLOC             LABEL LOC
         STW,7    BFSIZE            LABEL LENGTH
         LCI      15
         LM,1     OCSAV1
         LW,8     F:SORTOUT
         AND,8    =X'F'
         CI,8     3
         BNE      OU7
         BAL,9    OWRTLBL            LABEL WRITE
         B        *OU1R             EXIT
OU7      RES      0
         STW,9    BFLOC
         M:OPEN   *SORTSD,(OUT),(TLABEL,*BFLOC)
         B        *OU1R             EXIT
WRITE1C  RES      0
         BAL,9    OWRT1C
         PAGE
* THIS ROUTINE CLOSES INPUT FILES/VOLUMES . IT EXECUTES
*        TRAILER LABEL OWN CODE AND CAUSES EXECUTION OF USER
*        HEADER LABEL OWN CODE IF THE CLOSE IS FOR A VOLUME.
*
* AT ENTRY TO CI1
* REG 15 IS THE RETURN ADDR
*
*  CI1 ATTEMPTS TO OPEN THE NEXT VOLUME BEFORE CLOSING THE FILE.
*                 IF THERE IS NO NEXT VOL, CI1 CLOSES FILE
         PAGE
*
CI1R     DATA     0
*
CI1      STW,15   CI1R              SAVE RETURN ADDR
         LW,15    SLICEFL           IS THIS A SLICE CLOSE
         CI,15    2                 2 MEANS YES
         BE       CI5               BYPASS TRAILER PROC
         LW,15    NTRL              INPUT TRAILER OWN CODE FLAG
         BEZ      CI5                NONE PRES, SO BYPASS
         LI,12    0                 0 MEANS NO TRAILER GOTTEN
         LI,15    X'7'              MASK
         AND,15   *SORTSD            SEE DCB ASSIGNMENT
         CI,15    3
         BL       CI3               BR ON DEV=2,ANS-DEV=A,DEV=1
         LI,12    HTBUFIN           GET ADDR OF AREA FOR TRAILER
         LI,13    256
         M:READ   *SORTSD,(BUF,*12),(SIZE,*13),(BTD,1),(ERR,RDERR),;
                  (ABN,RDABN)
         LI,1     8                 INDEX
         LH,15    *SORTSD,1           GET ARS
         SLS,15   -1
         STB,15   *12               STORE LABEL LENGTH
         LI,1     1                 RESET SACRED INDEX
CI3      LCI      15
         STM,1    OCSAV              SAVE ALL GEN REGS
         LW,6     12                WORD ADDR OF TRAILER OR 0
         SLS,6    2                  TO BYTES
         BAL,5    *NTRL             EXEC USER ROUTINE
         LCI      15
         LM,1     OCSAV             RESTORE ALL GEN REGS
         LI,12    0                 FOR DROPBLK TO CHK IF NECESSARY
CI5      LI,15    X'7'               MASK
         AND,15   *SORTSD              SEE DCB ASSIGNMENT
         CI,15    3
         BL       CI9               BR ON DEV=2,DEV-ANS=A,ASN=1
         LW,15    SORTSD            DCB ADDR
         AI,15    6                 TO FLP PARAM
         LW,15    *15               GET FLP FIELD ADDR OF START VAR PARM
         AND,15   =X'0001FFFF'           MASK OUT ALL BUT FLP
         LI,6     3
CI6      RES      0
         LB,9     *15                GET VAR PARAM TYPE
         CI,9     7                 IS IT SN TYPE
         BE       CI7                YES
         LW,9     *15
         AND,9    =X'00FF0000'        GET BYTE 1 FOR LAST VAR/PARAM
         BEZ      CI61              NOT LAST
         LI,7     10                NO SN FOR DCB
         B        SC50
CI61     RES      0
         LB,9     *15,6
         AI,15    1
         AW,15    9                 ADD TO FIELD POINTER
         B        CI6               AND CHECK NEXT FIELD
CI7      RES      0
         AI,6     -1
         LB,9     *15,6              GET NUM OF SN PERMITTED
         LW,15    SORTSD            DCB ADDR
         AI,15    11                PARAM
         CB,9     *15               IS THIS THE LAST POS SN
         BE       CI9               YES
         LW,15    SLICEFL
         CI,15    2                 2 FOR SLICE CLOSE
         BE       CI9               YES, SO CLOSE FILE
         BAL,9    OCVL              CLOSE VOL OR FILE
         BAL,11   IN1               PROCESS BEGIN OF NEXT REEL
         B        *CI1R               EXIT TO REG PROCESSING
CI9      LW,15    NUSO              IS USER OWN CODE PRES
         BEZ      CI9A              NO
         LCI      15
         STM,1    OCSAV               SAVE ALL GEN REGS
         LI,6     0                 TELL USER EOF
         BAL,5    *NUSO             EXEC USER OWN CODE
         LCI      15
         LM,1     OCSAV             RESTORE REGS
CI9A     RES      0
         BAL,6    CLOSEIN           CLOSE INPUT
         MTW,1    EOFSW             SET ON FOR S:INPUT TEST
         B        *CI1R              EXIT
         PAGE
*
*  THIS ROUTINE CLOSES AN OUTPUT FILE.  IT ASSUMES THAT USER OWN
*        CODE HAS BEEN EXECUTED PREVIOUSLY IF IT EXISTED.
*
*  AT ENTRY TO CO1:
*   REG 15  IS THE RETURN ADDR
*   REG 7 HAS 0 FOR FILE CLOSE, ELSE VOLUME CLOSE
*
*  AT EXIT FROM CO1:
*        IF THE CLOSE IS FOR A FILE, THE FILE HAS BEEN CLOSED AND
*        ITS TRAILER LABEL HAS BEEN WRITTEN (IF ANY WAS SPECIFIED)
*
*        IF THE CLOSE IS FOR A VOLUME, THE VOLUME IS CLOSED AND A
*        NEW VOLUME PROCURED AND OPENED.
*
         PAGE
*
CO1R     DATA     0
*
CO1      STW,15   CO1R              SAVE RETURN ADDR
         LCI      15
         STM,1    OCSAV             SAVE REG, SO USER CAN USE
         CI,7     0
         BNEZ     CO1C              GO TO VOLUME CLOSE
         LI,13    F:SORTOUT         ADDR OF OUT DCB
         STW,13   SORTSD
         LW,13    BCT0+26           ADDR OF LAST OUT REC (BYTE)
         CW,13    BCT0+15           BUF 1 BASE ADDR
         BE       CO1C               YES  NO PARTIAL BLK
         CW,13    BCT0+16            BUF 2 BASE ADDR
         BG       CO1A               YES PARTIAL BLK 2 TO WRITE
         BL       CO1AA              YES PARTIAL BLK 1 TO WRITE
         LW,9     OUTBUF            WHAT BUF ARE WE IN
         CI,9     1
         BNE      CO1C              NO PARTIAL IN BLK 2
CO1AA    RES      0                 FULL BLK OR PARTIAL BLK 1 TO WRITE
         SW,13    BCT0+15            GET LEN OF RESIDUE IN BUF 1
         STW,13   BFSIZE            SIZE IN BYTES
         LW,13    BCT0+15
         STW,13   BFLOC             BEG LOC OF BUF 1 BYTE
         B        CO1B
CO1A     SW,13    BCT0+16           LEN OF RESIDUE IN BUF 2
         STW,13   BFSIZE            SIZE IN BYTES
         LW,13    BCT0+16           BEG ADDR BUF 2
         STW,13   BFLOC             BEG ADDR IN BYTES
CO1B     LW,13    ANSISWOU
         CI,13    2                 IS IT ANSI BVAR
         BNE      %+2
         BAL,13   MBLKWRD           MOVE BLK LEN CTL WRD (ANSI-BVAR)
         BAL,9    OWRT              WRITE RESIDUE
CO1BA    BAL,9    OCHKA
CO1C     BAL,9    OWFM               WRITE FILE MARK
         LW,9     OTRL              ANY OUT TRAILER OWN-CD SPEC ?
         BNEZ     CO1E              YES
         LH,9     CALLSW            ARE WE CALLED AS A SUB RTN
         BNEZ     CO1F              NO
         LB,9     *SORTSV+6         WAS A USER TRAILER TO BE PASSED ?
         BEZ      CO1F              NO
         LW,6     SORTSV+6           YES, SO WRITE IT
CO1D     STW,6    BFLOC
         SLS,6    2                 TO BYTES
         LB,6     0,6               GET LENGTH
         STW,6    BFSIZE            SAVE THE BYTE VALUE
         BAL,9    OWRTLBL           WRITE TRAILER
         BAL,9    OWFM              WRITE FILE MARK
         B        CO1F
CO1E     LI,6     0
         BAL,5    *OTRL             EXEC USER TRAILER RTN
         CI,6     0                 DID USER GIVE A TRAILER ?
         BEZ      CO1F
         SLS,6    -2                TO WORDS
         B        CO1D
CO1F     RES      0
         BAL,9    OWFM             WRITE 2ND EOF
         LW,7     OCSAV+6
         BNE      CO1G              GO DO VOL CLOSE
         M:REW    *SORTSD
         M:CLOSE  *SORTSD,(SAVE)
         B        *CO1R             EXIT
CO1G     BAL,9    OCVL              DO A CVOL
         BAL,15   OU1                OPEN NEZT VOL
         LCI      15
         LM,1     OCSAV
         B        *CO1R              EXIT
         PAGE
* THIS ROUTINE PROCURES ONE RECORD FROM THE INPUT FILE BY GOING
* TO THE APPROPRIATE DEBLOCKER. IF NECESSARY A PHYSICAL READ
* IS DONE ALONG WITH IO CHECKING. IF OWN CODE IS PRESENT,
*  IT IS EXECUTED, ALSO RECORD SKIPPING AND SLICING IS DONE.
* AT ENTRY  R11 IS THE RETURN ADDR
*            AT EXIT R7 HAS RECORDS BYTE ADDR
*            AT EXIT R8 HAS RECORDS BYTE LENGTH.
S:INPUTR DATA     0                 HOLD RETURN ADDR
S:IN     RES      0
         STW,11   S:INPUTR
         MTW,0    INSERTSW          ARE WE IN AN INSERT OWN CODE LOOP
         BEZ      S:INPUTA          NO
         LW,7     S:INPUTU          REC BYTE ADDR FROM DEBLOCKER
         LW,8     S:INPUTU+1        REC BYTE LENGTH FROM DEBLOCKER
         B        S:INPUTE          SKIP DEBLOCKER GO TO OWN CODE
S:INPUTA MTW,0    EOFSW             HAVE WE GOT EOF
         BEZ      %+3               NO
         LI,7     0                 EOF FLAG
         B        *S:INPUTR          EXIT
         LW,5     TCT0              DEBLOCKER INDEX
         LW,4     STV0,5            GET PROPER DEBLOCKER
         BAL,5    *4                EXEC DEBLOCKER
         B        S:INPUTB          WILL BR ON GOOD EXIT FROM DEBLOCKER
         LI,7     0                 BLOCK LENGTH ABN
         B        SC50              ABORT
S:INPUTB RES      0
         MTW,0    BCT0+13            IS SKIPPING DESIRED
         BEZ      S:INPUTD          NO SKIPPING
         MTW,-1   BCT0+13           DECREMENT SKIP COUNT
         BGEZ     S:INPUTA          GET ANOTHER REC, LOOP
S:INPUTD MTW,0    SLICEFL           IF HERE WE HAVE SKIPPED REQ AMT
         BEZ      S:INPUTE          NO SLICING
         MTW,-1   BCT0+12           REDUCE SLICE COUNT
         BGZ      S:INPUTE
         MTW,1    SLICEFL           MAKE SW A 2 FOR EOF
         BAL,15   CI1               SIMULATE EOF
         B        *S:INPUTR           EXIT OUT
S:INPUTE MTW,0    NUSO              IS OWN CODE PRES
         BNEZ     S:INPUTM          YES
         BAL,9    S:INPUTY          CHECK FOR REC LEN ABN
         B        *S:INPUTR          GOOD REC SO EXIT OUT
S:INPUTM RES      0
         STW,7    S:INPUTU           SAVE REC ADDR, INCASE OF INSRT
         STW,8    S:INPUTU+1        SAVE REC LENGTH IN CASE OF INSERT
         XW,7     11                SAVE REC ADDR FOR EXIT OUT
         LCI      15
         STM,1    OCSAV             SAVE GEN REGS
         LW,6     11                PUT REC BYTE ADDR IN 6 FOR USER
         LI,7     S:INPUTF          ACTION RETURN ADDR
         LI,5     0
         STW,5    INSERTSW          CLEAR EACH TIME
         BAL,5    *NUSO             EXEC USER OWN CODE
         LCI      15
         LM,1     OCSAV             RESTORE REGS
         XW,7     11                GET REC ADDR BACK
         B        *S:INPUTR           EXIT NO ACTION REQ
S:INPUTF LB,11    6                 BITS 00-07 HAVE ACTION REQ
         BNEZ     S:INPUTG          00 FOR DELETE
         LCI      15
         LM,1     OCSAV             RESTORE REGS
         MTW,1    BCT0+21           UP DELETE COUNT
         B        S:INPUTA
S:INPUTG RES      0
         CI,11    1
         BNE      S:INPUTH
         BAL,9    S:INPUTX          VALIDATE LEN OF USERS REPL REC
         AND,6    =X'0007FFFF'       MASK TO GET ADDR OF REPL REC
         STW,6    7                 7 MUST HAVE REC ADDR
         B        S:INPUTV            RESTORE REGS AND EXIT
S:INPUTH CI,11    2                 02 FOR INSERT
         BNE      S:INPUTW          ERROR
         MTW,1    INSERTSW          SET ON TO FLAG
         BAL,9    S:INPUTX          VALIDATE USERS INSERT LENGTH
         MTW,1    BCT0+20           ADD 1 TO INSERT COUNT (INPUT)
         AND,6    =X'0007FFFF'           GET INSERT ADDR
         STW,6    7                 7 MUST HAVE ADDR
         B        S:INPUTV          SAVE REG, REST REGS EXIT
*
S:INPUTU DATA     0                 HOLD 7 (ORIG) DUE TO INSERTS
         DATA     0                 HOLD 8 (ORIG) DUE TO INSERTS
S:INPUTV STW,7    OCSAV+6            7 HAS BYTE ADDR
         STW,8    OCSAV+7           8 HAS BYTE LENGTH
         LCI      15
         LM,1     OCSAV             RESTORE REGS
         B        *S:INPUTR         EXIT OUT
S:INPUTW LI,7     9                 ILL ACTION REQ
         B        SC50              ABORT
S:INPUTX XW,5     8                 5 HAS LENGTH FROM OWN CODE
S:INPUTY CW,8     SRTMIN            MIN ACCEPT SIZE (TOP KEY POS)
         BL       S:INPUTZ           LESS SO ABORT
         LW,11    BCT0+23           IN REC LEN MAX AS SPEC
         CW,8     11
         BG       S:INPUTZ          ERROR, BIGGER THAN STATED SIZE
         B        *9
S:INPUTZ LI,7     19                REC LENGTH ABN
         B        SC50              ABORT
         PAGE
*
*  THIS ROUTINE SELECTS THE APPROPRIATE BLOCKER FOR A FILE
*        AND EXECUTES IT.
* AT ENTRY TO S:OUTPUT
* REG 11 IS THE RETURN ADDR
* REG 7 HAS REC BYTE ADDR OR 0 FOR EOF
* REG 8 HAS REC LEN IN BYTES
*                 8=THE RECORDS LENGTH
*  AT EXIT THE REGISTERS ARE SET AS DESCRIBED IN THE EXIT
*        CONDITIONS FOR THE BLOCKERS
*
         PAGE
*
OBR1     DATA     0
*
S:OUT    RES      0
         STW,11   OBR1
         B        %+1               BR TO OUTOWNCD IF PRES
         B        %+1               BR TO SEQ CHK RTN IF PRES
         LW,5     TCT0              GET BLOCKER INDEX
         LW,4     STV0,5            BLOCKER ENTRY POINT
         CI,7     0                 0 MEANS EOF
         BE       *OBR1
         BAL,5    *4                EXEC BLOCKER
         B        *OBR1
         PAGE
* 5 HAS RETURN ADDR
* 7 HAS REC ADDR (BYTE) NO CTL WORDS
OCSEQR   DO1      4
         DATA     0
OCSEQ    LCI      4
         STM,5    OCSEQR
         CI,7     0                 0 FOR EOF
         BE       *5                NO NEED TO SEQ
         STW,7    10                SAVE ADDR
         LW,5     BCT0+2            0 FOR 1ST TIME
         BNEZ     OCSEQ4
OCSEQ2   RES      0
         AND,10   =X'FFFFF'         REC BYTE ADDR (NO CTL WDS)
         AI,10    -8                BACK TO CTL WD
         SLS,10   -2                TO WORDS
         LW,12    *10               GET CTL WD
         SLS,10   2                   TO BYTES
         AND,12   =X'FFFF'          GET BYTE REC LEN (FULL SIZE)
         AI,10    8                 BACK PAST CTL WDS
         AI,12    -8                NO CTL WORDS
         MTW,0    OWNCDLEN          FROM OWN CD
         BEZ      OCSEQ3            NOT FROM OWN CD
         LI,12    0                 SET OFFF
         STW,12   OWNCDLEN
         LW,12    OCSEQR+3          R8 HAS LENGTH FROM USER
         AND,12   =X'3FFF'            JUST TAKE LENGTH
OCSEQ3   RES      0
         LW,11    SEQRCD            HOLD AREA FOR PREV REC
         AI,11    8                 STORE ACTUAL REC 2 WORDS IN
         CW,12    OCSEQR+3          LEN FROM USER OR P3
         BLE      %+2
         LW,12    OCSEQR+3          PREVENT OVERLAY OF BUFFER
         BAL,9    RWMOV
         LCI      4
         LM,5     OCSEQR
         B        *5                 EXIT
* NOT 1ST TIME, WILL COMP THEN STORE SEQRCD FOR NEXT
OCSEQ4   LW,4     SEQRCD            HOLD AREA FOR PREV REC
         LW,5     7                 CURR REC ADDR BYTE
         AND,5    =X'FFFFF'             STRIP ACTION CODE IF ANY
         SLS,4    -2
         AI,5     -8                ADJ NEW REC ADDR BY 2 PSEUDO CTLWRDS
         SLS,5    -2
         LW,9     STOPCOMP           GET B *9 INST
         XW,9     *COMPSTOP         PUT IN COMP SEQUENCE TO END
         STW,9    STOPCOMP          SAVE INST OF COMP/SEQN FOR RESTORE
         BAL,9    COMPR              COMP REC ON KEYS
         BL       MSEQ3             SEQ ERROR ABORT
         LW,9     STOPCOMP          GET 1ST INSTR OF LAST COMP SEQN
         XW,9     *COMPSTOP           RESTORE COMP/SEQN
         STW,9    STOPCOMP          SAVE B *9 FOR NEXT TIME THRU
         LW,10    OCSEQR+2          GET SAVED R7, REC ADDR
         B        OCSEQ2
MSEQ3    LW,12    OCSEQR+2
         AND,12   =X'FFFFF'         JUST BYTE ADDR
         LI,7     0
         BAL,15   CO1               CLOSE OUT FILE
         AI,4     2
         LW,5     SEQLNG            LENGTH
         SLS,5    -2
         AW,5     4
         AI,5     -3
         M:SNAP   'SEQ REC1',(*4,*5)
         MTW,0    OWNCDLEN          ARE WE FROM OWN CD
         BEZ      MSEQ31              NO
         LW,5     OCSEQR+3          R8 HAS LEN FROM USER
         B        MSEQ32
MSEQ31   RES      0
         LW,5     12                REC BYTE ADDR
         AI,5     -8                BACK TO CTL WD
         SLS,5    -2                TO WORDS
         LW,5     *5                 GET CTL WD
         SLS,5    2                 TO BYTES
         AND,5    =X'FFFF'          GET LENGTH
MSEQ32   RES      0
         SLS,5    -2
         AI,5     -3
         SLS,12   -2
         LW,4     12
         AW,5     12
         M:SNAP   'SEQ REC2',(*4,*5)
         LI,7     15
         B        SC50              SEQ ERROR ABORT
         PAGE
* THIS ROUTINE PROCESSES USER OUTPUT OWN CODE REQUESTS.
* AT ENTRY AND EXIT THE FOLLOWING CONDITIONS EXIST:
* 5 HAS RETURN ADDR, 7 RECORDS BYTE ADDR, 8 HAS RECORDS LENGTH IN BYTES.
* A RETURN VIA 5 LEAVES THIS ROUTINE AND GOES TO S:OUTPUT CONTROLLER.
* A RETURN 7 STAYS HERE TO PROCESS ACTION REQUESTS, WHICH EVENTUALLY
* EXITS VIA 5. AT EOF 7 HAS A 0 AND THE USER IS NOTIFIED BY 6 = 0.
OUTOWNCD LCI      15
         STM,1    OCSAV1            SAVE REGS
OUT0     LW,6     7                 REC ADDR (BYTE)
         CI,7     0                  0 FOR EOF
         BE       OUT5              PROCESS EOF OWN CODE
         LI,7     OUT1              ACTION RETURN
         BAL,5    *OSO                EXECUTE OWN CODE
         LCI      15
         LM,1     OCSAV1            RESTORE REGS
         B        *5                NORMAL EXIT TO S:OUTPUT CONTROLLER
*  THIS AREA PROCESSES USER ACTION REQUESTS
OUT1     MTB,0    6                  TEST FOR 00 DELETE
         BNEZ     OUT2              NOT A DELETE
         MTW,1    BCT0+22           UP OUT DELETE COUNT
         MTW,-1   BCT0+2            REDUCE OUT COUNT,DUE TO UNCOND ADD
         LCI      15
         LM,1     OCSAV1            RESTORE REGS
         B        *OBR1             RETURN TO EXIT FROM CONTROLLER
OUT2     LB,7     6
         AND,5    =X'3FFF'          JUST WANT LENGTH
         CI,7     1                 01 FOR REPLACE
         BNE      OUT3              NOT A REPLACE
         LW,7     6                 BYTE ADDR OF REPLACE REC
         LI,1     1                  INDEX
         LH,8     BCT0+24,1           OUT LOG REC LEN IN WORDS
         SLS,8    2                  TO BYTES
         CW,8     5                 COMP TO USERS GIVEN LENGTH
         BLE      %+2               USER EXCEEDS, USE SORTS
         LW,8     5                  USE USERS
         LCI      6
         LM,1     OCSAV1            RESTORE REG 1-6
         LCI      7
         LM,9     OCSAV1+8          RESTORE REG 9-15
         MTW,1    OWNCDLEN          SET ON TO FLAG SEQ CHK
         B        *5                TO S:OUTPUT CONTROLLER
OUT3     LB,7     6
         AND,5    =X'3FFF'          JUST WANT LEN
         CI,7     2                 02 FOR INSERT
         BNE      OUT4               NOT INSERT: ERROR ILL ACTION REQ
         LW,7     6                 INSERT BYTE ADDR
         LI,1     1                 INDEX
         LH,8     BCT0+24,1          OUT LOG REC LEN IN WORDS
         SLS,8    2                 TO BYTES
         CW,8     5                 COMP TO USERS LOG REC LEN
         BLE      %+2               USER EXCEEDS, USE SORTS
         LW,8     5                 GET USERS LENGTH
         MTW,1    OWNCDLEN          LET SEQ CHK KNOW
OUTSEQK  B        %+1               SEQ CHK HOOK, IF SPECIFIED
         LW,5     TCT0              GET BLOCKER INDEX
         LW,4     STV0,5            BLOCKER ENTRY POINT
         BAL,5    *4                BLOCK INSERT
         MTW,1    BCT0+31           UP OUT INSERT COUNT
         MTW,1    BCT0+2            UP OUT COUNT
         LCI      15
         LM,1     OCSAV1            REST REG FOR USER AGAIN
         B        OUT0              RECYCLE THRU LOOP
OUT4     LI,7     9                 ERROR INDEX
         B        SC50              ABORT
OUT5     LI,7     OUT3              AT EOF INSERTS, OMLY ALLOWED
         BAL,5    *OSO              EXEC OWN CODE 6=0 TELLS USER EOF
         LCI      15
         LM,1     OCSAV1            RESTORE REGS
         B        *5                RETURN TO S:OUTPUT CONTROLLER
         PAGE
*
*  RECORDS ARE WRITTEN IN UNBLOCKED FORMAT-CURRENT BUFFER IS
*        ASSUMED TO BE AVAILABLE.
*
UBB1     MTW,0    ANSISWOU
         BEZ      UBB2              NOT ANSI
         LW,10    BLKCTLSY
         BEZ      UBB2              NO OUT-BLK-CTL-WORDS
         MTW,0    FIRSTSW
         BNEZ     UBB1A             NOT FIRST TIME THRU
         MTW,1    FIRSTSW           SET OFF
         LW,4     BCT0+15           GET BEGIN OF BUF 1
         STW,4    BUFSAV            SAVE FOR BLK-CTL-MOVE
UBB1A    AW,10    8                 10 HAS TOTAL BLK-SIZE (BYTE)
         STW,10   LENCTL1
         LW,13    BLKCTLSY
         AWM,13   BFSIZE1           SAVE FOR WRITE LENGTH
         BAL,13   MBLKWRD           MOVE BLK-LEN CTL WORD TO BUFF
         LW,11    BLKCTLSY          SOURCE RECORD ADDR
         AW,11    BCT0+26           UPDATE DEST BY BLK-CTL-SIZE
UBB2     LW,10    7                 SOURCE BYTE ADDR (REC)
         LW,11    BCT0+26           DEST
         LW,R12   R8                LENGTH
         AWM,8    BCT0+26                SET LIMIT FOR WRITE
         AWM,8    BFSIZE1           SAVE FOR WRITE LENGTH
         BAL,R9   RWMOV             GO MOVE RECORD
         BAL,X4   PW1               GO WRITE RECORD
         LI,4     0
         STW,4    BFSIZE1
         LW,4     BCT0+26           BUF ADDR FOR NEXT WRITE
         STW,4    BUFSAV            FOR NEXT MOVE OF BLK-CTL-SIZE
         B        *X5               EXIT:  NORMAL OR ERROR
*
         PAGE
*
* RECORDS ARE WRITTEN IN FIXED BLOCKED FORMAT
*        FIXED OR OF VARIABLE LENGTH.
*
BFVB1    LW,12    8                 SET LENGTH FOR MOVE CNT
         LW,R10   X7                SOURCE
         AW,8     BCT0+26            CURR ADDR PLUS LENGTH
         LW,4     OUTBUF             ARE WE IN BUF 1 OR 2
         CI,4     1
         BNE      BFVB1A
         CW,8     BCT0+16           BEGIN OF BUF 2
         BLE      BFVB2              OK WERE IN BUF 1
         B        BFVB1B            OVER TOP BUF 1 SO WRITE
BFVB1A   LH,4     BCT0+30,1             BUF LEN IN WORDS
         SLS,4    2                 TO BYTES
         AW,4     BCT0+16           BEGIN OF BUF 2
         CW,8     4
         BLE      BFVB2             OK, WITHIN BUF 2 SO NO WRITE
BFVB1B   LW,8     12                 RESET REC LEN AND WRITE
         BAL,4    PW1               PHY WRITE
         LI,4     0
         STW,4    BFSIZE1           CLEAR FOR NEXT ACCUM
         LW,R12   R8                SET LENGTH FOR MOVE
         LW,R10   X7                SET SOURCE FOR MOVE
         AW,8     BCT0+26           UPDATE CURR REC ADDR
BFVB2    LW,11    BCT0+26           DEST
         STW,8    BCT0+26           UPDATE CURR REC ADDR
         AWM,12   BFSIZE1          UPDATE BUFFER SIZE
         BAL,9    RWMOV             MOVE IT
         B        *X5               EXIT:  NORMAL OR ERROR
*
         PAGE
*
*  RECORDS ARE IN UNBLOCKED FORMAT AND BEING READ IN A FORWARD
*
UBDN1    MTW,0    FIT7+4            DO WE READ
         BEZ      UBDN2              NO
         MTW,-1   FIT7+4               SET OFF
         BAL,4    PR1               GO READ NEXT BLK AND CHK THIS BLK
UBDN2    LW,8     FIT7+2            GET LEN OF LAST BLOCK
         LW,7     INBUF
         CI,7     1                 WHAT BUF IS CURRENT
         BNE      UBDN3
         LW,7     FIT7              BUF 1 WORD ADDR
         B        UBDN4
UBDN3    LW,7     FIT7+1            BUF 2 WORD ADDR
UBDN4    SLS,7    2                 TO BYTES
         MTW,1    FIT7+4             SET TO READ NEXT BLK
         B        *5                EXIT
*
         PAGE
*
*  RECORDS ARE IN BLOCKED FORMAT.  THEY ARE ASSUMED TO BE FIXED
*        LENGTH AND ARE READ IN A FORWARD DIRECTION
*
BFDN1    MTW,0    FIT7+4            IS A READ NECESSARY
         BEZ      BFDN2             NO
         MTW,-1   FIT7+4            SET OFF
         BAL,4    PR1               READ NXT BLK AND CHK THIS BLK
BFDN2    LW,7     INBUF             WHAT BUF IS VALID
         CI,7     1
         BNE      BFDN3
         LW,7     FIT7              BUF 1 WORD ADDR
         B        BFDN4
BFDN3    LW,7     FIT7+1             BUF 2 WORD BASE ADDR
BFDN4    SLS,7    2                 TO BYTES
         AW,7     FIT7+3             COMP CURR REC BYTE ADDR
         LW,4     FIT7+3            DISPL BYTE WITHIN BLOCK
         AW,4     BCT0+23           UP DISPL BY REC SIZE
         STW,4    FIT7+3            SAVE FOR NEXT TIME
         LW,8     BCT0+23           REC BYTE LENGTH
         LW,4     FIT7+2            REM BYTE LEN OF CURR BLK
         SW,4     BCT0+23           REC BYTE LENGTH
         BGZ      BFDN5             WITHIN LIMITS
         BEZ      BFDN6             HAVE EHAUSTED BLOCK
         AI,5     1                 ERROR BLOCK LEN ABN
         B        *5                ABORT
BFDN5    STW,4    FIT7+2            SAVE FOR NEXT TIME
         B        *5                EXIT 8=LEN,7=ADDR
BFDN6    LI,4     0
         STW,4    FIT7+3            SET DISPL WITHIN BLK TO ZERO
         MTW,1    FIT7+4            SET TO READ NEXT TIME
         B        *5                EXIT 8=LEN,7=ADDR
         PAGE
*
*
* RECORDS ARE READ IN BLOCKED VAR FORWARD FORMAT ANSI-TYPE-V
*
*
BVDVN1   MTW,0    FIT7+4             IS A READ DUE
         BEZ      BVDVN2              NO
         MTW,-1   FIT7+4            SET OFF SW
         BAL,4    PR1               CHK LAST READ AND GET NXT BLK
BVDVN2   MTW,0    FIT7+3            IS THIS FIRST REC OF BLK
         BNEZ     BVDVN3             NO
         LW,7     BLKCTLSZ          LEN (BYTE) OF BLK CTL WORD/S
         STW,7    FIT7+3            UP TO BEGIN OF 1 REC
         LW,7     FIT7+2            LEN OF CURR BLK
         SW,7     BLKCTLSZ          REDUCE BY SIZE OF BLK-CTL WORD/S
         STW,7    FIT7+2            RESET
BVDVN3   LW,7     INBUF             CURR VALID BUFF
         CI,7     1
         BNE      BVDVN4
         LW,7     FIT7               BUF 1 BASE ADDR (WORD)
         B        BVDVN5
BVDVN4   LW,7     FIT7+1            BUF 2 BASE ADDR (WORD)
BVDVN5   SLS,7    2                 TO BYTES
         LW,4     7
         AW,4     FIT7+3            NOW TO BEG OF REC-CTL WORD OF REC
         STW,5    SAVE5             HOLD
         SAD,4    -2                BITS TO R5
         SCS,5    2                 R JUST BITS IN 5
         AND,5    =X'03'            MASK OUT REST IF ANY
         LB,8     *4,5              4 IS WORD ADDR, 5 HAS BYTE INDEX
         SLS,8    8
         STW,8    SAVEIT            HOLD LEFT BYTE OF HALFWRD LENGTH
         AI,5     1                 UP INDEX
         LB,8     *4,5              GET RIGHT BYTE OF HALFWRD LEN
         AW,8     SAVEIT             RECONSTRUCT LENGTH
         LW,5     SAVE5             RESTORE
         AW,7     FIT7+3            COMP BEGIN ADDR OF REC
         LW,4     FIT7+3             BYTE DISPL WITHIN BLK
         AW,4     8                 8 HAS PICKED LEN FROM CTL WORD
         STW,4    FIT7+3            POINT TO NEXT REC CTL WORD
         LW,4     FIT7+2            REM BYTE LEN OF CURR BLK
         SW,4     8                 REDUCE BY LENGTHBOF THIS REC
         BGZ      BVDVN6             STILL WITHIN LIMITS
         BEZ      BVDVN8             HAVE NOW EXHAUSTED BLOCK
         AI,5     1                 ERROR BLK LEN ABN
         B        *5                ABORT
BVDVN6   STW,4    FIT7+2            SAVE NEW REMAINDER
BVDVN7   AI,8     -4                REDUCE LEN BY REC CTL WORD SIZE
         AI,7     4                 UP ADDR PAST THE CTL WORD
         B        *5                NORMAL EXIT
BVDVN8   LI,4     0
         STW,4    FIT7+3            SET DISPL WITHIN BLK TO ZERO
         MTW,1    FIT7+4            SET TO READ NEXT TIME THRU
         B        BVDVN7            SET 7 AND 8 AND EXIT
         PAGE
* THIS DEBLOCKER HANDLES MANAGE RECORDS
MFDN1    RES      0
         MTW,0    FIRSTSW           IS IT FIRST TIME
         BEZ      MFDN15             NO
         MTW,1    FIRSTSW           SET OFF TO ZERO
         B        MFDN21            TREAT AS IF A READ WAS NESS
MFDN15   RES      0
         MTW,0    FIT7+4            IS A READ NESS
         BEZ      MFDN5             NO
         MTW,-1   FIT7+4            SET OFF
MFDN2    BAL,4    PR1               CHK LAST BLK READ NEXT ONE
MFDN21   RES      0
         LW,7     INBUF             WHAT BUF IS VALID
         CI,7     1
         BNE      MFDN3
         LW,7     FIT7              BUF 1 BASE ADDR
         B        MFDN4
MFDN3    LW,7     FIT7+1               BUF 2 BASE ADDR
MFDN4    STW,7    4
         SLS,7    2                 TO BYTES
         STW,7    MFDN8             SAVE FOR LATER
         AW,4     FMAN              MANG WORD DISPL INTO BUFFER
         LI,8     X'FFFF'            MASK
         AND,8    0,4               PICK UP DISPL OF THE REC
         BEZ      MFDN2              READ ANOTHER BLK
         SLS,8    2                  DISPL TO BYTES
         AW,8     7                 ADD BASE TO GET CURR REC ADDR
         STW,8    FIT7+5              STORE AS MANAGE CURR REC ADDR
MFDN5    LW,8     FIT7+5            GET CURR REC ADDR
         LW,7     FIT7+5            GET CURR REC ADDR
         SLS,8    -2                  TO WORDS
         LH,4     *8                4 HAS DISPL TO NEXT REC
         AND,4    =X'FFFF'          MASK
         BNEZ     MFDN6             NOT ZERO SO MORE RECS
         MTW,1    FIT7+4            SET ON TO FLAG READ NXT TIME
         B        MFDN7
MFDN6    SLS,4    2                 TO BYTES
         AW,4     MFDN8             ADD SAVED BASE
         STW,4    FIT7+5              UPDATE
MFDN7    LW,8     BCT0+23           BYTE LEN OF REC
         B        *5                  EXIT
MFDN8    DATA,4   0                 HOLD BASE OF BUFFER
         PAGE
*
*
* THIS BLOCKER BLOCKS VARIABLE BLOCKED RECORDS ANSI TYPE V
*
BVBV     MTW,0    FIRSTSW            FIRST TIME THRU ?
         BNEZ     BVBV0              NO
         MTW,1    FIRSTSW           SET OFF
         LW,4     BCT0+15           USE BUF 1  1ST TIME
         STW,4    BUFSAV            BEGIN BUF ADDR
         LW,4     BLKCTLSY           LEN OF BLK-CTL-WORD/S
         AWM,4    BCT0+26           UPDATE CURR REC ADDR
         STW,4    LENCTL1
BVBV0    LW,12    8                  RECORD LENGTH
         AI,12    4                  PLUS 4 BYTES FOR REC-CTL-WORD
         AW,12    BCT0+26           CURR REC ADDR
         LW,13    OUTBUF            ARE WE IN BUF 1 OR 2
         CI,13    1
         BNE      BVBV01            NOT IN BUF 1
         CW,12    BCT0+16               BEGIN OF BUF 2
         BLE      BVBV1             OK, WE ARE STILL IN BUF 1
         B        BVBV02            OVER TOP OF BUF 1,SO WRITE
BVBV01   LH,13    BCT0+30,1           BUF LEN IN WORDS
         SLS,13   2                 TO BYTES
         AW,13    BCT0+16           BEG ADDR OF BUF 2
         CW,12    13                13 HAS TOP ADDR OF BUF 2
         BLE      BVBV1             OK, STILL IN BUF 2
BVBV02   LW,13    LENCTL1
         STW,13   BFSIZE1           LENGTH FOR WRITE
         BAL,13   MBLKWRD           MOVE BLK-LEN CTL WORD TO BUFF
         BAL,4    PW1               PHYSICAL WRITE
         LI,4     0
         STW,4    BFSIZE1
         LW,4     BCT0+26            BEGIN OF BUF BEING BUILT
         STW,4    BUFSAV            SAVE FOR NXT BLK-LEN-CTL-WRD MOVE
         LW,12    BLKCTLSY          LEN (BYTE) OF BLK-CTL-WORD/S
         STW,12   LENCTL1           STORE IN BLK-LEN-COUNTER
         AWM,12   BCT0+26           UPDATE TO BYPASS BLK-CTL-WORD(S)
BVBV1    LW,12    LENCTL1           BLOCK SIZE WORD
         AI,12    4                 UP 4 BYTES FOR RECORD LENGTH WORD
         AW,12    8                 ADD ALSO REC LENGTH
         STW,12   LENCTL1           PUT BACK
         LI,12    4                  LENGTH OF REC-LEN-WORD
         AW,12    8                 REC LENGTH
         SLS,12   +16               LEFT HALF OF WORD
         STW,12   LENCTL2           COUNTER FOR REC LENGTH
         LI,10    BA(LENCTL2)       ADDR OF REC LEN COUNTER
         LW,11    BCT0+26             BYTE ADDR IN BUF OF CTL WRD
         LI,12    4                 4 BYTE LENGTH
         BAL,9    RWMOV             MOVE IT
         LW,12    BCT0+26           BYTE ADDR
         AI,12    4                 UP FOR REC JUST MOVED (REC-LEN)
         STW,12   BCT0+26           NOW HAS BEGIN ADDR OF REC ITSELF
         LW,12    8                 REC LENGTH
         LW,11    BCT0+26           DEST ADDR IN BUF OF THE REC
         LW,10    7                 SOURCE ADDR (BYTE)
         AW,8     11                ADD ADDR (DEST) TO LENGTH
         STW,8    BCT0+26           UPDATE FOR NEXT REC ADDR
         BAL,9    RWMOV             MOVE REC TO BUFFER
         B        *5                EXIT
         PAGE
*
*  AT ENTRY TO PR1:
*
*        REGISTER 4=THE RETURN ADDRESS
*                 5=THE RETURN ADDRESS FOR THE DEBLOCKER
*
*    ENVIRONMENTAL CONDITIONS ARE IDENTICAL TO THOSE LISTED FOR
*                 THE BLOCKERS AND THE DEBLOCKERS.
*
*
         PAGE
PR1      BAL,9    OCHKA             CHECK LAST READ
         BAL,9    ZEROIT            CLEAR SAVED 8.9,10
         MTW,0    EOFSW              HAVE WE SET EOF ON
         BNEZ     S:INPUTA+2        YES
         LW,9     INBUF             * IF HERE LAST READ WAS GOOD
         CI,9     1
         BNE      PR2
         LI,9     2
         STW,9    INBUF             SET TO 2
         LW,9     FIT7
         STW,9    BFLOC              SET TO BUF 1 FOR NEXT READ
         B        PR3
PR2      LI,9     1
         STW,9    INBUF
         LW,9     FIT7+1
         STW,9    BFLOC             SET BUF 2 FOR NEXT READ
PR3      LH,9     BCT0+30              IN BUF SIZE
         AND,9    =X'FFFF'
         SLS,9    2                 TO BYTES
         STW,9    BFSIZE
         BAL,9    PR9               GET ARS OF LAST VALID BLOCK
         BAL,9    ORDF              READ NEXT BLOCK
         B        *4                EXIT TO DEBLOCKER
*
PR9      LI,1     8                   SET INDEX
         LH,8     *SORTSD,1            GET ARS
         AND,8    =X'FFFF'
         SLS,8    -1
         STW,8    FIT7+2             SAVE SIZE READ FOR DEBLOCKER
         LI,1     1                 RESET SACRED INDEX
         B        *9                 EXIT
         PAGE
* THIS RTN DOES THE PHYSICAL WRITE OF OUTPUT FILES
PW1      LW,9     OUTBUF            WHAT BUFFER
         CI,9     1
         BNE      PW1AA
         LI,9     2                 SET TO BUF 2
         STW,9    OUTBUF
         B        PW1AB
PW1AA    LI,9     1                 SET TO BUF 1
         STW,9    OUTBUF
PW1AB    RES      0
         LW,10    ABNSAVE+2          EXAMINE R10
         BEZ      PW1AC             NO ABN
         LI,8     PW1B              SET UP RETURN ADDR
         B        RDABN              PROCESS ABN
PW1AC    RES      0
         LW,10    ERRSAVE+2         EXAMINE R10
         BEZ      PW1AD             NO ERR
         LI,8     PW1B              SET UP RETURN ADDR
         B        RDERR             PROCESS ERR
PW1AD    RES      0
         LW,9     SORTSD             DCB WORD ADDR
         AI,9     7                  POINT TO WORD 7
         LB,11    *9                 SEE BITS 00-07
         CI,11    0                  0 MEANS NO OUTSTANDING IO
         BNE      PW1A               NOT COMPL SO DO CHECK
         AI,9     -5                SEE WORD 2
         LB,11    *9,1               BITS 8-14 TYC
         AND,11   =X'00FE'          MASK ALL BUT TYC
         CI,11    2                 00-02 NORMAL TYC
         BLE      PW1B              NORMAL TYC SO DONT CHECK
PW1A     BAL,9    OCHK               CHECK LAST IO
PW1B     LW,9     BCT0+26           CUR TOP BYTE ADDR OF LAST REC
         CW,9     BCT0+16             BUF 2 BYTE ADDR BEGIN
         BLE      PW1C
         LW,9     BCT0+16            WE ARE CURRENTLY IN BUF 2
         STW,9    BFLOC             SO LOAD BUF 2 BASE ADDR
         LW,9     BCT0+15            LOAD BUF 1 BASE ADDR TO BCT0+26
         STW,9    BCT0+26           FOR NEXT BLOCK TO BE BUILT
         B        PW1D
PW1C     LW,9     BCT0+15             WE ARE CUR IN BUF 1
         STW,9    BFLOC
         LW,9     BCT0+16           LOAD BUF 2 BASE ADDR
         STW,9    BCT0+26            FOR NEXT BLOCK TO BE BUILT
PW1D     LW,9     BFSIZE1
         STW,9    BFSIZE
PW1E     RES      0
         BAL,9    ZEROIT            CLEAR SAVED 8.9,10
         BAL,9    OWRT               PHY WRITE
         B        *4                EXIT TO BLOCKER
         PAGE
*
*  ALL MONITOR COMMUNICATION FROM PR1 IS DONE THROUGH THESE CALLS
*
*
*  ALL MONITOR I/O FROM IN1,OU1,AND OS1 IS PERFORMED THROUGH
*        THESE FUNCTION CALLS
*
SPECRD   LCI      3
         STM,R8   ACTSAV
         M:READ   M:SI,(BUF,*WORK),(SIZE,80),(ABN,SPECRD2)
SPECRD1  RES      0
         LCI      3
         LM,R8    ACTSAV
         B        *R9
SPECRD2  RES      0
         LB,8     10               GET ERROR CODE
         CI,8     5                IS IT EOD
         BE       SPECRD3          YES.
         CI,8     6                IS IT EOF
         BNE      RDABN            NO.
SPECRD3  RES      0
         LW,8     =C'!EOD'          BANG EOD FOR SSP11 TO TEST
         STW,8    *WORK            SET EOD INTO RECORD AREA
         B        SPECRD1          EXIT
*
*
ORDF     MTW,0    INSERTSW           TEST IF INSERT
         BNEZ     ORD1                                     /SIG7-1883/*D4985
         M:READ   *SORTSD,(BUF,*BFLOC),(SIZE,*BFSIZE)
ORD1     B        *9                EXIT
*
OWRT1C   RES      0
         BAL,10   BATWD
         M:WRITE  *SORTSD,(BUF,*BFLOC),(SIZE,*BFSIZE),(ERR,WTERR),;
                  (ABN,WTABN)
         LCI      4
         LM,7     ACTSAV
         B        *9
*
OWRT     BAL,R10  BATWD
         M:WRITE  *SORTSD,(BUF,*BFLOC),(SIZE,*BFSIZE)
         LCI      4
         LM,7     ACTSAV             RESTORE REGS
         B        *9                RETURN
OWRTLBL  RES      0
         LCI      4
         STM,7    ACTSAV
         M:WRITE  *SORTSD,(ERR,WTERR),(ABN,WTABN),(SIZE,*BFSIZE),;
                  (BUF,*BFLOC),(BTD,1)
         LCI      4
         LM,7     ACTSAV
         B        *9
OCHKA    RES      0
         LW,10    ABNSAVE+2         SEE R10
         BEZ      OCHKB              NO ABN
         LW,8     9                   SET UP RETURN ADDR
         B        RDABN             PROCESS ABN
OCHKB    RES      0
         LW,10    ERRSAVE+2         SEE R10
         BEZ      OCHKC             NO ERR
         LW,8     9                  RETURN ADDR
         B        RDERR             PROCESS ERR
OCHKC    RES      0
         LI,10    F:SORTIN          INPUT DCB WORD ADDR
         AI,10    7                 TO WORD 7
         LB,11    *10                SEE BITS 00-07 WORD 7
         CI,11    0                 LAST IO COMPL = 0
         BNE      OCHK              NO, SO CHECK WILL FORCE WAIT
         AI,10    -5                SET DCB ADDR TO WORD 2
         LH,11    *10                BITS 8-14 WORD 2 TYC
         AND,11   =X'00FE'          MASK ALL BUT TYC
         CI,11    2                 00-02 NORMAL TYC
         BLE      *9                NORMAL SO BYPASS CHECK
OCHK     LCI      4
         STM,X7   DACTSAV           SAVE REGS              /SIG7-0735/*C4985
,OCH     M:CHECK  *SORTSD,(ABN,RDABN),(ERR,RDERR)          WAIT  SIG7-2127
         LCI      4
         LM,X7    DACTSAV           RESTORE REGS           /SIG7-0735/*C4985
         B        *R9               RETURN
*
OWFM     LCI      4                 WRITE A  FILE MARK
         STM,X7   CACTSAV
         M:WEOF   *SORTSD
OWF1     LCI      4
         LM,X7    CACTSAV
         B        *R9
*
OCVL     LCI      4                 CLOSE A VOLUME
         STM,X7   CACTSAV
         M:CVOL   *SORTSD
         B        OWF1
*
*
*
*
OPRNT    LCI      4
         STM,7    ACTSAV
         SLS,RF   -2
         STW,RF   OPN+2
         STB,R9   *OPN+2
,OPN     M:PRINT  (MESS,SKBB)
         LCI      4
         LM,7     ACTSAV
         B        *R10
*
ZEROITR  DATA     0                 HOLD RETURN ADDR
ZEROIT   RES      0
         STW,9    ZEROITR            SAVE RETURN
         LI,9     0
         STW,9    ABNSAVE
         STW,9    ABNSAVE+1
         STW,9    ABNSAVE+2
         STW,9    ERRSAVE
         STW,9    ERRSAVE+1
         STW,9    ERRSAVE+2
         B        *ZEROITR
*
ZERORTRN DATA     0                 RETURN ADDR
ZEROINTR RES      0
         STW,9    ZERORTRN          SAVE RTN ADDR
         LI,9     0
         STW,9    ABNINTER
         STW,9    ABNINTER+1
         STW,9    ABNINTER+2
         STW,9    ERRINTER
         STW,9    ERRINTER+1
         STW,9    ERRINTER+2
         B        *ZERORTRN
*        8 HAS RETURN ADDR IF ERR OR ABN
*        9     HAS RETURN ADDR IF NO ERROR OR ABN IN DCB
*        10      HAS DCB WORD ADDR
EXAMEN   RES      0
         STW,9    EXAMEN9             SAVE RETURN ADDR
         STW,10   EXAMEN10          SAVE DCB WORD ADDR
         LW,10    ABNINTER+2        * ANY ABN IN DCB
         BEZ      EXAMEN1           * NO
         AND,10   EXAMEN10          * SEE IF IT WAS FOR THIS DCB
         CW,10    EXAMEN10
         BNE      EXAMEN1           NO
         LW,10    ABNINTER+2        RESTORE ABN R 10
         BAL,9    ZEROINTR           CLEAR INTER
         B        RDABN
EXAMEN1  RES      0
         LW,10    ERRINTER+2        ANY ERRORS IN DCB ADDR
         BEZ      EXAMEN2             NO
         AND,10   EXAMEN10           * SEE IF FOR THIS DCB
         CW,10    EXAMEN10
         BNE      EXAMEN2           NO
         LW,10    ERRINTER+2         PUT ERR CD IN R10
         BAL,9    ZEROINTR          CLEAR INTER SAVE AREA
         B        RDERR
EXAMEN2  RES      0
         LW,10    EXAMEN10          RESTORE 10
         B        *EXAMEN9          RETURN IN LINE FOR MORE CHKS
*
EXAMEN9  DATA     0
EXAMEN10 DATA     0
         PAGE
EXTWT    RES      0
         STW,15   EXTWT90           SAVE RETURN ADDR
         LW,15    FIT4,6            CURR GRAN TOTAL
         STW,15   EXTDCB94          SAVE FOR EXTDCB10
         BAL,15   EXTDCB10          SET UP IO PARTIALLY
         LW,15    EXTNTBLE,6        GET CORRECT POS INTO TABLE
         STW,15   EXTDCB92          GOT ONE WITH BIT 0=0, USE IT
         MTW,1    EXTRD91            CLOSE AND SAVE
         BAL,15   EXTDCB20          SET REST OF IO AND DO IT
         LW,15    EXTNTBLE,6        GET FILE NAME FOR THIS EXTENT
         OR,15    =X'80000000'      BIT 0 ON SHOWS USED FOR THIS JOB
         STW,15   EXTNTBLE,6
         LW,6     EXTDCB91          RESET 6 WITH ORIG INDEX
         B        *EXTWT90           EXIT OUT
*
EXTWT90  DATA     0                 RETURN ADDR HOLD
*
EXTRD    RES      0
         STW,15   EXTRD90           SAVE RETURN ADDR
         LW,15    FIT4,6            CURR GRAN COUNT TOTAL
         STW,15   EXTDCB94          SAVE FOR EXTDCB10 ROUTINE
         BAL,15   EXTDCB10          SET UP IO PARTIALLY
         AI,6     -1
         LW,15    EXTNTBLE,6        GET PREV POS INTO TABLE 0-19 OF DCB
         AND,15   =X'20000000'      IS BIT 2 ON
         BEZ      %+2               NO SO CLOSE WITH REL
         MTW,1    EXTRD91           SET ON FOR CLOSE SAVE
         AI,6     1                 BACK TO CURR FILE NAME
         LW,15    EXTNTBLE,6        CORRECT FILE NAME TO OPEN
         BLZ      EXTRD1
         LW,6     EXTDCB91          RESET 6 WITH ORIG VALUE
         B        *EXTRD90          LOOK AHEAD, NEVER EXTENDED SO OUT
EXTRD1   RES      0
         STW,15   EXTDCB92          HAVE GOT ONE
         AND,15   =X'C0FFFFFF'       SET OFF BIT 2
         STW,15   EXTNTBLE,6        BACK IN TABLE
         BAL,15   EXTDCB20          SET REST OF IO AND DO IT
         LW,6     EXTDCB91          RESET 6 WITH ORIG INDEX VAL
         B        *EXTRD90          RETURN
*
EXTRD90  DATA     0                 HOLD RETURN ADDR*
*
*
EXTDCB10 RES      0
* THESE ROUTINES SET UP DCB FOR EXTENT IO
         STW,15   EXTDCB90          SAVE RETURN ADDR
         STW,6    EXTDCB91          SAVE INDEX
         LW,15    FIT5,6            DCB ADDR
         STW,15   EXTADDR           DCB ADDR FOR IO
         LH,15    RSTOR,6           ORIG USER SPEC GRAN REQ
         AND,15   =X'FFFF'          MASK SIGN EXT, IF ANY
         STW,15   EXTGRAN           GRANULE REQ FOR IO
         AI,6     -1                REDUCE INDEX
         STW,6    15
         MI,15    21                21 WORDS PER DCB IN EXTNTBLE
         LW,6     15                GET EXTNTBLE INDEX BACK IN 6
         AI,6     1                 GO PAST ORIG FILE NAME POS 00,21,42
         LW,15    EXTDCB94           CURR TOTAL GRAN COUNT
         DW,15    EXTGRAN           FILE SIZE IN GRAN
         MTW,0    EXTOP92           ARE WE FROM EXTOP
         BGZ      EXTDCB11           YES SO SKIP COMPARE
         CI,15    20                0-19 TO BE VALID
         BGE      EXTDCB30          ERROR
EXTDCB11 RES      0
         AW,6     15                ADD REL INDEX TO GET EXACT SPOT
         B        *EXTDCB90         EXIT OUT
*
EXTDCB20 RES      0
         STW,15   EXTDCB90          SAVE RETURN ADDR
         STW,6    EXTDCB93          SAVE EXTNTBLE INDEX VAL
         LW,15    EXTDCB92          NAME SUPPLIED FOR THIS IO
         AND,15   =X'00FFFFFF'         NAME ONLY
         OR,15    =X'03000000'       3 BYTES IN NAME
         LW,6     INXOPEN           COMPUTED SPOT FOR NAME IN OPEN
         STW,15   OPENFPT,6         STORE UNIQUE NAME IN FPT
         MTW,0    CLSLUPSW
         BNEZ     EXTDCB22          SKIP CLOSE
         MTW,0    EXTRD91           1 DO A CLOSE SAVE
         BEZ      EXTDCB21          OFF SO DO A CLOSE REL
         M:CLOSE  *EXTADDR,(SAVE)
         MTW,-1   EXTRD91           SET OFF
         B        EXTDCB22
EXTDCB21 RES      0
         M:CLOSE  *EXTADDR,(REL)
EXTDCB22 RES      0
,OPENFPT M:OPEN   *EXTADDR,(RANDOM),(OUTIN),(SAVE),;
                  (DIRECT),;
                  (RSTORE,*EXTGRAN),(ERR,RDERR),(ABN,RDABN),(FILE,'AAA')
         M:SETDCB *EXTADDR,(ERR,ERRINT),(ABN,ABNINT)
         LW,6     EXTDCB93          TABLE INDEX VAL
         B        *EXTDCB90          RETURN TO CALLER
EXTDCB30 RES      0
         LI,7     10                DISK OVERFLOW ABORT USED ALL EXTES
         B        SC50
*
EXTDCB90 DATA     0                 SAVER RETURN ADDR
*
EXTOP    RES      0
         STW,15   EXTOP90           SAVE RETURN ADDR
         STW,7    EXTOP93           HOLD REG 7 FOR WORK
         STW,6    EXTOP91           SAVE REG 6
         LW,6     ILT2,6            POINT TO PROPER DCB
         LW,15    6                 6 POINTS TO PROPER DCB
         AI,15    -1                IN TABLE DCB1 =0 INDEX GROUP
         MI,15    21                TABLE IN 21 INCR
         AI,15    1                 GO PAST ORIG NAME 00,21,42,63 ECT
         STW,15   7
         LW,15    EXTNTBLE,7        IF BIT 0=1, EXTENT HAS BEEN DONE
         BGZ      EXTOP30           MAY NOT BE FOR THIS IO CYCLE THO
         LW,15    FIT4,6            CURR TOTAL GRAN COUNT FOR DCB
         STW,15   EXTDCB94
         MTW,1    EXTOP92
         BAL,15   EXTDCB10
         MTW,-1   EXTOP92           SET OFF SW
         CI,15    0                  TEST REL POS INTO TABLE
         BE       EXTOP10           USE ORIG FILE NAME
         AI,6     -1                REDUCE INDEX TO GET PROPER NAME
         LW,15    EXTNTBLE,6        GET NAME
         B        EXTOP20
EXTOP10  RES      0
         LW,7     EXTOP91           OLD REG 6
         LW,7     ILT2,7            NOW HAVE DCB IN USE
         AI,7     -1
         MI,7     21                TABLE IN 21 INCR
         LW,15    EXTNTBLE,7        GET ORIG FILE NAME
         STW,7    6
EXTOP20  RES      0
         STW,15   EXTDCB92          PUT FILE NAME HARE
         OR,15    =X'20000000'       SET ON FOR LATER CLOSE SAVE
         STW,15   EXTNTBLE,6         PUT INTO TABLE
         MTW,1    EXTRD91            CLOSE AND SAVE
         BAL,15   EXTDCB20          DO IO
EXTOP30  RES      0
         LW,6     EXTOP91           RESET REG 6
         LW,7     EXTOP93           RESET REG 7
         B        *EXTOP90           EXIT OUT
*
EXTOP90  DATA     0                 SAVED RETURN ADDR
         PAGE
* THIS ROUTINE HANDLES ALL ABNORMAL RETURNS FROM ALL DCBS (READ AND WRITE)
WTABN    RES      0
RDABN    RES      0
         MTW,0    CLSLUPSW          FROM INTER CLOSE
         BNEZ     *8                YES SO IGNORE
         STW,10   ERRCD            SAVE ERROR CODE FOR PRINTING
         STW,8    SAVE8
         LB,9     10               PUT ABN CODE IN 9
         CI,9     X'03'
         BG       RDABN2
         LH,9     10
         AND,9    =X'FFFF'
         CI,9     X'0116'           NOT ENOUGH CONTIG GRAN
         BE       RDERR1A
RDABN1   LI,7     12                01,02,03,08,09,14,40,46,47,44,30
         B        SC50              ABORT
RDABN2   CI,9     X'08'
         BE       RDABN1
         CI,9     X'09'
         BE       RDABN1
         CI,9     X'0A'             CLOSE A CLOSED DCB
         BE       *8                 IGNORE
         CI,9     X'14'
         BE       RDABN1
         CI,9     X'30'
         BE       RDABN1
         CI,9     X'2E'
         BNE      RDABN3
         LI,7     13                2E
         B        SC50              ABORT
RDABN3   CI,9     X'07'
         BNE      RDABN5
RDABN3A  RES      0
         LI,13    F:SORTIN         INPUT DCB ADDRESS
         AND,10   =X'1FFFF'          STRIP OFF ERROR CODES
         CW,13    10               WAS ERROR ON INPUT
         BNE      RDABN4           NOT INPUT DCB
         LW,10    =X'400000'          IS DROP BLK OPTION SPEC
         AND,10   BCT0+28            OPTION FLAG
         BEZ      DROPBLK           YES, SO DROP INPUT BLOCK
RDABN4   LI,7     1                 07
         LW,10    ERRCD             RESET FOR USER TO SEE
         B        SC50              ABORT
RDABN5   CI,9     X'0B'
         BNE      RDABN6
         LI,7     1                 0B
         B        SC50              ABORT
RDABN6   CI,9     X'05'             EOD
         BE       RDABN7
         CI,9     X'06'             EOF
         BE       RDABN7
         B        RDABN8
RDABN7   RES      0
         LW,15    CRSF             IS IT CO-RESIDENT
         BNEZ     *SAVE8
         BAL,15   CI1
         B        *SAVE8
RDABN8   RES      0
         CI,9     X'1C'
         BNE      RDABN4            ABORT IO ERROR
         LW,15    CRSF             IS IT CO-RESIDENT
         BNEZ     *SAVE8
* SINCE SORT HAS ABN ADDR ON CHECK, IT WILL NEVER GET IO 1C
* ON LABELLED TAPE OR ANS TAPE, THEREFORE IF OUTPUT OWN CODE FOR
* USER HEADER AND TRAILERS IS SPECIFIED, FOR LAB TAPE OR ANS TAPE
* A SPECIAL WRITE WITH ERR/ABN WILL BE EXECUTED SO SORT WILL
* WAIT ON 1C TO BE ABLE TO PROCESS USER OWN CODE
         LI,15    F:SORTIN
         AND,10   =X'1FFFF'          STRIP OFF ERROR CODES
         CW,15    10
         BNE      %+2
         B        *SAVE8             LET 05/06 STOP IT
         BAL,15   CO1
         B        *SAVE8
RDABNDCB RES      0
         LCI      3
         STM,8    ABNSAVE
         B        *8
* THIS ROUTINE DROPS BLOCKS FOR IO 07 IO 41
DROPBLK  RES      0
         LI,13    HTBUFIN           BUF ADDR OF HEADER/TRAILER AREA
         CW,13    12
         BE       RDABN4            GOT IT READ OF HDR OR TRLR, SO ABORT
         M:PRINT  (MESS,SKBB)        PRINT DROPPED BLOCK
         LW,13    BFSIZE            GET REQUESTED REC LEN
         LW,9     BFSIZE
         CI,9     133
         BL       %+2
         LI,9     132               SO WILL PRINT IN BLKS OF 132
         LW,14    BFLOC             IN BUF ADDR WORD
         SLS,14   2                 TO BYTES
DROPBLK1 LW,15    14                 RECORDS BYTE ADDR
         AI,13    -132              DECR REC LENGTH
         AI,14    132               INCR REC ADDR
DROPBLK2 BAL,10   OPRNT               PRINT BUF REC
         CI,13    132
         BGE      DROPBLK1              132 CHARA OR MORE TO GO
         CI,13    0
         BLE      DROPBLK3
         LW,9     13
         LI,13    0
         LW,15    14
         B        DROPBLK2
DROPBLK3 B        %                HOOK TO HANDLE PR1 OR IN1 RTNS
*
DRPHOOK1 B        DROPBLK4         REDO READ AND GO TO PR1 TO CHK IT
DRPHOOK2 B        IN9C             DO RD AND CHK IN IN1 THEN NSI PR1
*
DROPBLK4 BAL,9    ORDF             GET ANOTHER BLOCK
         B        PR1              CHECK IT
*
         PAGE
* THIS ROUTINE HANDLES ALL ERROR RETURNS FROM ALL DCBS FOR READS AND
* WRITES, EXCEPT INPUT CLOSE ((CLSERR)
WTERR    RES      0
RDERR    RES      0
         MTW,0    CLSLUPSW          FROM INTER CLOSE
         BNEZ     *8                YES SO IGNORE
         STW,10   ERRCD            SAVE ERROR CODE FOR  PRINTING
         STW,8    SAVE8
         LB,9     10               PUT ERROR CODE IN 9
         CI,9     X'4E'             ONLY FOR ANS WHEN BLK CNT NOT EQUAL
         BNE      RDERR1
         LB,9     10,1
         SLS,9    -1                 SHIFT SUBODE
         CI,9     0                 EOT
         BE       RDABN7
         CI,9     7                 EOF
         BE       RDABN7
         B        *8
RDERR1   CI,9     X'57'
         BNE      RDERR2
         MTW,0    IO57M:DO          HAVE WE BEEN HERE FROM EXITCTL
         BNE      RDERR1A
         MTW,0    IO57M:LL          SEE IF SET
         BNE      RDERR1A
         BAL,8    EXITCTL5          SEE IF M:DO TO A FILE
RDERR1A  LI,7     10
         B        SC50
RDERR2   CI,9     X'41'
         BE       RDABN3A           EITHER DROP OR ABORT
         CI,9     X'46'
         BE       RDABN1            46 ABORT
         CI,9     X'40'
         BE       RDABN1            40 ABORT
         CI,9     X'45'
         BNE      RDERR3
         LI,7     1                  I/O ERROR
         B        SC50               ABORT
RDERR3   CI,9     X'47'
         BE       RDABN1            47 ABORT
         CI,9     X'44'
         BE       RDABN1             44 ABORT
         CI,9     X'42'
         BE       RDERR1A
         CI,9     X'56'
         BNE      RDABN4
         LW,9     SLICEFL
         CI,9     2
         BE       RDERR1A
         B        CI9
RDERRDCB RES      0
         LCI      3
         STM,8    ERRSAVE
         B        *8
*
ERRINT   RES      0
         LCI      3
         STM,8    ERRINTER
         B        *8
*
ABNINT   RES      0
         LCI      3
         STM,8    ABNINTER
         B        *8
         PAGE
*                 RETURN TO R10 (B *R10)
BATWD    LCI      4
         STM,X7   ACTSAV
         LW,R8    BFLOC
         AND,R8   =X'7FFFF'
         LI,R9    X'3'
         LI,X7    0
         STS,R8   X7
         SLS,R8   -2
         STW,R8   BFLOC
         B        *R10
*
         PAGE
*
*  AT ENTRY:
*        REGISTER 10=SOURCE ADDRESS--BYTE
*                 11=DESTINATION ADDRESS--BYTE
*                 12=LENGTH IN BYTES
*                 5-8=NOT USED
*                 9=RETURN ADDRESS
*
RWMOV    CI,R12   256
         BGE      RWM2              GREATER THAN 255
RWM1     STB,R12  R11               LESS OR EQUAL 255
         MBS,R10  0                 MOVE BYTES
         B        *R9               EXIT
*
RWM2     LI,R13   255               SET UP FOR SETTING COUNT
RWM3     STB,R13  R11               SET COUNT
         AI,R12   -255              REDUCE LENGTH
         MBS,R10  0                 MOVE BYTES
         CI,R12   256               IS R12 STILL GREATER THAN 255
         BL       RWM1              NO
         B        RWM3              YES
*
*  AT EXIT:  THE RECORD HAS BEEN MOVED
*
         PAGE
*
*  THIS ROUTINE CONVERTS A FOUR DIGIT BCD NUMBER TO BINARY
*        THE NUMBER TO BE CONVERTED IS IN CNVRT
*        THE CONVERTED NUMBER IS IN CNVRT+1 ON EXIT
*  EBCBN IS ENTERED VIA A BAL,R9   EBCBN
*
*
*
EBCBN    LCI      4
         STM,X7   ACTSAV            SAVE REGISTERS
         LI,X7    0                 BYTE INDEX
         LW,R8    CNVRT             EBCDIC NUMBER
         AND,R8   =X'F0F0F0F'       STRIP
         STW,R8   CNVRT+1
EBCB1    LB,R10   CNVRT+1,X7
         BCS,X3   EBCB2             NON-ZERO
         AI,X7    1
         CI,X7    3
         BCS,X2   EBCB5             EXIT WORD IS ALL ZEROES
         BLE      EBCB1
*
EBCB2    STW,R10  R9                FIRST DIGIT TO ACCUMULATOR
EBCB3    AI,X7    1                 COUNT TIMES THROUGH
         CI,X7    3                 IS DONE
         BCS,X2   EBCB4             YES:  STORE RESULT AND EXIT
         LB,R10   CNVRT+1,X7        NEXT DIGIT
         MI,R9    10                ACCUMULATED DIGITS TIMES TEN
         AW,R9    R10
         B        EBCB3
*
EBCB4    STW,R9   CNVRT+1           STORE BINARY NUMBER
EBCB5    LCI      4
         LM,X7    ACTSAV            RESTORE REGISTERS
         B        *R9               EXIT
*
*
BNEBCR   DATA     0
*
BINEBC   STW,X5   BNEBCR
         LI,X2    7                 BYTE INDEX
         LI,X3    8                 LOOP COUNTER
         LW,RB    CNVRT+1           BINARY NUMBER TO BE CONVERTED
BNEB1    LI,RA    0
         DW,RA    =X'A'
         AI,RA    X'F0'             ADD EBCDIC NUMBER CONSTANT
         STB,RA   CNVRT,X2          STORE REMAINTER AS EBCDIC DIGIT
         AI,X2    -1
         BDR,X3   BNEB1
         LI,RB    X'40'
BNEB2    LB,RA    CNVRT,X3          TEST FOR LEADING ZEROES
         CI,RA    X'F0'
         BCS,X3   *BNEBCR           NO MORE LEADING ZEROES:  EXIT
         STB,RB   CNVRT,X3
         AI,X3    1
         CI,X3    X'7'              DO NOT SUPPRESS LAST ZERO
         BL       BNEB2
         B        *BNEBCR
*
         PAGE
*
*  THESE ROUTINES PERFORM ALGEBRAIC COMPARISONS FOR ASCENDING AND
*       DESCENDING SEQUENCE BINARY KEY WHICH HAVE STARTING POSITIONS
*       OR LENGTHS THAT PRECLUDE THE USE OF SIMPLE HARDWARE SEQUENCES
*
*  ON ENTRY TO THESE ROUTINES:
*        REGISTER:  6=BYTE COUNT
*                   A=SOURCE BYTE DISPLACEMENT RELATIVE TO ADDRESSES
*                     IN REGISTERS 4 AND 5.
*                   4=WORD ADDRESS OF PREDICTED WINNER
*                   5=WORD ADDRESS OF PREDICTED LOSER
*  ON EXIT FROM THESE ROUTINES:
*        REGISTER:  4=WORD ADDRESS OF PREDICTED WINNER
*                   5=WORD ADDRESS OF PREDICTED LOSER
*                   CONDITION CODE 4=1 IF AN EXCHANGE IS NECESSRY
*  EXIT IS MADE TO:  *R0 IF THE RECORDS WERE EQUAL ON THE KEYS
*                    *R1 IF THE RECORDS WERE UNEQUAL ON THE KEYS
*
*                        ASCENDING
BNCMPA   SLD,X4   2                 CONVERT WORD ADDRESS TO BYTE ADDRESS
         LI,X7    X'30'
         LI,RB    X'38'
BNC01    STD,X7   RC                    DOUBLE WORD VALUES
         STD,X7   RE                X'C'+2=
         STB,X6   X7                DESTINATION WORD COMPLETE
         STB,X6   RB                DESTINATION WORD COMPLETE
         LW,X6    X4                SOURCE RECORD ADDRESS
         AW,X6    RA                PLUS BYTE DISPLACEMENT
         AW,RA    X5                BYTE DISPLACEMENT PLUS RECORD ADDRSS
         SLD,X4   -2                RESTORE WORD ADDRESSING IN X4 AND X5
         MBS,X6   0                 MOVE BYTE STRING-WINNER TO RC-RD
         MBS,RA   0                 MOVE BYTE STRING-LOSER TO RE-RF
         CD,RE    RC                COMPARE--WHO REALLY IS WINNER
         BE       *R0               EXIT IF EQUAL
         B        *R1               EXIT IF UNEQUAL
*                        DESCENDING
BNCMPD   SLD,X4   2
         LI,X7    X'38'
         LI,RB    X'30'
         B        BNC01
*
         PAGE
*
*
DECTRP   LI,X7    3                 ILLEG DEC KEY          /SIG7-1162/*C4985
         B        SC50              GO ABORT               /SIG7-1162/*C4985
*
*  THESE ROUTINES PERFORM THE COMPARISONS FOR ZONED AND PACKED
*       DECIMAL KEYS AND FOR ALPHANUMERIC KEYS REQUIRING KEY
*       TRANSLATION.
*
*  ON ENTRY TO THESE ROUTINES:
*        REGISTER:  4=WORD ADDRESS OF THE PREDICTED WINNER
*                   5=WORD ADDRESS OF THE PREDICTED LOSER
*                   6=KEY LENGTH
*                   A=SOURCE BYTE DISPLACEMENT
*
*  ON EXIT FROM THESE ROUTINES:
*        REGISTER:  4=WORD ADDRESS OF THE PREDICTED WINNER
*                   5=WORD ADDRESS OF THE PREDICTED LOSER
*                   CONDITION CODE 4=1 IF AN EXCHANGE IS NECESSARY
*                                   =0 IF AN EXCHANGE IS NOT NECESSARY
*
*  EXIT IS MADE TO:  *R0 IF THE RECORDS WERE EQUAL ON THE KEYS
*                    *R1 IF THE RECORDS WERE UNEQUAL ON THE KEYS
*
FO       DATA,4   X'F0F0F0F0',X'F0F0F0F0',X'F0F0F0F0',X'F0F0F0F0'
DEVSTP   LCI      4
         LM,RC    FO
         STM,RC   ALFTRAN1
         STM,RC   ALFTRAN1+4                               /SIG7-5885/*F4985
         STM,RC   ALFTRAN2+4                               /SIG7-5885/*F4985
         STM,RC   ALFTRAN2
         STW,X1   SAVEREG1         SAVE REGISTER 1
         LI,X1    1
         LI,RB    31
         SW,RB    X7
         AI,RB    BA(ALFTRAN1)
         SLD,X4   2
         STW,X4   RA
         STB,X7   RB
         STH,X6   EXMBS,X1                                              CRSRTP
         EXU      EXMBS             DO THE MBS TIMING PROBLEM           CRSRTP
         LI,RB    31
         SW,RB    X7
         AI,RB    BA(ALFTRAN2)
         STW,X5   RA
         STB,X7   RB
         SLD,X4   -2
         STH,X6   EXMBS,X1          STORE THE OFFSET                    CRSRTP
         EXU      EXMBS             DO THE MBS TIMING PROB              CRSRTP
         LW,X1    SAVEREG1
         B        *R0
*
EVDED    PACK,0   ALFTRAN2
         BCS,8    DECTRP
         DST,0    ALFTRAN2
         PACK,0   ALFTRAN1
         BCS,8    DECTRP
         DC,0     ALFTRAN2
         BCS,X3   *R1
         B        *R0
*
EVDEA    PACK,0   ALFTRAN1
         BCS,8    DECTRP
         DST,0    ALFTRAN1
         PACK,0   ALFTRAN2
         BCS,8    DECTRP
         DC,0     ALFTRAN1
         BCS,X3   *R1
         B        *R0
*
EXMBS    MBS,RA   0                 MOVE IT                             CRSRTP
         PAGE
*
*  THIS REGION PERFORMS TRANSLATION AND COMPARISON OPERATIONS FOR
*       ZONED DECIMAL KEYS
*
*   ASCENDING SEQUENCE ON KEY
*
*
ZTRANA   LI,RE    BA(ZDTRN1)        DESTINATION ADDRESS
         LI,RF    BA(ZDTRN2)        DESTINATION ADDRESS
ZTR1     STW,RE   DCLR
         STW,X1   SAVEREG1         SAVE REGISTER 1
         LI,X1    1
         STW,RF   DCLR+1
         STB,X6   DCLR              COUNT (BYTE)
         STB,X6   DCLR+1            COUNT (BYTE)
         STH,RA   ZTR2,X1           BYTE DISPLACEMENT
         STH,RA   ZTR3,X1           BYTE DISPLACEMENT
         SLD,X4   2
         LW,RC    X4
         LW,RD    DCLR              MOVE PREDICTED WINNER (ASCENDING)
ZTR2     MBS,RC   0                     TO ZDTRN1
         LW,RC    X5
         LW,RD    DCLR+1            MOVE PREDICTED LOSER (ASCENDING)
ZTR3     MBS,RC   0                     TO ZDTRN2
         LW,X1    DCLR
         TBS,0    BA(KTT0)          TRANSLATE BYTES IN ZDTRN1
         LW,X1    DCLR+1
         TBS,0    BA(KTT0)          TRANSLATE BYTES IN ZDTRN2
         LW,X1    SAVEREG1         RESTORE
         SLD,X4   -2                BYTE TO WORD
         LI,1     1
*  THIS REGION SETS UP FOR DECIMAL COMPARE AND PERFORMS THE COMPARE
*
         AI,X6    1                 CONVERT 2L-1 TO
         AND,X6   =X'E'                 L
         SLS,X6   16
         LW,X7    =X'FF0FFFFF'
         LS,X6    ZTR4
         STW,X6   ZTR4
         LS,X6    ZTR5
         STW,X6   ZTR5
         LS,X6    ZTR6
         STW,X6   ZTR6
         LS,X6    ZTR7
         STW,X6   ZTR7
ZTR4     PACK,0   ZDTRN1
ZTR5     DST,0    ZDTRN1
ZTR6     PACK,0   ZDTRN2
ZTR7     DC,0     ZDTRN1
         BE       *R0
         B        *R1
*
*   DESCENDING SEQUENCE ON KEY.
*
ZTRAND   LI,RE    BA(ZDTRN2)
         LI,RF    BA(ZDTRN1)
         B        ZTR1
*
         PAGE
*
*  THIS REGION PERFORMS TRANSLATION AND COMPARISON OPERATIONS FOR
*       PACKED DECIMAL KEYS
*
*   ASCENDING SEQUENCE ON KEY
*
PTRANA   LI,RE    X'30'              X'C' TIMES 4
         STW,X1   SAVEREG1
         STW,RE   DCLR              SET UP FOR TRANSLATE BYTE STRING
         STB,X6   DCLR              COUNT
         SLS,X6   17                POSITION BYTE LENGTH
         LW,X7    =X'FF0FFFFF'      GENERATE
         LS,X6    PTR1                      COMMANDS
         STW,X6   PTR1                             FOR
         LS,X6    PTR2                               DECIMAL
         STW,X6   PTR2                                     COMPARE
         LS,X6    PTR3
         STW,X6   PTR3
         LS,X6    PTR4
         STW,X6   PTR4
         XW,X6    RA                MOVE BYTE DISPLACEMENT INTO INDEX
PTR1     DL,0     *X4,X6            LOAD KEY
         LW,X1    DCLR
         TBS,0    BA(KTT0)          TRANSLATE KEY
PTR2     DST,0    ZDTRN1            STORE KEY
PTR3     DL,0     *X5,X6            LOAD KEY
         LW,X1    DCLR
         TBS,0    BA(KTT0)          TRANSLATE KEY
         LW,X1    SAVEREG1         RESTORE
         LI,1     1
PTR4     DC,0     ZDTRN1            COMPARE
         BE       *R0               RETURN TO SEQUENCE:  KEYS ARE EQUAL
         B        *R1               EXIT:  KEYS ARE UNEQUAL
*
*   DESCENDING SEQUENCE ON KEYS
*
PTRAND   LI,RE    X'30'             REGISTER X'C' X 4
         STW,X1   SAVEREG1
         STW,RE   DCLR              DESTINATION
         STB,X6   DCLR              COUNT
         SLS,X6   17                MOVE COUNT FOR DECIMAL INSTRUCTIONS
         LW,X7    =X'FF0FFFFF'
         LS,X6    PTD1              UNITE COUNT WITH DECIMAL INSTRUC-
         STW,X6   PTD1                  TIONS AND STORE INSTRUCTIONS.
         LS,X6    PTD2
         STW,X6   PTD2
         LS,X6    PTD3
         STW,X6   PTD3
         LS,X6    PTD4
         STW,X6   PTD4
         XW,X6    RA
PTD1     DL,0     *X5,X6            LOAD PREDICTED LOSER
         LW,X1    DCLR
         TBS,0    BA(KTT0)          PERFORM TRANSLATION
PTD2     DST,0    ZDTRN1            STORE FOR COMPARISON LATER
PTD3     DL,0     *X4,X6            LOAD PREDICTED WINNER
         LW,X1    DCLR
         TBS,0    BA(KTT0)          PERFORM TRANSLATION
         LW,X1    SAVEREG1         RESTORE
         LI,1     1
PTD4     DC,0     ZDTRN1            COMPARE KEYS
         BE       *R0               RETURN TO SEQUENCE:  KEYS ARE EQUAL
         B        *R1               EXITS KEYS ARE UNEQUAL
*
         PAGE
*
*  THIS REGION PERFORMS TRANSLATION AND COMPARISON OPERATIONS FOR
*       ALPHANUMERIC KEYS.
*
*   ASCENDING SEQUENCE ON KEY
*
*
ATRANA   LI,X7    BA(ALFTRN1)       DESTINATION FOR MBS AND TBS
         LI,RB    BA(ALFTRN2)           INSTRUCTIONS
         STW,X1   SAVEREG1
         STW,7    DCLR
         STW,RB   DCLR+1
         STB,X6   DCLR              COUNT FOR MBS AND TBS
         STB,X6   DCLR+1                INSTRUCTIONS
         SLD,X4   2                 CONVERT WORD TO BYTE ADDRESSING
         LW,RB    =X'7FFFF'
         STS,RA   ATR1
         STS,RA   ATR2
         LW,X6    X4
         LW,X7    DCLR
ATR1     MBS,X6   0                 MOVE BYTE STRING
         LW,RC    X5
         LW,RD    DCLR+1
ATR2     MBS,RC   0                 MOVE BYTE STRING
         SLD,X4   -2                RESTORE
         LW,X1    DCLR
         TBS,0    BA(KTT0)          TRANSLATE BYTES
         LW,X1    DCLR+1
         TBS,0    BA(KTT0)          TRANSLATE BYTES
         LW,X7    =X'7FFFF'
         LI,X6    0
         LS,X6    DCLR+1
         LW,X7    DCLR
         LW,X1    SAVEREG1         RESTORE
         CBS,X6   0                 COMPARE BYTES
         BE       *R0               RETURN TO SEQUENCE:  KEYS ARE EQUAL
         B        *R1               EXIT:  KEYS ARE UNEQUAL
*
*   DESCENDING SEQUENCE ON KEY
*
ATRAND   LI,X7    BA(ALFTRN2)
         LI,RB    BA(ALFTRN1)
         STW,X1   SAVEREG1
         STW,X7   DCLR
         STW,RB   DCLR+1
         STB,X6   DCLR
         STB,X6   DCLR+1
         SLD,X4   2
         LW,RB    =X'7FFFF'
         STS,RA   ATD1
         STS,RA   ATD2
         LW,X6    X4
         LW,X7    DCLR
ATD1     MBS,X6   0
         LW,RC    X5
         LW,RD    DCLR+1
ATD2     MBS,RC   0
         LW,RE    DCLR
         XW,RE    DCLR+1
         STW,RE   DCLR
         B        ATR2+1
*
         PAGE
*
*
*  THESE ROUTINES PERFORM COMPARISONS ON BINARY KEYS IN ASCENDING
*       OR DESCENDING SEQUENCE ON THEIR ABSOLUTE VALUES.
*
*  AT ENTRY TO THESE ROUTINES:
*        REGISTER:  4=WORD ADDRESS OF THE PREDICTED WINNER
*                   5=WORD ADDRESS OF THE PREDICTED LOSER
*                   6=KEY LENGTH IN BYTES
*                   8=KEY EQUAL RETURN
*                   9=KEY NOT EQUAL RETURN
*                   A=KEY RELATIVE BYTE DISPLACEMENT
*  AT EXIT FROM THESE ROUTINES:
*        REGISTER:  4=WORD ADDRESS OF THE PREDICTED WINNER
*                   5=WORD ADDRESS OF THE PREDICTED LOSER
*                   CC4=1 IF AN EXCHANGE IS NECESSARY
*                       0 IF AN EXCHANGE IS NOT NECESSARY
*
*
         PAGE
*
*   ASCENDING SEQUENCE ON KEY
*
BNABSA   LW,RB    =X'7FFFF'
         STS,RA   BNA2              BYTE
         STS,RA   BNA3
         LI,7     X'38'             DEST ADDR R JUST +1
         LI,11    X'40'             DEST ADDR R JUST +1
BNA1     STB,X6   X7                COUNT
         STB,X6   RB
BNA10    RES      0
         MTW,-1   7                 * REDUCE ADDR SO MBS STORES R JUST
         MTW,-1   11                * IN DOUBLE WRD REGS
         BDR,6    BNA10             REDUCE AGAIN
         LD,RC    BNZROD
         STD,RC   RE
         SLD,X4   2                 CONVERT WORD TO BYTE ADDRESSING
         LW,X6    X4                SOURCE
         LW,RA    X5                     ADDRESS
         SLD,X4   -2
BNA2     MBS,X6   0                 MOVE KEY INTO COMPARISON
BNA3     MBS,RA   0                     REGISTER
         LAD,RA   RC                GET ABSOLUTE VALUES OF
         LAD,RC   RE                    BOTH KEYS
         CD,RC    RA                COMPARE KEYS
         BE       *R0               RETURN TO SEQUENCE:  KEYS ARE EQUAL
         B        *R1               EXIT: KEYS ARE UNEQUAL
*
BNABSD   LW,RB    =X'7FFFF'
         STS,RA   BNA2              BYTE DISPLACEMENT
         STS,RA   BNA3
         LI,7     X'40'             DEST ADDR R JUST +1
         LI,11    X'38'             DEST ADDR R JUST +1
         B        BNA1
*
         BOUND    8
BNZROD   DATA,4   0,0
*
STOREXIT DATA     0
STOREBLK STW,9    STOREXIT
         STW,1    SAVEREG1
         LW,9     BLKCTLSY           ORIG  BLK-CTL-REC-SIZE OUTPUT
         AI,9     -4                FOR WORD OR LESS JUST MOVES
         BGZ      %+2               YES  MORE TO MOVE
         B        *STOREXIT
         LW,1     BUFSAV             BUFFER ADDR
         AI,1     4                 UP  TO NEXT WORD
         STB,9    1                  PUT IN LENGTH FOR MOVE
         MBS,0    BA(ZERO)            ZERO REST OF  BLK-CTL-WORDS
         LW,1     SAVEREG1
         B        *STOREXIT
SAVEREG1 DATA     0                 HOLD  REG  1
ZERO     DATA     0
MBLKWRD  LW,10    LENCTL1
         SLS,10   +16               LEFT SHIFT
         STW,10   LENCTL1           PUT BACK IN HOLD AREA
         MTW,1    BLKCNT             UP BLK CNT
         LW,10    BLKCNT
         STH,10   LENCTL1,1
         LI,10    BA(LENCTL1)         SOURCE ADDR FOR MOVE
         LW,11    BUFSAV             BYTE DEST ADDR 1ST WORD OF BUFFER
         LW,12    BLKCTLSY
         CI,12    4
         BLE      %+2
         LI,12    4                 JUST MOVE 4
         BAL,9    RWMOV             MOVE BLK-LEN-CTL-WORD
         BAL,9    STOREBLK          MOVE REST OF IT
         B        *13               EXIT
         PAGE
*
         PAGE
*
         END

