*DECK DB$CLSA 
USETEXT CDCSCTX 
USETEXT JLPCMTX 
      PROC DB$CLSA; 
      BEGIN 
 #
* *   DB$CLSA -- CLOSE AREA AND LOG CLOSE        PAGE  1
* *   C O GIMBER                                 10/27/76 
* *   W.P. CEAGLIO                               DATE  11/17/78 
* *   R.L. MCALLESTER                            DATE  01/26/81 
* 
* DC  PURPOSE 
* 
*     CLOSE AREA AND DO JOURNAL LOGGING FOR CLOSE.
* 
* DC  ENTRY CONDITIONS
* 
*     SALX SET. 
*     P<RSARBLK> SET. 
* 
* DC  CALLING ROUTINES
* 
*     DB$CLS$                THE CLOSE SYMBIONT 
*     DB$ERR                 CDCS USER ERROR ROUTINE
*     DB$TQTD                DELETE THE TASK QUEUE TABLE
*     DB$VER$                VERSION CHANGE CONTROL SYMBIONT
* 
* DC  CALLED ROUTINES 
# 
      XREF PROC CLOSEM;      #CRM CLOSE PROCESSOR#
      XREF FUNC DB$CDEC C(10);  # INTEGER TO DISPLAY CODED DECIMAL     #
      XREF PROC DB$DBPU;     # UNLOAD DATABASE PROCEDURE               #
      XREF PROC DB$FKLR;     # RELEASE A FIELD FROM THE FKL            #
      XREF PROC DB$FLOP;     #GENERATE FLOW POINT#
      XREF PROC DB$FSET;     # SELECT AND SET A FIT                    #
      XREF PROC DB$JLH;      # INITIALIZE JOURNAL LOG RECORD HEADER    #
      XREF PROC DB$JLO;      # OUTPUT JOURNAL LOG RECORD               #
      XREF PROC DB$LNKD;     #DELETE LINKED BLOCK#
      XREF PROC DB$LOKD;     #DELETE LOCK#
      XREF PROC DB$MBF;      # FREE AN RCB MANAGED BUFFER              #
      XREF PROC DB$MFO9;     #MEMORY OVERFLOW OPTION,  ABORT CDCS      #
      XREF FUNC DB$NEED;     # COMPUTE REVISED NEED FOR FITS           #
      XREF PROC DB$POP;      # POP AN ENTRY FROM THE STACK             #
      XREF PROC DB$PUSH;     # PUSH AN ENTRY ONTO THE STACK            #
# 
* DC  NON-LOCAL VARIABLES 
# 
      XREF ITEM CMM$SBL;     # SMALL BLOCK LIMIT  -- BECOMES CMM.SBL   #
      XREF ITEM CMMSBI;      # SMALL BLOCK BOUNDARY INCREMENT          #
      XREF ITEM DB$MFPA;     #MEMORY OVERFLOW OPTION PROCEDURE ADDRESS #
      XREF ARRAY DB$RA0;;    #ARRAY BASED AT RA+0 USED TO TERMINATE#
                             #FTN TYPE PARAMETER LISTS# 
      XREF ITEM RJRSW B;     # RESTRICT JOURNAL RECORDS  -  SWITCH     #
# 
*     CDCS COMMON 
*     CST AREA WORK BLOCK 
* 
*     JOURNAL LOG COMMON
 #
*CALL CSTARDCLS 
# 
*     LOCAL VARIABLES.
# 
      ITEM ALTPTR     I;     # VALUE FOR RSARALT                       #
      ITEM AREAOFFSET I;     # OFFSET IN RSB TO AREA CONTROL BLOCK     #
      ITEM ARID       I;     # SAVE AREA ID NUMBER                     #
      ITEM ARNAME C(30);     # AREA NAME                               #
      ITEM NEED       I;     # THE NUMBER OF FITS TO DELETE            #
      ITEM SAVEARBLK  I;     # SAVE RSB AREA CONTROL BLOCK POINTER     #
      BASED ARRAY DUMMY;; 
  
  
  
#     B E G I N   D B $ C L S A   E X E C U T A B L E   C O D E .      #
  
  
 #
