         PROC  &P,0,&INDEXED=                                           IS$00010
IS$LOAD  NAME                                                           IS$00020
         GBL   &IS$E               LOAD$                                IS$00030
         DO    '&IS$E'=''                                               IS$00040
&IS$E    SET   0                                                        IS$00050
         EJECT                                                          IS$00060
*                                                                       IS$00070
DH$LOAD  EQU   *                                                        IS$00080
         TM    DC$REQS,X'86'            LOAD CALL FOR WAIT              IS$00090
         BO    DL$LDWT                  YES, BR                         IS$00100
         MVI   DH$FG2,X'02'             SET WRITE NEWKEY BIT            IS$00110
         BAL   12,DH$CKSZ               SET SPB AND VALIDATE SIZE       IS$00120
         TM    DC$FG2,X'80'             IS IT KEYED FILE?               IS$00130
         BZ    DL$NKF                   BR IF NO KEYS                   IS$00140
         LTR   14,14                                                    IS$00150
         BNP   DH$ER18                  BR IF UNDERSIZE REC             IS$00160
         LH    10,DH$KLC                START PREP FOR KEY TEST         IS$00170
         L     8,DH$A1                                                  IS$00180
         AH    8,DH$NMH+3               R8 AT BUF REC START             IS$00190
         AR    8,10                                                     IS$00200
         A     10,DH$LWA                READY FOR NORMAL KEY TEST       IS$00210
         TM    DH$LFG4,X'80'                                            IS$00220
         BZ    DL$KEYT                  BR IF XTEND BIT NOT SET         IS$00230
         TM    DC$FG1,X'08'                                             IS$00240
         BZ    DL$KEYT                  BR IF NOT INDEXED               IS$00250
         L     8,DH$INDA                                                IS$00260
DL$KEYT  EQU   *                                                        IS$00270
         LH    14,DH$KSZ                                                IS$00280
         EX    14,DL$CLCK                                               IS$00290
         BL    DL$NKF                                                   IS$00300
         BH    DH$ER37                  SEQ ERR                         IS$00310
         EX    14,DL$KZCK                                               IS$00320
         BZ    DH$ER24                  IF WA KEY ZERO, OUTSIDE LIMS    IS$00330
         OI    DC$NMC+3,X'04'                                           IS$00340
         B     DH$ER36                  DUPE ERR                        IS$00350
DL$KZCK  EQU   *                                                        IS$00360
         OC    0(1,10),0(10)            EX INSTR                        IS$00370
DL$CLCK  EQU   *                                                        IS$00380
         CLC   0(1,8),0(10)             EX KEY COMPARE                  IS$00390
DL$EX1   EQU   *                                                        IS$00400
         MVC   0(1,4),0(5)              EX KEY MOVE                     IS$00410
DL$PTR   EQU   *                                                        IS$00420
         DC    X'F0AAAA'                CANNED POINTER                  IS$00430
         DC    X'AAAA00'                                                IS$00440
DL$NKF   EQU   *                                                        IS$00450
         TM    DH$LFG4,X'80'            EXTEND FLAG SET ?               IS$00451
         BNO   DL$NKF1                  NO                              IS$00452
         MVC   DH$PID+3(2),DH$BSZ       FORCE END OF BLOCK CONDITION    IS$00453
DL$NKF1  EQU   *                                                        IS$00454
         NI    DH$LFG4,X'7F'            CLR EXTEND BIT                  IS$00460
         LH    8,DH$BSZ                                                 IS$00470
         SH    8,DH$PID+3                                               IS$00480
         SH    8,DH$RDS                                                 IS$00490
         SH    8,DH$SPB                                                 IS$00500
         BM    DL$MREJ                  BR IF REC WONT FIT              IS$00510
DL$NEL2  EQU   *                                                        IS$00520
         TM    DC$FG2,X'02'                                             IS$00530
         BNZ   DL$NEL4                  IF 2 BUFS, SKIP WAIT            IS$00540
         BAL   3,DL$WAITX                                               IS$00550
