*DECK DB$QRFA 
USETEXT CDCSCTX 
      PROC DB$QRFA( ERRBLKA );
      BEGIN 
 #
* *   DB$QRFA - APPLY QRF TO A DATABASE          PAGE  1
* *   D E TRIGLIA/W P CEAGLIO                    DATE  01/27/81 
* *   BOB MCALLESTER                             DATE  12/20/84 
* 
* DC  PURPOSE 
* 
*     READ THE BLOCKS SAVED ON THE QUICK RECOVERY FILE AND WRITE THEM 
*     ON THE APPROPRIATE DATABASE AREAS, RESTORING THE DATABASE TO THE
*     LAST RECOVERY POINT.
* 
* DC  ENTRY CONDITIONS
* 
* D   PARAMETERS
# 
      ITEM ERRBLKA      I;   # ADDRESS OF ERROR STATUS BLOCK           #
# 
* D   ASSUMPTIONS 
* 
*     SALX IS SET.
*     SAL 
*       SAQRFPTR   CONTAINS POINTER TO QRF TABLE
*     QRF IS ATTACHED.
*     P<RCB> SET FOR AN AVAILABLE RCB.
* 
* DC  EXIT CONDITIONS 
* 
*     NORMAL   - THE CONTENTS OF THE QRF HAVE BEEN APPLIED TO THE 
*                DATABASE AND THE QRF IS REINITIALIZED. 
* 
*     ABNORMAL - INFORMATION IN THE STATUS BLOCK IS RETURNED FOR THE
*                FOLLOWING ERROR CONDITIONS:  
*                  1)  I/O ERROR READING THE QRF. 
*                  2)  SCHEMA IDENTIFIER MISMATCH ON QRF. 
*                  3)  QRF NOT EMPTIED BECAUSE OF BAD FILE. 
*                  4)  I/O ERROR ON APPLYING BLOCK TO DATABASE. 
* 
*     IF AN ERROR INVOLVING THE QRF OCCURRED, THE SCHEMA IS PLACED IN 
*     *ERRDOWN* STATUS.  IF AN ERROR OCCURRED INVOLVING AN AREA OF THE
*     DATABASE, THE AREA IS PLACED IN *ERRDOWN* STATUS. 
* 
* DC  CALLING ROUTINES
* 
*     DB$CARS      AUTO-RECOVERY CONTROL ROUTINE
* 
* DC  CALLED ROUTINES 
# 
      XREF FUNC DB$ACAI B;         # ATTACH AND CHECK AREA AND INDEX   #
      XREF FUNC DB$CDEC C(10);     # CONVERT INTEGER TO DISPLAY DECIMAL#
      XREF FUNC DB$COCT C(10);     # CONVERT INTEGER TO DISPLAY OCTAL  #
      XREF PROC DB$DRAR;           # DOWN AND RETURN AREA              #
      XREF PROC DB$FLOP;           # RECORD A FLOW POINT               #
      XREF PROC DB$IOBR;           # BACK SPACE ONE RECORD             #
      XREF PROC DB$IOBS;           # BACK SPACE ONE PRU                #
      XREF PROC DB$IORD;           # ISSUE CIO READ                    #
      XREF PROC DB$IORE;           # READ QRF, POSITION AT NEXT PRU    #
      XREF PROC DB$IORW;           # ISSUE CIO REWIND                  #
      XREF PROC DB$IOWR;           # ISSUE CIO (RE)WRITE               #
      XREF FUNC DB$LNK;            # LINK NEW ENTRY INTO BLOCK TABLE   #
      XREF PROC DB$LNKD;           # DELINK CMM BLOCK FROM CHAIN       #
      XREF PROC DB$MBA;            # ALLOCATE TEMPORARY CMM BLOCK      #
      XREF PROC DB$MBF;            # RELEASE TEMPORARY CMM BLOCK       #
      XREF PROC DB$MSG;            # MESSAGE TO DAYFILE                #
      XREF PROC DB$PUNT;           # CDCS INTERNAL ERROR               #
      XREF PROC DB$QRP;            # INITIALIZE THE QRF                #
      XREF PROC DB$RCLL;           # REQUEST RECALL                    #
      XREF PROC DB$RNRW;           # DO A RANDOM REWRITE               #
      XREF FUNC DB$ROLI B;         # READ FROM THE ROLL OUT FILE       #
      XREF FUNC DB$ROLO B;         # WRITE TO THE ROLL OUT FILE        #
# 
* 
* DC  INTERNAL PROCS/FUNCS
* 
*     APPLYBLOCK   APPLY CRM BLOCK TO DATA OR INDEX FILE
*     ATTACHAREA   ATTACH DATA AND INDEX FILES
*     FINDFILE     LOCATE FILE IN PF TABLE
*     RELEASEFETS  RELEASE AREA AND INDEX FILE FETS 
* 
* DC  NON-LOCAL VARIABLES MODIFIED
* 
*     OFT (ALL FIELDS VIA DB$ACAI)
* 
*     SAL 
*       SASCHST 
* 
*     QRF TABLE 
* 
*     DB$MFPA - MEMORY OVERFLOW OWNCODE ADDRESS 
* 
* DC  DESCRIPTION 
* 
*     -  INITIALIZE STATUS WORD TO ZERO.
* 
*     -  READ THE QRF HEADER.  IF IT IS EMPTY, POSITION THE QRF FOR 
*        WRITING, AND RETURN TO THE CALLER. 
* 
*     -  CHECK THAT THE SCHEMA ID RECORDED IN THE QRF HEADER MATCHES
*        THE ID IN THE CURRENT SAL ENTRY.  IF NOT, THEN ISSUE AN ERROR
*        AND PLACE THE SCHEMA IN A *DOWN* STATUS. 
* 
*     -  ALLOCATE BUFFERS FOR QRF I/O AND INTERNAL TABLES. INITIALIZE 
*        THE PERMANENT FILE TABLE.
* 
*     -  READ THE REMAINDER OF THE QRF UNTIL END-OF-INFORMATION.  FOR 
*        EACH RECORD (BLOCK), DO THE FOLLOWING: 
* 
*        *  IF EOI OCCURRED ON THE QRF, SET *DONE* FLAG.
*        *  IF AN I/O ERROR OCCURRED ON THE QRF, SET ERROR INDICATOR
*           AND SET *DONE* FLAG.
*        *  SEARCH THE PERMANENT FILE TABLE *PFTABLE* FOR THE ENTRY 
*           CORRESPONDING TO THIS QRF BLOCK.  IF NONE, CREATE NEW 
*           ENTRY.
*        *  ATTACH THE AREA AND ITS INDEX IF NECESSARY.  IF THERE IS
*           AN ATTACH ERROR, MARK THE AREA AS *BAD* IN THE AREA TABLE.
*           ALLOCATE FETS FOR THE AREA AND INDEX FILE OPERATIONS IF 
*           NECESSARY.
*        *  APPLY THE BLOCK TO THE DATABASE.  IF AN ERROR OCCURS, DOWN
*           AREA. 
* 
*     -  AT EOI ON THE QRF, RELEASE FETS AND BUFFERS. 
* 
*     -  REINITIALIZE THE QRF IF THERE WERE NO ERRORS.
* 
 #
  
  
