*DECK,AAMDNRO 
*CALL COMUSETXT 
PROC AAM$NRO; 
      BEGIN 
                                                                         SAAMNRO
     XREF BEGIN                                                          SAAMNRO
          PROC MUVW$AA ;                                                 SAAMNRO
          PROC LOCB$AA ;                                                 SAAMNRO
          PROC FIXX$AA ;                                                 SAAMNRO
          PROC IMPR$AA; 
          PROC MOVC$AA ;                                                 SAAMNRO
          PROC MOVW$AA ;                                                 SAAMNRO
          FUNC UUCC$AA ;                                                 SAAMNRO
          PROC MERR ;                                                    SAAMNRO
          FUNC LWAD$AA ;                                                 SAAMNRO
          PROC SETR$AA ;                                                 SAAMNRO
          PROC RPGT$AA ;                                                 SAAMNRO
          PROC OWN$AA ;                                                  AFB0528
          PROC LKEY$AA ;                                                 AFB0528
          PROC INCH$AA ;                                                 SAAMNRO
          PROC ALTR$AA ;                                                 SAAMNRO
          PROC IOWR$AA ;                                                 SAAMNRO
          PROC TRN1$IS;                                                  VBG1026
          PROC MSGF$AA ;
          PROC ER$SRM ; 
          PROC EXRP$AA ;
          PROC MSGZ$AA; 
          PROC LGFS$AA; 
          LABEL EXIT$AA;
          END                                                            SAAMNRO
                                                                         SAAMNRO
CONTROL WEAK TRN1$IS,ER$SRM;
                                                                         JJJ0724
     XDEF BEGIN                                                          SAAMNRO
          PROC DELL$AA ;                                                 SAAMNRO
          PROC ATEI$AA;                                                  RPN0615
          PROC ADRC$AA ;                                                 SAAMNRO
          PROC SLOG$AA ;                                                006200
          PROC VOKM$AA; 
          PROC NUBL$AA ;                                                 SAAMNRO
          PROC CMRC$AA ;                                                 AFB0528
          PROC RCKN$AA ;                                                 SAAMNRO
          PROC RPPT$AA ;                                                 SAAMNRO
          PROC XXUR$AA ;                                                 SAAMNRO
          PROC CONS$AA ;                                                 SAAMNRO
          PROC DUPK$AA ;
          END                                                            SAAMNRO
                                                                         SAAMNRO
                                                                         SAAMNRO
          ITEM IX;           #USED AS AN INDUCTION VARIABLE#             SAMNROM
          ITEM ENUM;
CONTROL EJECT;                                                           ID0913 
PROC ADRC$AA;                                                            SAMNROM
          BEGIN                                                          SAMNROM
                                                                         ID0913 
 #                                                                       ID0913 
* *   ADRC$AA - INSERT OR REPLACE A RECORD IN A BLOCK          PAGE 1    ID0913 
* *   A.F.R.BROWN                                                        ID0913 
* 1DC ADRC$AA                                                            ID0913 
*                                                                        ID0913 
* DC  FUNCTION                                                           ID0913 
*                                                                        ID0913 
*     TO INSERT A NEW RECORD IN A BLOCK, OR TO REPLACE AN EXISTING       ID0913 
*     RECORD WITH A NEW ONE, ON THE ASSUMPTION THAT THERE IS ROOM IN     ID0913 
*     THE BLOCK.                                                         ID0913 
*                                                                        ID0913 
*     IN AN I-S INDEX BLOCK, THE NEW RECORD IS A GROUP OF 1, 2, OR 3     ID0913 
*     CONSECUTIVE RECORDS (NRECINS CONTAINS THE COUNT), BUT THIS         ID0913 
*     ROUTINE IS UNAWARE OF THE FACT. AN INDEX BLOCK IS ALWAYS MARKED    ID0913 
*     AS HAVING UNIFORM RECORDS, BUT THIS ROUTINE TAKES THE LENGTH       ID0913 
*     OF THE ((RECORD)) FROM VARIABLE NEWLG RATHER THAN FROM ITS MORE    ID0913 
*     GENERAL KNOWLEDGE OF THE LENGTH AN INDEX RECORD IN THE GIVEN       ID0913 
*     FILE MUST HAVE.                                                    ID0913 
*                                                                        ID0913 
* DC  ENTRY CONDITIONS                                                   ID0913 
*                                                                        ID0913 
*     FUNCT = 0 FOR REPLACE, OR 1 FOR INSERT.                            ID0913 
*     NEWFWA IS THE FWA OF THE NEW RECORD.                               ID0913 
*     NEWLNG IS ITS LENGTH IN CHARACTERS.                                CY210
*     OUTKEY IS THE NUMBER OF WORDS OF NON-EMBEDDED KEY THAT ARE TO      ID0913 
*       PRECEDE THE RECORD PROPER, AS STORED IN THE BLOCK. MAY BE 0.     ID0913 
*     IF OUTKEY IS NOT 0, KEYFWA AND KEYOFF GIVE THE ADDRESS AND         CY210
*       THE STARTING CHARACTER POSITION OF THE PRIMARY KEY VALUE,        CY210
*       WHICH IS NOT-EMBEDDED, BUT TO BE STORED JUST AHEAD OF THE        CY210
*       RECORD PROPER.                                                   CY210
*     RECFWA IS THE ADDRESS AT WHICH THE NEW RECORD IS TO BE             ID0913 
*       STORED IN THE BLOCK. THIS IS THE FWA OF THE RECORD TO BE         ID0913 
*       REPLACED, OR THE FWA OF THE RECORD BEFORE WHICH THE NEW RECORD   ID0913 
*       IS TO BE INSERTED, OR THE LWA+1 OF THE LAST RECORD OF THE BLOCK  ID0913 
*       IF THE NEW RECORD IS TO BE ADDED AFTER IT, OR THE FWA OF RECORD  ID0913 
*       SPACE IN THE CURRENT BLOCK, IF IT IS EMPTY UNTIL THIS INSERTION. ID0913 
*     RECLG IS THE LENGTH IN WORDS OF THE RECORD TO BE REPLACED, IF THIS ID0913 
*       IS A REPLACEMENT.                                                ID0913 
*     RNO IS THE NUMBER OF THE CURRENT RECORD, I.E. THE RECORD OF        CY210
*       WHICH RECFWA IS THE FWA.                                         CY210
*     TEMPLOFF AND TEMPOS GIVE THE OFFSET, IN WORDS AND CHARACTERS,      CY210
*       BETWEEN THE START OF ANY RECORD IN THIS BLOCK AND THE            CY210
*       START OF ITS PRIMARY KEY.                                        CY210
*     QEI, QFR, AND QLR IN THE PTREE SHOULD BE CORRECTLY SET ACCORDING   ID0913 
*       TO THE CURRENT RECORD, WHICH IS THE ONE TO BE REPLACED OR        ID0913 
*       INSERTED-BEFORE. QEI WOULD BE 1 ONLY FOR ADDING A RECORD AFTER   ID0913 
*       THE LAST ONE IN THE FILE.                                        ID0913 
*     BARREN = 0 IF THE NEW RECORD DOES NOT CONTAIN A SUB-FILE HEADER    ID0913 
*       (THE USUAL CASE) OR 1 IF IT DOES (ONLY NOW AND THEN IN MIP).     ID0913 
*       THE ONLY SIGNIFICANCE OF BARREN TO ADRC$AA IS THAT IF IT IS      ID0913 
*       1, THE NEW RECORD MUST BE TREATED AS NON-UNIFORM EVEN IF IT      ID0913 
*       APPEARS TO BE THE RIGHT SIZE AND SHAPE.                          ID0913 
*     FTKA[0] AND FTKP[0] LOCATE THE START OF THE KEY, IF THIS IS A FILE ID0913 
*       WITH NON-EMBEDDED KEYS.                                          ID0913 
*                                                                        ID0913 
*     THERE MUST BE ROOM IN THE CURRENT BLOCK FOR THE INSERTION OR       ID0913 
*     REPLACEMENT, ALLOWING FOR ADDITIONAL RECORD POINTERS IF            ID0913 
*     DE-UNIFORMIZATION HAS TO BE DONE.                                  ID0913 
* 
*     IT IS POSSIBLE THAT THERE IS ROOM IN THE BLOCK ALL RIGHT, BUT 
*     THAT A LARGER RECORD, WHICH IS GOING TO BE REPLACED BY A SMALLER
*     RECORD, MUST BE PARTLY SQUEEZED OUT BEFORE CALLING XXUR$AA TO 
*     GENERATE A FULL SET OF RECORD POINTERS. OTHERWISE THERE WILL NOT
*     BE ROOM FOR THE NEW POINTERS, AND XXUR$AA WILL DECLARE A FATAL
*     ERROR. THIS IS A RARE CASE. IT IS DETECTED BEFORE CALLING 
*     XXUR$AA, AND WE SET ANOMALY=1 INSTEAD OF CALLING XXUR$AA. 
*     THE CALL TO XXUR$AA IS THEN MADE AT THE EARLIEST TIME WHEN THERE
*     WILL BE ROOM FOR XXUR$AA TO WORK. IF ANOMALY IS SET TO 1, 
*     TLN2 IS NECESSARILY NEGATIVE (OTHERWISE THERE WOULD NOT HAVE BEEN 
*     ROOM IN THE BLOCK FOR WHAT ADRC$AA IS DOING, AND THIS WOULD HAVE
*     BEEN DETECTED ON A PREVIOUS CALL TO RCKN$AA) AND SO WE CANNOT 
*     AVOID GOING THROUGH THE CODE WHERE XXUR$AA WILL BE CALLED LATE. 
*                                                                        ID0913 
* DC  EXIT CONDITIONS                                                    ID0913 
*                                                                        ID0913 
*     THE NEW RECORD HAS BEEN PUT INTO THE BLOCK, RECORD POINTERS        ID0913 
*     HAVE BEEN CHANGED ACCORDINGLY, AND THE RECORD COUNT AND EMPTY      ID0913 
*     SPACE COUNT IN THE BLOCK HEADER HAVE BEEN ADJUSTED.                ID0913 
*                                                                        ID0913 
*     UNIFORMITY OF RECORDS HAS BEEN ENDED IF UR WAS 1 ON ENTRY,         ID0913 
*     AND EITHER BARREN WAS NON-ZERO OR THE NEW RECORD HAD A             ID0913 
*     DIFFERENT LENGTH FROM THE EXISTING ONES.                           ID0913 
*                                                                        CY210
*     UR HAS BEEN SET TO 1 IF INDEXFLAG=1, OR IF BARREN IS 0 AND         CY210
*       RC IS FINALLY 1.                                                 CY210
*                                                                        ID0913 
*     THE FILE OR SUBFILE IS NOW CONSIDERED TO BE POSITIONED AT THE      ID0913 
*     NEW RECORD, AND RNO IS SET ACCORDINGLY. IF THIS WAS AN ADDITION    ID0913 
*     OR A RECORD AT THE END OF THE FILE, QEI WILL BE 0 AND QLR WILL     ID0913 
*     BE 1. IF IT WAS AN ADDITION TO THE END OF THE CURRENT BLOCK,       ID0913 
*     THE RECORD NUMBER IN THE CURRENT WORD OF THE PTREE WILL HAVE BEEN  ID0913 
*     INCREASED BY 1.                                                    ID0913 
*                                                                        ID0913 
*     RECFWA WILL BE THE FWA OF THE NEW RECORD. BUT RECLWA AND RECLG     ID0913 
*       ARE NOT CORRECT.                                                 ID0913 
*                                                                        ID0913 
*     IF BARREN WAS NON-ZERO, THE SUB-FILE FLAG IN THE RECORD POINTER    ID0913 
*       FOR THE NEW RECORD HAS BEEN SET TO 1, OTHERWISE 0.               ID0913 
*                                                                        CY210
*     TEMPLOC IS THE ADDRESS OF THE WORD IN WHICH THE PRIMARY KEY        CY210
*       OF THE NEW RECORD, AFTER BEING STORED IN THE BLOCK,BEGINS.       CY210
*                                                                        CY210
*     BLCIP[0] IS SET TO 0 AFTER ALL OTHER CHANGES HAVE BEEN MADE TO THE CY210
*       BLOCK. IT WILL HAVE BEEN SET TO 1 BY THE FIRST CALL TO ALTR$AA.  CY210
*                                                                        ID0913 
* DC  ERROR CONDITIONS                                                   ID0913 
*                                                                        ID0913 
*     NONE                                                               ID0913 
*                                                                        ID0913 
* DC  CALLED ROUTINES                                                    ID0913 
*                                                                        ID0913 
*     ALTR$AA - TO DO THE FORMALITIES BEFORE ALTERING THE BLOCK IMAGE.   ID0913 
*     RPGT$AA - TO FETCH RECORD POINTERS.                                ID0913 
*     RPPT$AA - TO PUT RECORD POINTERS INTO THE BLOCK.                   ID0913 
*     XXUR$AA - TO END UNIFORMITY, IF NECESSARY.                         ID0913 
*     MUVW$AA - TO MOVE THE RECORDS THAT WILL FOLLOW THE NEW ONE IN      ID0913 
*       THE BLOCK, BACKWARDS OR FORWARDS AS NECESSARY.                   ID0913 
*     MOVW$AA - TO MOVE THE NEW RECORD INTO THE BLOCK.                   ID0913 
*     MOVC$AA - TO MOVE THE NEW KEY INTO THE BLOCK,IF NON-EMBEDDED.      ID0913 
*     TRN1$IS - TO TRANSLATE EMBEDDED SYMBOLIC KEYS.                     VBG1026
*     LWAD$AA - TO FIND THE LWA OF A GIVEN RECORD IN THE BLOCK.          CY210
*                                                                        ID0913 
* DC  NON-LOCAL VARIABLES                                                ID0913 
*                                                                        ID0913 
*     IX IS USED AS AN INDUCTION VARIABLE.                               ID0913 
*     RECPTR IS USED TO COPY RECORD POINTERS INTO, OR TO BUILD           CY210
*       NEW ONES IN.                                                     CY210
*                                                                        ID0913 
 #                                                                       ID0913 
