*DECK OPENDAA                                                           000100
*CALL COMUSETXT 
PROC OPEN$AA;                                                            *--AK--
      BEGIN                                                             001000
      XREF                                                              001050
          BEGIN                                                         001060
          PROC IOWR$AA;      #BLOCK WRITE#                              001100
          PROC ALTR$AA;      #LOGGING INTERFACE#                        001110
          PROC MSGZ$AA;      #OUTPUT MESSAGE#                           001120
          FUNC CMM$ALF;      #ALLOCATE CMM SPACE WITH ZEROING#          001140
          FUNC CMM$GOS;                                                  *--AK--
          FUNC DICO$AA;      #GENERATE STANDARD DICOTAB#                001150
          PROC CRA1$AA;      #SYSTEM REQUEST#                           001170
          PROC OWN$AA ;                                                  AFB0528
          PROC CMM$FRF ;                                                 AFB0528
          PROC LOADCPR;      #LOAD SYSTEM COMPRESSION CAPSULE#
          PROC UNLDCPR;      #UNLOAD SYSTEM COMPRESSION CAPSULE#
          PROC MSGD$AA;      #OUTPUT MESSAGE WITH DECIMAL INSERT# 
          PROC MSGF$AA;      #OUTPUT FATAL ERROR MESSAGE# 
          PROC STMD$AA;                                                  JJJ0606
          PROC IMPR$AA; 
          FUNC RESP$AA;                                                  AM2A011
          PROC FLSH$AA;      #FLUSH BUFFERS#
          FUNC CKSM$AA;                                                  RPNMIP 
          FUNC MIPTIME;                                                  RPNMIP 
          PROC WTIO$AA;                                                  RPNMIP 
          PROC INCH$AA;      #LINK BLOCKS TO BUFFER CHAIN#               VBG1104
          PROC INFO$AA;      #FILE INFORMATION#                          VBG1025
          PROC INIT$AA; 
          PROC CLUN$AA; 
          PROC MFET$AA;      #SET FET POINTERS#                          VBG1112
          FUNC POWR$AA;                                                  GAG0726
          PROC UNCH$AA; 
          PROC BADM$AA ;
          LABEL EXIT$AA;     #ERROR EXIT#                                JJJ0913
          ITEM AAM$BL ; 
          FUNC HASH$DA ;                                                 *--AK--
          PROC SEBL$AA ;                                                 *--AK--
          PROC SETR$AA ;                                                 *--AK--
          END                                                           001200
  
CONTROL WEAK HASH$DA ;
  
      CONTROL WEAK AAM$BL ; 
                                                                         JJJ0724
      XDEF                                                               JJJ0724
          BEGIN                                                          JJJ0724
          PROC CLSF$AA;                                                  *--AK--
          PROC CLSF$AK ;
          PROC CLSF$DA ;
          PROC CLSF$IS ;
          PROC FATERR;
          END                                                            JJJ0724
                                                                         JJJ0724
          ITEM FOTYPE;       #FTFO[0] PLACED INTO FOTYPE AT START#       *--AK--
          ITEM MIPFL ; #MIP FILE LGTH IN PRUS AT OPEN#
          ITEM DATFL ; #DATA FILE DITTO#
          ITEM BCNTD;        #COUNT OF DATA BLOCKS DESIRED IF ONE FIT  # JJJ0402
          ITEM BCNTM;        #COUNT OF MIP BLOCKS DESIRED IF ONE FIT   # JJJ0402
          ITEM DBS;          #TRUE SIZE OF DATA BLOCK                  # JJJ0402
          ITEM MIPFS;        # MIP FSTT FWA IF ANY #
          ITEM DATFS;        #DATA FILE FSTT FWA IF ANY#
          ITEM MBCNTD;       #NUMBER OF DATA BLOCKS NEEDED AS A MINIMUM# JJJ0402
          ITEM MBCNTM;       #NUMBER OF MIP BLOCKS NEEDED AS A MINIMUM # JJJ0402
          ITEM MBS;          #TRUE SIZE OF MIP BLOCK                   # JJJ0402
          ITEM MXBS;         # CELL FOR HOLDING XBS # 
          ITEM UBSA;         #ADDRESS OF UNASSIGNED UBS#                 *--AK--
      ITEM UBSL;             #LENGTH OF UNASSIGNED UBS#                 001220
      ITEM UBSLP;            #PREVIOUS UBSL VALUE#                      001230
      ITEM UBSFLG; #UBS ALLOCATION FLAG, 1 IF IN UBS, 0 IF NOT#          VBG1104
      ITEM I,J,K,L;          #TEMPORARY INDEX ITEMS#                    001240
      ITEM X,Y,Z;            #TEMPORARY ITEMS, USUALLY ADDRESSES#       001250
      ITEM MIP;              #INDEX TO MIP FSTT#                        001260
      ITEM CMPLFSTT;         #COMPLEMENT OF FSTT BEING SEARCHED FOR#     JJJ0428
          ITEM XFWB;         #HOLDS FWB FOR DURATION OF OPEN PROCESS#    *--AK--
          ITEM SYSCOMP;                                                  *--AK--
      ITEM CBL ;                                                         AFB0528
      ITEM IX , I2 ;         #INDUCTION VARIABLES#                       JJJ0111
      ITEM IX2 , T1 , T2; 
          ITEM L1 , L2 , L3; #LINK ADDR USED IN RLSP AND DLNK#           *--AK--
CONTROL EJECT;                                                          001270
FUNC GETSPACE(SIZE);         #ALLOCATE SPACE, EITHER CMM OR UBS#        001280
 #                                                                      001290
* *   OPEN$AA                                    PAGE  1                 *--AK--
* *   GETSPACE                                                          001310
* *   VB GODDARD                                 DATE  76/08/25         001320
* DC  NAME                                                              001330
* C   GETSPACE                                                          001340
* DC  FUNCTION                                                          001350
*     ALLOCATE SPACE FROM EITHER UBS OR CMM SPACE.                      001360
* DC  ENTRY CONDITIONS                                                  001370
*     GETSPACE IS A FUNCTION HAVING ONE PARAMETER, THE BLOCK SIZE TO    001380
*     BE ALLOCATED.                                                     001390
*     GLOBAL ITEMS:                                                     001400
*         UBSA=ADDRESS OF UNASSIGNED USER BUFFER SPACE.                 001410
*             =0 IF NO UBS.                                             001420
*         UBSL=NUMBER OF WORDS AVAILABLE FOR ASSIGNMENT IN UBS.         001430
* DC  EXIT CONDITIONS                                                   001440
*     1 THE ADDRESS OF THE BLOCK ALLOCATED IS RETURNED TO THE CALLER.   001450
*     2 UBSA AND UBSL ARE UPDATED IF THE BLOCK WAS ALLOCATED IN UBS.    001460
*     3 THE BLOCK ALLOCATED IS ZEROED.                                  001470
* DC  ERROR CONDITIONS                                                  001490
*     EC354 - INSUFFICIENT UBS AND NO CMM.                               AM2A077
* DC  CALLED ROUTINES                                                   001510
*     CMM$ALF - TO ALLOCATE CMM SPACE.                                  001520
* DC  NON-LOCAL VARIABLES                                               001530
*     UBSA - UPDATED TO REFLECT ALLOCATION FROM UBS.                    001540
*     UBSL - UPDATED TO REFLECT ALLOCATION FROM UBS.                    001550
* DC  DESCRIPTION                                                       001560
*     IF ENOUGH UBS IS AVAILABLE THEN THE BLOCK IS ASSIGNED THERE AND   001570
*     UBSA AND UBSL ARE UPDATED BY THE SIZE OF THE BLOCK. OTHERWISE     001580
*     THE BLOCK IS ASSIGNED IN CMM SPACE IF CMM IS AVAILABLE. IF NO     001590
*     ASSIGNMENT WAS MADE AN ERROR IS GENERATED.                         AM2A077
 #                                                                      001610
CONTROL EJECT;                                                          001620
          BEGIN                                                         001630
          ITEM SIZE;                                                    001640
                                                                        001650
                                                                        001660
                                                                        001670
          IF UBSA GR 0       #UBS AVAILABLE#                            001680
          THEN                                                          001690
              BEGIN          #YES#                                      001700
              IF UBSL GQ SIZE #ENOUGH#
              THEN                                                      001720
                  BEGIN      #YES#                                      001730
                  GETSPACE=UBSA;    #ALLOCATE#                          001740
                  FOR I=1 STEP 1 UNTIL SIZE                             001760
                      DO                                                001770
                      BEGIN                                             001780
                      W[I+UBSA-1]=0;                                     VBG0922
                      END                                               001800
                  UBSA=UBSA+SIZE;      #SET NEW START ADDRESS#          001810
                  UBSL=UBSL-SIZE;      #SET NEW AMOUNT LEFT#            001820
                  UBSFLG=1;  #FLAG UBS ALLOCATION#                       VBG1104
                  RETURN;                                               001830
                                                                        001840
                  END                                                   001850
              END                                                       001860
          IF NOT NOCMM            #CMM AVAILABLE#                       001870
          THEN                                                          001880
              BEGIN                                                     001890
              GETSPACE=CMM$ALF(SIZE,0,0);        #YES, ASSIGN IT#       001900
              UBSFLG=0;      #FLAG CMM ALLOCATION#                       VBG1104
              END                                                       001910
          ELSE                                                          001920
              BEGIN                                                     001930
              FATERR(EC354); #NO, ERROR#                                001940
              END                                                       001950
          RETURN;                                                       001960
          END                                                           001970
CONTROL EJECT;                                                           AM2A077
FUNC TRIAL ;                                                             AFB0528
      BEGIN                                                              AFB0528
 #                                                                       AM2A077
* *   TRIAL - RETURN THE COMPRESSION PASSWORD        PAGE  1             AM2A077
* *   A.F.R.BROWN                                                        AM2A077
* 0DC TRIAL                                                              AM2A077
* 0DC FUNCTION                                                           AM2A077
* 0   TO RETURN THE PASSWORD GENERATED BY THE COMPRESSION RTN AND ENSURE AM2A077
*     THAT DCA IS NON-ZERO, AND THAT THE COMPRESSION BUFFER IS LARGE     AM2A077
*     ENOUGH FOR THIS FILE.                                              AM2A077
* 0DC ENTRY CONDITIONS                                                   AM2A077
* 0   FIT$AA AND FSTT$AA ARE SET FOR THE FILE. FTCPA POINTS TO ROUTINE.  AM2A077
*     NOCMM IS SET IF CMM IS NOT AVAILABLE                               AM2A077
* 0DC EXIT CONDITIONS                                                    AM2A077
* 0   IF NOCMM, A COMPRESSION BUFFER LARGE ENOUGH FOR MRL + 1 WORDS IS   AM2A077
*     ALOCATED IN UBS.                                                   AM2A077
* 0   IF CMM, THE BUFFER POINTED TO BY CBUFAD IS LARGE ENOUGH FOR THIS   AM2A077
*     FILE.                                                              AM2A077
* 0   THE VALUE OF TRIAL IS SET TO PASSWORD RETURNED BY COMPRESSION RTN. AM2A077
* 0DC ERROR CONDITIONS                                                   AM2A077
* 0   EC535 - IF DCA IS EQUAL TO 0.                                      AM2A077
* 0DC CALLED ROUTINES                                                    AM2A077
* 0   FATERR - ISSUE ERROR MSG AND EXIT.                                 AM2A077
* 0   GETSPACE - ALLOCATE UBS SPACE CAUSE NOCMM. WILL NOT RETURN IF NOT  AM2A077
*                ENOUGH SPACE.                                           AM2A077
* 0   CMM$FRF - RELEASE CMM SPACE IF CURRENT BUFFER TOO SMALL.           AM2A077
* 0   CMM$ALF - ALLOCATE CMM SPACE FOR COMPRESSION BUFFER                AM2A077
* 0   OWN$AA - CALL COMPRESSION ROUTINE                                  AM2A077
 #                                                                       AM2A077
      ITEM ZILCH = "ABCDEFGHIJ" ;                                        AFB0528
      ITEM X ;                                                           AFB0528
                                                                         AFB0528
      IF FTDCA[0] EQ 0                                                   AFB0528
      THEN                                                               AFB0528
          BEGIN                                                          AFB0528
          FATERR(EC535);     #DECOMPRESSION ROUTINE MISSING#
          END                                                            AFB0528
      X = 1 + WLG(FSMAXREC[0]) ;                                         AFB0528
      IF NOCMM                                                           AFB0528
      THEN                                                               AFB0528
          BEGIN                                                          AFB0528
          FSCOMPBUF[0] = GETSPACE ( X ) ;                                AFB0528
          CBUFAD = FSCOMPBUF[0] ;                                        AFB0528
          CBUFSZ = WC * X ;                                              *--AK--
          END                                                            AFB0528
      ELSE                                                               AFB0528
          BEGIN                                                          AFB0528
          IF CBUFSZ LS WC * X                                            *--AK--
          THEN                                                           AFB0528
              BEGIN                                                      AFB0528
              IF CBUFAD NQ 0                                             AFB0528
              THEN                                                       AFB0528
                  BEGIN                                                  AFB0528
                  CMM$FRF (CBUFAD);                                      AFB0528
                  END                                                    AFB0528
              CBUFAD = CMM$ALF (X,0,0);                                  AFB0528
              CBUFSZ = WC * X ;                                          *--AK--
              END                                                        AFB0528
          END                                                            AFB0528
      OWN$AA(FTCPA[0],LOC(ZILCH),WC,0,0,0,CBUFAD,CBUFSZ,COND) ;          *--AK--
      TRIAL = W[CBUFAD] ;                                                AFB0528
      END                                                                AFB0528
                                                                         AFB0528
                                                                         AFB0528
CONTROL EJECT;                                                           JJJ0402
PROC CTRG$AA;                                                            JJJ0402
          BEGIN                                                          JJJ0402
 #                                                                       JJJ0402
* *   CTRG$AA - CALCULATE TARGET VALUES FOR A FILE   PAGE  1             JJJ0402
* *   J.J. JANIK                                     DATE  76/11/28      JJJ0402
* 0DC FUNCTION                                                           JJJ0402
* 0   TO SET FSTARGET AND FSMINTARG FOR A FILE.                          JJJ0402
* 0DC ENTRY CONDITIONS                                                   JJJ0402
* 0   FSTT$AA POINTS TO FILES FSTT WHICH IS IN THE FSTT CHAIN            JJJ0402
*     ALL FITS ARE LINKED TO THE FSTT.                                   JJJ0402
* 0DC EXIT CONDITIONS                                                    JJJ0402
* 0   FSTARGET = IDEAL AMOUNT OF CMM SPACE FOR THIS FILE                 JJJ0402
*     FSMINTARG = MINIMUM CMM SPACE NEEDED FOR THIS FILE                 JJJ0402
* 0DC DESCRIPTION                                                        JJJ0402
 #                                                                       JJJ0402
                                                                         JJJ0402
# THE FOLLOWING DEFS ARE USED IN CALCULATING TARGET #                    JJJ0402
          DEF DDAIDEAL #2#;  #NUMBER OF BLOCKS FOR DA#                   JJJ0402
          DEF DAKIDEAL #2#;  #NUMBER OF BOLCKS FOR AK#                   JJJ0402
          DEF DIS1LEV  #3#;  #NUMBER OF BLOCKS FOR 1 LEV IS#             JJJ0402
          DEF DISMLEV  #6#;  #NUMBER OF BLOCKS FOR MULTI-LEV IS#         JJJ0402
          DEF DMLVMIP  #7#;  #NUMBER OF BLOCKS FOR MULTI-LEV MIP#        JJJ0402
          DEF D1LVMIP  #4#;  #NUMBER OF BLOCKS FOR 1 LEV IS#             JJJ0402
                                                                         JJJ0402
 #
*     FUNCTION BLKSZ RETURNS THE BLOCK SIZE IN WORDS FOR THE MIP OR 
*     DATA FILE. THE INPUT PARAMETER IS 0 IF THE FILE DOES NOT EXIST, 
*     OR OTHERWISE POINTS TO ITS FSTT.
 #
FUNC BLKSZ ( N ) ;
      BEGIN 
  
      ITEM N ;
  
      IF N EQ 0 
      THEN
          BEGIN 
          BLKSZ = 0 ; 
          END 
      ELSE
          BEGIN 
          BLKSZ = FSBLKSIZ[N-P<FSTT$AA>] * DPRUSIZ - 2 + DBLKFRAME ;
          END 
      END 
  
 #
*     FUNCTION MUBCT RETURNS, FOR THE MIP OR DATA FILE, THE NUMBER OF 
*     BLOCKS BY WHICH FSBUFCNT IN ITS FSTT FALLS SHORT OF 2. IT IS ONLY 
*     CALLED WHEN SOME USER BUFFER SPACE IS SUPPOSED TO HAVE BEEN 
*     ASSIGNED TO THE FILE,TO SEE HOW MANY EXTRA BLOCKS WOULD HAVE TO BE
*     REQUESTED FROM CMM TO BRING IT UP TO THE MINIMUM. THE INCOMING
*     PARAMETER IS 0 IF THE FILE DOES NOT EXIST, OTHERWISE IT POINTS
*     TO ITS FSTT.
 #
FUNC  MUBCT ( N ) ; 
      BEGIN 
  
      ITEM N ;
  
      IF N EQ 0 
      THEN
          BEGIN 
          MUBCT = 0 ; 
          END 
      ELSE
          BEGIN 
          T1 = 2 - FSBUFCNT[N-P<FSTT$AA>] ; 
          IF T1 LS 0
          THEN
              BEGIN 
              MUBCT = 0 ; 
              END 
          ELSE
              BEGIN 
              MUBCT = T1 ;
              END 
          END 
      END 
  
 #                                                                       JJJ0402
* 0   INITIALIZE ALL TEMPORARIES                                         JJJ0402
 #                                                                       JJJ0402
          FSTARGET = 0;                                                  JJJ0402
          FSMINTARG = 0;                                                 JJJ0402
          MIPFS = 0 ; 
          DATFS = 0 ; 
          BCNTD = 0;                                                     JJJ0402
          BCNTM = 0;                                                     JJJ0402
          MBCNTD = 2 ;
          MBCNTM = 2 ;
 #
*     IF THERE IS NO MIP FILE, THE EFFECT OF MBCNTM WILL BE NEGATED BY
*     SETTING MBS, THE LENGTH OF A MIP BLOCK, TO 0. 
* 
*     SET MIPFS=0 IF THERE IS NO MIP FILE FOR THIS FIT, OTHERWISE TO
*     THE ADDRESS OF THE FSTT OF THE MIP FILE. LIKEWISE SET DATFS 
*     FOR THE DATA FILE.
 #
          IF FSMIPFLG[0]
          THEN
              BEGIN 
              MIPFS = P<FSTT$AA> ;
              END 
          ELSE
              BEGIN 
              MIPFS = FSMIPFSTT[0] ;
              DATFS = P<FSTT$AA> ;
              END 
 #
*     SET DBS=0 IF NO DATA FILE, OTHERWISE TO THE SIZE OF ITS BLOCKS
*     IN WORDS, ACCORDING TO FSBLKSIZ IN ITS FSTT. LIKEWISE MBS=0 
*     IF NO MIP FILE, OTHERWISE TO THE SIZE OF ITS BLOCKS.
 #
          DBS = BLKSZ ( DATFS ) ; 
          MBS = BLKSZ ( MIPFS ) ; 
 #
*     IF USER BUFFER SPACE IS POINTED TO BY THE FIT, SET FSMINTARG
*     TO THE SUM OF THE MINIMUM ADDITIONAL BLOCK COUNT(S) FOR THE 
*     FILE(S) TIMES THE BLOCK LENGTH(S). FSTARGET NEED NOT BE SET.
*     IF FSMINTARG IS NONZERO, FSTARGET WILL LATER BE EQUATED TO IT.
 #
          IF FSFWBOPN[0] NQ 0 
          THEN
              BEGIN 
              FSMINTARG[0] = MBS*MUBCT(MIPFS) + DBS*MUBCT(DATFS) ;
              END 
 #
*     OTHERWISE WORK OUT THE PREFERRED BLOCK COUNT FOR EACH FILE. 
 #
          ELSE
              BEGIN 
              IF MIPFS NQ 0 
              THEN
                  BEGIN 
                  IF FSPT2SZ[MIPFS-P<FSTT$AA>] GR 3 
                    OR FSPT3SZ[MIPFS-P<FSTT$AA>] GR 3 
                  THEN
                      BEGIN 
                      BCNTM = DMLVMIP ; 
                      END 
                  ELSE
                      BEGIN 
 #
*     NOTE THAT IN THE MAIN SUBFILE OF A MIP FILE, THERE IS ONE RECORD
*     FOR EACH ALTERNATE KEY DEFINITION. SO FSRECCNT[0] IS THE NUMBER 
*     OF KEY DEFINITIONS, AND WE DESIRE TO ALLOW AN EXTRA BLOCK SPACE 
*     IF THIS IS AN OPEN-NEW, THIS COUNT WILL BE 0 BECAUSE WE DO NOT YET
*     KNOW HOW MANY KEY DEFINITIONS -- IN THIS CASE USE 3.
 #
                      BCNTM = D1LVMIP-1+FSRECCNT[MIPFS-P<FSTT$AA>] ;
                      IF BCNTM EQ D1LVMIP-1 
                      THEN
                          BEGIN   #NEW MIP FILE,GUESS 3 KEYDEFS#
                          BCNTM = D1LVMIP+2 ; 
                          END 
                      END 
                  END 
              IF DATFS NQ 0 
              THEN
                  BEGIN 
                  IF FSHEADW[0] EQ FSTTHIS
                  THEN
                      BEGIN 
                      IF FSNDXLVLS[0] GR 1
                      THEN
                          BEGIN 
                          BCNTD = DISMLEV ; 
                          END 
                      ELSE
                          BEGIN 
                          BCNTD = DIS1LEV ; 
                          END 
                      END 
                  ELSE
                      BEGIN 
                      IF FSHEADW[0] EQ FSTTHDA
                      THEN
                          BEGIN 
                          BCNTD = DDAIDEAL ;
                          END 
                      ELSE
                          BEGIN 
                          BCNTD = DAKIDEAL ;
                          END 
                      END 
                  END 
 #
*     NOW LOOK AT ALL THE FITS ASSOCIATED WITH THIS FILE, INCLUDING THE 
*     CURRENT FIT. (REMEMBER THAT THIS CODE IS NOT DONE IF THERE WAS
*     USER BUFFER SPACE ASSIGNED TO THE FILE. IN THAT CASE THERE COULD
*     IN ANY EVENT BE ONLY ONE FIT FOR THE FILE.) EVEN THOUGH NO
*     USER BUFFER SPACE WAS ASSIGNED TO THE FILE, BFS IN ANY FIT MAY BE 
*     NON-ZERO, INDICATING HOW MANY WORDS THE USER WANTS THAT FIT TO
*     CONTRIBUTE TO FSTARGET FOR THE FILE(S). IF SO, WE JUST ADD BFS TO 
*     FSTARGET. APART FROM THESE CASES, LET EVERY FIT THAT REFERS TO
*     THE DATA FILE CONTRIBUTE 1 TO L1, BUT LET THE FIRST SUCH FIT
*     CONTRIBUTE BCNTD. THEN L1 IS A BLOCK TOTAL FOR THE DATA FILE, 
*     AND WE ADD L1*DBS INTO FSTARGET. SIMILARLY WITH L2 AND BCNTM, 
*     FOR THE MIP FILE, AND WE ADD L2*MBS INTO FSTARGET.
 #
              L1 = 0 ;
              L2 = 0 ;
              T2 = P<FIT$AA> ;
              FOR T1 = FSFTCHN[0] WHILE T1 NQ 0 
              DO
                  BEGIN 
                  P<FIT$AA> = T1 ;
                  X = FTBFS[0] ;
                  FSTARGET[0] = FSTARGET[0] + X ; 
                  IF FTXN[0] NQ 0 
                  THEN
                      BEGIN 
                      IF X EQ 0 
                      THEN
                          BEGIN 
                          L2 = L2 + BCNTM ; 
                          BCNTM = 1 ; 
                          END 
                      END 
                  IF FTNDX[0] EQ 0
                  THEN
                      BEGIN 
                      IF X EQ 0 
                      THEN
                          BEGIN 
                          L1 = L1 + BCNTD ; 
                          BCNTD = 1 ; 
                          END 
                      END 
                  IF FTPD[0] NQ PD"INPUT" 
                  THEN
                      BEGIN 
                      MBCNTD = 3 ;
                      END 
                  T1 = FTFTCH[0] ;
                  END 
              P<FIT$AA> = T2 ;
              FSTARGET[0] = FSTARGET[0] + L2 * MBS + L1 * DBS ; 
              FSMINTARG[0] = MBCNTD * DBS + MBCNTM * MBS ;
              END 
          END  #OF CTRG$AA#                                              JJJ0402
