*DECK DB$CLSE 
USETEXT CDCSCTX 
      PROC DB$CLSE; 
      BEGIN 
 #
* *   DB$CLSE -- CLOSE AREAS IN AN EMERGENCY     PAGE  1
* *   R.L. MCALLESTER                            DATE  02/14/86 
* 
* DC  PURPOSE 
* 
*     CLOSE AREAS UNDER EMERGENCY CONDITIONS. 
* 
* DC  ENTRY CONDITIONS
* 
*     P<RSB> OR P<CSFIXED> IS NEGATIVE. 
*         THERE IS NOT ENOUGH MEMORY AVAILABLE TO SWAP IN 
*         THE RSB AND/OR THE CST. 
* 
* DC  CALLING ROUTINES
* 
*     DB$SWPI                SWAP IN TABLES 
* 
* DC  CALLED ROUTINES 
# 
      XREF PROC CLOSEM;      # CRM CLOSE PROCESSOR                     #
      XREF PROC CMMSDA;      # RESPECIFY DYNAMIC AREA BASE ADDRESS     #
      XREF FUNC DB$CDEC C(10);  # INTEGER TO DISPLAY CODED DECIMAL     #
      XREF PROC DB$DBPU;     # UNLOAD DATABASE PROCEDURE               #
      XREF PROC DB$FLOP;     # GENERATE FLOW POINT                     #
      XREF PROC DB$FLSH;     # FLUSH CRM OUTPUT BUFFERS                #
      XREF PROC DB$FSET;     # SELECT AND SET A FIT                    #
      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$MBFA;     # FREE ALL TEMPORARY BUFFERS              #
      XREF PROC DB$MFF;      # CMM FREE FIXED BLOCK                    #
      XREF FUNC DB$NEED;     # COMPUTE NEW NEED FOR UFT'S              #
      XREF PROC DB$OFTR;     # OFT RELEASE PROCESSOR                   #
      XREF PROC DB$PUNT;     # CDCS ABORT PROCESSOR                    #
      XREF PROC DB$QRP;      # FLUSH QRF FILE                          #
      XREF PROC DB$RNRD;     # RANDOM READ INTO WSA                    #
      XREF PROC DB$WART;     # WRITE THE ART TO THE TRF                #
# 
* DC  NON-LOCAL VARIABLES 
# 
      XREF ITEM DB$OVBF I;   # OVERLAY MINIMUM BUFFER                  #
      XREF ITEM DB$HHAE I;   # HIGHEST HIGH ADDRESS DURING EXECUTION   #
      XREF ITEM DB$MFPA I;   # MEMORY OVERFLOW OPTION PROCEDURE ADDRESS#
      XREF ITEM SWPTC   I;   # COUNT OF ENTRIES IN SWAP TABLE          #
  
      XREF ARRAY DB$RA0;;    # ARRAY BASED AT RA+0 USED TO TERMINATE   #
                             # FTN TYPE PARAMETER LISTS                #
  
      XREF ARRAY DB$RNFT;;   # FET FOR SWAP FILE                       #
  
      XREF ARRAY SWPSEGT;    # SWAP SEGMENT TABLE                      #
        BEGIN 
*CALL SWPTDCLS
        END 
# 
*     CDCS COMMON 
*     CST AREA WORK BLOCK 
* 
 #
      CONTROL NOLIST;        # CSTARDCLS                               #
*CALL CSTARDCLS 
      CONTROL LIST; 
# 
*     LOCAL VARIABLES.
# 
      ITEM AREAOFFSET I;     # OFFSET IN RSB TO AREA CONTROL BLOCK     #
      ITEM AREAORD    I;     # AREA ORDINAL                            #
      ITEM FETLOC I = 0;     # LOCATION OF FET                         #
      ITEM CSAROFFSET I;     # OFFSET IN CST TO AREA WORK BLOCK        #
      ITEM GAPCST     I;     # SIZE OF THE MISSING PART OF THE CST     #
      ITEM GAPRSB     I;     # SIZE OF THE MISSING PART OF THE RSB     #
      ITEM LIMCST     I;     # LAST WORD +1 ADDRESS OF CST BUFFER AREA #
      ITEM LIMRSB     I;     # LAST WORD +1 ADDRESS OF RSB BUFFER AREA #
      ITEM NEED       I;     # NUMBER OF UFT'S TO BE RELEASED          #
      ITEM OLDGAP     I;     # WORKING VARIABLE                        #
      ITEM PRU        I;     # PRU NUMBER                              #
      ITEM STX        I;     # INDEX INTO SWAP SEGMENT TABLE           #
      ITEM WL         I;     # WORD LENGTH OF TABLE                    #
      ITEM WSA        I;     # ADDRESS OF WORKING STORAGE              #
      ITEM XCST       I;     # INDEX INTO THE SWAP SEG TABLE FOR CST   #
      ITEM XRSB       I;     # INDEX INTO THE SWAP SEG TABLE FOR RSB   #
  
      BASED ARRAY DUMMY;; 
  
  
  