CONTROL EJECT;                                                           JJJ0209
                                                                         JJJ0209
          ITEM TLN2;         #LENGTH IN WORDS#                           SAMNROM
          ITEM TLNW;         #LENGTH IN WORDS#                           SAMNROM
          ITEM TUCC;         #TEMPORARY UCC#                             SAMNROM
          ITEM DESTIN;       #DESTINATION#                               SAMNROM
          ITEM ANOMALY ;
                                                                         SAMNROM
                             #START OF ADRC$AA CODE#                     ID0913 
          ALTR$AA ;                                                      SAAMNRO
          TLNW = WLG(NEWLNG);                                            SAMNROM
          TUCC = TLNW * WC - NEWLNG ;                                    DABBLE 
          IF INDEXFLAG EQ 0    THEN TLNW = TLNW + OUTKEY;                SAMNROM
          IF RC EQ 0 THEN RNO = 1 ;                                      SAAMNRO
          IF FUNCT EQ 0                                                  SAAMNRO
            THEN  TLN2 = TLNW - RECLNG;                                  SAMNROM
            ELSE  TLN2 = TLNW;                                           SAMNROM
          IF RNO LQ RC                                                   SAAMNRO
            THEN DESTIN = LWAD$AA ( RNO - FUNCT ) ;                      SAAMNRO
            ELSE BEGIN                                                   SAAMNRO
              IF QEI NQ 0                                                SAAMNRO
                THEN BEGIN                                               SAAMNRO
                  QEI = 0 ;                                              SAAMNRO
                  QLR = 1 ;                                              SAAMNRO
                  IF RECCNT EQ 0 THEN QFR = 1 ;                          SAAMNRO
                END                                                      SAAMNRO
              DESTIN = LWAD$AA ( RC ) ;                                  SAAMNRO
              RNO = RC + 1 ;                                             SAAMNRO
              PTCUREC[CURPTR] = RNO ;                                    SAAMNRO
              RECFWA = DESTIN + BLOCFWA ;                                SAAMNRO
            END                                                          SAAMNRO
          ANOMALY = 0 ; 
          IF UR NQ 0 AND INDEXFLAG EQ 0 AND RC NQ 0                      SAAMNRO
            THEN BEGIN                                                   SAAMNRO
              RPGT$AA ( 1 ) ;                                            SAAMNRO
              IF LWAFIELD NQ TLNW OR UCCFIELD NQ TUCC OR BARREN NQ 0     SAMNROM
               OR (CMPREC NQ RPCMP AND BLMIPBLK[0] EQ 0)
                THEN BEGIN
                  IF EC GQ RC-1 
                    THEN XXUR$AA ;
                    ELSE ANOMALY = 1 ;
                END 
            END                                                          SAAMNRO
                                                                         SAAMNRO
          IF TLN2 NQ 0                                                   SAMNROM
            THEN BEGIN                                                   SAAMNRO
              IX = EC - 2 * TLN2 ;                                       CREATEM
              IF IX LS 0
              THEN
                  BEGIN 
                  IMPOSSIBLE ( ECNEG ) ;
                  END 
              EC = IX ;                                                  CREATEM
              IF FACREATE[0] NQ 0 THEN GOTO INSRB ;                      CREATEM
              MUVW$AA (DESTIN+BLOCFWA, LWAD$AA(RC)-DESTIN, TLN2);        SAMNROM
              IF ANOMALY NQ 0 THEN XXUR$AA ;
              IF UR EQ 0                                                 JJJ1116
              THEN                                                       SAMNROM
                BEGIN                                                    SAMNROM
                FOR IX = RC STEP -1 UNTIL RNO                            SAMNROM
                  DO                                                     SAMNROM
                  BEGIN                                                  SAMNROM
                  RPGT$AA (IX);                                          SAMNROM
                  RECPTR = RECPTR+TLN2;                                  JJJ1129
                  RPPT$AA (IX+FUNCT);                                    SAMNROM
                  END                                                    SAMNROM
                END                                                      SAAMNRO
            END                                                          SAAMNRO
     INSRB:                                                              CREATEM
          IF OUTKEY EQ 0 OR INDEXFLAG NQ 0                               SAAMNRO
            THEN  MOVW$AA (NEWFWA, TLNW, RECFWA);                        SAMNROM
            ELSE BEGIN                                                   SAAMNRO
              MOVC$AA ( KEYFWA,KEYOFF,RECFWA,0,WC*OUTKEY ) ;             DABBLE 
              MOVW$AA (NEWFWA, TLNW-OUTKEY, RECFWA+OUTKEY);              SAMNROM
            END                                                          SAAMNRO
          IF UR EQ 0                                                     SAAMNRO
          THEN
              BEGIN 
              IX = EC - FUNCT;
              IF IX LS 0
              THEN
                  BEGIN 
                  IMPOSSIBLE(ECNEG);
                  END 
              EC = IX;
              RECPTR = 0 ;                                               SAAMNRO
              LWAFIELD = RECFWA - BLOCFWA + TLNW;                        SAMNROM
              UCCFIELD = TUCC;                                           SAMNROM
              SUBFLAG = BARREN ;                                         SAAMNRO
              IF BLMIPBLK[0] EQ 0 
                THEN RPCMP = CMPREC ; 
              RPPT$AA ( RNO ) ;                                          SAAMNRO
            END                                                          SAAMNRO
          TEMPLOC = RECFWA + TEMPLOFF ; 
          IF OUTKEY EQ 0 AND INDEXFLAG EQ 0                              AFB0528
           AND FSKEYTYPE[0] EQ KT"SYMBOLIC"                              AFB0528
            THEN BEGIN                                                   AFB0528
       TRN1$IS ( TEMPLOC , TEMPOS , FSKEYSIZE[0] , LOC(FSDICOTAB[0]) ) ; AFB0528
            END                                                          AFB0528
          RC = RC+FUNCT+NRECINS-1 ;                                      SAAMNRO
          IF RC EQ 1                                                     CREATEM
           AND ( BARREN EQ 0 OR INDEXFLAG NQ 0 )                         CREATEM
            THEN UR = 1 ;                                                CREATEM
          BLCIP[0] = 0 ;
          END                                                            SAAMNRO
CONTROL EJECT;                                                           ID0913 
PROC ATEI$AA;                                                            RPN0615
          BEGIN                                                          ID0913 
                                                                         ID0913 
 #                                                                       ID0913 
* *   ATEOI - EXTEND THE CURRENT FILE BY ONE BLOCK              PAGE 1   ID0913 
* *   PROGRAM IS CALLED ATEI$AA EXTERNALLY.                              RPN0615
* *   A.F.R.BROWN                                                        ID0913 
* 1DC ATEOI                                                              ID0913 
*                                                                        ID0913 
* DC  FUNCTION                                                           ID0913 
*                                                                        ID0913 
*     TO EXTEND THE CURRENT FILE LOGICALLY BY ONE BLOCK. THIS ROUTINE    ID0913 
*     IS LOGICALLY PART OF NUBL$AA, AS IT IS ONLY CALLED ONCE, AND THAT  ID0913 
*     IS FROM NUBL$AA.                                                   ID0913 
*                                                                        ID0913 
* DC  ENTRY CONDITIONS                                                   ID0913 
*                                                                        ID0913 
*     P<FSTT$AA> DEFINES THE CURRENT FILE.                               ID0913 
*                                                                        ID0913 
*     IF THERE IS ALREADY A BLOCK IN CORE WHOSE CORRESPONDING BLOCK ON   CY210
*       DISK HAS NEVER YET BEEN WRITTEN, FSUNWFLG[0] CONTAINS ITS        CY210
*       ADDRESS. OTHERWISE, FSUNWFLG[0]=0.                               CY210
*                                                                        ID0913 
* DC  EXIT CONDITIONS                                                    ID0913 
*                                                                        ID0913 
*     P<BLOK$AA> IS THE FWA OF THE NEW BLOCK PARCEL.                     CY210
*                                                                        CY210
*     NEWBNUM IS THE PRU NUMBER OF THE NEW BLOCK, AND HAS BEEN INSERTED  CY210
*       IN THE BLOCKID[0] FIELD OF THE BLOCK FRAME.                      CY210
*                                                                        CY210
*     IF FSUNWR1[0] WAS 0, IT NOW = P<BLOK$AA> BECAUSE THE NEW
*       BLOCK IS THE FIRST ONE THAT DOESNT EXIST ON DISK YET. 
*       IF NOT, BUT FSUNWR2[0] WAS 0, FSUNWR2[0] NOW = P<BLOK$AA> 
*       BECAUSE THE NEW BLOCK IS THE SECOND SUCH. 
*       IF NOT, THERE WERE ALREADY TWO UNWRITTEN BLOCKS, SO THE 
*       FIRST ONE HAD TO BE WRITTEN, WHICH CLEARED FSUNWR2[0],
*       AND THEN PROCEED AS FOR FSUNWR2[0]=0. 
*                                                                        ID0913 
*     THE NEW BLOCK PARCEL HAS BEEN LINKED INTO THE KICK-OUT CHAIN,      ID0913 
*       UNLESS IT IS IN UBS SPACE, AND INTO THE CHAIN OF BLOCKS FOR      ID0913 
*       THIS FILE. THESE JOBS WOULD BE DONE BY LOCB$AA FOR A BLOCK OF    ID0913 
*       KNOWN PRU NUMBER, BUT HERE THEY HAVE TO BE DONE BY ATEOI.        ID0913 
* 
*     IF THE NEW BLOCK REPRESENTS AN EXTENSION AND IS IN CMM-SUPPLIED 
*       SPACE, IT HAS BEEN ZEROED FOR SECURITY. 
*                                                                        ID0913 
* DC  ERROR CONDITIONS                                                   ID0913 
*                                                                        ID0913 
*     NONE                                                               ID0913 
*                                                                        ID0913 
* DC  CALLED ROUTINES                                                    ID0913 
*                                                                        ID0913 
*     IOWR$AA - IF THERE ARE ALREADY TWO NOT-YET-WRITTEN BLOCKS 
*       IN CORE, TO WRITE THE FIRST OF THEM, BECAUSE NOT MORE 
*       THAN TWO SUCH MAY EXIT AT ONE TIME FOR ANY ONE FILE.
*     LOCB$AA - TO GET A BLOCK-SIZED PARCEL.                             ID0913 
*     INCH$AA - TO LINK THE NEW PARCEL INTO THE TWO CHAINS.              ID0913 
*                                                                        ID0913 
* DC  NON-LOCAL VARIABLES                                                ID0913 
*                                                                        ID0913 
*     NONE                                                               ID0913 
*                                                                        ID0913 
 #                                                                       ID0913 
                                                                         ID0913 
                             #START OF ATEOI CODE#                       ID0913 
      ITEM I , J  ; 
          IF FSUNWR2[0] NQ 0
            THEN BEGIN
              P<BLOK$AA> = FSUNWR1[0] ; 
              IOWR$AA ( -1 ) ;
            END 
          LOCB$AA ( 0 , -1 ) ;
          IF FSUNWR1[0] NQ 0
            THEN BEGIN
              NEWBNUM = FSNXTPRU[0] + FSBLKSIZ[0] ; 
              FSUNWR2[0] = P<BLOK$AA> ; 
            END 
            ELSE BEGIN
              NEWBNUM = FSNXTPRU[0] ; 
              FSUNWR1[0] = P<BLOK$AA> ; 
            END 
          IF BLUBSFLG[0] EQ 0                                            SAAMNRO
            THEN BEGIN #EXTENDED WITH A CMM BLOCK#                       SAAMNRO
              INCH$AA ( LOC(BLKFPTR[0]) , LOC(FSBCHNH[0]) ) ;            SAAMNRO
              J = BLKLNG+2 ;
              FOR I = 3 STEP 1 UNTIL J
                DO BEGIN
                  BLWRD0[I] = 0 ; 
                END 
            END                                                          SAAMNRO
          INCH$AA(P<BLOK$AA>,LOC(BFCHNHD));                              VBG0922
          BLOCKID[0] = NEWBNUM ;                                         SAAMNRO
          END                                                            SAAMNRO
