* CATALOG NO. 704985   SIGMA 5/7 SORT            ROOT SEGMENT
*  VERSION C00
         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
         DEF      OTABN,INABN,CI2
         REF      UTSCPVSW
         DEF      BCT0,FCT1,FCT2,FCT3,FCT4,CPER
         DEF      ILT0,STT0,HEDBUF
         DEF      CNVRT,PRAMLOC,DCBLOC,SINTMP
         DEF      S:SORTP,SC1,SC5
         DEF      MASAD,DECSV,DECSAV,MASKS
         DEF      ZTRANA,ZTRAND,PTRANA,PTRAND,ATRANA,ATRAND
         DEF      BNCMPA,BNCMPD,BNABSA,BNABSD,BNEBC
         DEF      BINEBC,WORK,SORTSV,SPECRD
         DEF      KTTL,KRDSC,KRASC,OSO,NUSO,OCSAV          /SIG7-4137/*E4985
         DEF      OBRAD,NHED,NTRL,OHED,OTRL
         DEF      IDR1,ID2,IDC
         DEF      RWMOV,IN1,OU1,OS1,CI1,CO1,CSI,CSO,ID1,OB1
         DEF      SD1,EBCBN                                /SIG7-1162/*C4985
         DEF      OUTLENSW,MEMPROSW
         DEF      ILT1,SEQRCD,SEQLNG
         DEF      SLICE,SLICEFL                                        R
         DEF      DEVSTP,EVDEA,EVDED
         DEF      DECTRP,INPORD
         DEF      RLKCM,ILLDEC                   % LINE 34 REM (UTS)
         DEF      SIN1R
         DEF      BFVB1,BVDR1,S:SORTC,STFP,STEP
         DEF      CRSF,SBBCNT
         DEF      BLKCTLSY          OUT BLK-CTL-WORDS SIZE ANSI-V 0-99
         DEF      CPGSAV
* LEAVE ABOVE DEF IN FOR DMS
         DEF      COMSTOPA,COMSTOPD
         DEF      ENDSORT
         DEF      BLKCTLSZ          IN  BLK-CTL-WORDS SIZE ANSI-V 0-99
         DEF      ANSISWIN          IN ANSI TYPE SWITCH
         DEF      DUMPMEM
         DEF      ANSISWOU          OU ANSI TYPE SWITCH
         DEF      NUMPGS
         DEF      KLNGC,RIT
         DEF      KEYLOC            HIGH ORDER KEY POS
         REF      SCR0
         DEF      CCT0,FCT5
CCT0     EQU      FCT0
         REF      SCR1,SBC,MCR
         REF      CALLSW
         REF      M:SI
         SREF     S:INHED,S:INUSO,S:INTRL,S:OUHED,S:OUSO,S:OUTRL
* CODE DELETED
*
         REF      KTT0,DCBTABLE
         DEF      FCT0
         REF      STEPCODE
         PAGE
*
SORTSV   RES      15
KTTL     DATA     150                                      /SIG7-5406/*F4985
KLNGC    DATA     55
KRDSC    DATA     0                                        /SIG7-4137/*E4985
KRASC    DATA     0                                        /SIG7-4137/*E4985
FCT0     RES      0
         DATA,4   0,DA(F:SCRF1),DA(F:SCRF2),DA(F:SCRF3),DA(F:SCRF4),;
                  DA(F:SCRF5),DA(F:SCRF6),DA(F:SCRF7),DA(F:SCRF8),;
                  DA(F:SCRF9),DA(F:SCRF10),DA(F:SCRF11),DA(F:SCRF12),;
                  DA(F:SCRF13),DA(F:SCRF14),DA(F:SCRF15),DA(F:SCRF16)
         DO1      73
         DATA     0
FCT5     RES      0
         DO1      18
         DATA     0
         BOUND    8
MASKS    DO1      33
         DATA     0
BCT0     RES      0                 BCT0 22 WORDS
         LOCAL    ILIST
ILIST    DO       24
         LIST     ILIST=1
         DATA,4   0
         FIN
         LIST     1
SIN1R    DO1      3
         DATA     0
OCSAV    DO1      16                OWN CODE REG SAVE DATA
         DATA     0
OCSAV1   DO1      16                OWN CODE REG SAVE READER
         DATA     0
OCSAV2   DO1      16
         DATA     0
ILT0     DO1      18
         DATA     0
ILT1     DO1      10
         DATA     0
PRAMLOC  DO1      8
         DATA     0
ACTSAV   DO1      5                  IO REG SAVE
         DATA     0
BUFTMP   DO1      5
         DATA     0
TMPLOC   DO1      4
         DATA     0
CACTSV   DO1      4                                        /SIG7-1687/*D4985
         DATA     0
DACTSAV  DO1      4                                        /SIG7-0735/*C
         DATA     0
ALFTRN1  DO1      64                   TRANS PREDICTED WINNER HERE
         DATA     0
ALFTRN2  DO1      64                 TRANS PREDICTED LOSER HERE
         DATA     0
DECSAV   DO1      3
         DATA     0
DECSV    DO1      3
         DATA     0
TCT0     DO1      5
         DATA     0
ACTION   DO1      2                 RECORD INFO SAVE FOR INSERT
         DATA     0
CNVRT    DO1      2
         DATA     0
BFLOC    DO1      1
         DATA     0
BFSIZE   DATA     0
CPER     DATA     0
SEQRCD   DATA     0
SEQLNG   DATA     0
MASAD    DATA     0
OBRAD    DATA     0
RIT      DATA     0
BNEBC    EQU      BINEBC
SORTSD   DATA     0
STT0     DATA     0
CPGSAV   DATA     0                 COM PAGE ADDR FOR SNAP /SIG7-4174/*E4985
EOFSW    DATA     0
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)
NUMPGS   DATA     0
DUMPMEM  DATA     0                 HAS 1 FOR USER DUMP,THEN ADDR
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
BUFFSIZE DATA     0                 BUFFER SIZE FOR ANSI TYPE
BLKCNT   DATA     X'FFFFFFFF'       BLK CNT FOR ANSI V
SAVEIT   DATA     0                 HOLDS REC LEN FOR ANSI V
SAVER1   DATA     0
SW414C   DATA     0                 HOLD R10
SAVE5    DATA     0                 HOLD R5 FOR DEBLOCKER
BLKLENCT DATA     0                 HOLDS COMPUTED BLK SIZE OF REC PROCESSED
BLKLENRD DATA     0                 HOLDS BLOCK SIZE FROM READ OF ANSI V
CRSF     DATA     0
MONTYP   DATA     0
WORK     DATA     0
OUTLENSW DATA     0                  1 USE OUT REC LEN
MEMPROSW DATA     0                 1 POSS MEM PRO OUT REC IS BIGGER THAN IN
FMAN     DATA     0
SLICE    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
ENDSORT  DATA     0
SLICEFL  DATA     0                                                    R
RLKCM    DATA     0
ILLDEC   DATA     0
SINTMP   DO1      5
         DATA     0
INPORD   DATA     0                                        /SIG7-2254/*D4985
*        LINES 122,123,124  REMOVED FOR UTS
*
BFTMP    DATA     0,0,0                                    /SIG7-1687/*D4985
KEYLOC   DATA     0                 HIGH ORDER KEY POS
ERRCD    DATA     0
COMSTOPA DATA     0                 1ST WRD OF LAST COMP SEQ
COMSTOPD DATA     0                 1ST WRD OF LAST COMP SEQ  DESC
         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
DCBLOC   EQU      PRAMLOC+1
DCLR     AD,0     ZDTRN1
         AD,0     ZDTRN2
FCT1     EQU      FCT0+18
FCT2     EQU      FCT0+36
FCT3     EQU      FCT0+54
FCT4     EQU      FCT0+72
PDTRN1   EQU      ALFTRN1
PDTRN2   EQU      ALFTRN2
ALFTRAN1 EQU      ALFTRN1
ALFTRAN2 EQU      ALFTRN2
S:SORTP  EQU      SC1
SORTP    EQU      S:SORTP
ZDTRN1   EQU      ALFTRN1
ZDTRN2   EQU      ALFTRN2
UBD1     EQU      UBDN1
UBDR1    EQU      UBDNR1
BFD1     EQU      BFDN1
BFDR1    EQU      BFDNR1
BVD1     EQU      BVDN1
MFD1     EQU      MFDN1
BVDV1    EQU      BVDVN1
CACTSAV  EQU      CACTSV
*
         PAGE
*
HEDBUF   TEXTC    'SORT F 0       '     THE SKELETON HEADER  LABEL
TRBUF    TEXTC    'SORT T 0           ' THE SKELETON TRAILER LABEL
EOSBUF   TEXTC    'SORT END OF STRING ' THE END OF STRING RECORD
SKBB     TEXTC    'BLOCK DROPPED'
*
E1       TEXTC    'BLOCK LENGTH ABNORMAL'
E2       TEXTC    'I/O ERROR CODE:        '
E3       TEXTC    'STRING LABEL ERROR'
EE       TEXTC    'ILLEGAL DECIMAL KEY'
EF       TEXTC    'MEMORY OVERFLOW'
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',;/SIG7-1162/*C4985
                  ' NEXT VOLUME'
E20      TEXTC    'INSUFFICIENT INFORMATION: INPUT,OUTPUT OR INTER DCB'
E21      TEXTC    'INPUT OR OUTPUT FILE ALREADY OPEN'
E22      TEXTC    ' NOT 3-17 DEVICES/FILES AVAILABLE'
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
E29      TEXTC    'HDR FIELD NOT BLANK,F, OR 1-9'
*
SRTMES   TEXTC    'SEQUENTIAL'
         PAGE
*
SBBCNT   DATA,4   0,0
ERTBL    DATA,4   E1,E2,E3,EE,EF,0,0,E1B,E1C
         DATA,4   E1D,E1E,0,E20,E21,E22,E23,E24
         DATA,4   E25,E26,E27,E28,E29                      SIG7-8751
*
*                                                          /SIG7-1043/*C4985
         PAGE
*
STV0     DATA,4   UBDN1             DEBLOCKERS-NO MOVE
         DATA,4   UBDNR1
         DATA,4   BFDN1
         DATA,4   BFDNR1
         DATA,4   BVDN1
         DATA,4   BVDNR1
         DATA,4   MFDN1
         DATA,4   BVDVN1            ANSI BLK-VAR DEBLOCKER NO MOVE
STV1     DATA,4   UBD1              DEBLOCKERS MOVE
         DATA,4   UBDR1
         DATA,4   BFD1
         DATA,4   BFDR1
         DATA,4   BVD1
         DATA,4   BVDR1
         DATA,4   MFD1
         DATA,4   BVDV1             ANSI BLOCKED-VAR DEBLOCKER MOVE
         DATA,4   UBB1              BLOCKERS
         DATA,4   BFVB1
         DATA,4   BVBV              ANSI BLOCKED-VAR BLOCKER MOVE
*
*
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
*
*
OWNCUT   LW,R11   IDR1+1
*
         PAGE
*
*        SORT IS ALWAYS CALLED AS A SUBROUTINE, EITHER BY THE
*        SORT PREPROCESSOR OR BY AN ACTUAL USER PROCESSOR
*        PROGRAM: COBOL-MANAGE-FORTRAN-DMS-METASYMBOL-ETC.
*
         PAGE
SC1      RES      0
* UPON ENTRY TO THE SEQUENTIAL 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
         LCI      15
         STM,1    SORTSV            SAVE GEN REGS
         STW,5    CALLSW
         STW,5    CCT0
         STW,X6   FMAN
         STW,6    CPGSAV             SAVE COM PG ADDR      /SIG7-4174/*E4985
         M:PRINT  (MESS,SRTMES)
         LI,7     24                SEE IF USER WANTS A DUMP
         LB,7     *CPGSAV,7
         CI,7     C'D'               D FOR DUMP
         BNE      %+2
         MTW,1    DUMPMEM           SET ON FOR P0 TO TEST
         B        SO2
*
         PAGE
*
SRTCR    EQU      SORTSV+10
S:SORTC  RES      0
         LCI      15            SAVE ALL GENERAL 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 IF HERE
         AND,15   =X'FF'            GET VERSION NUMBER
         CI,15    X'30'             FOR 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
         LI,2     202
         STW,15   KTTL,2            ZERO KTTL TO KTTL+202
         BDR,2    %-1
         LI,15    150           INITIALIZE KTTL AND FOLLOWING AREA
         STW,15   KTTL
         LI,15    55
         STW,15   KLNGC
         LCI      7
         LM,1     DCBTABLE      INITIALIZE FCT0 TABLE WITH DCB'S
         STM,1    FCT0+1
         LCI      9
         LM,1     DCBTABLE+7
         STM,1    FCT0+8
         LI,X1    1
         STW,X1   CRSF           SET CO-RESIDENT SORT FLAG
         LW,6     SORTSV+5
         LW,7     SORTSV+6
         PAGE
*
SO2      RES      0
         M:SETDCB F:SORTIN,(ERR,CI2),(ABN,INABN)
         M:SETDCB F:SORTOUT,(ERR,CI2),(ABN,INABN)
         BAL,11   INUM             GET NUMBER OF INTERM DCBS TO USE
*                                  AND OPENS THE INTERMEDIATE DCBS
         LB,X5    X'2B'            CHECK WHAT SYSTEM IS ON
         SLS,X5   -4
         CI,X5    6                IS IT UTS
         BE       SO21             YES.
         CI,X5    7                IS IT CP-V
         BNE      SO22             NO.
SO21     RES      0
         M:XCON   EXITCTL          SET XCON ON
SO22     RES      0
         BAL,X5   SCR0              EXECUTE PHASE 0
         LW,X7    CPER              ANY ERRORS
         BNE      SC5               YES: TAKE RRROR EXIT
*
         BAL,X5   SCR1             GO EXECUTE PHASE ONE
         LW,X7    CPER              ANY PHASE  ONE ERRORS  /SIG7-1162/*C4985
         BNE      SC5               YES: TAKE ERROR EXIT
SO3      RES      0
         BAL,X5   SBC               GO EXECUTE PHASE TWO
*
SO4      RES      0
         BAL,X5   MCR               GO EXECUTE PHASE THREE
         BAL,X4   CLOSAL           CLOSE INTERMEDIATE FILES
         LCI      15
         LM,X1    SORTSV
         LI,X6    0                 COMPLETION CODE = NORMAL
         LW,9     BCT0+6            IN COUNT               SIG7-8751
         LW,8     BCT0+7            OUT COUNT              SIG7-8751
         AW,8     BCT0+22           OUT DELETED            SIG7-8751
         SW,8     BCT0+23           OUT INSERTED
         LW,7     BCT0+7                                   SIG7-8751
         CW,9     8                                        SIG7-8751
         BE       SO6                                      SIG7-8751
         LW,7     CRSF
         BNEZ     SO6               YES
         LI,7     X'14'             INDEX                  SIG7-8751
         B        SC5                ERROR ABORT           SIG7-8751
SO6      RES      0
,STFP    M:FP     0
         LW,8     CRSF
         BNEZ     SO8
         B        *1                RETURN TO ROOT
SO8      RES      0
         LW,X7    BCT0+7            CHECK NUMBER OF RECORDS IN
         CW,X7    BCT0+6            WITH NUMBER ORECORDS OUT
         BE       SO9
         LI,X6    1                 SET FOR ERROR
SO9      RES      0
         B        *SRTCR            EXIT TO CO-RESIDENT CALLER.
*
         PAGE
EXITCTL0 RES      0
         STW,1    SAVER1            MAY BE CLOBBERED BY CLOSES
         STW,9    SAVE5             TEMP HOLD, . HAS ABORT CODES
         BAL,X4   CLOSAL           GO CLOSE INTERMEDIATES
         LW,9     SAVE5             SHOW USER XCON ABORT CODE
         MTW,0    DUMPMEM           DO IT HAVE AN ADDR
         BEZ      EXITCTL-1
         M:SNAP   'MEMORY',(SORTSV,*ENDSORT)
         M:SNAP   'MEMORY',(*KRASC,*DUMPMEM)
         LW,1     SAVER1
         AI,1     18
         STW,1    SAVER1
         AI,1     -18
         M:SNAP   'SAVE REG',(*1,*SAVER1)
         M:TRTN   XCON             RE-ISSUE TRAP
EXITCTL  RES      0
         STW,R8   X6               SAVE RUN STATUS
         M:XCON   0                SET XCON OFF
         CI,6     0
         BEZ      EXITCTL-1
         CI,6     X'80'              M:ERR
         BE       EXITCTL-1
         CI,6     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
         LW,8     6
         AND,8    =X'00000030'      FOR OPR ERROR OR ABORT
         BEZ      EXITCTLA          NO SO TEST FOR OTHER
         LI,7     16
         B        SC5               GO ABORT WITH MSG
EXITCTLA RES      0
         LW,8     6
         AND,8    =X'00000004'       IS BIT 29 ON LIMITS
         BNEZ     EXITCTL4           YES
         AND,X6   =X'3'            CHECK FOR I/O OR TRAP
         BEZ      EXITCTL0         NO.
         AND,X6   =X'1'            IS IT A TRAP
         BEZ      EXITCTL1         NO. I/O ERROR
         LH,X6    CCT0             IS IT SUBROUTINE CALLED
         BNEZ     EXITCTL0         OK TO TRAP
         M:SNAP   'REGS'
         MTW,0    DUMPMEM           DOES USER WANT DUMPS
         BEZ      EXITCTLB          NO
         AI,1     18
         STW,1    SAVER1            SNAP REG BEFORE XCON
         AI,1     -18
         M:SNAP   'SAVE REG',(*1,*SAVER1)
EXITCTLB RES      0
         STW,9    SAVE5             TEMP STORE
         BAL,4    CLOSAL
         LW,9     SAVE5             RESTORE
         LCI      15
         LM,X1    SORTSV           RESTORE REGISTERS
         LI,X6    4                SET ERROR RETURN
         MTW,0    DUMPMEM           DO IT HAVE AN ADDR
         BEZ      %+3
         M:SNAP   'MEMORY',(SORTSV,*ENDSORT)
         M:SNAP   'MEMORY',(*KRASC,*DUMPMEM)
,STFP2   M:FP     0
         MTW,0    CRSF
         BNEZ     *11
         B        *1                RETURN TO ROOT
EXITCTL1 RES      0
         LW,9     10               GET ERROR CODE INTO 9
         CI,R9    X'54'
         BE       EXITCTL0         EXIT
         CI,9     X'57'
         BNE      %+2
         BAL,8    EXITCTL5           SEE IF M:DO TO A FILE
         M:XCON   EXITCTL          SET XCON ON AGAIN
         SLS,10   24               SET CODE INTO FIRST BYTE
         LI,1     1
         SLS,11   1                 FORMAT CORRECTLY FOR PRINT
         STB,11   10,1              MAKE SUBCODE
         STW,10   ERRCD
         LI,8     0
         STW,8    STEPCODE          CLEAR MAY NOT BE ABORTING
         MTW,1    MONTYP            SET FLAG FOR ERROR RETURN
         CI,9     X'40'
         BGE      EXITCTL2         IT IS AN ERROR
         BAL,8    INABN            GO
         BAL,8    PWA1             CHECK
         BAL,8    PRA1             ABNORMAL CODES
         MTW,-1   MONTYP             TURN OFF ERROR RETURN FLAG
         B        EXITCTL-1
EXITCTL2 RES      0
         CI,9     X'57'
         BLE      EXITCTL3
         LI,7     1                 DEFAULT TO IO ERROR
         B        SC5
EXITCTL3 RES      0
         BAL,8    PWE1             GO CHECK
         BAL,8    PRE1             ERROR CODES
         MTW,-1   MONTYP             TURN OFF ERROR RETURN FLAG
         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        SC5               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
         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
SC5      RES      0
         LW,4     ERTBL,7           MESS POINTER
         LI,6     0
         LI,5     0
         LW,13    =C'    '         BLANK OUT MESSAGE
         CI,7     1                IS IT AN I/O 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 SUBCODE
         CI,6     4                IS IT DIGIT NUMBER 4
         BL       SC9              YES: GO PROCESS DIGIT NUMBER 4
         STW,13   E2+5              STORE 4 BYTE OF ALPHA ERROR CODE
SC12     RES      0
         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,HEDBUF-1)                 /SIG7-4174/*E4985
         M:SNAP   'IN - OUT',(BCT0+6,BCT0+7)
SC52     RES      0
         BAL,X4   CLOSAL           CLOSE INTERMEDIATE FILES
         STW,X7   CPER              SAVE ERR CODE          /SIG7-1162/*C4985
         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      RES      0
         LW,X7    BCT0+7            NO 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,*ENDSORT)
         M:SNAP   'MEMORY',(*KRASC,*DUMPMEM)
SC53     RES      0
,STEP    M:FP     0
         MTW,6    STEPCODE          SIGNAL ERROR TO USER
         MTW,0    CRSF              IS IT CO-RES
         BNEZ     *SRTCR            YES
         B        *1                RETURN TO ROOT
CLOSAL   RES      0
         LH,X5    BCT0+1           NUMBER OF DCBS TO CLOSE
CLSINT   RES      0
         LW,R9    DCBTABLE-1,X5    ADDRESS OF INTERMEDIATE DCB7S
         SLS,R9   1                TO WORD ADDRES
         M:CLOSE  *R9,(REL)
         BDR,X5   CLSINT           IF MORE GO CLOSE
         MTW,0    CRSF              IS IT CO-RES
         BNEZ     *4                YES
         BAL,9    CLOSEIN           CLOSE INPUT
         LI,9     F:SORTOUT
         LW,5     =X'00200000'         TEST FCD IN DCB
         AND,5    *9
         BEZ      *4                DCB CLOSED EXIT OUT
         M:CLOSE  *9,(SAVE),(REM)
         B        *4
*
CLDCBADR DATA     0                 HOLD DCB ADDR
CLRETURN DATA     0                 HOLD RETURN ADDR
CLOSEIN  RES      0
         STW,9    CLRETURN          SAVE RETURN ADDR
         LI,9     F:SORTIN          GET DCB ADDR
         STW,9    CLDCBADR          SAVE FOR CLOSE OPERATION
         LW,9     *9                GET WORD 0 OF THE DCB
         AND,9    =X'00200000'       TEST FCD TO SEE IF ON
         BEZ      *CLRETURN         NOT ON SO OUT
         LI,9     F:SORTIN
         AI,9     5                 COMPUTE WORD 5 ADDR
         LB,9     *9                 GET FIL1 FIELD WORD 5
         AND,9    =X'000000C0'      MASK OUT OTHER THAN
         CI,9     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
*        THIS ROUTINE GETS THE NUMBER OF INTERMEDIATE DCBS
*        FROM THE USERS PARAMETER LIST.
INUM     RES      0
         LI,X4    9
         LW,4     *SORTSV+5,4       6 ADDR OF PARAM L&ST
         AND,X4   =X'FF'           MASK OUT NUMBER OF DCBS
         CI,4     X'F3'             LEAST ALLOWED FOR SEQN SORT
         BGE      INUM10           YES.
         CI,4     X'40'
         BE       INUM20
         CI,4     0
         BE       INUM20
         CI,4     X'C1'
         BL       INUM30            ERROR
         CI,4     X'C9'             ERROR
         BGE      INUM30
         AND,X4   =X'F'
         AI,4     9                 A=10,B=11 ECT
         B        OPINT            RETURN
INUM10   RES      0
         AND,X4   =X'F'            REG 4= NUMBER OF DCBS TO PROCESS
         B        OPINT            RETURN
INUM20   RES      0
         LI,4     6                 6 IS NEW DEFAULT
         B        OPINT
INUM30   RES      0
         LI,4     17                DEFAULT TO 17 AND FALL TO OPINT
*
*        THIS ROUTINE OPENS THE INTERMEDIATE DCBS NORMALLY
*
OPINT    RES      0
         SLS,4    +16
         STW,4    BCT0+1            TEMP STOR
         SLS,4    -16
         AI,4     -1                DONT OPEN DCB (N) TILL INPT DONE
OPINT0   RES      0
         LW,3     DCBTABLE-1,4
         SLS,X3   1                TO WORD ADDRESS
         M:OPEN   *X3,(ERR,CI2),(ABN,INABN),(CONSEC)
         M:SETDCB *X3,(ERR,0),(ABN,0)
         BDR,4    OPINT0
         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:
*        REGISTER 5=THE RETURN ADDRESS
*                 6=THE FCT ORDINATE FOR THE FILE
*                 7=TYPE CODE:
*                        BYTE 0=U IF UNBLOCKED
*                               B IF BLOCKED
*                        BYTE 1=F IF FORWARD READ
*                               R IF REVERSE READ
*                        BYTE 2=F IF FIXED LENGTH RECORDS
*                               V IF VARIABLE
*  AT EXIT FROM IN1:
*        REGISTER 5=THE ADDRESS TO WHICH RETURN WAS MADE
*                       =SUPPLIED ADDRESS+1 IF ERROR,ADDRESS IF
*                        NORMAL RETURN
*                 6=THE FCT ORDINATE FOR THE FILE
*                 2=THE ENTRY POINT TO THE DEBLOCKER WITH MOVE
*                 3=THE ENTRY POINT TO THE DEBLOCKER WITHOUT MOVE
*                 FCT1 SET NOT AVAILABLE
*                 FCT2 WITH A READ IN PROCESS
*                 FCT4 SET TO UPPER LIMIT FOR BUFFER IN FCT1
*                 FCT3 IS SET = FCT1
*        IF INPUT TYPE WAS REVERSE (READ BACKWARD):
*                 FCT1=LOW LIMIT (BYTE)
*                 FCT3=FCT4=BASE BUFFER ADDRESS FOR THIS BUFFER
*                      (THE LARGEST BYTE ADDRESS WITHIN THE
*                       BUFFER
*
         PAGE
*                     THIS REGION PERFORMS THE LEGALITY CHECK
*
IN1R     DATA     0
*
IN1      STW,X5   IN1R              SAVE RETURN ADDRESS
         MTW,0    FCT0,X6           IS FILE OPEN
         BGE      IN2               NO:  GO OPEN FILE
         AI,X5    1                 YES:  ERROR
         B        *X5
*
*                     THIS REGION DEVELOPES THE FILE'S TYPE CODE
IN2      LI,X4    3                 SET TO PICK UP LAST BYT/SIG7-1042/*C4985
         LI,R8    0                 TYPE CODE
         STW,X7   FCT5,X6
         LI,R9    X'FFFF'
         AND,R9   FCT0,X6           DCB ADDRESS
         SLS,R9   1
         STW,R9   SORTSD
IN3      LB,R9    X7                U/B:  BLOCKED OR UNBLOCKED
         CI,R9    C'U'              IS FORMAT UNBLOCKED
         BE       IN42              YES:  FINISHED         /SIG7-1042/*C4985
         LW,9     ANSISWIN          INPUT ANSI TYPE
         CI,9     0
         BE       IN4-1             NOT ANSI, SEE IF MON OR MANAGE
         CI,9     1
         BE       IN42              ANSI U TREAT AS USER UNBLOCKED
         CI,9     3
         BE       IN4-1             ANSI BLOCKED
         LI,8     7                 ANSIBLK-VAR 7 INDEX IN STV0,STV1
         B        IN42
         LI,R8    2                 SET TYPE CODE TO BLOCK /SIG7-1042/*C4985
IN4      LB,R9    X7,X4             IS IT MANAGE FILE      /SIG7-1042/*C4985
         CI,R9    C'M'
         BNE      IN42
         MTW,15   FMAN
         LI,R9    X'FFFF'
         AND,R9   *FMAN
         STW,R9   FMAN
         LI,R8    6
*                 THIS REGION DETERMINES THE TYPE OF HEADER/SIG7-1042/*C4985
*                 HANDLING THAT IS TO OCCUR AND READS      /SIG7-1042/*C4985
*                 ONE DATA RECORD PRIOR TO EXITING.        /SIG7-1042/*C4985
IN42     STB,R8   TCT0,X6
         LW,R9    FCT1
         STW,R9   BFSIZE
         LI,R10   X'7FFFF'
         AND,R10  FCT1,X6           BUFFER ADDRESS
         SLS,R10  -2                WORD ADDRESS           /SIG7-1042/*C4985
         STW,R10  BFLOC
         SLS,R10  2                 BACK TO BYTE ADDRESS   /SIG7-1042/*C4985
         OR,R10   =X'80000000'      SET SIGN BIT
         XW,R10   FCT2,X6           EXCHANGFCT2 AND FCT1
         OR,R10   =X'80000000'      SET SIGN BIT
         STW,R10  FCT1,X6
         LW,R8    =X'80000000'                             /SIG7-1042/*C4985
         OR,R8    FCT0,X6                                  /SIG7-1042/*C4985
         STW,R8   FCT0,X6           SET FILE OPEN          /SIG7-1042/*C4985
         MTW,0    NHED
         BEZ      IN12
         LI,R9    X'F'                                     /SIG7-1042/*C4985
         AND,R9   *SORTSD           IS FILE MONITOR        /SIG7-1042/*C4985
         CI,R9    3                                FORMAT  /SIG7-1042/*C4985
         BNE      IN10              YES:  USE TLABEL       /SIG7-1042/*C4985
         M:READ   *SORTSD,(BUF,*BFLOC),(SIZE,*BFSIZE),;    /SIG7-1042/*C4985
                  (BTD,1),(WAIT)                           /SIG7-1042/*C4985
         LI,X5    8                                        /SIG7-1042/*C4985
         LH,R9    *SORTSD,X5        GET ARS                /SIG7-1042/*C4985
         SLS,R9   -1                                       /SIG7-1042/*C4985
         STB,R9   *BFLOC            STORE LABEL LENGTH     /SIG7-1042/*C4985
IN6      LCI      15
         STM,X1   OCSAV1            SAVE ALL GENERAL REGISTERS
*
IN65     LW,X6    FCT2,X6
         AND,X6   =X'7FFFF'
         BAL,X5   S:INHED           EXECUTE OWN CODE
         LCI      15
         LM,X1    OCSAV1
         B        IN12              TO EXIT                /SIG7-1042/*C4985
*
IN10     LI,R9    X'FF'             SET MAX LABEL          /SIG7-1042/*C4985
         STB,R9   *BFLOC            SIZE                   /SIG7-1042/*C4985
         M:OPEN   *SORTSD,(IN),(TLABEL,*BFLOC)             /SIG7-1042/*C4985
         B        IN6
IN12     RES      0
         MTW,0    BCT0+8
         BL       IN15
         LI,4     12
         LB,9     *CPGSAV,4
         CI,9     X'C6'
         BNE      IN13
         M:PFIL   *SORTSD,(EOF)
         B        IN15
IN13     RES      0
         STH,9    IN14+2,1           IN FPT
,IN14    M:PRECORD  *SORTSD,(N,1)
IN15     RES      0
         LW,9     FCT2,6             BUF ADDR
         AND,R9   =X'7FFFF'                                /SIG7-1042/*C4985
         STW,R9   BFLOC                                    /SIG7-1042/*C4985
         BAL,R9   ORDF              INIT READ              /SIG7-1042/*C4985
         B        *IN1R             RETURN                 /SIG7-1042/*C4985
         PAGE
*
*
*                     THIS REGION PERFORMS LEGALITY CHECK
*
OU1R     DATA     0
*
OU1      STW,X5   OU1R
         MTW,0    FCT0,X6
         BGE      OU2               NO:   GO OPEN FILE
         AI,X5    1                 YES:  ERROR
         B        *X5               EXIT:  ERROR
*
OU2      LI,8     8                 TYPE CODE FOR FIRST BLKR IN STV1
         LB,R9    X7                U/B:  BLOCKED OR UNBLOCKED
         CI,R9    C'U'              IS UNBLOCKED
         BE       OU3               YES:  FINISHED
         LW,9     ANSISWOU
         CI,9     1                 UNDEF ANSI SAME AS UNBLOCKED
         BE       OU3
         AI,8     1
         CI,9     2                 VAR-BLK ANSI
         BNE      OU3               NO ASSUME BLOCKED ANSI
         AI,8     1                 SET TYPE TO VAR-BLK ANSI
OU3      STB,R8   TCT0,X6           SET TYPE CODE FOR FILE
         LW,R9    FCT1,X6           BUFFER BASE ADDRESS
         STW,R9   FCT3,X6           INITIALIZE CURRENT AVAIL LOC
         AW,R9    FCT2              PLUS LENGTH
         STW,R9   FCT4,X6           SET BUFFER LIMIT FOR FILE
         LW,R8    =X'80000000'
         AWM,R8   FCT0,X6           SET FILE OPEN
         LW,9     OHED              IS OUT HEADER OWN CODE PRES
         BNEZ     OU31               YES
         LH,9     CALLSW             IS IT MAIN PROG CALLED
         BEZ      OU5               NO
         B        *OU1R             EXIT
OU31     RES      0
         LCI      15
         STM,X1   OCSAV1
         BAL,X5   S:OUHED           GO:  EXECUTE OWN CODE
         LB,X7    0,X6              LABEL LENGTH
         AI,X6    1                 SKIP LENGTH FIELD
         STW,X6   BFLOC             LABEL LOCATION
         STW,X7   BFSIZE            LABEL LENGTG
         LCI      15
         LM,X1    OCSAV1
OU35     LI,R8    X'FFFF'
         AND,R8   FCT0,X6
         SLS,R8   1
         STW,R8   SORTSD
         LI,R8    X'F'                                     /SIG7-1042/*C4985
         AND,R8   *SORTSD           IS FILE MONITOR        /SIG7-1042/*C4985
         CI,R8    3                                 FORMAT /SIG7-1042/*C4985
         BNE      OU6               YES:  USE TLABEL       /SIG7-1042/*C4985
         BAL,R9   OWRT              GO:  WRITE LABEL RECORD
         B        *OU1R
OU5      LH,R9    CCT0
         BNE      *OU1R             NO:  EXIT
         LW,R9    SORTSV+6          YES:LABEL
         LB,R8    *R9               LABEL LENGTH
         BE       *OU1R             NO LABEL
         SLS,R9   2                 CONVERT LABEL ADDRESS TO BYRTES
         AI,R9    1
         STW,R9   BFLOC
         STW,R8   BFSIZE
         B        OU35
*
OU6      LW,R9    BFLOC             CONVERT                /SIG7-1042/*C4985
         SLS,R9   -2                       TO              /SIG7-1042/*C4985
         STW,R9   BFLOC                        WORD ADDRESS/SIG7-1042/*C4985
         M:OPEN   *SORTSD,(OUT),(TLABEL,*BFLOC)            /SIG7-1042/*C4985
         B        *OU1R             RETURN                 /SIG7-1038/*C4985
         PAGE
*
*  THIS ROUTINE OPENS SCRATCH FILES AND OR STRINGS.  IT ASSUMES
*  THAT ALL INPUT FILES WILL BE READ IN A REVERSE DIRECTION.
*  TAPE POSITION WILL BE SUCH THAT OPEN INPUT FILE WILL READ:
*                 FM TRAILER FM   IN THAT ORDER
*        OPEN INPUT FILE WILL READ:
*                 FM TRAILER FM   IN THAT ORDER
*        OPEN INPUT STRING WILL READ:  FM
*
*        OPEN OUTPUT STRING WILL WRITE NOTHING
*                 (CLOSE IS EXPECTED TO PRODUCE:
*                   FM EOS FM   IN THAT ORDER)
*  AT ENTRY TO OS1:
*        REGISTER 5=THE RETURN ADDRESS
*                 6=THE FCT ORDINATE FOR THE FILE
*                 7=0 IF THE FILE IS AN INPUT FILE
*                  =1 IF THE FILE IS AN OUTPUT FILE
*
         PAGE
OSR1     DATA     0
*
OS1      STW,X5   OSR1
         LI,R9    X'FFFF'
         AND,R9   FCT0,X6
         SLS,R9   1
         STW,R9   SORTSD
         LW,R9    FCT1,X6           BUFFER LOCATION
         AND,R9   =X'7FFFF'
         CI,X7    0                 IS OPEN INPUT
         BE       OS3                YES:  GO OPEN INPUT FILE
         STW,R9   FCT1,X6           BEGINNING BUFFER LOCATION
         STW,R9   FCT3,X6           CURRENT AVAILABLE LOCATION
         AW,R9    FCT2              OUTPUT RECORD LENGTH
         STW,R9   FCT4,X6           LIMIT ADDRESS
         STB,X6   HEDBUF+2          NO:  OPEN OUTPUT SET N
         LW,R9    CRSF              CHECK IF CO-RESIDENT
         BNEZ     OS151             YES.
         LI,9     9                 POINT TO BFVB1
         STB,R9   TCT0,X6
OS151    RES      0
         LW,R9    =X'800000'
         AND,R9   FCT0,X6           IS FILE OPEN AS A FILE
         BNE      OS2               YES:  BYPASS WRITINE HEADER
         BAL,R9   OWFM              GO WRITE FILE MARK
         M:CHECK  *SORTSD,(ABN,OS16),(ERR,OS16)            /SIG7-3820/*E4985
OS16     BAL,10   OWRH                                     /SIG7-3820/*E4985
         M:CHECK  *SORTSD,(ABN,OS17),(ERR,OS17)            /SIG7-3820/*E4985
OS17     BAL,9    OWFM                                     /SIG7-3820/*E4985
         M:CHECK  *SORTSD,(ABN,OS18),(ERR,OS18)            /SIG7-3820/*E4985
OS18     LW,9     FCT0,6                                   /SIG7-3820/*E4985
         OR,R9    =X'800000'        SET FILE OPEN INDICATOR
         STW,R9   FCT0,X6
         LI,R9    OS2
         STW,R9   COCH+2            IGNORE ERROR AND ABNORMAL
         STW,R9   COCH+3                CONDITIONS
         BAL,R9   COCHK              WAIT FOR WRITE
OS2      LW,R9    =X'E0000000'      SET:  FILE, STRING, AND
         OR,R9    FCT0,X6
         STW,R9   FCT0,X6            = NOT AT END POINT
         B        *OSR1             EXIT:  NORMAL
*                      THIS REGION OPENS INPUT FILES/STRINGS
OS3      OR,R9    =X'80000000'
         STW,R9   FCT1,X6           SET NOT AVAILABLE
         LI,R9    5
         STB,R9   TCT0,X6
         LW,R9    FCT2,X6
         AND,R9   =X'7FFFF'
         STW,R9   BFLOC             BUFFER LOCATION
         OR,R9    =X'80000000'
         STW,R9   FCT2,X6
         LI,R9    OS5
         STW,R9   COCH+2
         STW,R9   COCH+3
         LW,R9    FCT1              INPUT BUFFER LENGTH
         STW,R9   BFSIZE
         LW,10    FCT0,6            DCB ADDR
         SLS,10   1                 TO WORDS
         LW,10    *10               WORD 0 OF DCB
         AND,10   =X'F'             GET DEV-TYPE
         CI,R10   1
         BE       OS7
OS4      BAL,R9   ORDR              READ PAST FM
         BAL,R9   COCHK             WAIT ON READS
OS5      LW,R9    BFLOC
         SLS,R9   2
         STW,R9   BFLOC
OS53     BAL,R9   ORDR
         LW,R9    =X'E0000000'
         OR,R9    FCT0,X6
         STW,R9   FCT0,X6           SET FILE/STRING OPEN
         LW,R9    FCT1,X6
         AI,R9    -1
OS6      STW,R9   FCT1,X6
         STW,R9   FCT3,X6
         AW,R9    FCT1
         STW,R9   FCT4,X6
         B        *OSR1
*
OS7      RES      0
         LW,R9    *SORTSD
         AND,R9   =X'F'             IS IT A FILE OR TAPE
         CI,R9    1
         BNE      OS53              MUST BE A TAPE
         M:WRITE  *SORTSD,(SIZE,12),(BUF,KTTL)
         BAL,R9   COCHK             WAIT FOR WRITE
         M:PRECORD *SORTSD,(N,1),(REV)
         BAL,R9   COCHK             WAIT FOR PRECORD
         B        OS53              RELEASED UNUSED FILE SPACE
*
         PAGE
*
*
*  THIS ROUTINE CLOSES INPUT FILES/VOLUMES.  IT EXECUTES USER
*        TRAILER LABEL OWN CODE AND CAUSES EXECUTION OF USER
*        HEADER LABEL OWN CODE IF THE CLOSE IS FOR A VOLUME.
*
*  AT ENTRY TO CI1:
*        REGISTER 5=THE RETURN ADDRESS
*                 6=THE FCT ORDINATE
*
*  CI1 ATTEMPTS TO OPEN THE NEXT VOLUME BEFORE CLOSING THE FILE.
*        IF THERE IS NO NEXT VOLUME,CI1 SETS THE FILE CLOSED AND
*        EXAMINES THE REL PARAMETER TO SORT.  IF THIS PARAMETER
*        SPECIFIES RELEASE,CI1 RELEASES THE FILE.
*
         PAGE
*
CI1R     DATA     0
*
CI1      STW,X5   CI1R              SAVE RETURN
         LI,R9    X'FFFF'
         AND,R9   FCT0,X6
         SLS,R9   1
         STW,R9   SORTSD            DCB ADDRESS
         LI,X1    1
         LW,R9    SLICEFL                                              R
         CI,R9    2                 IS THIS AN END-OF-SLICE CLOSE      R
         BE       CI114             YES BYPASS TRAILER     /SIG7-0750/*C4985
         LW,R9    =X'40000000'      DO TRAILER LABELS EXIST
         CS,R9    BCT0+8
         BE       CI114             NO:  BYPASS OWN-CODE
         LW,R9    NTRL              YES:  DOES OWN CODE EXIST
         BE       CI114             NO:  BYPASS OWN CODE ROUTINE
         LI,9     7
         AND,R9   *SORTSD
         CI,R9    3                 IS FILE ASSIGNED TO A DEVICE
         BL       CI112
CI111    LI,R9    X'7FFFF'
         AND,R9   FCT2,X6
         SLS,R9   -2
         STW,R9   BFLOC
         LW,R9    FCT1
         SLS,R9   -2
         STW,R9   BFSIZE
         M:READ   *SORTSD,(BUF,*BFLOC),(BTD,1),(SIZE,*BFSIZE),(WAIT)
         LI,X3    8
         LH,R9    *SORTSD,X3        ACTUAL RECORD SIZE X 2
         SLS,R9   -1                ACTUAL RECORD SIZE
          STB,R9  *BFLOC            STORE LABEL LENGTH
CI112    LCI      15
         STM,X1   OCSAV             SAVE ALL GENERAL REGISTERS
         LW,X6    BFLOC             LABEL LOCATION OR ZERO
         SLS,X6   2
         LI,X7    0
         BAL,X5   *NTRL             EXECUTE USER ROUTINE
         LCI      15
         LM,X1    OCSAV
CI114    RES      0
         LI,9     7                A(ANSI) TREATED AS 2
         AND,R9   *SORTSD
         CI,R9    3                 IS THE FILE ASSIGNED TO A DEVICE
         BL       CI3               NOT A DEVICE (3)
CI116    LW,R9    SLICEFL           IS THIS A SLICE CLOSE  /SIG7-0750/*C4985
         CI,R9    2                                        /SIG7-0750/*C4985
         BNE      CI117             NO: CLOSE VOL          /SIG7-0750/*C4985
CI116A   RES      0
         B        CI3               GO CLOSE DCB           /SIG7-0750/*C4985
CI117    RES      0
         LW,5     SORTSD            DCB ADDR
         AI,5     6                 TO FLP PARAM
         LW,5     *5                GET FLP FIELD ADDR OF START VAR PARM
         AND,5    =X'0001FFFF'           MASK OUT ALL BUT FLP
         LI,7     3
CI6      RES      0
         LB,9     *5                 GET VAR PARAM TYPE
         CI,9     7                 IS IT SN TYPE
         BE       CI7                YES
         LW,9     *5                GET NUM OF WORDS THIS FIELD
         AND,9    =X'00FF0000'
         BEZ      CI61
         LI,7     10
         B        SC5
CI61     RES      0
         LB,9     *5,7
         AI,5     1
         AW,5     9                 ADD TO FIELD POINTER
         B        CI6               AND CHECK NEXT FIELD
CI7      RES      0
         AI,7     -1
         LB,9     *5,7
         LW,5     SORTSD            DCB ADDR
         AI,5     11                PARAM
         CB,9     *5                IS THIS THE LAST POS SN
         BE       CI3
         LI,10    0                 CLEAR INCASE LATER USED             CTSRTP
         M:CVOL   *SORTSD
CI2      LB,R9    SR3               ERROR CODE INTO R9
         STW,SR3  ERRCD
         CI,9     X'75'
         BNE      %+3
         LI,7     1
         B        SC5
         CI,9     X'4E'
         BE       CI3               IGNORE
CI2L     RES      0
CI2M     CI,9     X'56'
         BE       CI3               NO:  GO CLOSE THE DCB
         CI,9     X'40'              READ AN OUT FILE
         BE       CI2A
         CI,9     X'46'                                    /SIG7-2592/*E4985
         BNE      %+3                                      /SIG7-2592/*E4985
CI2A     LI,7     12
         B        SC5                                      /SIG7-2592/*E4985
         CI,9     X'57'             DISK OVERFLOW                       CTSRTP
         BNE      CI2B              NO                                  CTSRTP
         LI,7     10                ABORT WITH MSG                      CTSRTP
         B        SC5                                                   CTSRTP
CI2B     RES      0                                                     CTSRTP
         MTW,0    9                 WAS THERE AN ERROR                  CTSRTP
         BEZ      CI2C              NO                                  CTSRTP
         LI,7     1                 ABORT WITH MSG                      CTSRTP
         B        SC5                                                   CTSRTP
CI2C     RES      0                                                     CTSRTP
         LI,R9    X'7FFFF'
         AND,R9   FCT0,X6
         STW,R9   FCT0,X6           CLOSE FCT0 ENTRY
         LW,X7    BCT0+19
         BAL,X5   IN1               OPEN NEXT VOLUME
         B        *CI1R             RET THRU CHANS         /SIG7-1039/*C4985
         B        CI3               GO:  CLOSE FILE
*
CI3      LI,X4    1
         LW,R9    NUSO
         BE       CI35              BRANCH IF NO USER OWN CODE
         LCI      15                SAVE REGISTERS
         STM,X1   OCSAV
         LI,6     0
         BAL,X5   *NUSO             GO EXECUTE USER ROUTINE
         LW,X5    OWNCUT            STOP EXECUTING S:INUSO
         STW,X5   IDC
         LCI      15                RESTORE REGISTERS
         LM,X1    OCSAV
CI35     RES      0
         BAL,9    CLOSEIN           CLOSE INPUT
CI4      LI,R9    X'FFFF'
         AND,R9   FCT0,X6
         STW,R9   FCT0,X6           SET FILE CLOSED INDICATION
         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:
*        REGISTER 5=THE RETURN ADDRESS
*                 6=THE FCT ORDINATE
*                 7=0 IF CLOSE IS FOR A FILE
*                  =1 IF CLOSE IS FOR A VOLUME
*
*  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,X5   CO1R              SAVE RETURN
         CI,X7    2                 VOLUME CLOSE           /SIG7-0738/*C4985
         BE       CO15              YES                    /SIG7-0738/*C4985
         LI,R9    X'FFFF'
         AND,R9   FCT0,X6
         SLS,R9   1
         STW,R9   SORTSD
         LW,R9    FCT3,X6           IS THERE A PARTIAL BLOCK
         SW,R9    FCT1,X6               TO BE WRITTEN
         BE       CO15              NO:  BYPASS WRITING RESIDUE
         STW,R9   BFSIZE            YES:  SET UP TO WRITE PARTIAL BLOCK
         LW,R9    FCT1,X6
         STW,R9   BFLOC
         STW,R9   FCT3,X6
         LW,9     ANSISWOU
         CI,9     2
         BNE      %+2
         BAL,13   MBLKWRD
         BAL,R9   OWRT
CO15     BAL,R9   OWFM
*                      THIS REGION PERFORMS THE LOGICAL CLOSE
CO2      LW,R9    FCT0,X6
         AND,R9   =X'1FFFFFFF'      SET INDICATORS FOR FILE
         STW,R9   FCT0,X6                  AND
         LCI      15
         STM,X1   OCSAV1            SAVE ALL GENERAL REGISTERS
         LW,R9    OTRL
         BE       CO3
         LI,X6    0
         BAL,X5   *OTRL             EXECUTE USER ROUTINE
         CI,X6    0
         BNE      CO34              USER SUPPLIED TRAILER EXISTS
CO3      RES      0
         LH,X6    CCT0             SUBROUTINE CALLED
         BNEZ     CO36             NO
CO32     LB,X6    *SORTSV+6
         BE       CO36              NO LABEL
         LW,X6    SORTSV+6
         SLS,X6   2
CO34     STW,X6   BFLOC
         LB,X6    0,X6
         STW,X6   BFSIZE
         MTW,1    BFLOC
         BAL,R9   OWRT              GO WRITE TRAILER
         BAL,R9   OWFM              GO WRITE FM
CO36     RES      0
         BAL,R9   OWFM             WRITE SECOND EOF
CO38     RES      0
         LCI      15
         LM,X1    OCSAV1            RESTORE GENERAL REGISTERS
         CI,X7    0                 IS CLOSE FOR FILE OR VOLUME
         BNE      CO4               VOLUME
         M:CLOSE  *SORTSD,(SAVE),(REM) CLOSE AND SAVE
         B        *CO1R             EXIT
*                           THIS REGION WRITE USER SUPPLIED TRAILER
CO4      BAL,R9   OCVL      GO CLOSE VOLUME
         LW,5     ANSISWOU
         CI,5     1
         BE       CO41              UNDEF ANSI
         CI,5     0
         BE       %+2               NOT ANSI
         B        CO42              BLOCKED ANSI
         LH,X5    BCT0+17,X1        SET BL/UNBL            /SIG7-0737/*C4985
         CI,X5    1                 INDICATOR:             /SIG7-0737/*C4985
         BNE      %+2               BLOCKED                /SIG7-0737/*C4985
CO41     LW,7     =C'U   '          UNDEFINED
CO42     BAL,5    OU1               GO OPEN NEXT VOLUME
         B        *CO1R
*
         PAGE
*  THIS ROUTINE CLOSES AN INPUT(SCRATCH) FILE,STRING, OR VOLUME.
*
*  AT ENTRY TO CSI
*        REGISTER 5=THE RETURN ADDRESS
*                 6=THE FCT ORDINATE
*                 7=0 IF THE CLOSE IS FOR A STRING
*                   1 IF THE CLOSE IS FOR A FILE
*                   2 IF THE CLOSE IS FOR A VOLUME
*        CSI READS THE END OF STRING,FILE,OR VOLUME LABEL AND
*                 SETS THE APPROPRIATE INDICATORS.
*                   IF THE CLOSE IS FOR A VOLUME (IE, BEGINNING
*                   OF TAPE HAS BEEN ENCOUNTERED) CSI OPENS THE
*                   PRECEEDING VOLUME AND POSITIONS IT TO END OF
*                   VOLUME.  AT EXIT THE NEXT READ WILL PRODUCE
*                   A DATA RECORD.
*
         PAGE
*
CSIR     DATA     0
*
CSI      STW,X5   CSIR              SAVE RETURN
         LI,R9    X'FFFF'
         AND,R9   FCT0,X6
         SLS,R9   1
         STW,R9   SORTSD            DCB ADDRESS
         BAL,R9   CSRDR             READ LABEL
CSI0     LW,R9    BUFTMP+1
         CW,R9    =C'T EN'          IS THIS AN END OF STRING
         BE       CSI2              YES:
         CW,R9    =C'T F '          IS THIS A BEGINNING LABEL
         BE       CSI1              YES
         LI,X7    2                 STRING LAB ERR         /SIG7-1162/*C4985
         B        SC5               GO ABORT               /SIG7-1162/*C4985
*                      THIS REGION PROCESSES BEGINNING LABELS
CSI1     LI,4     44                                       /SIG7-1687/*D4985
         LB,X5    *SORTSD,X4        CUI
         AI,X5    -1
         BLE      CSI17
*                      BEGINNING OF VOLUME
         BAL,R9   CICL              GO CLOSE THE FILE
         STW,5    COFPT+2                                  /SIG7-1687/*D4985
         BAL,R9   CVOPEN            OPEN FILE
         BAL,R9   POSEND
         BAL,R9   CSRDR             BACK OVER LA TRAILER
         BAL,R9   CSRDR             BACK OVER FILE MARK
CSI10    LI,R9    X'7FFFF'
         AND,R9   FCT2,X6
         STW,R9   BFLOC
         LI,R9    X'7FFFF'
         AND,R9   FCT1
         STW,R9   BFSIZE                      AND
         BAL,R9   ORDR
         LW,R9    FCT1,X6
         OR,R9    =X'80000000'
         STW,R9   FCT1,X6
         LW,R9    FCT2,X6
         OR,R9    =X'80000000'
         STW,R9   FCT2,X6
CSI15    B        *CSIR
*                      BEGINNING OF FILE
CSI17    LI,R9    X'FFFF'
         AND,R9   FCT0,X6           SET FILE CLOSED
         STW,R9   FCT0,X6           CLOSE THE FILE
* LINE DELETED                                             /SIG7-5196/*F4985
         B        *CSIR             EXIT
*
*                      THIS REGION PROCESSES END OF STRING
CSI2     LI,R9    X'FFFF'
         AND,R9   FCT0,X6
CSI3     STW,R9   FCT0,X6
         B        *CSIR             EXIT
*
         PAGE
*
*  THIS  ROUTINE CLOSES AN OUTPUT(SCRATCH) FILE,STRING, OR VOLUME.
*
*  AT ENTRY TO CSO:
*        REGISTER 5=THE RETURN ADDRESS
*                 6=THE FCT ORDINATE
*                 7=0 IF THE CLOSE IS FOR A STRING
*                   1 IF THE CLOSE IS FOR A FILE
*                   2 IF THE CLOSE IS FOR A VOLUME
*        CSO WRITES:
*                    IF END OF STRING:  FM EOS FM
*                    IF END OF FILE:  FM TRAILER FM
*                    IF END OF VOLUME:  FM TRAILER FM
*                        THEN REWINDS AND CALLS OPEN TO OPEN
*                        THE NEXT VOLUME
*
         PAGE
*
CSOR     DATA     0
*
CSO      STW,X5   CSOR
         LI,R9    X'FFFF'
         AND,R9   FCT0,X6           DCB ADDRESS
         SLS,R9   1
         STW,R9   SORTSD
         LW,R9    FCT3,X6           IS THERE A PARTIAL BLOCK
         SW,R9    FCT1,X6               TO BE WRITTEN
         BE       CSO0              NO:  BYPASS WRITING RESIDUE
         LW,X4    CRSF              CHECK IF CO-RESIDENT
         BNEZ     CSOA              YES.
         CI,7     1                 1 FOR FILE
         BNE      CSOA              NOT A FILE
         LW,4     ANSISWOU
         CI,4     2
         BNE      CSOA              NOT ANSI BLK-VAR
         BAL,13   MBLKWRD
CSOA     BAL,4    PW1
         LW,R9    FCT1,X6
         STW,R9   BFLOC
CSO0     LI,R9    BA(EOSBUF)
         CI,X7    1
         BL       CS1               STRING
         BG       CS2               VOLUME
         B        CS3
CS1      STW,R9   BFLOC
         BAL,R10  EOSFV             GO WRITE FM EOF/S/V  FM
         LW,R9    =X'80FFFF'
         AND,R9   FCT0,X6           SET FILE NOT OPEN
         STW,R9   FCT0,X6
         B        *CSOR             EXIT
*                      THIS REGION PROCESSES END OF VOLUME
*                      CONDITIONS
CS2      LI,R9    BA(TRBUF)
         STW,R9   BFLOC
         BAL,R10  EOSFV             GO WRITE FM  EOV  FM
         BAL,R9   EOFRW             GO REWIND FILE
         LI,X7    1
         LI,R9    X'FFFF'
         AND,R9   FCT0,X6
         STW,R9   FCT0,X6
         BAL,X5   OS1               GO OPEN NEW SCRATCH VOLUME
         B        *CSOR             EXIT
*
CS3      LI,R9    BA(BUFTMP)
         STW,R9   BFLOC
         LI,R9    20
         STW,R9   BFSIZE
         BAL,R9   ORDR
         LW,X5    BFLOC
         SLS,X5   2
         STW,X5   BFLOC
         LW,5     FCT0,6            DCB ADDR
         SLS,5    1                 TO WORDS
         LW,5     *5                WORD 0 OF DCB
         AND,5    =X'F'             GET DEV-TYPE
         CI,X5    1                 IS FILE ASSIGNED TO A RAD
         BE       CS4               YES:  READ PAST LABEL ONLY
         BAL,R9   ORDR
CS4      LI,R9    X'FFFF'
         B        CS1+3
         PAGE
*  THIS ROUTINE SELECTS THE APPROPRATE DEBLOCKER FOR A FILE
*        AND EXECUTES IT.
*  AT ENTRY TO ID1:
*        REGISTER 5=THE RETURN ADDRESS
*                 6=THE FCT ORDINATE FOR THE FILE
*                 7=THE TO ADDRESS FOR A RECORD MOVE
*                   OR ZERO FOR NO MOVE
*  AT EXIT THE REGISTERS ARE SET AS DESCRIBED IN THE
*        EXIT CONDITIONS FOR THE DEBLOCKERS
*
         PAGE
*
IDR1     DATA     0,0
*
ID1      STW,X5   IDR1              SAVE RETURN ADDRESS
         STW,X7   IDR1+1            SAVE MOVE INDICATOR
         MTW,1    INPORD                                   /SIG7-2254/*D4985
         LB,X5    TCT0,X6           GET TYPE CODE
         LW,X4    STV0,X5
         BAL,X5   *X4               GO EXECUTE DEBLOCKER
         B        ID010
         LI,X7    0                 ABN BLK LENGTH         /SIG7-1162/*C4985
         B        SC5               GO ABORT               /SIG7-1162/*C4985
ID010    LW,X5    SLICEFL           DO WE SLICE THE FILE               R
         BE       IDC               NO
         MTW,15   SLICE             YES: DECREASE COUNT                R
         BGE      IDC
         MTW,1    SLICEFL           THIS IS A SLICE CLOSE  /SIG7-0736/*C4985
         BAL,X5   CI1               YES: SIMULATE END OF FILE          R
         LI,X7    0                                                    R
         STW,X7   IDR1+1                                               R
IDC      LW,11    IDR1+1             IS MOVE REQUESTED
         BE       *IDR1             NO:  EXIT
         BAL,9    ID12              CHECK FOR REC LEN ABN
*
         STW,X7   R10               YES:  SOURCE
         LH,R12   R8,X1             LENGTH
         MTW,0    FCT0+17           IS FILE OPEN
         BGE      *IDR1             NO BYPASS RECORD MOVE
         BAL,R9   RWMOV             GO MOVE RECORD
         B        *IDR1                 AND EXIT
*                        PROCESS OWN CODE REQUESTS
ID2      LCI      15
         STM,X1   OCSAV
ID3      LW,X6    X7                RECORD ADDRESS
         LI,X7    ID5               ACTION RETURN          /SIG7-1883/*D4985
         LI,X5    0                 CLEAR EACH TIME        /SIG7-1883/*D4985
         STW,X5   INSERTSW                                 /SIG7-1883/*D4985
         BAL,X5   *NUSO             EXECUTE OWN CODE ROUTINE
         LCI      15
         LM,X1    OCSAV             RESTORE REGISTERS
ID4      LW,R11   IDR1+1            IS MOVE REQUESTED--IF YES-DESTINATN
         BE       *IDR1             NO:  EXIT
         LW,R10   X7                YES:  SOURCE
         LH,R12   R8,X1             LENGTH
         BAL,9    ID12              CHK FOR REC-LEN-ABN
         BAL,R9   RWMOV             GO MOVE RECORD
         B        *IDR1
*
ID5      STW,X5   ACTION            LENGTH
         STW,X6   ACTION+1          ACTION CODE AND RECORD ADDRESS
         LCI      15
         LM,X1    OCSAV             RESTORE REGISTERS
         MTB,0    ACTION+1
         BE       ID10
         MTB,15   ACTION+1
         BNE      ID7               NOT REPLACE
ID6      LW,R8    ACTION
         LW,X7    ACTION+1
         B        ID4
ID7      MTB,15   ACTION+1
         BE       ID8
         LI,X7    9                 ILL ACTION REQUEST     /SIG7-1162/*C4985
         B        SC5               GO ABORT               /SIG7-1162/*C4985
*
ID8      LW,RF    IDK1              INSERT
         XW,RF    ID1+3                                    /SIG7-4136/*E4985
         STW,RF   IDK1
         MTW,1    BCT0+20           ADD 1 TO INSERT COUNT
         MTW,1    INSERTSW           SET SW ON             /SIG7-1883/*D4985
         LW,X7    ACTION+1
         LW,R8    ACTION
         B        ID4
*
IDK1     B        ID9
*
ID9      LW,X7    OCSAV+6           GET ORIGINAL RECORD ADDRESS IN
         LW,8     OCSAV+7            REST BYTE CNT         /SIG7-6134/*F4985
         LW,RF    IDK1                  INPUT BUFFER
         XW,RF    ID1+3                                    /SIG7-4136/*E4985
         STW,RF   IDK1
         B        ID2
*
ID10     MTW,1    BCT0+21
         B        ID1+2
* THIS TESTS FOR REC-LEN-ABN (FROM DEBLOCKER) HIGHEST KEY MUST BE IN REC
*
ID12     MTW,0    EOFSW
         BNEZ     *9
         CW,8     KEYLOC
         BGE      *9
         LI,7     19
         B        SC5               ERROR ABORT
         PAGE
*
*  THIS ROUTINE SELECTS THE APPROPRIATE BLOCKER FOR A FILE
*        AND EXECUTES IT.
*  AT ENTRY TO OB1:
*        REGISTER 5=THE RETURN ADDRESS
*                 6=THE FCT ORDINATE FOR THE FILE
*                 7=THE FROM ADDRESS FOR A RECORD MOVE
*                 8=THE RECORDS LENGTH
*  AT EXIT THE REGISTERS ARE SET AS DESCRIBED IN THE EXIT
*        CONDITIONS FOR THE BLOCKERS
*
         PAGE
*
OBR1     DATA     0
*
OB1      STW,X5   OBR1              SAVE RETURN ADDRESS
KOB1     LB,X5    TCT0,X6           GET TYPE CODE:  OR EXECUTE OC
OB2      LW,X4    STV1,X5           BLOCKER ENTRY POINT
         BAL,X5   *X4               EXECUTE BLOCKER
OB25     B        *OBR1
*                      WHEN USER OWN CODE EXISTS THIS COMMAND
         PAGE
*
*  THIS ROUTINE DEBLOCKS RECORDS FROM SORT SCRATCH FILES.  IT
*  ASSUMES THAT ALL RECORDS ARE VARIABLE LENGTH RECORDS AND ARE
*  BEING READ IN THE REVERSE DIRECTION.
*
*  AT ENTRY TO SD1:
*        REGISTER 5=THE RETURN ADDRESS
*                 6=THE FCT ORDINATE FOR THE FILE
*                 7=THE TO ADDRESS IF A RECORD MOVE IS REQUESTED
*                   OR ZERO IF NO RECORD MOVE IS REQUIRED
*
         PAGE
*
SDR1     DATA     0
*
SD1      STW,X5   SDR1              SAVE ENTRY POINT
         CI,X7    0                 IS MOVE REQUESTED
         BNE      SD3               YES:  GO READ NAD MOVE RECORD
         BAL,X5   *STV0+5           NO:  GO READ RECORD
         B        *SDR1             EXIT:  NORMAL EXIT
SD2      LI,X7    0                 BLOCK LEN ABN          /SIG7-1162/*C4985
         B        SC5               GO ABORT               /SIG7-1162/*C4985
*
SD3      BAL,5    *STV1+5            DEBLOCKER WITH MOVE
         B        *SDR1             EXIT:  NORMAL EXIT
         B        SD2               GO PROCESS ERROR
*
         PAGE
*
*  AT ENTRY TO THESE ROUTINES (BLOCKERS AND DEBLOCKERS)
*        REGISTER 5=THE RETURN ADDRESS
*                 6=THE FCT ORDINATE
*                 7=THE 'TO ADDRESS' OR ZERO FOR A DEBLOCKER (BYTE)
*                   THE 'FROM ADDRESS' FOR A BLOCKER (BYTE)
*                 8=THE RECORD'S LENGTH IN BYTES FOR A BLOCKER
*                   THE RECORD'S LENGTH IS RETURNED IN REGISTER 8
*                   BY THE DEBLOCKERS
*
*  ENVIRONMENTAL ASSUMPTIONS ARE:
*                 FCT0=DCB ADDRESS FOR FILE
*                 FCT1=BUFFER ADDRESS AND AVAILABILITY BIT FOR
*                      LOGICAL RECORD PROCESSORS
*                 FCT2=BUFFER ADDRESS AND AVAILABILITY BIT FOR
*                      PHYSICAL RECORD PROCESSORS
*                 FCT3=CURRENT LOGICAL RECORD ADDRESS
*                 FCT4=LIMIT ADDRESS FOR BUFFER IN FCT1
*       WORD 0 OF FCT1=CURRENT ACTUAL BUFFER LENGTH FOR INPUT
*                 FCT2=CURRENT ACTUAL (MAX) BUFFER LENGTH
*                      FOR OUTPUT
*                 FCT3=LOGICAL RECORD LENGTH USED FOR INPUT
*                      (MAX FOR VARIABLE LENGTH RECORDS)
*                 FCT4=LOGICAL RECORD LENGTH USED FOR OUTPUT
*                      (MAX FOR VARIABLE LENGTH RECORDS)
*        SORT TRANSFER VECTOR=STV=BCT0+16,17,18 AND 19 SET TO
*                 BLOCKER OR DEBLOCKER ADDRESS
*                 VALUES IN STV ARE:
*                        DURING PHASES 1 AND 2
*                        STT+0=ADDRESS OF INPUT FILE DEBLOCKER
*                           +1=ADDRESS OF OUTPUT FILE BLOCKER
*                           +3=ADDRESS OF SORT FILE DEBLOCKER
*                           +4=ADDRESS OF SORT FILE BLOCKER
*                        DURING PHASE 3:
*                           +0 AND +3 ARE EXCHANGED
*                        DURING THE FINAL SUBPHASE OF PHASE 3
*                           +1 AND +4 ARE EXCHANGED
*
*  FIRST ENTRY CONDITIONS IN ADDITION TO THE ABOVE ARE:
*                 FCT1 SET NOT AVAILABLE BY OPEN
*                 FCT2 SET AVAILABLE BY OPEN
*
*
         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     FCT1,6            GET BEGIN OF BUFFER
         SLS,4    +8
         SLS,4    -8
         STW,4    BUFSAV            SAVE FOR BLK-CTL-MOVE
UBB1A    AW,10    8                 10 HAS TOTAL BLK-SIZE (BYTE)
         STW,10   LENCTL1
         BAL,13   MBLKWRD           MOVE BLK-LEN CTL WORD TO BUFF
         LW,11    BLKCTLSY          SOURCE RECORD ADDR
         AW,11    FCT3,6            UPDATA DEST BY BLK-CTL-SIZE
UBB2     LW,10    7                 SOURCE BYTE ADDR (REC)
         LW,R11   FCT3,X6           DESTINATION
         STW,R11  OBRAD             CURRENT RECORD'S BYRE ADDRESS
         LW,R12   R8                LENGTH
         AWM,R8   FCT3,X6           SET LIMIT FOR WRITE
         BAL,R9   RWMOV             GO MOVE RECORD
         BAL,X4   PW1               GO WRITE RECORD
         LW,4     FCT3,6            BUFF 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 BLOCKED FORMAT-RECORDS MAY BE OF
*        FIXED OR OF VARIABLE LENGTH.
*
BFVB1    RES      0
         LW,12    8                 SET LENGTH FOR MOVE COUNT
         LW,R10   X7                SOURCE
         AW,R8    FCT3,X6           CURRENT ADDRESS PLUS LENGTH
         CW,R8    FCT4,X6           IS THERE ROOM FOR THIS RECORD
         BLE      BFVB2             YES:  BYPASS PHYSICAL WRITE
         LW,R8    R12               NO:  RESET RECORD LENGTH
         BAL,4    PW1               PHYSICAL WRITE
         LW,R12   R8                SET LENGTH FOR MOVE
         LW,R10   X7                SET SOURCE FOR MOVE
         AW,R8    FCT3,X6           UPDATE CURRENT RECORD ADDRESS
BFVB2    LW,R11   FCT3,X6           DESTINATION
         STW,R11  OBRAD             CURRENT RECORD'S BYTE ADDRESS
         STW,R8   FCT3,X6           UPDATED CURRENT RECORD ADDRESS
BFVB3A   BAL,9    RWMOV              MOVE IT
         B        *X5               EXIT:  NORMAL OR ERROR
*
         PAGE
*
*  RECORDS ARE IN UNBLOCKED FORMAT AND BEING READ IN A FORWARD
*        DIRECTION-LOGICAL RECORD LENGTH=FCT4-FCT3(SET BY PR1)
*        NO RECORD MOVE IS ALLOWED AND THE CURRENT BUFFER IS
*        ASSUMED TO BE NOT AVAILABLE
*
UBDN1    LI,R8    0                 0 INDICATES FORWARD READ
         BAL,X4   PR1               GO GET FULL BUFFER
         MTW,0    ANSISWIN
         BEZ      UBDN2             NOT ANSI
         LW,8     BLKCTLSZ
         BEZ      UBDN2             NO BLK-CTL-WORD/S
         AWM,8    FCT3,6            UPDATE TO GET  BY BLK-CTL-WORD/S
UBDN2    LW,7     FCT3,6
         LW,R8    FCT4,X6           LIMIT ADDRESS
         SW,R8    X7                RECORD LENGTH
         B        *X5               EXIT:  NORMAL OR ABNORMAL
*
         PAGE
*
*  RECORDS ARE IN UNBLOCKED FORMAT AND ARE READ IN A BACKWARD
*        DIRECTION-LOGICAL RECORD LENGTH=FCT4-FCT3(SET BY PR1)
*        NO RECORD MOVE IS ALLOWED AND THE CURRENT BUFFER IS
*        ASSUMED TO BE NOT AVAILABLE
*
UBDNR1   LI,R8    1                 1 INDICATES BACKWARD READ
         BAL,X4   PR1               GO READ RECORD
         LW,X7    FCT3,X6           CURRENT RECORD ADDRESS
         LW,R8    X7                FCT1=LIMIT FOR READ BACKWARD
         SW,R8    FCT1,X6           RECORD LENGTH
         SW,X7    R8
         AI,X7    1
         MTW,0    FCT0,X6
         BL       *X5
         STW,X7   FCT1,X6           END OF FILE ADJUSTMENT
         B        *X5
*
         PAGE
*
*  RECORDS ARE IN BLOCKED FORMAT.  THEY ARE ASSUMED TO BE FIXED
*        LENGTH AND ARE READ IN A FORWARD DIRECTION-NO MOVE IS
*                 ALLOWED.
*
BFDN1    MTW,0    FCT1,X6           IS BUFFER AVAILABLE
         BGE      BFDN2             YES:  BYPASS PHYSICAL READ
         LI,R8    0                       0 MEANS FORWARD READ
         BAL,X4   PR1               NO:  GO GET FULL BUFFER
         MTW,0    ANSISWIN
         BEZ      BFDN2              NOT ANSI
         LW,8     BLKCTLSZ
         BEZ      BFDN2             NO BLK-CTL-WORD/S
         AWM,8    FCT3,6            UPDATA FOR FIRST LOGICAL REC
BFDN2    LW,R8    FCT3              INPUT LOGICAL RECORD LENGTH
         LW,X7    FCT3,X6           CURRENT RECORD ADDRESS
         B        BVDN3
*
         PAGE
*
*  RECORDS ARE IN BLOCKED FORMAT.  THEY ARE ASSUMED TO BE FIXED
*        LENGTH AND ARE READ IN A BACKWARD DIRECTION-NO MOVE IS
*                 ALLOWED.
*
BFDNR1   MTW,0    FCT1,X6           IS BUFFER AVAILABLE
         BGE      BFDNR2            YES:  BYPASS PHYSICAL READ
         LI,R8    1                       1 MEANS BACKWARD READ
         BAL,X4   PR1               NO:  GO GET FULL BUFFER
BFDNR2   LW,R8    FCT3              CURRENT RECORD LENGTH
         LW,X7    FCT3,X6           CURRENT RECORD HIGH ADDRESS
         B        BVDNR3
*
         PAGE
*
*  RECORDS ARE IN BLOCKED FORMAT.  THEY ARE ASSUMED TO BE VARIABLE
*        LENGTH AND ARE READ IN A FORWARD DIRECTION-NO MOVE IS
*                 ALLOWED.
*
BVDN1    MTW,0    FCT1,X6           IS BUFFER AVAILABLE
         BGE      BVDN2             YES:  BYPASS PHYSICAL READ
         LI,R8    0                       0 MEANS FORWARD READ
         BAL,X4   PR1               NO:  GO GET FULL BUFFER
BVDN2    LW,X7    FCT3,X6           CURRENT RECORD'S ADDRESS
         SLS,X7   -2
         LI,R8    X'FFFF'           RIGHT HALF WORD MASK
         AND,8    *7                REC LENGTH
         SLS,X7   2
* CODE DELETED
BVDN3    AWM,R8   FCT3,X6           UPDATE CURRENT RECORD ADDRESS
         LW,R9    FCT3,X6           UPDATED CURRENT RECORD ADDRESS
         CW,R9    FCT4,X6           IS WITHIN LIMIT
         BL       *X5               YES:  EXIT:  NORMAL EXIT
         BLE      BVDN4             NO:  EQUAL TO LIMIT
         MTW,0    FCT0,X6
         BG       *X5               FILE IS CLOSED:  EXIT
         AI,X5    1                 NO:  EXCEEDS LIMIT:  ERROR
BVDN4    LW,R9    =X'80000000'      SET SIGN BIT
         AWM,R9   FCT1,X6           SET BUFFER NOT AVAILABLE
         B        *X5               EXIT:  NORMAL OR ERROR
*
         PAGE
*
*
* RECORDS ARE READ IN BLOCKED VAR FORWARD FORMAT ANSI-TYPE-V
*
*
BVDVN1   MTW,0    FCT1,6               IS BUFFER AVAILABLE
         BGE      BVDVN2            YES SKIP PHYSICAL READ
         LI,8     0                 0 FOR FORWARD  READ
         BAL,4    PR1                 PHY READ
         STW,8    BLKLENRD          LEN OF BLK READ (VAR)
         LW,4     BLKCTLSZ          ADD LEN OF BLK CTL WORDS
         STW,4    BLKLENCT          ADD TO COMPUTE BLK SIZE
         AI,4     4                 ADD LEN OF REC CTL  WORD
         AWM,4    FCT3,6            ADDR OF FIRST LOG REC
BVDVN2   LW,7     FCT3,6
         LW,4     FCT3,6             CURR  REC ADDR (BYTE)
         AI,4     -4                BACK  TO REC LEN WORD
         STW,4    9                 SAVE FOR LATER
         STW,5    SAVE5
         SAD,4    -2                 BITS TO R5
         SCS,5    2                  BITS TO R SIDE OF R5
         AND,5    =X'03'
         LB,8     *4,5              4 IS NOW WORD ADDR
         SLS,8    +8
         STW,8    SAVEIT            HOLD L BYTE OF LENGTH
         AI,5     1                 UP INDEX
         LB,8     *4,5
         AW,8     SAVEIT
         LW,5     SAVE5
         LW,4     9                 RESTORE REC BYTE ADDR
* TO RECONSTRUCT LENGTH FOR ANSI V (NECCESSARY) DUE TO BYTE ADDR
         AWM,8    BLKLENCT
         AW,4     8                 ADD LEN TO GET BEGIN OF NEXT REC
         AI,4     4                 GO  PAST CTL WORD FOR REC ADDR
         STW,4    FCT3,6            NOW  HAS UPDATED  REC ADDR IN BYTES
         AI,8     -4
         LW,4     BLKLENCT          COMPUTED BLK SIZE OF REC PROCESSED
         CW,4     BLKLENRD           TO BLK SIZE READ (VAR)
         BL       *5                YES EXIT
         BE       BVDVN3            END OF BUFFER
         MTW,0    FCT0,6
         BG       *5                 FILE IS CLOSED EXIT
         AI,5     1                 ERROR EXCEEDES LIMIT
BVDVN3   LW,9     =X'80000000'       SET SIGN BIT
         AWM,9    FCT1,6             SET BUFFER NOT AVAIL
         B        *5                EXIT NORMAL OR ERROR
         PAGE
         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     FCT1,6
         SLS,4    +8
         SLS,4    -8
         STW,4    BUFSAV            BEGIN BUF ADDR
         LW,4     BLKCTLSY           LEN OF BLK-CTL-WORD/S
         AWM,4    FCT3,6
         STW,4    LENCTL1
BVBV0    LW,12    8                  RECORD LENGTH
         AI,12    4                  PLUS 4 BYTES FOR REC-CTL-WORD
         AW,12    FCT3,6            ADD CURR REC ADDR TO LENGTH
         CW,12    FCT4,6            IS IT PAST BUFFER LIMIT
         BLE      BVBV1             NO, SO JUST MOVE THE RECORD
         BAL,13   MBLKWRD           MOVE BLK-LEN CTL WORD TO BUFF
         BAL,4    PW1               PHYSICAL WRITE
         LW,4     FCT1,6            NEW BUFF BASE ADDR
         SLS,4    +8
         SLS,4    -8                CLEAR FIRST BYTE
         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   FCT3,6            UPDATE BEGIN OF REC ADDR
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    FCT3,6            BYTE ADDR OF BUF FOR THIS CTL-WORD
         LI,12    4                 4 BYTE LENGTH
         BAL,9    RWMOV             MOVE IT
         LW,12    FCT3,6             BYTE ADDR
         AI,12    4                 UP FOR REC JUST MOVED (REC-LEN)
         STW,12   FCT3,6            NOW HAS BEG ADDR FOR REC ITSELF
         STW,12   OBRAD             USED IN S:SORTP2
         LW,12    8                 REC LENGTH
         LW,11    FCT3,6            DEST ADDR (BYTE) BUFFER-AREA
         LW,10    7                 SOURCE ADDR (BYTE)
         AW,8     11                ADD ADDR (DEST) TO LENGTH
         STW,8    FCT3,6            UPDATE FOR NEXT REC DESTIN
         BAL,9    RWMOV             MOVE REC TO BUFFER
         B        *5                EXIT
*
*  RECORDS ARE IN BLOCKED FORMAT.  THEY ARE ASSUMED TO BE VARIABLE
*        LENGTH AND ARE READ IN A BACKWARD DIRECTION-NO MOVE IS
*                 ALLOWED
*
BVDR1    RES      0
BVDNR1   MTW,0    FCT1,X6           IS BUFFER AVAILABLE
         BGE      BVDNR2            YES:  BYPASS PHYSICAL READ
         LI,R8    1                       1 MEANS BACKWARD READ
         BAL,X4   PR1               NO:  GO GET FULL BUFFER
BVDNR2   LW,X7    FCT3,X6           RECORD'S HIGH ADDRESS
         LI,R8    X'FFFF'           RIGHT HALF WORD MASK
         SLS,X7   -2
         AND,R8   *X7               LENGTH
         LW,X7    FCT3,X6
BVDNR3   MTW,0    FCT0,X6
         BG       BVDNR5            GO INITIALIZE BUFFER ADDRESSES
         SW,X7    R8                RECORD'S BEGINNING ADDRESS NINUS U
         STW,X7   FCT3,X6           UPDATE RECORD'S HIGH ADDRESS
         AI,X7    1                 SET TO BEGINNING ADDRESS
         LW,R9    FCT3,X6           UPDATED RECORD ADDRESS
         CW,R9    FCT1,X6           IS RECORD WITHIN LIMITS
         BG       *X5               GREATER THAN LOWER LIMIT
         BGE      BVDNR4            BRANCH IF EQUAL TO LOWER LIMIT
         AI,X5    1                 SET UP FOR ERROR EXIT
BVDNR4   LW,R9    =X'80000000'      SET SIGN BIT
         AWM,R9   FCT1,X6           SET BUFFER NOT AVAILABLE
         B        *X5
*
BVDNR5   LW,R10   FCT4,X6           REVERSE BASE ADDRESS
         AI,R10   1
         STW,R10  FCT4,X6           THE FILE IS CLOSED
         STW,R10  FCT3,X6               INITIALIZE BUFFER ADDRESSES
         SW,R10   FCT1                      FOR NEXT OPEN
         STW,R10  FCT1,X6                       AND EXIT
         B        *X5
         PAGE
*
*  AT ENTRY TO PR1:
*
*        REGISTER 4=THE RETURN ADDRESS
*                 5=THE RETURN ADDRESS FOR THE DEBLOCKER
*                 6=THE FCT ORDINATE FOR THE FILE
*                 7=NOT USED
*                 8=FORWARD/BACKWARD READ INDICATOR
*                 9-12=NOT USED
*
*    ENVIRONMENTAL CONDITIONS ARE IDENTICAL TO THOSE LISTED FOR
*                 THE BLOCKERS AND THE DEBLOCKERS.
*
*        NOTE:    FCT1 AND FCT4 EXCHANGE USAGES WHEN A READ
*                 BACKWARD OPERATION IS SPECIFIED
*
         PAGE
DIRECT   DATA,4   0
*
PR1      LW,R13   FCT1              READ LENGTH
         STW,R13  BFSIZE
         LI,R13   X'FFFF'
         AND,R13  FCT0,X6           DCB ADDRESS
         SLS,R13  1
         STW,R13  SORTSD
*        CODE DELETED                                      /SIG7-5426/*F4985
         LI,R9    PRA1
         STW,R9   OCH+3             SET ABNORMAL RETURN
         LI,R9    PRE1
         STW,R9   OCH+2             SET ERROR RETURN
         STW,R8   DIRECT
         BAL,R9   OCHK              PERFORM READ CHECK
         BAL,R9   OCHK              CHECK AGAIN FOR EOF    /SIG7-1036/*C4985
         LW,R8    CRSF              CHECK IF CO-RESIDENT
         BNEZ     PRV1              YES.
         LW,R8    DIRECT
PR3      CI,R8    1                 IS A FORWARD READ REQUESTED
         BE       PRV1              NO:  GO PERFORM REVERSE READ
*  PROCESS FORWARD READ HERE
         LW,R8    FCT1,X6           BUFFER ADDRESS
         STW,R8   BFLOC                 FOR FORWARD READ
         LI,X3    8
         LH,R8    *SORTSD,X3        ACTUAL RECORD SIZE
         AND,R8   =X'FFFE'
         SLS,R8   -1
         MTW,0    FCT0,X6           HAS FILE BEEN CLOSED
         BGE      PRF2              YES:  GO SWAP BUFFERS
*        THE FOLLOWING INSTRUCTION IS CHANGED AT EOR       /SIG7-1036/*C4985
PRF1     BAL,R9   ORDF              INITIATE FORWARD READ  /SIG7-1036/*C4985
PRF2     LW,R13   FCT1,X6           EXCHANGE BUFFERS
         OR,R13   =X'80000000'               AND
         XW,R13   FCT2,X6                    SET
         AND,R13  =X'7FFFFFFF'      CURRENT RECORD SDDRESS
         STW,R13  FCT1,X6                    AND
         STW,R13  FCT3,X6          BUFFER LIMIT
         AW,R13   R8
         STW,R13  FCT4,X6
         MTW,0    FCT0,6             HAS FILE BEEN CLOSED
         BGE      %+2               YES
         B        *4
         LH,7     CCT0,1            WHAT PHASE
         CI,7     3
         BGE      *4                EXIT
         MTW,1    EOFSW
         B        *4
*
*
         PAGE
*  PROCESS REVERSE READ HERE
PRV1     LW,R13   FCT4,X6           UPPER BASE BUFFER ADDRESS
         SW,R13   FCT1              MINUS MAXIMUM LENGTH
         AI,R13   1                     PLUS 1
         STW,R13  BFLOC             =BEGINNING ADDRESS
         LI,X3    8
         LH,R8    *SORTSD,X3        ACTUAL RECORD SIZE (ARS)
         AND,R8   =X'FFFE'
         LI,3     X'3F00'           TYPE FIELD MASK
         AND,3    *SORTSD,1         SEE TYPE FIELD WORD 1
         CI,3     X'900'            7T
         BNE      %+2
         AND,R8   =X'FFF8'          FOR PACKED 7T
         SLS,R8   -1
         LW,14    FCT0,6            DCB ADDR
         SLS,14   1                 TO WORDS
         LW,14    *14               WORD 1 OF DCB
         AND,14   =X'F'             DEV ASSSIGNMENT
         CI,14    3
         BL       PRV3              DEV 1 + 2 (SHRT BLK GOES IN NORMAL)
         LW,14    FCT0,6            DCB ADDR
         SLS,14   1                 TO WORDS
         LW,14    *14,1             WORD 1 OF DCB
         AND,14   =X'3F00'          GET TYPE FIELD
         CI,14    X'900'            FOR 7T TAPE
         BE       PRV3              7T (SHORT BLOCK GOES IN NORMAL)
         MTW,0    FCT0,X6           HAS FILE BEEN CLOSED
         BGE      PRV2              YES:  GO SWAP BUFFERS
         BAL,R9   ORDR              INITIATE REVERSE READ
PRV2     OR,R13   =X'80000000'      EXCHANGE FCT1 AND FCT2
         XW,R13   FCT2,X6               WITH NOT AVAILABLE SET
         AND,R13  =X'7FFFFFFF'      REMOVE NOT AVAILABLE INDICATOR
         AW,R13   FCT1              BEGINNING LOC PLUS LENGTH
         AI,R13   -1                    MINUS 1
         STW,R13  FCT4,X6           =BEGINNING ADDRESS FOR BUFFER
         STW,R13  FCT3,X6               (UPPER ADDRESS)
         SW,R13   R8                SET LIMIT
         STW,R13  FCT1,X6                  INTO FCT1
         B        *X4               EXIT:  NORMAL
*
PRV3     OR,R13   =X'80000000'      SET NOT AVAILABLE
         XW,R13   FCT2,X6           EXCHANGE FCT1AND FCT2
         AND,R13  =X'7FFFFFFF'
         AI,R13   -1
         STW,R13  FCT1,X6           LIMITTING BYTE ADDRESS
         AW,R13   R8
         STW,R13  FCT3,X6           CURRENT BUFFER LOCATION
         LW,R15   FCT1,X6           LIMIT BYRE ADDRESS
         AW,R15   FCT1
         STW,R15  FCT4,X6
         LW,14    FCT0,6            DCB ADDR
         SLS,14   1                 TO WORDS
         LW,14    *14               WORD 0 OF DCB
         AND,14   =X'F'             GET DEV-TYPE
         CI,R14   1                 IF NOT RAD--FILE MARK WILL SIGNAL
         BNE      PRV4                  EXECUTION OF CLOSE
         STW,X4   CSIR
         LW,R14   FCT1,X6
         AI,R14   5
         SLS,R14  -2
         LW,R13   *R14
         CW,R13   =C'T EN'
         BE       CSI2
         CW,R13   =C'T F '
         BE       CSI17
PRV4     MTW,0    FCT0,X6           IS FILE OPEN
         BGE      PRV5              NO
         BAL,R9   ORDR
PRV5     B        *X4
*
         PAGE
*
PW1      LI,R9    X'FFFF'
         AND,R9   FCT0,X6           DCB ADDRESS
         SLS,R9   1
         STW,R9   SORTSD
         LI,R9    X'7FFFF'          REMOVE SIGN BIT
         AND,R9   FCT1,X6           BUFFER BASE ADDRESS
         STW,R9   BFLOC             LOCATION
         LW,R10   FCT3,X6
         SW,R10   R9
         STW,R10  BFSIZE            ACTUAL SIZE
         AND,9    =X'7FFFF'                                /SIG7-6003/*F4985
         STW,9    FCT3,6                                   /SIG7-6003/*F4985
*        CODE DELETED                                      /SIG7-5426/*F4985
*    CODE DELETED                                          /SIG7-6003/*F4985
         LI,R9    PWA1
         STW,R9   OCH+3             SET ABNORMAL RETURN
         LI,R9    PWE1
         STW,R9   OCH+2             SET ERROR RETURN
         BAL,R9   OCHK              CHECK WRITE
*    CODE DELETED                                          /SIG7-6003/*F4985
PW3      LW,R13   FCT1,X6           FULL BUFFER'S ADDRESS
         OR,R13   =X'80000000'      SET SIGN BIT
         XW,R13   FCT2,X6           EXHCANGE BUFFERS
         AND,R13  =X'7FFFFFFF'      REMOVE SIGN BIT
         STW,R13  FCT1,X6           SET NEW BUFFER BASE
         STW,R13  FCT3,X6           SET NEW AVAILABLE BYTE
         AW,R13   FCT2              PLUS OUTPUT LENGTH
         STW,R13  FCT4,X6           =NEW LIMIT LOCATION
PW4      BAL,R9   OWRT              INITIATE PHYSICAL WRITE
         B        *X4
         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      INABN            NO.
SPECRD3  RES      0
         LW,8     =C'!EOD'          BANG EOD FOR SSP11 TO TEST
         STW,8    *MASAD           SET EOD INTO RECORD AREA
         B        SPECRD1          EXIT
*
SPECPT   LCI      3
         STM,R8   ACTSAV
         M:WRITE  M:LL,(BUF,*WORK),(SIZE,80),WAIT
         LCI      3
         LM,R8    ACTSAV
         B        *R9
*
ORDF     BAL,R10  BATWD
         MTW,0    INSERTSW          TEST IF INSERT         /SIG7-1883/*D4985
         BNEZ     ORD1                                     /SIG7-1883/*D4985
         M:READ   *SORTSD,(BUF,*BFLOC),(SIZE,*BFSIZE),(BTD,*7)
ORD1     LCI      4
         LM,X7    ACTSAV
         B        *R9
*
ORDR     BAL,R10  BATWD
*        LINES 1586 THROUGH 1595   REMOVED FOR UTS
         M:READ   *SORTSD,(BUF,*BFLOC),(SIZE,*BFSIZE),;
                  (BTD,*7),(REV)
         B        ORD1
*
OWRT     BAL,R10  BATWD
         M:WRITE  *SORTSD,(BUF,*BFLOC),(SIZE,*BFSIZE),(BTD,*7)
         B        ORD1
OCHK     LCI      4
         STM,X7   DACTSAV           SAVE REGS              /SIG7-0735/*C4985
         BAL,R10  NOCHK            SEE IF I/O IS COMPLETED
,OCH     M:CHECK  *SORTSD,(ABN,OCH1),(ERR,OCH1)      WAIT  /SIG7-2127/*D4985
OCH1     LCI      4                                        /SIG7-2127/*D4985
         LM,X7    DACTSAV           RESTORE REGS           /SIG7-0735/*C4985
         B        *R9               RETURN
*
COCHK    LCI      4
         STM,X7   CACTSAV
         BAL,R10  NOCHK            SEE IF I/O IS COMPLETED
,COCH    M:CHECK  *SORTSD,(ABN,OWF1),(ERR,OWF1)    IGN ERR /SIG7-2127/*D4985
         B        OWF1
*
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
*
*
OWRH     LCI      4
         STM,X7   CACTSAV
         M:WRITE  *SORTSD,(BUF,HEDBUF),(SIZE,20),(BTD,0)
         LCI      4
         LM,X7    CACTSAV
         B        *R10
*
CSRDR    LCI      4
         STM,X7   CACTSV
*        LINES 1650 THROUGH 1660   REMOVED FOR UTS
CSRDR2   M:READ   *SORTSD,(BUF,BUFTMP),(SIZE,20),;         /SIG7-3820/*E4985
                  (REV),(BTD,0)
         BAL,R10  NOCHK            SEE IF I/O IS COMPLETED
         M:CHECK  *SORTSD,(ABN,CSRDR2A),(ERR,CSRDR2A)      /SIG7-3820/*E4985
CSRDR2A  B        OWF1                                     /SIG7-3820/*E4985
EOSFVR   DATA     0
*
EOSFV    STW,R10  EOSFVR
         LI,R9    20
         STW,R9   BFSIZE                LABEL
         LW,9     FCT0,6            DCB ADDR
         SLS,9    1                 TO WORDS
         LW,9     *9                WORD 0 OF DCB
         AND,9    =X'F'             GET DEV-TYPE
         CI,R9    1
         BE       EOSFV6
         BAL,R9   OWFM              GO WRITE FILE MARK
         M:CHECK  *SORTSD,(ABN,EOSF10),(ERR,EOSF10)        /SIG7-3820/*E4985
EOSF10   BAL,9    OWRT                                     /SIG7-3820/*E4985
         BAL,R10  NOCHK            SEE IF I/O IS COMPLETED
         M:CHECK  *SORTSD,(ABN,EOSF11),(ERR,EOSF11)        /SIG7-3820/*E4985
EOSF11   BAL,9    OWFM                                     /SIG7-3820/*E4985
EOSFV3   LI,R9    EOSFV5
         STW,R9   COCH+2
         STW,R9   COCH+3
         BAL,R9   COCHK
EOSFV5   B        *EOSFVR
EOSFV6   BAL,R9   OWRT
         B        EOSFV3
*
EOFRW    LCI      4                 THIS ROUTIN CLOSES A VOLUME
         STM,X7   CACTSAV
         M:CVOL   *SORTSD
         B        OWF1
*
CICL     LCI      4                 CLOSE AN INPUT FILE
         STM,X7   CACTSV
         M:CLOSE  *SORTSD,(REM)                            /SIG7-1687/*D4985
         M:DEVICE *SORTSD,(BIN)
         B        OWF1
*
CVOPEN   LCI      4                 OPEN NEXT VOLUME
         STM,X7   CACTSV
,COFPT   M:OPEN   *SORTSD,(VOL,1)
         B        OWF1
*
POSEND   LCI      4
         STM,X7   CACTSV
POSE1    M:PFIL   *SORTSD,(EOF)
         LI,R9    BUFTMP
         STW,R9   BFLOC
         LI,R9    20
         STW,R9   BFSIZE
         M:READ   *SORTSD,(BUF,*BFLOC),(SIZE,*BFSIZE),;
                  (BTD,0)                                  /SIG7-3820/*E4985
         BAL,R10  NOCHK            SEE IF I/O IS COMPLETED
         M:CHECK  *SORTSD,(ABN,POSE2),(ERR,POSE2)          /SIG7-3820/*E4985
POSE2    RES      0
         LW,R9    BUFTMP+1
         CW,R9    =C'T T '
         BNE      POSE1
         B        OWF1
*
*        THIS ROUTINE CHECKS THE FCN AND TYC PARAMETERS OF THE
*        DCB TO INSURE THE LAST I/O ON THIS DCB HAS BEEN
*        COMPLETED.  IF COMPLETED RETURN TO M:CHECK+1
*        ELSE RETURN TO M:CHECK
*
NOCHK    RES      0
         LI,X7    7                CHECK FCN PARAMETER
         LW,R9    *SORTSD,X7       IN DCB
         AND,R9   MFCN
         BNEZ     *R10             FCN NOT EQUAL ZERO   GO CHECK
         LI,X7    2                GET TYC PARAMETER
         LW,R9    *SORTSD,X7       IN DCB
         AND,R9   MTYC
         CW,R9    TYC1             EQUAL TO 1?
         BG       *R10             NO. GO CHECK
         AI,R10   1                NO CHECK NEEDED
         B        *R10             BRANCH AROUND CHECK
*
TYC1     DATA     X'20000'
MFCN     DATA     X'FF000000'
MTYC     DATA     X'FE0000'
*
         PAGE
*
PRE1     LB,R9    SR3               PUT ERROR CONDITION INTO R9
         STW,SR3  ERRCD             SAVE ERROR CODE AND SUB-CODE
         CI,9     X'75'
         BNE      %+3
         LI,7     1
         B        SC5
         CI,9     X'4E'             ANSI BLK CNT ERROR RETURN
         BE       PRE81
         CI,R9    X'57'
         BNE      PRE12                                    /SIG7-1162/*C4985
         MTW,0    IO57M:DO          HAVE WE BEEN HERE FROM EXITCTL
         BNE      PRE11
         MTW,0    IO57M:LL          SEE IF SET
         BNE      PRE11
         BAL,8    EXITCTL5          SEE IF M:DO TO A FILE
PRE11    RES      0
         LI,X7    10                UNABLE TO SWITHCH      /SIG7-1162/*C4985
         B        SC5               GO ABORT               /SIG7-1162/*C4985
PRE12    CI,R9    X'41'             IS IT IREC. READ       /SIG7-1162/*C4985
         BNE      PRE13             NO CHECK FOR 46        /SIG7-2592/*E4985
         LW,X7    CRSF              CHECK IF CO-RESIDENT
         BNEZ     PRE125
         LB,9     10,1               SEE SUB CODE
         SLS,9    -1                BITS 7 HAVE CODE
         CI,9     X'05'               EOF ?
         BE       PRA2
         CI,9     X'06'
         BE       PRA2
* ANSI TAPES GET 41 XX (SUBCDE) WHEN BLK COUNT ON INPUT NOT EQUAL
* AND USER HAS ABCERR ON INPUT ASSIGN CARD
*  SUBCODE HAS EOF RETURN. FOR D00 UTS WILL CHANGE FROM 41 TO 4C
         LW,R9    =X'400000'        YES:  IS THE DROP BAD BLOCK
         AND,R9   BCT0+8            OPTION SPECIFIED
         BE       PRE14
PRE125   RES      0
         LI,X7    1                 I/O ERROR              /SIG7-1162/*C4985
         B        SC5               GO ABORT               /SIG7-1162/*C4985
PRE13    CI,9     X'46'                                    /SIG7-2592/*E4985
         BNE      PRE125            DEFAULT TO IO ERRROR
         LI,7     12                  INSUFF INFO ABORT    /SIG7-2592/*E4985
         B        SC5                                      /SIG7-2592/*E4985
*
PRE14    LH,RF    CCT0,X1
         CI,RF    3
         BGE      PRE18             GO POSITION IN REV DIRECTION
* CODE DELETED                                             /SIG7-1594/*D4985
         B        PRE2
* CODE DELETED                                             /SIG7-1594/*D4985
PRE18    EQU      %                                        /SIG7-1594/D*4985
*
PRE2     XW,X3    SR1
         M:PRINT  (MESS,SKBB)       PRINT: DROPPED BLOCK
         LW,RD    BFSIZE            GET REQUESTED REC LEN  /SIG7-1163/*C4985
         LI,R9    X'F'              IS THE INPUT FILE A SORT
         AND,R9   CCT0                  SCRATCH FILE
         CI,R9    2
         BG       PRE3              PRINT ALL              /SIG7-1163/*C4985
         LI,RD    132               PRINT ONLY ONE LINE    /SIG7-1163/*C4985
PRE3     LW,R9    BFSIZE                                   /SIG7-1163/*C4985
         CI,R9    133               PRINT ONLY THE RECORD  /SIG7-1163/*C4985
         BL       PRE4              IF IT IS LESS THAN     /SIG7-1163/*C4985
         LI,R9    132                  132 CHARACTERS      /SIG7-1163/*C4985
PRE4     LI,RE    X'7FFFF'                                 /SIG7-1163/*C4985
         AND,RE   FCT2,X6           BUFFER ADDRESS         /SIG7-1163/*C4985
PRE5     LW,RF    RE                RECORD BYTE ADDRESS
         AI,RD    -132              DECREMENT RECORD LENGTH
         AI,RE    132               INCREMENT RECORD ADDRESS
PRE6     BAL,R10  OPRNT             GO PRINT BUFFER RECORD
         CI,RD    132
         BGE      PRE5              132 OR MORE CHARACTERS TO GO
         CI,RD    0
         BLE      PRE7              NOT GREATER THAN ZERO
         LW,R9    RD
         LI,RD    0
         LW,RF    RE
         B        PRE6
*
PRE7     XW,X4    KPRE
         XW,X3    SR1               RESTORE X3
         B        *SR1              GO FINISH CURRENT READ
*
KPRE     DATA,4   PRE8
*
PRE8     XW,X4    KPRE              RESET PR1 EXIT
         LI,R8    1
         LI,R9    X'F'
         AND,R9   CCT0              TEST FOR INTERNAL SORT
         CI,R9    2                     OR FOR MERGE
         BG       %+2               SET R8 = 0 OR 1 ACCORDINGLY
         LI,R8    0
         LW,R9    =X'80000000'      GO READ NEXT BLOCK
         OR,R9    FCT1,X6
         B        PR1
*
PRE81    LB,9     10,1                SEE SUBCODE
         SLS,9    -1                LEFT 7 BITS OF BYTE HAVE SUBCDE
         CI,9     0                 EOT
         BE       PRA2
         CI,9     7                 EOF
         BE       PRA2              IT IS EOF
         B        *8                IGNORE
*
*
PRA1     LB,R9    SR3               SET ERROR CODE INTO R9
         STW,SR3  ERRCD            SAVE ERROR CODE AND SUB-CODE
         CI,R9    X'7'                   LOST DATA
         BNE      PRA15             NO: CHECK FOR EOT      /SIG7-1162/*C4985
         LW,R9    CRSF              CHECK IF CO-RESIDENT
         BNEZ     PRA13             YES.
         LW,R9    =X'400000'        YES: IS DROP BLOCK     /SIG7-1162/*C4985
         AND,R9   BCT0+8               OPTION SPECIFIED    /SIG7-1162/*C4985
         BE       PRE2              YES                    /SIG7-1162/*C4985
PRA13    RES      0
         LI,X7    1                 NO: I/O ERROR          /SIG7-1162/*C4985
         B        SC5               GO ABORT               /SIG7-1162/*C4985
PRA15    CI,9     X'5'                IS IT EOD            /SIG7-1687/*D4985
         BE       PRA2
         CI,9     X'1C'
         BE       *8                LET 05/06 CATCH IT
         CI,R9    X'6'              NO:  IS IT END OF FILE
         BNE      *SR1              NO:  IGNORE CONDITION
PRA2     STW,X5   TMPLOC            SAVE MAJOR EXIT
         STW,X4   TMPLOC+1          SAVE INTER MEDIATE EXIT
         STW,SR1  TMPLOC+2          SAVE MINOR EXIT
         LH,X5    CCT0,X1
         CI,X5    3
         BGE      PRA4
         LW,X5    CRSF              CHECK IF CO-RESIDENT
         BNEZ     PRA3              YES.
         BAL,X5   CI1               GO SWAP REELS--OR CLOSE FILE
PRA3     LW,X5    TMPLOC
         LW,X4    TMPLOC+1                 EXITS
         B        *TMPLOC+2         AND RETURN
*
PRA4     BAL,X5   CSI
         B        PRA3
*
*
         PAGE
*
PWE1     LB,R9    SR3
         STW,SR3  ERRCD            SAVE ERROR CODE AND SUB-CODE
         CI,R9    X'45'
         BNE      PWE3
         LI,7     1                   I/O ERROR
         B        SC5               ABORT
PWE3     CI,R9    X'57'
         BNE      PWE4                                     /SIG7-2592/*E4985
         MTW,0    IO57M:DO          HAVE WE BEEN HERE FROM EXITCTL
         BNE      PWE31
         MTW,0    IO57M:LL          SEE IF SET
         BNE      PWE31
         BAL,8    EXITCTL5          SEE IF M:DO TO A FILE
PWE31    RES      0
         LI,X7    10                DISC SATURATED         /SIG7-1162/*C4985
         B        SC5               GO ABORT               /SIG7-1162/*C4985
*
PWE4     CI,9     X'47'                                    /SIG7-2592/*E4985
         BNE      *SR1                                     /SIG7-2592/*E4985
         LI,7     12                CAN'T OPEN CLOSED DCB  /SIG7-2592/*E4985
         B        SC5               FOR WRITE.. ABORT      /SIG7-2592/*E4985
*                                                          /SIG7-2592/*E4985
PWA1     LB,R9    SR3
         STW,SR3  ERRCD            SAVE ERROR CODE AND SUB-CODE
         CI,R9    X'1C'             IF NOT END OF TAPE
         BNE      *SR1                  IGNORE
         MTW,0    MONTYP
         BEZ      PWA11             NOT FROM EXCON
         MTW,1    8                 UP RETURN ADDR TO SKIP PRA1
PWA11    RES      0
         LW,9     BFLOC                                    /SIG7-1687/*D4985
         STW,9    BFTMP                                    /SIG7-1687/*D4985
         LW,9     BFSIZE                                   /SIG7-1687/*D4985
         STW,9    BFTMP+1                                  /SIG7-1687/*D4985
         LW,R9    CRSF              CHECK IF CO-RESIDENT
         BNEZ     PWA15             YES.
         LI,R9    X'F'
         AND,R9   CCT0
PWA15    RES      0
         STW,X7   TMPLOC+3
         LW,7     FCT1,6                                   /SIG7-3820/*E4985
         STW,7    FCT3,6           INHIBIT CLOSE WRITE CALL/SIG7-3820/*E4985
* CODE DELETED                                             /SIG7-6003/*F4985
         LI,X7    2                 CLOSE VOLUME
         STW,X5   TMPLOC            SAVE MAJOR EXIT
         STW,X4   TMPLOC+1          SAVE INTERMEDIATE EXIT
         STW,SR1  TMPLOC+2          SAVE MINOR EXIT
         LW,X5    CRSF              CHECK IF CO-RESIDENT
         BNEZ     PWA4              YES.
         CI,R9    3
         BG       PWA2              FINAL OUTPUT SUBPHASE
         LW,8     DACTSAV+1         SAVE LENGTH            /SIG7-6003/*F4985
         BAL,X5   CSO               CLOSE SCRATCH OUTPUT
         B        PWA3
PWA2     BAL,X5   CO1               CLOSE FINAL OUTPUT VOLUME
PWA3     LW,X5    TMPLOC
         LW,X4    TMPLOC+1
         LW,7     FCT1,6                                   /SIG7-6003/*F4985
         AW,7     BFTMP+1                                  /SIG7-6003/*F4985
         STW,7    FCT3,6                                   /SIG7-6003/*F4985
PWA5     RES      0
         LW,X7    TMPLOC+3
         LW,9     BFTMP                                    /SIG7-1687/*D4985
         STW,9    BFLOC                                    /SIG7-1687/*D4985
         LW,9     BFTMP+1                                  /SIG7-1687/*D4985
         STW,9    BFSIZE                                   /SIG7-1687/*D4985
         B        *TMPLOC+2
*
PWA4     RES      0
         BAL,X5   CSO
         LW,X5    TMPLOC
         LW,X4    TMPLOC+1
         B        PWA5
         PAGE
INABN    LB,RF    SR3
         CI,RF    X'4'
         BG       INA2
INA1     LI,X7    12                INS INFO IN DCB        /SIG7-1162/*C4985
         B        SC5               GO ABORT               /SIG7-1162/*C4985
INA2     CI,RF    X'14'
         BE       INA1
         CI,15    X'1D'
         BE       INA1
         CI,15    X'0E'
         BE       INA1
         CI,15    X'0D'
         BE       INA1
         CI,RF    X'8'
         BE       INA1
         CI,15    X'1C'
         BE       *8
         CI,15    7
         BLE      *8
         CI,15    X'0A'
         BE       *8
         CI,RF    X'2E'
         BNE      PRA13
         LI,X7    13                FILE ALREADY OPEN      /SIG7-1162/*C4985
         B        SC5               GO ABORT               /SIG7-1162/*C4985
OTABN    EQU      INABN
*
         PAGE
*
MFDN1    MTW,0    FCT1,X6           IS BUFFER AVAILABLE
         BGE      MFDN2             YES:  BYPASS PHYSICAL READ
         LI,R8    0                 0 MEANS FORWARD READ
         BAL,X4   PR1               GO READ PHYSICAL RECORD
         MTW,0    FCT0,X6           IS FILE OPEN
         BGE      *5                NO:  EXIT
         LI,X7    X'7FFFF'
         AND,X7   FCT1,X6           BASE ADDRESS
         SLS,X7   -2                BASE ADDRESS
         AW,X7     FMAN             PLUS WORD  DISPLACEMENT
         LI,R8    X'FFFF'               INTO X7
         AND,R8   0,X7
         BE       MFDN1+2
         SLS,R8   2                 CONVERT TO BYTE DISPLACEMENT
         AW,R8    FCT1,X6           ADD BASE
         STW,R8   FCT3,X6           STORE AS CURRENT RECORD ADDRESS
MFDN2    LI,X7    0
         MTW,0    FCT0,X6
         BGE      *5
         LW,X7    FCT3,X6
         LW,R8    X7
         SLS,R8   -2                AS A WORD ADDRESS
         LH,R9    *R8               POINTER TO NEXT RECORD
         BNE      MFDN3             IS IT ZERO:  NO:  MORE RECORDS
         LW,R9    =X'80000000'      YES:  SET BUFFER NOT AVAILABLE
         OR,R9    FCT1,X6
         STW,R9   FCT1,X6
         B        MFDN4
MFDN3    SLS,R9   2                 CONVERT TO BYTE ADDRESS
         AW,R9    FCT1,X6           DEVELOPE CURRENT RECORD ADDRESS
         STW,R9   FCT3,X6               FOR NEXT TIME
MFDN4    LW,R8    FCT3              RECORD LENGTH
         B        *X5
*
         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
*
EBCBNR   DATA     0
*
*
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
         BNE      EBCB2             NON-ZERO
         AI,X7    1
         CI,X7    3
         BG       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
         BG       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'
         BNE      *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        SC5               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
         LI,RB    31
         SW,RB    X7
         AI,RB    BA(ALFTRAN1)
         SLD,X4   2
         STW,X4   RA
         STB,X7   RB
         STH,X6   EXMBS,X1          STORE OFFSET                        CTSRTP
         EXU      EXMBS             DO THE MBS TIMING PROB              CTSRTP
         LI,RB    31
         SW,RB    X7
         AI,RB    BA(ALFTRAN2)
         STW,X5   RA
         STB,X7   RB
         SLD,X4   -2
         STH,X6   EXMBS,X1                                              CTSRTP
         EXU      EXMBS             DO THE MBS TIMING PROB              CTSRTP
         B        *R0
*
EVDED    PACK,0   ALFTRAN2
         BCS,8    DECTRP              ABORT ON BAD KEY
         DST,0    ALFTRAN2
         PACK,0   ALFTRAN1
EVDEC    RES      0
         BCS,8    DECTRP              ABORT ON BAD KEY
         DC,0     ALFTRAN2
         BNE      *R1
         B        *R0
*
EVDEA    PACK,0   ALFTRAN1
         BCS,8    DECTRP              ABORT ON BAD KEY
         DST,0    ALFTRAN1
         PACK,0   ALFTRAN2
         BCS,8    DECTRP              ABORT ON BAD KEY
         DC,0     ALFTRAN1
         BNE      *R1
         B        *R0
*
EXMBS    MBS,RA   0                 MOVE IT                             CTSRTP
         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,RF   DCLR+1
         STW,X1   SAVEREG1         SAVE INDEX
         LI,X1    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 REG 1
         SLD,X4   -2                BYTE TO WORD
*  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
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
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
ATRAN1   STW,X7   DCLR
         STW,RB   DCLR+1
         STW,X1   SAVEREG1
         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
         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