#     B E G I N   D B $ C L S E   E X E C U T A B L E   C O D E .      #
  
  
 #
* 
* DC  DESCRIPTION 
* 
*     THIS ROUTINE HAS BEEN COMPOSED OF PORTIONS OF DB$TQTD, DB$CLSA
*     AND DB$SWI. 
* 
*     IT RESIDES IN AN OVERLAY AND USES THE OVERLAY RESIDENCE AREA
*     TO READ THE RSB AND CST TABLES. 
*     IF THERE IS NOT ENOUGH SPACE, THESE TABLES ARE READ IN A PIECE
*     AT A TIME.
* 
*     BECAUSE IT RESIDES IN AN OVERLAY, IT CAN NOT BE INTERRUPTED.
*     FOR THAT REASON, IT DOES NOT DO ANY JOURNAL LOGGING.
* 
 #
  
      CONTROL IFGR DFFLOP,0;
        DB$FLOP("CLSE");
      CONTROL ENDIF;
  
      GAPCST =0;
      GAPRSB =0;
      FETLOC = LOC(DB$RNFT);
 #
*     DETERMINE IF THE RSB OR CST (OR BOTH) IS SWAPPED OUT. 
*     FOR EACH THAT IS SWAPPED OUT, SEARCH THE SWAP TABLE FOR THE 
*     SPECIFIED PRU NUMBER. 
*       IF FOUND, RECORD THE INDEX INTO THE SWAP SEGMENT TABLE. 
*       IF NOT FOUND, ABORT CDCS. 
 #
      XRSB = 0; 
      IF TQRSB[0] LS 0
      THEN
        BEGIN 
        PRU = -TQRSB[0];
        FOR STX = 1 STEP 1 UNTIL SWPTC
        DO
          BEGIN 
          IF PRU EQ SWPN[STX] 
          THEN                     # THE ENTRY IS FOUND                #
            BEGIN 
            XRSB = STX; 
            END 
          END 
        IF XRSB EQ 0
        THEN
          BEGIN 
          DB$PUNT("DB$CSLE 1");    # THE ENTRY WAS NOT FOUND.  ABORT.  #
          END 
        END 
  
      XCST = 0; 
      P<ASL> = TQASL[0];
      IF ASCSTLOC[0] LS 0 
      THEN
        BEGIN 
        PRU = -ASCSTLOC[0]; 
        FOR STX = 1 STEP 1 UNTIL SWPTC
        DO
          BEGIN 
          IF PRU EQ SWPN[STX] 
          THEN                     # THE ENTRY IS FOUND                #
            BEGIN 
            XCST = STX; 
            END 
          END 
        IF XCST EQ 0
        THEN
          BEGIN 
          DB$PUNT("DB$CSLE 2");    # THE ENTRY WAS NOT FOUND.  ABORT.  #
          END 
        END 
      ELSE
        BEGIN 
        P<CSFIXED> = ASCSTLOC[0]; 
        END 
 #
*     DEFINE THE BUFFER AREAS INTO WHICH THE RSB AND CST TABLES CAN 
*     BE READ.
*     THE AREA BETWEEN THE END OF THE OVERLAY AND HIGHEST HIGH ADDRESS
*     IS AVAILABLE FOR THIS USE.
*     DB$OVBF IS PLACED AT THE END OF THE OVERLAY TO RESERVE A MINIMUM
*     FOR THIS USE. 
 #
      CMMSDA(DB$HHAE);       # RESPECIFY THE DYNAMIC AREA TO HHA       #
  
      IF XCST NQ 0  AND  XRSB NQ 0
      THEN
        BEGIN 
        LIMCST = DB$HHAE -1;
        P<CSFIXED> = (LOC(DB$OVBF) + LIMCST) / 2; 
        P<RSB> = LOC(DB$OVBF);
        LIMRSB = LOC(CSFIXED) -1; 
        END 
      ELSE
        BEGIN 
        IF XRSB NQ 0
        THEN
          BEGIN 
          LIMRSB = DB$HHAE -1;
          P<RSB> = LOC(DB$OVBF);
          END 
        IF XCST NQ 0
        THEN
          BEGIN 
          LIMCST = DB$HHAE -1;
          P<CSFIXED> = LOC(DB$OVBF);
          END 
        END 
 #