* 
* DC  DESCRIPTION 
* 
*     DELETE LOCK ON AREA.
 #
  
      CONTROL IFGR DFFLOP,0;
        DB$FLOP("CLSA");
      CONTROL ENDIF;
  
      DB$PUSH(DB$CLSA); 
      DB$LOKD(TRUE);
      P<OFT> = RSAROFIT[0]; 
 #
*     DB$MFPA DETERMINES THE OPTION TO BE SELECTED ON MEMORY OVERFLOW.
*     DB$MFO9 IS THE OVERFLOW OPTION PROCEDURE TO ABORT CDCS. 
*     IF AN OVERFLOW OCCURS DURING THE CLOSE PROCESS, A USER TERMINATION
*     IS IMPOSSIBLE.  THE ONLY REMAINING OPTION IS TO ABORT CDCS. 
 #
      DB$MFPA = LOC(DB$MFO9); 
 #
* 
*     IF THIS CLOSURE REDUCES THE NUMBER OF FITS THAT SHOULD BE USED
*     ISSUE CRM CLOSE ON AREA.
* 
*     THE COUNT OF OPENS IS REDUCED BEFORE CALLING DB$NEED. 
*     THIS IS NECESSARY SO THAT DB$NEED WILL COMPUTE THE CORRECT
*     REDUCTION OF THE NUMBER OF FITS.
*     THERE IS A DANGER THAT IF THE JOB WAS DROPPED DURING LOG
*     PROCESSING DB$CLSA WOULD BE REPEATED DURING JOB TERMINATION.
*     THAT COULD RESULT IN A DOUBLE REDUCTION OF THE OFOPEN COUNT.
*     RSAROFOCR IS USED TO AVOID THAT POSIBILITY. 
* 
 #
      IF NOT RSAROFOCR[0]          # OFT OPEN COUNT REDUCED            #
      THEN
        BEGIN 
        OFOPENS[0] = OFOPENS[0] - 1;
        END 
      RSAROFOCR[0] = TRUE;
      NEED = -DB$NEED;
      FOR NEED = NEED STEP -1 UNTIL 1 
      DO
        BEGIN 
 #
*       SELECT AND SET A UFT. 
*       IF THE ONLY ONE LEFT IS IN THE OFT, IT IS SELECTED. 
*       CLOSE THE SELECTED UFT. 
 #
        DB$FSET;
        IF LOC(UFT) EQ LOC(OFUFT[0])
        THEN
          BEGIN 
          UFTQT[0] = 0;      # SO DB$FSET WILL NOT SELECT IT AGAIN     #
                             # UNLESS IT IS THE ONLY ONE.              #
          DB$FSET;
          END 
        P<DUMMY> = LOC(UFFIT[0]); 
        UFFITFNF[0] = FALSE;      # RESET FATAL ERROR FLAG             #
  
        CONTROL IFGR DFFLOP,0;
          DB$FLOP("CLSA-1");
        CONTROL ENDIF;
  
        IF UFFITOC[0] EQ DFFITOCOPEN  # IF FILE IS OPEN, CLOSE IT.     #
        THEN
          BEGIN 
          CLOSEM(DUMMY,DFFITCFDET,DB$RA0);
          END 
 #
*       DELINK THE UFT UNLESS IT IS THE ONE IN THE OFT. 
*       IF IT IS IN THE OFT, CLEAR ITS LINKAGES.
 #
        IF LOC(UFT) NQ LOC(OFUFT[0])
        THEN
          BEGIN 
          UFTQT[0] = 0;      # SO DB$FSET WILL NOT SELECT IT AGAIN     #
          FPUFT[0] = 0; 
          DB$LNKD(P<UFT>);
          END 
        ELSE
          BEGIN 
          UFWORD[0] = DFNPTR; 
          END 
        END 
      P<UFT> = LOC(OFUFT);
 #