DL$NEL4  EQU   *                                                        IS$00560
         L     9,DH$A1                  BUF ADR                         IS$00570
         LH    11,DH$SPB                REC SIZE                        IS$00580
         LH    3,DH$CFB                                                 IS$00590
         STH   3,DH$NMH+3               OLD CFB IS NEW REC START        IS$00600
         AR    3,11                     R3 HAS OFFSET TO NEW POINTER    IS$00610
         LA    6,0(3,9)                                                 IS$00620
         MVC   0(5,6),DL$PTR            FILL IN POINTER                 IS$00630
         AH    3,DH$RDS                                                 IS$00640
         STH   3,0(9)                   NEW CFB TO BUFF                 IS$00650
         AH    9,DH$CFB                                                 IS$00660
         STH   3,DH$CFB                 NEW CFB TO CFB AND PID+3        IS$00670
         STH   3,DH$PID+3                                               IS$00680
         L     6,DH$NMP-1                                               IS$00690
         LA    6,1(6)                                                   IS$00700
         ST    6,DH$NMP-1               NUMB PRIMES INCR                IS$00710
DL$2LA   EQU   *                                                        IS$00720
         L     10,DH$LWA                ORIGIN TO R10                   IS$00730
         LA    6,256                                                    IS$00740
DL$2LC   EQU   *                                                        IS$00750
         SR    11,6                                                     IS$00760
         BP    DL$3LC                   BR IF MORE THAN 256 LEFT        IS$00770
         AR    11,6                                                     IS$00780
         BCTR  11,0                                                     IS$00790
         EX    11,DL$2LB                MOVE FRACTIONAL PART            IS$00800
         B     DH$CXT                                                   IS$00810
DL$2LB   MVC   0(1,9),0(10)             EX                              IS$00820
DL$3LC   EQU   *                                                        IS$00830
         MVC   0(256,9),0(10)           MOVE 256 BYTES                  IS$00840
         AR    9,6                                                      IS$00850
         AR    10,6                     REGISTERS                       IS$00860
         B     DL$2LC                                                   IS$00870
*                                                                       IS$00880
*                                                                       IS$00890
*                                                                       IS$00900
DL$MREJ  EQU   *                                                        IS$00910
         BAL   3,DL$WAITX                                               IS$00920
         LA    14,1(14)                                                 IS$00930
         ST    14,DH$PID-1              PID RESET UP 1                  IS$00940
         MVC   DH$PID+3(2),DH$BHB                                       IS$00950
         TM    DC$FG3,X'01'                                             IS$00960
         BZ    DL$NEOC                  BR IF NO OVERFLOW               IS$00970
         L     9,DH$A1                                                  IS$00980
         L     3,DH$PCAID                                               IS$00990
         SR    2,2                                                      IS$01000
         STH   2,DH$BPC-2                                               IS$01010
         D     2,DH$BPC-2                                               IS$01020
         SH    2,DH$PDLC                                                IS$01030
         BM    DL$NEOC                  BR IF NOT LAST PRIME OF CYL     IS$01040
         SH    14,DH$PDLC                                               IS$01050
         AH    14,DH$BPC                                                IS$01060
         ST    14,DH$PID-1              PID AT NEXT CYL                 IS$01070
         AH    9,DH$CFB                                                 IS$01080
         SH    9,DH$RDS                                                 IS$01090
         CLI   0(9),X'F0'                                               IS$01100
         BNE   DL$NEOC                  DO NOT OVERLAY UNLESS F0        IS$01110
         MVC   0(5,9),DH$PID                                            IS$01120
         OI    0(9),X'80'               SPECIAL POINTER DONE            IS$01130
DL$NEOC  EQU   *                                                        IS$01140
         MVC   DH$CFB(2),DH$BHB         RESET CFB                       IS$01150
         BAL   3,DL$WRTD                WRITE DATA BLK                  IS$01160
         L     4,DH$IOA1                                                IS$01170
         TM    DC$FG2,X'02'                                             IS$01180
         BZ    DL$EFL                   BR IF ONE BUF                   IS$01190
         CLC   DH$IOA2(4),DH$A1                                         IS$01200
         BE    DL$STBA                  BR IF IOA2 JUST WRITTEN         IS$01210
         L     4,DH$IOA2                                                IS$01220