#     NON-LOCAL VARIABLES REFERENCED                                   #
  
  
      XREF ARRAY DB$RNFT;          # SKELETON FET FOR RANDOM I/O       #
        ITEM RNFTWD U(0,0,60);
  
      XREF ITEM DB$FWAR;           # FIRST WORD ADDRESS FOR ROLL OUT   #
      XREF ITEM DB$LWAR;           # LAST WORD ADDRESS FOR ROLL OUT    #
      XREF ITEM DB$MFPA;           # MEMORY OVERFLOW OWNCODE ADDRESS   #
      XREF ITEM DB$TARN;           # ID NUMBER OF AREA BEING TERMINATED#
      XREF ITEM DB$TARV C(7);      # VERSION OF AREA BEING TERMINATED  #
      XREF ITEM CRMRC I;           # CRM RECALL COUNT                  #
  
#     LOCAL DEFS                                                       #
  
      DEF DFBLKTBSZ #3#;           # SIZE (WORDS) OF BLOCK TABLE ENTRY #
      DEF DFEOP #O"31"#;           # END OF PARTITION CODE             #
      DEF DFEOR #O"21"#;           # END OF RECORD                     #
      DEF DFPFTENSZ #6#;           # PF TABLE ENTRY SIZE (WORDS)       #
      DEF DFRANDFETLN #8#;         # LENGTH OF FET FOR RANDOM FILE     #
  
#**********************************************************************#
  
#     LOCAL VARIABLES                                                  #
  
      ITEM AREAID    I;            # AREA IDENTIFIER FROM QRF BLOCK    #
      ITEM BLOCKPTR     I;         # START OF CHAIN FOR BLOCK TABLE    #
      ITEM BUFLEN       I;         # LENGTH OF I-O BUFFER              #
      ITEM DOWNSCH      B;         # AT LEAST ONE AREA BAD             #
                                   #     - DOWN THE SCHEMA             #
      ITEM FETLOC       U;         # TEMPORARY STORAGE OF QFFET        #
      ITEM FIRSTBLOCK   B;         # WHILE PROCESSING THE FIRST BLOCK  #
      ITEM FOUND        B;         # FOR TABLE SEARCH                  #
      ITEM GOODBLID     I;         # GOOD BLOCK (CURRENT) IDENTIFIER   #
      ITEM INDEX        I;         # LOOP INDEX                        #
      ITEM LENGTH       I;         # LENGTH OF DATA IN BUFFER          #
      ITEM LONGBLOCK    B;         # BLOCK READ IS LONGER THAN BUFFER  #
      ITEM MAXARID      I;         # MAXIMUM LEGAL AREA ID FOR SCHEMA  #
      ITEM MFPASAVE     U;         # SAVE MEMORY OVERFLOW OWNCODE      #
      ITEM AREAMSG1  C(52) =
               "  AREA ID = 0000, LAST CLOSED DDDDDDDDDDTTTTTTTTTT: ";
      ITEM AREAMSG2  C(52) =
               "    DATE/TIME FROM QRF FSTT   DDDDDDDDDDTTTTTTTTTT: ";
      ITEM AREAMSG3  C(50) =
               "  AREA ID = 0000, QRF BLOCK PRU 1 IS NOT AN FSTT:"; 
      ITEM AREAMSG4  C(40) =
               "  AREA ID = 0000,  PRU NUMBER NNNNNNN:";
      ITEM PRUNUM       I;         # PRU NUMBER FOR WRITING DATA FILE  #
      ITEM VERSION      C(7);      # VERSION NAME OF FILE              #
      ARRAY FSTTBUF S(128); 
        BEGIN 
        ITEM FSTIME      C(05,00,10);  # TIME LAST CLOSED              #
        ITEM FSDATE      C(06,00,10);  # DATE LAST CLOSED              #
        ITEM FSBLKSIZ    U(15,42,18);  # BLOCK SIZE OF FILE            #
        END 
  
      BASED ARRAY BLOCKTBL S(DFBLKTBSZ); # TABLE OF APPLIED BLOCKS     #
        BEGIN 
        ITEM BLOCKPRIOR U(00,24,18);   # PRIOR ENTRY IN CHAIN          #
        ITEM BLOCKNEXT  U(00,42,18);   # NEXT ENTRY IN CHAIN           #
        ITEM BLOCKCTL0  U(01,00,60);   # COPIED FROM QRF BLOCK         #
        ITEM BLOCKCTL1  U(02,00,60);   # COPIED FROM QRF BLOCK         #
        END 
  
  
  
      ITEM PFTPTR    I;            # START OF CHAIN FOR PF TABLE       #
  
      BASED ARRAY PFTABLE S(DFPFTENSZ);  # TABLE OF ACTIVE PERM FILES  #
        BEGIN 
        ITEM PTPRIOR    U(00,24,18);   # PRIOR ENTRY IN CHAIN          #
        ITEM PTNEXT     U(00,42,18);   # NEXT ENTRY IN CHAIN           #
        ITEM PTBLKSIZ   U(00,06,18);   # BLOCK SIZE OF FILE            #
        ITEM PTAREAWD   U(01,00,60);   # AREA (FILE) WORD              #
        ITEM PTATTACH   B(01,00,01);   # TRUE IF AREA + INDEX ATTACHED #
        ITEM PTAREABAD  B(01,01,01);   # TRUE IF AREA FATAL ERROR      #
        ITEM PTAREADN   B(01,02,01);   # TRUE IF AREA DOWNED           #
        ITEM PTAREAOLD  B(01,03,01);   # TRUE IF AREA OLDER THAN QRF   #
        ITEM PTAREAFET  I(01,42,18);   # LOCATION OF FET FOR AREA      #
        ITEM PTINDEXWD  U(02,00,60);   # INDEX WORD                    #
        ITEM PTINDEXFET I(02,42,18);   # LOCATION OF FET FOR INDEX FILE#
        ITEM PTVERSWD   U(03,00,60);   # VERSION WORD                  #
        ITEM PTPVENAME  C(03,00,07);   # PRIMARY VERSION NAME          #
        ITEM PTAREAID   U(03,48,12);   # AREA ID                       #
        ITEM PTTIME     C(04,00,10);   # TIME LAST CLOSED              #
        ITEM PTDATE     C(05,00,10);   # DATE LAST CLOSED              #
        END 
  