CONTROL EJECT;                                                           RPNMIP 
FUNC SRCHFSTT(TYPE);                                                     RPNMIP 
 #                                                                       RPNMIP 
* *   SRCHFSTT - FIND MATCHING FSTT              PAGE  1                 AM2A077
* 1DC SRCHFSTT                                                           AM2A077
* 0DC FUNCTION                                                           AM2A077
* 0   SRCHFSTT SEARCHES THE FSTT CHAIN FOR A MATCHING FILE TO THE ONE    AM2A077
*     DESCRIBED BY THE FIT.  THE PARAMETER TYPE = 0 IF WE ARE LOOKING    RPNMIP 
*     FOR A DATA FILE MATCH, 1 FOR INDEX FILE.                           RPNMIP 
*0CD  ENTRY CONDITIONS.                                                  RPNMIP 
*     P<FIT$AA> IS SET POINTING TO THE FIT IN QUESTION.                  RPNMIP 
*0CD  EXIT CONDITIONS                                                    RPNMIP 
*     SRCHFSTT = ADDRESS OF FSTT IF FOUND.                               RPNMIP 
*              = 0 IF NOT FOUND                                          RPNMIP 
*             = - ADDRESS OF COMPLEMENT FSTT IF SEARCHED FOR FSTT        JJJ0428
*               WAS NOT FOUND BUT COMPLEMENT WAS.  THE                   JJJ0428
*                COMPLEMENT FSTT IS THE FSTT OF THE FILE THAT IS         RPNMIP 
*                ASSOCIATED WITH THE CURRENT FILE IN QUESTION AS AN      RPNMIP 
*                INDEX-DATA FILE PAIR.                                   RPNMIP 
*     CMPLFSTT = -ADDRESS OF THE COMPLEMENT FSTT REGARDLESS OF WHETHER   JJJ0428
*                THE DESIRED FSTT WAS FOUND.                             JJJ0428
*0CD  DESCRIPTION.                                                       RPNMIP 
*     SET I TO FSTTHED, AND GO INTO THE DO LOOP TO STEP DOWN THE CHAIN   RPNMIP 
*     OF FSTT.  ANY TIME WE ARE AT AN FSTT, GET THE LFN FROM ONE OF ITS  RPNMIP 
*     FITS AND COMPARE IT TO THE CURRENT ONE.  IF EQUAL, J IS SET TO     RPNMIP 
*     EITHER + OR - OF THAT FSTT ADDRESS DEPENDING ON TYPE.  OTHER, WE   RPNMIP 
*     GO TO NEXT FSTT UNTIL WE REACH THE END.                            RPNMIP 
 #                                                                       RPNMIP 
BEGIN                                                                    RPNMIP 
      ITEM I,J,K,L,TYPE;                                                 RPNMIP 
      CMPLFSTT = 0;                                                      JJJ0428
      I=FSTTHED;                                                         RPNMIP 
      FOR J=0 WHILE I NQ 0          #TRAVERSE FSTT CHAIN#                RPNMIP 
        DO                                                               JJJ0428
        BEGIN                                                            JJJ0428
        P<FSTT$AA> = I;                                                  JJJ0428
        I = FSFSCHN;         #GO TO NEXT FSTT#                           RPN0512
        IF FSFTCHN NQ 0      #THERE ARE FITS LINKED TO THIS FSTT#        JJJ0428
        THEN                                                             JJJ0428
          BEGIN                                                          JJJ0428
          K=FSFTCHN[0]-P<FIT$AA>;   #INDEX TO FIT#                       RPNMIP 
          IF FTLFN[0] EQ FTLFN[K]                                        RPNMIP 
          THEN                                                           RPNMIP 
              BEGIN                                                      RPNMIP 
              IF FSMIPFLG THEN L=1;                                      RPNMIP 
                          ELSE L=0;                                      RPNMIP 
              IF TYPE EQ L                                               JJJ0428
              THEN                                                       JJJ0428
                  BEGIN                                                  JJJ0428
                  J = P<FSTT$AA> ;                                       JJJ0428
                  IF CMPLFSTT NQ 0                                       JJJ0428
                  THEN                                                   JJJ0428
                      BEGIN                                              JJJ0428
                      I = 0;  #DONE, FOUND BOTH#                         JJJ0428
                      END                                                JJJ0428
                  END                                                    JJJ0428
              ELSE                                                       JJJ0428
                  BEGIN                                                  JJJ0428
                  CMPLFSTT = -P<FSTT$AA>;                                JJJ0428
                  IF J EQ 0  #SEE IF REAL ONE FOUND#                     JJJ0428
                  THEN                                                   JJJ0428
                      BEGIN                                              JJJ0428
                      J = CMPLFSTT;  #ONLY FOUND COMPLEMENT#             JJJ0428
                      END                                                JJJ0428
                  ELSE                                                   JJJ0428
                      BEGIN                                              JJJ0428
                      I = 0;  #DONE FOUND BOTH#                          JJJ0428
                      END                                                JJJ0428
                  END                                                    JJJ0428
              END                                                        RPNMIP 
          END                                                            JJJ0428
        END                                                              JJJ0428
      SRCHFSTT = J;                                                      RPNMIP 
END   #END SRCHFSTT#                                                     RPNMIP 
CONTROL EJECT;                                                           AM2A077
PROC CLSF$AA;                #PROCESS CLOSEM FOR AN AAM FILE#            *--AK--
 #
* *   CLSF$AA - CLOSE AN AAM FILE                PAGE  1                 *--AK--
* *   VB GODDARD                                 76/08/27 
* DC  NAME
* C   CLSF$AA                                                            *--AK--
* DC  FUNCTION
*     PROCESS A CLOSEM REQUEST TO CLOSE A FILE. 
* DC  ENTRY CONDITIONS
*     FIT$AA CONTAINS FIT ADDRESS.                                       VBG1005
* DC  EXIT CONDITIONS 
*     THE FILE IS CLOSED. 
*     THE FSTT AND FIAT LINKS IN THE FIT ARE CLEARED. 
* DC  ERROR CONDITIONS
*     EC200 - BAD FSTT. 
* DC  CALLED ROUTINES 
*     MSGZ$AA - MESSAGES. 
*     MSGD$AA - MESSAGES WITH DECIMAL INSERT ITEMS. 
*     MSGF$AA - FATAL ERROR MESSAGES. 
*     CRA1$AA - CIO CLOSE REQUEST.
*     DLNK$AA - DELINKING FOR THE FIT.
*     CTRG$AA - RECALCULATE FSTARGET AND FSMINTARG                       AM2A095
*     STRG$AA - RECALCULATE TARGET AND MINTARG                           AM2A095
*     RLSP$AA - RELEASE CMM SPACE.
*     FLSH$AA - FLUSH BUFFERS.
*     STATIS  - STATISTICS FOR IS FILES.
*     CLOSFIL - ISSUE CIO CLOSE                                          AM2A077
*     WTIO$AA - ENSURE ALL I/O DONE ON FILE                              AM2A077
*     STG$AA - RECALCULATE TARGET                                        AM2A077
*     RESP$AA - RELEASE CMM SPACE                                        AM2A077
*     CMM$FRF - FREE TOO LARGE OR UNNEEDED COMPRESSION BUFFER            AM2A077
*     CMM$ALF - ALLOCATE NEW COMPRESSION BUFFER                          AM2A077
*     CLUN$AA - UNLOAD UNNEED CAPSULES                                   AM2A077
*     UNLDCPR - UNLOAD COMPRESSION ROUTINE                               AM2A077
*     STMD$AA - SET MODE BACK TO DATA FILE IF NDX LEFT ON BUT DATA FILE  AM2A077
*               OPEN                                                     AM2A077
* DC  DESCRIPTION 
*     THIS PROC IS MUCH SIMPLER THAN YOU WOULD THINK BECAUSE MOST OF
*     THE WORK REQUIRED IN CLOSING A FILE IS DONE BY FLSH$AA AND CIO, 
*     BOTH OF WHICH CLSF$AA MUST CALL.                                   *--AK--
*     THE CAPSULE USAGE MASK IS MOVED TO FIT.                            AM2A077
*     IF NDX ON AND DATA FILE OPENED, CALL STMD$AA                       AM2A077
*     THE FSTT HEADER WORD IS CHECKED.
*     THE FIT OC FIELD IS SET CLOSED.                                    VBG1006
*     FTCPA IS SET TO THE SYSTEM COMPRESSION ROUTINE NUMBER IF IT EXISTS AM2A077
*     IF A MIP FILE IS IN USE BY THE FIT, THE TIME AND DATE ARE ALSO
*     SET IN THE MIP FSTT, AND VALUES NEEDED TO GENERATE THE FIAT NEXT
*     OPEN ARE MOVED FROM THE MIP FSTT TO THE DATA FSTT.
*     FLSH$AA IS CALLED TO FLUSH ALL BUFFERS, INCLUDING THE FSTT. 
*     DLNK$AA IS CALLED TO DELINK THE FIT AND POSSIBLY THE FSTT AND 
*     DATA BUFFERS FROM CRM TABLES AND LISTS. 
*     IF THE USER COUNT IS ZERO, THE CBL IS SET FOR USE LATER IN         AM2A077
*     FREEING OR REDUCING THE COMPRESSION BUFFER. IN ADDITION, CLOSFIL   AM2A077
*     IS CALLED.                                                         AM2A077
*     IF THE USER COUNT FOR THE MIP FILE IS ZERO CLOSFIL IS CALLED FOR   AM2A077
*     THE MIP FILE.                                                      AM2A077
*     STATIS IS CALLED AND FTFWB IS RESTORED.                            AM2A077
*     IF THE FIT BEING CLOSED WAS ALSO THE LAST BUSY FET, THE CHANGE     VBG0922
*     THE LAST BUSY FET TO BE THE FIT AT THE HEAD OF THE FIT CHAIN.      VBG0922
*     IF FILE WAS CLOSED, CALL STRG$AA.                                  AM2A077
*     RLSP$AA IS CALLED TO RELEASE ALL CMM SPACE RESERVED FOR THE FIT.
*     IF COMPRESSION BUFFER NEEDS ADJUSTING OR FREED, DO IT.             AM2A077
*     CALL CLUN$AA TO UNLOAD UNUSED CAPSULES, AND UNLDCPR TO UNLOAD THE  AM2A077
*     SYSTEM COMPRESSION ROUTINE IF ONE IS USED.                         AM2A077
 #
CONTROL EJECT;
ENTRY PROC CLSF$AK ;
ENTRY PROC CLSF$DA ;
ENTRY PROC CLSF$IS ;
      BEGIN 
          FTAAMSR1=FACAPUSM;  #MOVE CAPSULE USAGE MASK BACK TO FIT# 
      IF FTFSTT EQ 0 AND FTNDX NQ 0                                      JJJ0428
      THEN                                                               JJJ0428
          BEGIN                                                          JJJ0428
          P<FSTT$AA> = FTMIPFS;                                          JJJ0428
          MIP = 0;                                                       JJJ0428
          END                                                            JJJ0428
      ELSE                                                               JJJ0428
          BEGIN                                                          JJJ0428
          STMD$AA(0);                                                    JJJ0606
          FTNDX = 0;                                                     JJJ0428
          END                                                            JJJ0428
      IF P<FSTT$AA> EQ 0                                                 JJJ0428
      THEN                                                               JJJ0428
          BEGIN                                                          JJJ0428
          MSGF$AA (EC200);                                               JJJ0428
          RETURN;                                                        JJJ0428
                                                                         JJJ0428
          END                                                            JJJ0428
      SYSCOMP = FSSYSCOMP ; 
      IF FTNDX EQ 0                                                      JJJ0428
      THEN                                                               JJJ0428
      BEGIN                                                              JJJ0428
      IF (FSFILEORG[0] EQ FO"IS" AND FSHEADW[0] NQ FSTTHIS)              *--AK--
        OR (FSFILEORG[0] EQ FO"AK" AND FSHEADW[0] NQ FSTTHAK)            *--AK--
        OR (FSFILEORG[0] EQ FO"DA" AND FSHEADW[0] NQ FSTTHDA)            *--AK--
          THEN                                                           JJJ0908
              BEGIN                                                      JJJ0908
              MSGF$AA(EC200);                                            JJJ0908
              RETURN;                                                    JJJ0908
              END                                                        JJJ0908
      FTON = ON"OLD"; 
      FTOC[0]=2;             #SET OC FIELD TO CLOSED#                    VBG1006
      IF SYSCOMP NQ 0 
      THEN
          BEGIN 
          FTCPA[0] = SYSCOMP;  #COMPRESS ADDR = COMPRESS RTN NUM# 
          END 
          FSOPENFLG[0]=TRUE;             #FORCE FSTT TO BE WRITTEN# 
      IF FTMIPFS[0] NQ 0     #IF A MIP FILE#
      THEN
          BEGIN              #THEN DO IT TO#
          MIP=FTMIPFS[0]-P<FSTT$AA>;          #INDEX# 
              FSOPENFLG[MIP]=TRUE;       #FORCE MIP FSTT TO BE WRITTEN# 
          FSPT2SZ[0]=FSPT2SZ[MIP];  #FOR MAKING FIAT NEXT OPEN# 
          FSPT3SZ[0]=FSPT3SZ[MIP];
          FSMXALTKY[0]=FSMXALTKY[MIP];
          END 
      FITNAM[0] = FTLFN[0];  #MAKE SURE FITWRD CONTAINS LFN OF FILE AS #
                             #WELL AS FIT ADDR #
      IF FTFNF[0] EQ 0
      THEN
          BEGIN #REAL CLOSE, NOT A DRAN$AA CALL#
          FLSH$AA ( LOC(FITWRD[0]) ) ;
          END 
                                                                         JJJ1109
      P<FIT$AA> = FITSAV;    #RESTORE FIT$AA AND FSTT$AA#                JJJ1109
      P<FSTT$AA> = FTFSTT[0];                                            JJJ1109
      END                                                                JJJ0428
      DLNK$AA;                                                           JJJ0428
      CBL = 0 ;                                                          AFB0528
      IF FSUSRCNT EQ 0                                                   JJJ0428
      THEN                                                               JJJ0428
          BEGIN                                                          JJJ0428
          IF FSCOMPACT[0] NQ 0 AND NOT NOCMM                             AFB0528
          THEN                                                           AFB0528
              BEGIN                                                      AFB0528
              IX = P<FSTT$AA> ;                                          AFB0528
              P<FSTT$AA> = FSTTHED ;                                     AFB0528
              ASLONGAS P<FSTT$AA> NQ 0                                   AFB0528
              DO                                                         AFB0528
                  BEGIN                                                  AFB0528
                  IF FSCOMPACT[0] NQ 0 AND FSMAXREC[0] GR CBL            AFB0528
                  THEN                                                   AFB0528
                      BEGIN                                              AFB0528
                      CBL = FSMAXREC[0] ;                                AFB0528
                      END                                                AFB0528
                  P<FSTT$AA> = FSFSCHN[0] ;                              AFB0528
                  END                                                    AFB0528
              P<FSTT$AA> = IX ;                                          AFB0528
              IF CBL NQ 0                                                AFB0528
              THEN                                                       AFB0528
                  BEGIN                                                  AFB0528
                  CBL = WC * ( WLG(CBL+WC) ) ;                           *--AK--
                  IF CBL GR CBUFSZ                                       AFB0528
                  THEN                                                   AFB0528
                      BEGIN                                              AFB0528
                      IMPOSSIBLE(CBFERR); 
                      END                                                AFB0528
                  IF CBL EQ CBUFSZ                                       AFB0528
                  THEN                                                   AFB0528
                      BEGIN                                              AFB0528
                      CBL = 0 ;                                          AFB0528
                      END                                                AFB0528
                  END                                                    AFB0528
              ELSE                                                       AFB0528
                  BEGIN                                                  AFB0528
                  CBL = -1 ;                                             AFB0528
                  END                                                    AFB0528
              END                                                        AFB0528
          CLOSFIL (0);                                                   JJJ0428
          END                                                            JJJ0428
      IF FTMIPFS NQ 0 AND FSUSRCNT[MIP] EQ 0                             JJJ0428
      THEN                                                               JJJ0428
          BEGIN                                                          JJJ0428
          CLOSFIL (MIP);                                                 JJJ0428
          END                                                            JJJ0428
      STATIS;                                                            *--AK--
      IF FSBZFET[0] EQ P<FIT$AA>       #IF CLOSING FIT WAS BUSY FET#     VBG0922
        AND FSUSRCNT NQ 0 
      THEN                             #THEN CHANGE TO ANOTHER FIT#      VBG0922
          BEGIN                                                          VBG0922
          P<FET$AA> = FSBZFET[0];                                        JJJ0810
          WTIO$AA;           #ENSURE ALL IO IS DONE#                     JJJ0810
          FSBZFET[0]=FSFTCHN[0];                                         VBG0922
          P<FET$AA>=FSBZFET[0];        #SET NEW BUSY FET COMPLETE#       VBG1018
          FEFCS[0]=1;                                                    VBG1018
          I2 = FSFTCHN;                                                  JJJ0111
          ASLONGAS I2 NQ 0                                               JJJ0111
              DO                                                         JJJ0111
              BEGIN                                                      JJJ0111
              IX = I2 - P<FIT$AA>;                                       JJJ0111
              IF FTBZF[IX] EQ P<FIT$AA>                                  JJJ0111
              THEN                                                       JJJ0111
                  BEGIN                                                  JJJ0111
                  FTBZF[IX] = I2;  #POINT IT TO ITSELF#                  JJJ0111
                  END                                                    JJJ0111
              I2 = FTFTCH[IX];                                           JJJ0111
              END                                                        JJJ0111
          END                                                            VBG0922
      FTFWB[0] = FSFWBOPN[0] ; #RESTORE FWB SAVED AT OPEN#
      IF FSUSRCNT NQ 0                                                   AM2A095
      THEN                                                               AM2A095
          BEGIN              # NOT COMPLETELY CLOSED #                   AM2A095
          CTRG$AA ;  #RECALCULATE FSTARGET AND FSMINTARG #               AM2A095
          END                                                            AM2A095
      STRG$AA ;   #RECALCULATE TARGET AND MINTARG#                       AM2A095
      IF TARGET LS 0                                                     AM2A095
      THEN                                                               AM2A095
          BEGIN                                                          AM2A095
          TARGET = -TARGET ;                                             AM2A095
          END                                                            AM2A095
      RLSP$AA;               #RELEASE CMM SPACE, IF ANY#
      IX = RUNTOTCM - TARGET;                                            AM2A011
      IF IX GR 0                                                         AM2A011
      THEN                                                               AM2A011
          BEGIN                                                          AM2A011
          P<BLOK$AA> = 0;    #NO NEED TO PRESERVE CURRENT BLOCK#
          IF RESP$AA(IX,0) GR 0                                          AM2A011
          THEN                                                           AM2A011
              BEGIN                                                      AM2A011
              IMPOSSIBLE(RTOTHI); 
              END                                                        AM2A011
          END                                                            AM2A011
      IF CBL NQ 0                                                        AFB0528
      THEN                                                               AFB0528
          BEGIN                                                          AFB0528
          CMM$FRF ( CBUFAD ) ;                                           AFB0528
          IF CBL GR 0                                                    AFB0528
          THEN                                                           AFB0528
              BEGIN                                                      AFB0528
              CBUFAD = CMM$ALF ( CBL/WC , 0 , 0 ) ;                      *--AK--
              CBUFSZ = CBL ;                                             AFB0528
              END                                                        AFB0528
          ELSE                                                           AFB0528
              BEGIN                                                      AFB0528
              CBUFAD = 0 ;                                               AFB0528
              CBUFSZ = 0 ;                                               AFB0528
              END                                                        AFB0528
          END                                                            AFB0528
      CLUN$AA;       #UNLOAD UNUSED CAPS AND CLEAN UP#
      IF SYSCOMP NQ 0 
      THEN
          BEGIN 
          UNLDCPR(SYSCOMP); 
          END 
  
#  THIS IS TEMPORARY TILL BAMLIB GETS ITS ACT TOGETHER#                  JJJ0529
      IF FTFWB EQ 0  THEN FTFWB = LOC(FTPOP);                            JJJ0529
      FTIN = FTFWB;                                                      JJJ0529
      FTOUT = FTFWB;                                                     JJJ0529
      FTLIMIT = FTFWB + 65;                                              JJJ0529
      RETURN; 
CONTROL EJECT;
PROC STATIS;                 #OUTPUT FILE STATISTICS FOR AAM FILES#      *--AK--
 #
* *   CLSF$AA                                    PAGE  1                 *--AK--
* *   STATIS                                                             JJJ0929
* *   VB GODDARD                                 DATE  76/08/27 
* DC  NAME                                                               JJJ0916
*     STATIS
* DC  FUNCTION
*     COLLECT AND OUTPUT CLOSE STATISTICS.                               *--AK--
* DC  ENTRY CONDITIONS
*     P<FSTT$AA>=FSTT ADDRESS.
* DC  EXIT CONDITIONS 
*     STATISTICAL MESSAGES ARE OUTPUT VIA MSGZ$AA AND MSGD$AA.
* DC  CALLED ROUTINES 
*     MSGZ$AA - TO OUTPUT MESSAGES. 
*     MSGD$AA - TO OUTPUT MESSAGES WITH A DECIMAL INSERT ITEM.
* DC  DECRIPTION
*     THE STATISTICS REPORT ARE:  
*         CURRENT NUMBER OF INDEX LEVELS
*         GET COUNT THIS RUN
*         PUT COUNT THIS RUN
*         REPLACE COUNT THIS RUN
*         DELETE COUNT THIS RUN 
*         WORDS OF FILE SPACE IN USE
 #
CONTROL EJECT;
          BEGIN 
          ITEM X;            #MESSAGE INSERT ITEM#
          ITEM Y;            #NOTE NUMBER#
  
  
  
          MSGZ$AA(NOTE002);  #FILE CLOSE MESSAGE# 
          IF FTMIPGN NQ 0 THEN RETURN;  #DONT PUT OUT STATS FOR MIPGEN#  GAG1025
  
      IF FSFILEORG[0] EQ FO"IS"                                          *--AK--
      THEN                                                               *--AK--
          BEGIN                                                          *--AK--
          X = FSNDXLVLS[0];                #NUMBER OF INDEX LEVELS# 
          Y=NOTE003;
          MSGD$AA(Y,X); 
          END                                                            *--AK--
                                                                         *--AK--
  
          X=FSGETCNT[0]-FSOGETCNT[0];       #CURRENT GET COUNT# 
          Y = NOTE004;
          MSGD$AA(Y,X); 
  
          X=FSPUTCNT[0]-FSOPUTCNT[0];       #CURRENT PUT COUNT# 
          Y = NOTE005;
          MSGD$AA(Y,X); 
  
          X=FSREPCNT[0]-FSOREPCNT[0];       #CURRENT REPLACE COUNT# 
          Y = NOTE006;
          MSGD$AA(Y,X); 
  
          X=FSDELCNT[0]-FSODELCNT[0];       #CURRENT DELETE COUNT#
          Y = NOTE007;
          MSGD$AA(Y,X); 
  
          X=FSGTNCNT[0]-FSOGTNCNT[0];       #CURRENT GETN COUNT#
          Y = NOTE033;
          MSGD$AA(Y,X); 
  
          X = (FSNXTPRU[0]-1) * DPRUSIZ ; #WORDS OF FILE SPACE#          *--AK--
          Y = NOTE010;
          MSGD$AA(Y,X); 
          IF FSFILEORG[0] EQ FO"DA"                                      *--AK--
          THEN                                                           *--AK--
              BEGIN                                                      *--AK--
              X = FSORCNT[0] - FSOORCNT[0] ;                             *--AK--
              Y = NOTE041 ;                                              *--AK--
              MSGD$AA ( Y , X ) ;                                        *--AK--
              X = FSRECCNT[0] - FSOLDRC[0] - X ;                         *--AK--
              Y = NOTE040 ;                                              *--AK--
              MSGD$AA ( Y , X ) ;                                        *--AK--
              X = FSOBCNT[0] - FSOOBCNT[0] ;                             *--AK--
              Y = NOTE042 ;                                              *--AK--
              MSGD$AA ( Y , X ) ;                                        *--AK--
              END                                                        *--AK--
  
          RETURN; 
  
          END 