*     UPDATE RUN-UNIT STATISTICS AND LOG "CLOSE" RECORD IF NOT IMPLICIT 
*     AREA ENTRY
 #
      P<CSAREBLK> = LOC(CSFIXED) + RSARCSTP [0];
      IF NOT RSARIMPL [0] 
          AND NOT RJRSW            # NOT SUPPRESSED BY RJR PARAMETER   #
      THEN
        BEGIN 
        RSFNRDS[0] = RSFNRDS[0] + FPNRDS[0];
        RSFNWRS[0] = RSFNWRS[0] + FPNWRS[0];
        RSFNRWS[0] = RSFNRWS[0] + FPNRWS[0];
        RSFNDLS[0] = RSFNDLS[0] + FPNDLS[0];
        IF SASCJAFG[SALX] 
          AND OFSTATUS[0] NQ S"ERRDOWN" 
          AND NOT SANOJLF[SALX] 
          AND P<RCB> GR 0 
          AND NOT RCJLRS[0]        # NOT DROPPED DURING JOURNAL LOGGING#
          AND NOT RCJLWTR[0]       # NOT DROPPED DURING DB$RWTR        #
        THEN
          BEGIN 
          PARLEN = DFJLSZCL;
          DB$JLH;            # INITIALIZE JOURNAL LOG RECORD HEADER    #
          JLHDWDA[0] = DFJLWDACL; 
          JLCLARNM[0] = C<0,CSANAMLW[0]*10>CSANAME[0];   # AREA NAME   #
  
                                                         # NUMBER OF   #
          JLCLNRDS[0] = DB$CDEC(FPNRDS[0],10);  # READS                #
          JLCLNWRS[0] = DB$CDEC(FPNWRS[0],10);  # WRITES               #
          JLCLNRWS[0] = DB$CDEC(FPNRWS[0],10);  # REWRITES             #
          JLCLNDLS[0] = DB$CDEC(FPNDLS[0],10);  # DELETES              #
          AREAOFFSET = LOC(RSARBLK) - LOC(RSB); 
          DB$PUSH(AREAOFFSET);  # THE AREA OFFSET IN THE RSB MUST BE   #
                                # SAVED BECAUSE A DB$SCHD CALL VIA     #
                                # DB$JLO COULD SET IT INCORRECTLY      #
                                # BECAUSE RSFCAORD MAY NOT CONTAIN     #
                                # THE APPROPIATE AREA ORDINAL.         #
                                #         ALSO                         #
                                # THE RSB COULD BE SWAPPED OUT AND     #
                                # RELOADED IN A DIFFERENT LOCATION.    #
          TRLRLEN = 0;
          DB$JLO;            # OUTPUT A JOURNAL LOG RECORD             #
                             # DB$JLO IS INTERRUPTIBLE, RESTORE POINTER#
          DB$POP(AREAOFFSET); 
          P<RSARBLK> = LOC(RSB) +  AREAOFFSET;
          DB$MBF(P<JLREC>);  # FREE THE JOURNAL LOG RECORD BUFFER      #
                             # THAT WAS ALLOCATED BY DB$JLH.           #
          P<CSAREBLK> = LOC(CSFIXED) + RSARCSTP[0]; 
          P<OFT> = RSAROFIT[0]; 
          P<FKL> = RSFFKLLOC[0];
          P<FPT> = LOC(FKL) + RSARFPT[0]; 
          P<UFT> = LOC(OFUFT);
          END 
        END 
  
 #
*     IF A DA HASHING PROCEDURE IS SPECIFIED FOR THIS FILE, 
*     DECREMENT THE USER COUNT FOR THE PROCEDURE. 
*     IF THE USER COUNT IS ZERO, UNLOAD THE PROCEDURE.
 #
      APLX = CSAHSORD[0]; 
      IF APLX NQ 0 AND UFFITHRL[0] NQ 0 THEN
        BEGIN 
        P<APL> = SADBPPTR[SALX];
        APNUSERS[APLX] = APNUSERS[APLX] - 1;
        IF APNUSERS[0] EQ 0 THEN
          BEGIN 
  
          CONTROL IFGR DFFLOP,0;
            DB$FLOP("CLSA-2");
          CONTROL ENDIF;
  
          DB$DBPU(APWORD0[0],LOC(APDBPNAM[APLX]));
          END 
        END 
  
 #