CONTROL EJECT;
PROC CMRC$AA ;                                                           CY210
          BEGIN                                                          CY210
 #                                                                       CY210
* *   CMRC$AA - COMPRESS A RECORD BEFORE STORING IT           PAGE 1     CY210
* *   A.F.R.BROWN                                                        CY210
* 1DC CMRC$AA                                                            CY210
*                                                                        CY210
* DC  FUNCTION                                                           CY210
*                                                                        CY210
*     WHENEVER A RECORD IS ABOUT TO BE STORED IN A DATA FILE, CMRC$AA    CY210
*     IS CALLED TO COMPRESS IT IF NECESSARY                              CY210
*                                                                        CY210
* DC  ENTRY CONDITIONS                                                   CY210
*                                                                        CY210
*     FTWSA[0] GIVES THE STARTING ADDRESS OF THE RECORD, WHICH BEGINS    CY210
*       AT THE FIRST CHARACTER.                                          CY210
*     FTRL[0] IS THE LENGTH OF THE RECORD IN CHARACTERS.                 CY210
*     FSCOMPACT[0] IS 0 IF THERE IS NO COMPRESSION FOR THIS FILE.        CY210
*       OTHERWISE IT CONTAINS A WORD THAT SHOULD BE MATCHED AGAINST      CY210
*       THE FIRST WORD SENT BACK BY THE COMPRESSION ROUTINE, EACH        CY210
*       TIME THAT ROUTINE IS CALLED, JUST TO MAKE SURE IT IS THE         CY210
*       RIGHT ROUTINE.                                                   CY210
*     P<FSTT$AA> IS THE FWA OF THE FSTT OF THIS FILE.                    CY210
*     MIPMODE = 0 IF THE FILE IS A DATA FILE, NON-ZERO IF A MIP FILE.    CY210
*       IN FACT, HOWEVER, THE ONLY TWO CALLS TO CMRC$AA ARE IN           CY210
*       SITUATIONS WHERE THE DATA FILE IS CURRENT.                       CY210
*     FTCPA[0] IS THE ENTRY POINT OF THE COMPRESSION ROUTINE, IF         CY210
*       FSCOMPACT[0] IS NOT ZERO.                                        CY210
*     SAMKLENG IS THE LENGTH OF THE PRIMARY KEY IN CHARACTERS, IF        CY210
*       EMBEDDED. IF SAMKLENG=0, THE KEY IS NON-EMBEDDED.                CY210
*     SAMKLOC AND SAMKPOS, IF SAMKLENG IS NOT 0, GIVE THE DISTANCE       CY210
*       IN WORDS AND CHARACTERS, FROM THE START OF THE RECORD TO         CY210
*       THE START OF ITS PRIMARY KEY.                                    CY210
*     CBUFAD AND CBUFSZ ARE THE FWA AND THE LENGTH IN CHARACTERS         CY210
*       OF THE COMPRESSION BUFFER, WHERE THE COMPRESSION AND             CY210
*       DECOMPRESSION ROUTINES PUT THEIR OUTPUTS.                        CY210
*                                                                        CY210
* DC  EXIT CONDITIONS                                                    CY210
*                                                                        CY210
*     CMPREC = 0 IF THE RECORD WAS NOT COMPRESSED, WHETHER BECAUSE       CY210
*       THE FILE DOES NOT HAVE COMPRESSION ANYWAY, OR BECAUSE THE        CY210
*       COMPRESSION ROUTINE COULD NOT HANDLE THE RECORD.                 CY210
*     CMPREC = 1 IF THE RECORD HAS BEEN COMPRESSED.                      CY210
*     NEWFWA IS THE FWA OF THE COMPRESSED OR UNCOMPRESSED COPY           CY210
*       OF THE RECORD THAT IS ACTUALLY TO BE COPIED INTO THE             CY210
*       FILE.                                                            CY210
*     NEWLG IS ITS LENGTH IN CHARACTERS.                                 CY210
*                                                                        CY210
* DC  ERROR CONDITIONS                                                   CY210
*                                                                        CY210
*     EC536 NON FATAL, IF THE CHECK WORD RETURNED BY THE                 CY210
*       COMPRESSION ROUTINE AT THE START OF ITS OUTPUT DOES              CY210
*       NOT MATCH FSCOMPACT[0].                                          CY210
*       IN THIS CASE WE GO AHEAD AND STORE THE RECORD AS IF              CY210
*       THE COMPRESSION ROUTINE HAD REPORTED THAT IT COULDNT             CY210
*       SQUEEZE IT DOWN.                                                 CY210
*                                                                        CY210
* DC  CALLED ROUTINES                                                    CY210
*                                                                        CY210
*     OWN$AA - TO INTERFACE WITH THE COMPRESSION ROUTINE                 CY210
*                                                                        CY210
* DC  NON-LOCAL VARIABLES                                                CY210
*                                                                        CY210
*     ONLY THOSE MENTIONED IN ((ENTRY CONDITIONS)) AND ((EXIT            CY210
*     CONDITIONS)).                                                      CY210
*                                                                        CY210
 #                                                                       CY210
          ITEM CLG ;                                                     CY210
          NEWFWA = FTWSA[0] ;                                            AFB0528
          NEWLNG = FTRL[0] ;                                             AFB0528
          CMPREC = 0 ;                                                   AFB0528
          IF FSCOMPACT[0] NQ 0 AND MIPMODE EQ 0                          AFB0528
          THEN                                                           CY210
              BEGIN                                                      CY210
              OWN$AA(FTCPA[0],NEWFWA,NEWLNG,SAMKLOC,SAMKPOS,SAMKLENG,    AFB0528
                  CBUFAD,CBUFSZ,CLG);                                    AFB0528
              IF W[CBUFAD] NQ FSCOMPACT 
              THEN
                  BEGIN 
                  MSGZ$AA(EC536); 
                  CLG = -1 ; #SHOW COMPRESSION FAILED#
                  END 
              IF CLG GR 0                                                CY210
              THEN                                                       CY210
                  BEGIN                                                  CY210
                  CMPREC = 1 ;
                  NEWLNG = CLG - WC ;                                    DABBLE 
                  NEWFWA = CBUFAD + 1;                                   CY210
                  END                                                    CY210
              END                                                        CY210
          END                                                            AFB0528
CONTROL EJECT;                                                           ID0913 
PROC CONS$AA;                                                            SAMNROM
          BEGIN              #UR = 0#                                    SAMNROM
                                                                         ID0913 
 #                                                                       ID0913 
* *   CONS$AA - SQUEEZE DEAD RECORDS FROM A BLOCK              PAGE 1    ID0913 
* *   A.F.R.BROWN                                                        ID0913 
* 1DC CONS$AA                                                            ID0913 
*                                                                        ID0913 
* DC  FUNCTION                                                           ID0913 
*                                                                        ID0913 
*     IF A BLOCK CONTAINS ONE OR MORE DEAD RECORDS (DELETED EARLIER      ID0913 
*     BUT NOT SQUEEZED OUT OF THE BLOCK), THIS ROUTINE IS CALLED BEFORE  ID0913 
*     INSERTING OR REPLACING A RECORD IN THE BLOCK, IN ORDER TO          ID0913 
*     CONSOLIDATE THE BLOCK IMAGE AND MAKE THINGS EASIER BY ELIMINATING  ID0913 
*     DEAD RECORD SPACE. IN AN I-S OR D-A FILE, OR AN I-S OR FIFO        ID0913 
*     SUBFILE OF A MIP FILE, THE DEAD RECORD POINTERS WILL ALSO BE       ID0913 
*     SQUEEZED OUT. BUT IN AN A-K FILE, THOSE RECORD POINTERS HAVE TO    ID0913 
*     REMAIN AS PLACEHOLDERS, EVEN THOUGH POINTING TO ZERO-LENGTH        ID0913 
*     DEAD RECORDS.                                                      ID0913 
*                                                                        ID0913 
* DC  ENTRY CONDITIONS                                                   ID0913 
*                                                                        ID0913 
*     P<BLOK$AA> LOCATES THE BLOCK IMAGE.                                ID0913 
*     RNO CONTAINS THE NUMBER OF THE CURRENT RECORD, WHICH MUST BE       ID0913 
*        A LIVE ONE, OR = RC+1. 
*                                                                        ID0913 
* DC  EXIT CONDITIONS                                                    ID0913 
*                                                                        ID0913 
*     THE BLOCK IMAGE HAS BEEN CONSOLIDATED AS EXPLAINED ABOVE UNDER     ID0913 
*     ((FUNCTION.))                                                      ID0913 
*                                                                        ID0913 
*     BLANYDED[0] ( ANYDEAD ) IN THE BLOCK HEADER HAS BEEN SET TO 0.     ID0913 
*                                                                        ID0913 
*     IF THE CURRENT RECORD HAS HAD ITS RECORD NUMBER CHANGED            ID0913 
*     (IF A LOWER-NUMBERED RECORD POINTER WAS SQUEEZED OUT)              ID0913 
*     RNO HAS BEEN ADJUSTED TO ITS NEW VALUE, AND THIS HAS BEEN          ID0913 
*     INSERTED IN THE CURRENT PTREE WORD.                                ID0913 
* 
*     IF RNO WAS RC+1, THE PTREE WORD THEN POINTED TO THE LAST
*     RECORD IN THE BLOCK. RNO HAS NOW BEEN REDUCED BY THE NUMBER 
*     OF DEAD RECORDS REMOVED FROM THE BLOCK, AND THE PTREE WORD
*     AGAIN POINTS TO THE LAST RECORD IN THE BLOCK. 
*                                                                        ID0913 
*     WHETHER RNO HAS CHANGED OR NOT, RECFWA AND RECLWA CONTAIN THE      ID0913 
*     FWA AND LWA+1 OF THE CURRENT RECORD IN ITS NEW POSITION.           ID0913 
*                                                                        ID0913 
* DC  ERROR CONDITIONS                                                   ID0913 
*                                                                        ID0913 
*     NONE                                                               ID0913 
*                                                                        ID0913 
* DC  CALLED ROUTINES                                                    ID0913 
*                                                                        ID0913 
*     ALTR$AA - TO DO THE FORMALITIES BEFORE ALTERING A BLOCK IMAGE.     ID0913 
*     RPGT$AA - TO FETCH EACH RECORD POINTER IN THE BLOCK.               ID0913 
*     RPPT$AA - TO REPLACE EACH RECORD POINTER FOR A LIVE RECORD         ID0913 
*        (DEAD ONES TOO IN AN A-K FILE)                                  ID0913 
*     MUVW$AA - TO MOVE RECORDS IN THE BLOCK IMAGE.                      ID0913 
*     SETR$AA - TO SET THE RECORD NUMBER IN THE PTREE, AND FIND THE      ID0913 
*       CURRENT RECORD AGAIN, AT THE END OF THE CONSOLIDATION.           ID0913 
*                                                                        ID0913 
* DC  NON-LOCAL VARIABLES                                                ID0913 
*                                                                        ID0913 
*     IX IS USED AS AN INDUCTION VARIABLE.                               ID0913 
      RECPTR IS USED BY RPGT$AA AND RPPT$AA.                             CY210