DL$STBA  EQU   *                                                        IS$01230
         ST    4,DH$A1                  STORE ALT BUF ADDR              IS$01240
DL$EFL   EQU   *                                                        IS$01250
         TM    DC$FG1,X'08'        IS THIS FILE AN INDEXED FILE?        IS$01260
         BZ    DL$NIX              IF NOT JUMP OVER                     IS$01270
*                                                                       IS$01280
         LH    6,DH$KSZ            R6 - KEYSIZE-1                       IS$01290
         L     4,DH$INDA           R4 - ADDRESS OF INDEX BUFFER         IS$01300
         LA    7,256                                                    IS$01310
         LH    8,DH$BID+3                                               IS$01320
         SR    7,8                      R7 HAS SPACE REMAINING          IS$01330
         LA    3,4(6)                   R3 HAS ENTRY SIZE               IS$01340
         SR    7,3                                                      IS$01350
         BM    DL$FULN                  BR IF NOT ROOM FOR ENTRY        IS$01360
         AR    4,8                                                      IS$01370
         AR    3,8                                                      IS$01380
DL$FULN  EQU   *                                                        IS$01390
         STH   3,DH$BID+3               RESET SPACE IN USE              IS$01400
         LR    10,4                                                     IS$01410
         L     5,DH$LWA                                                 IS$01420
         AH    5,DH$KLC                                                 IS$01430
         EX    6,DL$EX1            MOVE KEY TO ENTRY POSN IN INDEX      IS$01440
         AH    4,DH$KSZ            INCREMENT R4 TO POINT TO LAST BYTE   IS$01450
         MVC   1(3,4),DH$NMH       MOVE IN 3 BYTE INDEX POINTER         IS$01460
*                                       OF KEY IN INDEX BUFFER          IS$01470
DL$KHD   SR    5,5                 CLEAR R5                             IS$01480
         IC    5,0(4)              INSERT ONE BYTE FROM KEY             IS$01490
         BCTR  5,0                 SUBTRACT 1 FROM R5                   IS$01500
         STC   5,0(4)              PUT IT BACK WHERE IT CAME FROM       IS$01510
         LTR   5,5                 LET CONTENTS OF R5 SET COND CODE     IS$01520
         BNM   DL$HOP              IF SUBT CAUSED -VE RESULT, FALL THRU IS$01530
         CR    4,10                COMPARE IF WHOLE KEY TAKEN CARE OF   IS$01540
         BC    13,DH$ER39               BR = OR < ILLOGICAL FILE COND.  IS$01550
         BCT   4,DL$KHD                 R4-1 AND BR                     IS$01560
DL$HOP   EQU   *                                                        IS$01570
         C     10,DH$INDA                                               IS$01580
         BE    DL$IW                    BR TO WRITE INDEX               IS$01590
DL$NIX   EQU   *                                                        IS$01600
         MVC   DH$NMH(3),DH$PID         UPDATE FILENAME-H               IS$01610
         B     DL$NEL2                  TO POST RECORD                  IS$01620
DL$IW    EQU   *                                                        IS$01630
         BAL   3,DL$WAITX          CALL WAIT ROUTINE                    IS$01640
         BAL   3,DL$WRTI                                                IS$01650
         L     3,DH$BID-1               INCREMENT DH$BID.RRR            IS$01660
         LA    3,1(3)                                                   IS$01670
         ST    3,DH$BID-1               INITIALIZE DH$BID               IS$01680
         B     DL$NIX                                                   IS$01690
DL$WAITX EQU   *                                                        IS$01700
         TM    DC$MFLG,X'40'                                            IS$01710
         BZ    DL$BYPS                  BR IF WAIT NOT REQD             IS$01720
         MVI   DC$REQS,X'86'                                            IS$01730
         OI    DH$FG2,X'02'             SET WRT NEWKEY BIT              IS$01740
         B     DL$WRTA                                                  IS$01750
DL$WRTD  EQU   *                                                        IS$01760
         LA    12,DH$PCAID              SET DATA PARTITION              IS$01770
         B     DL$WRTF                                                  IS$01780
DL$WRTI  EQU   *                                                        IS$01790
         LA    12,DC$CID2               SET INDEX PARTITION             IS$01800