CONTROL EJECT;                                                           JJJ0428
PROC CLOSFIL (WHICH);                                                    JJJ0428
 #                                                                       JJJ0428
* *   CLOSFIL - ISSUE CLOSE FUNCTION             PAGE  1                 AM2A077
* *   J J JANIK                                                          JJJ0428
* 0DC NAME                                                               JJJ0428
*     CLOSFIL                                                            JJJ0428
* 0DC FUNCTION                                                           JJJ0428
*     TO ISSUE CIO CLOSE ON A FILE                                       JJJ0428
* 0DC ENTRY CONDITIONS                                                   JJJ0428
*     P<FIT$AA> AND P<FSTT$AA> ARE SET UP.                               JJJ0428
*     FORMAL PARAMETER, WHICH, IS NON-ZERO IF MIP FILE IS TO BE CLOSED   JJJ0428
*     AND IS THE DIFFERENCE BETWEEN MIP FSTT AND P<FSTT$AA>.             JJJ0428
 #                                                                       JJJ0428
                                                                         JJJ0428
          BEGIN                                                          JJJ0428
          ITEM WHICH;        #FORMAL PARAMETER#                          JJJ0428
          ITEM FUN; 
                                                                         JJJ0428
          P<FET$AA> = FSBZFET[WHICH];  #WHICH IS DIF BETWEEN FSTT'S#     JJJ0428
          FESRB = 0;                                                     JJJ0428
          FEFIRST = 200;
          FEIN = 200; 
          FEOUT = 200;
          FELIMIT = 300;
          FUN = CIOCLS; 
          IF FELFN NQ FTLFN 
          THEN #MIP FILE# 
              BEGIN 
              I = B<27,3>W[P<FIT$AA>+11]; 
              IF I EQ 3 OR I EQ 4 THEN FUN = CIOCLS+O"20";
                  #UNLOAD IF CF=RET OR U# 
              END 
          CRA1$AA (DCIO,P<FET$AA>,1,FUN); #CLOSE, NO RANDOM BIT#
          IF FSBADBLK[WHICH] NQ 0 
          THEN
              BEGIN 
              BADM$AA ( FELFN[0] ) ;
              END 
                                                                         JJJ0428
          END                                                            JJJ0428
      END 
CONTROL EJECT;
PROC DLNK$AA;                #DELINK ALL THINGS FOR THIS FIT#            *--AK--
 #
* *   DLNK$AA                                    PAGE  1
* *   VB GODDARD                                 DATE  76/08/23 
* DC  NAME
* C   DLNK$AA 
* DC  FUNCTION
*     DETACH A FIT FROM CRM TABLES BY DELINKING EVERYTHING RESERVED FOR 
*     THAT FIT. AREAS SHARED WITH OTHER FITS ARE NOT DELINKED. THE
*     ADDRESS OF THE FSTT IN THE FIT IS NOT CHANGED.
* DC  ENTRY CONDITIONS
*     FIT$AA CONTAINS FIT ADDRESS.                                       VBG1101
*     DLNK$AA HAS NO PARAMETERS.
* DC  EXIT CONDITIONS 
*     1 IF A MIP FILE IS LINKED TO THE FIT: 
*       1 DECREMENT THE MIP FSTT USER COUNT BY 1. 
*       2 IF THIS FIT THE ONLY USER OF THE MIP FSTT:  
*         1 DELINK THE MIP FSTT FROM THE FSTT CHAIN.
*         2 DELINK ALL BUFFERS FOR MIP FILE FROM THE BUFFER CHAIN.
*     2 DECREMENT THE FSTT USER COUNT BY 1. 
*     3 IF THIS FIT IS THE ONLY USER OF THE FSTT: 
*       1 DELINK THE FSTT FROM THE FSTT CHAIN.
*       2 DELINK ALL BUFFERS FOR THE FILE FROM THE BUFFER CHAIN.
*       ELSE: 
*       1 DELINK THE FIT FROM ITS FSTT FIT CHAIN. 
* DC  ERROR CONDITIONS
*     NONE
* DC  CALLED ROUTINES 
*     DLINK, AN INTERNAL SUB-PROC.
* DC  NON-LOCAL VARIABLES 
*     IN GCOM$AA: 
*      1 FSTTHED - IF DELINKED FSTT WAS AT FSTT CHAIN HEAD. 
*      2 BFFCHNPTR - IF A DELINKED BUFFER WAS AT BUFFER CHAIN HEAD. 
*      3 BFBCHNPTR - IF A DELINKED BUFFER WAS AT BUFFER CHAIN TAIL. 
*     IN MIP AND DATA FSTT FOR FIT: 
*      4 FSUSRCNT - DECREMENTED BY 1. 
*      5 FSFSCHN - ZEROED.
*      6 FSFTCHN - IF DELINKED FIT AT FIT CHAIN HEAD. 
*     IN OTHER FSTT TABLES: 
*      7 FSFSCHN - IF DELINKED FSTT WAS ATTACHED. 
*     IN OTHER FIT TABLES:  
*      8 FTFTCH - IF A DELINKED FIT WAS ATTACHED. 
*     IN BLOCK BUFFERS FOR THE FILE:  
*      9 BLBKOPTR - ZEROED. 
*     10 BLFKOPTR - ZEROED. 
*     IN BLOCK BUFFERS FOR OTHER FILES: 
*     11 BLBKOPTR - IF A DELINKED BUFFER WAS ATTACHED.
*     12 BLFKOPTR - IF A DELINKED BUFFER WAS ATTACHED.
*     BASED ARRAY POINTERS: 
*     P<FIT$AA> - THE FIT.
*     P<FSTT$AA> - THE FSTT FOR THE FIT.
*     P<BLOK$AA> - IF THE FILES BUFFER CHAIN WAS EXAMINED.
* DC  DESCRIPTION 
*     THE FSTT CHAIN IS TRAVERSED, LOOKING FOR LINKS WITHIN THE DATA AND
*     MIP FSTT TABLES. WHEN ONE IS FOUND, SUB-PROC DLINK IS CALLED TO DO
*     THE DELINKING FOR THAT FSTT.
 #
CONTROL EJECT;
      BEGIN 
          BEGIN 
          L1 = FTFSTT[0] ; #DATA FILE FSTT# 
          L2 = FTMIPFS[0];   #MIP FILE FSTT#
          L3 = FSTTHED[0];   #FSTT CHAIN HEAD#
          FOR IX2 = 0 WHILE L3 NQ 0  #IX2=0 MEANS AT HEAD, DO UNTIL#
                                  #END OF LIST #
              DO
              BEGIN 
              IX = L3 - P<FSTT$AA>;  #CURRENT FSTT INDEX# 
              IF L1 EQ L3 OR L2 EQ L3 
              THEN
                  BEGIN 
                  DLINK;     #DATA OR MIP FSTT#                          VBG1101
                  END 
              ELSE           #INDEX FOR LAST NON-DELINKED FSTT#          VBG0104
                  BEGIN                                                  VBG0104
                  IX2 = L3; 
                  END 
              L3 = FSFSCHN[IX];  #NEXT LINK#
              END 
          RETURN; 
          END 
CONTROL EJECT;
PROC DLINK;        #DLINK FSTT IF ONLY USE, OTHERWISE DETACH FIT# 
 #
* *   DLNK$AA                                    PAGE  1
* *   DLINK 
* *   VB GODDARD                                 DATE  76/08/23 
* DC  NAME
* C   DLINK 
* DC  FUNCTION
*     DELINK EVERYTHING ASSOCIATED WITH A FIT BEING DEACTIVATED WHICH 
*     IS NO LONGER NEEDED.
* DC  ENTRY CONDITIONS
*     DLINK IS CALLED WITH NO PARAMETERS. BEFORE CALLING, HOWEVER,
*     P<FIT$AA> AND P<FSTT$AA> MUST BE SET FOR THE DEACTIVATING FSTT AND
*     ITS FIT. IN ADDITION, GLOBAL ITEM I MUST BE SET TO INDEX THE FSTT 
*     (EITHER DATA OR MIP) TO BE PROCESSED. THE GENERAL RULE IS:  
*                  I=LOC(OBJECT-FSTT)-LOC(DATA-FSTT)
*     SO THAT REFERENCES OF THE FORM
*                  FSTT-FIELD[I]
*     ADDRESS OBJECT-FSTT.
* DC  EXIT CONDITIONS 
*     DISCUSSED FULLY UNDER PROC DLNK$AA. 
* DC  ERROR CONDITIONS
*     NONE
* DC CALLED ROUTINES                                                     VBG1101
*     UNCH$AA - TO DELINK BLOCKS.                                        VBG1101
* DC  DESCRIPTION 
*     THE FSTT USER COUNT IS DECREMENTED BY 1. IF THERE ARE NO OTHER
*     FIT TABLES ATTACHED TO THE FSTT, THE FSTT IS DELINKED FROM THE
*     FSTT CHAIN AND ALL BUFFERS ATTACHED TO THE FSTT ARE DELINKED FROM 
*     THE BUFFER CHAIN. THE BUFFER CHAIN LINKS IN DELINKED BUFFERS ARE
*     ZEROED. 
*     OTHERWISE, THE FIT IS DELINKED FROM THE FSTT FIT CHAIN. THIS CODE 
*     INCLUDES A TEST WHICH ALWAYS FAILS WHEN WORKING ON A MIP FSTT,
*     WHICH IS FINE BECAUSE THERE IS NO FIT TO DELINK FROM THE MIP FSTT.
 #
CONTROL EJECT;
          BEGIN 
          ITEM W,K;          #FIT CHAIN LINK AND INDEX# 
  
  
  
          FSUSRCNT[IX] = FSUSRCNT[IX] - 1; #REDUCE USER COUNT#
          IF FSUSRCNT[IX] EQ 0  #DELINK IF NO OTHER FITS ATTACHED#
          THEN
              BEGIN 
              IF IX2 EQ 0     #AT HEAD OR NOT#
              THEN
                  BEGIN 
                  FSTTHED[0] = FSFSCHN[IX];  #HEAD# 
                  END 
              ELSE
                  BEGIN 
                  K = IX2 - P<FSTT$AA>; 
                  FSFSCHN[K] = FSFSCHN[IX]; 
                  END 
              W = FSBCHNH[IX];  #TRAVERSE THIS FILES BUFFER CHAIN#
              FOR K = 0 WHILE W NQ LOC(FSBCHNH[IX]) 
                  DO
                  BEGIN 
                  P<BLOK$AA>=W-DOFFBFCHN; 
                  IF BLFKOPTR[0] NQ 0 
                  THEN
                      BEGIN 
                      UNCH$AA(LOC(BLFKOPTR[0])); #DELINK FROM KO CHAIN#  VBG1101
                      END 
                  BLBKOPTR[0]=0;  #CLEAR LINKS# 
                  W=BLKFPTR[0]; 
                  END 
              K = FSMIPFSTT[IX];
              IF K NQ 0                                                  VBG0104
              THEN                                                       VBG0104
                  BEGIN                                                  VBG0104
                  K=K-P<FSTT$AA>;                                        VBG0104
                  FSMIPFSTT[K]=0;      #DELINK COMPANION FSTT#           VBG0104
                  END                                                    VBG0104
              END 
          ELSE
              BEGIN          #OTHER USERS, DONT DELINK FSTT#
              IX2 = L3;      #HOLD AS PREVIOUS LINK IN CHAIN# 
              W = FSFTCHN[IX];   #DELINK FIT FROM FSTT# 
              FSLGX[IX] = 0;  #CLEAR LOGGING OPTIONS IN CASE ONLY ONE#   JJJ0810
              FSDFLG[IX] = 0; #FIT IS LOGGING#                           JJJ0810
              FOR K=0 WHILE W NQ 0      #K=0 MEANS HEAD OF CHAIN# 
                  DO
                  BEGIN      #W IS FIT CHAIN LINK, W=0 WHEN AT END# 
                  IF W EQ P<FIT$AA>    #ALWAYS FAILS FOR MIP#            JJJ0908
                  THEN
                      BEGIN 
                      IF K EQ 0  #DELINK FIT WHEN FOUND#
                      THEN
                          BEGIN 
                          FSFTCHN[IX] = FTFTCH[0];
                          END 
                      ELSE
                          BEGIN 
                          FTFTCH[K]=FTFTCH[0];
                          END 
                      END 
                  ELSE       #NOT DELINKED FIT, LOOK FOR LOGGING#        VBG1109
                      BEGIN  #IN ANOTHER FIT#                            VBG1109
                      K=W-P<FIT$AA>;                                     VBG1109
                      IF FTLGX[K] NQ 0                                   VBG1109
                      THEN             #IF ANY LOGGING, SET IN FSTT#     VBG1109
                          BEGIN                                          VBG1109
                          FSLGX[IX] = FTLGX[K];                          JJJ0810
                          FSDFLG[IX] = FTDFLG[K];                        JJJ0810
                          IF FSMIPFSTT[IX] NQ 0 
                          THEN
                            BEGIN 
                            FSLGX[FSMIPFSTT[IX]-P<FSTT$AA>]=FTLGX[K]; 
                            FSDFLG[FSMIPFSTT[IX]-P<FSTT$AA>]=FTDFLG[K]; 
                            END 
                          END                                            VBG1109
                      END                                                VBG1109
                  K=W-P<FIT$AA>;       #PREVIOUS FIT INDEX#              JJJ0908
                  W=FTFTCH[K];       #NEXT LINK#
                  END 
              END 
          RETURN; 
          END 
      END 
CONTROL EJECT;
PROC RLSP$AA;                #RELEASE ALL CMM SPACE FOR CURRENT FIT#
 #
* *   RLSP$AA                                    PAGE  1
* *   VB GODDARD                                 DATE  76/08/24 
* DC  NAME
* C   RLSP$AA 
* DC  FUNCTION
*     RELEASE ALL CMM SPACE ALLOCATED TO A DEACTIVATED FIT. 
* DC  ENTRY CONDITIONS
*     1 ALL DELINKING MUST HAVE BEEN DONE BEFORE CALLING RLSP$AA TO 
*       RELEASE SPACE. (SEE DLNK$AA.) 
*     2 FIT$AA CONTAINS FIT ADDRESS.                                     VBG1101
*     3 THE FSTT POINTER IN THE FIT (FTFSTT) CONTAINS THE ADDRESS OF THE
*       FSTT, AN EXCEPTION TO THE DELINKING RULE. 
*     4 RLSP$AA HAS NO PARAMETERS.
*     5 NOCMM IN GCOM$AA IS SET TO REFLECT AVAILABILITY OF CMM SPACE. 
* DC  EXIT CONDITIONS 
*     1 P<FIT$AA>=ADDRESS OF DEACTIVATED FIT. 
*     2 P<FSTT$AA>=ADDRESS OF ITS FSTT. 
*     3 P<FIAT$AA>=ADDRESS OF ITS FIAT. 
*     4 P<BLOK$AA>=ADDRESS OF SOME BUFFER, IF THE FSTT HAD NO OTHER FIT 
*       TABLES ATTACHED.
*     5 LINKS TO THE FSTT, FIAT, AND MIP FSTT ARE ZEROED. 
*     6 IF A MIP FSTT EXISTS AND HAS NO OTHER FITS ATTACHED, THAT FSTT
*       TOGETHER WITH ALL ATTACHED BUFFERS ARE RELEASED IF THEY ARE IN
*       CMM SPACE. NOTE THAT AN FET FOR MIP FILES DOES EXIST, BUT NEED
*       NOT BE RELEASED BECAUSE IT RESIDES IN THE BLOCK OF SPACE
*       CONTAINING THE FSTT.
*     7 IF THERE ARE NO FIT TABLES ATTACHED TO THE FSTT, THAT FSTT
*       TOGETHER WITH ALL ATTACHED BUFFERS ARE RELEASED IF THEY ARE IN
*       CMM SPACE.
*     8 THE FIAT IS RELEASED IF IT IS IN CMM SPACE. 
* DC  ERROR CONDITIONS
*     NONE
* DC  CALLED ROUTINES 
*     CMM$FRF - TO RELEASE FIXED BLOCKS OF CMM SPACE. 
*     RELEASE - SUB-PROC TO EXAMINE AN FSTT AND ALL OF ITS BUFFERS, 
*               RELEASING ALL BLOCKS OF CMM SPACE NOT REQUIRED FOR
*               OTHER FIT TABLES. 
* DC  DESCRIPTION 
*     IF A MIP FSTT EXISTS, RELEASE IS CALLED TO DO ALL RELEASING FOR 
*     IT. RELEASE IS CALLED TO DO ALL RELEASING FOR THE DATA FSTT.
*     IF THE FIAT IS IN CMM SPACE, CMM$FRF IS CALLED TO RELEASE IT. 
*     FIT POINTERS TO THE FSTT, FIAT, AND MIP FSTT ARE ZEROED.
 #
CONTROL EJECT;
      BEGIN 
          BEGIN 
  
  
  
        IF NOT NOCMM THEN BEGIN 
          IF FTMIPFS[0] NQ 0      #IS THERE A MIP FILE# 
          THEN
              BEGIN 
              IX2 = FTMIPFS[0]-P<FSTT$AA>;  #MIP AREAS# 
              RELEASE;                                                   VBG1101
              END 
          IF FTFSTT[0] NQ 0                                              VBG1101
          THEN                                                           VBG1101
              BEGIN                                                      VBG1101
              IX2 = FTFSTT[0] - P<FSTT$AA> ; #DATA AREAS#                GAG1103
              IX2 = FTFSTT[0] - P<FSTT$AA>;  #DATA AREAS#                GAG1025
              RELEASE;                                                   VBG1101
              END                                                        VBG1101
          P<FIAT$AA>=FTFIAT[0];   #RELEASE FIAT IF IN CMM#
          IF FTFIAT[0] NQ 0            #FIAT ALLOCATED#                  VBG1111
          AND FAINUBS[0] EQ 0          #AND NOT IN UBS#                  VBG1111
          THEN
              BEGIN 
              CMM$FRF(P<FIAT$AA>);
              END 
        END 
          FTFIAT[0]=0;            #CLEAR FIAT LINK# 
          FTFSTT[0]=0;            #CLEAR FIT LINK TO FSTT#
          FTMIPFS[0]=0;           #CLEAR MIP FSTT LINK# 
          RETURN; 
          END 
CONTROL EJECT;
PROC RELEASE;      #RELEASE CMM SPACE FOR DATA OR MIP FILE#              VBG1101
 #
* *   RLSP$AA                                    PAGE  1
* *   RELEASE 
* *   VB GODDARD                                 DATE  76/08/24 
* DC  NAME
* C   RELEASE 
* DC  FUNCTION
*     EXAMINE AN FSTT AND ALL BUFFERS ATTACHED TO IT, RELEASING ALL 
*     BLOCKS IN CMM SPACE NOT REQUIRED FOR OTHER FIT TABLES ATTACHED
*     TO THE FSTT.
* DC  ENTRY CONDITIONS
*     GLOBAL ITEM J CONTAINS FSTT INDEX, =0 FOR DATA FSTT,               VBG1101
*       =LOC(DATA-FSTT)-LOC(MIP-FSTT) FOR MIP FSTT. 
* DC  EXIT CONDITIONS 
*     FULL DESCRIBED UNDER PROC RLSP$AA.
* DC  ERROR CONDITIONS
*     NONE
* DC  CALLED ROUTINES 
*     CMM$FRF - TO RELEASE BLOCKS OF CMM SPACE. 
* DC  NON-LOCAL VARIABLES 
*     IN FSTT 
*     1 FSBCHNH=ADDRESS OF SELF, SIGNIFYING AN EMPTY CHAIN. 
*     2 FSBCHNT=ADDRESS OF SELF, SIGNIFYING AN EMPTY CHAIN. 
*     BASED ARRAYS
*     3 P<BLOK$AA>=ADDRESS OF FSTT FRAME OR SOME BUFFER.
* DC  DESCRIPTION 
*     IF THERE ARE OTHER FIT TABLES ATTACHED TO THE FSTT THE ROUTINE
*     DOES NOTHING. OTHERWISE, THE BUFFER CHAIN FOR THE FILE IS 
*     TRAVERSED, AND CMM$FRF IS CALLED TO RELEASE SPACE FOR ALL BUFFERS 
*     RESIDING IN CMM SPACE. THE FILE BUFFER CHAIN IS SET TO EMPTY IN 
*     THE FSTT. IF THE FSTT IS IN CMM SPACE, CMM$FRF IS CALLED TO 
*     RELEASE THAT SPACE. 
 #
CONTROL EJECT;
          BEGIN 
  
  
  
          IF FSUSRCNT[IX2] EQ 0    #IF NO MORE USERS# 
          THEN
              BEGIN               #THEN RELEASE DATA BUFFERS AMD FSTT#
              L1 = FSBCHNH[IX2];  #BUFFER CHAINS# 
              FSBCHNH[IX2] = LOC(FSBCHNH[IX2]);  #SET CHAIN EMPTY#
              FSBCHNT[IX2] = LOC(FSBCHNT[IX2]); 
              IF L1 NQ 0
              THEN
                BEGIN 
                FOR IX = 0 WHILE L1 NQ LOC(FSBCHNH[IX2])
                  DO
                  BEGIN 
                  P<BLOK$AA> = L1 - DOFFBFCHN;
                  L1 = BLKFPTR[0];
                  IF BLUBSFLG[0] EQ 0 
                  THEN
                      BEGIN 
                      RUNTOTCM = RUNTOTCM -(BRICK(IX2)+DBLKFRAME) ;      *--AK--
                      CMM$FRF(P<BLOK$AA>);
                      END 
                  END 
                END                                                      JJJ0405
              P<BLOK$AA> = LOC(FSTT$AA[IX2]); 
              IF BLUBSFLG[0] EQ 0 
              THEN
                  BEGIN 
                  CMM$FRF(P<BLOK$AA>);
                  END 
              END 
          RETURN; 
          END 
      END 
CONTROL EJECT;                                                           JJJ0402
PROC STRG$AA;                                                            JJJ0402
          BEGIN                                                          JJJ0402
 #                                                                       JJJ0402
* *   STRG$AA - SET TARGET AND MINTARG IN GCOM$AA  PAGE  1               JJJ0402
* *   J.J. JANIK                                   DATE  76/11/28        JJJ0402
* 0DC FUNCTION                                                           JJJ0402
* 0   TO SET TARGET AND MINTARG                                          JJJ0402
* 0DC ENTRY CONDITIONS                                                   JJJ0402
* 0   FSTT CHAIN CONTAINS ALL FILES AND FSTARGET/FSMINTARG ARE VALID.    JJJ0402
*     CMM IS AVAILABLE                                                   JJJ0402
* 0DC EXIT CONDITIONS                                                    JJJ0402
* 0   TARGET IS SET TO BEST VALUE. MINTARG IS SET TO MINIMUM REQUIRED    JJJ0402
*     FOR RARE FUNCTION ON FILE WITH LARGEST BLOCKS.                     JJJ0402
* 0DC ERROR CONDITIONS                                                   JJJ0402
* 0   MINTARG < 0 IF NOT ENOUGH SPACE IN CMM.  A NOTE HAS BEEN ISSUED.   JJJ0402
*     CALLER MUST SET MINTARG = - MINTARG BEFORE CONTINUING.             JJJ0402
* 0DC CALLED ROUTINES                                                    JJJ0402
* 0   CMM$GOS - GET OVERFLOW STATISTICS                                  JJJ0402
* 0DC DESCRIPTION                                                        JJJ0402
 #                                                                       JJJ0402
          BASED ARRAY OVSTAT S(15);                                      JJJ0402
              BEGIN                                                      JJJ0402
              ITEM OVFRW (14,0,60);                                      JJJ0402
              END                                                        JJJ0402
 #                                                                       JJJ0402