*CALL QRCTLDCLS 
  
      BASED ARRAY QH;              # FOR READING THE QRF HEADER        #
        BEGIN 
*CALL QRHEDDCLS 
        END 
*CALL QRTABDCLS 
  
      ITEM QRFDONE;                # LOOP INDEX                        #
  
*CALL SRERRDCLS 
  
      BASED ARRAY WSA;             # WORKING STORAGE FOR QRF BLOCKS    #
        BEGIN 
        ITEM WSAAMLOGO   C(01,00,05);  # AAM FILE LOGO                 #
        ITEM WSTIME      C(05,00,10);  # TIME LAST CLOSED              #
        ITEM WSDATE      C(06,00,10);  # DATE LAST CLOSED              #
        END 
  
  
  
  
#**********************************************************************#
#                                                                      #
#     I N T E R N A L   P R O C E D U R E   -   A P P L Y B L O C K .  #
#                                                                      #
#**********************************************************************#
  
      PROC APPLYBLOCK;
      BEGIN 
 #
* *   DB$QRFA                                    PAGE  1
* *   APPLYBLOCK - WRITE BLOCK TO DATABASE
* *   W P CEAGLIO                                DATE  01/29/81 
* 
* DC  PURPOSE 
* 
*     APPLY A QRF BLOCK (ONE OR MORE PRUS) TO AN AREA OR INDEX FILE 
*     IN A DATABASE.
* 
* DC  ENTRY CONDITIONS
* 
* D   PARAMETERS
* 
*     NONE. 
* 
* D   ASSUMPTIONS 
* 
*     P<PFTABLE> POINTS TO APPLICABLE ENTRY IN THE PF TABLE.
*     THE AREA AND INDEX FILES ARE ALREADY ATTACHED AND THE FETS ARE
*     ARE SETUP.
*     THE QRF BLOCK HAS BEEN READ INTO CMM AT ADDRESS *WSA*.
* 
* DC  EXIT CONDITIONS 
* 
*     NORMAL   - IF QRF BLOCK PREVIOUSLY APPLIED, THEN AN IMMEDIATE 
*                RETURN IS MADE.  FOR A NEW BLOCK, THE CONTROL WORDS
*                ARE ADDED TO THE QRF BLOCK CHAIN *BLOCKTBL*.  THE QRF
*                BLOCK IS APPLIED TO EITHER THE AREA OR INDEX FILE. 
* 
*     ABNORMAL - IF AN I/O ERROR OCCURS ON REWRITING THE AREA OR INDEX
*                FILE, THE *BAD FILE* FLAG IS SET IN THE PF TABLE ENTRY.
* 
* DC  CALLING ROUTINES
* 
*     DB$QRFA - MAIN PROCEDURE
* 
* DC  CALLED ROUTINES 
* 
*     DB$LNK       LINK NEW ENTRY INTO QRF BLOCK CHAIN
*     DB$RNRW      CIO RANDOM REWRITE PROCESSOR 
* 
* DC  DESCRIPTION 
* 
*     -  SEARCH THE QRF BLOCK TABLE TO SEE IF THE BLOCK HAS BEEN
*        PREVIOUSLY APPLIED. IF IT HAS, RETURN TO THE CALLER. 
* 
*     -  ADD THE CONTROL WORDS FOR THE NEW BLOCK TO THE BLOCK TABLE.
* 
*     -  SET FET POINTER FOR AREA OR INDEX FILE DEPENDING ON BLOCK
*        TYPE IN QRF CONTROL WORDS. 
* 
*     -  PERFORM CIO REWRITE OF INDICATED FILE (WITH RECALL).  IF AN
*        ERROR OCCURS, SET *BAD* FLAG IN PERMANENT FILE TABLE *PFTABLE*.
* 
 #
  
  
# S T A R T   O F   A P P L Y B L O C K   E X E C U T A B L E  C O D E #
  
  
  
      CONTROL IFGR DFFLOP,0;
        XREF FUNC DB$CDEC C(10);
        XREF FUNC DB$COCB C(10);
        XREF PROC DB$FLUI;
        ITEM QRFFLOP C(7);
        ITEM QRFFLO2 C(7);
  
        QRFFLOP = "AID000 ";
        C<3,3>QRFFLOP = DB$CDEC(QCAID[0],3);
        QRFFLO2 = DB$COCB(B<3,21>QCPRUN[0],7);
        IF QCINDEXF[0]
        THEN
          BEGIN 
          C<6,1>QRFFLOP = "X";
          END 
        DB$FLOP("QRFA-AB");            # APPLY BLOCK - FLOW POINT      #
        DB$FLUI(QRFFLOP);              # AREA ID                       #
        DB$FLUI(QRFFLO2);              # PRU NUMBER                    #
      CONTROL ENDIF;
  
#   SEARCH THE QRF BLOCK TABLE TO DETERMINE IF THE BLOCK HAS BEEN      #
#     PREVIOUSLY APPLIED.  IF IT HAS, RETURN TO CALLER.                #
  
      P<BLOCKTBL> = LOC(BLOCKPTR);
      FOR BLOCKPTR=BLOCKPTR 
        WHILE BLOCKNEXT[0] NQ 0 
      DO
        BEGIN 
        P<BLOCKTBL> = BLOCKNEXT[0]; 
        IF BLOCKCTL0[0] EQ QCWORD0[0] 
          AND BLOCKCTL1[0] EQ QCWORD1[0]
        THEN
          BEGIN 
  
          CONTROL IFGR DFFLOP,0;
            DB$FLOP("QRFA-SK");        #  SKIP BLOCK - FLOW POINT      #
          CONTROL ENDIF;
  
          RETURN; 
  
          END 
        END 
  
#     ADD THE CONTROL WORDS FOR THE NEW BLOCK TO THE BLOCK TABLE.      #
  
      P<BLOCKTBL> = DB$LNK(LOC(BLOCKPTR),DFBLKTBSZ);
      BLOCKCTL0[0] = QCWORD0[0];
      BLOCKCTL1[0] = QCWORD1[0];
  
#     SET THE FET POINTER FOR THE AREA OR INDEX FILE DEPENDING ON THE  #
#     BLOCK TYPE IN THE QRF CONTROL WORDS.                             #
  
      IF QCINDEXF[0]               # IF INDEX FILE BLOCK,...           #
      THEN
        BEGIN 
        P<FET> = PTINDEXFET[0]; 
        END 
      ELSE                         # OTHERWISE, AREA FET...            #
        BEGIN 
        P<FET> = PTAREAFET[0];
        END 
  
      PRUNUM = QCPRUN[0]; 
  