*     IF IT IS SWAPPED, READ THE RSB FROM THE SWAP TABLE. 
 #
      IF XRSB NQ 0
      THEN
        BEGIN 
  
        CONTROL IFGR DFFLOP,0;
          DB$FLOP("CLSE-R1"); 
        CONTROL ENDIF;
  
        WSA = LOC(RSB);            # WORKING STORAAGE ADDRESS          #
        WL = LIMRSB - WSA;         # WORD LENGTH OF AVAILABLE BUFFER   #
        PRU = SWPN[XRSB];          # PRU NUMBER                        #
        DB$RNRD(FETLOC,WSA,WL,PRU); 
        END 
 #
*     IF IT IS SWAPPED, READ THE CST FROM THE SWAP TABLE. 
 #
      IF XCST NQ 0
      THEN
        BEGIN 
  
        CONTROL IFGR DFFLOP,0;
          DB$FLOP("CLSE-R2"); 
        CONTROL ENDIF;
  
        WSA = LOC(CSFIXED);        # WORKING STORAAGE ADDRESS          #
        WL = LIMCST - WSA;         # WORD LENGTH OF AVAILABLE BUFFER   #
        PRU = SWPN[XCST];          # PRU NUMBER                        #
        DB$RNRD(FETLOC,WSA,WL,PRU); 
        END 
  
 #
* 
*     IF THE SCHEMA HAS NOT BEEN PLACED IN DOWN STATUS BECAUSE OF AN
*     INTERNAL ERROR, CLOSE ALL OF THE OPEN AREAS.
* 
 #
      IF SASCHST[SALX] NQ S"ERRDOWN"
      THEN
        BEGIN 
        DB$FLSH;
 #
*       IF QRF LOGGING IS ACTIVE, TAKE A QRF RECOVERY POINT.
 #
        IF SAQRFPTR[SALX] NQ 0
        THEN
          BEGIN 
          RPNUM = RPNUM +1; 
          DB$QRP(RPNUM);   # RESET THE QRF                           #
          END 
 #
*       CHECK WHETHER ART MUST BE WRITTEN TO TRF BEFORE RELEASING LOCKS 
*       HELD BY THIS RUNUNIT. 
 #
        IF RCWART[0]               # IF ART MUST BE WRITTEN TO TRF     #
        THEN
          BEGIN 
          DB$WART;                 # WRITE ART TO TRF                  #
          END 
 #
*       LOOP THRU ALL THE AREAS FOR THIS USER.
 #
        AREAOFFSET = DFRSBFIX;
        FOR AREAORD = 1 STEP 1 UNTIL CSFARENO[0]
        DO
          BEGIN 
          P<RSARBLK> = P<RSB> + AREAOFFSET; 
          P<OFT> = RSAROFIT[0]; 
 #
*         CLOSE AREA IF OPEN. 
 #
          IF RSARFPT[0] NQ 0
          THEN
            BEGIN 
            FPFTEX[0] = DFFTEX0;   # DO NOT EXECUTE DB PROCS ON ERROR  #
            CLOSE;
            END 
 #
*         IF LAST USER OF OFT THEN DO OFT RELEASE PROCESSING--
*           RELEASE INTERNAL FILE TABLE (IFT) 
*           CHECK FOR CHANGE IN OFT STATUS
*           RETURN FILE IF NOT RETAINED.
 #
          IF P<OFT> NQ 0 THEN 
            BEGIN 
            OFUSERS[0] = OFUSERS[0] - 1;
            RSAROFIT[0] = 0;       # CLEAR THE OFT POINTER             #
            IF OFUSERS [0] EQ 0 
            THEN
              BEGIN 
              DB$OFTR;             # OFT RELEASE PROCESSOR.            #
              END 
            END 
          AREAOFFSET = AREAOFFSET + DFARECON; 
 #