*                                                                        ID0913 
 #                                                                       ID0913 
          ITEM TLW1,TLW2;    #TEMPORARY LWA S #                          SAMNROM
          ITEM TRP;          #TEMPORARY REC POINTER#                     SAMNROM
          ITEM TRC1,TRC2;    #TEMPORARY REC COUNTS#                      SAMNROM
          ITEM HAMMER ;    #FLAG SET IF RNO = RC+1# 
                                                                         SAMNROM
                                                                         SAMNROM
                             #START OF CONS$AA CODE#                     JJJ0916
          TRP  = 0;                                                      SAMNROM
          TLW1 = 0;                                                      SAMNROM
          TRC1 = 0;                                                      AFB0131
          HAMMER = 0 ;
          IF RNO EQ RC + 1 AND ORG NQ FO"AK"
          THEN
              BEGIN 
              RNO = RNO - 1 ; 
              HAMMER = 1 ;
              END 
          ALTR$AA;                                                       SAMNROM
          ANYDEAD = 0;                                                   SAMNROM
          FOR IX = 1 STEP 1 UNTIL RC                                     SAMNROM
            DO                                                           SAMNROM
            BEGIN                                                        SAMNROM
            TRC2 = TRC1;                                                 SAMNROM
            IF RNO EQ IX   THEN RNO = -(TRC1+1);                         SAMNROM
            RPGT$AA (IX);                                                SAMNROM
            TLW2 = LWAFIELD;                                             SAMNROM
            IF UCCFIELD EQ DEAD                                          SAMNROM
            THEN                                                         SAMNROM
              BEGIN                                                      SAMNROM
              TRP = TRP + TLW2 - TLW1;                                   SAMNROM
              IF ORG EQ FO"AK"                                           SAMNROM
              THEN                                                       SAMNROM
                BEGIN                                                    SAMNROM
                TRC1 = TRC1 + 1;                                         SAMNROM
                RECPTR = RECPTR - TRP;                                   SAMNROM
                END                                                      SAMNROM
              END                                                        SAMNROM
            ELSE                                                         SAMNROM
              BEGIN                                                      SAMNROM
              IF TRP NQ 0                                                SAMNROM
              THEN                                                       SAMNROM
                BEGIN                                                    SAMNROM
                MUVW$AA (BLOCFWA+TLW1, TLW2-TLW1, -TRP);                 SAMNROM
                RECPTR = RECPTR - TRP;                                   SAMNROM
                END                                                      SAMNROM
              TRC1 = TRC1 + 1;                                           SAMNROM
              END                                                        SAMNROM
            IF TRC1 NQ TRC2 AND (IX NQ TRC1 OR TRP NQ 0)                 SAMNROM
            THEN                                                         SAMNROM
              BEGIN                                                      SAMNROM
              RPPT$AA (TRC1);                                            SAMNROM
              END                                                        SAMNROM
            TLW1 = TLW2 ;                                                AFB0131
            END                                                          SAMNROM
                                                                         SAMNROM
#         EC ALREADY INCLUDES THE DEAD RECORDS #                         SAMNROM
                                                                         SAMNROM
          RC = TRC1;                                                     SAMNROM
          BLCIP[0] = 0 ;
          IF RNO LS 0   THEN SETR$AA (-RNO);                             SAMNROM
          IF HAMMER NQ 0
          THEN
              BEGIN 
              RNO = RNO + 1 ; 
              END 
          END                #END OF CONS$AA #                           SAMNROM
CONTROL EJECT;                                                           ID0913 
PROC DELL$AA;                                                            ID0913 
          BEGIN                                                          ID0913 
                                                                         ID0913 
 #                                                                       ID0913 
* *   DELL$AA - DELETE A RECORD FROM A BLOCK                  PAGE 1     ID0913 
* *   A.F.R.BROWN                                                        ID0913 
* 1DC DELL$AA                                                            ID0913 
*                                                                        ID0913 
* DC  FUNCTION                                                           ID0913 
*                                                                        ID0913 
*     TO DELETE THE CURRENT RECORD FROM ITS BLOCK. NO CHANGES            ID0913 
*     ARE MADE EXCEPT THOSE TO THE BLOCK ITSELF.                         ID0913 
*                                                                        ID0913 
*     THIS IS SUITABLE FOR AN I-S FILE OR SUBFILE, A D-A FILE, OR A      ID0913 
*     FIFO SUBFILE, BUT NOT FOR AN A-K FILE.                             ID0913 
*                                                                        ID0913 
* DC  ENTRY CONDITIONS                                                   ID0913 
*                                                                        ID0913 
*     THE CURRENT RECORD AND ITS BLOCK MUST BE IN CORE, WITH THE         ID0913 
*     CURRENT WORD OF THE PTREE, P<BLOK$AA>,AND RNO PROPERLY SET.        CY210
*                                                                        CY210
*     RECLWA MUST BE THE LWA+1 OF THE CURRENT RECORD.                    CY210
*     RECLNG MUST BE THE LENGTH IN WORDS OF THE CURRENT RECORD.          CY210
*                                                                        ID0913 
*     THE CURRENT RECORD MUST BE LIVE,BUT NOT THE ONLY LIVE ONE IN THE   ID0913 
*     BLOCK. (WHETHER IT IS THE ONLY ONE CAN BE CHECKED, BEFORE CALLING  ID0913 
*     DELL$AA, BY SEEING                                                 ID0913 
*     WHETHER THE CURRENT EMPTY COUNT FOR THE BLOCK, INCREASED BY        ID0913 
*     THE LENGTH OF THE RECORD AND A HALF-WORD FOR ITS POINTER, WOULD    ID0913 
*     EQUAL THE MAXIMUM POSSIBLE EMPTY COUNT FOR A BLOCK IN THIS FILE.   ID0913 
*     IF SO, WORRY ABOUT DELETING THE BLOCK INSTEAD OF CALLING DELL$AA.) ID0913 
*                                                                        ID0913 
* DC  EXIT CONDITIONS                                                    ID0913 
*                                                                        ID0913 
*     IN ANY CASE, THE EMPTY SPACE COUNT IN THE BLOCK HEADER HAS BEEN    ID0913 
*     ADJUSTED, AND BLALTFLG[0] HAS BEEN SET TO ONE.                     ID0913 
*                                                                        ID0913 
*     IF THE LAST RECORD IN THE BLOCK IS THE ONE DELETED, WE SIMPLY      ID0913 
*     DROP IT FROM THE RECORD COUNT. (IF ITS IMMEDIATE PREDECESSOR(S)    ID0913 
*     ARE DEAD RECORDS, WE DROP THEM FROM THE COUNT AS WELL, BECAUSE     ID0913 
*     THE LAST RECORD IN A BLOCK MUST ALWAYS BE LIVE.)                   ID0913 
*                                                                        ID0913 
*     AS TO A NON-LAST RECORD, IN A BLOCK OF UNIFORM RECORDS WE          ID0913 
*     SQUEEZE IT OUT, AND OTHERWISE WE JUST MARK IT DEAD BY SETTING      ID0913 
*     THE UNUSED CHARACTER COUNT FIELD OF ITS RECORD POINTER TO THE      ID0913 
*     IMPOSSIBLE VALUE OF 15.                                            ID0913 
*                                                                        ID0913 
*     RNO, AND THE RECORD NUMBER IN THE CURRENT PTREE WORD, CAN NO       ID0913 
*     LONGER BE RELIED ON. THIS IS VERY IMPORTANT. AT THE LEVEL OF       ID0913 
*     DATA BLOCKS, WHERE FILE POSITION IS MOST IMPORTANT, THE FACT IS    ID0913 
*     THAT A DELETE IS NOT SUPPOSED TO ESTABLISH A POSITION, SO AFTER    ID0913 
*     A DELETE, ANY PREVIOUS POSITION WILL CERTAINLY HAVE TO BE          ID0913 
*     LOCATED BY KEY. AT INDEX BLOCK LEVELS, THE FACT THAT THE           ID0913 
*     RECORD NUMBER IS NOT QUITE ASSURED IS NOT, IN PRACTICE,            ID0913 
*     TROUBLESOME.                                                       ID0913 
*                                                                        ID0913 
* DC  ERROR CONDITIONS                                                   ID0913 
*                                                                        ID0913 
*     NONE                                                               ID0913 
*                                                                        ID0913 
* DC  CALLED ROUTINES                                                    ID0913 
*                                                                        ID0913 
*     ALTR$AA - TO DO FORMALITIES BEFORE ALTERING THE BLOCK IMAGE.       ID0913 
*     MUVW$AA - TO SQUEEZE OUT BY MOVING ALL LATER RECORDS.              ID0913 
*     UUCC$AA - TO FETCH THE UNUSED CHARACTER COUNT OF A RECORD POINTER. ID0913 
*                                                                        ID0913 
* DC  NON-LOCAL VARIABLES                                                ID0913 
*                                                                        ID0913 
*     IX AS INDUCTION VARIABLE.                                          CY210
*                                                                        ID0913 
 #                                                                       ID0913 
                                                                         ID0913 
                             #START OF DELL$AA CODE#                     ID0913 
          ALTR$AA ;                                                      SAAMNRO
          EC = EC + 2 * RECLNG + 1 - UR;                                 JJJ0908
          IF UR NQ 0                                                     SAAMNRO
            THEN BEGIN                                                   SAAMNRO
              MUVW$AA(RECLWA, (RC-RNO) * RECLNG, -RECLNG);               JJJ0908
              RC = RC - 1 ;                                              SAAMNRO
            END                                                          SAAMNRO
            ELSE BEGIN                                                   SAAMNRO
              IF RNO EQ RC                                               SAAMNRO
              THEN                                                       SAMNROM
                BEGIN                                                    SAMNROM
                FOR IX = RNO - 1 STEP -1                                 SAMNROM
                  DO                                                     SAMNROM
                  BEGIN                                                  SAMNROM
                  RNO = IX;                                              SAMNROM
                  RC = RNO;                                              SAMNROM
                    IF RNO EQ 0     THEN GOTO DELMAR;                    AFB0214
                  IF UUCC$AA(RNO) NQ DEAD 
                    THEN GOTO DELMAT ; #DONE# 
                                                                         SAMNROM
                  END                                                    SAMNROM
                END                                                      SAMNROM
              ELSE                                                       SAMNROM
                  BEGIN                                                  SAMNROM
                  ANYDEAD = 1 ;                                          SAAMNRO
                  #RPFIELD(0,4,RNO) = DEAD #                             SAAMNRO
                  B<(RNO-RNO/2*2)*30,4>W[BLOCLWA-(RNO+1)/2] = DEAD ;     SAAMNRO
                END                                                      SAAMNRO
            END                                                          SAAMNRO
          IF RC EQ 0                                                     AFB0214
          THEN                                                           AFB0214
              BEGIN                                                      AFB0214
DELMAR:                                                                  AFB0214
              EC = MAXMT;                                                AFB0214
              UR = 0;                                                    AFB0214
              ANYDEAD = 0;                                               AFB0214
              INDEXFLAG = 0;                                             AFB0214
              END                                                        AFB0214
DELMAT: 
          BLCIP[0] = 0 ;
          END                                                            SAAMNRO
CONTROL EJECT ; 
      PROC DUPK$AA ( MESSAGE ) ;
          BEGIN 
  
 #