#     IF THE BLOCK THAT IS TO BE WRITTEN IS THE FSTT,                  #
#       CHECK FOR THE "SAAM/" LOGO AND A VALID DATE/TIME STAMP         #
  
      IF PRUNUM EQ 1
      THEN
        BEGIN 
        IF WSAAMLOGO[0] NQ "SAAM/"
        THEN
          BEGIN 
          C<12,04>AREAMSG3 = DB$CDEC(PTAREAID[0],4);
          DB$MSG(AREAMSG3); 
          PTAREABAD[0] = TRUE;
          RETURN; 
  
          END 
        IF PTDATE[0] LS WSDATE[0] 
          OR (PTDATE[0] EQ WSDATE[0] AND PTTIME[0] LS WSTIME[0])
        THEN
          BEGIN 
          C<12,04>AREAMSG1 = DB$CDEC(PTAREAID[0],4);
          C<30,10>AREAMSG1 = PTDATE;
          C<40,10>AREAMSG1 = PTTIME;
          C<30,10>AREAMSG2 = WSDATE;
          C<40,10>AREAMSG2 = WSTIME;
          DB$MSG(AREAMSG1); 
          DB$MSG(AREAMSG2); 
          DB$MSG("    RECOVERED FILE DOES NOT MATCH THE QRF FILE:");
          DB$MSG("    BLOCK IMAGES WILL NOT BE APPLIED:");
          PTAREAOLD[0] = TRUE;
          RETURN; 
  
          END 
        END 
                         # FOR OTHER BLOCKS VALIDATE THE PRU NUMBER    #
      ELSE
        BEGIN 
        IF PRUNUM - (((PRUNUM -3) / PTBLKSIZ[0]) * PTBLKSIZ[0]) NQ 3
        THEN
          BEGIN 
          C<12,04>AREAMSG4 = DB$CDEC(PTAREAID[0],4);
          C<30,07>AREAMSG4 = DB$COCT(PRUNUM,7); 
          DB$MSG(AREAMSG4); 
          DB$MSG("    THAT PRU NUMBER IS NOT VALID ON THIS FILE:"); 
          PTAREABAD[0] = TRUE;
          RETURN; 
  
          END 
        END 
  
#     IF THE BLOCK THAT IS TO BE WRITTEN IS LONGER THAN THE AVAILABLE  #
#     BUFFER, COPY ONE BUFFER LOAD AT A TIME TO THE FILE.              #
  
      IF LONGBLOCK
      THEN
        BEGIN 
  
        CONTROL IFGR DFFLOP,0;
          DB$FLOP("QRFA-LB");          # LONG BLOCK - FLOW POINT       #
        CONTROL ENDIF;
  
        DB$IOBR(FETLOC);               # BACK SPACE OVER THE BLOCK     #
        DB$RCLL(FETLOC);
        IF FIRSTBLOCK                  # HANDLING THE FIRST BLOCK      #
        THEN
          BEGIN 
          DB$IORE(FETLOC,P<WSA>,DFPRUSIZ);  # SKIP PAST QRF HEADER     #
          DB$RCLL(FETLOC);
          END 
        DB$IORE(FETLOC,P<WSA>,BUFLEN);  # READ FIRST BUFFER LOAD       #
        DB$RCLL(FETLOC);
  
        FOR INDEX = INDEX WHILE QFFETST[0] LS DFEOR 
        DO
          BEGIN 
          CRMRC =0; 
          IF QFFETEC[0] NQ 0           # IF I/O ERROR...               #
          THEN
            BEGIN 
            SRENUMB[0] = DFSRENFUN; 
            SREFUNC[0] = DFSREFNIO; 
            SREFPAR[0] = QFFETEC[0];
            SREFTYP[0] = DFSREFTQR; 
            SASCHST[SALX] = S"ERRDOWN"; 
            QRFDONE = 1;
            RETURN; 
  
            END 
                             # WRITE THE CURRENT BUFFER LOAD           #
  
          LENGTH = QFFETIN[0] - QFFETOUT[0];
          DB$RNRW(P<FET>,P<WSA>,LENGTH,PRUNUM); 
          DB$RCLL(P<FET>);
          PRUNUM = PRUNUM + (LENGTH / DFPRUSIZ);
          IF FETNOSAT[0] NQ 0 
          THEN
            BEGIN 
            PTAREABAD[0] = TRUE;
            RETURN; 
  
            END 
  
                             # READ THE NEXT BUFFER LOAD               #
  
          DB$IORE(FETLOC,P<WSA>,BUFLEN);
          DB$RCLL(FETLOC);
          END 
  
        IF QFFETEC[0] NQ 0             # IF I/O ERROR...               #
        THEN
          BEGIN 
          SRENUMB[0] = DFSRENFUN; 
          SREFUNC[0] = DFSREFNIO; 
          SREFPAR[0] = QFFETEC[0];
          SREFTYP[0] = DFSREFTQR; 
          SASCHST[SALX] = S"ERRDOWN"; 
          QRFDONE = 1;
          RETURN; 
  
          END 
        END 
  
#     PERFORM A CIO REWRITE ON THE INDICATED FILE WITH RECALL.  IF AN  #
#     ERROR OCCURS, SET THE *BAD* FLAG IN THE *PFTABLE* ENTRY FOR THIS #
#     AREA.                                                            #
  
      DB$RNRW(P<FET>, P<WSA>, QFFETIN[0]-QFFETOUT[0]-2, PRUNUM);
      DB$RCLL(P<FET>);
      IF FETNOSAT[0] NQ 0 
      THEN
        BEGIN 
        PTAREABAD[0] = TRUE;
        END 
      RETURN; 
  
      END 
  
  
#**********************************************************************#
#                                                                      #
#     I N T E R N A L   P R O C E D U R E   -   A T T A C H A R E A .  #
#                                                                      #
#**********************************************************************#
  
      PROC ATTACHAREA;
      BEGIN 
 #