DL$WRTF  EQU   *                                                        IS$01810
         MVI   DC$REQS,X'20'            CODE FOR WRITE                  IS$01820
DL$WRTA  EQU   *                                                        IS$01830
         L     15,DC$RELOC                                              IS$01840
         BALR  14,15                    TO SAT                          IS$01850
         L     15,16(13)                RESTORE R15                     IS$01860
DL$BYPS  EQU   *                                                        IS$01870
         MVC   DC$CID2(4),DH$BID-1      SET UP FOR SUBSEQ WRITE         IS$01880
         L     14,DH$PID-1                                              IS$01890
         ST    14,DH$PCAID                                              IS$01900
         BR    3                                                        IS$01910
DL$LDWT  EQU   *                                                        IS$01920
         BAL   3,DL$WAITX                                               IS$01930
         BAL   3,DL$WRTD                WRT FINAL PRIME BLK             IS$01940
         BAL   3,DL$WAITX                                               IS$01950
         TM    DC$FG1,X'08'                                             IS$01960
         BZ    DH$CXT                   BR IF NOT INDEXED               IS$01970
         L     5,DH$BID-1               ADDR OF FINAL BI BLK            IS$01980
         LH    7,DC$LCE2                                                IS$01990
         LA    7,3(0,7)                                                 IS$02000
         ST    7,DH$PCAID               TEMP ENTRY SIZE                 IS$02010
         LA    7,256                                                    IS$02020
         SR    6,6                                                      IS$02030
         D     6,DH$PCAID               R7 HAS SLOTS/BLK                IS$02040
         M     6,DC$BPT2                                                IS$02050
         ST    7,DH$PCAID               PCAID HAS SLOTS PER TRK         IS$02060
         AR    7,7                                                      IS$02070
         CLI   DC$BPT2+3,X'28'                                          IS$02080
         BE    DL$F32                                                   IS$02090
         AR    7,7                                                      IS$02100
DL$F32   EQU   *                        R7 HAS SLOTS OF TOP             IS$02110
         SR    8,8                                                      IS$02120
         LR    9,5                      BI BLK TO BE WRITTEN            IS$02130
         SH    9,DH$NMG+1               BI LOBK                         IS$02140
         A     9,DC$BPT2                                                IS$02150
         D     8,DC$BPT2                R9 HAS NUMB BI TRKS             IS$02160
         LA    4,1                                                      IS$02170
         CR    9,7                      BI TRKS VS TOP SLOTS            IS$02180
         BNH   DL$F37                   BR IF NO INTERMED REQD          IS$02190
         M     6,DH$PCAID               TOP SLOT TIMES SLOTS PER TRK    IS$02200
         CR    9,7                                                      IS$02210
         BH    DL$F34                   BR IF SUPER REQD                IS$02220
DL$F33   EQU   *                                                        IS$02230
         LA    3,1                      SET R3 TO CAUSE FALL THRU       IS$02240
         D     6,DH$PCAID               R7 BACK TO NUMB TOP SLOTS       IS$02250
         SR    9,7                                                      IS$02260
         AI    DH$PCAID+2,-1            REDUCE SLOTS PER TRACK          IS$02270
DL$F34   EQU   *                                                        IS$02280
         A     9,DH$PCAID                                               IS$02290
         BCTR  9,0                                                      IS$02300
         SR    8,8                                                      IS$02310
         D     8,DH$PCAID                                               IS$02320
         AR    4,9                                                      IS$02330
         BCT   3,DL$F33                 LOOP TO FINAL PHASE             IS$02340
DL$F37   EQU   *                                                        IS$02350
         ST    5,DC$CID2                                                IS$02360
         BAL   3,DL$WRTI                WRITE UNFINISHED BLK            IS$02370
         BAL   3,DL$WAITX               WAIT                            IS$02380
         A     5,DC$BPT2                                                IS$02390
         BCT   4,DL$F37                 LOOP IF NOT DONE                IS$02400
         B     DH$CXT                                                   IS$02410
*                                                                       IS$02420
         ENDO                                                           IS$02430
         END                                                            IS$02440