* *   DUPK$AA - ISSUE ERROR MESSAGE FOR DUPLICATE KEY PUT/RPL 
* *   A.F.R.BROWN 
* 1DC DUPK$AA 
* 
* DC  FUNCTION
* 
*     TO ISSUE AN ERROR MESSAGE (446 OR 503) AFTER A PUT OR REPLACE 
*     HAS FAILED BECAUSE OF DUPLICATE PRIMARY OR ALTERNATE KEY, BUT 
*     FIRST TO ISSUE A NOTE CONTAINING THE PRIMARY KEY VALUE, 
*     AS AN OCTAL NUMBER, UNCOLLATED IF THE KEY IS SYMBOLIC TYPE. 
* 
* DC  ENTRY CONDITIONS
* 
*     THERE IS ONE PARAMETER, PASSED IN THE USUAL SYMPL MANNER. 
*     THIS IS THE ERROR NUMBER (446 OR 503) TO BE PASSED TO MSGZ$AA 
*     AFTER THE KEY VALUE NOTE HAS BEEN ISSUED. 
* 
*     KEYFWA AND KEYOFF ARE THE STARTING ADDRESS AND CHARACTER
*     POSITION OF THE PRIMARY KEY VALUE. IF THIS IS TYPE SYMBOLIC,
*     KEYFWA AND KEYOFF POINT TO ARRAY TRKY$IS, WHICH CONTAINS THE KEY
*     VALUE IN COLLATED FORM. 
* 
*     P<FIT$AA> POINTS TO THE CURRENT FIT, IN WHICH FTFSTT[0] POINTS
*     TO THE IMAGE OF THE FSTT OF THE DATA FILE. FITSAV ALSO POINTS TO
*     THE CURRENT FIT.
* 
* DC  EXIT CONDITIONS 
* 
*     THE TWO MESSAGES HAVE BEEN ISSUED.
* 
*     IF THE PRIMARY KEY IS TYPE SYMBOLIC, THE KEY VALUE IN ARRAY 
*     TRKY$IS HAS BEEN DE-COLLATED. 
* 
* DC  ERROR CONDITIONS
* 
*     NONE
* 
* DC  CALLED ROUTINES 
* 
*     ER$SRM - TO ISSUE THE NOTE WITH THE KEY VALUE.
*     MSGZ$AA - TO ISSUE THE ERROR MESSAGE FOR DUP. KEY.
*     TRN1$IS - TO DECOLLATE THE PRIMARY KEY VALUE IF NECESSARY.
* 
* DC  NON-LOCAL VARIABLES 
* 
*     ONLY KEYFWA AND KEYOFF AS NOTED ABOVE.
* 
 #
          ITEM MESSAGE ; #EC446 OR EC503# 
          ITEM X ; #SCRATCH#
          ARRAY INS ; 
              BEGIN 
              ITEM EOL B(0,0,1) = [TRUE] ; #END OF LIST FLAG# 
              ITEM TYPE U(0,1,3) = [1] ;   #OCTAL#
              ITEM MODE U(0,4,2) = [2] ;   #LENGTH IS IN CHARACTERS#
              ITEM DIS U(0,15,1) = [0] ;
              ITEM POS U(0,17,6) ;
              ITEM LEN U(0,24,18) ;        #LENGTH# 
              ITEM LOCA I(0,42,18) ;       #FWA#
              END 
  
          X = FTFSTT[0] - P<FSTT$AA> ;
          IF FSKEYTYPE[X] EQ KT"SYMBOLIC" 
          THEN
              BEGIN 
              TRN1$IS(KEYFWA,KEYOFF,FSKEYSIZE[X],LOC(FSCODITAB[X]));
              END 
          POS = KEYOFF ;
          LEN = FSKEYSIZE[X] ;
          LOCA = KEYFWA ; 
          ER$SRM(FITSAV,O"1027",0,LOC(INS),1,0,0);
          MSGZ$AA ( MESSAGE ) ; 
          END 
CONTROL EJECT;                                                           ID0913 
PROC NUBL$AA ( M );                                                      ID0913 
          BEGIN                                                          ID0913 
                                                                         ID0913 
 #                                                                       ID0913 