* *   DB$QRFA                                    PAGE  1
* *   ATTACHAREA - ATTACH DATABASE AREA AND INDEX FILE
* *   W P CEAGLIO                                DATE  02/01/81 
* 
* DC  PURPOSE 
* 
*     ATTACH A DATABASE AREA AND INDEX FILE . 
* 
* DC  ENTRY CONDITIONS
* 
*     PARAMETERS
* 
*     NONE. 
* 
* DC  ASSUMPTIONS 
* 
*     P<PFTABLE> POINTS TO APPLICABLE ENTRY IN THE PF TABLE.
*     P<QCCTLWD> POINTS TO THE BLOCK READ FROM THE QRF. 
* 
* DC  EXIT CONDITIONS 
* 
*     NORMAL   - AREA AND INDEX FILES HAVE BEEN ATTACHED.  THE *ATTACH* 
*                FLAG IN THE PFTABLE ENTRY IS SET *TRUE*. 
* 
*     ABNORMAL - AREA AND INDEX FILES COULD NOT BE ATTACHED.  THE *BAD* 
*                FILE FLAG IN THE PFTABLE ENTRY IS SET *TRUE*.
* 
* DC  CALLING ROUTINES
* 
*     DB$QRFA      MAIN PROCEDURE 
* 
* DC  CALLED ROUTINES 
* 
*     DB$ACAI      ATTACH AND CHECK AREA AND INDEX FILES
*     DB$MBA       ALLOCATE TEMPORARY CMM BLOCK 
* 
* 
* DC  NON-LOCAL VARIABLES MODIFIED
* 
*     NONE. 
* 
* DC  DESCRIPTION 
* 
*     -  IF CANNOT ATTACH AREA AND INDEX FILES, SET THE *BAD* FILE FLAG 
*        IN THE PFTABLE ENTRY AND RETURN. 
* 
*     -  ALLOCATE SPACE FOR THE FETS FOR THE AREA AND INDEX FILES AND 
*        INITIALIZE THEM FROM A MODEL FET.  RECORD POINTERS TO THE FETS 
*        IN THE PFTABLE ENTRY.
* 
*     -  SET THE *ATTACH* FLAG IN THE PFTABLE ENTRY TO *TRUE*.
* 
 #
  
# S T A R T   O F   A T T A C H A R E A   E X E C U T A B L E  C O D E #
  
#     IF CANNOT ATTACH AREA AND INDEX FILES, SET *BAD* FILE FLAG IN    #
#     PFTABLE ENTRY AND RETURN.                                        #
  
      IF NOT DB$ACAI(QCAID[0],QCVENAME[0],ERRBLKA)
      THEN
        BEGIN 
        PTAREABAD[0] = TRUE;
  
        RETURN; 
  
        END 
  
#     ALLOCATE SPACE FOR FETS FOR AREA AND INDEX FILES AND INITIALIZE  #
#     THEM FROM A MODEL FET.  RECORD POINTERS TO FETS IN PFTABLE ENTRY #
  
      DB$MBA(DFRANDFETLN,P<FET>); 
      FOR INDEX=DFRANDFETLN-1 STEP -1 
        UNTIL 0 
      DO
        BEGIN 
        FETLFNWD[INDEX] = RNFTWD[INDEX];
        END 
      FETLFNU[0] = OFFITLFN[0]; 
      PTAREAFET[0] = LOC(FET);
      IF OFFITXN[0] NQ 0
      THEN
        BEGIN 
        DB$MBA(DFRANDFETLN,P<FET>); 
        FOR INDEX=DFRANDFETLN-1 STEP -1 
          UNTIL 0 
        DO
          BEGIN 
          FETLFNWD[INDEX] = RNFTWD[INDEX];
          END 
        FETLFNU[0] = OFFITXN[0];
        PTINDEXFET[0] = LOC(FET); 
        END 
  
#     SET THE *ATTACH* FLAG IN THE PFTABLE ENTRY TO *TRUE*.            #
  
      PTATTACH[0] = TRUE; 
  
      P<FET> = PTAREAFET[0];
      DB$IORW(P<FET>);
      DB$RCLL(P<FET>);
      DB$IORD(P<FET>,LOC(FSTTBUF),127); 
      DB$RCLL(P<FET>);
      IF FETNOSAT[0] NQ 0 
      THEN
        BEGIN 
        PTAREABAD[0] = TRUE;
        RETURN; 
  
        END 
      PTDATE[0] = FSDATE[0];
      PTTIME[0] = FSTIME[0];
      PTBLKSIZ[0] = FSBLKSIZ[0];
  
      RETURN; 
  
      END 
  
  
#**********************************************************************#
#                                                                      #
#     I N T E R N A L   P R O C E D U R E   -   F I N D F I L E .      #
#                                                                      #
#**********************************************************************#
  
      PROC FINDFILE;
      BEGIN 
 #
* *   DB$QRFA                                    PAGE  1
* *   FINDFILE - FIND PF TABLE ENTRY FOR AN AREA/VERSION
* *   W P CEAGLIO                                DATE  01/29/81 
* 
* DC  PURPOSE 
* 
*     LOCATE THE ENTRY IN THE PF TABLE FOR A GIVEN AREA/VERSION.
* 
* DC  ENTRY CONDITIONS
* 
* D   PARAMETERS
* 
*     NONE. 
* 
* D   ASSUMPTIONS 
* 
*     PFTPTR CONTAINS THE START OF THE CHAIN OF ENTRIES.
*     P<QCCTLWD> POINTS TO THE BLOCK READ FROM THE QRF. 
* 
* 
* DC  EXIT CONDITIONS 
* 
*     IF AN EXISTING ENTRY IS FOUND, *FOUND* IS SET *TRUE*.  IF AN
*     ENTRY IS NOT FOUND, A NEW ENTRY IS LINKED INTO THE CHAIN AND IS 
*     INITIALIZED.
* 
* DC  CALLING ROUTINES
* 
*     DB$QRFA      MAIN PROCEDURE 
* 
* DC  CALLED ROUTINES 
* 
*     DB$LNK       LINK PF TABLE ENTRY INTO CHAIN 
* 
* DC  NON-LOCAL VARIABLES MODIFIED
* 
*     NONE. 
* 
* DC  DESCRIPTION 
* 
*     -  SEARCH THE PF TABLE FOR A MATCH ON AREA ID AND VERSION WITH
*        THE BLOCK READ FROM THE QRF.  IF A MATCH WAS FOUND, SET THE
*        *FOUND* FLAG TO *TRUE*.
* 
*     -  IF A MATCH WAS NOT FOUND, CREATE A NEW ENTRY AND LINK IT INTO
*        THE PF TABLE CHAIN.  INITIALIZE THE ENTRY. 
* 
 #
  
  
  
# S T A R T   O F   F I N D F I L E   E X E C U T A B L E   C O D E    #
  
  
#     SEARCH PF TABLE FOR MATCH ON AREA ID AND VERSION WITH THE BLOCK  #
#     READ FROM THE QRF.  IF FOUND A MATCH, SET *FOUND* FLAG *TRUE*.   #
  
      P<PFTABLE> = LOC(PFTPTR); 
      FOUND = FALSE;
      FOR INDEX=INDEX 
        WHILE PTNEXT[0] NQ 0
        AND NOT FOUND 
      DO
        BEGIN 
        P<PFTABLE> = PTNEXT[0]; 
        IF QCAID[0] EQ PTAREAID[0]
          AND QCVENAME[0] EQ PTPVENAME[0] 
        THEN
          BEGIN 
          FOUND = TRUE; 
          END 
        END 
  