*     IF ANY DATA COMPRESSION AND PROC WAS LOADED, DECREMENT USER COUNT 
*     FOR PROC - IF ZERO, UNLOAD DBP.  REPEAT STEPS FOR DECOMPRESSION 
*     DBP IF DIFFERENT ROUTINE WAS USED.
 #
      APLX = CSACMORD[0]; 
      IF APLX NQ 0 AND UFFITCPA[0] NQ 0 THEN
        BEGIN 
        P<APL> = SADBPPTR[SALX];
        APNUSERS[APLX] = APNUSERS[APLX] - 1;
        IF APNUSERS[APLX] EQ 0 THEN 
          BEGIN 
  
          CONTROL IFGR DFFLOP,0;
            DB$FLOP("CLSA-3");
          CONTROL ENDIF;
  
          DB$DBPU (APWORD0[0],LOC(APDBPNAM[APLX])); 
          END 
        END 
      IF CSADEORD[0] NQ CSACMORD[0] THEN
        BEGIN 
        APLX = CSADEORD[0]; 
        APNUSERS[APLX] = APNUSERS[APLX] - 1;
        IF APNUSERS[APLX] EQ 0 THEN 
          BEGIN 
  
          CONTROL IFGR DFFLOP,0;
            DB$FLOP("CLSA-4");
          CONTROL ENDIF;
  
          DB$DBPU (APWORD0[0],LOC(APDBPNAM[APLX])); 
          END 
        END 
 #
*     IF THE SMALL BLOCK BOUNDARY IS BEING ADJUSTED DYNAMICALLY,
*     REDUCE IT.
 #
      IF CMMSBI NQ 0
      THEN
        BEGIN 
        CMM$SBL = CMM$SBL - O"100";  # CMM$SBL BECOMES CMM.SBL         #
        END 
 #
*     IF THERE ARE ANY EXTENDED AREA CONTROL BLOCKS THAT MIGHT BE 
*     USED FOR CONSTRAINT PROCESSING, THEN SCAN THE CONTROL BLOCKS
*     FOR INSTANCES OF THIS AREA THAT ARE STILL OPEN. 
*     DONT PERFORM THE SCAN IF THE ONE BEING DELETED IS NOT THE 
*     MAIN POINTER.  ONLY THE MAIN POINTER NEEDS REPLACING. 
* 
*     IF OTHERS ARE FOUND, THE FIRST ONE BECOMES THE MAIN POINTER.
*     THE OTHERS ARE RESET TO POINT TO IT.
 #
  
      IF CSFEXTNO[0] GR 0 
        AND RSARALT[0] EQ 0 
      THEN
        BEGIN 
        ARID = RSARID[0]; 
        SAVEARBLK = P<RSARBLK>; 
        ALTPTR = 0; 
  
        FOR AREAOFFSET=DFRSBFIX + (CSFARENO[0] -1) * DFARECON 
        STEP -DFARECON  UNTIL DFRSBFIX
        DO
          BEGIN 
          P<RSARBLK> = LOC(RSB) + AREAOFFSET; 
          IF ARID EQ RSARID[0]
            AND P<RSARBLK> NQ SAVEARBLK 
            AND RSARFPT[0] NQ 0 
          THEN
            BEGIN                  # FOUND ANOTHER STATUS BLOCK FOR    #
                                   # THE SAME AREA ID                  #
  
            CONTROL IFGR DFFLOP,0;
              DB$FLOP("CLSA-5");
            CONTROL ENDIF;
  
            RSARALT[0] = ALTPTR;
            IF ALTPTR EQ 0
            THEN
              BEGIN                # THE 1ST ONE FOUND IS THE NEW PTR  #
                                   # THE OTHERS POINT TO IT            #
              ALTPTR = LOC(RSB) - LOC(RSARALT[0]);
              END 
            END 
          END 
        P<RSARBLK> = SAVEARBLK; 
        END 
      RSAROFOCR[0] = FALSE; 
      RSARREQ[0] = 7; 
      DB$FKLR;                     # RETURN THE FPT.                   #
      DB$POP(DB$CLSA);
      P<FPT> = DFNPTR;
      RETURN; 
      END  #DB$CLSA#
      TERM; 