* 0   INITIALIZE TARGET AND MINTARG.                                     JJJ0402
*     SCAN FSTT CHAIN ADDING FSTARGET TO TARGET AND SETTING MINTARG TO   JJJ0402
*     LARGEST FSMINTARG.                                                 JJJ0402
 #                                                                       JJJ0402
          IF NOCMM
          THEN
              BEGIN 
              RETURN ;
              END 
          TARGET = 0;                                                    JJJ0402
          MINTARG = 0;                                                   JJJ0402
          T2 = P<FSTT$AA>;                                               JJJ0402
          FOR IX = FSTTHED WHILE IX NQ 0                                 JJJ0402
              DO                                                         JJJ0402
              BEGIN                                                      JJJ0402
              P<FSTT$AA> = IX;                                           JJJ0402
              IX = FSFSCHN;  #GET READY FOR NEXT FSTT#                   JJJ0402
              IF FSFTCHN NQ 0                                            JJJ0402
              THEN                                                       JJJ0402
                  BEGIN                                                  JJJ0402
                  TARGET = TARGET + FSTARGET;                            JJJ0402
                  IF FSMINTARG GR MINTARG                                JJJ0402
                  THEN                                                   JJJ0402
                      BEGIN                                              JJJ0402
                      MINTARG = FSMINTARG;                               JJJ0402
                      END                                                JJJ0402
                  END                                                    JJJ0402
              END  #OF FOR LOOP#                                         JJJ0402
          P<FSTT$AA> = T2;                                               JJJ0402
 #                                                                       JJJ0402
*     ADD SIZE OF MAXIMUM RARE CAPSULE REQUIRED TO MINTARG AND TARGET.   JJJ0402
*     CALL CMM$GOS TO DETERMINE AMOUNT OF CMM AVAILABLE.                 JJJ0402
*     IF TARGET > SPACE AVAILABLE SET TARGET = WORDS AVAILABLE.          JJJ0402
*     IF TARGET < MINTARG ISSUE NOTE AND SET MINTARG NEGATIVE.           JJJ0402
 #                                                                       JJJ0402
          IF MAXRARE EQ 0 
          THEN
              BEGIN 
              MAXRARE = O"2000" ; 
              END 
          MINTARG = MINTARG + MAXRARE;                                   JJJ0402
          TARGET  = TARGET  + MAXRARE;                                   JJJ0402
          IF LOC(AAM$BL) GR 0 
          THEN
              BEGIN 
              IF TARGET GR AAM$BL 
              THEN
                  BEGIN 
                  TARGET = AAM$BL ; 
                  END 
              END 
          IF TARGET LS MINTARG                                           JJJ0402
          THEN                                                           JJJ0402
              BEGIN                                                      JJJ0402
              TARGET = MINTARG;                                          JJJ0402
              END                                                        JJJ0402
          T1 = TARGET - RUNTOTCM;                                        CY209
          IF T1 GR 0                                                     AM2A011
          THEN                                                           AM2A011
              BEGIN                                                      AM2A011
              P<OVSTAT> = CMM$GOS;                                       AM2A011
              T1 = OVFRW + RUNTOTCM - FCMMNED;                           AM2A011
              IF TARGET GR T1                                            AM2A011
              THEN                                                       AM2A011
                  BEGIN                                                  AM2A011
                  IF MINTARG GR T1                                       AM2A011
                  THEN                                                   AM2A011
                      BEGIN                                              AM2A011
                      TARGET = -MINTARG;  #CMM MAY BE TOO SMALL#
                      END                                                AM2A011
                  ELSE                                                   AM2A011
                      BEGIN                                              AM2A011
                      TARGET = T1;                                       AM2A011
                      END                                                AM2A011
                  END                                                    AM2A011
              END                                                        AM2A011
          RETURN;                                                        JJJ0402
          END  #OF STRG$AA#                                              JJJ0402
CONTROL EJECT;                                                          001980
 #                                                                       AM2A077
* *   OPEN$AA                                    PAGE  1                 GAG0623
* *   VB GODDARD                                 DATE  76/08/30          AM2A077
* 1DC NAME                                                               AM2A077
* 0C  OPEN$IS                                                            AM2A077
* 0DC FUNCTION                                                           AM2A077
* 0   OPEN AN AAM FILE.                                                  GAG0623
* 0DC ENTRY CONDITIONS                                                   AM2A077
* 0   FIT$AA CONTAINS FIT ADDRESS.                                       AM2A077
* 0DC EXIT CONDITIONS                                                    AM2A077
* 0   THE FIT IS COMPLETED AND LINKED TO THE FSTT AND FIAT. IF A MIP     AM2A077
*     FILE IS DECLARED, IT IS LIKEWISE OPENED.                           AM2A077
* 0DC ERROR CONDITIONS                                                   AM2A077
* 0   EC55  - OPEN/OLD NON-EXISTENT FILE.                                AM2A077
*     EC532 - OPEN/NEW EXISTING FILE.                                    AM2A077
*     EC536 - NO OR WRONG COMPRESSION ROUTINE.                           AM2A077
*     EC544 - PADDING FACTOR TOO LARGE.                                  AM2A077
*     EC545 - PD CANT BE INPUT FOR OPEN/NEW.                             AM2A077
*     EC550 - COMPRESSED FILES KEY MUST BE NON-EMBEDDED OR AT HEAD       AM2A077
*     EC345 - NOT ENOUGH CMM                                             AM2A077
* 0DC CALLED ROUTINES                                                    AM2A077
* 0   FATERR   - TO PROCESS FATAL ERROR MESSAGE.                         AM2A077
*     FINDFSTT - TO FIND FSTT FOR EXISTING FILES.                        AM2A077
*     MIP$OPN  - TO OPEN THE MIP FILE.                                   AM2A077
*     MAKEFITX - TO MAKE A FIAT.                                         AM2A077
*     LOADCPR  - TO LOAD SYSTEM COMPRESSION CAPSULE.                     AM2A077
*     VALFIT   - TO VALIDATE A FIT.                                      AM2A077
*     MAKEFSTT - TO CONSTRUCT AN FSTT.                                   AM2A077
*     IOWR$AA  - TO WRITE THE FSTT, NEW FILES ONLY.                      AM2A077
*     ORGUBS   - TO ALLOCATE BUFFERS IN UBS.                             AM2A077
*     MSGZ$AA  - TO OUTPUT FILE OPEN MESSAGE.                            AM2A077
*     INFO$AA  - TO RETRIEVE FILE INFORMATION.                           AM2A077
*     CRA1$AA - TO ISSUE A CIO OPEN ON THE MIP FILE IF ANY
*     INIT$AA  - DO INITIALIZATION                                       AM2A077
*     TRIAL    - GET PASSWORD FROM COMPRESSION ROUTINE                   AM2A077
*     CTRG$AA  - CALCULATE FILES TARGET REQUIREMENTS                     AM2A077
*     STRG$AA  - SET TARGET REQUIREMENTS                                 AM2A077
* 0DC STRUCTURE                                                          AM2A077
* 0   OPEN$AA CONTAINS A CONTROLLING ROUTINE BEGINNING AT THE STATEMENT  GAG0623
*     LABELLED START, WHICH CONTROLS THE OPEN PROCESS FOR AAM FILES.     GAG0623
*     THE CONTROLLING ROUTINE CALLS SUB-PROCS TO PERFORM VARIOUS TASKS.  AM2A077
*     SOME OF THE SUB-PROCS ALSO HAVE SUB-PROCS. SOME SUB-PROCS ARE      AM2A077
*     CALLED ONLY ONCE, BUT ARE IMPLEMENTED AS SEPARATE PROCS FOR        AM2A077
*     PURPOSES OF MODULARITY ONLY.                                       AM2A077
* 0DC DESCRIPTION                                                        AM2A077
* 0   MOST OF THE OPEN PROCESS IS DESCRIBED IN THE DOCUMENTATION OF THE  AM2A077
*     SUB-PROCS, AND ARE NOT REPEATED HERE. THIS IS A DESCRIPTION OF     AM2A077
*     THE CONTROLLING ROUTINE ONLY, AND IS AN OVERVIEW OF THE OPEN       AM2A077
*     PROCESS. FOR MORE DETAILS REFER TO SUB-PROC DOCUMENTATION.         AM2A077
* 0   INFO$AA IS CALLED TO GET FILE INFORMATION INTO THE FIT.            AM2A077
*     IF NOT THE FIRST AAM CALL, INIT$AA IS CALLED                       AM2A077
*     UBSA AND UBSL ARE SET TO FIT VALUES TO INITIALIZE UBS ALLOCATION.  AM2A077
*     THERE ARE 2 PARALLEL PATHS DEPENDING ON WHETHER OR NOT THE FILE    AM2A077
*     IS DECLARED AS OLD:                                                AM2A077
*     OLD:                                                               AM2A077
*         ISSUE A ERROR IF THE FILE DOES NOT EXIST.                      AM2A077
*         CALL FINDFSTT TO LINK THE FIT TO THE FSTT.                     AM2A077
*         IF A MIP FILE IS NAMED CALL MIP$OPN TO OPEN THE MIP FILE.      AM2A077
*         CALL MAKEFITX TO CONSTRUCT A FIAT AND LINK IT TO THE FIT.      AM2A077
*     NEW:                                                               AM2A077
*         ISSUE A ERROR IF THEN FILE EXISTS OR IF PD IS INPUT.           AM2A077
*         CALL VALFIT TO VALIDATE THE FIT.                               AM2A077
*         CALL MAKEFSTT TO CONSTRUCT THE FSTT.                           AM2A077
*         CHECK PADDING FACTORS.                                         AM2A077
*         IF A MIP FILE IS NAMED CALL MIP$OPN TO GENERATE AN EMPTY MIP   AM2A077
*         FILE AND ALL OF ITS TABLES.                                    AM2A077
*         CALL MAKEFITX TO CONSTRUCT A FIAT AND LINK IT TO THE FIT.      AM2A077
*         CALL IOWR$AA TO WRITE THE FSTT.                                AM2A077
*     VERIFY COMPRESSION.                                                AM2A077
*     CALL ORGUBS TO ORGANIZE UBS INTO BUFFERS.                          AM2A077
*     CALL MSGZ$AA TO OUTPUT A FILE OPENED MESSAGE.                      AM2A077
*     CALCULATE TARGET IF CMM IN USE.                                    AM2A077
*     SET OC FLAGE.                                                      AM2A077
 #                                                                       AM2A077
ENTRY PROC OPEN$AK ;
ENTRY PROC OPEN$DA ;
ENTRY PROC OPEN$IS ;
START:                                                                  001990
      FTMKL[0] = 0; 
      MXBS = FTXBS[0] ; 
      FTMIPFS[0] = 0 ;
          # FTXBS AND FTMIPFS ARE SAME FIELD #
      FOTYPE = FTFO[0];                                                  *--AK--
      DATFL = 0 ; 
      MIPFL = 0 ; 
      IF FTNDX[0] EQ 0
      THEN
          BEGIN #NOT INDEX-ONLY, THERE MUST BE A MAIN FILE# 
          IF FTFSTT[0] NQ 0 
          THEN
              BEGIN 
              P<FSTT$AA> = FTFSTT[0] ;
              P<BLOK$AA> = P<FSTT$AA> ; 
              IF BLFSTTADR[0] NQ P<FSTT$AA> 
              THEN
                  BEGIN 
                  FTFSTT[0] = 0 ; 
                  END 
              ELSE
                  BEGIN 
                  IF FTXN[0] NQ 0 
                  THEN
                      BEGIN 
                      MIPFL = FSMIPFSTT[0] ; #NONZERO IFF MIP FILE KNON#
                      END 
                  FTPMB[0] = FTPMB[FSFTCHN[0]-P<FIT$AA>] ;
                  FTPRUNO[0] = 10 ; #JUST NONZERO#
                  END 
              END 
          IF FTFSTT[0] EQ 0 
          THEN
              BEGIN 
              INFO$AA ( P<FIT$AA> ) ; 
              END 
          ELSE
              BEGIN 
              FTFSTT[0] = 0 ; 
              END 
          IF FTTAPE NQ 0                                                 GAG0919
          THEN                                                           GAG0919
              BEGIN  #DATA FILE MUST RESIDE ON RMS DEVICE#               GAG0919
              FATERR (EC150) ;                                           GAG0919
              END                                                        GAG0919
                                                                         GAG0919
          UBSA = FTPMB[0] ; #SAVE PERMISSIONS#
          DATFL = FTPRUNO[0] ; #AND LENGTH# 
          END 
      ELSE
          BEGIN #DATA FILE UNNEEDED#
          UBSA = 15 ; #AS IF ALL PERMISSIONS ON DATA FILE#
          END 
      IF FTXN[0] EQ 0 
      THEN
          BEGIN #NO MIP FILE# 
          IF FTNDX[0] NQ 0
          THEN
              BEGIN 
              MSGZ$AA ( EC515 ) ; 
              GOTO EXIT$AA ;
              END 
          END 
      ELSE
          BEGIN 
          FTXN[0] == FTLFN[0] ; 
          IF MIPFL EQ 0 
          THEN
              BEGIN 
              CRA1$AA ( DCIO,P<FIT$AA>,1,CIOOPN ) ; #ISSUE CIO OPEN#
              INFO$AA ( P<FIT$AA> ) ; 
              MIPFL = FTPRUNO[0] ;
              END 
          FTPMB[0] = FTPMB[0] LAN UBSA ;
          FTLFN[0] == FTXN[0] ; 
          END 
  
      #NOW FTPMB[0] IS JOINT PERMISSIONS, DATFL IS LENGTH OF
       MAIN FILE, MIPFL IS LENGTH OF MIP FILE#
  
      IF FTMER[0] NQ 7
      THEN
          BEGIN 
          IF FTON[0] NQ 0 # I.E. IF NEW # 
          THEN
              BEGIN 
              MSGZ$AA ( EC554 ) ; 
              GOTO EXIT$AA ;
              END 
          ELSE
              BEGIN 
              IF FTXN[0] NQ 0 AND MIPFL EQ 0
              THEN
                  BEGIN 
                  MSGZ$AA ( EC555 ) ; 
                  GOTO EXIT$AA ;
                  END 
              END 
          END 
      IF NOT NOTFRST THEN 
          BEGIN 
          NOTFRST=TRUE;     #SET NOT FIRST TIME FLAG# 
          INIT$AA;          #DO INITIALIZATION WORK#
          END 
      UBSA=FTFWB[0];         #SET TO ALLOCATE UBS#                      002020
      UBSL=FTBFS[0];                                                    002030
      XFWB=FTFWB[0];         #SAVE FWB#                                  VBG1208
      FTFTCH = 0;            #CLEAR FIT CHAIN POINTER#                   JJJ0111
      IF UBSL NQ 0                                                       JJJ0913
      THEN                                                               JJJ0913
          BEGIN                                                          JJJ0913
          UBSL = UBSL - 1;   #NEVER ALLOCATE LAST WORD OF UBS#           JJJ0913
          END                                                            JJJ0913
      IF FTFLM[0] EQ 0
      THEN
          BEGIN 
          FTFLM[0] = 2**30-1 ;  #MAX, I.E. NO LIMIT#
          END 
      CMPLFSTT = 0; 
      IF FTON[0] EQ ON"OLD"  #OLD ELSE NEW#                             002040
      THEN                                                              002050
          BEGIN              #OLD#                                      002060
          IF DATFL EQ 0 AND FTNDX[0] EQ 0 #OPEN/OLD NONEXISTING FILE# 
                                         #OK IF NDX SINCE DATA FILE#     JJJ0428
                                         #NEED NOT BE PRESENT#           JJJ0428
          THEN                                                          002080
              BEGIN                                                     002090
              FATERR (EC55);                                             JJJ0503
              END                                                       002110
          IF FTRDB EQ 0                                                  GAG0919
          THEN                                                           GAG0919
              BEGIN  #READ PERMISSION IS NECESSARY#                      GAG0919
              FATERR (EC300);                                            GAG0919
              END                                                        GAG0919
          FINDFSTT;       #FIND THE FSTT#                               002120
          MIP$OPN ;  #OPEN MIP FILE IF ANY#                              GAG0623
          MAKEFITX;       #MAKE A FIAAT#                                002180
          P<PTRE$AA>=FADPTRADR[0];     #PTREE ADDRESS#                   JJJ1204
          IF FTOF[0] NQ OF"E"          #CHECK FILE POSITIONING#          JJJ1204
          THEN                                                           JJJ1204
              BEGIN                                                      JJJ1204
              PTOF[0]=OF"R";           #BOI#                             JJJ1204
              END                                                        JJJ1204
          ELSE                                                           JJJ1204
              BEGIN                    #NOTE - USE N INSTEAD OF E#       JJJ1204
              PTOF[0]=OF"N";           #EOI#                             JJJ1204
              END                                                        JJJ1204
          END                                                           002320
      ELSE                                                              002330
          BEGIN            #NEW#                                        002340
          IF DATFL NQ 0 OR FTNDX[0] NQ 0 #OPEN/NEW ON EXISTING FILE#
                                          #NDX FOR OPEN NEW#             JJJ0428
          THEN                                                          002360
              BEGIN                                                     002370
              FATERR(EC532); #CANT OPEN NEW AN EXISTING FILE# 
              END                                                       002390
          IF FTPD EQ PD"INPUT"
          THEN
              BEGIN 
              FATERR(EC545); #PD MUST NOT BE  INPUT FOR OPEN NEW# 
              END 
          VALFIT;            #VALIDATE THE FIT#                         002400
          MAKEFSTT;          #MAKE THE FSTT#                            002410
          IF FOTYPE NQ FO"DA"                                            *--AK--
          THEN                                                           *--AK--
          BEGIN                                                          *--AK--
          X = 2 * (BRICK(0)-DBLKHEDSZ); #MAXMT#                          *--AK--
          FSDATAPAD[0] = X * FTDP[0] / 100 ;
          IF (X-FSDATAPAD[0])*WC/2 LS (FTMRL[0]+(WC/2))                  *--AK--
          THEN
              BEGIN 
              FATERR ( EC544 ); #PADDING FACTOR TOO LARGE, NO ROOM
                        LEFT IN BLOCK FOR MAX-SIZED DATA RECORD#
              END 
          END                                                            *--AK--
          IF FOTYPE EQ FO"IS"                                            *--AK--
          THEN                                                           *--AK--
          BEGIN                                                          *--AK--
          I = X * FTIP[0] / 100 ; 
          K = WLG(FSKEYSIZE[0]+FOUR) ; #INDXLNG#                         *--AK--
          J = ( X - I - 1 ) / ( 2 * K ) ; 
          IF J LS 2 
          THEN
              BEGIN 
              FATERR ( EC544 ); #PADDING FACTOR TOO LARGE, NO ROOM
                                 LEFT IN BLOCK FOR 3 INDEX RECORDS# 
              END 
          I = X - 1 - ( 2 * K ) * ( J + 1 ) ; 
          IF I GR 0 THEN FSINDXPAD[0] = I ; 
          END                                                            *--AK--
          MIP$OPN ;  #OPEN MIP FILE IF ANY#                              *--AK--
          MAKEFITX;          #MAKE A FIAAT#                             002470
          PTOF[0] = OF"R" ;   #BOI#                                     000250
          FSOPENFLG = TRUE;                                              CY209
          P<BLOK$AA>=P<FSTT$AA>;   #SET FOR IOWR$AA#                     RPNMIP 
          IOWR$AA(1);        #WRITE THE FSTT WITH RECALL#               002530
          END                                                           002540
      IF FTNDX NQ 0                                                      JJJ0625
      THEN                                                               JJJ0625
        BEGIN                                                            JJJ0625
        P<FSTT$AA> = FTMIPFS;                                            JJJ0625
        END                                                              JJJ0625
      ELSE                                                               JJJ0625
        BEGIN                                                            JJJ0625
        IF FTON EQ ON"NEW"    #OPEN NEW#
          AND  FTMIPGN[0] EQ 0 #IF MIPGEN, IT IS REALLY OPEN OLD# 
        THEN
            BEGIN 
            SYSCOMP = FTCPA ; 
            IF SYSCOMP EQ 0 
            THEN
                BEGIN 
                GOTO NOCOMP ; #NO COMPRESSION IN THIS FILE# 
                END 
            ELSE                                                         CY209
                BEGIN                                                    CY209
                IF FTEMK NQ 0                                            CY209
                THEN                                                     CY209
                    BEGIN                                                CY209
                    IF FTRKP NQ 0 OR FTRKW NQ 0                          CY209
                    THEN                                                 CY209
                        BEGIN                                            CY209
                        FATERR( EC550 ) ;                                CY209
                        END                                              CY209
                    END                                                  CY209
                END                                                      CY209
            IF SYSCOMP GQ 64
            THEN
                BEGIN 
                SYSCOMP = 0 ; #USER SUPPLIED COMPRESS ROUTINE#
                END 
            END 
        ELSE                  #OPEN OLD#
            BEGIN 
            IF FSCOMPACT EQ 0 
            THEN
                BEGIN 
                FTCPA = 0 ; 
                FTDCA = 0 ; 
                GOTO NOCOMP ; #NO COMPRESSION IN THIS FILE# 
                END 
            ELSE              #FSCOMPACT NOT ZERO, FILE IS COMPRESSED#
                BEGIN 
                SYSCOMP = FSSYSCOMP ; 
                IF SYSCOMP EQ 0 AND FTCPA LS 64                          RJC1018
                THEN
                    BEGIN 
                    FATERR( EC536 ) ; #NO COMPRESSION ROUTINE#
                    END 
                END 
            END 
        IF SYSCOMP GR 0 AND SYSCOMP LS 64 
        THEN
            BEGIN 
            LOADCPR( SYSCOMP ) ;   #LOAD SYSTEM COMPRESSION CAPSULE#
            END 
        IF FTON EQ ON"NEW"
        THEN                  #OPEN NEW#
            BEGIN 
            IF SYSCOMP LS 64
            THEN
                BEGIN 
                FSSYSCOMP = SYSCOMP ; 
                END 
            FSCOMPACT = TRIAL ; 
            P<BLOK$AA> = P<FSTT$AA> ; 
            IOWR$AA( 1 ) ;   #WRITE FSTT# 
            END 
        ELSE                  #OPEN OLD#
            BEGIN 
            IF TRIAL NQ FSCOMPACT 
            THEN
                BEGIN 
                FATERR( EC536 ) ; #WRONG COMPRESSION ROUTINE# 
                END 
            END 
NOCOMP: 
        END                                                              JJJ0625
      ORGUBS;                #ALLOCATE UNASSIGNED UBS FOR BUFFERS#      002550
      FTBZF = FSBZFET;                                                   JJJ0526
      FSFWBOPN[0]=XFWB;      #SAVE FWB UNTIL FILE IS CLOSED#             VBG1208
      MSGZ$AA(NOTE001);      #FILE OPENED MESSAGE#                      002560
      IF NOT NOCMM           #IF CMM CALCULATE TARGET#                   JJJ0402
      THEN                                                               JJJ0402
          BEGIN                                                          JJJ0402
          CTRG$AA;           #CALCULATE TARGET CONTRIBUTIONS THIS FILE#  JJJ0402
          STRG$AA;           #SET NEW TARGET#                            JJJ0402
          IF TARGET LS 0
          THEN
              BEGIN 
              FATERR (EC345); 
              END 
          END                                                            JJJ0402
      IF FTON[0] EQ ON"OLD"                                              *--AK--
        AND FSFILEORG EQ FO"DA" AND FTNDX EQ 0 AND FSHBCNT GQ 3          *--AK--
        AND FSRECCNT[0] NQ 0                                             GAG0928
            THEN                                                         *--AK--
                BEGIN  #CHECK FOR CORRECT HASH ROUTINE#                  *--AK--
                STMD$AA ( 0 ) ;                                          AFB0801
                FOR IX = 0 STEP 1 UNTIL 2                                *--AK--
                DO                                                       *--AK--
                    BEGIN                                                *--AK--
                    PTCURBLK[0] = PRU3 + IX * FSBLKSIZ[0] ;              *--AK--
                    SEBL$AA ( 0 , 1 ) ;                                  *--AK--
                    IF RC NQ 0                                           *--AK--
                    THEN                                                 *--AK--
                        BEGIN                                            *--AK--
                        SETR$AA ( RC ) ;                                 *--AK--
                        IF BLOCKID[0] NQ                                 *--AK--
                          HASH$DA(RECFWA+TOMPLEFF,TOMPES,FSKEYSIZE[0])
                        THEN                                             *--AK--
                            BEGIN                                        *--AK--
                            FATERR ( EC171 ) ;                           *--AK--
                            END                                          *--AK--
                        END                                              *--AK--
                    BLNORU[0] = 1 ; #FORCE RETURN OF SPACE TO CMM#       AFB1128
                    END                                                  *--AK--
                END                                                      *--AK--
      FTOC = 1;                                                          AFB0726
      RETURN;                                                           002570