#     IF A MATCH WAS NOT FOUND, CREATE A NEW ENTRY AND LINK IT INTO THE#
#     PF TABLE CHAIN.  INITIALIZE THE ENTRY.                           #
  
      IF NOT FOUND
      THEN
        BEGIN 
        P<PFTABLE> = DB$LNK(LOC(PFTPTR),DFPFTENSZ); 
        PTAREAWD[0] = 0;
        PTINDEXWD[0] = 0; 
        PTVERSWD[0] = 0;
        PTAREAID[0] = QCAID[0]; 
        PTPVENAME[0] = QCVENAME[0]; 
        END 
      RETURN; 
  
      END 
  
  
#**********************************************************************#
#                                                                      #
#     I N T E R N A L   P R O C E D U R E   -   M E M O V F L          #
#                                                                      #
#**********************************************************************#
  
      PROC MEMOVFL; 
      BEGIN 
 #
* *   DB$QRFA                                    PAGE 1 
* *   MEMOVFL - PROCESS CMM OVERFLOW ERRORS 
* *   M L BRANDENBURG                            DATE 06/01/81
* 
* DC  PURPOSE 
* 
*     PROCESS CMM OVERFLOW ERRORS 
* 
* DC  ENTRY CONDITIONS
* 
* D   PARAMETERS
* 
*     NONE
* 
* D   ASSUMPTIONS 
* 
*     DB$MFPA HAS BEEN SET TO THE ADDRESS OF THIS PROCEDURE 
*     AND CMM COULD NOT FIND SUFFICIENT MEMORY TO ALLOCATE. 
* 
* DC  EXIT CONDITIONS 
* 
*     ERROR NUMBER AND FUNCTION HAVE BEEN STORED IN SRERRBLK. 
*     SCHEMA IS SET TO "ERRDOWN". 
* 
* DC  CALLING ROUTINES
* 
*     DB$QRFA      MAIN PROCEDURE 
* 
* DC  CALLED ROUTINES 
* 
*     NONE
* 
* DC  NON-LOCAL VARIABLES MODIFIED
* 
*     SRENUMB - ERROR NUMBER
*     SREFUNC = FUNCTION
*     SASCHST - SCHEMA STATUS 
* 
* DC  DESCRIPTION 
* 
*     THE ERROR NUMBER AND FUNCTION CODE IS SET IN SERRBLK SO 
*     THAT AN ERROR MESSAGE CAN BE WRITTEN. 
*     THE SCHEMA IS SET TO "ERRDOWN". 
*     THE PROCEDURE EXITS BY GOING TO ENDQRFA SO THAT ONLY CLEANUP
*     IS PERFORMED AFTER THE MEMORY ERROR OCCURS. 
* 
 #
  
  
# B E G I N   M E M O V F L   E X E C U T A B L E   C O D E            #
  
  
#     STORE INFORMATION IN SRERRBLK FOR MESSAGE                        #
  
      SRENUMB[0] = DFSRENMEM;          # MEMORY ERROR                  #
      SREFUNC[0] = DFSREFNQA;          # FROM QRFA                     #
  
#     SET SCHEMA "DOWN".                                               #
  
      SASCHST[SALX] = S"ERRDOWN"; 
  
      GOTO ENDQRFA;                    # GO CLEANUP AND LEAVE          #
  
      END                              # END PROC MEMOVFL              #
  
  
#**********************************************************************#
#                                                                      #
#     I N T E R N A L   P R O C E D U R E   -   R E L E A S E F E T S .#
#                                                                      #
#**********************************************************************#
  
      PROC RELEASEFETS; 
      BEGIN 
 #
* *   DB$QRFA                                    PAGE  1
* *   RELEASEFETS - RELEASE AREA AND INDEX FILE FETS
* *   W P CEAGLIO                                DATE  02/14/81 
* 
* DC  PURPOSE 
* 
*     RELEASE ALL AREA AND INDEX FILE FETS. 
* 
* DC  ENTRY CONDITIONS
* 
* D   PARAMETERS
* 
*     NONE. 
* 
* D   ASSUMPTIONS 
* 
*     PFTPTR POINTS TO START OF PF TABLE CHAIN. 
* 
* DC  EXIT CONDITIONS 
* 
*     THE SPACE FOR THE FETS OF ATTACHED AREA AND INDEX FILES IS
*     RELEASED. 
* 
* DC  CALLING ROUTINES
* 
*     DB$QRFA      MAIN PROCEDURE 
* 
* DC  CALLED ROUTINES 
* 
*     DB$MBF       RELEASE SPACE FOR FET
* 
* DC  NON-LOCAL VARIABLES MODIFIED
* 
*     NONE. 
* 
* DC  DESCRIPTION 
* 
*     POINT TO THE START OF THE PF TABLE.  FOR EACH ENTRY FOR WHICH THE 
*     ATTACH FLAG IS *TRUE*, DO THE FOLLOWING:  
*       -  RELEASE THE AREA FET.
*       -  IF THE ENTRY SHOWS THAT AN INDEX FILE WAS ATTACHED, RELEASE
*          THE FET FOR THE INDEX FILE.
* 
 #
  
  
#  B E G I N   R E L E A S E F E T S   E X E C U T A B L E   C O D E   #
  
#**********************************************************************#
#                                                                      #
#     POINT TO START OF PF TABLE CHAIN.  FOR EACH TABLE ENTRY FOR WHICH#
#     THE ATTACH FLAG IS *TRUE*, DO THE FOLLOWING:                     #
#       -  RELEASE THE AREA FET.                                       #
#       -  IF THE ENTRY SHOWS THAT AN INDEX FILE WAS ATTACHED, RELEASE #
#          THE FET FOR THE INDEX FILE.                                 #
#                                                                      #
#**********************************************************************#
  
      P<PFTABLE> = LOC(PFTPTR); 
      FOR INDEX=INDEX 
        WHILE PTNEXT[0] NQ 0
      DO
        BEGIN 
        P<PFTABLE> = PTNEXT[0]; 
        IF PTATTACH[0]
        THEN
          BEGIN 
          P<FET> = PTAREAFET[0];
          DB$MBF(P<FET>); 
          IF PTINDEXFET[0] NQ 0 
          THEN
            BEGIN 
            P<FET> = PTINDEXFET[0]; 
            DB$MBF(P<FET>); 
            END 
          END 
        END 
      RETURN; 
  
      END 
  