*         IF THE NEXT AREA CONTROL BLOCK IS NOT ENTIRELY WITHIN THE 
*         RESIDENT PORTION OF THE RSB, READ IN THE NEXT PORTION.
 #
          IF XRSB NQ 0
            AND  AREAOFFSET + DFARECON   GR   LIMRSB - LOC(RSB) 
          THEN
            BEGIN 
  
            CONTROL IFGR DFFLOP,0;
              DB$FLOP("CLSE-R3"); 
            CONTROL ENDIF;
  
            WSA = LOC(RSB) + DFRSBFIX;
            WL = LIMRSB - WSA;
            OLDGAP = GAPRSB;
            PRU = (GAPRSB + AREAOFFSET -1) / 64;
            GAPRSB = (PRU * 64) - DFRSBFIX; 
            AREAOFFSET = AREAOFFSET + OLDGAP - GAPRSB;
            PRU = PRU + SWPN[XRSB]; 
            DB$RNRD(FETLOC,WSA,WL,PRU); 
            END 
          END 
 #
*       RELEASE THE RSB SWAP FILE BLOCK OR
*       RELEASE THE RSB IF THERE WAS ONE IN CENTRAL MEMORY. 
* 
*                                  NOTE --
*                                  IF A SWAPPED OUT RSB HAS AN FKL
*                                  SWAPPED OUT SEPARATELY, THE FKL IS 
*                                  ABANDONED AND LEFT ON THE SWAP FILE. 
* 
*                                  THIS MUST BE FIXED LATER.
 #
        IF XRSB NQ 0
        THEN
          BEGIN 
                                   # SQUEEZE OUT THE SWAP TABLE ENTRY  #
          FOR STX = XRSB STEP 1 UNTIL SWPTC 
          DO
            BEGIN 
            SWWORD[STX] = SWWORD[STX+1];
            END 
  
          SWPTC = SWPTC-1;         # REDUCE THE SWAP TABLE ENTRY COUNT #
          END 
        ELSE
          BEGIN 
          DB$MFF(TQRSB[0]); 
          END 
        TQRSB[0] = 0; 
        TQSWPF[0] = FALSE;
        END 
  
  
  
  
  
  
#**********************************************************************#
#                                                                      #
#     I N T E R N A L   P R O C E D U R E   -   C L O S E              #
#                                                                      #
#**********************************************************************#
  
      PROC CLOSE; 
      BEGIN 
 #
*     DELETE LOCK ON AREA.
 #
      DB$LOKD(TRUE);
      P<OFT> = RSAROFIT[0]; 
 #
*     IF THIS CLOSURE REDUCES THE NUMBER OF FITS THAT SHOULD BE USED
*     CLOSE AND RETURN THE EXCESS NUMBER OF FITS. 
 #
      OFOPENS[0] = OFOPENS[0] - 1;
      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("CLSE-CF"); 
        CONTROL ENDIF;
  
        CLOSEM(DUMMY,O"04052400000000000000",DB$RA0); 
 #
*       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     #
          DB$LNKD(P<UFT>);
          END 
        ELSE
          BEGIN 
          UFWORD[0] = DFNPTR; 
          END 
        END 
  
      P<UFT> = LOC(OFUFT);
 #
*         IF THE NEXT AREA WORK BLOCK IS NOT ENTIRELY WITHIN THE
*         RESIDENT PORTION OF THE CST, READ IN THE NEXT PORTION.
 #
      CSAROFFSET = RSARCSTP[0] - GAPCST;
      IF XCST NQ 0
        AND  CSAROFFSET + 6  GR   LIMCST - LOC(CSFIXED) 
      THEN
        BEGIN 
  
        CONTROL IFGR DFFLOP,0;
          DB$FLOP("CLSE-R4"); 
        CONTROL ENDIF;
  
        WSA = LOC(CSFIXED) + DFCSTFIX;
        WL = LIMCST - WSA;
        PRU = (RSARCSTP[0] -1) / 64;
        GAPCST = (PRU * 64) - DFCSTFIX; 
        CSAROFFSET = RSARCSTP[0] - GAPCST;
        PRU = PRU + SWPN[XCST]; 
        DB$RNRD(FETLOC,WSA,WL,PRU); 
        END 
  
      P<CSAREBLK> = LOC(CSFIXED) + CSAROFFSET;
 #
*     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("CLSE-D1"); 
          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("CLSE-D2"); 
          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("CLSE-D3"); 
          CONTROL ENDIF;
  
          DB$DBPU (APWORD0[0],LOC(APDBPNAM[APLX])); 
          END 
        END 
 #
 #
      DB$LNKD(P<UFT>);
      P<FPT> = DFNPTR;
      P<UFT> = DFNPTR;
      RETURN; 
      END                    # CLOSE #
  
      END                    #DB$CLSE#
      TERM