* *   NUBL$AA - GET A NEW BLOCK                            PAGE 1        ID0913 
* *   A.F.R.BROWN                                                        ID0913 
* 1DC NUBL$AA                                                            ID0913 
*                                                                        ID0913 
* DC  FUNCTION                                                           ID0913 
*                                                                        ID0913 
*     TO LOCATE AN EMPTY BLOCK FOR USE IN THE CURRENT FILE.              ID0913 
*     IF THERE ARE ANY BLOCKS ON THE EMPTY CHAIN OF THE CURRENT FILE,    ID0913 
*     ONE OF THEM IS READ IN FROM THE EMPTY CHAIN AND LOGICALLY          ID0913 
*     REMOVED FROM IT. IF THE EMPTY CHAIN IS EMPTY, WE HAVE TO CALL      ID0913 
*     ATEOI TO GET A NEW BLOCK ESTABLISHED AT LOGICAL EOI.               CY210
*                                                                        ID0913 
* DC  ENTRY CONDITIONS                                                   ID0913 
*                                                                        ID0913 
*     THERE IS ONE PARAMETER,PASSED IN THE USUAL SYMPL MANNER.           ID0913 
*     IT HAS A SOMEWHAT ARTIFICIAL MEANING, CONNECTED WITH THE FACT      ID0913 
*     THAT NUBL$AA IS MOST OFTEN CALLED IN CONNECTION WITH WHAT IS       ID0913 
*     TREATED AS A BLOCK SPLIT. PART OF THE CURRENT BLOCK MAY BE         ID0913 
*     COPIED INTO THE NEW BLOCK, AND BOTH OF THEM WILL HAVE TO HOLD      ID0913 
*     STILL.                                                             ID0913 
*                                                                        ID0913 
*     IF THE PARAMETER IS 0, THE CURRENT BLOCK IS NOT FROZEN, AND        ID0913 
*     THE NEW BLOCK IS FROZEN BY A CALL TO FIXX$AA, ITS ADDRESS          ID0913 
*     BEING STORED IN FIXHOLD[0] .                                       ID0913 
*                                                                        ID0913 
*     IF THE PARAMETER IS NOT 0, IT CAN BE 1, 2, OR 3. THE CURRENT       ID0913 
*     BLOCK IS FROZEN, ITS ADDRESS BEING STORED IN FIXHOLD[0], AND       ID0913 
*     THE NEW BLOCK IS ALSO FROZEN, ITS ADDRESS BEING STORED IN          ID0913 
*     FIXHOLD[M], M BEING THE PARAMETER VALUE.                           ID0913 
*                                                                        ID0913 
*     IF THE PARAMETER IS NOT 0, THERE MUST BE A CURRENT BLOCK IN        ID0913 
*     CORE, LOCATED BY P<BLOK$AA> .                                      ID0913 
*                                                                        ID0913 
*     FSMTBPRU[0] IS THE PRU NUMBER OF THE FIRST BLOCK ON THE            ID0913 
*       EMPTY CHAIN OF THIS FILE. IF IT IS 0, THE EMPTY CHAIN IS EMPTY.  ID0913 
*                                                                        ID0913 
* DC  EXIT CONDITIONS                                                    ID0913 
*                                                                        ID0913 
*     NEWBNUM IS THE PRU NUMBER OF THE NEW BLOCK.                        ID0913 
*                                                                        ID0913 
*     NEWBFWA IS THE FWA OF THE NEW BLOCK PARCEL IN CORE.                ID0913 
*                                                                        ID0913 
*     P<BLOK$AA> AND BLOCLWA POINT TO THE NEW BLOCK. (THE OLD BLOCK IS   ID0913 
*     NOT LOST. USUALLY NUBL$AA IS CALLED WITH A NON-ZERO PARAMETER,     ID0913 
*     AND THEN THE FWA OF THE OLD BLOCK IS STORED AT FIXHOLD[0].         ID0913 
*     A CALL OF TROW$AA(0) WILL RESTORE P<BLOK$AA> AND BLOCLWA.          ID0913 
*     A CALL OF UNFX$AA(0) WILL ALSO BE NEEDED SOONER OR LATER TO        ID0913 
*     RELEASE IT BACK TO THE KICKOUT CHAIN.                              ID0913 
*                                                                        ID0913 
*     ONE OR BOTH BLOCKS HAVE BEEN FROZEN AS DESCRIBED ABOVE.            ID0913 
*                                                                        ID0913 
*     IF THE NEW BLOCK CAME FROM THE EMPTY CHAIN, ITS SUCCESSOR          ID0913 
*     IN THAT CHAIN HAS BEEN POPPED INTO FSMTBPRU[0], AND THE COUNT      ID0913 
*     IN FSMTBCN[0] HAS BEEN REDUCED BY 1.                               ID0913 
*                                                                        ID0913 
*     OTHERWISE, THE NEW BLOCK REPRESENTS AN EXTENSION, AND              ID0913 
*     FSNXTPRU[0] IS ITS PRU NUMBER. FSUNWFLG[0] HAS BEEN                CY210
*     SET = NEWBFWA.                                                     CY210
*                                                                        ID0913 
*     THE NEW BLOCK IMAGE LOOKS LIKE A NORMAL EMPTY BLOCK, JUST WAITING  ID0913 
*     FOR THE FIRST RECORD TO BE ADDED.                                  ID0913 
*     ITS BLALTFLG[0] HAS BEEN SET TO 1, SO THAT WHENEVER THIS IMAGE     ID0913 
*     IS ALTERED, UP TO THE TIME IT IS FIRST WRITTEN TO DISK, LOGGING    ID0913 
*     WILL BE CONSIDERED UNNECESSARY.                                    ID0913 
*                                                                        CY210
*     BLXTEND[0], IN THE BLOCK FRAME, IS 0 IF THE BLOCK CAME             CY210
*     FROM THE EMPTY CHAIN, OR 1 IF IT REPRESENTS AN EXTENSION           CY210
*     OF THE FILE.                                                       CY210
*                                                                        ID0913 
*     FSBLKCNT HAS BEEN UPDATED.                                         CIM0718
*                                                                        CIM0718
* DC  ERROR CONDITIONS                                                   ID0913 
*                                                                        ID0913 
*     A FATAL ERROR, IMPLYING A FAULT IN OUR LOGIC, IF A BLOCK TAKEN     ID0913 
*     FROM THE EMPTY CHAIN HAS A NON-ZERO RECORD COUNT IN ITS HEADER.    ID0913 
*     WE ZERO  THIS COUNT BEFORE PUTTING ANY BLOCK ONTO THE EMPTY CHAIN  ID0913 
*     AS A SLIGHT SAFEGUARD AGAINST ACCIDENTALLY RE-USING A BLOCK THAT   ID0913 
*     WAS NOT REALLY ON THE EMPTY CHAIN.                                 ID0913 
*                                                                        ID0913 
* DC  CALLED ROUTINES                                                    ID0913 
*                                                                        ID0913 
*     LOCB$AA - TO LOCATE THE NEW BLOCK IMAGE, FIRST READING IT IN       ID0913 
*       IF IT IS ON THE EMPTY CHAIN (ACTUALLY IT MIGHT NOT HAVE TO BE    ID0913 
*       READ IN IF IT HAD BEEN PUT ON THE EMPTY CHAIN VERY RECENTLY,     ID0913 
*       AND NOT YET KICKED OUT.)                                         ID0913 
*     ATEOI - TO EXTEND THE FILE, IF THE EMPTY CHAIN IS EMPTY.           ID0913 
*     FIXX$AA - TO FREEZE THE NEW BLOCK, AND MAYBE THE OLD BLOCK,        ID0913 
*       AND SAVE THEIR FWA-S IN THE FIXHOLD ARRAY.                       ID0913 
*     EXRP$AA - TO DECIDE WHETHER AN ERROR SHOULD BE CALLED              CY210
*       FATAL OR NON-FATAL, AND CALL THE RIGHT SUBROUTINE.               CY210
*     LGFS$AA - TO LOG THE FSTT, IF LOGGING IS IN FORCE, AND
*       AND THIS IS THE FIRST ALTERATION TO THE FILE SINCE
*       THE LAST OPEN OR FLUSH. 
*                                                                        ID0913 
* DC  NON-LOCAL VARIABLES                                                ID0913 
*                                                                        ID0913 
*     IX IS USED FOR SCRATCH.                                            CY210
*                                                                        ID0913 
 #                                                                       ID0913 
          ITEM M;            #SEE ENTRY CONDITIONS#                      ID0913 
                                                                         ID0913 
                             #START OF NUBL$AA CODE#                     ID0913 
          IF FSALTFLG[0] EQ 0 THEN LGFS$AA; 
          IF M NQ 0 THEN FIXX$AA ( P<BLOK$AA> , 0 ) ;                    SAAMNRO
          IF FSMTBPRU[0] NQ 0                                            SAAMNRO
            THEN BEGIN                                                   SAAMNRO
              NEWBNUM = FSMTBPRU[0] ;                                    SAAMNRO
              LOCB$AA ( NEWBNUM , 1 ) ;                                  SAAMNRO
              IF P<BLOK$AA> LS 0
              THEN
                  BEGIN 
                 EXRP$AA ;
                  END 
              FIXX$AA ( P<BLOK$AA> , M ) ;                               SAAMNRO
              FSMTBPRU[0] = FWD ;                                        SAAMNRO
              FSMTBCNT[0] = FSMTBCNT[0] - 1;                             JJJ0908
              IF RC NQ 0
                THEN BEGIN
                  MSGF$AA ( EC547 ) ; #EMPTY CHAIN BLOCK HAS RC NOT 0#
                  GOTO EXIT$AA ;
                END 
              BLXTEND[0] = 0 ;                                          018400
            END                                                          SAAMNRO
            ELSE BEGIN                                                   SAAMNRO
              ATEI$AA; #ATEOI CALL#                                      RPN0615
              FIXX$AA ( P<BLOK$AA> , M ) ;                               SAAMNRO
              BLXTEND[0] = 1 ;                                          018600
            END                                                          SAAMNRO
          FOR IX = 0 STEP 1 UNTIL DBLKHEDSZ-1  DO BLKHDR[IX] = 0;        SAMNROM
          ALTR$AA ; 
          BLCIP[0] = 0 ;
          BLPRFXLN[0] = 2 ;                                              SAAMNRO
          EC = MAXMT ;                                                   SAAMNRO
          NEWBFWA = P<BLOK$AA> ;                                         SAAMNRO
          BLOCLWA = P<BLOK$AA> + BLKLG + DBLKFRAME ;                     SAAMNRO
          FSBLKCNT = FSBLKCNT + 1 ;                                      CIM0718
          NEWBNUM = NEWBNUM LAN ( 2**24-1 ) ; 
          END                                                            SAAMNRO
CONTROL EJECT;                                                           ID0913 
PROC RCKN$AA ( (N) , BARN );                                             ID0913 
          BEGIN                                                          ID0913 
                                                                         ID0913 
 #                                                                       ID0913 
* *   RCKN$AA - IS THERE ROOM IN THIS BLOCK                  PAGE 1      ID0913 
* *   A.F.R.BROWN                                                        ID0913 
* 1DC RCKN$AA                                                            ID0913 
*                                                                        ID0913 
* DC  FUNCTION                                                           ID0913 
*                                                                        ID0913 
*     TO DETERMINE, WHEN THE POINT IN A FILE AT WHICH A PUT OR REPLACE   ID0913 
*     IS TO HAPPEN HAS BEEN LOCATED, WHETHER THERE IS ROOM TO DO IT      ID0913 
*     WITHOUT A BLOCK SPLIT, AND IF A SPLIT IS NEEDED, WHAT KIND.        ID0913 
*                                                                        ID0913 
* DC  ENTRY CONDITIONS                                                   ID0913 
*                                                                        ID0913 
*     THERE ARE TWO PARAMETERS, PASSED IN THE NORMAL SYMPL WAY.          ID0913 
*       1. THE FIRST PARAMETER IS 0 IF A REPLACE IS BEING CONSIDERED,    ID0913 
*           OR 1 IF THE INSERTION OF AN ADDITIONAL RECORD.               ID0913 
*       2. THE SECOND PARAMETER IS 0 IF THE NEW RECORD WILL NOT          ID0913 
*           CONTAIN A SUB-FILE HEADER, OR 1 IF IT WILL (SEE THE          ID0913 
*           COMMENTS ON VARIABLE BARREN, IN THE PREAMBLE TO ROUTINE      ID0913 
*           ADRC$AA.)                                                    ID0913 
*                                                                        ID0913 
*     THE LENGTH OF THE NEW RECORD IN CHARACTERS IS NEWLG.               ID0913 
*     HOWEVER, NEWLG MAY BE NEGATIVE, IN WHICH CASE THE ROUTINE IS TO    ID0913 
*     WORK IT OUT FOR A NEW RECORD THAT WOULD BE JUST BIG ENOUGH TO      ID0913 
*     FORCE A BLOCK SPLIT, ON THE BASIS OF A REPLACEMENT. IT MAY HAPPEN  ID0913 
*     IN MIP THAT WE WANT TO FORCE A BLOCK SPLIT WITHOUT (YET) ADDING    ID0913 
*     A NEW RECORD, AND WE CALL RCKN$AA TO LEARN WHETHER TO SPLIT        ID0913 
*     BEFORE OR AFTER THE CURRENT RECORD.                                ID0913 
*                                                                        ID0913 
*     OUTKEY GIVES THE LENGTH IN WORDS OF A NON-EMBEDDED KEY IN THE      ID0913 
*       CURRENT FILE ( 0 IF NO SUCH NON-EMBEDDED KEY. )                  ID0913 
*                                                                        ID0913 
*     NRECINS IS THE NUMBER OF NEW RECORDS. ORDINARILY THIS IS 1,        ID0913 
*       AND IN FACT IT NEED NOT BE SET BEFORE CALLING RCKN$AA EXCEPT     ID0913 
*       WHEN THE CURRENT BLOCK IS AN INDEX BLOCK. IN THAT CASE, WE       ID0913 
*       MAY BE CONVENIENTLY SMUGGLING IN A GROUP OF 1, 2, OR 3           ID0913 
*       INDEX RECORDS AT ONE BLOW, AND IT IS ESSENTIAL TO HAVE NRECINS   ID0913 
*       CORRECT THEN, WHILE RECLG MUST BE THE LENGTH OF ONE INDEX        ID0913 
*       RECORD.                                                          ID0913 
*                                                                        ID0913 
*     THE FILE IS NOW POSITIONED AT THE RECORD TO BE REPLACED, OR        ID0913 
*       BEFORE WHICH THE NEW RECORD IS TO BE INSERTED.                   ID0913 
*     RECLNG IS THE LENGTH IN WORDS OF THE CURRENT RECORD.               CY210
*       IT NEED NOT BE SET UNLESS THE CURRENT RECORD IS GOING            CY210
*       TO BE REPLACED.                                                  CY210
*     RNO IS THE RECORD NUMBER, WITHIN THE CURRENT BLOCK, OF THE         ID0913 
*       CURRENT RECORD.                                                  ID0913 
*       WHEN WHAT IS BEING CONSIDERED IS THE ADDING A RECORD AFTER       ID0913 
*       THE LAST IN THE CURRENT BLOCK, THE PTREE AND RNO SHOW US AS      ID0913 
*       POSITIONED AT THE LAST RECORD OF THE BLOCK, AS IF WE WERE        ID0913 
*       GOING TO INSERT BEFORE IT. HOWEVER, THIS DOES NOT MATTER MUCH,   ID0913 
*       BECAUSE RCKN$AA WILL REPORT THAT WE CAN OR CANNOT FIT THE NEW    ID0913 
*       RECORD INTO THE BLOCK. IF WE CAN, THE ROUTINE THAT CALLED        ID0913 
*       RCKN$AA WILL DO THE RIGHT THING WITHOUT BEING FOOLED BY RNO.     ID0913 
*       IF WE CANNOT, THE ROUTINE THAT CALLED RCKN$AA WILL ADD A NEW     ID0913 
*       BLOCK TO THE RIGHT OF THE CURRENT ONE, WITHOUT REGARDING THE     ID0913 
*       DETAILS OF THE REPLY FROM RCKN$AA.                               ID0913 
*                                                                        CY210
*     FTON[0] WAS SET AT OPEN TIME TO SHOW WHETHER THE MOST              CY210
*       RECENT OPEN WAS OLD OR NEW.                                      CY210
*     FSINDXPAD[0] AND FSDATAPAD[0] GIVE THE NUMBER OF HALF-WORDS        CY210
*       OF PADDING THAT MUST BE LEFT IN AN INDEX BLOCK OR A DATA         CY210
*       BLOCK, RESPECTIVELY, IF THE OPEN WAS NEW.                        CY210
*                                                                        ID0913 
* DC  EXIT CONDITIONS                                                    ID0913 
*                                                                        ID0913 
*     SPLTFLG = 0 IF IT CAN ALL FIT IN THE NEW BLOCK.                    ID0913 
*     SPLTFLG < 0 IF A THREE-WAY SPLIT WILL BE NEEDED.                   ID0913 
*     SPLTFLG = 1 IF A TWO-WAY SPLIT WILL BE NEEDED, AND THE NEW         ID0913 
*       RECORD SHOULD COME AT THE END OF THE FIRST OF THE TWO BLOCKS     ID0913 
*       INTO WHICH WE SPLIT.                                             ID0913 
*     SPLTFLG = 2 IF A TWO-WAY SPLIT, AND THE NEW RECORD SHOULD COME     ID0913 
*       AT THE BEGINNING OF THE SECOND OF THE TWO BLOCKS INTO WHICH      ID0913 
*       WE SPLIT, BUT COULD ALSO BE FITTED AT THE END OF THE FIRST.      CY210
*     SPLTFLG = 3 IF A TWO-WAY SPLIT, AND THE NEW RECORD CAN ONLY        CY210
*       FIT AT THE BEGINNING OF THE SECOND BLOCK.                        CY210
* 
*     IF THE BLOCK DOESNT BELONG TO AN IS FILE (I.E. IT IS DA OR FIFO)
*     0 AND 3 ARE THE ONLY VALUES RETURNED IN SPLTFLG.
*                                                                        CY210
*     NRECINS = 1 IF THE CURRENT BLOCK IS A DATA BLOCK.                  CY210
*                                                                        ID0913 
* DC  ERROR CONDITIONS                                                   ID0913 
*                                                                        ID0913 
*     NONE                                                               ID0913 
*                                                                        ID0913 
* DC  CALLED ROUTINES                                                    ID0913 
*                                                                        ID0913 
*     CONS$AA - GET RID OF DEAD RECORDS                                  JJJ0405
*     LWAD$AA - TO LOCATE A RECORD LWA+1 WITHIN THE BLOCK, OR            CY210
*       TO DETERMINE RECORD LENGTH IN A UNIFORM BLOCK.                   CY210
*                                                                        ID0913 
* DC  NON-LOCAL VARIABLES                                                ID0913 
*                                                                        ID0913 
*     NONE                                                               ID0913 
*                                                                        ID0913 
 #                                                                       ID0913 
CONTROL EJECT;               #START OF RCKN$AA CODE#                     ID0913 
          ITEM N;            #0 = REPLACE, 1 = INSERT#                   ID0913 
          ITEM BARN;         #0 = NO SUBFILE#                            ID0913 
          ITEM X;            #TEMP REC LENGTH IN WORDS#                  ID0913 
          ITEM RIGHT , LEFT;  #NUM WORDS IN BLK HALVES#                  ID0913 
          ITEM ENTIRE;       #SIZE OF BLOCK IF REC ADDED#                ID0913 
          ITEM YY;            #TEMPORARY REC LENGTH#                     SAMNROM
          ITEM MAXHF;        #MAX NUM OF 1/2 WORDS IN BLOCK#             VBG1208
          ITEM ORGIS ;    # 0 IFF FO"IS" #                               DABBLE 
                                                                         ID0913 
                                                                         ID0913 
          ORGIS = ORG - FO"IS" ;                                         DABBLE 
          MAXHF = MAXMT;                                                 VBG1208
          IF FTON[0] NQ ON"OLD" 
          THEN
              BEGIN 
              IF INDEXFLAG NQ 0 
              THEN
                  BEGIN 
                  MAXHF = MAXHF - FSINDXPAD[0] ;
                  END 
              ELSE
                  BEGIN 
                  MAXHF = MAXHF - FSDATAPAD[0] ;
                  END 
              END 
          RIGHT = 0 ;                                                    SAAMNRO
          YY = NEWLNG;                                                   JJJ0908
          IF YY LS 0                                                     JJJ0908
            THEN YY = WC*RECLNG + (WC/2)*EC + 1 ;                        DABBLE 
            #NEWLG = -1 IS A KLUGE IN MIPNRO TO CAUSE                    SAAMNRO
              A BLOCK SPLIT BEFORE ENLARGING A SUBBLOCK #                SAAMNRO
          IF INDEXFLAG EQ 0                                              JJJ0916
          THEN                                                           JJJ0916
            BEGIN                                                        JJJ0916
            YY = YY + WC * OUTKEY ;                                      DABBLE 
            NRECINS = 1 ;                                                JJJ0916
            END                                                          JJJ0916
          IF INDEXFLAG NQ 0                                              SAAMNRO
           OR ( BARN EQ 0 AND UR NQ 0 
               AND (BLMIPBLK[0] NQ 0 OR CMPREC EQ RPFIELD(4,1,1) )
                  AND YY EQ WC*LWAD$AA(1) - UUCC$AA(1) )                 DABBLE 
            THEN BEGIN #NRECINS COULD BE 1 2 OR 3#                       SAAMNRO
              RECLNG = LWAD$AA ( 1 ) ;                                   AFB0128
              ENTIRE = 2 * (RC + N + NRECINS - 1) * RECLNG + 1;          JJJ0908
              IF ENTIRE GR MAXHF AND ORGIS EQ 0                          DABBLE 
                THEN BEGIN                                               SAAMNRO
                  LEFT = 2 * (RNO + NRECINS - 1) * RECLNG + 1;           JJJ0908
                  RIGHT = 2 * (RC - RNO + N + NRECINS) * RECLNG + 1;     JJJ0908
                END                                                      SAAMNRO
            END                                                          SAAMNRO
            ELSE BEGIN                                                   SAAMNRO
              X = WLG(YY) ;                                              SAAMNRO
              IF UR NQ 0                                                 SAAMNRO
                THEN BEGIN #NRECINS MUST BE 1#                           SAAMNRO
                  RECLNG = LWAD$AA ( 1 ) ;                               AFB0128
                  ENTIRE = 2 * ((RC-1+N) * RECLNG + X) + RC + N;         JJJ0908
                  IF ENTIRE GR MAXHF AND ORGIS EQ 0                      DABBLE 
                    THEN BEGIN                                           SAAMNRO
                      LEFT = 2 *((RNO-1) * RECLNG + X) + RNO;            JJJ0908
                      RIGHT = 2 * ((RC-RNO+N) * RECLNG + X) + RC - RNO   JJJ0908
                                                              + N + 1;   JJJ0908
                    END                                                  SAAMNRO
                END                                                      SAAMNRO
                ELSE BEGIN                                               SAAMNRO
                  IF ANYDEAD NQ 0 AND ORGIS EQ 0                         DABBLE 
                  THEN                                                   JJJ0405
                      BEGIN                                              JJJ0405
                      CONS$AA;    #GET RID OF DEAD RECORDS#              JJJ0405
                      END                                                JJJ0405
                  ENTIRE = MAXMT - EC + 2 * X + N ;                      DABBLE 
                  IF N EQ 0                                              JJJ0908
                    THEN ENTIRE = ENTIRE - 2 * RECLNG;                   JJJ0908
                  IF ENTIRE GR MAXHF AND ORGIS EQ 0                      DABBLE 
                    THEN BEGIN                                           SAAMNRO
                      LEFT = 2 * ( LWAD$AA (RNO-1) + X ) + RNO ;         SAAMNRO
                      RIGHT = 2 * (LWAD$AA(RC)-LWAD$AA(RNO-N)+X) +       SAAMNRO
                                                  RC-RNO+N+1;            SAAMNRO
                    END                                                  SAAMNRO
                END                                                      SAAMNRO
            END                                                          SAAMNRO
          IF ORGIS NQ 0                                                  DABBLE 
            THEN BEGIN                                                   DABBLE 
              SPLTFLG = ENTIRE - MAXHF ;                                 DABBLE 
              IF SPLTFLG LS 0 THEN SPLTFLG = 0 ;                         DABBLE 
              IF SPLTFLG GR 0 THEN SPLTFLG = 3 ;
              RETURN ;                                                   DABBLE 
            END                                                          DABBLE 
          IF RIGHT EQ 0                                                  SAAMNRO
            THEN SPLTFLG = 0 ;                                           SAAMNRO
            ELSE BEGIN                                                   SAAMNRO
              IF LEFT LS RIGHT                                           VBG1208
              THEN                                                       VBG1208
                  BEGIN                                                  VBG1208
                  IF LEFT GR MAXHF                                       VBG1208
                  THEN                                                   VBG1208
                      BEGIN                                              VBG1208
                      SPLTFLG = -1;  #3-WAY#                             VBG1208
                      END                                                VBG1208
                  ELSE                                                   VBG1208
                      BEGIN                                              VBG1208
                      SPLTFLG = 1;  #USE LEFT SIDE#                      VBG1208
                      END                                                VBG1208
                  END                                                    VBG1208
              ELSE                                                       VBG1208
                  BEGIN                                                  VBG1208
                  IF RIGHT GR MAXHF                                      VBG1208
                  THEN                                                   VBG1208
                      BEGIN                                              VBG1208
                      SPLTFLG = -2;  #3-WAY#                             VBG1208
                      END                                                VBG1208
                  ELSE                                                   VBG1208
                      BEGIN                                              VBG1208
                      IF LEFT GR MAXHF                                   VBG1208
                      THEN                                               VBG1208
                          BEGIN                                          VBG1208
                          SPLTFLG = 3;  #MUST USE RIGHT#                 VBG1208
                          END                                            VBG1208
                      ELSE                                               VBG1208
                          BEGIN                                          VBG1208
                          SPLTFLG = 2;  #EITHER OK, RIGHT SMALLER#       VBG1208
                          END                                            VBG1208
                      END                                                VBG1208
                  END                                                    VBG1208
            END                                                          SAAMNRO
          END                                                            SAAMNRO
CONTROL EJECT;
     PROC RPPT$AA( N ) ; BEGIN ITEM N ;                                  SAAMNRO
 #                                                                       CY211
* *   RPPT$AA - INSERT A RECORD POINTER INTO THE CURRENT BLOCK           CY211
* *   A.F.R.BROWN                                                        CY211
* 1DC RPPT$AA                                                            CY211
*                                                                        CY211
* DC  FUNCTION                                                           CY211
*                                                                        CY211
*     TO TAKE A RECORD POINTER THAT HAS BEEN CONSTRUCTED OR              CY211
*     MODIFIED, AND IS NOW IN THE RIGHT HALF OF VARIABLE RECPTR,         CY211
*     AND INSERT IT INTO THE CURRENT BLOCK AS THE POINTER TO             CY211
*     RECORD NUMBER N.                                                   CY211
*                                                                        CY211
* DC  ENTRY CONDITIONS                                                   CY211
*                                                                        CY211
*     THERE IS ONE PARAMETER PASSED IN THE NORMAL WAY. THIS IS           CY211
*     THE RECORD NUMBER TO GOVERN THE LOCATION FOR STORING THE           CY211
*     RECORD POINTER. IT MUST BE GREATER THAN 0.                         CY211
*                                                                        CY211
*     RECPTR CONTAINS, IN BITS 0-29, THE RECORD POINTER. THE             CY211
*     REST OF RECPTR IS IGNORED.                                         CY211
*                                                                        CY211
*     BLOCLWA IS THE LWA+1 OF THE IMAGE OF THE CURRENT BLOCK.            CY211
*                                                                        CY211
* DC  EXIT CONDITIONS                                                    CY211
*                                                                        CY211
*     IF N IS EVEN (IT MUST NOT BE 0), THE POINTER HAS BEEN              CY211
*     INSERTED AS THE LEFT HALF OF THE WORD AT BLOCLWA-N/2.              CY211
*     IF N IS ODD, THE POINTER HAS BEEN INSERTED AS THE RIGHT            CY211
*     HALF OF THE WORD AT BLOCLWA-(N+1)/2.                               CY211
*                                                                        CY211
* DC  ERROR CONDITIONS                                                   CY211
*                                                                        CY211
*     NONE                                                               CY211
*                                                                        CY211
* DC  CALLED ROUTINES                                                    CY211
*                                                                        CY211
*     NONE                                                               CY211
*                                                                        CY211
* DC  NON-LOCAL VARIABLES                                                CY211
*                                                                        CY211
*     NONE                                                               CY211
*                                                                        CY211
 #                                                                       CY211
          RPFIELD(0,30,N) = RECPTR ;                                     SAAMNRO
          END                                                            SAAMNRO
CONTROL EJECT ;                                                         006400
PROC SLOG$AA ;                                                          006500
      BEGIN                                                             006600
 #                                                                      006700
* *   SLOG$AA - NOTIFY SPECIAL TAF LOGGING            PAGE 1            006800
* *   A.F.R.BROWN                                                       006900
* 1DC SLOG$AA                                                           007000
*                                                                       007100
* DC  FUNCTION                                                          007200
*                                                                       007300
*     TO ENABLE A SPECIAL TAF LOGGING ROUTINE TO CATCH THE MOMENT       007400
*     AT WHICH AN UPDATE BEGINS, THAT WILL ALTER MORE THAN ONE          007500
*     BLOCK OF A FILE (NOT COUNTING THE FSTT) OR WILL ALTER AT          007600
*     LEAST ONE BLOCK OF A MIP FILE AS WELL AS ONE BLOCK OF THE         007700
*     DATA FILE.                                                        007800
*                                                                       007900
* DC  ENTRY CONDITIONS                                                  008000
*                                                                       008100
*     SFLG IN THE FIT IS 1 IF THE USER WANTS THIS DONE, OTHERWISE 0.    008200
*                                                                       008300
*     FS2BLOX, A FLAG IN THE FSTT, IS 1 IF SUBROUTINE SLOG$AA HAS       008400
*       ALREADY BEEN CALLED IN THE COURSE OF THE CURRENT OPERATION.     008500
*       IF IT IS 0, THEN IT HAS TO BE SET TO 1, AND THE FSTT MUST       008600
*       BE WRITTEN TO DISK WITH THE FLAG SET, AS A SIGN THAT DURING     008700
*       THIS OPERATION, BECAUSE IT INVOLVES THE ALTERATION OF MORE      008800
*       THAN ONE BLOCK, THERE WILL BE A PERIOD OF TIME WHEN THE         008900
*       FILE ON DISK IS NOT IN EQUILIBRIUM. AT THE CONCLUSION OF        009000
*       THE OPERATION, THE FSTT WILL BE REWRITTEN WITH FS2BLOX          009100
*       RESET TO 0. THIS WILL BE ACHIEVED BECAUSE THE USER WILL         009200
*       HAVE SET FWI IN THE FIT TO 1, FORCING THE FSTT TO BE            009300
*       FLUSHED AT THE END OF THE OPERATION, AND THE FLUSH ROUTINE      009400
*       CLEARS FS2BLOX. FS2BLOX IS ALSO USED BY LOG$AA IN ORDER         009500
*       TO TELL THE USER-S LOGGING ROUTINE WHETHER IT IS BEING          009600
*       CALLED FOR A MULTI-BLOCK OPERATION OR NOT.                      009700
*     NOTE THAT THIS IS FS2BLOX IN A DATA FILE, NEVER IN A MIP FILE.    009800
*                                                                       009900
*     THIS SUBROUTINE DEPENDS ONLY ON P<FIT$AA>, NOT ON P<FSTT$AA>      010000
*       OR P<BLOK$AA>.                                                  010100
*                                                                       010200
* DC  EXIT CONDITIONS                                                   010300
*                                                                       010400
*     IF SFLG IN THE FIT IS 1, AND FS2BLOX IN THE DATA FILE FSTT        010500
*       WAS 0 ON ENTRY, AND WE HAVE ALL THE WRITE PERMISSIONS,          010600
*       FS2BLOX HAS BEEN SET TO 1 AND THE FSTT HAS BEEN WRITTEN         010700
*       TO DISK.                                                        010800
*                                                                       010900
*     P<FSTT$AA> AND P<BLOK$AA> ARE PRESERVED.                          011000
*                                                                       011100
* DC  ERROR CONDITIONS                                                  011200
*                                                                       011300
*     NONE                                                              011400
*                                                                       011500
* DC  CALLED ROUTINES                                                   011600
*                                                                       011700
*     IOWR$AA - TO WRITE OUT THE FSTT                                   011800
*                                                                       011900
* DC  NON-LOCAL VARIABLES                                               012000
*                                                                       012100
*     NONE                                                              012200
*                                                                       012300
 #                                                                      012400
      ITEM SVFS , SVBL ;                                                012500
                                                                        012600
      IF FTSFLG[0] NQ 0 AND FS2BLOX[FTFSTT[0]-P<FSTT$AA>] EQ 0          012700
          AND FTMER[0] EQ 7                                             012800
      THEN                                                              012900
          BEGIN                                                         013000
          SVFS = P<FSTT$AA> ;                                           013100
          SVBL = P<BLOK$AA> ;                                           013200
          P<FSTT$AA> = FTFSTT[0] ;                                      013300
          FS2BLOX[0] = 1 ;                                              013400
          P<BLOK$AA> = P<FSTT$AA> ;                                     013500
          IOWR$AA ( 1 ) ;                                               013600
          P<FSTT$AA> = SVFS ;                                           013700
          P<BLOK$AA> = SVBL ;                                           013800
          END                                                           013900
      END                                                               014000
CONTROL EJECT;
PROC VOKM$AA;      #VERIFY THAT ITS OK TO MODIFY THE FILE#               JJJ0908
 #                                                                       JJJ0908
* *   VOKM$AA                                    PAGE  1                 JJJ0908
* *   VB GODDARD                                 DATE  76/09/07          JJJ0908
* DC  VOKM$AA                                                            JJJ0908
* DC  FUNCTION                                                           JJJ0908
*     VERIFY THAT A FILE MAY BE MODIFIED.                                JJJ0908
* DC  ENTRY CONDITIONS                                                   JJJ0908
*     P<FIT$AA> = FIT ADDRESS.                                           JJJ0908
*     P<FSTT$AA>=FSTT ADDRESS.                                           JJJ0908
*     VOKM$AA IS A SYMPL PROC WITH NO PARAMETERS.                        JJJ0908
* DC  EXIT CONDITIONS                                                    JJJ0908
*     CONTROL IS RETURNED IF OK TO PROCEED WITH FILE MODIFICATION.       JJJ0908
* DC  ERROR CONDITIONS                                                   JJJ0908
*     EC2   - FILE ORGANIZATION MISMATCH, FIT VS FSTT.                   JJJ0908
*     EC201 - FILE CONTAINS BAD BLOCKS.                                  JJJ0908
*     EC202 - FILE IS RUINED.                                            JJJ0908
*     EC52  - FILE WAS PREVIOUSLY NOT PROPERLY CLOSED.                   JJJ0908
*     EC441 - BAD PRIMARY KEY SPECIFICATIONS.                            JJJ0908
*     EC203 - MIP FILE NOT AVAILABLE.                                    JJJ0908
*     EC301 - NO MODIFY PERMISSION.                                      JJJ0908
*     EC302 - NO EXTEND PERMISSION.                                      JJJ0908
*     EC421 - WSA NOT SPECIFIED.                                         CIM0214
*     EC447 - NO KEY ADDRESS SPECIFIED.                                  CIM0202
*     EC373 - INDEX LEVEL OR PTREE CAPACITY EXCEEDED.                    CIM0202
* DC  CALLED ROUTINES                                                    JJJ0908
*     MSGF$AA - TO SEND ERROR MESSAGE AND SET FATAL FLAG
*     MSGZ$AA - TO OUTPUT ERROR DIAGNOSTICS.                             JJJ0908
* DC  DESCRIPTION                                                        JJJ0908
*     VOKM$AA IS CALLED WHENEVER AN AAM FILE IS ABOUT TO BE MODIFIED     JJJ0908
*     BY A MAIN FUNCTION PROCESSOR. THE FUNCTIONS WHICH MODIFY FILES     JJJ0908
*     ARE PUT, REPLACE, AND DELETE. THE PROGRAM IS A SERIES OF IF-TESTS  JJJ0908
*     CHECKING FOR THE ERRORS LISTED UNDER ERROR CONDITIONS. CONTROL IS  JJJ0908
*     RETURNED IF NO ERRORS ARE DETECTED AND THE FILE MODIFICATION MAY   JJJ0908
*     PROCEED. OTHERWISE, A DIAGNOSTIC MESSAGE IS GENERATED AND THE      JJJ0908
*     ERROR EXIT(EXIT$AA) IS TAKEN.                                      JJJ0908
 #                                                                       JJJ0908
CONTROL EJECT;                                                           JJJ0908
      BEGIN                                                              CIM0214
                                                                         JJJ0908
      FS2BLOX[0] = 0 ;                                                  014200
      IF FTCOP NQ OP"DLT" AND FTWSA[0] EQ 0                              CIM0214
      THEN                                                               CIM0214
          BEGIN         #WSA NOT SPECIFIED FOR PUT OR REPLACE#           CIM0214
          ENUM = EC421; 
          GOTO ERR;                                                      CIM0214
          END                                                            CIM0214
      IF FTKA[0] EQ 0                                                    CIM0202
      AND FTRKP[0] EQ 10                                                 CIM0202
      THEN                                                               CIM0202
          BEGIN                                                          CIM0202
          ENUM = EC447;   #NO KEY ADDR SPECIFIED# 
          GOTO ERR;                                                      CIM0202
          END                                                            CIM0202
      IF FSPARBAD[0] NQ 0    #DISALLOW MODS IF FILE HAS BAD BLOCKS#      JJJ0908
      THEN                                                               JJJ0908
          BEGIN                                                          JJJ0908
          ENUM = EC201; 
          GOTO ERR;                                                      VBG1029
          END                                                            JJJ0908
      IF FSRUINFLG[0]        #DITTO IF FILE RUINED#                      JJJ0908
      THEN                                                               JJJ0908
          BEGIN                                                          JJJ0908
          ENUM = EC202; 
          GOTO ERR;                                                      VBG1029
          END                                                            JJJ0908
      IF FSMIPWORD[0] NQ 0   #IF A MIP FILE IT MUST BE ATTACHED#         JJJ0908
      THEN                                                               JJJ0908
          BEGIN                                                          JJJ0908
          IF FTMIPFS[0] EQ 0                                             JJJ0908
          THEN                                                           JJJ0908
              BEGIN                                                      JJJ0908
              ENUM = EC203; 
              GOTO ERR;                                                  VBG1029
              END                                                        JJJ0908
          END                                                            JJJ0908
      IF FTCOP NQ OP"DLT"                                                JJJ0519
      THEN                                                               JJJ0519
          BEGIN                                                          JJJ0519
          IF FSEXCEDPT NQ 0 
          THEN                                                           JJJ0519
              BEGIN                                                      JJJ0519
              ENUM = EC335; 
              GOTO ERR;                                                  JJJ0519
              END                                                        JJJ0519
          IF FSINXFUL NQ 0
          THEN
              BEGIN 
              MSGF$AA(EC372); 
              GOTO EXIT$AA; 
              END 
          IF FTRL GR FSMAXREC OR FTRL LS FSMINREC                        JJJ0519
          THEN                                                           JJJ0519
              BEGIN                                                      JJJ0519
              ENUM = EC167; 
              GOTO ERR;      #REC LENGTH OUT OF RANGE#                   JJJ0519
              END                                                        JJJ0519
          END                                                            JJJ0519
      ELSE                                                               DABBLE 
          BEGIN                                                          DABBLE 
          IF FTKA[0] EQ 0                                                DABBLE 
          THEN                                                           DABBLE 
              BEGIN                                                      DABBLE 
              ENUM = EC447 ;                                             DABBLE 
              GOTO ERR ;                                                 DABBLE 
              END                                                        DABBLE 
          END                                                            DABBLE 
                             #CHECK PERMISSION BITS#                     JJJ0908
      IF FTMER NQ 7                                                      GAG0919
      THEN                                                               GAG0919
          BEGIN  #EXTEND PERMISSION REQUIRED#                            GAG0919
          ENUM = EC554;                                                  GAG0919
          GOTO ERR;                                                      GAG0919
          END                                                            GAG0919
      RETURN;      #ALL IS OK#                                           VBG1029
ERR:                                                                     VBG1029
      MSGZ$AA (ENUM); 
      GOTO EXIT$AA;                                                      VBG1029
      END                                                                JJJ0908
CONTROL EJECT;                                                           ID0913 
PROC XXUR$AA;                                                            SAMNROM
          BEGIN                                                          SAMNROM
                                                                         ID0913 
 #                                                                       ID0913 
* *   XXUR$AA - CHANGE FROM UNIFORM TO NON-UNIFORM RECORDS     PAGE 1    ID0913 
* *   A.F.R.BROWN                                                        ID0913 
* 1DC XXUR$AA                                                            ID0913 
*                                                                        ID0913 
* DC  FUNCTION                                                           ID0913 
*                                                                        ID0913 
*     WHEN A BLOCK HAS THE UR FLAG IN ITS HEADER = 1, INDICATING         ID0913 
*     UNIFORM RECORDS WITH ONLY ONE RECORD POINTER FOR ALL, AND WE       ID0913 
*     ARE ABOUT TO PUT IN A RECORD THAT WILL DESTROY THE UNIFORMITY,     ID0913 
*     WE MUST FIRST ADJUST THE BLOCK TO NON-UNIFORMITY, BY SETTING       ID0913 
*     UP ONE RECORD POINTER PER RECORD. XXUR$AA DOES THIS.               ID0913 
*                                                                        ID0913 
* DC  ENTRY CONDITIONS                                                   ID0913 
*                                                                        ID0913 
*     P<BLOK$AA> LOCATES THE CURRENT BLOCK.                              ID0913 
*     BLKUR[0] ( UR ) THE UNIFORM RECORD FLAG IN THE HEADER, MUST BE 1.  ID0913 
*                                                                        ID0913 
* DC  EXIT CONDITIONS                                                    ID0913 
*                                                                        ID0913 
*     BLKUR[0] = 0.                                                      ID0913 
*     THERE IS NOW ONE RECORD POINTER PER RECORD IN THE BLOCK.           ID0913 
*     BLECNT[0] ( EC ) THE COUNT OF HALF-WORDS OF FREE SPACE IN THE      ID0913 
*        BLOCK, HAS BEEN REDUCED BY THE NUMBER OF ADDED RECORD POINTERS. ID0913 
*                                                                        ID0913 
* DC  ERROR CONDITIONS                                                   ID0913 
*                                                                        ID0913 
*     FATAL ERROR IF NO ROOM AFTER ALL.                                  CY210
*                                                                        ID0913 
* DC  CALLED ROUTINES                                                    ID0913 
*                                                                        ID0913 
*     RPPT$AA - TO INSERT THE FIRST ADDITIONAL RECORD POINTER.           ID0913 
*                                                                        ID0913 
* DC  NON-LOCAL VARIABLES                                                ID0913 
*                                                                        ID0913 
*     IX USED FOR SCRATCH.                                               CY210
*                                                                        ID0913 
 #                                                                       ID0913 
          ITEM TLW;          #TEMP LWA#                                  SAMNROM
                                                                         SAMNROM
                             #START OF XXUR$AA CODE#                     ID0913 
          IF RC GR 1                                                     SAMNROM
          THEN                                                           SAMNROM
            BEGIN                                                        SAMNROM
            IX = EC - (RC - 1); 
            IF IX LS 0
          THEN
              BEGIN 
              IMPOSSIBLE ( ECNEG ) ;
              END 
            EC = IX;
            TLW = 2 * LWAFIELD;                                          SAMNROM
            LWAFIELD = TLW;                                              SAMNROM
            RPPT$AA (2);                                                 SAMNROM
            TLW = TLW + TLW * 2**30;                                     SAMNROM
            FOR IX = 2 STEP 1 UNTIL (RC+1)/2                             SAMNROM
              DO  W[BLOCLWA-IX] = W[BLOCLWA-IX+1] + TLW;                 SAMNROM
            END                                                          SAAMNRO
          UR = 0 ;                                                       SAAMNRO
          END                                                            SAAMNRO
                                                                         SAAMNRO
          END   TERM                                                     SAAMNRO