#**********************************************************************#
#     E N D   O F   I N T E R N A L   P R O C E D U R E S              #
#**********************************************************************#
  
  
  
  
# S T A R T   O F   D B $ Q R F A   E X E C U T A B L E   C O D E      #
  
  
  
  
      CONTROL IFGR DFFLOP,0;
        DB$FLOP("QRFA");
      CONTROL ENDIF;
  
#**********************************************************************#
#                                                                      #
#     INITIALIZE STATUS WORD TO ZERO                                   #
#                                                                      #
#**********************************************************************#
  
      P<SRERRBLK> = ERRBLKA;
      SREWORD[0] = 0; 
  
#**********************************************************************#
#                                                                      #
#     READ THE QRF HEADER.                                             #
#                                                                      #
#**********************************************************************#
  
      P<QFT> = SAQRFPTR[SALX];
      FETLOC = LOC(QFFET[0]);          # SET LOC FOR FOLLOWING CALLS   #
      P<WSA> = FETLOC + DFFETLEN; 
      MFPASAVE = DB$MFPA;              # SAVE MEMORY OVERFLOW OPTION   #
      DB$MFPA = LOC(MEMOVFL);          # USE A LOCAL OVERFLOW OPTION   #
      BUFLEN = QFBUFL[0]; 
      IF BUFLEN LS O"202" 
      THEN
        BEGIN 
        BUFLEN = O"1002"; 
        DB$MBA(BUFLEN,P<WSA>);
        END 
      P<QH> = LOC(WSA); 
      DB$IORW(FETLOC);                 # REWIND                        #
      DB$RCLL(FETLOC);
      DB$IORD(FETLOC,P<QH>,DFPRUSIZ +1);  # READ HEADER                #
      DB$RCLL(FETLOC);
      IF QFFETEC[0] NQ 0               # IF I/O ERROR ON QRF...        #
      THEN
        BEGIN 
        SRENUMB[0] = DFSRENFUN;        # SET INFO IN ERROR BLOCK       #
        SREFUNC[0] = DFSREFNIO; 
        SREFPAR[0] = QFFETEC[0];
        SREFTYP[0] = DFSREFTQR; 
        SASCHST[SALX] = S"ERRDOWN"; 
        RETURN; 
  
        END 
  
#**********************************************************************#
#                                                                      #
#     IF THE QRF IS EMPTY, NO FURTHER PROCESSING NEEDED--RETURN TO     #
#      CALLER WITH OK STATUS.                                          #
#                                                                      #
#**********************************************************************#
  
      IF QFFETIN[0] - QFFETOUT[0] EQ DFPRUSIZ 
      THEN
        BEGIN 
        DB$QRP(0);                     # POSITION THE QRF FOR WRITING  #
        RETURN; 
  
        END 
  
#**********************************************************************#
#                                                                      #
#     INITIALIZE START POINTERS FOR TABLES.                            #
#                                                                      #
#**********************************************************************#
  
      BLOCKPTR = 0; 
      PFTPTR = 0; 
      DOWNSCH = FALSE;
      MAXARID = SASCNBAR[SALX];        # LAST ASSIGNED AREA NUMBER     #
      GOODBLID = QHGBID[0];            # SAVE GOOD BLOCK ID            #
  
      IF DB$TARN NQ 0 
      THEN                         # RECOVERING A SINGLE AREA          #
        BEGIN                      # SAVE THE QFT, FET AND BUFFER      #
        DB$FWAR = LOC(QFT); 
        DB$LWAR = FETLOC + DFFETLEN + QFBUFL[0] -1; 
        IF DB$ROLO                 # WRITE THE CURRENT QRF STATUS TO   #
        THEN                       # THE ROLL OUT FILE                 #
          BEGIN 
          DB$PUNT("DB$QRFA 1");    # I-O ERROR ON THE ROLL OUT FILE.   #
                                   # ABORT CDCS                        #
          END 
        END 
  
      FIRSTBLOCK = TRUE;
  