CONTROL EJECT;                                                          002690
PROC FINDFSTT;               #FIND THE FSTT#                            002700
 #                                                                      002710
* *   OPEN$AA                                    PAGE  1                 *--AK--
* *   FINDFSTT                                                          002730
* *   VB GODDARD                                 DATE 76/08/27          002740
* DC  NAME                                                              002750
*     FINDFSTT                                                          002760
* DC  FUNCTION                                                          002770
*     FIND THE FSTT FOR AN EXISTING FILE.                               002780
* DC  ENTRY CONDITIONS                                                  002790
*     P<FIT$AA>=ADDRESS OF FIT.                                         002800
*     FSTTHED IN GCOM$AA CONTAINS THE HEAD OF THE FSTT CHAIN.           002810
*     FINDFSTT IS A SYMPL PROC WITH NO PARAMETERS.                      002820
* DC  EXIT CONDITIONS                                                   002830
*     THE FSTT IS IN THE FSTT CHAIN WITH THE FIT LINKED TO IT.          002840
*     P<FSTT$AA>=ADDRESS OF FSTT.                                       002850
* DC  ERROR CONDITIONS                                                  002860
*     EC6   - BAD FSTT.                                                 002870
*     EC52  - NON-FATAL, THE OPEN FLAG IS SET IN THE FSTT ON DISK.      002880
*     EC74  - MUST HAVE CMM FOR MULTIPLE FILE ACCESS.                   002890
*     EC75  - MAY NOT USE UBS FOR MULTIPLE FILE ACCESS.                 002900
* DC  CALLED ROUTINES                                                   002910
*     FSTTBLOK - ALLOCATE SPACE FOR FSTT AND BUILD FSTT BLOCK FRAME.     CIM0117
*     SRCHFSTT - TO SEARCH THE FSTT CHAIN.                               CIM0117
*     CKFSFT   - CHECK FIT AGAINST FSTT.                                002950
*     FSTTSUB  - FSTT INITIALIZATION CODE SHARED WITH PROC MAKEFSTT.    002960
*     READFSTT - TO READ THE FSTT IN FROM DISK.                          CIM0117
*     FATERR   - FATAL ERROR MESSAGES.                                  002980
* DC  DESCRIPTION                                                       002990
*     THE FSTT CHAIN IS SEARCHED FOR AN FSTT HAVING AN LFN MATCHING THE 003000
*     LFN IN THE FIT.                                                   003010
*     IF THE FSTT FOR THE FILE IS NOT FOUND ON THE FSTT CHAIN FSTTBLOK  003020
*     IS CALLED TO PREPARE SPACE FOR THE FSTT AND SET ITS LOCATION IN   003030
*     P<FSTT$AA> AND P<BLOK$AA>. CRA1$AA IS CALLED TO READ THE FSTT FROM003040
*     DISK INTO ITS SPACE. IF LOGGING IS INDICATED, ALTR$AA IS CALLED   003050
*     TO INITIATE LOGGING OF THE FSTT. A FATAL ERROR IS ISSUED IF THE   003060
*     FSTT HEADER WORD IS BAD. IF THE OPEN FLAG IS SET IN THE FSTT WHEN 003070
*     READ FROM DISK, A WARNING ERROR IS ISSUED, THE OPEN FLAG IS RESET,003080
*     AND THE FILE-NOT-PROPERLY-CLOSED FLAG IS SET IN THE FSTT. THE     003090
*     FSTT IS INITIALIZED AND CKFSFT IS CALLED TO CHECK THE FIT AGAINST 003100
*     THE FSTT, FSTTSUB IS CALLED TO COMPLETE LINKING OF THE FIT AND    003110
*     FSTT.                                                             003120
*     IF THE FSTT FOR THE FILE IS FOUND IN THE FSTT CHAIN, BOTH FIT AND 003130
*     FSTT ARE CHECKED TO ASSURE THAT UBS IS NOT BEING USED, WHICH IS   003140
*     A FATAL ERROR CONDITION. IF OK, CKFSFT IS CALLED TO CHECK THE FIT 003150
*     AGAINST THE FSTT, THE FSTT USER COUNT IS INCREMENTED BY 1, AND    003160
*     THE FIT IS LINKED TO THE FSTT.                                    003170
 #                                                                      003180
CONTROL EJECT;                                                          003190
          BEGIN                                                         003200
          I = SRCHFSTT (FTNDX);  #SEARCH IF FSTT EXISTS#                 JJJ0428
          IF I LQ 0          #SINGLE USE ELSE MULTIPLE USE#              RPNMIP 
          THEN                                                          003350
            BEGIN                                                        JJJ0428
            IF FTNDX EQ 0                                                JJJ0428
            THEN             #IF NOT INDEX ONLY#                         JJJ0428
              BEGIN                                                      JJJ0428
              FSTTBLOK(0);   #BUILD AN FSTT BUFFER FRAME#               003370
              FTFSTT[0] = P<FSTT$AA> ;
              P<FET$AA>=P<FIT$AA>;     #SET FET POINTER#                 RPNMIP 
              READFSTT;      #READ FSTT IN#                              RPNMIP 
              IF (FOTYPE EQ FO"IS" AND FSHEADW[0] NQ FSTTHIS)            *--AK--
                OR (FOTYPE EQ FO"AK" AND FSHEADW[0] NQ FSTTHAK)          *--AK--
                OR (FOTYPE EQ FO"DA" AND FSHEADW[0] NQ FSTTHDA)          *--AK--
              THEN                                                      003450
                  BEGIN                                                 003460
                  FATERR(EC6);                                          003470
                  END                                                   003480
                                                                        003560
#                            INITIALIZE FSTT              #             003570
                                                                        003580
              FSMIPFSTT[0]=0;                                           003590
              CKFSFT;         #CHECK FSTT/FIT FOR AGREEMENT#            003710
              FSTTSUB;        #SHARED SUB-PROC#                         003720
              IF I LS 0      #COMPLEMENT FSTT EXISTS#                    RPNMIP 
              THEN                                                       RPNMIP 
                  BEGIN                                                  RPNMIP 
                  FSMIPFSTT[0]=-I;     #LINK THEM UP#                    RPNMIP 
                  I=P<FSTT$AA>+I;                                        RPNMIP 
                  FSMIPFSTT[I]=P<FSTT$AA>;                               RPNMIP 
                  END                                                    RPNMIP 
              END                                                       003730
            ELSE                                                         RPN0512
              BEGIN                                                      RPN0512
              P<FSTT$AA> = 0;  #CLEAR IT PRIOR TO MIP OPEN#              RPN0512
              END                                                        RPN0512
            END                                                          JJJ0428
          ELSE               #FSTT IN CHAIN, MULTIPLE USE CASE#         003740
              BEGIN                                                     003750
              P<FSTT$AA>=I;  #SET ADDRESS#                              003760
              P<BLOK$AA>=I;                                             003770
              FTFSTT[0] = P<FSTT$AA> ;
              IF NOCMM       #MUST HAVE CMM FOR MULTIPLE USE#           003780
              THEN                                                      003790
                  BEGIN                                                 003800
                  FATERR(EC74);                                         003810
                  END                                                   003820
              IF UBSA NQ 0   #MAY NOT USE UBS FOR MULTIPLE ACCESS#      003830
              OR BLUBSFLG[0] NQ 0                                        VBG1104
              THEN                                                      003840
                  BEGIN                                                 003850
                  FATERR(EC75);                                         003860
                  END                                                   003870
              FTFTCH = FSFTCHN;  #LINK FITS TO FSTT#                     JJJ0428
              FSFTCHN = P<FIT$AA>;                                       JJJ0428
              FACREATE[FTFIAT[FTFTCH[0]-P<FIT$AA>]-P<FIAT$AA>] = 0; 
              FSUSRCNT[0] = FSUSRCNT[0] + 1 ; 
              IF FTNDX NQ 0  #IF NDX, CLEAR FSTT AND BLOCK, RETURN#      JJJ0428
              THEN                                                       JJJ0428
                  BEGIN                                                  JJJ0428
                  CMPLFSTT = P<FSTT$AA>;  #USED IN MIP$OPN#              JJJ0428
                  P<FSTT$AA> = 0;                                        JJJ0428
                  P<BLOK$AA> = 0;                                        JJJ0428
                  RETURN;                                                JJJ0428
                                                                         JJJ0428
                  END                                                    JJJ0428
              CKFSFT;        #CHECK FSTT/FIT FOR AGREEMENT#             003940
              IF FSLGX[0] EQ 0         #IF LOGGING NOT ON#               VBG1109
              THEN           #GET LOG ITEMS FROM NEW FIT#                VBG1109
                  BEGIN                                                  VBG1109
                  FSLGX[0]=FTLGX[0];                                     VBG1109
                  FSDFLG[0]=FTDFLG[0];                                   VBG1109
                  END                                                    VBG1109
              END                                                       003980
          RETURN;                                                       003990
          END                                                           004000
CONTROL EJECT;                                                          004010
PROC CKFSFT;       #CHECK FIT AGAINST FSTT FOR CONSISTENCY AND ERRORS#  004020
 #                                                                      004030
* *   OPEN$AA                                    PAGE  1                 *--AK--
* *   FINDFSTT                                                          004050
* *   CKFSFT                                                            004060
* *   VB GODDARD                                 DATE  76/08/27         004070
* DC  NAME                                                              004080
*     CKFSFT                                                            004090
* DC  FUNCTION                                                          004100
*     CHECK THE FSTT AND FIT FOR CONSISTENCY.                           004110
* DC  ENTRY CONDITIONS                                                  004120
*     P<FIT$AA>=ADDRESS OF FIT.                                         004130
*     P<FSTT$AA>=ADDRESS OF FSTT.                                       004140
* DC  EXIT CONDITIONS                                                   004150
*     THE FOLLOWING FIT FIELDS ARE SET FROM FSTT FIELDS:                004160
*         FTKT  - KEY TYPE                                              004170
*         FTKL  - KEY LENGTH                                            004180
*         FTMBL - BLOCK SIZE                                            004190
*         FTNL  - INDEX LEVELS                                          004200
*         FTMRL - MAXIMUM RECORD LENGTH (ONLY IF NOT GIVEN)             004210
* DC  ERROR CONDITIONS                                                  004230
*     EC2   - FILE IS NOT AN IS FILE.                                   004240
*     EC76  - FILE IS RUINED.                                           004250
*     EC73  - NON-FATAL, FILE-NOT-PROPERLY-CLOSED FLAG WAS SET.         004260
* DC  CALLED ROUTINES                                                   004270
*     MSGZ$AA - MESSAGES                                                004280
*     FATERR  - FATAL ERROR MESSAGES.                                   004290
* DC  DESCRIPTION                                                       004300
*     FULLY DESCRIBED UNDER EXIT CONDITIONS AND ERROR CONDITIONS.       004310
 #                                                                      004320
          BEGIN                                                         004330
          IF FSRUINFLG[0] 
           OR (FSMODFLG[0] AND (B<0,1>W[P<FIT$AA>+29] EQ 0))
                                  #CDCS FLAG# 
          THEN                                                          004400
              BEGIN                                                     004410
              FATERR(EC202);                                             JJJ0721
              END                                                       004430
          IF FSNCLSFLG       #NONFATAL ERROR IF FILE NOT PROPERLY CLOSD#004440
          THEN                                                          004450
              BEGIN                                                     004460
              MSGZ$AA(EC52);
              END                                                       004480
          FTKT[0]=FSKEYTYPE[0];  #SET KEY PARAMETERS#                   004490
          FTKL[0]=FSKEYSIZE[0];                                         004500
          FTRKP[0] = FSKEYPOS[0];                                        JJJ1116
          FTRKW[0] = FSKEYLOC[0];                                        JJJ1116
          FTMBL[0] = BRICK(0) * WC ;                                     *--AK--
          FTNL[0]=FSNDXLVLS[0];  #INDEX LEVELS IN USE#                  004520
          IF FTMRL[0] EQ 0   #SET MAX REC SIZ IF NOT GIVEN#             004530
          THEN                                                          004540
              BEGIN                                                     004550
              FTMRL[0]=FSMAXREC[0];                                     004560
              END                                                       004570
          ELSE                                                           JJJ0720
              BEGIN                                                      JJJ0720
              IF FTMRL LS FSMAXREC                                       JJJ0720
              THEN                                                       JJJ0720
                  BEGIN                                                  JJJ0720
                  MSGZ$AA(EC176);  #WARN USER THAT WSA TOO SHORT#        JJJ0720
                  END                                                    JJJ0720
              END                                                        JJJ0720
          IF FTMNR EQ 0                                                  JJJ1206
          THEN                                                           JJJ1206
              BEGIN                                                      JJJ1206
              FTMNR = FSMINREC;                                          JJJ1206
              END                                                        JJJ1206
          RETURN;                                                       004630
          END                                                           004640
CONTROL EJECT;                                                          004650
PROC MAKEFITX;               #GENERATE THE FIT EXTENSION TABLE#         004660
 #                                                                      004670
* *   OPEN$AA                                    PAGE  1                 *--AK--
* *   MAKEFITX                                                          004690
* *   VB GODDARD                                 DATE  76/08/27         004700
* DC  NAME                                                              004710
*     MAKEFITX                                                          004720
* DC  FUNCTION                                                          004730
*     CONSTRUCT A FIT EXTENSION TABLE, CALLED FIAT.                     004740
* DC  ENTRY CONDITIONS                                                  004750
*     P<FIT$AA>=ADDRESS OF FIT.                                         004760
*     P<FSTT$AA>=ADDRESS OF FSTT.                                       004770
*     IF A MIP FILE ITS OPEN PROCESSING HAS BEEN COMPLETED.             004780
*     MAKEFITX IS A SYMPL PROC WITH NO PARAMETERS.                      004790
* DC  EXIT CONDITIONS                                                   004800
*     A COMPLETED FIAT IS LINKED TO THE FIT(FTFIAT).                    004810
*     P<FIAT$AA>=ADDRESS OF FIAT.                                       004820
* DC  ERROR CONDITIONS                                                  004830
*     NONE.                                                             004840
* DC  CALLED ROUTINES                                                   004850
*     GETSPACE - TO ALLOCATE SPACE FOR THE FIAT.                        004860
* DC  DESCRIPTION                                                       004870
*     SEVERAL INTERMEDIATE RESULTS TO BE USED SEVERAL TIMES ARE COMPUTED004880
*     AND STORED TO SAVE SPACE. INCLUDED ARE FIAT SIZE.                 004890
*     GETSPACE IS CALLED TO ALLOCATE SPACE FOR THE FIAT.                004900
*     THE FIAT IN-UBS FLAG IS SET IF THE FIAT IS IN UBS.                004910
*     THE FIAT IS COMPLETED BY SETTING ADDRESS POINTERS AND INDICATORS  004920
*     FOR THE VARIOUS SUB-TABLES AND AREAS WITHIN THE FIAT(MOST ARE     004930
*     VARIABLE IN LENGTH). THE CODE IS LONG AND LOOKS COMPLICATED, BUT  004940
*     IT IS STRICTLY PLOW-AHEAD ACCORDING TO THE FIAT FORMAT.           004950
 #                                                                      004960
CONTROL EJECT;                                                          004970
          BEGIN                                                         004980
          ITEM XSIZE;            #SIZE OF EXTENSION AREA(FIAT$AA)#      004990
          ITEM PSIZE;        #P-TREE SIZE#                               JJJ1204
          IF FTNDX NQ 0                                                  JJJ0428
          THEN                                                           JJJ0428
              BEGIN                                                      JJJ0428
              P<FSTT$AA> = FTMIPFS;                                      JJJ0428
              END                                                        JJJ0428
                                                                        005010
          IF FSMIPFSTT NQ 0 AND FTNDX EQ 0                               JJJ0428
          THEN                                                          005030
              BEGIN                                                     005040
              MIP=FSMIPFSTT[0]-P<FSTT$AA>;   #ADDRESSING TRICK, WORKS#  005050
              END                                                       005060
          ELSE                                                          005070
              BEGIN                                                     005080
              MIP=0;         #INDICATES NO MIP FILE IN USE#             005090
              END                                                       005100
          X=WLG(FTKL[0]);    #VALUE USED SEVERAL TIMES#                 005110
          IF FOTYPE EQ FO"IS"                                            *--AK--
          THEN                                                           *--AK--
              BEGIN                                                      *--AK--
              PSIZE = FSNDXLVLS[0] + 6;  #IS PTREE SIZE#
              END                                                        *--AK--
          ELSE                                                           *--AK--
              BEGIN                                                      *--AK--
              PSIZE = FSMXNDXLV[0];  #AK/DA PTREE SIZE#                  *--AK--
              END                                                        *--AK--
          IF FOTYPE EQ FO"IS"                                            *--AK--
           AND (PSIZE GR MXFTNL OR FTON[0] EQ ON"NEW")                   *--AK--
          THEN                                                           *--AK--
              BEGIN                                                      *--AK--
              PSIZE = MXFTNL;  #DONT EXCEED LIMIT#                       *--AK--
              END                                                        *--AK--
          XSIZE=6+2*X+PSIZE; #BASIC SIZE#                                JJJ1204
          IF MIP NQ 0 OR FTNDX NQ 0                                      JJJ0428
          THEN                                                          005140
              BEGIN                                                     005150
              Y=WLG(FSMXALTKY[MIP]);    #VALUE USED SEVERAL TIMES#      005160
              XSIZE=XSIZE+22+2*Y+FSPT2SZ[MIP]+FSPT3SZ[MIP];              GBK0121
              END                                                       005190
          P<FIAT$AA>=GETSPACE(XSIZE);       #ALLOCATE SPACE#            005210
          IF UBSFLG NQ 0     #SET FLAG IF FIAT IS IN UBS#                VBG1104
          THEN                                                          005230
              BEGIN                                                     005240
              FAINUBS[0]=1;                                             005250
              END                                                       005260
          FTFIAT[0]=P<FIAT$AA>;             #SET FIAT ADDRESS IN FIT#   005270
          IF MIP EQ 0 AND FTNDX EQ 0  #SET ADDRESS POINTERS#             JJJ0428
          THEN                                                          005290
              BEGIN          #NO MIP#                                   005300
              FAPKY3ADR[0]=LOC(FAPOSKEY1[0])+1;                          VBG1014
              FASKY3ADR[0]=FAPKY3ADR[0]+X;                              005320
              FADPTRADR[0]=FASKY3ADR[0]+X;                              005330
          IF FTON[0] EQ ON"NEW" AND FOTYPE EQ FO"IS"                     *--AK--
          THEN                                                           JJJ0502
              BEGIN                                                      JJJ0502
              FACREATE = 1;                                              JJJ0502
              END                                                        JJJ0502
              END                                                       005340
          ELSE                                                          005350
              BEGIN          #MIP#                                      005360
              FAPKY2ADR[0]=LOC(FAPOSKEY1[0])+1;                         005370
              FAPKY3ADR[0]=FAPKY2ADR[0]+Y;                              005380
              FASKY2ADR[0]=FAPKY3ADR[0]+X;                              005390
              FASKY3ADR[0]=FASKY2ADR[0]+Y;                              005400
              FADPTRADR[0]=FASKY3ADR[0]+X;                              005410
              FAMPATADR[0]=FADPTRADR[0]+PSIZE+1;                         JJJ1204
              P<MPAT$AA>=FAMPATADR[0];                                  005430
              MPATFIN[0] = FSMIPFSTT[0] + DOFFSFIDS;                     RPN0627
              MPATPTR[0]=P<MPAT$AA>+5;                                   GBK0121
              MPATFIN[1]=MPATPTR[0]+2;                                  005460
              MPATPTR[1]=MPATFIN[1]+3;                                  005470
              MPATFIN[2]=MPATPTR[1]+FSPT2SZ[MIP]+4; 
              MPATPTR[2]=MPATFIN[2]+3;                                  005490
              P<PTRE$AA>=MPATPTR[0];                                    005500
              PTREESIZE[0]=2;                                           005510
              PTCURPTR[0]=1;                                            005520
              P<PTRE$AA>=MPATPTR[1];                                    005530
              PTREESIZE[0]=FSPT2SZ[MIP]+4;
              P<PTRE$AA>=MPATPTR[2];                                    005550
              PTREESIZE[0]=FSPT3SZ[MIP]+4;
              P<FINF$AA> = MPATFIN[1];                                   RPN0113
              KLOC = TENTH(FSPKL[MIP]);  #SET LEVEL 2 KW FOR LEVEL 1 SH# RPN0114
              KPOS = FSPKL[MIP] - WC * KLOC ;                            *--AK--
              ORG = FO"IS";                                              RPN0113
              P<FINF$AA> = MPATFIN[2];                                   RPN0113
              KLENG = FSPKL[MIP];                                        RPN0114
              KPOS = 0;                                                  RPN0113
              KLOC = 0;                                                  RPN0113
              CURLEV = 0;                                                RPN0113
              KTYPE = FSPKT[MIP];                                        RPN0114
              P<FINF$AA>=MPATFIN[0];                                    005570
              IF FTON EQ ON"NEW"       #IF CREATION#                     VBG0106
              THEN                                                       RPNMIP 
                  BEGIN                                                  RPNMIP 
                  FSMXALTKY[MIP]=0;    #CLEAR THESE FIELDS IN MIP FSTT#  RPNMIP 
                  FSPT2SZ[MIP] = 1 ;
                  FSPT3SZ[MIP] = 1 ;
                  END                                                    RPNMIP 
              ELSE           #JUST IN CASE OF MIPGEN, RESET FIELDS#      JJJ0311
                  BEGIN                                                  JJJ0311
                  FSMXALTKY[MIP] = FSMXALTKY[0];                         JJJ0311
                  FSPT2SZ[MIP] = FSPT2SZ[0];                             JJJ0311
                  FSPT3SZ[MIP] = FSPT3SZ[0];                             JJJ0311
                  END                                                    JJJ0311
              END                                                       005580
          P<PTRE$AA>=FADPTRADR[0];                                      005590
          PTREESIZE = PSIZE;                                             JJJ0428
          IF FTNDX NQ 0                                                  JJJ0428
          THEN                                                           JJJ0428
              BEGIN                                                      JJJ0428
              P<FSTT$AA> = 0;                                            JJJ0428
              END                                                        JJJ0428
              FACAPUSM=FTAAMSR1; #SAVE CAPSULE USAGE WORD FOR THIS FIT# 
          RETURN;                                                       005620
          END                                                           005630
CONTROL EJECT;                                                          005640
PROC MAKEFSTT;               #GENERATE AN FSTT#                         005650
 #                                                                      005660
* *   OPEN$AA                                    PAGE  1                 *--AK--
* *   MAKEFSTT                                                          005680
* *   VB GODDARD                                 DATE  76/08/30         005690
* DC  NAME                                                              005700
*     MAKEFSTT                                                          005710
* DC  FUNCTION                                                          005720
*     GENERATE AN FSTT TABLE FOR A NEW FILE.                            005730
* DC  ENTRY CONDITIONS                                                  005740
*     P<FIT$AA>=ADDRESS OF FIT                                          005750
*     MAKEFSTT IS A SYMPL PROC WITH NO PARAMETERS.                      005760
* DC  EXIT CONDITIONS                                                   005770
*     THE FSTT IS LINKED INTO THE FSTT CHAIN, AND THE FIT IS LINKED TO  005780
*     THE FSTT.                                                         005790
* DC  ERROR CONDITIONS                                                  005800
*     NONE                                                              005810
* DC  CALLED ROUTINES                                                   005820
*     FSTTBLOK - TO BUILD FSTT BLOCK FRAME.                             005830
*     CRA1$AA  - TO GET CURRENT DATE FROM SYSTEM.                       005840
*     DICO$AA  - TO SET ADDRESS OF DEFAULT DISPLAY/COLLATE CONVERT TABLE005850
*     GENCODI  - TO GENERATE COLLATE/DISPLAY CONVERT TABLE.             005860
*     FSTTSUB  - TO COMPLETE LINKING.                                   005870
* DC  DESCRIPTION                                                       005880
*     FSTTBLOK IS CALLED TO GENERATE THE FSTT BLOCK FRAME. THE FSTT IS  005890
*     INITIALIZED FROM INFORMATION IN THE FIT. FILE CREATION DATE IS    005900
*     SET. THE DEFAULT DISPLAY-TO-COLLATE CONVERSION TABLE IS MOVED TO  005910
*     THE FSTT UNLESS THE USER SUPPLIES HIS OWN OVERRIDING TABLE.       005920
*     SUB-PROC GENCODI IS CALLED TO GENERATE THE COLLATE-TO-DISPLAY     005930
*     CONVERSION TABLE. FSTTSUB IS CALLED TO COMPLETE LINKUP FOR THE    005940
*     FSTT.                                                             005950
 #                                                                      005960
CONTROL EJECT;                                                          005970
          BEGIN                                                         005980
                                                                        006090
          FSTTBLOK(0);       #BUILD AN FSTT BLOCK FRAME#                006100
          FTFSTT[0]=P<FSTT$AA>;                                          VBG1111
          FSBLKSIZ[0] = (TENTH(FTMBL[0])+2) / DPRUSIZ ;                  *--AK--
                                 #PRUS IN BLOCK#                         *--AK--
          FSBKFACTR[0] = FTRB[0];  #STORE RB IN THE FSTT#                *--AK--
          IF FTBCK[0] EQ 1   #CHECKSUM FLAG#                            006120
          THEN                                                          006130
              BEGIN                                                     006140
              FSCKSUMFLG[0]=TRUE;                                       006150
              END                                                       006160
          FSFILEORG[0] = FOTYPE ;                                        *--AK--
          IF FOTYPE EQ FO"IS"                                            *--AK--
          THEN                                                           *--AK--
              BEGIN                                                      *--AK--
              FSHEADW[0] = FSTTHIS ; #HEADER WORD SAAM/IS#               *--AK--
              END                                                        *--AK--
          ELSE                                                           *--AK--
              BEGIN                                                      *--AK--
              IF FOTYPE EQ FO"AK"                                        *--AK--
              THEN                                                       *--AK--
                  BEGIN                                                  *--AK--
                  FSHEADW[0] = FSTTHAK ;  #ESTABLISH AK HEADER WORD#     *--AK--
                  FSPRCNTBK[0] = DFTPRCNTBK;  #EST SERIAL PROBE TRIGGER# *--AK--
                  FSPROBLIM[0] = DFTPROBLIM; #EST LIMIT ON RANDOM PROBE# *--AK--
                  FSTRIGBNO[0] = 3;  #INITIALIZE TO PRU 3#               *--AK--
                  END                                                    *--AK--
              ELSE                                                       *--AK--
                  BEGIN                                                  *--AK--
                  FSHEADW[0] = FSTTHDA;  #ESTABLISH DA FSTT HEADER WORD# *--AK--
                  END                                                    *--AK--
              END                                                        *--AK--
          FSKEYLOC[0] = FTRKW[0];                                        JJJ1116
          FSKEYPOS[0]=FTRKP[0];   #RELATIVE KEY POSITION#               006270
          FSKEYSIZE[0]=FTKL[0];   #KEY SIZE#                            006280
          FSKEYTYPE[0]=FTKT[0];   #KEY TYPE#                            006290
          IF FSKEYTYPE[0] EQ 0                                           AFB0214
          THEN                                                           AFB0214
              BEGIN                                                      AFB0214
              FSKEYTYPE[0] = KT"SYMBOLIC" ;                              AFB0214
              END                                                        AFB0214
          IF FOTYPE EQ FO"AK"                                            AFB0801
          THEN                                                           AFB0801
              BEGIN  #SET LOWEST ILLEGAL PRU NUMBER#                     AFB0801
              IF FSKEYSIZE GR 5                                          AFB0801
              THEN                                                       AFB0801
                  BEGIN                                                  AFB0801
                  FSLSTPRU[0] = 2**24 - 1 ;                              GAG0919
                  END                                                    AFB0801
              ELSE                                                       AFB0801
                  BEGIN                                                  AFB0801
                  I = 2**(FSKEYSIZE*CHSZB)-1 ; #HIGHEST POSSIBLE KEY# 
                  T1 = (I/FSBKFACTR)*FSBLKSIZ+PRU3; #LOWEST ILLEGAL BLK#
                  IF T1 EQ PRU3 
                  THEN
                      BEGIN #B.F. ABOVE HIGHEST POSS. KEY#
                      FSBKFACTR = I ; #REDUCE IT TO HIGHEST POSS.KEY# 
                      T1 = PRU3 + FSBLKSIZ ; #ONE DATA BLK POSS.# 
                      END 
                  IF T1 LS 2**24                                         GAG0919
                  THEN                                                   GAG0919
                      BEGIN                                              GAG0919
                      FSLSTPRU[0] = T1 ;                                 GAG0919
                      END                                                GAG0919
                  ELSE                                                   GAG0919
                      BEGIN                                              GAG0919
                      FSLSTPRU[0] = 2**24 - 1 ;                          GAG0919
                      END                                                GAG0919
                  END                                                    AFB0801
              END                                                        AFB0801
          FSMAXREC[0]=FTMRL[0];   #MAXIMUM RECORD SIZE, IN CHARACTERS#  006300
          FSMINREC[0]=FTMNR[0];   #MINIMUM RECORD SIZE, IN CHARACTERS#  006310
          FSNXTPRU[0]=1;     #FSTT HAS NOT YET BEEN WRITTEN#             VBG0922
          FSEXTFLG[0]=TRUE;  #FILE MUST BE EXTENDED#                     VBG0922
          SYSDATE( LOC(FSFILDAT[0]) );  #DATE OF FILE CREATION#          JJJ0930
          IF FOTYPE EQ FO"IS"                                            *--AK--
          THEN                                                           *--AK--
          BEGIN                                                          *--AK--
          IF FTNL[0] EQ 15   #MAX LEVELS NO GREATER THAN 15#            006350
          THEN                                                          006360
              BEGIN                                                     006370
              FSMXNDXLV[0]=15;                                          006380
              END                                                       006390
          ELSE                                                          006400
              BEGIN                                                     006410
              FSMXNDXLV[0]=FTNL[0]+1;                                   006420
              END                                                       006430
          GETDICO ;                                                      *--AK--
          END                                                            *--AK--
                                                                         *--AK--
          IF FOTYPE EQ FO"DA"                                            *--AK--
          THEN                                                           *--AK--
              BEGIN                                                      *--AK--
              IF FTHMB[0] EQ 0
              THEN
                  BEGIN 
                  FATERR ( EC166 ) ; #FIT INCOMPLETE# 
                  END 
              FSHBCNT[0] = FTHMB[0] ;                                    *--AK--
              END                                                        *--AK--
          IF FOTYPE NQ FO"IS"                                            *--AK--
          THEN                                                           *--AK--
              BEGIN                                                      *--AK--
              FSKEYTYPE[0] = KT"UNSIGNED" ;                              *--AK--
              FSMXNDXLV[0] = 5;  #5 WORD PTREE FOR AK#                   RPN0627
              FSFDBPRU = PRU3;                                           RPN0629
              END                                                        *--AK--
          FSTTSUB ; #SHARED SUB-PROC#                                    *--AK--
          FSLGX = FTLGX ;                                                *--AK--
          FSDFLG = FTDFLG ;                                              *--AK--
          END                                                            *--AK--
CONTROL EJECT ;                                                          *--AK--
      BASED ARRAY DICOTAB [1:8] ; #DISPLAY-TO-COLLATE TABLE#             *--AK--
          BEGIN                                                          *--AK--
          ITEM DICOTABI ;                                                *--AK--
          END                                                            *--AK--
                                                                         *--AK--
      BASED ARRAY UDICO [1:8] ; #USER-SUPPLIED DICOTAB#                  *--AK--
          BEGIN                                                          *--AK--
          ITEM UDICOI ;                                                  *--AK--
          END                                                            *--AK--
                                                                         *--AK--
      PROC GETDICO ;                                                     *--AK--
          BEGIN                                                          *--AK--
          ITEM I ;                                                       *--AK--
                                                                         *--AK--
          IF FTDCT[0] EQ 0   #FETCH DISPLAY-TO-COLLATE CONVERT TBL#     006440
          THEN                                                          006450
              BEGIN                                                     006460
              P<UDICO>=DICO$AA;    #DEFAULT#                            006470
              FSDCOLTAB = TRUE ;   #INDICATES DEFAULT COLLATE TABLE#
              END                                                       006480
          ELSE                                                          006490
              BEGIN                                                     006500
              P<UDICO>=FTDCT[0];   #USER SPECIFIED#                     006510
              END                                                       006511
          P<DICOTAB>=LOC(FSDICOTAB[0]);                                 006520
          FOR I=1 STEP 1 UNTIL SZDICOTAB                                006530
              DO                                                        006540
              BEGIN                                                     006550
              DICOTABI[I]=UDICOI[I];                                    006560
              END                                                       006570
          P<UDICO>=LOC(FSCODITAB[0]);                                   006580
          GENCODI;           #GENERATE FSCODITAB#                       006590
          END                                                            *--AK--
CONTROL EJECT;                                                          006620
PROC GENCODI;      #GENERATE COLLATE TO DISPLAY CONVERSION TABLE#       006630
 #                                                                      006640
* *   OPEN$AA                                    PAGE  1                 *--AK--
* *   MAKEFSTT                                                          006660
* *   GENCODI                                                           006670
* *   VB GODDARD                                 DATE  76/08/30         006680
* DC  NAME                                                              006690
*     GENCODI                                                           006700
* DC  FUNCTION                                                          006710
*     GENERATE COLLATE-TO-DISPLAY CONVERSION TABLE FROM                 006720
*     DISPLAY-TO-COLLATE CONVERSION TABLE.                              006730
* DC  ENTRY CONDITIONS                                                  006740
*     P<DICOTAB>=ADDRESS OF DISPLAY-TO-COLLATE TABLE.                   006750
*     P<UDICO>=ADDRESS OF AREA FOR COLLATE-TO-DISPLAY TABLE. THIS AREA  006760
*     MUST BE COMPLETELY ZEROED.                                        006770
*     GENCODI IS A SYMPL PROC WITH NO PARAMETERS.                       006780
* DC  EXIT CONDITIONS                                                   006790
*     THE GENERATED COLLATE-TO-DISPLAY TABLE IS IN AREA UDICO.          006800
* DC  ERROR CONDITIONS                                                  006810
*     EC177 - DISPLAY-TO-COLLATE TABLE DOES NOT CONTAIN UNIQUE MAPPING. 006820
* DC  CALLED ROUTINES                                                   006830
*     FATERR - TO GENERATE FATAL ERROR MESSAGE.                         006840
* DC  DESCRIPTION                                                       006850
*     A SINGLE PASS IS MADE OVER THE 64 ENTRIES IN DICOTAB. THE UPPER 3 006860
*     BITS OF EACH ENTRY ARE USED AS A WORD INDEX TO UDICO AND THE      006870
*     LOWER 3 BITS ARE USED AS A BYTE INDEX WITHIN THAT WORD. A FATAL   006880
*     ERROR RESULTS IF THE ADDRESSES UDICO ENTRY IS NOT ZERO, MEANING   006890
*     THE MAPPING IS NOT UNIQUE. THE DICOTAB ENTRY NUMBER IS STORED     006900
*     IN THE UDICO ENTRY.                                               006910
 #                                                                      006920
CONTROL EJECT;                                                          006930
              BEGIN                                                     006940
              ITEM X C(1);   #TEMPORARY#                                006950
                                                                        006960
                                                                        006970
              FOR I=1 STEP 1 UNTIL SZDICOTAB    #ALL DICOTAB WORDS#     006980
                  DO                                                    006990
                  BEGIN                                                 007000
                  FOR J=0 STEP 1 UNTIL 7     #8 BYTES IN EACH WORD#     007010
                      DO                                                007020
                      BEGIN                                             007030
                      X=C<J>DICOTABI[I];                                007040
                      K=B<0,3>X+1;                                      007050
                      L=B<3,3>X;                                        007060
                      C<L>UDICOI[K] = 8 * (I-1) + J;                     AM2A011
                      END                                               007160
                  END                                                   007170
              RETURN;                                                   007180
              END                                                       007190
CONTROL EJECT;                                                           RPNMIP 
PROC MIP$OPN;                                                            RPNMIP 
 #                                                                       RPNMIP 
* *   MIP$OPN                                    PAGE  1                 RPNMIP 
* *   THE INTERNAL MIP OPEN MODULE.                                      RPNMIP 
* *   R.P.NG                                     10/18/76.               RPNMIP 
*0CD  MIP$OPN                                                            RPNMIP 
*     THIS ROUTINE IS CALLED BY THE DATA FILE OPEN OR INDEX ONLY OPEN    RPNMIP 
*     PROCESSORS TO DO THE WORK FOR AN INDEX FILE OPEN.                  RPNMIP 
*0CD  ENTRY CONDITIONS                                                   RPNMIP 
*     P<FIT$AA> IS SET POINTING TO THE USER FIT.                         RPNMIP 
*     XN IS THE NAME OF THE MIP FILE IF ANY, ELSE = 0.                   *--AK--
*     P<FSTT$AA> SHOULD POINT TO A DATA FILE FSTT IF ONE EXIST, ZERO     RPNMIP 
*     OTHERWISE.                                                         RPNMIP 
*0CD  EXIT CONDITIONS                                                    RPNMIP 
*     IF XN=0,FTMIPFS[0] HAS BEEN ZEROED. OTHERWISE ---                  *--AK--
*     MIP FILE OPENED.  THE FSTT AND FET IS ESTABLISHED IF NECESSARY.    RPNMIP 
*     THE MIPFSTT ADDRESS WILL BE SET IN FTMIPFS.  P<FSTT$AA> POINTS TO  RPNMIP 
*     THE DATA FILE FSTT IF ONE EXIST, INDEX FSTT OTHERWISE.             RPNMIP 
*0CD  ERROR CONDITIONS                                                   RPNMIP 
*     THE ERROR PROCESSOR WILL BE CALLED WITH THE FOLLOWING ERROR        RPNMIP 
*     ORDINALS                                                           RPNMIP 
*     NOTNEW - CANNOT OPEN NEW ON EXISTING MIP FILE, FATAL.  USER ERROR  RPNMIP 
*              TRYING TO CREATE A NEW INDEX FILE WITH A NAME THAT IS     RPNMIP 
*              ALREADY USED.                                             RPNMIP 
*     NOTOLD - OPEN OLD ON AN EMPTY INDEX FILE, PROBABLY BAD FILE NAME   RPNMIP 
*              USED.                                                     RPNMIP 
*     BADHEAD - BAD MIP FSTT HEADER, FILE BAD OR CLOBBERED.              RPNMIP 
*     BADCOMP - BAD MIPWORD COMPARE, FATAL ERROR.                        RPNMIP 
*0CD  CALLED ROUTINES                                                    RPNMIP 
*     FSTTBLOK - GET SPACE TO BUILD FSTT AND FET                         RPNMIP 
*     READFSTT - TO READ THE INDEX FILE FSTT.                            RPNMIP 
*     IOWR$AA  - TO WRITE THE FSTT.                                      CIM0117
*0CD  DESCRIPTION                                                        RPNMIP 
*     ON ENTRY, SAVE P<FSTT$AA>.  IF THE DATA FILE FSTT EXIST, SEE IF    RPNMIP 
*     IT ALREADY HAS AN INDEX FILE FSTT ALSO BY LOOKING AT THE FSMIPFSTT RPNMIP 
*     FIELD.  IF WE LOOK BACK AT THE DATA FILE OPEN OLD, WE FIND THAT    RPNMIP 
*     AT ONE POINT, SRCHFSTT HAS BEEN CALLED.  IF BOTH FSTTS EXIST, THAT RPNMIP 
*     SUBROUTINE WOULD HAVE ENSURE THAT THIS LINK IS SET.  HENCE, IF THE RPNMIP 
*     LINK IS SET, WE ARE READY TO GO.  JUST BUMP THE FSUSRCNT, AND GO   RPNMIP 
*     TO THE END TO FINISH UP INITIALIZATION.                            RPNMIP 
 #                                                                       RPNMIP 
BEGIN                                                                    RPNMIP 
      ITEM FSSAV,I,J,K;                                                  RPNMIP 
      IF FTXN[0] EQ 0                                                    *--AK--
      THEN                                                               *--AK--
          BEGIN                                                          *--AK--
          FTMIPFS[0] = 0 ;                                               *--AK--
          RETURN ;                                                       *--AK--
          END                                                            *--AK--
      FSSAV = P<FSTT$AA>;          #SAVE FSTT ADDRESS#                   RPNMIP 
      IF FSSAV NQ 0 AND FSMIPFSTT NQ 0                                   RPNMIP 
      THEN                                                               RPNMIP 
          BEGIN                                                          RPNMIP 
          P<FSTT$AA>=FSMIPFSTT[0];     #SET FSTT POINTER#                RPNMIP 
          FTMIPFS[0] = P<FSTT$AA> ; 
          IF NOCMM THEN FATERR(EC74);                                    RPNMIP 
                   ELSE FSUSRCNT = FSUSRCNT + 1;                         RPNMIP 
          END                                                            RPNMIP 
      ELSE                                                               RPNMIP 
 #                                                                       RPNMIP 
*     IF THE INDEX FILE FSTT DOES NOT EXIST, WE CALL FSTTBLOK TO GET     RPNMIP 
*     SPACE FOR IT, ISSUE THE CIO OPEN, AND GET THE FILE INFORMATION     RPNMIP 
 #                                                                       RPNMIP 
        BEGIN                                                            JJJ0428
        IF CMPLFSTT LQ 0     #CMPLFSTT > 0 MEANS MIP FSTT IN CHAIN#      JJJ0428
        THEN                                                             JJJ0428
          BEGIN                                                          RPNMIP 
          FSTTBLOK(SZFET);                                               *--AK--
          FTMIPFS[0] = P<FSTT$AA> ;                                      *--AK--
          FSMIPBLK = 1;                                                  *--AK--
          P<FET$AA> = P<FSTT$AA> + SZFSTTIC;  #SET FET TO FOLLOW FSTT#
          FELFN = FTXN;     #MOVE LFN OVER#                              RPNMIP 
          FELNG=3;     #LENGTH OF FET#                                   RPNMIP 
          FEEP=1;      #SET ERROR PROCESSING BIT#                        RPNMIP 
          FESRB = 1;                                                     RPNMIP 
          FEFCSE = 1;        #SET COMPLETION STATUS#                     JJJ0216
          IF FTNDX NQ 0                                                  JJJ0428
          THEN                                                           JJJ0428
              BEGIN                                                      JJJ0428
              I = 0;                                                     JJJ0428
              FSMIPWORD[0] = 1;  #TO FOOL NEXT TEST#                     JJJ0625
              END                                                        JJJ0625
          ELSE                                                           JJJ0625
              BEGIN                                                      JJJ0625
              I = FSSAV - P<FSTT$AA>;                                    JJJ0625
              END                                                        JJJ0428
 #                                                                       RPNMIP 
*     NOW IF ON IS SET OR THE DATA FILE MIPWORD IS ZERO, THIS MUST BE AN RPNMIP 
*     OPEN NEW CALL.  IT IS NECESSARY TO CHECK FOR THE MIPWORD BECAUSE   RPNMIP 
*     IXGEN IS THE EXCEPTIONAL CASE WHEN WE OPEN OLD ON DATA FILE BUT    RPNMIP 
*     OPEN NEW ON INDEX FILE.  FOR INDEX ONLY PROCESSING, ON IS OFF.     RPNMIP 
 #                                                                       RPNMIP 
          IF FTON EQ 1 OR FSMIPWORD[I] EQ 0                              RPN0104
          THEN                                                           RPNMIP 
              BEGIN                                                      RPNMIP 
              IF MIPFL GR 0 #MIP FILE LGTH# 
              THEN
                  BEGIN 
                  FATERR ( -EC532 ) ; #CANT OPEN NEW EXISTING FILE# 
                  END 
 #                                                                       RPNMIP 
*     IF OPENNEW, DO A WHOLE BUNCH OF INITIALIZATION.  THE FIELDS        RPNMIP 
*     FSMAXALTKY, FSPT2SZ, FSPT3SZ ARE ALL SET TO MAXIMUM POSSIBLE VALUE RPNMIP 
*     AT CREATION.  THIS IS BECAUSE THE NEXT THING THAT WE HAVE TO DO    RPNMIP 
*     IS TO MAKE THE FIAT, AND AT CREATION TIME WE CANNOT REALLY TELL    RPNMIP 
*     WHAT THE EVENTUAL VALUE IS, SO LET US USE JUST THE MAXIMUM VALUE   RPNMIP 
*     MAKEFITX SHOULD RESET THEM TO ZERO WHEN IT IS DONE.                RPNMIP 
 #                                                                       RPNMIP 
              FSOPENFLG[0] = TRUE ; 
              FSCKSUMFLG[0] = FSCKSUMFLG[I];  #BOTH FILES,SAME CHECK#    AFB0726
              FSMIPWORD[0] = MIPTIME; #SET MIPWORD#                      RPNMIP 
              FSMIPWORD[I] = FSMIPWORD[0];                               RPNMIP 
              FSPKL[0] = FSKEYSIZE[I];                                   RPNMIP 
              FSPKT[0] = FSKEYTYPE[I];                                   RPNMIP 
              FSPKW[0] = FSKEYLOC[I];                                    RPNMIP 
              FSPKP[0] = FSKEYPOS[I];                                    RPNMIP 
              SYSDATE( LOC(FSFILDAT[0]) ) ; #FILE CREATION DATE#
              FSRECCNT[0]=0;                                             RPNMIP 
              FSNDXLVLS[0]=0;                                            RPNMIP 
          IF MXBS EQ 0
          THEN                                                           CY209
              BEGIN                                                      CY209
              FSBLKSIZ[0] = FSBLKSIZ[I]; #MIP AND DATA BLOCKS EQUAL#     CY209
              END                                                        CY209
          ELSE                                                           CY209
              BEGIN                                                      *--AK--
              FSBLKSIZ[0] = (WLG(MXBS)+DPRUSIZ-1) / DPRUSIZ ;            *--AK--
              END                                                        *--AK--
              FSNXTPRU[0]=1;                                             RPNMIP 
              FSEXTFLG = TRUE;                                           JJJ0717
              FSKEYSIZE[0]=5;                                            RPNMIP 
              FSKEYPOS[0]=0;                                             RPNMIP 
              FSKEYTYPE[0] = KT"UNSIGNED" ; 
              FSFILEORG[0]= FO"IS";                                      RPNMIP 
              FSMXALTKY[0]=256;     #MAX KEY LENGTH IS 256 CHAR#         RPNMIP 
              FSPT2SZ[0] = 10;      #ALLOW 10 LEVELS FOR LEVEL 2#        RPNMIP 
              FSPT3SZ[0] = 10;      #AND LEVEL 3#                        RPNMIP 
          IF FSFILEORG[I] EQ FO"IS"                                      *--AK--
          THEN                                                           *--AK--
              BEGIN                                                      *--AK--
              FOR J=0 STEP 1 UNTIL 7    #MOVE COLLATE TABLE#             RPNMIP 
                  DO FSDICOTAB[J]=FSDICOTAB[I+J];                        RPNMIP 
              FOR J = 0 STEP 1 UNTIL 7                                   JJJ0311
                  DO  FSCODITAB[J] = FSCODITAB[I+J];                     JJJ0311
              END                                                        *--AK--
          ELSE                                                           *--AK--
              BEGIN                                                      *--AK--
              GETDICO ;                                                  *--AK--
              END                                                        *--AK--
                                                                         *--AK--
              FSHEADW[0]=MIPHEAD;                                        RPNMIP 
              FSBZFET[0]=P<FET$AA>;    #MUST SET THIS FOR IOWR$AA#       RPNMIP 
              IOWR$AA(1);    #WRITE THE FSTT#                            RPNMIP 
              FTON = 1;      #SET ON IF IXGEN#                           RPNMIP 
          FSLGX = FTLGX;                                                 JJJ0503
          FSDFLG = FTDFLG;                                               JJJ0503
              END                                                        RPNMIP 
          ELSE                                                           RPNMIP 
 #                                                                       RPNMIP 