#**********************************************************************#
#                                                                      #
#     READ REMAINDER OF THE QRF UNTIL END-OF-INFORMATION.  FOR EACH    #
#     BLOCK READ, DO THE FOLLOWING:                                    #
#                                                                      #
#       *  IF THE BLOCK IS LONGER THAN THE BUFFER INTO WHICH IT WAS    #
#          READ, BACKSPACE TWO PRU'S AND REREAD THE END OF THE RECORD. #
#       *  IF END-OF-INFORMATION, SET FLAG TO TERMINATE READ.          #
#       *  IF AN I/O ERROR OCCURRED, COMPLETE THE ERROR STATUS BLOCK   #
#          AND SET FLAG TO TERMINATE READ.                             #
#       *  CHECK THE AREA IDENTIFIER IN THE BLOCK AGAINST THE MAXIMUM  #
#          FOR THE SCHEMA.  IF IT IS LARGER, COMPLETE THE ERROR STATUS #
#          BLOCK AND SET FLAG TO TERMINATE READ.                       #
#       *  USING THE AREA ID AND VERSION FROM THE BLOCK, LOCATE THE PF #
#          TABLE ENTRY.  IF NONE, CREATE A NEW ONE.                    #
#       *  IF THE AREA/VERSION IS NOT ALREADY ATTACHED, PERFORM ATTACH #
#          PROCESSING.                                                 #
#       *  IF THE AREA IS NOT FLAGGED AS *BAD*, APPLY THE BLOCK TO THE #
#          FILE (DATA OR INDEX).  OTHERWISE, IF THE AREA WAS ATTACHED  #
#          AND NOT ALREADY DOWNED, PLACE IT IN *DOWN* STATUS.          #
#                                                                      #
#**********************************************************************#
  
  
      FETLOC = LOC(QFFET[0]);          # SAVE IN TEMP SPOT FOR CALL    #
      DB$IORW(FETLOC);                 # REWIND QRF                    #
      DB$RCLL(FETLOC);
      DB$IORE(FETLOC,P<WSA>,DFPRUSIZ); # POSITION AT 1ST BLK           #
      DB$RCLL(FETLOC);
  
      FOR QRFDONE=0 
        WHILE QRFDONE EQ 0
      DO
        BEGIN 
        CRMRC =0; 
        LONGBLOCK = FALSE;
        DB$IORD(FETLOC,P<WSA>,BUFLEN); # READ NEXT BLOCK               #
        DB$RCLL(FETLOC);
  
        IF QFFETIN[0] EQ LOC(WSA) + BUFLEN
        THEN
          BEGIN 
          LONGBLOCK = TRUE; 
          DB$IOBS(FETLOC);             # BACK SPACE PRU                #
          DB$RCLL(FETLOC);
          DB$IOBS(FETLOC);             # BACK SPACE PRU                #
          DB$RCLL(FETLOC);
          DB$IORD(FETLOC,P<WSA>,BUFLEN); # REREAD END OF THE BLOCK     #
          DB$RCLL(FETLOC);
          END 
  
        P<QCCTLWD> = QFFETIN[0] - 2;
        IF QFFETST[0] GQ DFEOP         # IF EOI...                     #
          OR QCGBID[0] NQ GOODBLID     # OR NOT SAME RECOVERY PT GROUP #
        THEN
          BEGIN 
          QRFDONE = 1;
          TEST QRFDONE; 
  
          END 
  
        IF QFFETEC[0] NQ 0             # IF I/O ERROR...               #
        THEN
          BEGIN 
          SRENUMB[0] = DFSRENFUN; 
          SREFUNC[0] = DFSREFNIO; 
          SREFPAR[0] = QFFETEC[0];
          SREFTYP[0] = DFSREFTQR; 
          SASCHST[SALX] = S"ERRDOWN"; 
          QRFDONE = 1;
          TEST QRFDONE; 
  
          END 
  
        AREAID = QCAID[0];
        VERSION =QCVENAME[0]; 
        IF AREAID GR MAXARID           # IF INVALID AREA ID...         #
          OR AREAID LQ 0
        THEN
          BEGIN 
          SRENUMB[0] = DFSRENAID; 
          SREFTYP[0] = DFSREFTQR; 
          SREARID[0] = ABS(AREAID); 
          SASCHST[SALX] = S"ERRDOWN"; 
          QRFDONE = 1;
          TEST QRFDONE; 
  
          END 
  
        IF DB$TARN NQ 0                # IF PROCESSING ONLY ONE AREA   #
          AND NOT (DB$TARN EQ AREAID   # AND THIS IS NOT IT            #
               AND DB$TARV EQ VERSION)
        THEN
          BEGIN                        # SKIP IT                       #
          FIRSTBLOCK = FALSE; 
          TEST QRFDONE; 
  
          END 
  
        FINDFILE;                      # FIND/CREATE PF TABLE ENTRY    #
        IF NOT PTATTACH[0]             # IF AREA NOT ATTACHED...       #
          AND NOT PTAREABAD[0]
        THEN
          BEGIN 
          ATTACHAREA;                  # PERFORM ATTACH PROCESSING     #
          END 
  
        IF NOT PTAREABAD[0]            # IF AREA NOT *BAD*...          #
          AND NOT PTAREAOLD[0]         # AND NOT AN OLD AREA THAT HAS  #
                                       #   BEEN RECOVERED.             #
        THEN
          BEGIN 
          APPLYBLOCK;                  # APPLY QRF BLOCK TO AREA       #
          END 
  
        IF PTAREABAD[0]                # IF AREA *BAD*...              #
        THEN
          BEGIN 
          DOWNSCH = TRUE;              # DO A DELAYED  DOWN-SCHEMA     #
          END 
  
        IF PTAREABAD[0]                # IF THE AREA IS BAD, AND       #
          AND PTATTACH[0]              # IF THE AREA IS ATTACHED, AND  #
          AND NOT PTAREADN[0]          # AN ERROR OCCURRED ON REWRITE  #
        THEN
          BEGIN 
          SRENUMB[0] = DFSRENARB; 
          SREFUNC[0] = DFSREFNIO; 
          SREFPAR[0] = FETNOSAT[0]; 
          SREARID[0] = DB$CDEC(PTAREAID[0],4);
          SREVRNM[0] = PTPVENAME[0];
          DB$DRAR(ERRBLKA);            # DOWN AND RETURN THE AREA      #
          PTAREADN[0] = TRUE; 
          END 
        FIRSTBLOCK = FALSE; 
        END 
  
#**********************************************************************#
#                                                                      #
#     QRF PROCESSING COMPLETE OR ABNORMALLY TERMINATED.  RELEASE ALL   #
#     FETS AND TEMPORARY BUFFERS.  IF THE SCHEMA WAS NOT PLACED IN     #
#     *ERRDOWN* STATUS (DUE TO QRF ERROR OR INSUFFICIENT MEMORY),      #
#     REWRITE THE QRF HEADER TO INDICATE AND *EMPTY* STATE.            #
#                                                                      #
#**********************************************************************#
  
ENDQRFA:  
      RELEASEFETS;                     # RELEASE ALL FETS              #
  
      IF LOC(WSA) NQ FETLOC + DFFETLEN  # IF A SEPARATE I-O BUFFER HAS #
      THEN                             #  BEEN ALLOCATED               #
        BEGIN 
        DB$MBF(P<WSA>);                #  RETURN IT.                   #
        END 
  
      IF DB$TARN NQ 0 
      THEN                             # RECOVERING A SINGLE AREA      #
        BEGIN 
        IF DB$ROLI                     # RESTORE THE  QRF STATUS       #
        THEN                           # FROM THE ROLL OUT FILE        #
          BEGIN 
          DB$PUNT("DB$QRFA 2");        # I-O ERROR ON ROLL OUT FILE    #
                                       # ABORT CDCS                    #
          END 
        END 
  
      P<BLOCKTBL> = BLOCKPTR;          # RELEASE QRF BLOCK TABLE       #
      FOR INDEX=INDEX 
        WHILE P<BLOCKTBL> NQ 0
      DO
        BEGIN 
        DB$LNKD(P<BLOCKTBL>); 
        END 
  
      P<PFTABLE> = PFTPTR;             # RELEASE PF TABLE              #
      FOR INDEX=INDEX 
        WHILE P<PFTABLE> NQ 0 
      DO
        BEGIN 
        DB$LNKD(P<PFTABLE>);
        END 
      IF DOWNSCH                       # IF ANY AREA IS  *BAD*...      #
      THEN
        BEGIN 
        SASCHST[SALX] = S"ERRDOWN"; 
        END 
  
      IF SASCHST[SALX] NQ S"ERRDOWN"
        AND DB$TARN EQ 0
      THEN
        BEGIN 
        DB$QRP(0);                     # REWIND, REINITIALIZE THE QRF  #
        IF QFFETEC[0] NQ 0             # IF I/O ERROR ON QRF...        #
        THEN
          BEGIN 
          SRENUMB[0] = DFSRENFUN; 
          SREFUNC[0] = DFSREFNIO; 
          SREFPAR[0] = QFFETEC[0];
          SREFTYP[0] = DFSREFTQR; 
          SASCHST[SALX] = S"ERRDOWN"; 
          END 
        END 
  
      DB$MFPA = MFPASAVE;              # RESTORE OWNCODE ADDRESS       #
      END                              # END DB$QRFA                   #
      TERM; 