*     IF OPEN OLD, WE MAKE SURE THAT INDEX FILE LENGTH IS NON-ZERO.  IF  RPNMIP 
*     SO, IT IS FATAL ERROR.  WE CAN THEN READ THE FSTT IN, VERIFY THAT  RPNMIP 
*     THE HEADER WORD AND MIPWORDS ARE CORRECT.                          RPNMIP 
 #                                                                       RPNMIP 
              BEGIN                                                      RPNMIP 
              IF MIPFL EQ 0 #MIP FILE LENGTH# 
              THEN
                  BEGIN 
                  FATERR ( EC555 ) ; #INDEX FILE MISSING#                RJC1026
                  END 
              READFSTT;      #READFSTT IN#                               RPNMIP 
              IF FSHEADW NQ MIPHEAD 
              THEN
                  BEGIN 
                  FATERR (EC6);  #BAD HEADER# 
                  END 
              IF FSMIPWORD[0] NQ FSMIPWORD[I] 
              THEN
                  BEGIN 
                  FATERR (EC501);  #MIP AND DATA FILES NOT COMPATABLE#
                  END 
              IF FTMIPGN[0] EQ 1                                         CIM0413
              THEN                                                       JJJ0311
                  BEGIN      #MIPGEN, PREPARE FIAT FOR EXPANSION#        JJJ0311
                  FSMXALTKY = 256;                                       JJJ0311
                  FSPT2SZ = 13; 
                  FSPT3SZ = 13; 
                  END                                                    JJJ0311
              END                                                        RPNMIP 
          FSTTSUB;   #COMMON INITIALIZATION#                             RPNMIP 
          FTFSTT = FSSAV;                                                RPNMIP 
          FSBZFET = P<FET$AA>;                                           RPNMIP 
          IF FTNDX EQ 0 THEN FSFTCHN[0]=0;                               RPNMIP 
                   #DO NOT LINK FIT TO FSTT IF FULL OPEN#                RPNMIP 
          FSMIPFLG = TRUE;                                               RPNMIP 
          FSMIPFSTT[0]=FSSAV;                                            RPNMIP 
          FSMIPFSTT[I]=P<FSTT$AA>;                                       RPNMIP 
          END                                                            JJJ0428
        ELSE                                                             JJJ0428
          BEGIN                                                          JJJ0428
          P<FSTT$AA> = CMPLFSTT; #MIP FSTT FOUND IN SRCHFSTT#            JJJ0428
          FTMIPFS[0] = P<FSTT$AA> ; 
          END                                                            RPNMIP 
        END                                                              JJJ0428
 #                                                                       RPNMIP 
*     NOW WE ARE ALL DONE.  SET THE FIT MIP FSTT PROPERLY, RESTORE FSTT  RPNMIP 
*     ADDRESS, THEN EXIT.                                                RPNMIP 
 #                                                                       RPNMIP 
      FTDT = 1;    #SET MIP FILE OPENED FLAG# 
      IF FTNDX NQ 0                                                      JJJ0428
      THEN                                                               JJJ0428
          BEGIN                                                          JJJ0428
          FTKL = FSPKL;                                                  JJJ0428
          FTRKW = FSPKW;                                                 JJJ0428
          FTRKP = FSPKP;                                                 JJJ0428
          END                                                            JJJ0428
      P<FSTT$AA>=FSSAV;                                                  RPNMIP 
END   #END MIP$OPN#                                                      RPNMIP 
CONTROL EJECT;                                                           RPNMIP 
PROC READFSTT;                                                           RPNMIP 
 #                                                                       RPNMIP 
* *   OPEN$AA                                    PAGE  1                 *--AK--
* *   READFSTT                                                           RPNMIP 
* *   TO READ THE FSTT IN FROM DISK.                                     RPNMIP 
* *   R.P.NG                                     10/22/76                RPNMIP 
*0CD  READFSTT                                                           RPNMIP 
*     THIS MODULE READS THE FSTT FROM DISK INTO AN AREA DESCRIBED BY     RPNMIP 
*     P<BLOK$AA> USING THE FET POINTED TO BY P<FET$AA>.                  RPNMIP 
*0CD  ENTRY CONDITIONS                                                   RPNMIP 
*     P<BLOK$AA> POINTS TO A FRAME THAT IS TO CONTAIN THE FSTT.          RPNMIP 
*     P<FET$AA> MUST BE SET TO THE FET TO BE USED.                       RPNMIP 
*     P<FSTT$AA> MUST BE SET. 
*0CD  EXIT CONDITION                                                     RPNMIP 
*     FSTT READ IN.  CERTAIN FIELDS ARE INITIALIZED IN FSTT.             RPNMIP 
*0CD  ERROR CONDITIONS                                                   RPNMIP 
*     BADREAD - FATAL READ ERROR                                         RPNMIP 
*     FSTCKSM - FSTT CHECKSUM ERROR                                      RPNMIP 
*     RDPAR   - READ PARITY ERROR                                        RPNMIP 
*     EC52    - FILE NOT CLOSED PROPERLY SINCE LAST OPEN                 RPNMIP 
*0CD  ROUTINES CALLED                                                    RPNMIP 
*     CRA1$AA - TO ISSUE CIO READ                                        RPNMIP 
*     CKSM$AA - TO COMPUTE CHECKSUM                                      RPNMIP 
*     WTIO$AA - TO GET READ STATUS                                       RPNMIP 
*     MFET$AA - SET UP FET FOR READ                                      RPNMIP 
*     ALTR$AA - TO LOG FSTT.                                             CIM0117
*     MSGZ$AA - TO OUTPUT ERROR MESSAGE.                                 CIM0117
*     FATERR  - TO OUTPUT FATAL ERROR MESSAGE.                           CIM0117
*0CD  DESCRIPTION                                                        RPNMIP 
*     FIRST, CALL MFET$AA TO SET UP FET.  CALL CRA1$AA TO READ FSTT.     RPNMIP 
*     CALL WTIO$AA TO GET READ STATUS.  TEST FOR READ ERROR, PARITY AND  RPNMIP 
*     CHECKSUM ERRORS.  NOW, WE ARE GOING TO INITIALIZE SOME FIELDS IN   RPNMIP 
*     THE FSTT, SO WE HAVE BETTER SET UP FOR LOGGING IF NECESSARY.       RPNMIP 
*     NOW TEST IF FILE WAS CLOSED PROPERLY LAST TIME.  IF IT IS NOT, WE  RPNMIP 
*     SHOULD PUT OUT A NOTE BEFORE PROCEEDING.  FINALLY, WE INITIALIZE   RPNMIP 
*     FIELDS IN THE FSTT.                                                RPNMIP 
 #                                                                       RPNMIP 
BEGIN                                                                    RPNMIP 
      MFET$AA;               #PREPARE FET#                               RPNMIP 
      FEIN[0]=FEOUT[0];                                                  RPNMIP 
      CRA1$AA ( DCIO , P<FET$AA> , 1 , O"20" ) ; #READSKP#
      WTIO$AA;               #GET READ STATUS#                           RPNMIP 
      IF BLCODSTAT[0] NQ O"21" OR BLKLNG[0] NQ SZFSTT                    RPNMIP 
      THEN
          BEGIN 
          FATERR (EC6);      #FIRST BLOCK IS NOT AN FSTT# 
          END 
      #IF FEES EQ O"20" THEN FATERR(RDPAR)#                              RPNMIP 
      IF CKSM$AA NQ BLCHKSUM
      THEN
          BEGIN 
          FATERR (EC147); 
          END 
      FSREADCNT = FSREADCNT + 1;
      FSLGX = FTLGX;                                                     JJJ0502
      FSDFLG = FTDFLG;                                                   JJJ0502
      IF FTLGX NQ 0                                                      JJJ0503
      THEN                                                               JJJ0503
          BEGIN                                                          JJJ0503
          FSBZFET = P<FIT$AA>;                                           JJJ0503
          FSFTCHN = P<FIT$AA>;                                           JJJ0503
          END                                                            JJJ0503
      IF FSOPENFLG[0]   #WARNING IF OPEN FLAG SET IN FSTT ON DISK#       RPNMIP 
      THEN                                                               RPNMIP 
          BEGIN                                                          RPNMIP 
          MSGZ$AA(EC52);                                                 RPNMIP 
          FSOPENFLG[0] = FALSE;                                          RPNMIP 
          FSNCLSFLG[0] = TRUE;                                           RPNMIP 
          END                                                            RPNMIP 
      FSIOBZFLG = FALSE;                                                 RPNMIP 
      FSEXTFLG = FALSE;                                                  RPNMIP 
      FSBUFFREE = 0;                                                     RPNMIP 
      FSBUFCNT = 0;                                                      RPNMIP 
      FSCOMPBUF = 0;                                                     RPNMIP 
      FSUNWR1[0] = 0 ;
      FSUNWR2[0] = 0 ;
      FSOGETCNT[0] =FSGETCNT[0];  #SAVE PREVIOUS ACCESS COUNTS#          RPNMIP 
      FSOPUTCNT[0] =FSPUTCNT[0];                                         RPNMIP 
      FSOREPCNT[0]=FSREPCNT[0];                                          RPNMIP 
      FSODELCNT[0]=FSDELCNT[0];                                          RPNMIP 
      FSOGTNCNT[0]=FSGTNCNT[0]; 
      FSOLDRC[0] = FSRECCNT[0] ;                                         *--AK--
      IF FSFILEORG[0] EQ FO"DA"                                          *--AK--
      THEN                                                               *--AK--
          BEGIN                                                          *--AK--
          FSOORCNT[0] = FSORCNT[0] ;                                     *--AK--
          FSOOBCNT[0] = FSOBCNT[0] ;                                     *--AK--
          END                                                            *--AK--
      FSOLDRC[0] = FSRECCNT[0] ;                                         *--AK--
      IF FSFILEORG[0] EQ FO"DA"                                          *--AK--
      THEN                                                               *--AK--
          BEGIN                                                          *--AK--
          FSOORCNT[0] = FSORCNT[0] ;                                     *--AK--
          FSOOBCNT[0] = FSOBCNT[0] ;                                     *--AK--
          END                                                            *--AK--
END   #END READFSTT#                                                     RPNMIP 
CONTROL EJECT;                                                          007320
PROC ORGUBS;                 #ORGANIZE UBS#                             007330
 #                                                                      007340
* *   OPEN$AA                                    PAGE  1                 *--AK--
* *   ORGUBS                                                            007360
* *   VB GODDARD                                 DATE  76/08/30         007370
* DC  NAME                                                              007380
*     ORGUBS                                                            007390
* DC  FUNCTION                                                          007400
*     ORGANIZE USER BUFFER SPACE INTO BUFFERS.                          007410
* DC  ENTRY CONDITIONS                                                  007420
*     P<FSTT$AA>=ADDRESS OF FSTT.                                       007430
*     UBSA=FIRST WORD OF UNASSIGNED UBS.                                007440
*     UBSL=LENGTH IN WORDS OF UNASSIGNED UBS.                           007450
*     ORGUBS IS A SYMPL PROC WITH NO PARAMETERS.                        007460
* DC  EXIT CONDITIONS                                                   007470
*     UNASSIGNED UBS IS ALLOCATED FOR DATA AND MIP FILE BUFFERS. UBSA   007480
*     AND UBSL ARE UPDATED TO REFLECT ALLOCATE. UBSL WILL BE LESS THAN  007490
*     THE SMALLER BUFFER SIZE.                                          007500
* DC  ERROR CONDITIONS                                                  007510
*     EC354 - INSUFFICIENT BUFFER SPACE FOR EXECUTION.                  007520
* DC  CALLED ROUTINES                                                   007530
*     GETSPACE - TO ALLOCATE UBS.                                       007540
*     MAKEBUF  - TO CONSTRUCT A BUFFER BLOCK FRAME AND LINK IT TO FSTT. 007550
*     FATERR   - TO GENERATE FATAL ERROR MESSAGE.                       007560
*     NON-LOCAL VARIABLES                                               007570
*     UBSA - ADDRESS OF UNASSIGNED UBS.                                 007580
*     UBSL - LENGTH OF UNASSIGNED UBS.                                  007590
*     X,Y  - GLOBAL TEMPORARIES.                                        007600
* DC  DESCRIPTION                                                       007610
*     X IS SET TO THE SIZE OF A DATA FILE BUFFER BLOCK FRAME AND Y IS   007620
*     LIKEWISE SET FOR MIP FILE BUFFERS(Y=0 IF NO MIP FILE). UNASSIGNED 007630
*     UBS IS ALLOCATED ALTERNATELY TO THE DATA AND MIP FILE, ONE BUFFER 007640
*     AT A TIME, UNTIL REMAINING SPACE IS LESS THAN SMALLEST BUFFER     007650
*     BLOCK FRAME.                                                      007660
*     SINCE GETSPACE ALSO ALLOCATES CMM SPACE, ORGUBS MUST MAKE A       007670
*     SPECIAL CHECK ON UBS AVAILABILITY BEFORE CALLING GETSPACE.        007680
 #                                                                      007690
CONTROL EJECT;                                                          007700
          BEGIN                                                         007710
          IF UBSA GR 0       #UBS AVAILABLE#                            007720
          THEN                                                          007730
              BEGIN          #YES#                                      007740
              X = BRICK(0) + DBLKFRAME ; #BLOCK SIZE#                    *--AK--
              IF FSMIPFSTT NQ 0 AND FTNDX EQ 0                           JJJ0428
              THEN                                                      007770
                  BEGIN      #YES#                                      007780
                  MIP=FSMIPFSTT[0]-P<FSTT$AA>;    #SET MIP FSTT XDX#    007790
                  Y = BRICK(MIP) + DBLKFRAME ; #MIP BUFFER#              *--AK--
                  END                                                   007810
              ELSE                                                      007820
                  BEGIN      #NO MIP#                                   007830
                  Y=0;                                                  007840
                  MIP=0;                                                007850
                  END                                                   007860
ALLOCATE:                                                               007870
              UBSLP=0;       #END OF LOOP INDICATOR#                     VBG1104
              IF UBSL GQ X   #ENOUGH FOR A DATA FILE BUFFER#            007890
              THEN                                                      007900
                  BEGIN      #YES#                                      007910
                  UBSLP=1;                                               VBG1104
                  P<BLOK$AA>=GETSPACE(X);     #ALLOCATE SPACE#          007920
                  MAKEBUF(0);       #MAKE A DATA BUFFER#                007930
                  END                                                   007940
              IF MIP NQ 0    #IF A MIP FILE#                            007950
              THEN                                                      007960
                  BEGIN                                                 007970
                  IF UBSL GQ Y      #THEN ALLOCATE IT BUFFERS#          007980
                  THEN                                                  007990
                      BEGIN                                             008000
                      UBSLP=1;                                           VBG1104
                      P<BLOK$AA>=GETSPACE(Y);                           008010
                      MAKEBUF(MIP);                                     008020
                      END                                               008030
                  END                                                   008040
              IF UBSLP NQ 0  #LOOP UNTIL NOTHING ALLOCATED#              VBG1104
              THEN                                                      008060
                  BEGIN                                                 008070
                  GOTO ALLOCATE;                                        008080
                  END                                                   008090
              END                                                       008100
              IF NOCMM       #CHECK IF ENOUGH BUFFERS TO RUN#           008110
              THEN                                                      008120
                  BEGIN                                                 008130
                  IF FSBUFFREE[0] LS MINBUF                             008140
                  THEN                                                  008150
                      BEGIN                                             008160
                      FATERR(EC354);                                    008170
                      END                                               008180
                  IF MIP NQ 0                                           008190
                  THEN                                                  008200
                      BEGIN                                             008210
                      IF FSBUFFREE[MIP] LS MINBUF                       008220
                      THEN                                              008230
                          BEGIN                                         008240
                          FATERR(EC354);                                008250
                          END                                           008260
                      END                                               008270
              END                                                       008280
          RETURN;                                                       008290
          END                                                           008300
CONTROL EJECT;                                                          008310
PROC MAKEBUF(I);   #COMPLETE THE BUFFER BLOCK AND LINK IT IN#           008320
 #                                                                      008330
* *   OPEN$AA                                    PAGE  1                 *--AK--
* *   ORGUBS                                                            008350
* *   MAKEBUF                                                           008360
* *   VB GODDARD                                 DATE  76/08/30         008370
* DC  NAME                                                              008380
*     MAKEBUF                                                           008390
* DC  FUNCTION                                                          008400
*     CONSTRUCT A FREE BUFFER BLOCK FRAME AND LINK IT TO THE FSTT.      008410
* DC  ENTRY CONDITIONS                                                  008420
*     MAKEBUF IS A SYMPL PROC WITH 1 PARAMETER, I, THE FSTT INDEX.      008430
*     P<BLOK$AA>=ADDRESS OF SPACE FOR BUFFER.                           008440
* DC  EXIT CONDITIONS                                                   008450
*     THE BLOCK FRAME HEADER IS COMPLETED AND IS LINKED TO THE          008460
*     DESIGNATED FSTT. THE FSTT BUFFER COUNT AND FREE BUFFER COUNT ARE  008470
*     EACH INCREMENTED BY 1. NOTE THAT FREE UBS BLOCKS ARE NOT LINKED   008480
*     TO THE BUFFER CHAIN, WHICH IS DONE WHEN THEY ARE FIRST USED.      008490
* DC  ERROR CONDITIONS                                                  008500
*     NONE                                                              008510
* DC  CALLED ROUTINES                                                    VBG1104
*     INCH$AA - TO LINK BLOCKS TO BUFFER CHAIN OF FSTT.                  VBG1104
* DC  DESCRIPTION                                                       008520
*     THE BUFFER HEADED IS COMPLETED, MARKED FREE, AND LINKED TO FSTT.  008530
 #                                                                      008540
          BEGIN                                                         008550
          ITEM I;                                                       008560
                                                                        008570
                                                                        008580
                                                                        008590
          IF I NQ 0 OR FTNDX NQ 0  #IF MIP BLOCK SET MIP FLAG#           JJJ0428
          THEN                                                          008610
              BEGIN                                                     008620
              BLMIPBLK[0]=1;                                            008630
              END                                                       008640
          BLUBSFLG[0]=1;     #BLOCK IS IN UBS#                          008650
          BLFSTTADR[0]=LOC(FSTT$AA[I]);#FSTT ADDRESS#                   008660
          INCH$AA(LOC(BLKFPTR[0]),LOC(FSBCHNH[I])); #HOOK TO CHAIN#      VBG1104
          FSBUFCNT[I]=FSBUFCNT[I]+1;   #BUMP BUFFER COUNT#              008720
          FSBUFFREE[I]=FSBUFFREE[I]+1; #BUMP FREE BUFFER COUNT#         008730
          BLKLNG[0] = BRICK(I) ; #BLOCK SIZE#                            *--AK--
          BLECNT[0]=(BLKLNG[0]-DBLKHEDSZ)*2;     #UNUSED HALF WORDS#    008750
          BLPRFXLN[0]=DBLKHEDSZ;  #SIZE OF BLOCK HEADER#                008760
          RETURN;                                                       008770
          END                                                           008780
CONTROL EJECT;                                                          008790
PROC VALFIT;                 #VALIDATE THE FIT#                         008800
 #                                                                      008810
* *   OPEN$AA                                    PAGE  1                 *--AK--
* *   VALFIT                                                            008830
* *   VB GODDARD                                 DATE  76/08/26         008840
* DC  NAME                                                              008850
*     VALFIT                                                            008860
* DC  FUNCTION                                                          008870
*     VALIDATE A FIT, CHECKING FOR ERRORS, INCONSISTENCIES, AND         008880
*       SETTING DEFAULT VALUES. USED FOR NEW FILES ONLY.                008890
* DC  ENTRY CONDITIONS                                                  008900
*     P<FIT$AA>=ADDRESS OF FIT.                                         008910
* DC  EXIT CONDITIONS                                                   008920
*     (THE FOLLOWING FIT FIELDS MAY BE SET OR MODIFIED)                 008930
*          FTKT  - KEY TYPE                                             008940
*          FTKL  - KEY LENGTH                                           008950
*          FTMNR - MINIMUM RECORD LENGTH                                008960
*          FTDP  - PADDING FACTOR                                       008970
*          FTNL  - INDEX LEVELS                                         008980
*          FTRB  - BLOCKING FACTOR                                      008990
*          FTMBL - BLOCK SIZE                                           009010
* DC  ERROR CONDITIONS                                                  009020
*     EC172 - KEY LENGTH MUST BE 5 OR 10 FOR INTEGER KEYS.              009030
*     EC166 - MRL(RECORD SIZE) NOT GIVEN.                               009040
*     EC166 - KL(KEY LENGTH) NOT GIVEN.                                 009050
*     EC172 - RKP EXCEEDS 9, WHILE EMK=YES. 
*     EC172 - KL(KEY LENGTH) TOO BIG.                                   009070
*     EC172 - MRL(RECORD SIZE) TOO BIG.                                 009080
*     EC530 - PADDING PERCENTAGE 100 OR MORE. 
* DC  CALLED ROUTINES                                                   009090
*     MBLCOMP - SUB-PROC TO COMPUTE BLOCK SIZE.                         009100
*     FATERR  - FATAL ERROR MESSAGES.                                   009110
*     DESCRIPTION                                                       009120
*     A STRAIGHT SEQUENCE OF IF-TESTS CHECK FOR ERRORS, RIGHTING        009130
*     INCONSISTENCIES, AND SETTING DEFAULTS.                            009140
 #                                                                      009150
CONTROL EJECT;                                                          009160
          BEGIN                                                         009170
          ITEM KLPP,MRLP,MNRP,MBLP;  #INTERMEDIATE VALUES#               *--AK--
                                                                        009190
                                                                        009200
          IF FTKT[0] EQ 0         #DEFAULT KEY TYPE IS SYMBOLIC#        009210
          THEN                                                          009220
              BEGIN                                                     009230
              FTKT[0] = KT"SYMBOLIC";                                   009240
              END                                                       009250
          IF (FTKT EQ KT"SIGNED" AND FTKL NQ 10 AND FOTYPE EQ FO"IS")    GAG0919
          OR (FTKL GR 8 AND FOTYPE EQ FO"AK")                            GAG0919
          THEN                                                           VBG1104
              BEGIN                                                      VBG1104
              FATERR(EC172);                                             VBG1104
              END                                                        VBG1104
          IF FTMNR[0] GR FTMRL[0] #LIMIT MINIMUM RECORD SIZE TO MAXIMUM#009460
          THEN                                                          009470
              BEGIN                                                     009480
              FTMNR[0] = FTMRL[0];                                      009490
              END                                                       009500
          IF FTMRL[0] EQ 0        #MAXIMUM RECORD SIZE MUST BE KNOWN#   009560
          OR FTKL[0] EQ 0    #KEY LENGTH IS REQUIRED#                    VBG1104
          THEN                                                          009570
              BEGIN                                                     009580
              FATERR(EC166);                                            009590
              END                                                       009600
          IF FTEMK EQ 0                                                  JJJ0519
          THEN                                                           JJJ0519
              BEGIN                                                      JJJ0519
              FTRKP = 10;                                                JJJ0519
              FTRKW[0] = 0;                                              *--AK--
              END                                                        JJJ0519
          ELSE
              BEGIN 
              IF FTRKP[0] GR 9
              THEN
                  BEGIN 
                  FATERR ( EC172 ) ;
                  END 
              END 
          IF FTKL[0] GR MXFTKL   #KEY SIZE TOO BIG# 
          THEN                                                          009670
              BEGIN                                                     009680
              FATERR(EC172);                                            009690
              END                                                       009700
          IF FTRKP[0] NQ 10       #SIZE OF NON-EMBEDDED KEY IN WORDS,#  009760
                                  #ELSE 0#                              009770
          THEN                                                          009780
              BEGIN                                                     009790
              KLPP=0;         #EMBEDDED KEY#                            009800
              X = WC * FTRKW[0] + FTRKP[0] + FTKL[0] ; #EXTENT OF KEY#   *--AK--
              IF FTMNR[0] EQ 0         #IS MIN REC SIZE GIVEN#           VBG1215
              THEN                                                       VBG1215
                  BEGIN                                                  VBG1215
                  FTMNR[0]=X;          #SET MIN TO CONTAIN KEY#          VBG1215
                  END                                                    VBG1215
              IF X GR FTMRL[0]         #RECORDS MUST CONTAIN KEY#        VBG1215
              OR X GR FTMNR[0]                                           VBG1215
              THEN                                                       VBG1215
                  BEGIN                                                  VBG1215
                  FATERR (EC206);  #KEY NOT IN RECORD#
                  END                                                    VBG1215
              END                                                       009810
          ELSE                                                          009820
              BEGIN                                                     009830
              KLPP=WLG(FTKL[0]);        #NON-EMBEDDED KEY, ADD SIZE#    009840
              END                                                       009850
          IF FTMRL[0] + WC * KLPP GR MXFTMRL #RECORD SIZE TOO BIG#       *--AK--
          THEN                                                          009870
              BEGIN                                                     009880
              FATERR (EC534);  #MRL TOO LARGE#
              END                                                       009900
          IF FTRT[0] EQ RT"F"     #MIN = MAX IF RECORD IS FIXED SIZE#   009910
          THEN                                                          009920
              BEGIN                                                     009930
              FTMNR[0]=FTMRL[0];                                        009940
              END                                                       009950
          IF FTDP[0] GQ 100 OR FTIP[0] GQ 100 
          THEN
              BEGIN 
              FATERR ( EC530 ) ;
              END 
          IF FOTYPE EQ FO"IS"                                            *--AK--
          THEN                                                           *--AK--
              BEGIN                                                      *--AK--
              IF FTNL[0] EQ 0      #DEFAULT INDEX LEVEL COUNT#           *--AK--
              THEN                                                       *--AK--
                  BEGIN                                                  *--AK--
                  FTNL[0] = DFTNL;                                       *--AK--
                  END                                                    *--AK--
              IF FTNL[0] GR MXFTNL #LIMIT NUMBER OF LEVELS TO MAXIMUM#   *--AK--
              THEN                                                       *--AK--
                  BEGIN                                                  *--AK--
                  FTNL[0] = MXFTNL;                                      *--AK--
                  END                                                    *--AK--
              END                                                        *--AK--
          IF FOTYPE  NQ FO"AK"                                           *--AK--
          THEN                                                           *--AK--
              BEGIN                                                      *--AK--
              IF FTRB[0] EQ 0      #DEFAULT BLOCKING FACTOR#             *--AK--
              THEN                                                       *--AK--
                  BEGIN                                                  *--AK--
                  FTRB[0] = DFTISDARB;                                   *--AK--
                  END                                                    *--AK--
              END                                                        *--AK--
          ELSE                                                           *--AK--
              BEGIN                                                      *--AK--
              IF FTRB[0] EQ 0      #DEFAULT BLOCKING FACTOR#             *--AK--
              THEN                                                       *--AK--
                  BEGIN                                                  *--AK--
                  MRLP = WLG((FTMRL[0]+FTMNR[0])/2); #WDS PER AVG REC#
                  IF FTMBL[0] EQ 0
                  THEN
                      BEGIN #NEITHER BLOCK SIZE NOR RB GIVEN# 
                      J = DFTAKBLKSZ*DPRUSIZ-DBLKHEDSZ-TWO-DFTAKRB/2 ;
                      IF DFTAKRB*MRLP LS J
                      THEN
                          BEGIN 
                          FTRB[0] = J / MRLP ;
                          END 
                      ELSE
                          BEGIN 
                          FTRB[0] = DFTAKRB ; 
                          END 
                      END 
                  ELSE #DEDUCE RB FROM GIVEN BLOCK SIZE#
                      BEGIN 
                      FTRB[0] = (WLG(FTMBL[0]))/MRLP + 1 ;
                      END 
                  END                                                    *--AK--
              END                                                        *--AK--
          MBLCOMP;           #COMPUTE FTMBL (BLOCK SIZE)#               010160
          RETURN;                                                       010170
CONTROL EJECT;                                                          010180
PROC MBLCOMP;      #COMPUTE BLOCK SIZE FROM FIT PARAMETERS#             010190
 #                                                                      010200
* *   OPEN$AA                                    PAGE  1                 *--AK--
* *   VALFIT                                                            010220
* *   MBLCOMP                                                           010230
* *   GA GREENE                                  DATE  78/05/31          *--AK--
* DC  NAME                                                              010250
*     MBLCOMP                                                           010260
* DC  FUNCTION                                                          010270
*     COMPUTE BLOCK SIZE.                                               010280
* DC  ENTRY CONDITIONS                                                  010290
*     P<FIT$AA>=ADDRESS OF FIT.                                         010300
*     FTKL=KEY LENGTH, IN CHARACTERS.                                   010310
*     FTMRL=MAXIMUM RECORD LENGTH, IN CHARACTERS.                       010320
*     FTMNR=MINIMUM RECORD LENGTH, IN CHARACTERS, OR 0.                 010330
*     FTMBL=BLOCK SIZE, IN CHARACTERS, OR 0.                            010340
*     FTRB=RECORDS/BLOCK.                                               010350
*     FTDP=PERCENT PADDING.                                             010360
*     FTFLM=FILE LIMIT, IN RECORDS.                                     010370
*     FTNL=NUMBER OF INDEX LEVELS.                                      010380
*     KLPP=0 IF KEY EMBEDDED, ELSE KEYSIZE IN WORDS.                    010390
*     FOTYPE=FTFO[0] SET UP AT START IN OPEN                             *--AK--
*     MBLCOMP HAS NO PARAMETERS.                                        010400
* DC  EXIT CONDITIONS                                                   010410
*     FTMBL=BLOCK LENGTH, IN CHARACTERS.                                010420
* DC  ERROR CONDITIONS                                                  010430
*     NONE                                                              010440
* DC  NON-LOCAL VARIABLES.                                              010450
*     (ALL DEFINED IN VALFIT)                                           010460
*     MRLP=ACTUAL MAXIMUM RECORD LENGTH, IN WORDS.                      010480
*     MNRP=ACTUAL MINIMUM RECORD LENGTH, IN WORDS.                      010490
*     MBLP=COMPUTED BLOCK LENGTH, IN WORDS.                             010500
*     (GLOBAL TEMPORARIES)                                              010510
*     X,Y,I.                                                            010520
* DC  DESCRIPTION                                                       010530
*     1. MRLP, AND MNRP ARE COMPUTED, ALLOWING FOR NON-EMBEDDED KEYS.    GAG0623
*     2. IF BLOCK SIZE IS GIVEN                                          GAG0623
*        -1-  MBLP IS GREATER OF FTMBL OR MRLP+1                         GAG0623
*        -2-  MBLP IS ADJUSTED UPWARDS TO AN INTEGRAL NUMBER OF PRUS     GAG0623
*              LESS 2 WORDS.                                             GAG0623
*        -3-  FTMBL=10*MBLP UNLESS IT EXCEEDS THE MAXIMUM PERMISSIBLE    GAG0623
*              BLOCK SIZE, IN WHICH CASE FTMBL=MXFTMBL.                  GAG0623
*     3. IF BLOCK SIZE IS NOT GIVEN                                      GAG0623
*        -1-  SET RUP TO THE APPROPRIATE DEFAULT BLOCK SIZE              GAG0623
*        -2-  STEP RUP UP UNTIL RUP GQ A, DATA BLOCK SIZE REQUIRED (IN   GAG0623
*              WORDS)                                                    GAG0623
*        -3-  IF FOTYPE EQ FO"IS", STEP UP RUP UNTIL RUP REFLECTS AN     GAG0623
*              ADEQUATE INDEX BLOCK SIZE                                 GAG0623
*        -4-  MBLP=DPRUSIZ*RUP-TWO                                       GAG0623
*        -5-  FTMBL=10*MBLP UNLESS IT EXCEEDS THE MAXIMUM PERMISSIBLE    GAG0623
*              BLOCK SIZE, IN WHICH CASE FTMBL=MXFTMBL.                  GAG0623
*                                                                        GAG0623
 #                                                                      010970
CONTROL EJECT;                                                          010980
              BEGIN  #BEGINNING OF FTMBL COMPUTATION#                    *--AK--
              ITEM A,B,XNL,XMAX,XRB,RUP;                                 *--AK--
              MRLP=WLG(FTMRL[0])+KLPP;  #MAX RECORD SIZE IN WORDS#       *--AK--
              MNRP=WLG(FTMNR[0])+KLPP;  #MIN RECORD SIZE IN WORDS#       *--AK--
              IF FTMBL[0] NQ 0  #DETERMINE BLOCK SIZE#                   *--AK--
              THEN                                                       *--AK--
                  BEGIN  #MBL GIVEN - DETERMINE IF LARGE ENOUGH#         *--AK--
                  MBLP=WLG(FTMBL[0]);                                    *--AK--
                  MBLP=((MBLP+DBLKHEDSZ+3+DPRUSIZ-1)/DPRUSIZ)            *--AK--
                        *DPRUSIZ-TWO; #ROUND UP MBLP TO INTEGRAL   PRUS# *--AK--
                  END                                                    *--AK--
              ELSE  #IF FTMBL[0] EQ 0#                                   *--AK--
                  BEGIN  #MBL NOT GIVEN - IT MUST BE CALCULATED#         *--AK--
                  XMAX=(MXFTMBL+(DPRUSIZ-1)*WC)/(DPRUSIZ*WC);            *--AK--
                  XNL=FTNL[0];  #NUMBER OF LEVELS OF INDEX BLOCKS#       *--AK--
                  XRB=FTRB[0];  #NUMBER OF RECORDS PER BLOCK#            *--AK--
                  A=XRB*(MRLP+MNRP+1)/2;  #WORDS NEEDED IN DATA BLOCK#   *--AK--
                  IF XRB EQ 1                                            *--AK--
                  THEN                                                   *--AK--
                      BEGIN                                              *--AK--
                      A=A+1;                                             *--AK--
                      END                                                *--AK--
                  IF FOTYPE EQ FO"IS"                                    *--AK--
                  THEN                                                   *--AK--
                      BEGIN                                              *--AK--
                      RUP=DFTISBLKSZ;                                    *--AK--
                      B=WLG(FTKL[0]+FOUR);  #INDEX RECORD LENGTH#        *--AK--
                      IF FTFLM[0] EQ 2**30-1  #DEFAULT# 
                      THEN                                               *--AK--
                          BEGIN                                          *--AK--
                          I2 = 100000 ; 
                          END 
                      ELSE
                          BEGIN 
                          I2 = FTFLM[0] ; 
                          END 
                      IF XNL EQ 0                                        *--AK--
                      THEN                                               *--AK--
                          BEGIN                                          *--AK--
                          XNL=2;                                         *--AK--
                          END                                            *--AK--
                      END                                                *--AK--
                  ELSE  #IF FOTYPE IS NOT IS#                            *--AK--
                      BEGIN                                              *--AK--
                      IF FOTYPE EQ FO"AK"                                *--AK--
                      THEN                                               *--AK--
                          BEGIN                                          *--AK--
                          RUP = 1 ; 
                          END                                            *--AK--
                      ELSE  #IF FOTYPE IS DA#                            *--AK--
                          BEGIN                                          *--AK--
                          RUP=DFTDABLKSZ;                                *--AK--
                          END                                            *--AK--
                      END                                                *--AK--
                  FOR RUP=RUP STEP 1 WHILE RUP LS XMAX DO                *--AK--
                      BEGIN                                              *--AK--
                      IF (RUP*DPRUSIZ-DBLKHEDSZ-TWO) GQ A                *--AK--
                        AND (FOTYPE NQ FO"IS"                            *--AK--
                        OR (XRB*POWR$AA((RUP*DPRUSIZ-DBLKHEDSZ-TWO-1)/B,
                          XNL) GQ I2 )) 
                      THEN                                               *--AK--
                          BEGIN                                          *--AK--
                          GOTO EXIT;                                     *--AK--
                          END                                            *--AK--
                      END                                                *--AK--
      EXIT:       MBLP=DPRUSIZ*RUP-TWO;                                  *--AK--
                  END                                                    *--AK--
              ASLONGAS (MBLP*(100-FTDP[0]))/100 LS MRLP+1 
              DO
                  BEGIN 
                  MBLP = MBLP + DPRUSIZ ; 
                  END 
              MBLP=MBLP*WC;  #BLOCK SIZE IN CHARACTERS#                  *--AK--
              IF MBLP GR MXFTMBL  #MUST NOT EXCEED MAX BLOCK SIZE#       *--AK--
              THEN                                                       *--AK--
                  BEGIN                                                  *--AK--
                  FTMBL[0]=MXFTMBL;                                      *--AK--
                  END                                                    *--AK--
              ELSE                                                       *--AK--
                  BEGIN                                                  *--AK--
                  FTMBL[0]=MBLP;                                         *--AK--
                  END                                                    *--AK--
              RETURN;                                                    *--AK--
              END  #END OF FTMBL COMPUTATION#                            *--AK--
          END  #END OF VALFIT#                                           *--AK--
CONTROL EJECT;                                                          011740
PROC FSTTBLOK(FET);#ALLOCATE SPACE AND BUILD AN FSTT BLOCK FRAME#       011750
 #                                                                      011760
* *   OPEN$AA                                    PAGE  1                 *--AK--
* *   FSTTBLOK                                                          011780
* *   VB GODDARD                                 DATE  76/08/25         011790
* DC  NAME                                                              011800
*     FSTTBLOK                                                          011810
* DC  FUNCTION                                                          011820
*     ALLOCATE SPACE FOR AN FSTT AND BUILD ITS BLOCK FRAME.             011830
* DC  ENTRY CONDITIONS                                                  011840
*     1 THIS PROC HAS 1 PARAMETER:                                      011850
*            =0 FOR DATA FILE FSTT,                                     011860
*            =SIZE OF FET FOR MIP FILE FSTT.                            011870
*     2 P<FIT$AA>=ADDRESS OF FIT.                                       011880
* DC  EXIT CONDITIONS                                                   011890
      1 P<FSTT$AA>=ADDRESS OF THE FSTT.                                 011900
*     2 P<BLOK$AA>=ADDRESS OF THE FSTT BLOCK FRAME.                     011910
*     3 SPACE FOR THE FSTT IS ALLOCATED, ITS BLOCK FRAME COMPLETED.     011920
*       IF IT IS A MIP FSTT, THE SPACE INCLUDES ROOM FOR THE FET        011930
*       IMMEDIATELY FOLLOWING THE FSTT.                                 011940
*     6 SET COMPLETION STATUS AND FET POINTERS FOR FSTT.                 VBG0922
*     7 THE FWB VALUE IS SAVED IN THE FSTT.                              VBG1026
* DC  ERROR CONDITIONS                                                  011970
*     NONE                                                              011980
* DC  CALLED ROUTINES                                                   011990
*     GETSPACE - TO ALLOCATE SPACE. GETSPACE IS A FUNC.                 012000
*     MFET$AA - TO SET FET BUFFER POINTERS.                              CIM0117
* DC  DESCRIPTION                                                       012010
*     FULLY DESCRIBED UNDER EXIT CONDITIONS.                            012020
 #                                                                      012030
                                                                        012040
                                                                        012050
                                                                        012060
          BEGIN                                                         012070
          ITEM FET;          #SIZE OF FET FOR MIP FILE, ELSE 0#         012080
                                                                        012090
                                                                        012100
          P<FSTT$AA> = GETSPACE(SZFSTTIC + FET);  #ALLOCATE SPACE#       JJJ1204
          P<BLOK$AA>=P<FSTT$AA>;     #SET BLOCK FRAME ADDRESS#          012130
          IF UBSFLG NQ 0     #SET FLAG IF FSTT IS IN UBS#                VBG1104
          THEN                                                          012150
              BEGIN                                                     012160
              BLUBSFLG[0]=1;                                            012170
              END                                                       012180
          BLKLNG[0]=SZFSTT;  #BLOCK SIZE#                               012280
          BLOCKID[0]=1;      #PRU OF FSTT ALWAYS 1#                     012290
          BLFSTTADR[0]=P<FSTT$AA>;          #I/O ROUTINES LOOK AT FSTTS#012300
          P<FET$AA>=P<FIT$AA>;                                           VBG1112
          FEFCSE = 1;        #SET COMPLETION STATUS#                     JJJ0216
          MFET$AA;           #SET FET BUFFER POINTERS#                   VBG1112
          FEIN[0]=FEOUT[0];  #SET IN POINTER FOR READ#                   VBG1117
          RETURN;                                                       012310
          END                                                           012320
CONTROL EJECT;                                                          012330
PROC FSTTSUB;      #CODE COMMON TO FINDFSTT AND MAKEFSTT PROCS#         012340
 #                                                                      012350
* *   OPEN$AA                                    PAGE  1                 *--AK--
* *   FSTTSUB                                                           012370
* *   VB GODDARD                                                        012380
* DC  NAME                                                              012390
*     FSTTSUB                                                           012400
* PC  FUNCTION                                                          012410
*     A SPACE SAVING PROC CONTAINING CODE NEEDED BY BOTH FINDFSTT AND   012420
*     MAKEFSTT WHILE INITIALIZING AN FSTT.                              012430
* DC  ENTRY CONDITIONS                                                  012440
*     1 P<FIT$AA>=ADDRESS OF FIT.                                       012450
*     2 P<FSTT$AA>=ADDRESS OF FSTT.                                     012460
*     3 FSTTHED IN GCOM$AA CONTAINS THE ADDRESS OF THE FSTT CHAIN.      012470
* DC  EXIT CONDITIONS                                                   012480
*     1 THE FSTT USER COUNT IS SET TO 1.                                012490
*     2 THE FSTT BUFFER CHAIN IS SET EMPTY.                             012500
*     4 THE FIT IS LINKED INTO THE FSTT FIT CHAIN.                      012520
*     5 THE FSTT IS LINKED INTO THE FSTT CHAIN.                         012530
*     6 THE FIT IS DESIGNATED AS THE LAST BUSY FET.                      VBG0922
* DC  ERROR CONDITIONS                                                  012540
*     NONE                                                              012550
* DC  DESCRIPTION                                                       012560
*     FULLY DESCRIBED UNDER EXIT CONDITIONS                             012570
 #                                                                      012580
          BEGIN                                                         012590
          FSUSRCNT[0]=1;          #ONLY 1 FIT WHEN OPEN/NEW#            012600
          FSBCHNH[0]=LOC(FSBCHNH[0]);  #BUFFER CHAIN TO SELF#           012610
          FSBCHNT[0]=LOC(FSBCHNT[0]);                                   012620
          FSFTCHN[0]=P<FIT$AA>;   #LINK FSTT TO FIT#                    012640
          FSFSCHN[0]=FSTTHED[0];  #FSTT CHAIN#                          012650
          FSTTHED[0]=P<FSTT$AA>;  #LINK INTO FSTT CHAIN#                012660
      FSBZFET[0]=P<FIT$AA>;  #SET LAST BUSY FET TO CURRENT FIT#          VBG0922
          END                                                           012670
CONTROL EJECT;                                                          012680
PROC FATERR (ERRNO);         #ERROR FATAL TO OPEN#                       JJJ0408
 #                                                                      012700
* *   OPEN$AA                                    PAGE  1                 *--AK--
* *   FATERR                                                            012720
* *   VB GODDARD                                 DATE  76/08/25         012730
* DC  NAME                                                              012740
*     FATERR                                                            012750
* DC  FUNCTION                                                          012760
*     PROCESS AN ERROR DETECTED WHILE ATTEMPTING TO OPEN A FILE.         AM2A077
* DC  ENTRY CONDITIONS                                                  012780
*     1 THE ERROR CODE NUMBER IS THE ONLY PARAMETER FOR THIS PROC.      012790
*       NORMALLY IT IS POSITIVE. IF IT IS NEGATIVE, ITS ABSOLUTE
*       VALUE IS TO BE PASSED TO THE FATAL MESSAGE ROUTINE, BUT THE 
*       NAMES OF THE MAIN FILE AND THE MIP FILE ARE TO BE EXCHANGED 
*       IN THE FIT IMMEDIATELY BEFORE CALLING THE FATAL MESSAGE 
*       ROUTINE, AND RESTORED IMMEDIATELY AFTER. THIS ENABLES US TO 
*       HAVE THE MIP FILE NAME, RATHER THAN THE MAIN FILE NAME, 
*       INSERTED IN THE MESSAGE. AT ONLY ONE PLACE IS THIS FEATURE
*       USED -- IN MIP$OPN, IF WE DISCOVER THAT THE MIP FILE ALREADY
*       EXISTS, AND SPOILS AN OPEN-NEW, THOUGH THE MAIN FILE DOES NOT.
*     2 FITSAV IN GCOM$AA CONTAINS THE FIT ADDRESS.                     012800
* DC  EXIT CONDITIONS                                                   012810
*     ANY SPACE ALLOCATED FOR THE FIT IS DELINKED, IF NECESSARY, AND    012820
*     RELEASED, IF IN CMM SPACE. THEN ERROR CODE IS PASSED TO MSGZ$AA TO JJJ0408
*     GENERATE THE ERROR MESSAGE. FTFWB IS SET TO ITS STATE ON ENTRY TO  JJJ0408
*     OPEN AND FTOC IS SET TO NEVER OPENED.                              JJJ0408
* DC  ERROR CONDITIONS                                                  012850
*     NONE                                                              012860
* DC  CALLED ROUTINES                                                   012870
*     DLNK$AA - TO DELINK THE FIT, FSTT, AMD BUFFERS, AS NECESSARY.     012880
*     RLSP$AA - TO RELEASE BLOCKS IN CMM SPACE.                         012890
*     MSGZ$AA - GENERATE ERROR MESSAGE                                   JJJ0408
* DC  DESCRIPTION                                                       012910
*     DLNK$AA IS CALLED TO DO ALL DELINKING. RLSP$AA IS CALLED TO       012920
*     RELEASE CMM SPACE. FTFWB AND FTOC ARE RESET. MSGZ$AA IS CALLED TO  JJJ0408
*     ISSUE THE ERROR MESSAGE. EXIT$AA IS CALLED TO RETURN TO THE OPENER JJJ0408
*     OR ERROR EXIT IF ANY.                                              JJJ0408
 #                                                                      012960
                                                                        012970
                                                                        012980
                                                                        012990
          BEGIN                                                         013000
          ITEM ERRNO;                                                   013010
                                                                        013020
                                                                        013030
          DLNK$AA;      #DELINK EVERYTHING FOR FIT#                     013040
          RLSP$AA;           #RELEASE ALL CMM SPACE FOR THIS FIT#       013050
          FTFWB = XFWB;      #VALUE ON ENTRY#                            JJJ0408
          FTOC = 0;          #NEVER OPENED#                              JJJ0408
          IF ERRNO LS 0 
          THEN
              BEGIN 
              FTLFN[0] == FTXN[0] ; 
              END 
          MSGF$AA ( ABS(ERRNO) ) ;
          IF ERRNO LS 0 
          THEN
              BEGIN 
              FTLFN[0] == FTXN[0] ; 
              END 
          CLUN$AA;          #CLEAN UP DUE TO UNSUCCESSFUL OPEN# 
          STRG$AA;           #RECALCULATE TARGET# 
          IF TARGET LS 0
          THEN
              BEGIN 
              TARGET = -TARGET; 
              END 
          GOTO EXIT$AA;                                                  JJJ0913
          END                                                           013080
      END                                                               013090
      TERM                                                              013100
