SUBROUTINE W3FI88(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX,
     *            LDATA,LSTACK,MAXR,MAXD,IUNITB,IUNITD)
C
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:  W3FI88        BUFR MESSAGE DECODER
C   PRGMMR: KEYSER           ORG: NP22        DATE: 2001-02-01
C
C ABSTRACT: THIS SET OF ROUTINES WILL DECODE A BUFR MESSAGE AND
C   PLACE INFORMATION EXTRACTED FROM THE BUFR MESSAGE INTO SELECTED
C   ARRAYS FOR THE USER. THE ARRAY KDATA CAN NOW BE SIZED BY THE USER
C   BY INDICATING THE MAXIMUM NUMBER OF SUBSETS AND THE MAXIMUM
C   NUMBER OF DESCRIPTORS THAT ARE EXPECTED IN THE COURSE OF DECODING
C   SELECTED INPUT DATA.  THIS ALLOWS FOR REALISTIC SIZING OF KDATA
C   AND THE MSTACK ARRAYS. THIS VERSION ALSO ALLOWS FOR THE INCLUSION
C   OF THE UNIT NUMBERS FOR TABLES B AND D INTO THE
C   ARGUMENT LIST. THIS ROUTINE DOES NOT INCLUDE IFOD PROCESSING.
C
C PROGRAM HISTORY LOG:
C 1988-08-31  CAVANAUGH
C 1990-12-07  CAVANAUGH   NOW UTILIZING GBYTE ROUTINES TO GATHER
C                         AND SEPARATE BIT FIELDS. THIS SHOULD IMPROVE
C                         (DECREASE) THE TIME IT TAKES TO DECODE ANY
C                         BUFR MESSAGE. HAVE ENTERED CODING THAT WILL
C                         PERMIT PROCESSING BUFR EDITIONS 1 AND 2.
C                         IMPROVED AND CORRECTED THE CONVERSION INTO
C                         IFOD FORMAT OF DECODED BUFR MESSAGES.
C 1991-01-18  CAVANAUGH   PROGRAM/ROUTINES MODIFIED TO PROPERLY HANDLE
C                         SERIAL PROFILER DATA.
C 1991-04-04  CAVANAUGH   MODIFIED TO HANDLE TEXT SUPPLIED THRU
C                         DESCRIPTOR 2 05 YYY.
C 1991-04-17  CAVANAUGH   ERRORS IN EXTRACTING AND SCALING DATA
C                         CORRECTED. IMPROVED HANDLING OF NESTED
C                         QUEUE DESCRIPTORS IS ADDED.
C 1991-05-10  CAVANAUGH - ARRAY 'DATA' HAS BEEN ENLARGED TO REAL*8
C                         TO BETTER CONTAIN VERY LARGE NUMBERS MORE
C                         ACCURATELY. THE PREIOUS SIZE REAL*4 COULD NOT
C                         CONTAIN SUFFICIENT SIGNIFICANT DIGITS.
C                       - CODING HAS BEEN INTRODUCED TO PROCESS NEW
C                         TABLE C DESCRIPTOR 2 06 YYY WHICH PERMITS IN
C                         LINE PROCESSING OF A LOCAL DESCRIPTOR EVEN IF
C                         THE DESCRIPTOR IS NOT CONTAINED IN THE USERS
C                         TABLE B.
C                       - A SECOND ROUTINE TO PROCESS IFOD MESSAGES
C                         (IFOD0) HAS BEEN REMOVED IN FAVOR OF THE
C                         IMPROVED PROCESSING OF THE ONE
C                         REMAINING (IFOD1).
C                       - NEW CODING HAS BEEN INTRODUCED TO PERMIT
C                         PROCESSING OF BUFR MESSAGES BASED ON BUFR
C                         EDITION UP TO AND INCLUDING EDITION 2.
C                         PLEASE NOTE INCREASED SIZE REQUIREMENTS
C                         FOR ARRAYS IDENT(20) AND IPTR(40).
C 1991-07-26  CAVANAUGH - ADD ARRAY MTIME TO CALLING SEQUENCE TO
C                         PERMIT INCLUSION OF RECEIPT/TRANSFER TIMES
C                         TO IFOD MESSAGES.
C 1991-09-25  CAVANAUGH -     ALL PROCESSING OF DECODED BUFR DATA INTO
C                         IFOD (A LOCAL USE REFORMAT OF BUFR DATA)
C                         HAS BEEN ISOLATED FROM THIS SET OF ROUTINES.
C                         FOR THOSE INTERESTED IN THE IFOD FORM,
C                         SEE W3FL05 IN THE W3LIB ROUTINES.
C                             PROCESSING OF BUFR MESSAGES CONTAINING
C                         DELAYED REPLICATION HAS BEEN ALTERED SO THAT
C                         SINGLE SUBSETS (REPORTS) AND AND A MATCHING
C                         DESCRIPTOR LIST FOR THAT PARTICULAR  SUBSET
C                         WILL BE PASSED TO THE USER WILL BE PASSED TO
C                         THE USER ONE AT A TIME TO ASSURE THAT EACH
C                         SUBSET CAN BE FULLY DEFINED WITH A MINIMUM
C                         OF REPROCESSING.
C                             PROCESSING OF ASSOCIATED FIELDS HAS BEEN
C                         TESTED WITH MESSAGES CONTAINING NON-COMPRESSED
C                         DATA.
C                             IN ORDER TO FACILITATE USER PROCESSING
C                         A MATCHING LIST OF SCALE FACTORS ARE INCLUDED
C                         WITH THE EXPANDED DESCRIPTOR LIST (MSTACK).
C 1991-11-21  CAVANAUGH -     PROCESSING OF DESCRIPTOR 2 03 YYY
C                         HAS CORRECTED TO AGREE WITH FM94 STANDARDS.
C 1991-12-19  CAVANAUGH -     CALLS TO FI8803 AND FI8804 HAVE BEEN
C                         CORRECTED TO AGREE CALLED PROGRAM ARGUMENT
C                         LIST. SOME ADDITIONAL ENTRIES HAVE BEEN
C                         INCLUDED FOR COMMUNICATING WITH DATA ACCESS
C                         ROUTINES. ADDITIONAL ERROR EXIT PROVIDED FOR
C                         THE CASE WHERE TABLE B IS DAMAGED.
C 1992-01-24  CAVANAUGH -    ROUTINES FI8801, FI8803 AND FI8804
C                         HAVE BEEN MODIFIED TO HANDLE ASSOCIATED FIELDS
C                         ALL DESCRIPTORS ARE SET TO ECHO TO MSTACK(1,N)
C 1992-05-21  CAVANAUGH -    FURTHER EXPANSION OF INFORMATION COLLECTED
C                         FROM WITHIN UPPER AIR SOUNDINGS HAS PRODUCED
C                         THE NECESSITY TO EXPAND SOME OF THE PROCESSING
C                         AND OUTPUT ARRAYS. (SEE REMARKS BELOW)
C 1992-06-29  CAVANAUGH -    CORRECTED DESCRIPTOR DENOTING HEIGHT OF
C                         EACH WIND LEVEL FOR PROFILER CONVERSIONS.
C 1992-07-23  CAVANAUGH -    EXPANSION OF TABLE B REQUIRES ADJUSTMENT
C                         OF ARRAYS TO CONTAIN TABLE B VALUES NEEDED TO
C                         ASSIST IN THE DECODING PROCESS.
C            ARRAYS CONTAINING DATA FROM TABLE B
C                    KFXY1    - DESCRIPTOR
C                    ANAME1   - DESCRIPTOR NAME
C                    AUNIT1   - UNITS FOR DESCRIPTOR
C                    ISCAL1   - SCALE FOR VALUE OF DESCRIPTOR
C                    IRFVL1   - REFERENCE VALUE FOR DESCRIPTOR
C                    IWIDE1   - BIT WIDTH FOR VALUE OF DESCRIPTOR
C 1992-09-09  CAVANAUGH -    FIRST ENCOUNTER WITH OPERATOR DESCRIPTOR
C                     2 05 YYY SHOWED ERROR IN DECODING. THAT ERROR
C                     IS CORRECTED WITH THIS IMPLEMENTATION. FURTHER
C                     TESTING OF UPPER AIR DATA HAS ENCOUNTERED
C                     THE CONDITION OF LARGE (MANY LEVEL) SOUNDINGS
C                     ARRAYS IN THE DECODER HAVE BEEN EXPANDED (AGAIN)
C                     TO ALLOW FOR THIS CONDITION.
C 1992-10-02  CAVANAUGH -   MODIFIED ROUTINE TO REFORMAT PROFILER DATA
C                     (FI8809) TO SHOW DESCRIPTORS, SCALE VALUE AND
C                     DATA IN PROPER ORDER.  CORRECTED AN ERROR THAT
C                     PREVENTED USER FROM ASSIGNING THE SECOND DIMENSION
C                     OF KDATA(500,*).
C 1992-10-20  CAVANAUGH -   REMOVED ERROR THAT PREVENTED FULL
C                     IMPLEMENTATION OF PREVIOUS CORRECTIONS AND
C                     MADE CORRECTIONS TO TABLE B TO BRING IT UP TO
C                     DATE. CHANGES INCLUDE PROPER REFORMAT OF PROFILER
C                     DATA AND USER CAPABILITY FOR ASSIGNING SECOND
C                     DIMENSION OF KDATA ARRAY.
C 1992-12-09  CAVANAUGH -   THANKS TO DENNIS KEYSER FOR THE SUGGESTIONS
C                     AND CODING, THIS IMPLEMENTATION WILL ALLOW THE
C                     INCLUSION OF UNIT NUMBERS FOR TABLES B & D, AND
C                     IN ADDITION ALLOWS FOR REALISTIC SIZING OF KDATA
C                     AND MSTACK ARRAYS BY THE USER. AS OF THIS
C                     IMPLEMENTATION, THE UPPER SIZE LIMIT FOR A BUFR
C                     MESSAGE ALLOWS FOR A MESSAGE SIZE GREATER THAN
C                     15000 BYTES.
C 1993-01-26  CAVANAUGH -   ROUTINE FI8810 HAS BEEN ADDED TO PERMIT
C                     REFORMATTING OF PROFILER DATA IN EDITION 2.
C 1993-05-13  CAVANAUGH -   ROUTINE FI8811 HAS BEEN ADDED TO PERMIT
C                     PROCESSING OF RUN-LINE ENCODING. THIS PROVIDES FOR
C                     THE HANDLING OF DATA FOR GRAPHICS PRODUCTS.
C                     PLEASE NOTE THE ADDITION OF TWO ARGUMENTS IN THE
C                     CALLING SEQUENCE.
C 1993-12-01  CAVANAUGH -   ROUTINE FI8803 TO CORRECT HANDLING OF
C                     ASSOCIATED FIELDS AND ARRAYS ASSOCIATED WITH
C                     TABLE B ENTRIES ENLARGED TO HANDLE LARGER TABLE B
C 1994-05-25  CAVANAUGH -   ROUTINES HAVE BEEN MODIFIED TO CONSTRUCT A
C                     MODIFIED TABLE B I.E., IT IS TAILORED TO CONTAIN O
C                     THOSE DESCRIPTORS THAT WILL BE USED TO DECODE
C                     DATA IN CURRENT AND SUBSEQUENT BUFR MESSAGES.
C                     TABLE B AND TABLE D DESCRIPTORS WILL BE ISOLATED
C                     AND MERGED WITH THE MAIN TABLES FOR USE WITH
C                     FOLLOWING BUFR MESSAGES.
C                     THE DESCRIPTORS INDICATING THE REPLICATION OF
C                     DESCRIPTORS AND DATA ARE ACTIVATED WITH THIS
C                     IMPLEMENTATION.
C 1994-08-30  CAVANAUGH -   ADDED STATEMENTS THAT WILL ALLOW USE OF
C                     THESE ROUTINES DIRECTLY ON THE CRAY WITH NO
C                     MODIFICATION. HANDLING OD TABLE D ENTRIES HAS BEEN
C                     MODIFIED TO PREVENT LOSS OF ANCILLARY ENTRIES.
C                     CODING HAS BEEN ADDED TO ALLOW PROCESSING ON
C                     EITHER AN 8 BYTE WORD OR 4 BYTE WORD MACHINE.
C
C                     FOR THOSE USERS OF THE BUFR DECODER THAT ARE
C                     PROCESSING SETS OF BUFR MESSAGES THAT INCLUDE
C                     TYPE 11 MESSAGES, CODING HAS BEEN ADDED TO ALLOW
C                     THE RECOVERY OF THE ADDED OR MODIFIED TABLE B
C                     ENTRIES BY WRITING THEM TO A DISK FILE AVAILABLE
C                     TO THE USER. THIS IS ACCOMPLISHED WITH NO CHANGE
C                     TO THE CALLING SEQUENCE. TABLE B ENTRIES WILL BE
C                     DESIGNATED AS FOLLOWS:
C
C                      IUNITB - IS THE UNIT NUMBER FOR THE MASTER
C                               TABLE B.
C                      IUNITB+1 - WILL BE THE UNIT NUMBER FOR THE
C                               TABLE B ENTRIES THAT ARE TO BE USED
C                               IN THE DECODING OF SUBSEQUENT MESSAGES.
C                               THIS DEVICE WILL BE FORMATTED THE SAME
C                               THE DISK FILE ON IUNITB.
C
C 1995-06-07  KEYSER- CORRECTED AN ERROR WHICH REQUIRED INPUT
C                     ARGUMENT "MAXD" TO BE NEARLY TWICE AS LARGE AS
C                     NEEDED FOR DECODING WIND PROFILER REPORTS (LIMIT
C                     UPPER BOUND FOR "IWORK" ARRAY WAS SET TO "MAXD",
C                     NOW IT IS SET TO 15000). ALSO, A CORRECTION WAS
C                     MADE IN THE WIND PROFILER PROCESSING TO PREVENT
C                     UNNECESSARY LOOPING WHEN ALL REQUESTED
C                     DESCRIPTORS ARE MISSING.  ALSO CORRECTED AN
C                     ERROR WHICH RESULTED IN RETURNED SCALE IN
C                     "MSTACK(2, ..)" ALWAYS BEING SET TO ZERO FOR
C                     COMPRESSED DATA.
C 1996-02-15  CAVANAUGH- MODIFIED IDENTIFICATION OF ASCII/EBCDIC
C                     MACHINE. MODIFIED HANDLING OF TABLE B TO PERMIT
C                     FASTER PROCESSING OF MULTIPLE MESSAGES WITH
C                     CHANGING DATA TYPES AND/OR SUBTYPES.
C 1996-04-02  CAVANAUGH- DEACTIVATED EXTRANEOUS WRITE STATEMENT.
C                     ENLARGED ARRAYS FOR TABLE B ENTRIES TO CONTAIN
C                     UP TO 1300 ENTRIES IN PREPARATION FOR NEW
C                     ADDITIONS TO TABLE B.
C 2001-02-01  KEYSER- THE TABLE B FILE WILL NOW BE READ WHENEVER THE
C                     INPUT ARGUMENT "IUNITB" (TABLE B UNIT NUMBER)
C                     CHANGES FROM ITS VALUE IN THE PREVIOUS CALL TO
C                     THIS ROUTINE (NORMALLY IT IS ONLY READ THE
C                     FIRST TIME THIS ROUTINE IS CALLED)
C 2002-10-15  VUONG   REPLACED FUNCTION ICHAR WITH MOVA2I
C
C
C USAGE:    CALL W3FI88(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX,
C                       LDATA,LSTACK,MAXR,MAXD,IUNITB,IUNITD)
C
C   INPUT ARGUMENT LIST:
C     MSGA     - ARRAY CONTAINING SUPPOSED BUFR MESSAGE
C                SIZE IS DETERMINED BY USER, CAN BE GREATER
C                THAN 15000 BYTES.
C     MAXR     - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE
C                CONTAINED IN A BUFR MESSAGE
C     MAXD     - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT
C                MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE
C                DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST
C                OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE
C     IUNITB   - UNIT NUMBER OF DATA SET HOLDING TABLE B, THIS IS THE
C                NUMBER OF A PAIR OF DATA SETS
C     IUNITB+1 - UNIT NUMBER FOR A DATASET TO CONTAIN TABLE B ENTRIES
C                FROM MASTER TABLE B AND TABLE B ENTRIES EXTRACTED
C                FROM TYPE 11 BUFR MESSAGES THAT WERE USED TO DECODE
C                CURRENT BUFR MESSAGES.
C     IUNITD   - UNIT NUMBER OF DATA SET HOLDING TABLE D
C
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     ISTACK   - ORIGINAL ARRAY OF DESCRIPTORS EXTRACTED FROM
C                SOURCE BUFR MESSAGE.
C
C     MSTACK(A,B)-LEVEL B - DESCRIPTOR NUMBER (LIMITED TO VALUE OF
C                           INPUT ARGUMENT MAXD)
C
C                 LEVEL A = 1 DESCRIPTOR
C                         = 2 10**N SCALING TO RETURN TO ORIGINAL VALUE
C     IPTR     - UTILITY ARRAY    (SHOULD HAVE AT LAST 42 ENTRIES)
C         IPTR( 1)- ERROR RETURN
C         IPTR( 2)- BYTE COUNT SECTION 1
C         IPTR( 3)- POINTER TO START OF SECTION 1
C         IPTR( 4)- BYTE COUNT SECTION 2
C         IPTR( 5)- POINTER TO START OF SECTION 2
C         IPTR( 6)- BYTE COUNT SECTION 3
C         IPTR( 7)- POINTER TO START OF SECTION 3
C         IPTR( 8)- BYTE COUNT SECTION 4
C         IPTR( 9)- POINTER TO START OF SECTION 4
C         IPTR(10)- START OF REQUESTED SUBSET, RESERVED FOR DAR
C         IPTR(11)- CURRENT DESCRIPTOR PTR IN IWORK
C         IPTR(12)- LAST DESCRIPTOR POS IN IWORK
C         IPTR(13)- LAST DESCRIPTOR POS IN ISTACK
C         IPTR(14)- NUMBER OF MASTER TABLE B ENTRIES
C         IPTR(15)- REQUESTED SUBSET POINTER, RESERVED FOR DAR
C         IPTR(16)- INDICATOR FOR EXISTANCE OF SECTION 2
C         IPTR(17)- NUMBER OF REPORTS PROCESSED
C         IPTR(18)- ASCII/TEXT EVENT
C         IPTR(19)- POINTER TO START OF BUFR MESSAGE
C         IPTR(20)- NUMBER OF ENTRIES FROM TABLE D
C         IPTR(21)- NR TABLE B ENTRIES
C         IPTR(22)- NR TABLE B ENTRIES FROM CURRENT MESSAGE
C         IPTR(23)- CODE/FLAG TABLE SWITCH
C         IPTR(24)- ADITIONAL WORDS ADDED BY TEXT INFO
C         IPTR(25)- CURRENT BIT NUMBER
C         IPTR(26)- DATA WIDTH CHANGE - ADD TO TABLE B WIDTH
C         IPTR(27)- DATA SCALE CHANGE - MODIFIES TABLE B SCALE
C         IPTR(28)- DATA REFERENCE VALUE CHANGE - ?????????
C         IPTR(29)- ADD DATA ASSOCIATED FIELD
C         IPTR(30)- SIGNIFY CHARACTERS
C         IPTR(31)- NUMBER OF EXPANDED DESCRIPTORS IN MSTACK
C         IPTR(32)- CURRENT DESCRIPTOR SEGMENT F
C         IPTR(33)- CURRENT DESCRIPTOR SEGMENT X
C         IPTR(34)- CURRENT DESCRIPTOR SEGMENT Y
C         IPTR(35)- DATA/DESCRIPTOR REPLICATION IN PROGRESS
C                   0  = NO
C                   1  = YES
C         IPTR(36)- NEXT DESCRIPTOR MAY BE UNDECIPHERABLE
C         IPTR(37)- MACHINE TEXT TYPE FLAG
C                   0  = EBCIDIC
C                   1  = ASCII
C         IPTR(38)- DATA/DESCRIPTOR REPLICATION FLAG
C                      0 - DOES NOT EXIST IN CURRENT MESSAGE
C                      1 - EXISTS IN CURRENT MESSAGE
C         IPTR(39)- DELAYED REPLICATION FLAG
C                      0 - NO DELAYED REPLICATION
C                      1 - MESSAGE CONTAINS DELAYED REPLICATION
C         IPTR(40)- NUMBER OF CHARACTERS IN TEXT FOR CURR DESCRIPTOR
C         IPTR(41)- NUMBER OF ANCILLARY TABLE B ENTRIES
C         IPTR(42)- NUMBER OF ANCILLARY TABLE D ENTRIES
C         IPTR(43)- NUMBER OF ADDED TABLE B ENTRIES ENCOUNTERED WHILE
C                    PROCESSING A BUFR MESSAGE. THESE ENTRIES ONLY
C                    EXIST DURNG PROCESSING OF CURRENT BUFR MESSAGE
C         IPTR(44)- BITS PER WORD
C         IPTR(45)- BYTES PER WORD
C     IDENT    - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM
C                  BUFR MESSAGE -
C         IDENT(1) -EDITION NUMBER     (BYTE 4, SECTION 1)
C         IDENT(2) -ORIGINATING CENTER (BYTES 5-6, SECTION 1)
C         IDENT(3) -UPDATE SEQUENCE    (BYTE 7, SECTION 1)
C         IDENT(4) -OPTIONAL SECTION   (BYTE 8, SECTION 1)
C         IDENT(5) -BUFR MESSAGE TYPE  (BYTE 9, SECTION 1)
C                  0 = SURFACE DATA (LAND)
C                  1 = SURFACE DATA (SHIP)
C                  2 = VERTICAL SOUNDINGS (OTHER THAN SATELLITE)
C                  3 = VERTICAL SOUNDINGS (SATELLITE)
C                  4 = SINGLE LVL UPPER-AIR DATA(OTHER THAN SATELLITE)
C                  5 = SINGLE LEVEL UPPER-AIR DATA (SATELLITE)
C                  6 = RADAR DATA
C                  7 = SYNOPTIC FEATURES
C                  8 = PHYSICAL/CHEMICAL CONSTITUENTS
C                  9 = DISPERSAL AND TRANSPORT
C                 10 = RADIOLOGICAL DATA
C                 11 = BUFR TABLES (COMPLETE, REPLACEMENT OR UPDATE)
C                 12 = SURFACE DATA (SATELLITE)
C                 21 = RADIANCES (SATELLITE MEASURED)
C                 31 = OCEANOGRAPHIC DATA
C         IDENT(6) -BUFR MSG SUB-TYPE  (BYTE 10, SECTION 1)
C              TYPE SBTYP
C               2     7   = PROFILER
C         IDENT(7) -                   (BYTES 11-12, SECTION 1)
C         IDENT(8) -YEAR OF CENTURY    (BYTE 13, SECTION 1)
C         IDENT(9) -MONTH OF YEAR      (BYTE 14, SECTION 1)
C         IDENT(10)-DAY OF MONTH       (BYTE 15, SECTION 1)
C         IDENT(11)-HOUR OF DAY        (BYTE 16, SECTION 1)
C         IDENT(12)-MINUTE OF HOUR     (BYTE 17, SECTION 1)
C         IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1)
C         IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3)
C         IDENT(15)-OBSERVED FLAG      (BYTE 7, BIT 1, SECTION 3)
C         IDENT(16)-COMPRESSION FLAG   (BYTE 7, BIT 2, SECTION 3)
C         IDENT(17)-MASTER TABLE NUMBER(BYTE 4, SECTION 1, ED 2 OR GTR)
C     KDATA    - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
C                KDATA(REPORT NUMBER,PARAMETER NUMBER)
C
C                (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
C                 MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
C                 ARGUMENT MAXD)
C     INDEX    - POINTER TO AVAILABLE SUBSET
C
C  ===========================================================
C            ARRAYS CONTAINING DATA FROM TABLE B
C           NEW - BASE ARRAYS CONTAINING DATA FROM TABLE B
C     KFXY1    - DECIMAL DESCRIPTOR VALUE OF F X Y VALUES
C     ANAME1   - DESCRIPTOR NAME
C     AUNIT1   - UNITS FOR DESCRIPTOR
C     ISCAL1   - SCALE FOR VALUE OF DESCRIPTOR
C     IRFVL1   - REFERENCE VALUE FOR DESCRIPTOR
C     IWIDE1   - BIT WIDTH FOR VALUE OF DESCRIPTOR
C  ===========================================================
C           NEW - ANCILLARY ARRAYS CONTAINING DATA FROM TABLE B
C                  CONTAINING TABLE B ENTRIES EXTRACTED
C                  FROM TYPE 11 BUFR MESSAGES
C     KFXY2    - DECIMAL DESCRIPTOR VALUE OF F X Y VALUES
C     ANAME2   - DESCRIPTOR NAME
C     AUNIT2   - UNITS FOR DESCRIPTOR
C     ISCAL2   - SCALE FOR VALUE OF DESCRIPTOR
C     IRFVL2   - REFERENCE VALUE FOR DESCRIPTOR
C     IWIDE2   - BIT WIDTH FOR VALUE OF DESCRIPTOR
C  ===========================================================
C           NEW - ADDED ARRAYS CONTAINING DATA FROM TABLE B
C                  CONTAINING TABLE B ENTRIES EXTRACTED
C                  FROM NON-TYPE 11 BUFR MESSAGES
C                  THESE EXIST FOR THE LIFE OF CURRENT BUFR MESSAGE
C     KFXY3    - DECIMAL DESCRIPTOR VALUE OF F X Y VALUES
C     ANAME3   - DESCRIPTOR NAME
C     AUNIT3   - UNITS FOR DESCRIPTOR
C     ISCAL3   - SCALE FOR VALUE OF DESCRIPTOR
C     IRFVL3   - REFERENCE VALUE FOR DESCRIPTOR
C     IWIDE3   - BIT WIDTH FOR VALUE OF DESCRIPTOR
C  ===========================================================
C
C   SUBPROGRAMS CALLED:
C     LIBRARY:
C       UNIQUE   - FI8801  FI8802  FI8803  FI8804  FI8805  FI8806
C                  FI8807  FI8808  FI8809  FI8810  FI8811  FI8812
C                  FI8813  FI8814  FI8815  FI8820
C       W3LIB    - W3AI39  W3FC05  GBYTE   GBYTES
C
C REMARKS: ERROR RETURNS:
C    IPTR(1) = 1   'BUFR' NOT FOUND IN FIRST 125 CHARACTERS
C            = 2   '7777' NOT FOUND IN LOCATION DETERMINED BY
C                  BY USING COUNTS FOUND IN EACH SECTION. ONE OR
C                  MORE SECTIONS HAVE AN ERRONEOUS BYTE COUNT OR
C                  CHARACTERS '7777' ARE NOT IN TEST MESSAGE.
C            = 3   MESSAGE CONTAINS A DESCRIPTOR WITH F=0 THAT DOES
C                  NOT EXIST IN TABLE B.
C            = 4   MESSAGE CONTAINS A DESCRIPTOR WITH F=3 THAT DOES
C                  NOT EXIST IN TABLE D.
C            = 5   MESSAGE CONTAINS A DESCRIPTOR WITH F=2 WITH THE
C                  VALUE OF X OUTSIDE THE RANGE 1-6.
C            = 6   DESCRIPTOR ELEMENT INDICATED TO HAVE A FLAG VALUE
C                  DOES NOT HAVE AN ENTRY IN THE FLAG TABLE.
C                  (TO BE ACTIVATED)
C            = 7   DESCRIPTOR INDICATED TO HAVE A CODE VALUE DOES
C                  NOT HAVE AN ENTRY IN THE CODE TABLE.
C                  (TO BE ACTIVATED)
C            = 8   ERROR READING TABLE D
C            = 9   ERROR READING TABLE B
C            = 10  ERROR READING CODE/FLAG TABLE
C            = 11  DESCRIPTOR 2 04 004 NOT FOLLOWED BY 0 31 021
C            = 12  DATA DESCRIPTOR OPERATOR QUALIFIER DOES NOT FOLLOW
C                  DELAYED REPLICATION DESCRIPTOR.
C            = 13  BIT WIDTH ON ASCII CHARACTERS NOT A MULTIPLE OF 8
C            = 14  SUBSETS = 0, NO CONTENT BULLETIN
C            = 20  EXCEEDED COUNT FOR DELAYED REPLICATION PASS
C            = 21  EXCEEDED COUNT FOR NON-DELAYED REPLICATION PASS
C            = 22  EXCEEDED COMBINED BIT WIDTH, BIT WIDTH > 32
C            = 23  NO ELEMENT DESCRIPTORS FOLLOWING 2 03 YYY
C            = 27  NON ZERO LOWEST ON TEXT DATA
C            = 28  NBINC NOT NR OF CHARACTERS
C            = 29  TABLE B APPEARS TO BE DAMAGED
C            = 30  TABLE D ENTRY WITH MORE THAN 18 IN SEQUENCE
C                  BEING ENTERED FROM TYPE 11 MESSAGE
C            = 99  NO MORE SUBSETS (REPORTS) AVAILABLE IN CURRENT
C                  BUFR MESAGE
C
C            = 400 NUMBER OF SUBSETS EXCEEDS THE VALUE OF INPUT
C                  ARGUMENT MAXR; MUST INCREASE MAXR TO VALUE OF
C                  IDENT(14) IN CALLING PROGRAM
C
C            = 401 NUMBER OF PARAMETERS (AND ASSOCIATED FIELDS)
C                  EXCEEDS LIMITS OF THIS PROGRAM.
C            = 500 VALUE FOR NBINC HAS BEEN FOUND THAT EXCEEDS
C                  STANDARD WIDTH PLUS ANY BIT WIDTH CHANGE.
C                  CHECK ALL BIT WIDTHS UP TO POINT OF ERROR.
C            = 501 CORRECTED WIDTH FOR DESCRIPTOR IS 0 OR LESS
C            = 888 NON-NUMERIC CHARACTER IN CONVERSION REQUEST
C            = 890 CLASS 0 ELEMENT DESCRIPTOR W/WIDTH OF 0
C
C        ON THE INITIAL CALL TO W3FI88 WITH A BUFR MESSAGE THE ARGUMENT
C    INDEX MUST BE SET TO ZERO (INDEX = 0). ON THE RETURN FROM W3FI88
C    'INDEX' WILL BE SET TO THE NEXT AVAILABLE SUBSET/REPORT. WHEN
C    THERE ARE NO MORE SUBSETS AVAILABLE A 99 ERR RETURN WILL OCCUR.
C
C    IF THE ORIGINAL BUFR MESSAGE DOES NOT CONTAIN DELAYED REPLICATION
C    THE BUFR MESSAGE WILL BE COMPLETELY DECODED AND 'INDEX' WILL POINT
C    TO THE FIRST DECODED SUBSET. THE USERS WILL THEN HAVE THE OPTION
C    OF INDEXING THROUGH THE SUBSETS ON THEIR OWN OR BY RECALLING THIS
C    ROUTINE (WITHOUT RESETTING 'INDEX') TO HAVE THE ROUTINE DO THE
C    INDEXING.
C
C    IF THE ORIGINAL BUFR MESSAGE DOES CONTAIN DELAYED REPLICATION
C    ONE SUBSET/REPORT WILL BE DECODED AT A TIME AND PASSED BACK TO
C    THE USER. THIS IS NOT AN OPTION.
C
C  =============================================
C   TO USE THIS ROUTINE
C  =============================================
C       THE ARRAYS TO CONTAIN THE OUTPUT INFORMATION ARE DEFINED
C       AS FOLLOWS:
C
C           KDATA(A,B)  IS THE A DATA ENTRY  (INTEGER VALUE)
C                       WHERE A IS THE MAXIMUM NUMBER OF REPORTS/SUBSETS
C                       THAT MAY BE CONTAINED IN THE BUFR MESSAGE (THIS
C                       IS NOW SET TO "MAXR" WHICH IS PASSED AS AN INPUT
C                       ARGUMENT TO W3FI88), AND WHERE B IS THE MAXIMUM
C                       NUMBER OF DESCRIPTOR COMBINATIONS THAT MAY
C                       BE PROCESSED (THIS IS NOW SET TO "MAXD" WHICH
C                       IS ALSO PASSED AS AN INPUT ARGUMENT TO W3FI88;
C                       UPPER AIR DATA AND SOME SATELLITE DATA REQUIRE
C                       A VALUE FOR MAXD OF 1700, BUT FOR MOST OTHER
C                       DATA A VALUE FOR MAXD OF 500 WILL SUFFICE)
C           MSTACK(1,B) CONTAINS THE DESCRIPTOR THAT MATCHES THE
C                       DATA ENTRY (MAX. VALUE FOR B IS NOW "MAXD"
C                       WHICH IS PASSED AS AN INPUT ARGUMENT TO W3FI88)
C           MSTACK(2,B) IS THE SCALE (POWER OF 10) TO BE APPLIED TO
C                       THE DATA (MAX. VALUE FOR B IS NOW "MAXD"
C                       WHICH IS PASSED AS AN INPUT ARGUMENT TO W3FI88)
C
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  NAS
C
C$$$
C
C
C          THE MEMORY REQUIREMENTS FOR LSTACK AND LDATA ARE USED WITH
C          RUN-LINE CODING PROVIDING FOR THE HANDLING OF DATA FOR
C          GRAPHICS. I.E., RADAR DISPLAYS. IF THE DECODING PROCESS WILL
C          NOT BE USED TO PROCESS THOSE TYPE OF MESSAGES, THEN THE
C          VARIABLE SIZES FOR THE ARRAYS CAN BE MINIMIZED.
C          IF THE DECODING PROCESS WILL BE USED TO DECODE THOSE MESSAGE
C          TYPES, THEN MAXD MUST REFLECT THE MAXIMUM NUMBER OF
C          DESCRIPTORS (FULLY EXPANDED LIST) TO BE EXPECTED IN THE
C          MESSAGE.
C
      INTEGER        LDATA(MAXD)
      INTEGER        LSTACK(2,MAXD)
C
      INTEGER        MSGA(*)
      INTEGER        IPTR(*),KPTRB(16384),KPTRD(16384)
      INTEGER        KDATA(MAXR,MAXD)
      INTEGER        MSTACK(2,MAXD)
C
      INTEGER        IVALS(1000)
      INTEGER        KNR(MAXR)
      INTEGER        IDENT(*)
      INTEGER        ISTACK(*),IOLD11
cdak KEYSER fix 02/02/2001 VVVVV
      INTEGER        IOLDTB
cdak KEYSER fix 02/02/2001 AAAAA
      INTEGER        IWORK(15000)
      INTEGER        INDEX
C
      INTEGER        IIII
      CHARACTER*1    BLANK
      CHARACTER*4    DIRID(2)
C
      LOGICAL        SEC2
C  ..................................................
C
C     NEW               BASE TABLE B
C                            MAY BE A COMBINATION OF MASTER TABLE B
C                            AND ANCILLARY TABLE B
C
      INTEGER        KFXY1(1300),ISCAL1(1300)
      INTEGER        IRFVL1(3,1300),IWIDE1(1300)
      CHARACTER*40   ANAME1(1300)
      CHARACTER*24   AUNIT1(1300)
C  ..................................................
C
C        NEW            ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE
C
      INTEGER        KFXY2(200),ISCAL2(200),IRFVL2(200),IWIDE2(200)
      CHARACTER*64   ANAME2(200)
      CHARACTER*24   AUNIT2(200)
C  ..................................................
C
C           NEW         ADDED TABLE B FROM NON-TYPE 11 BUFR MESSAGE
C
C     INTEGER        KFXY3(200),ISCAL3(200),IRFVL3(200),IWIDE3(200)
C     CHARACTER*64   ANAME3(200)
C     CHARACTER*24   AUNIT3(200)
C  ..................................................
C
C                       NEW BASE TABLE D
C
      INTEGER        ITBLD(20,400)
C  ..................................................
C
C                       ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
C
      INTEGER        ITBLD2(20,50)
C  ..................................................
C
      SAVE

cdak KEYSER fix 02/02/2001 VVVVV
      DATA              IOLD11/0/
      DATA              IOLDTB/-99/
cdak KEYSER fix 02/02/2001 AAAAA
C
      CALL W3FI01(LW)
      IPTR(45) = LW
      IPTR(44) = LW * 8
C
      BLANK  = ' '
      IF (MOVA2I(BLANK).EQ.32) THEN
          IPTR(37) = 1
C         PRINT *,'ASCII MACHINE'
      ELSE
          IPTR(37) = 0
C         PRINT *,'EBCDIC MACHINE'
      END IF
C
C     PRINT *,' W3FI88 DECODER'
C                            INITIALIZE ERROR RETURN
      IPTR(1)   = 0
      IF (INDEX.GT.0) THEN
C                                 HAVE RE-ENTRY
          INDEX   = INDEX + 1
C         PRINT *,'RE-ENTRY LOOKING FOR SUBSET NR',INDEX
          IF (INDEX.GT.IDENT(14)) THEN
C                                 ALL SUBSETS PROCESSED
              IPTR(1)  = 99
              IPTR(38) = 0
              IPTR(39) = 0
          ELSE IF (INDEX.LE.IDENT(14)) THEN
              IF (IPTR(39).NE.0) THEN
                  DO 3000 J =1, IPTR(13)
                      IWORK(J)  = ISTACK(J)
 3000             CONTINUE
                  IPTR(12)  = IPTR(13)
                 CALL FI8801(IPTR,IDENT,MSGA,ISTACK,IWORK,KDATA,IVALS,
     *           MSTACK,KNR,INDEX,MAXR,MAXD,
     *           KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,IRF1SW,INEWVL,
     *           KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,
     *           KFXY3,ANAME3,AUNIT3,ISCAL3,IRFVL3,IWIDE3,
     *           IUNITB,IUNITD,ITBLD,ITBLD2,KPTRB,KPTRD)
C
              END IF
          END IF
          RETURN
      ELSE
          INDEX  = 1
C         PRINT *,'INITIAL ENTRY FOR THIS BUFR MESSAGE'
      END IF
      IPTR(39)  = 0
C                        FIND 'BUFR' IN FIRST 125 CHARACTERS
      DO 1000 KNOFST = 0, 999, 8
          INOFST     = KNOFST
          CALL GBYTE (MSGA,IVALS,INOFST,8)
          IF (IVALS(1).EQ.66) THEN
              IPTR(19)   = INOFST
              INOFST     = INOFST + 8
              CALL GBYTE (MSGA,IVALS,INOFST,24)
              IF (IVALS(1).EQ.5588562) THEN
C                 PRINT *,'FOUND BUFR AT',IPTR(19)
                  INOFST     = INOFST + 24
                  GO TO 1500
              END IF
          END IF
 1000 CONTINUE
      PRINT *,'BUFR - START OF BUFR MESSAGE NOT FOUND'
      IPTR(1)    = 1
      RETURN
 1500 CONTINUE
      IDENT(1)   = 0
C                            TEST FOR EDITION NUMBER
C  ======================
      CALL GBYTE (MSGA,IDENT(1),INOFST+24,8)
C     PRINT *,'THIS IS AN EDITION',IDENT(1),' BUFR MESSAGE'
C
      IF (IDENT(1).GE.2) THEN
C                           GET TOTAL COUNT
          CALL GBYTE (MSGA,IVALS,INOFST,24)
          ITOTAL   = IVALS(1)
          KENDER   = ITOTAL * 8 - 32 + IPTR(19)
          CALL GBYTE (MSGA,ILAST,KENDER,32)
C         IF (ILAST.EQ.926365495) THEN
C             PRINT *,'HAVE TOTAL COUNT FROM SEC 0',IVALS(1)
C         END IF
          INOFST     = INOFST + 32
C                           GET SECTION 1 COUNT
          IPTR(3)  = INOFST
          CALL GBYTE (MSGA,IVALS,INOFST,24)
C         PRINT *,'SECTION 1 STARTS AT',INOFST,'  SIZE',IVALS(1)
          INOFST     = INOFST + 24
          IPTR( 2)   = IVALS(1)
C                           GET MASTER TABLE
          CALL GBYTE (MSGA,IVALS,INOFST,8)
          INOFST     = INOFST + 8
          IDENT(17)  = IVALS(1)
C         PRINT *,'BUFR MASTER TABLE NR',IDENT(17)
      ELSE
          IPTR(3)    = INOFST
C                           GET SECTION 1 COUNT
          CALL GBYTE (MSGA,IVALS,INOFST,24)
C         PRINT *,'SECTION 1 STARTS AT',INOFST,'  SIZE',IVALS(1)
          INOFST     = INOFST + 32
          IPTR( 2)   = IVALS(1)
      END IF
C  ======================
C                            ORIGINATING CENTER
      CALL GBYTE (MSGA,IVALS,INOFST,16)
      INOFST     = INOFST + 16
      IDENT(2)   = IVALS(1)
C                            UPDATE SEQUENCE
      CALL GBYTE (MSGA,IVALS,INOFST,8)
      INOFST     = INOFST + 8
      IDENT(3)   = IVALS(1)
C                            OPTIONAL SECTION FLAG
      CALL GBYTE (MSGA,IVALS,INOFST,1)
      IDENT(4)   = IVALS(1)
      IF (IDENT(4).GT.0) THEN
          SEC2       = .TRUE.
      ELSE
C         PRINT *,'              NO OPTIONAL SECTION 2'
          SEC2       = .FALSE.
      END IF
      INOFST     = INOFST + 8
C                            MESSAGE TYPE
      CALL GBYTE (MSGA,IVALS,INOFST,8)
      IDENT(5)   = IVALS(1)
      INOFST     = INOFST + 8
C                            MESSAGE SUBTYPE
      CALL GBYTE (MSGA,IVALS,INOFST,8)
      IDENT(6)   = IVALS(1)
      INOFST     = INOFST + 8
cdak KEYSER fix 02/02/2001 VVVVV
      IF (IUNITB.NE.IOLDTB) THEN
C                IF HAVE A CHANGE IN TABLE B UNIT NUMBER , READ TABLE B
          IF(IOLDTB.NE.-99)  PRINT *, 'W3FI88 - NEW TABLE B UNIT NUMBER'
          IOLDTB = IUNITB
          IPTR(14)  = 0
          IPTR(21)  = 0
      END IF
cdak KEYSER fix 02/02/2001 AAAAA
C                            IF HAVE CHANGE IN DATA TYPE , RESET TABLE B
      IF (IOLD11.EQ.11) THEN
          IOLD11 = IDENT(5)
          IOLDSB = IDENT(6)
C                            JUST CONTINUE PROCESSING
      ELSE IF (IOLD11.NE.11) THEN
          IF (IDENT(5).EQ.11) THEN
              IOLD11  = IDENT(5)
              IPTR(21) = 0
          ELSE IF (IDENT(5).NE.IOLD11) THEN
              IOLD11  = IDENT(5)
              IPTR(21) = 0
          ELSE IF (IDENT(5).EQ.IOLD11) THEN
C                      IF HAVE A CHANGE IN SUBTYPE, RESET TABLE B
              IF (IOLDSB.NE.IDENT(6)) THEN
                  IOLDSB  = IDENT(6)
                  IPTR(21)  = 0
C             ELSE IF
              END IF
          END IF
      END IF
C                           IF BUFR EDITION 0 OR 1 THEN
C                                 NEXT 2 BYTES ARE BUFR TABLE VERSION
C                           ELSE
C                               BYTE 11 IS VER NR OF MASTER TABLE
C                               BYTE 12 IS VER NR OF LOCAL TABLE
      IF (IDENT(1).LT.2) THEN
          CALL GBYTE (MSGA,IVALS,INOFST,16)
          IDENT(7)   = IVALS(1)
          INOFST     = INOFST + 16
      ELSE
C                               BYTE 11 IS VER NR OF MASTER TABLE
          CALL GBYTE (MSGA,IVALS,INOFST,8)
          IDENT(18)  = IVALS(1)
          INOFST     = INOFST + 8
C                               BYTE 12 IS VER NR OF LOCAL TABLE
          CALL GBYTE (MSGA,IVALS,INOFST,8)
          IDENT(19)  = IVALS(1)
          INOFST     = INOFST + 8

      END IF
C                            YEAR OF CENTURY
      CALL GBYTE (MSGA,IVALS,INOFST,8)
      IDENT(8)   = IVALS(1)
      INOFST     = INOFST + 8
C                            MONTH
      CALL GBYTE (MSGA,IVALS,INOFST,8)
      IDENT(9)   = IVALS(1)
      INOFST     = INOFST + 8
C                            DAY
C     PRINT *,'DAY AT ',INOFST
      CALL GBYTE (MSGA,IVALS,INOFST,8)
      IDENT(10)  = IVALS(1)
      INOFST     = INOFST + 8
C                            HOUR
      CALL GBYTE (MSGA,IVALS,INOFST,8)
      IDENT(11)  = IVALS(1)
      INOFST     = INOFST + 8
C                            MINUTE
      CALL GBYTE (MSGA,IVALS,INOFST,8)
      IDENT(12)  = IVALS(1)
C                            RESET POINTER (INOFST) TO START OF
C                                NEXT SECTION
C                                (SECTION 2 OR SECTION 3)
      INOFST     = IPTR(3) + IPTR(2) * 8
      IPTR(4)    = 0
      IPTR(5)    = INOFST
      IF (SEC2) THEN
C                            SECTION 2 COUNT
          CALL GBYTE (MSGA,IPTR(4),INOFST,24)
          INOFST   = INOFST + 32
C         PRINT *,'SECTION 2 STARTS AT',INOFST,' BYTES=',IPTR(4)
          KENTRY  = (IPTR(4) - 4) / 14
C         PRINT *,'SHOULD BE A MAX OF',KENTRY,' REPORTS'
          IF (IDENT(2).EQ.7) THEN
              DO 2000 I = 1, KENTRY
                  CALL GBYTE (MSGA,KDSPL ,INOFST,16)
                  INOFST  = INOFST + 16
                  CALL GBYTE (MSGA,LAT   ,INOFST,16)
                  INOFST  = INOFST + 16
                  CALL GBYTE (MSGA,LON   ,INOFST,16)
                  INOFST  = INOFST + 16
                  CALL GBYTE (MSGA,KDAHR ,INOFST,16)
                  INOFST  = INOFST + 16
                  CALL GBYTE (MSGA,DIRID(1),INOFST,32)
                  INOFST  = INOFST + 32
                  CALL GBYTE (MSGA,DIRID(2),INOFST,16)
                  INOFST  = INOFST + 16
C                 PRINT *,KDSPL,LAT,LON,KDAHR,DIRID(1),DIRID(2)
 2000         CONTINUE
          END IF
C                            RESET POINTER (INOFST) TO START OF
C                                SECTION 3
          INOFST     = IPTR(5) + IPTR(4) * 8
      END IF
C                            BIT OFFSET TO START OF SECTION 3
      IPTR( 7)   = INOFST
C                            SECTION 3 COUNT
      CALL GBYTE (MSGA,IPTR(6),INOFST,24)
C     PRINT *,'SECTION 3 STARTS AT',INOFST,' BYTES=',IPTR(6)
      INOFST     = INOFST + 24
C                           SKIP RESERVED BYTE
      INOFST     = INOFST + 8
C                            NUMBER OF DATA SUBSETS
      CALL GBYTE (MSGA,IDENT(14),INOFST,16)
C
      IF (IDENT(14).GT.MAXR) THEN
          PRINT *,'THE NUMBER OF SUBSETS EXCEEDS THE MAXIMUM OF',MAXR
          PRINT *,'PASSED INTO W3FI88; MAXR MUST BE INCREASED IN '
          PRINT *,'THE CALLING PROGRAM TO AT LEAST THE VALUE OF'
          PRINT *,IDENT(14),'TO BE ABLE TO PROCESS THIS DATA'
C
          IPTR(1)  = 400
          RETURN
      END IF
      INOFST     = INOFST + 16
C                            OBSERVED DATA FLAG
      CALL GBYTE (MSGA,IVALS,INOFST,1)
      IDENT(15)  = IVALS(1)
      INOFST     = INOFST + 1
C                            COMPRESSED DATA FLAG
      CALL GBYTE (MSGA,IVALS,INOFST,1)
      IDENT(16)  = IVALS(1)
      INOFST     = INOFST + 7
C                            CALCULATE NUMBER OF DESCRIPTORS
      NRDESC     = (IPTR( 6) - 8) / 2
      IPTR(12)   = NRDESC
      IPTR(13)   = NRDESC
C                            EXTRACT DESCRIPTORS
      CALL GBYTES (MSGA,ISTACK,INOFST,16,0,NRDESC)
C     PRINT *,'INITIAL DESCRIPTOR LIST OF',NRDESC,' DESCRIPTORS'
      DO 10 L = 1, NRDESC
          IWORK(L)   = ISTACK(L)
C         PRINT *,L,ISTACK(L)
   10 CONTINUE
      IPTR(13)   = NRDESC
C  ===============================================================
C
C                            CONSTRUCT A TABLE B TO MATCH THE
C                            LIST OF DESCRIPTORS FOR THIS MESSAGE
C
      IF (IPTR(21).EQ.0) THEN
          PRINT *,'W3FI88- TABLE B NOT YET ENTERED'
          CALL FI8812(IPTR,IUNITB,IUNITD,ISTACK,NRDESC,KPTRB,KPTRD,
     *                     IRF1SW,NEWREF,ITBLD,ITBLD2,
     *                     KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
     *                     KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2)
      ELSE
C         PRINT *,'W3FI88- TABLE B ALL READY IN PLACE'
          IF (IPTR(41).NE.0) THEN
C             PRINT *,'MERGE',IPTR(41),' ENTRIES INTO TABLE B'
C             CALL FI8818(IPTR,KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
C    *                 KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,KPTRB)
          END IF
      END IF
      IF (IPTR(1).NE.0) RETURN
C ================================================================
C                            RESET POINTER TO START OF SECTION 4
      INOFST     = IPTR(7) + IPTR(6) * 8
C                            BIT OFFSET TO START OF SECTION 4
      IPTR( 9)   = INOFST
C                            SECTION 4 COUNT
      CALL GBYTE (MSGA,IVALS,INOFST,24)
C     PRINT *,'SECTION 4 STARTS AT',INOFST,' VALUE',IVALS(1)
      IPTR( 8)   = IVALS(1)
      INOFST     = INOFST + 32
C                            SET FOR STARTING BIT OF DATA
      IPTR(25)   = INOFST
C                            FIND OUT IF '7777' TERMINATOR IS THERE
      INOFST     = IPTR(9) + IPTR(8) * 8
      CALL GBYTE  (MSGA,IVALS,INOFST,32)
C     PRINT *,'SECTION 5 STARTS AT',INOFST,' VALUE',IVALS(1)
      IF (IVALS(1).NE.926365495) THEN
          PRINT *,'BAD SECTION COUNT'
          IPTR(1)     = 2
          RETURN
      ELSE
          IPTR(1)     = 0
      END IF
C
      CALL FI8801(IPTR,IDENT,MSGA,ISTACK,IWORK,KDATA,IVALS,
     *           MSTACK,KNR,INDEX,MAXR,MAXD,
     *           KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,IRF1SW,INEWVL,
     *           KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,
     *           KFXY3,ANAME3,AUNIT3,ISCAL3,IRFVL3,IWIDE3,
     *           IUNITB,IUNITD,ITBLD,ITBLD2,KPTRB,KPTRD)
C
C     PRINT *,'HAVE RETURNED FROM FI8801'
      IF (IPTR(1).NE.0) THEN
          RETURN
      END IF
C                FURTHER PROCESSING REQUIRED FOR PROFILER DATA
      IF (IDENT(5).EQ.2) THEN
          IF (IDENT(6).EQ.7) THEN
C             PRINT *,'REFORMAT PROFILER DATA'
C
C             DO 7151 I = 1, 40
C                 IF (I.LE.20) THEN
C                     PRINT *,'IPTR(',I,')=',IPTR(I),
C    *                                       ' IDENT(',I,')= ',IDENT(I)
C                 ELSE
C                     PRINT *,'IPTR(',I,')=',IPTR(I)
C                 END IF
C7151         CONTINUE
C             DO 152 I = 1, IPTR(31)
C                 PRINT *,MSTACK(1,I),MSTACK(2,I),(KDATA(J,I),J=1,5)
C 152         CONTINUE
              IF (IDENT(1).LT.2) THEN
                  CALL FI8809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
              ELSE
                  CALL FI8810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
              END IF
C             DO 151 I = 1, 40
C                 IF (I.LE.20) THEN
C                     PRINT *,'IPTR(',I,')=',IPTR(I),
C    *                                       ' IDENT(',I,')= ',IDENT(I)
C                 ELSE
C                     PRINT *,'IPTR(',I,')=',IPTR(I)
C                 END IF
C 151         CONTINUE
              IF (IPTR(1).NE.0) THEN
                  RETURN
              END  IF
C
C             DO 154 I = 1, IPTR(31)
C                PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I)
C 154         CONTINUE
          END IF
      END IF
C                        IF DATA/DESCRIPTOR REPLICATION FLAG IS ON,
C                         MUST COMPLETE EXPANSION OF DATA AND
C                          DESCRIPTORS.
      IF (IPTR(38).EQ.1) THEN
          CALL FI8811(IPTR,IDENT,MSTACK,KDATA,KNR,
     *                  LDATA,LSTACK,MAXD,MAXR)
      END IF
C
C                        IF HAVE A LIST OF TABLE ENTRIES FROM
C                        A BUFR MESSAGE TYPE 11
C                        PRINT OUT THE ENTRIES
C
      IF (IDENT(5).EQ.11) THEN
C         DO 100 I = 1, IPTR(31)+IPTR(24)
C             PRINT *,I,MSTACK(1,I),(KDATA(J,I),J=1,4)
C 100     CONTINUE
          CALL FI8813 (IPTR,MAXR,MAXD,MSTACK,KDATA,IDENT,KPTRD,KPTRB,
     *         ITBLD,ANAME1,AUNIT1,KFXY1,ISCAL1,IRFVL1,IWIDE1,IUNITB)
      END IF
      RETURN
      END
      SUBROUTINE FI8801(IPTR,IDENT,MSGA,ISTACK,IWORK,KDATA,IVALS,
     *        MSTACK,KNR,INDEX,MAXR,MAXD,
     *        KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,IRF1SW,INEWVL,
     *        KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,
     *        KFXY3,ANAME3,AUNIT3,ISCAL3,IRFVL3,IWIDE3,
     *        IUNITB,IUNITD,ITBLD,ITBLD2,KPTRB,KPTRD)
C
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8801      DATA EXTRACTION
C   PRGMMR: KEYSER           ORG: NP22        DATE: 1995-06-07
C
C ABSTRACT: CONTROL THE EXTRACTION OF DATA FROM SECTION 4 BASED ON
C   DATA DESCRIPTORS.
C
C PROGRAM HISTORY LOG:
C 1988-09-01  CAVANAUGH
C 1991-01-18  CAVANAUGH   CORRECTIONS TO PROPERLY HANDLE NON-COMPRESSED
C                         DATA.
C 1991-09-23  CAVANAUGH   CODING ADDED TO HANDLE SINGLE SUBSETS WITH
C                         DELAYED REPLICATION.
C 1992-01-24  CAVANAUGH   MODIFIED TO ECHO DESCRIPTORS TO MSTACK(1,N)
C 1995-06-07  KEYSER      CORRECTED AN ERROR WHICH REQUIRED INPUT
C                         ARGUMENT "MAXD" TO BE NEARLY TWICE AS LARGE
C                         AS NEEDED FOR DECODING WIND PROFILER REPORTS
C                         (LIMIT UPPER BOUND FOR "IWORK" ARRAY WAS SET
C                         TO "MAXD", NOW IT IS SET TO 15000)
C
C USAGE:    CALL FI8801(IPTR,IDENT,MSGA,ISTACK,IWORK,KDATA,IVALS,
C    *        MSTACK,KNR,INDEX,MAXR,MAXD,
C    *        KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,IRF1SW,INEWVL,
C    *        KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,
C    *        KFXY3,ANAME3,AUNIT3,ISCAL3,IRFVL3,IWIDE3,
C    *        IUNITB,IUNITD,ITBLD,ITBLD2,KPTRB)
C
C   INPUT ARGUMENT LIST:
C     IPTR     - SEE W3FI88 ROUTINE DOCBLOCK
C     IDENT    - SEE W3FI88 ROUTINE DOCBLOCK
C     MSGA     - ARRAY CONTAINING BUFR MESSAGE
C     ISTACK   - ORIGINAL ARRAY OF DESCRIPTORS EXTRACTED FROM
C                SOURCE BUFR MESSAGE.
C     MSTACK   - WORKING ARRAY OF DESCRIPTORS (EXPANDED)AND SCALING
C                FACTOR
C     KFXY1    - IMAGE OF CURRENT DESCRIPTOR
C     INDEX    -
C     MAXR     - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE
C                CONTAINED IN A BUFR MESSAGE
C     MAXD     - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT
C                MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE
C                DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST
C                OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE
C     IUNITB   - UNIT NUMBER OF DATA SET HOLDING TABLE B
C     IUNITD   - UNIT NUMBER OF DATA SET HOLDING TABLE D
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     IWORK    - WORKING DESCRIPTOR LIST
C     KDATA    - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
C                KDATA(REPORT NUMBER,PARAMETER NUMBER)
C
C                (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
C                 MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
C                 ARGUMENT MAXD)
C
C     ISTACK   - SEE ABOVE
C            ARRAYS CONTAINING DATA FROM TABLE B
C     KFXY1    - SEE ABOVE
C     ANAME1   - DESCRIPTOR NAME
C     AUNIT1   - UNITS FOR DESCRIPTOR
C     ISCAL1   - SCALE FOR VALUE OF DESCRIPTOR
C     IRFVL1   - REFERENCE VALUE FOR DESCRIPTOR
C     IWIDE1   - BIT WIDTH FOR VALUE OF DESCRIPTOR
C
C   SUBPROGRAMS CALLED:
C     LIBRARY:
C       W3LIB    - FI8802 FI8805 FI8806 FI8807 FI8808
C
C REMARKS: ERROR RETURN:
C     IPTR(1) = 8   ERROR READING TABLE B
C             = 9   ERROR READING TABLE D
C             = 11  ERROR OPENING TABLE B
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  NAS
C
C$$$
C  ..................................................
C
C        NEW            ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE
C
      INTEGER        KFXY2(*),ISCAL2(*),IRFVL2(*),IWIDE2(*)
      CHARACTER*64   ANAME2(*)
      CHARACTER*24   AUNIT2(*)
C  ..................................................
C
C           NEW         ADDED TABLE B FROM NON-TYPE 11 BUFR MESSAGE
C
      INTEGER        KFXY3(200),ISCAL3(200),IRFVL3(200),IWIDE3(200)
      CHARACTER*64   ANAME3(200)
      CHARACTER*24   AUNIT3(200)
C  ..................................................
C
C     NEW               BASE TABLE B
C                            MAY BE A COMBINATION OF MASTER TABLE B
C                            AND ANCILLARY TABLE B
C
      INTEGER        KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*)
      CHARACTER*40   ANAME1(*)
      CHARACTER*24   AUNIT1(*)
C  ..................................................
C
C                       ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
C
      INTEGER        ITBLD2(20,*)
C  ..................................................
C
C                       NEW BASE TABLE D
C
      INTEGER        ITBLD(20,*)
C  ..................................................
C
C
      INTEGER        MAXD, MAXR
C
      INTEGER        MSGA(*),KDATA(MAXR,MAXD),IVALS(*)
C
      INTEGER        KNR(MAXR)
      INTEGER        LX,LY,LL,J
C     INTEGER        IHOLD(33)
      INTEGER        IPTR(*),KPTRB(*),KPTRD(*)
      INTEGER        IDENT(*)
      INTEGER        ISTACK(*),IWORK(*)
C
      INTEGER        MSTACK(2,MAXD)
C
      INTEGER        JDESC
      INTEGER        INDEX
C
      SAVE
C
C     PRINT *,' DECOLL FI8801'
      IF (INDEX.GT.1) THEN
              GO TO 1000
      END IF
C                      ---------  DECOLL  ---------------
      IPTR(23)    = 0
      IPTR(26)    = 0
      IPTR(27)    = 0
      IPTR(28)    = 0
      IPTR(29)    = 0
      IPTR(30)    = 0
      IPTR(36)    = 0
C                            INITIALIZE OUTPUT AREA
C                              SET POINTER TO BEGINNING OF DATA
C                                   SET BIT
      IPTR(17)   = 1
 1000 CONTINUE
C     IPTR(12)   = IPTR(13)
      LL         = 0
      IPTR(11)   = 1
      IF (IPTR(10).EQ.0) THEN
C                              RE-ENTRY POINT FOR MULTIPLE
C                                 NON-COMPRESSED REPORTS
      ELSE
          INDEX     = IPTR(15)
          IPTR(17)  = INDEX
          IPTR(25)  = IPTR(10)
          IPTR(10)  = 0
          IPTR(15)  = 0
      END IF
C     PRINT *,'FI8801 - RPT',IPTR(17),'  STARTS AT',IPTR(25)
      IPTR(24)  = 0
      IPTR(31)  = 0
C                              POINTING AT NEXT AVAILABLE DESCRIPTOR
      MM         = 0
      IF (IPTR(21).EQ.0) THEN
          NRDESC  = IPTR(13)
          CALL FI8812(IPTR,IUNITB,IUNITD,ISTACK,NRDESC,KPTRB,KPTRD,
     *                     IRF1SW,NEWREF,ITBLD,ITBLD2,
     *                     KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
     *                     KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2)
      END IF
   10     CONTINUE
C                              PROCESS THRU THE FOLLOWING
C                              DEPENDING UPON THE VALUE OF 'F' (LF)
          MM     = MM + 1
   12     CONTINUE
          IF (MM.GT.MAXD) THEN
              GO TO 200
          END IF
C                            END OF CYCLE TEST (SERIAL/SEQUENTIAL)
          IF (IPTR(11).GT.IPTR(12)) THEN
C             PRINT *,' HAVE COMPLETED REPORT SEQUENCE'
              IF (IDENT(16).NE.0) THEN
C                 PRINT *,' PROCESSING COMPRESSED REPORTS'
C                            REFORMAT DATA FROM DESCRIPTOR
C                            FORM TO USER FORM
                  RETURN
              ELSE
C                 WRITE (6,1)
C   1             FORMAT (1H1)
C                 PRINT *,' PROCESSED SERIAL REPORT',IPTR(17),IPTR(25)
                  IPTR(17) = IPTR(17) + 1
                  IF (IPTR(17).GT.IDENT(14)) THEN
                      IPTR(17)  = IPTR(17) - 1
                      GO TO 200
                  END IF
                  DO 300 I = 1, IPTR(13)
                      IWORK(I)  = ISTACK(I)
  300             CONTINUE
C                             RESET POINTERS
                  LL       = 0
                  IPTR(1)   = 0
                  IPTR(11)  = 1
                  IPTR(12)  = IPTR(13)
C                         IS THIS LAST REPORT ?
C                 PRINT *,'READY',IPTR(39),INDEX
                  IF (IPTR(39).GT.0) THEN
                      IF (INDEX.GT.0) THEN
C                         PRINT *,'HERE IS SUBSET NR',INDEX
                          RETURN
                      END IF
                  END IF
                  GO TO 1000
              END IF
          END IF
   14     CONTINUE
C                               GET NEXT DESCRIPTOR
          CALL FI8808 (IPTR,IWORK,LF,LX,LY,JDESC)
C         PRINT *,IPTR(11)-1,'JDESC= ',JDESC,' AND NEXT ',
C    *                       IPTR(11),IWORK(IPTR(11)),IPTR(31)
C         PRINT *,IPTR(11)-1,'DESCRIPTOR',JDESC,LF,LX,LY,
C    *       ' FOR LOC',IPTR(17),IPTR(25)
CVVVVVCHANGE#2 FIX BY KEYSER  -- 12/06/1994
C  NOTE: THIS FIX NEEDED BECAUSE IWORK ARRAY DOES NOT HAVE TO BE
C        LIMITED TO SIZE OF "MAXD" -- WASTES SPACE BECAUSE "MAXD"
C        MUST BECOME OVER TWICE AS LARGE AS NEEDED FOR PROFILERS
C        IN ORDER TO AVOID SATISFYING THIS BELOW IF TEST
CDAK      IF (IPTR(11).GT.MAXD) THEN
          IF (IPTR(11).GT.15000) THEN
CAAAAACHANGE#2 FIX BY KEYSER -- 12/06/1994
              IPTR(1)  = 401
              RETURN
          END IF
C
              KPRM        = IPTR(31) + IPTR(24)
              IF (KPRM.GT.MAXD) THEN
                  IF (KPRM.GT.KOLD) THEN
                      PRINT *,'EXCEEDED  ARRAY SIZE',KPRM,IPTR(31),
     *                        IPTR(24)
                      KOLD  = KPRM
                  END IF
              END IF
C                          REPLICATION PROCESSING
          IF (LF.EQ.1) THEN
C                                        ----------  F1  ---------
              IPTR(31)    = IPTR(31) + 1
              KPRM        = IPTR(31) + IPTR(24)
              MSTACK(1,KPRM)       = JDESC
              MSTACK(2,KPRM)       = 0
              KDATA(IPTR(17),KPRM) = 0
C             PRINT *,'FI8801-1',KPRM,MSTACK(1,KPRM),
C    *                       MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
              CALL FI8805(IPTR,IDENT,MSGA,IWORK,LX,LY,
     *                       KDATA,LL,KNR,MSTACK,MAXR,MAXD)
C    *                              KDATA,LL,KNR,MSTACK,MAXR,MAXD)
              IF (IPTR(1).NE.0) THEN
                  RETURN
              ELSE
                  GO TO 12
              END IF
C
C                             DATA DESCRIPTION OPERATORS
          ELSE IF (LF.EQ.2)THEN
              IF (LX.EQ.4) THEN
                  IPTR(31)       = IPTR(31) + 1
                  KPRM           = IPTR(31) + IPTR(24)
                  MSTACK(1,KPRM) = JDESC
                  MSTACK(2,KPRM) = 0
                  KDATA(IPTR(17),KPRM) = 0
C                 PRINT *,'FI8801-2',KPRM,MSTACK(1,KPRM),
C    *                       MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
              END IF
              CALL FI8806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK,
     *          IWIDE1,IRFVL1,ISCAL1,J,LL,KFXY1,IWORK,JDESC,MAXR,MAXD,
     *          KPTRB)
              IF (IPTR(1).NE.0) THEN
                  RETURN
              END IF
              GO TO 12
C                              DESCRIPTOR SEQUENCE STRINGS
          ELSE IF (LF.EQ.3) THEN
C             PRINT *,'F3  SEQUENCE DESCRIPTOR'
C                                  READ IN TABLE D, BUT JUST ONCE
              IF (IPTR(20).EQ.0) THEN
                  CALL FI8820 (ITBLD,IUNITD,IPTR,ITBLD2,KPTRD)
                  IF (IPTR(1).GT.0) THEN
                       RETURN
                  END IF
C             ELSE
C                 IF (IPTR(42).NE.0) THEN
C                     PRINT *,'MERGE',IPTR(42),' ENTRIES INTO TABLE D'
C                     CALL FI8819(IPTR,ITBLD,ITBLD2,KPTRD)
C                 END IF
              END IF
              CALL FI8807(IPTR,IWORK,ITBLD,ITBLD2,JDESC,KPTRD)
              IF (IPTR(1).GT.0) THEN
                   RETURN
              END IF
              GO TO 14
C
C                              ELEMENT DESCRIPTOR PROCESSING
C
          ELSE
              KPRM           = IPTR(31) + IPTR(24)
              CALL FI8802(IPTR,IDENT,MSGA,KDATA,KFXY1,LL,MSTACK,
     *          AUNIT1,IWIDE1,IRFVL1,ISCAL1,JDESC,IVALS,J,MAXR,MAXD,
     *          KPTRB)
C                             TURN OFF SKIP FLAG AFTER STD DESCRIPTOR
              IPTR(36)   = 0
              IF (IPTR(1).GT.0) THEN
                  RETURN
              ELSE
C
C                               IF ENCOUNTER CLASS 0 DESCRIPTOR
C                                  NOT CONTAINED WITHIN A BUFR
C                                  MESSAGE OF TYPE 11, THEN COLLECT
C                                  ALL TABLE B ENTRIES FOR USE ON
C                                  CURRENT BUFR MESSAGE
C
                  IF (JDESC.LE.20.AND.JDESC.GE.10) THEN
                      IF (IDENT(5).NE.11) THEN
C                                     COLLECT TABLE B ENTRIES
                          CALL FI8815(IPTR,IDENT,JDESC,KDATA,
     *                                KFXY3,MAXR,MAXD,ANAME3,AUNIT3,
     *                                ISCAL3,IRFVL3,IWIDE3,
     *                                KEYSET,IBFLAG,IERR)
                          IF (IERR.NE.0) THEN
                          END IF
                          IF (IAND(IBFLAG,16).NE.0) THEN
                            IF (IAND(IBFLAG,8).NE.0) THEN
                              IF (IAND(IBFLAG,4).NE.0) THEN
                                IF (IAND(IBFLAG,2).NE.0) THEN
                                  IF (IAND(IBFLAG,1).NE.0) THEN
C                                          HAVE A COMPLETE TABLE B ENTRY
                                    IPTR(43) = IPTR(43) + IDENT(14)
                                    KEYSET  = 0
                                    IBFLAG  = 0
                                    GO TO 1000
                                  END IF
                                END IF
                              END IF
                            END IF
                          END IF
                      END IF
                  END IF
                  IF (IDENT(16).EQ.0) THEN
                      KNR(IPTR(17))  = IPTR(31)
                  ELSE
                      DO 310 KJ = 1, MAXR
                          KNR(KJ) = IPTR(31)
  310                 CONTINUE
                  END IF
                  GO TO 10
              END IF
          END IF
C     END IF
C         END DO WHILE
  200 CONTINUE
C     IF (IDENT(16).NE.0) THEN
C         PRINT *,'RETURN WITH',IDENT(14),' COMPRESSED REPORTS'
C     ELSE
C         PRINT *,'RETURN WITH',IPTR(17),' NON-COMPRESSED REPORTS'
C     END IF
      RETURN
      END
      SUBROUTINE FI8802(IPTR,IDENT,MSGA,KDATA,KFXY1,LL,MSTACK,AUNIT1,
     *      IWIDE1,IRFVL1,ISCAL1,JDESC,IVALS,J,MAXR,MAXD,KPTRB)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8802      PROCESS ELEMENT DESCRIPTOR
C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 88-09-01
C
C ABSTRACT: PROCESS AN ELEMENT DESCRIPTOR (F = 0) AND STORE DATA
C   IN OUTPUT ARRAY.
C
C PROGRAM HISTORY LOG:
C   88-09-01  CAVANAUGH
C   91-04-04  CAVANAUGH   CHANGED TO PASS WIDTH OF TEXT FIELDS IN BYTES
C
C USAGE:    CALL FI8802(IPTR,IDENT,MSGA,KDATA,KFXY1,LL,MSTACK,AUNIT1,
C                   IWIDE1,IRFVL1,ISCAL1,JDESC,IVALS,J,MAXR,MAXD,KPTRB)
C   INPUT ARGUMENT LIST:
C     IPTR     - SEE W3FI88 ROUTINE DOCBLOCK
C     IDENT    - SEE W3FI88 ROUTINE DOCBLOCK
C     MSGA     - ARRAY CONTAINING BUFR MESSAGE
C     KDATA    - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
C                KDATA(REPORT NUMBER,PARAMETER NUMBER)
C                (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
C                 MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
C                 ARGUMENT MAXD)
C     KFXY1    - IMAGE OF CURRENT DESCRIPTOR
C     ANAME1   - LIST OF NAME OF DESCRIPTOR CONTENTS
C     MSTACK   -
C     MAXR     - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE
C                CONTAINED IN A BUFR MESSAGE
C     MAXD     - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT
C                MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE
C                DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST
C                OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     KDATA    - SEE ABOVE
C     KFXY1    - SEE ABOVE
C            ARRAYS CONTAINING DATA FROM TABLE B
C     AUNIT1   - UNITS FOR DESCRIPTOR
C     ISCAL1   - SCALE FOR VALUE OF DESCRIPTOR
C     IRFVL1   - REFERENCE VALUE FOR DESCRIPTOR
C     IWIDE1   - BIT WIDTH FOR VALUE OF DESCRIPTOR
C
C   SUBPROGRAMS CALLED:
C     LIBRARY:
C       W3LIB    - FI8803 FI8804
C
C REMARKS: ERROR RETURN:
C IPTR(1) = 3     - MESSAGE CONTAINS A DESCRIPTOR WITH F=0
C                   THAT DOES NOT EXIST IN TABLE B.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  NAS
C
C$$$
C                                          TABLE B ENTRY
      CHARACTER*24   ASKEY
      INTEGER        MSGA(*)
      INTEGER        IPTR(*)
      INTEGER        KPTRB(*)
      INTEGER        IDENT(*)
      INTEGER        J
      INTEGER        JDESC
      INTEGER        MSTACK(2,MAXD)
      INTEGER        KDATA(MAXR,MAXD),IVALS(*)
C  ..................................................
C
C     NEW               BASE TABLE B
C                            MAY BE A COMBINATION OF MASTER TABLE B
C                            AND ANCILLARY TABLE B
C
      INTEGER        KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*)
C     CHARACTER*40   ANAME1(*)
      CHARACTER*24   AUNIT1(*)
C  ..................................................
      SAVE
C
      DATA  ASKEY /'CCITT IA5               '/
C
C     PRINT *,' FI8802 - ELEMENT DESCRIPTOR ',JDESC,KPTRB(JDESC)
C                                      FIND TABLE B ENTRY
      J  = KPTRB(JDESC)
C                                   HAVE A MATCH
C                                        SET FLAG IF TEXT EVENT
C     PRINT *,'ASKEY=',ASKEY,'AUNIT1(',J,')=',AUNIT1(J),JDESC
      IF (ASKEY(1:9).EQ.AUNIT1(J)(1:9)) THEN
          IPTR(18)     = 1
          IPTR(40)     = IWIDE1(J) / 8
      ELSE
          IPTR(18)     = 0
      END IF
C     PRINT *,'FI8802 - BIT WIDTH =',IWIDE1(J),IPTR(18),' FOR',JDESC
      IF (IDENT(16).NE.0) THEN
C                                   COMPRESSED
          CALL FI8803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK,
     *                IWIDE1,IRFVL1,ISCAL1,J,JDESC,MAXR,MAXD)
C         IF (IPTR(1).NE.0) THEN
C             RETURN
C         END IF
      ELSE
C                                   NOT COMPRESSED
C         PRINT *,' FROM FI8802',J
          CALL FI8804(IPTR,MSGA,KDATA,IVALS,MSTACK,
     *                  IWIDE1,IRFVL1,ISCAL1,J,LL,JDESC,MAXR,MAXD)
C         IF (IPTR(1).NE.0) THEN
C             RETURN
C         END IF
      END IF
      RETURN
      END
C -----------------------------------------------------
      SUBROUTINE FI8803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK,
     *                      IWIDE1,IRFVL1,ISCAL1,J,JDESC,MAXR,MAXD)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8803      PROCESS COMPRESSED DATA
C   PRGMMR: KEYSER           ORG: NP22       DATE: 1995-06-07
C
C ABSTRACT: PROCESS COMPRESSED DATA AND PLACE INDIVIDUAL ELEMENTS
C   INTO OUTPUT ARRAY.
C
C PROGRAM HISTORY LOG:
C 1988-09-01  CAVANAUGH
C 1991-04-04  CAVANAUGH  TEXT HANDLING PORTION OF THIS ROUTINE
C                        MODIFIED TO HANLE WIDTH OF FIELDS IN BYTES.
C 1991-04-17  CAVANAUGH  TESTS SHOWED THAT THE SAME DATA IN COMPRESSED
C                        AND UNCOMPRESSED FORM GAVE DIFFERENT RESULTS.
C                        THIS HAS BEEN CORRECTED.
C 1991-06-21  CAVANAUGH  PROCESSING OF TEXT DATA HAS BEEN CHANGED TO
C                        PROVIDE EXACT REPRODUCTION OF ALL CHARACTERS.
C 1994-04-11  CAVANAUGH  CORRECTED PROCESSING OF DATA WHEN ALL VALUES
C                        THE SAME (NBINC = 0). CORRECTED TEST OF LOWEST
C                        VALUE AGAINST PROPER BIT MASK.
C 1995-06-07  KEYSER     CORRECTED AN ERROR WHICH RESULTED IN
C                        RETURNED SCALE IN "MSTACK(2, ..)" ALWAYS
C                        BEING SET TO ZERO FOR COMPRESSED DATA.  ALSO,
C                        SCALE CHANGES WERE NOT BEING RECOGNIZED.
C
C USAGE:    CALL FI8803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK,
C                           IWIDE1,IRFVL1,ISCAL1,J,JDESC,MAXR,MAXD)
C   INPUT ARGUMENT LIST:
C     IPTR     - SEE W3FI88 ROUTINE DOCBLOCK
C     IDENT    - SEE W3FI88 ROUTINE DOCBLOCK
C     MSGA     - ARRAY CONTAINING BUFR MESSAGE,MSTACK,
C     IVALS    - ARRAY OF SINGLE PARAMETER VALUES
C     J        -
C     MAXR     - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE
C                CONTAINED IN A BUFR MESSAGE
C     MAXD     - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT
C                MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE
C                DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST
C                OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     KDATA    - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
C                KDATA(REPORT NUMBER,PARAMETER NUMBER)
C                (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
C                 MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
C                 ARGUMENT MAXD)
C     J        -
C            ARRAYS CONTAINING DATA FROM TABLE B
C     ISCAL1   - SCALE FOR VALUE OF DESCRIPTOR
C     IRFVL1   - REFERENCE VALUE FOR DESCRIPTOR
C     IWIDE1   - BIT WIDTH FOR VALUE OF DESCRIPTOR
C
C   SUBPROGRAMS CALLED:
C     LIBRARY:
C       W3LIB    - GBYTE  GBYTES W3AI39
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  NAS
C
C$$$
C
C  ..................................................
C
C     NEW               BASE TABLE B
C                            MAY BE A COMBINATION OF MASTER TABLE B
C                            AND ANCILLARY TABLE B
C
C     INTEGER        KFXY1(*)
      INTEGER        ISCAL1(*)
      INTEGER        IRFVL1(3,*)
      INTEGER        IWIDE1(*)
C     CHARACTER*40   ANAME1(*)
C     CHARACTER*24   AUNIT1(*)
C  ..................................................
      INTEGER        MAXD,MAXR
      INTEGER        MSGA(*),JDESC,MSTACK(2,MAXD)
      INTEGER        IPTR(*),IVALS(*),KDATA(MAXR,MAXD)
      INTEGER        NRVALS,JWIDE,IDATA
      INTEGER        IDENT(*)
      INTEGER        J
      INTEGER        KLOW(256)
C
      LOGICAL        TEXT
C
      INTEGER        MSK(32)
C
      SAVE
C
      DATA   MSK  /1,  3,  7,  15,  31,  63,  127,
C                  1   2   3   4    5    6    7
     *             255,  511,  1023,  2047,  4095,
C                  8     9     10     11     12
     *             8191,  16383,  32767,  65535,
C                  13     14      15      16
     *             131071,  262143,  524287,
C                  17       18       19
     *             1048575, 2097151,  4194303,
C                  20       21        22
     *             8388607,  16777215,  33554431,
C                  23        24         25
     *             67108863,  134217727,  268435455,
C                  26         27          28
     *             536870911, 1073741823, 2147483647,-1     /
C                  29         30          31          32
      CALL W3FI01(LW)
      MWDBIT  = IPTR(44)
      IF (IPTR(45).EQ.8) THEN
          I        = 2147483647
          MSK(32)  = I + I + 1
      END IF
C
C     PRINT *,' FI8803  COMPR    J=',J,' IWIDE1(J) =',IWIDE1(J),
C    *             ' EXTRA BITS =',IPTR(26),' START AT',IPTR(25)
      IF (IPTR(18).EQ.0) THEN
          TEXT    = .FALSE.
      ELSE
          TEXT    = .TRUE.
      END IF
C     PRINT *,'DESCRIPTOR',KPRM,JDESC
      IF (.NOT.TEXT) THEN
          IF (IPTR(29).GT.0.AND.JDESC.NE.7957) THEN
C             PRINT *,'ASSOCIATED FIELD AT',IPTR(25)
C                        WORKING WITH ASSOCIATED FIELDS HERE
              IPTR(31)   = IPTR(31) + 1
              KPRM       = IPTR(31) + IPTR(24)
C                        GET LOWEST
              CALL GBYTE (MSGA,LOWEST,IPTR(25),IPTR(29))
              IPTR(25)   = IPTR(25) + IPTR(29)
C                        GET NBINC
              CALL GBYTE (MSGA,NBINC,IPTR(25),6)
              IPTR(25)   = IPTR(25) + 6
C             PRINT *,'LOWEST=',LOWEST,' NBINC=',NBINC
              IF (NBINC.GT.32) THEN
                  IPTR(1)  = 22
                  RETURN
              END IF
C                        EXTRACT DATA FOR ASSOCIATED FIELD
              IF (NBINC.GT.0) THEN
                  CALL GBYTES (MSGA,IVALS,IPTR(25),NBINC,0,IPTR(21))
                  IPTR(25)   = IPTR(25) + NBINC * IPTR(21)
                  DO 50 I = 1, IDENT(14)
                      KDATA(I,KPRM) = IVALS(I) + LOWEST
                      IF (NBINC.EQ.32) THEN
                          IF (KDATA(I,KPRM).EQ.MSK(NBINC)) THEN
                              KDATA(I,KPRM) = 999999
                          END IF
                      ELSE IF (KDATA(I,KPRM).GE.MSK(NBINC)) THEN
                          KDATA(I,KPRM) = 999999
                      END IF
   50             CONTINUE
              ELSE
                  DO 51 I = 1, IDENT(14)
                      KDATA(I,KPRM) = LOWEST
                      IF (NBINC.EQ.32) THEN
                          IF (LOWEST.EQ.MSK(32)) THEN
                              KDATA(I,KPRM) = 999999
                          END IF
                      ELSE IF(LOWEST.GE.MSK(NBINC)) THEN
                          KDATA(I,KPRM) = 999999
                      END IF
   51             CONTINUE
              END IF
          END IF
C                                       SET PARAMETER
C                                       ISOLATE COMBINED BIT WIDTH
          JWIDE     = IWIDE1(J) + IPTR(26)
C
          IF (JWIDE.GT.32) THEN
C                                       TOO MANY BITS IN COMBINED
C                                       BIT WIDTH
              PRINT *,'ERR 22 - HAVE EXCEEDED COMBINED BIT WIDTH'
              IPTR(1)  = 22
              RETURN
          END IF
C                                       SINGLE VALUE FOR LOWEST
          NRVALS    = 1
C                                       LOWEST
C         PRINT *,'PARAM',KPRM
          CALL GBYTE (MSGA,LOWEST,IPTR(25),JWIDE)
C         PRINT *,'            LOWEST=',LOWEST,' AT BIT LOC ',IPTR(25)
          IPTR(25)  = IPTR(25) + JWIDE
C                                       ISOLATE COMPRESSED BIT WIDTH
          CALL GBYTE (MSGA,NBINC,IPTR(25),6)
C         PRINT *,'            NBINC=',NBINC,' AT BIT LOC',IPTR(25)
          IF (NBINC.GT.32) THEN
C                                NBINC TOO LARGE
              IPTR(1)  = 22
              RETURN
          END IF
          IF (IPTR(32).EQ.2.AND.IPTR(33).EQ.5) THEN
          ELSE
              IF (NBINC.GT.JWIDE) THEN
C                 PRINT *,'FOR DESCRIPTOR',JDESC
C              PRINT *,J,'NBINC=',NBINC,' LOWEST=',LOWEST,' IWIDE1(J)=',
C    *          IWIDE1(J),' IPTR(26)=',IPTR(26),' AT BIT LOC',IPTR(25)
C                 DO 110 I = 1, KPRM
C                     WRITE (6,111)I,(KDATA(J,I),J=1,6)
C 110             CONTINUE
C 111             FORMAT (1X,5HDATA ,I3,6(2X,I10))
                  IPTR(1) = 500
                  PRINT *,'NBINC CALLS FOR LARGER BIT WIDTH THAN TABLE',
     *                       ' B  PLUS  WIDTH CHANGES'
              END IF
          END IF
          IPTR(25)  = IPTR(25) + 6
C         PRINT *,'LOWEST',LOWEST,' NBINC=',NBINC
C                                       IF TEXT EVENT, PROCESS TEXT
C                                       GET COMPRESSED VALUES
C         PRINT *,'COMPRESSED VALUES - NONTEXT'
          NRVALS    = IDENT(14)
          IPTR(31)  = IPTR(31) + 1
          KPRM      = IPTR(31) + IPTR(24)
          IF (NBINC.NE.0) THEN
              CALL GBYTES (MSGA,IVALS,IPTR(25),NBINC,0,NRVALS)
              IPTR(25)  = IPTR(25) + NBINC * NRVALS
C                                       RECALCULATE TO ORIGINAL VALUES
              DO 100 I = 1, NRVALS
C                 PRINT *,IVALS(I),MSK(NBINC),NBINC
                  IF (IVALS(I).GE.MSK(NBINC)) THEN
                      KDATA(I,KPRM) = 999999
                  ELSE
                      IF (IRFVL1(2,J).EQ.0) THEN
                         JRV  = IRFVL1(1,J)
                     ELSE
                         JRV  = IRFVL1(3,J)
                     END IF
                     KDATA(I,KPRM) = IVALS(I) + LOWEST + JRV
                  END IF
  100         CONTINUE
C             PRINT *,I,JDESC,LOWEST,IRFVL1(1,J),IRFVL1(3,J)
          ELSE
              IF (LOWEST.EQ.MSK(JWIDE)) THEN
                  DO 105 I = 1, NRVALS
                      KDATA(I,KPRM)    = 999999
  105             CONTINUE
              ELSE
                  IF (IRFVL1(2,J).EQ.0) THEN
                      JRV  = IRFVL1(1,J)
                  ELSE
                      JRV  = IRFVL1(3,J)
                  END IF
                  ICOMB  = LOWEST + JRV
                  DO 106 I = 1, NRVALS
                      KDATA(I,KPRM) = ICOMB
  106             CONTINUE
              END IF
          END IF
C         PRINT *,'KPRM=',KPRM,'  IPTR(25)=',IPTR(25)
          MSTACK(1,KPRM)  = JDESC
C         WRITE (6,80) (KDATA(I,KPRM),I=1,10)
   80     FORMAT(2X,10(F10.2,1X))
CVVVVVCHANGE#3 FIX BY KEYSER  -- 12/06/1994
C  NOTE: THIS FIX NEEDED BECAUSE THE RETURNED SCALE IN MSTACK(2,..)
C        WAS ALWAYS '0' FOR COMPRESSED DATA, INCL. CHANGED SCALES)
          MSTACK(2,KPRM) = ISCAL1(J) + IPTR(27)
CAAAAACHANGE#3 FIX BY KEYSER  -- 12/06/1994
      ELSE IF (TEXT) THEN
C         PRINT *,' FOUND TEXT MODE IN COMPRESSED DATA',IPTR(40)
C                                   GET LOWEST
C         PRINT *,' PICKED UP LOWEST',(KLOW(K),K=1,IPTR(40))
          DO 1906 K = 1, IPTR(40)
              CALL GBYTE (MSGA,KLOW,IPTR(25),8)
              IPTR(25)   = IPTR(25) + 8
              IF (KLOW(K).NE.0) THEN
                  IPTR(1)   = 27
                  PRINT *,'NON-ZERO LOWEST ON TEXT DATA'
                  RETURN
              END IF
 1906     CONTINUE
C         PRINT *,'TEXT - LOWEST = 0'
C                                   GET NBINC
          CALL GBYTE (MSGA,NBINC,IPTR(25),6)
          IPTR(25)     = IPTR(25) + 6
          IF (NBINC.NE.IPTR(40)) THEN
              IPTR(1)  = 28
              PRINT *,'NBINC IS NOT THE NUMBER OF CHARACTERS',NBINC
              RETURN
          END IF
C         PRINT *,'TEXT    NBINC =',NBINC
C                                   FOR NUMBER OF OBSERVATIONS
          IPTR(31)      = IPTR(31) + 1
          KPRM          = IPTR(31) + IPTR(24)
          ISTART        = KPRM
          I24           = IPTR(24)
          DO 1900 N   = 1, IDENT(14)
              KPRM        = ISTART
              IPTR(24)    = I24
              NBITS       = IPTR(40) * 8
 1700         CONTINUE
C             PRINT *,N,IDENT(14),'KPRM-B=',KPRM,IPTR(24),NBITS
              IF (NBITS.GT.MWDBIT) THEN
                  CALL GBYTE (MSGA,IDATA,IPTR(25),MWDBIT)
                  IPTR(25)     = IPTR(25) + MWDBIT
                  NBITS        = NBITS - MWDBIT
                  IF (IPTR(37).EQ.0) THEN
C                               CONVERTS ASCII TO EBCIDIC
                      CALL W3AI39 (IDATA,LW)
                  END IF
                  MSTACK(1,KPRM) = JDESC
                  MSTACK(2,KPRM) = 0
                  KDATA(N,KPRM) = IDATA
C                 PRINT *,'TEXT        ',N,KPRM,KDATA(N,KPRM)
C                         SET FOR NEXT PART
                  KPRM          = KPRM + 1
                  IPTR(24)      = IPTR(24) + 1
C                 PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA
C1701             FORMAT (1X,I1,1X,6HKDATA=,A4,2X,I5,2X,I5,2X,I5,2X,I12)
                  GO TO 1700
              ELSE IF (NBITS.GT.0) THEN
                  CALL GBYTE (MSGA,IDATA,IPTR(25),NBITS)
                  IPTR(25)     = IPTR(25) + NBITS
                  IBUF         = (IPTR(44) - NBITS) / 8
                  IF (IBUF.GT.0) THEN
                      DO 1750 MP = 1, IBUF
                          IDATA  = IDATA * 256 + 32
 1750                 CONTINUE
                  END IF
C                               CONVERTS ASCII TO EBCIDIC
                  IF (IPTR(37).EQ.0) THEN
                      CALL W3AI39 (IDATA,LW)
                  END IF
                  MSTACK(1,KPRM) = JDESC
                  MSTACK(2,KPRM) = 0
                  KDATA(N,KPRM) = IDATA
C                 PRINT *,'TEXT        ',N,KPRM,KDATA(N,KPRM)
C                 PRINT 1701,2,KDATA(N,KPRM),N,KPRM,NBITS
                  NBITS          = 0
              END IF
C             WRITE (6,1800)N,(KDATA(N,I),I=KPRS,KPRM)
C1800         FORMAT (2X,I4,2X,3A4)
 1900     CONTINUE
      END IF
      RETURN
      END
C -----------------------------------------------------
      SUBROUTINE FI8804(IPTR,MSGA,KDATA,IVALS,MSTACK,
     *                  IWIDE1,IRFVL1,ISCAL1,J,LL,JDESC,MAXR,MAXD)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8804      PROCESS SERIAL DATA
C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 88-09-01
C
C ABSTRACT: PROCESS DATA THAT IS NOT COMPRESSED
C
C PROGRAM HISTORY LOG:
C   88-09-01  CAVANAUGH
C   91-01-18  CAVANAUGH   MODIFIED TO PROPERLY HANDLE NON-COMPRESSED
C                         DATA.
C   91-04-04  CAVANAUGH   TEXT HANDLING PORTION OF THIS ROUTINE
C                         MODIFIED TO HANDLE FIELD WIDTH IN BYTES.
C   91-04-17  CAVANAUGH  TESTS SHOWED THAT THE SAME DATA IN COMPRESSED
C                        AND UNCOMPRESSED FORM GAVE DIFFERENT RESULTS.
C                        THIS HAS BEEN CORRECTED.
C
C USAGE:    CALL FI8804(IPTR,MSGA,KDATA,IVALS,MSTACK,
C                           IWIDE1,IRFVL1,ISCAL1,J,LL,JDESC,MAXR,MAXD)
C   INPUT ARGUMENT LIST:
C     IPTR     - SEE W3FI88 ROUTINE DOCBLOCK
C     MSGA     - ARRAY CONTAINING BUFR MESSAGE
C     IVALS     - ARRAY OF SINGLE PARAMETER VALUES
C     J        -
C     MAXR     - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE
C                CONTAINED IN A BUFR MESSAGE
C     MAXD     - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT
C                MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE
C                DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST
C                OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     KDATA    - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
C                KDATA(REPORT NUMBER,PARAMETER NUMBER)
C                (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
C                 MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
C                 ARGUMENT MAXD)
C     IVALS     - SEE ABOVE
C     J        - SEE ABOVE
C            ARRAYS CONTAINING DATA FROM TABLE B
C     ISCAL1   - SCALE FOR VALUE OF DESCRIPTOR
C     IRFVL1   - REFERENCE VALUE FOR DESCRIPTOR
C     IWIDE1   - BIT WIDTH FOR VALUE OF DESCRIPTOR
C
C   SUBPROGRAMS CALLED:
C     LIBRARY:
C       W3LIB    - GBYTE
C
C REMARKS: ERROR RETURN:
C IPTR(1) = 13   - BIT WIDTH ON ASCII CHARS NOT A MULTIPLE OF 8
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  NAS
C
C$$$
C  ..................................................
C
C     NEW               BASE TABLE B
C                            MAY BE A COMBINATION OF MASTER TABLE B
C                            AND ANCILLARY TABLE B
C
C     INTEGER        KFXY1(*)
      INTEGER        ISCAL1(*)
      INTEGER        IRFVL1(3,*)
      INTEGER        IWIDE1(*)
C     CHARACTER*40   ANAME1(*)
C     CHARACTER*24   AUNIT1(*)
C  ..................................................
C
      INTEGER        MSGA(*),MAXD,MAXR
      INTEGER        IPTR(*)
      INTEGER        JDESC
      INTEGER        IVALS(*)
C     INTEGER        LSTBLK(3)
      INTEGER        KDATA(MAXR,MAXD),MSTACK(2,MAXD)
      INTEGER        J,LL
C     LOGICAL        LKEY
C
C
      INTEGER        ITEST(32)
C
       SAVE
C
      DATA  ITEST  /1,3,7,15,31,63,127,255,
     *             511,1023,2047,4095,8191,16383,
     *             32767, 65535,131071,262143,524287,
     *             1048575,2097151,4194303,8388607,
     *             16777215,33554431,67108863,134217727,
     *             268435455,536870911,1073741823,
     *             2147483647,-1/
C
      MWDBIT  = IPTR(44)
      IF (IPTR(45).NE.4) THEN
          I         = 2147483647
          ITEST(32) = I + I + 1
      END IF
C
C     PRINT *,' FI8804 NOCMP',J,JDESC,IWIDE1(J),IPTR(26),IPTR(25)
C                  --------  NOCMP  --------
C                                       IF NOT TEXT EVENT, PROCESS
      IF (IPTR(18).EQ.0) THEN
C          PRINT *,'                              NOT TEXT'
          IF ((IPTR(26)+IWIDE1(J)).LT.1) THEN
C            PRINT *,' FI8804 NOCMP',J,JDESC,IWIDE1(J),IPTR(26),IPTR(25)
              IPTR(1)  = 501
              RETURN
          END IF
C                                ISOLATE BIT WIDTH
          JWIDE    = IWIDE1(J) + IPTR(26)
C                                    IF ASSOCIATED FIELD SW ON
          IF (IPTR(29).GT.0) THEN
              IF (JDESC.NE.7957.AND.JDESC.NE.7937) THEN
                  IPTR(31)        = IPTR(31) + 1
                  KPRM            = IPTR(31) + IPTR(24)
                  MSTACK(1,KPRM)  = 33792 + IPTR(29)
                  MSTACK(2,KPRM)  = 0
                  CALL GBYTE (MSGA,IVALS,IPTR(25),IPTR(29))
                  IPTR(25)        = IPTR(25) + IPTR(29)
                  KDATA(IPTR(17),KPRM) = IVALS(1)
C                 PRINT *,'FI8804-A',KPRM,MSTACK(1,KPRM),
C    *                      MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM)
              END IF
          END IF
          IPTR(31) = IPTR(31) + 1
          KPRM     = IPTR(31) + IPTR(24)
          MSTACK(1,KPRM) = JDESC
C         IF (IPTR(27).NE.0) THEN
C             MSTACK(2,KPRM) = IPTR(27)
C         ELSE
              MSTACK(2,KPRM) = ISCAL1(J) + IPTR(27)
C         END IF
C                                       GET VALUES
C                                CALL TO GET DATA OF GIVEN BIT WIDTH
          CALL GBYTE (MSGA,IVALS,IPTR(25),JWIDE)
C         PRINT *,'DATA  TO',IPTR(17),KPRM,IVALS(1),JWIDE,IPTR(25)
          IPTR(25) = IPTR(25) + JWIDE
C                                RETURN WITH SINGLE VALUE
          IF (IRFVL1(2,J).EQ.0) THEN
              JRV  = IRFVL1(1,J)
          ELSE
              JRV  = IRFVL1(3,J)
          END IF
          IF (JWIDE.EQ.32) THEN
              IF (IVALS(1).EQ.ITEST(JWIDE)) THEN
                  KDATA(IPTR(17),KPRM) = 999999
              ELSE
                  KDATA(IPTR(17),KPRM) = IVALS(1) + JRV
              END IF
          ELSE IF (IVALS(1).GE.ITEST(JWIDE)) THEN
              KDATA(IPTR(17),KPRM) = 999999
          ELSE
              KDATA(IPTR(17),KPRM) = IVALS(1) + JRV
          END IF
C         PRINT *,'FI8804-B',KPRM,MSTACK(1,KPRM),
C    *                     MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM)
C         IF(JDESC.EQ.2049) THEN
C             PRINT *,'VERT SIG =',KDATA(IPTR(17),KPRM)
C         END IF
C         PRINT *,'FI8804  ',KPRM,MSTACK(1,KPRM),
C    *                       MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
      ELSE
C         PRINT *,'                             TEXT'
C         PRINT *,' FOUND TEXT MODE ****** NOT COMPRESSED *********'
          JWIDE      = IPTR(40) * 8
C         PRINT *,'                              WIDTH =',JWIDE,IPTR(40)
          NRCHRS     = IPTR(40)
          NRBITS     = JWIDE
C         PRINT *,'          CHARS =',NRCHRS,' BITS =',NRBITS
          IPTR(31)        = IPTR(31) + 1
          KANY   = 0
 1800     CONTINUE
          KANY  = KANY + 1
C         PRINT *,'          NR BITS THIS PASS',NRBITS
          IF (NRBITS.GT.MWDBIT) THEN
              CALL GBYTE (MSGA,IDATA,IPTR(25),MWDBIT)
C             PRINT 1801,KANY,IDATA,IPTR(17),KPRM,NRBITS
 1801         FORMAT (1X,I2,4X,Z8,2(4X,I4))
C                               CONVERTS ASCII TO EBCIDIC
C                               COMMENT OUT IF NOT IBM370 COMPUTER
              IF (IPTR(37).EQ.0) THEN
                  CALL W3AI39 (IDATA,IPTR(45))
              END IF
              KPRM            = IPTR(31) + IPTR(24)
              KDATA(IPTR(17),KPRM)  = IDATA
              MSTACK(1,KPRM)  = JDESC
              MSTACK(2,KPRM)  = 0
C             PRINT *,'BODY ',KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM),
C    *                   KDATA(IPTR(17),KPRM)
              IPTR(25)    = IPTR(25) + MWDBIT
              NRBITS      = NRBITS - MWDBIT
              IPTR(24)    = IPTR(24) + 1
              GO TO 1800
          ELSE IF (NRBITS.GT.0) THEN
              CALL GBYTE (MSGA,IDATA,IPTR(25),NRBITS)
              IPTR(25)    = IPTR(25) + NRBITS
C                               CONVERTS ASCII TO EBCIDIC
C                               COMMENT OUT IF NOT IBM370 COMPUTER
              IF (IPTR(37).EQ.0) THEN
                  CALL W3AI39 (IDATA,IPTR(45))
              END IF
              KPRM            = IPTR(31) + IPTR(24)
              KSHFT           = MWDBIT - NRBITS
              IF (KSHFT.GT.0) THEN
                  KTRY  = KSHFT / 8
                  DO  1722  LAK = 1, KTRY
                      IF (IPTR(37).EQ.0) THEN
                          IDATA  = IDATA * 256 + 64
                      ELSE
                          IDATA  = IDATA * 256 + 32
                      END IF
C                     PRINT 1723,IDATA
C1723                 FORMAT (12X,Z8)
 1722             CONTINUE
              END IF
              KDATA(IPTR(17),KPRM) = IDATA
C             PRINT 1801,KANY,IDATA,KDATA(IPTR(17),KPRM),KPRM
              MSTACK(1,KPRM)  = JDESC
              MSTACK(2,KPRM)  = 0
C             PRINT *,'TAIL ',KPRM,MSTACK(1,KPRM),
C    *                   KDATA(IPTR(17),KPRM)
          END IF
      END IF
      RETURN
      END
C -----------------------------------------------------
      SUBROUTINE FI8805(IPTR,IDENT,MSGA,IWORK,LX,LY,
     *                          KDATA,LL,KNR,MSTACK,MAXR,MAXD)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8805      PROCESS A REPLICATION DESCRIPTOR
C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 88-09-01
C
C ABSTRACT: PROCESS A REPLICATION DESCRIPTOR, MUST EXTRACT NUMBER
C   OF REPLICATIONS OF N DESCRIPTORS FROM THE DATA STREAM.
C
C PROGRAM HISTORY LOG:
C   88-09-01  CAVANAUGH
C   YY-MM-DD  MODIFIER2   DESCRIPTION OF CHANGE
C
C USAGE:    CALL FI8805(IPTR,IDENT,MSGA,IWORK,LX,LY,
C    *                                  KDATA,LL,KNR,MSTACK,MAXR,MAXD)
C   INPUT ARGUMENT LIST:
C     IWORK    - WORKING DESCRIPTOR LIST
C     IPTR     - SEE W3FI88 ROUTINE DOCBLOCK
C     IDENT    - SEE W3FI88 ROUTINE DOCBLOCK
C     LX       - X PORTION OF CURRENT DESCRIPTOR
C     LY       - Y PORTION OF CURRENT DESCRIPTOR
C     MAXR     - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE
C                CONTAINED IN A BUFR MESSAGE
C     MAXD     - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT
C                MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE
C                DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST
C                OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     KDATA    - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
C                KDATA(REPORT NUMBER,PARAMETER NUMBER)
C                (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
C                 MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
C                 ARGUMENT MAXD)
C     LX       - SEE ABOVE
C     LY       - SEE ABOVE
C
C   SUBPROGRAMS CALLED:
C     LIBRARY:
C       W3LIB    - GBYTES FI8808
C
C REMARKS: ERROR RETURN:
C    IPTR(1) = 12  DATA DESCRIPTOR QUALIFIER DOES NOT FOLLOW
C                  DELAYED REPLICATION DESCRIPTOR
C            = 20  EXCEEDED COUNT FOR DELAYED REPLICATION PASS
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  NAS
C
C$$$
C
      INTEGER        IPTR(*)
      INTEGER        KNR(MAXR)
      INTEGER        ITEMP(2000)
      INTEGER        LL
      INTEGER        KTEMP(2000)
      INTEGER        KDATA(MAXR,MAXD)
      INTEGER        LX,MSTACK(2,MAXD)
      INTEGER        LY
      INTEGER        MSGA(*)
      INTEGER        KVALS(1300)
CVVVVVCHANGE#2 FIX BY KEYSER  -- 12/06/1994
C  NOTE: THIS FIX JUST CLEANS UP CODE SINCE IWORK ARRAY IS EARLIER
C        DEFINED AS 15000 WORDS
      INTEGER        IWORK(*)
CDAK  INTEGER        IWORK(MAXD)
CAAAAACHANGE#2 FIX BY KEYSER  -- 12/06/1994
      INTEGER        IDENT(*)
C
      SAVE
C
C     PRINT *,' REPLICATION FI8805'
C     DO 7100 I = 1, IPTR(13)
C         PRINT *,I,IWORK(I)
C7100 CONTINUE
C                         NUMBER OF DESCRIPTORS
      NRSET   = LX
C                         NUMBER OF REPLICATIONS
      NRREPS  = LY
      ICURR   = IPTR(11) - 1
      IPICK   = IPTR(11) - 1
C
      IF (NRREPS.EQ.0) THEN
          IPTR(39)  = 1
C                         SAVE PRIMARY DELAYED REPLICATION DESCRIPTOR
C         IPTR(31)  = IPTR(31) + 1
C         KPRM      = IPTR(31) + IPTR(24)
C         MSTACK(1,KPRM)  = JDESC
C         MSTACK(2,KPRM)  = 0
C         KDATA(IPTR(17),KPRM) = 0
C         PRINT *,'FI8805-1',KPRM,MSTACK(1,KPRM),
C    *                       MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
C                          DELAYED REPLICATION - MUST GET NUMBER OF
C                              REPLICATIONS FROM DATA.
C                                GET NEXT DESCRIPTOR
          CALL FI8808(IPTR,IWORK,LF,LX,LY,JDESC)
C          PRINT *,' DELAYED REPLICATION',LF,LX,LY,JDESC
C                                MUST BE DATA DESCRIPTION
C                                   OPERATION QUALIFIER
          IF (JDESC.EQ.7937.OR.JDESC.EQ.7947) THEN
              JWIDE     = 8
          ELSE IF (JDESC.EQ.7938.OR.JDESC.EQ.7948) THEN
              JWIDE     = 16
          ELSE IF (JDESC.EQ.7936) THEN
              JWIDE  = 1
          ELSE
              IPTR(1)   = 12
              RETURN
          END IF
C                        THIS IF BLOCK IS SET TO HANDLE
C                        DATA/DESCRIPTOR REPLICATION
          IF (JDESC.EQ.7947.OR.JDESC.EQ.7948) THEN
C                         SET DATA/DESCRIPTOR REPLICATION FLAG = ON
              IPTR(38)  = 1
C                         SAVE AS NEXT ENTRY IN KDATA, MSTACK
              IPTR(31)  = IPTR(31) + 1
              KPRM      = IPTR(31) + IPTR(24)
              MSTACK(1,KPRM)  = JDESC
              MSTACK(2,KPRM)  = 0
              CALL GBYTE (MSGA,KVALS,IPTR(25),JWIDE)
              IPTR(25)   = IPTR(25) + JWIDE
              KDATA(IPTR(17),KPRM) = KVALS(1)
              RETURN
          END IF

C                             SET SINGLE VALUE FOR SEQUENTIAL,
C                                  MULTIPLE VALUES FOR COMPRESSED
          IF (IDENT(16).EQ.0) THEN

C                               NON COMPRESSED
              CALL GBYTE (MSGA,KVALS,IPTR(25),JWIDE)
C             PRINT *,LF,LX,LY,JDESC,' NR OF REPLICATIONS',KVALS(1)
              IPTR(25)   = IPTR(25) + JWIDE
              IPTR(31)  = IPTR(31) + 1
              KPRM       = IPTR(31) + IPTR(24)
              MSTACK(1,KPRM)  = JDESC
              MSTACK(2,KPRM)  = 0
              KDATA(IPTR(17),KPRM) = KVALS(1)
              NRREPS          = KVALS(1)
C             PRINT *,'FI8805-2',KPRM,MSTACK(1,KPRM),
C    *                       MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
          ELSE
              NRVALS     = IDENT(14)
              CALL GBYTES (MSGA,KVALS,IPTR(25),JWIDE,0,NRVALS)
              IPTR(25)   = IPTR(25) + JWIDE * NRVALS
              IPTR(31)  = IPTR(31) + 1
              KPRM       = IPTR(31) + IPTR(24)
              MSTACK(1,KPRM)  = JDESC
              MSTACK(2,KPRM)  = 0
              KDATA(IPTR(17),KPRM) = KVALS(1)
              DO 100 I = 1, NRVALS
                  KDATA(I,KPRM) = KVALS(I)
  100         CONTINUE
              NRREPS     = KVALS(1)
          END IF
      ELSE
C         PRINT *,'NOT DELAYED REPLICATION'
      END IF
C                             RESTRUCTURE WORKING STACK W/REPLICATIONS
      IF (NRREPS.EQ.0) THEN
C         PRINT *,'RESTRUCTURING - NO REPLICATION'
          IPTR(11)  = IPICK + NRSET + 2
          GO TO 9999
      END IF
C     PRINT *,' SAVE OFF',NRSET,' DESCRIPTORS'
C                                 PICK UP DESCRIPTORS TO BE REPLICATED
      DO 1000 I = 1, NRSET
          CALL FI8808(IPTR,IWORK,LF,LX,LY,JDESC)
          ITEMP(I)    = JDESC
C         PRINT *,'REPLICATION        ',I,ITEMP(I)
 1000 CONTINUE
C                              MOVE TRAILING DESCRIPTORS TO HOLD AREA
      LAX       = IPTR(12) - IPTR(11) + 1
C     PRINT *,LAX,' TRAILING DESCRIPTORS TO HOLD AREA',IPTR(11),IPTR(12)
      DO 2000 I = 1, LAX
          CALL FI8808(IPTR,IWORK,LF,LX,LY,JDESC)
          KTEMP(I)   = JDESC
C         PRINT *,'                             ',I,KTEMP(I)
 2000 CONTINUE
C                              REPLICATIONS INTO ISTACK
C     PRINT *,' MUST REPLICATE ',KX,' DESCRIPTORS',KY,' TIMES'
C     PRINT *,'REPLICATIONS INTO STACK. LOC',ICURR
      DO 4000 I = 1, NRREPS
          DO 3000 J = 1, NRSET
              IWORK(ICURR) = ITEMP(J)
C             PRINT *,'FI8805 A',ICURR,IWORK(ICURR)
              ICURR         = ICURR + 1
 3000     CONTINUE
 4000 CONTINUE
C     PRINT *,'                     TO  LOC',ICURR-1
C                              RESTORE TRAILING DESCRIPTORS
C     PRINT *,'TRAILING DESCRIPTORS INTO STACK. LOC',ICURR
      DO 5000 I = 1, LAX
          IWORK(ICURR) = KTEMP(I)
C         PRINT *,'FI8805 B',ICURR,IWORK(ICURR)
          ICURR        = ICURR + 1
 5000 CONTINUE
      IPTR(12)  = ICURR - 1
      IPTR(11)  = IPICK
 9999 CONTINUE
C     DO 5500 I = 1, IPTR(12)
C         PRINT *,'FI8805 B',I,IWORK(I),IPTR(11)
C5500 CONTINUE
      RETURN
      END
      SUBROUTINE FI8806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK,
     *     IWIDE1,IRFVL1,ISCAL1,J,LL,KFXY1,IWORK,JDESC,MAXR,MAXD,KPTRB)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8806      PROCESS OPERATOR DESCRIPTORS
C   PRGMMR: CAVANAUGH        ORG: W/NMCX42   DATE: 88-09-01
C
C ABSTRACT: EXTRACT AND SAVE INDICATED CHANGE VALUES FOR USE
C   UNTIL CHANGES ARE RESCINDED, OR EXTRACT TEXT STRINGS INDICATED
C   THROUGH 2 05 YYY.
C
C PROGRAM HISTORY LOG:
C   88-09-01  CAVANAUGH
C   91-04-04  CAVANAUGH   MODIFIED TO HANDLE DESCRIPTOR 2 05 YYY
C   91-05-10  CAVANAUGH   CODING HAS BEEN ADDED TO PROCESS PROPERLY
C                         TABLE C DESCRIPTOR 2 06 YYY.
C   91-11-21  CAVANAUGH   CODING HAS BEEN ADDED TO PROPERLY PROCESS
C                         TABLE C DESCRIPTOR 2 03 YYY, THE CHANGE
C                         TO NEW REFERENCE VALUE FOR SELECTED
C                         DESCRIPTORS.
C
C USAGE:    CALL FI8806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK,
C    *      IWIDE1,IRFVL1,ISCAL1,J,LL,KFXY1,IWORK,JDESC,MAXR,MAXD,KPTRB)
C   INPUT ARGUMENT LIST:
C     IPTR     - SEE W3FI88 ROUTINE DOCBLOCK
C     LX       - X PORTION OF CURRENT DESCRIPTOR
C     LY       - Y PORTION OF CURRENT DESCRIPTOR
C     MAXR     - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE
C                CONTAINED IN A BUFR MESSAGE
C     MAXD     - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT
C                MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE
C                DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST
C                OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE
C
C   OUTPUT ARGUMENT LIST:
C     KDATA    - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
C                KDATA(REPORT NUMBER,PARAMETER NUMBER)
C                (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
C                 MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
C                 ARGUMENT MAXD)
C            ARRAYS CONTAINING DATA FROM TABLE B
C     ISCAL1   - SCALE FOR VALUE OF DESCRIPTOR
C     IRFVL1   - REFERENCE VALUE FOR DESCRIPTOR
C     IWIDE1   - BIT WIDTH FOR VALUE OF DESCRIPTOR
C
C REMARKS: ERROR RETURN:
C IPTR(1) = 5   - ERRONEOUS X VALUE IN DATA DESCRIPTOR OPERATOR
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  NAS
C
C$$$
C  ..................................................
C
C     NEW               BASE TABLE B
C                            MAY BE A COMBINATION OF MASTER TABLE B
C                            AND ANCILLARY TABLE B
C
      INTEGER        KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*)
C     CHARACTER*40   ANAME1(*)
C     CHARACTER*24   AUNIT1(*)
C  ..................................................
      INTEGER        IPTR(*),KDATA(MAXR,MAXD),IVALS(*)
      INTEGER        IDENT(*),IWORK(*),KPTRB(*)
      INTEGER        MSGA(*),MSTACK(2,MAXD)
      INTEGER        J,JDESC
      INTEGER        LL
      INTEGER        LX
      INTEGER        LY
C
      SAVE
C
C     PRINT *,' F2 - DATA DESCRIPTOR OPERATOR'
      IF (LX.EQ.1) THEN
C                                CHANGE BIT WIDTH
          IF (LY.EQ.0) THEN
C             PRINT *,' RETURN TO NORMAL WIDTH'
              IPTR(26) = 0
          ELSE
C             PRINT *,' EXPAND WIDTH BY',LY-128,' BITS'
              IPTR(26)  = LY - 128
          END IF
      ELSE IF (LX.EQ.2) THEN
C                                  CHANGE SCALE
          IF (LY.EQ.0) THEN
C                              RESET TO STANDARD SCALE
              IPTR(27) = 0
          ELSE
C                               SET NEW SCALE
              IPTR(27)  = LY - 128
          END IF
      ELSE IF (LX.EQ.3) THEN
C                      CHANGE REFERENCE VALUE
C                                 FOR EACH OF THOSE DESCRIPTORS BETWEEN
C                                 2 03 YYY WHERE Y LT 255 AND
C                                 2 03 255, EXTRACT THE NEW REFERENCE
C                                 VALUE (BIT WIDTH YYY) AND PLACE
C                                 IN TERTIARY TABLE B REF VAL POSITION,
C                                 SET FLAG IN SECONDARY REFVAL POSITION
C                                 THOSE DESCRIPTORS DO NOT HAVE DATA
C                                 ASSOCIATED WITH THEM, BUT ONLY
C                                 IDENTIFY THE TABLE B ENTRIES THAT
C                                 ARE GETTING NEW REFERENCE VALUES.
          KYYY     = LY
          IF (KYYY.GT.0.AND.KYYY.LT.255) THEN
C                               START CYCLING THRU DESCRIPTORS UNTIL
C                               TERMINATE NEW REF VALS IS FOUND
  300         CONTINUE
              CALL FI8808 (IPTR,IWORK,LF,LX,LY,JDESC)
              IF (JDESC.EQ.33791) THEN
C                    IF 2 03 255 THEN RETURN
                  RETURN
              END IF
C                               FIND MATCHING TABLE B ENTRY
              LJ  = KPTRB(JDESC)
              IF (LJ.LT.1) THEN
C                         MATCHING DESCRIPTOR NOT FOUND, ERROR ERROR
                  PRINT *,'2 03 YYY - MATCHING DESCRIPTOR NOT FOUND'
                  IPTR(1)  = 23
                  RETURN
              END IF
C                                  TURN ON SWITCH
              IRFVL1(2,LJ) = 1
C                                 INSERT NEW REFERENCE VALUE
              CALL GBYTE (MSGA,IRFVL1(3,LJ),IPTR(25),KYYY)
              GO TO 300
          ELSE IF (KYYY.EQ.0) THEN
C                                      MUST TURN OFF ALL NEW
C                                      REFERENCE VALUES
              DO 400 I = 1, IPTR(21)
                  IRFVL1(2,I) = 0
  400         CONTINUE
          END IF
C                                      LX = 3
C                                      MUST BE CONCLUDED WITH Y=255
      ELSE IF (LX.EQ.4) THEN
C                             ASSOCIATED VALUES
          IF (LY.EQ.0) THEN
              IPTR(29) = 0
C             PRINT *,'RESET ASSOCIATED VALUES',IPTR(29)
          ELSE
              IPTR(29)  = LY
              IF (IWORK(IPTR(11)).NE.7957) THEN
                  PRINT *,'2 04 YYY NOT FOLLOWED BY 0 31 021'
                  IPTR(1)   = 11
              END IF
C             PRINT *,'SET ASSOCIATED VALUES',IPTR(29)
          END IF
      ELSE IF (LX.EQ.5) THEN
          MWDBIT = IPTR(44)
C                        PROCESS TEXT DATA
          IPTR(40)  = LY
          IPTR(18)  = 1
          J = KPTRB(JDESC)
          IF (IDENT(16).EQ.0) THEN
C             PRINT *,'FROM FI8806 - 2 05 YYY - NONCOMPRESSED TEXT',J
              CALL FI8804(IPTR,MSGA,KDATA,IVALS,MSTACK,
     *                IWIDE1,IRFVL1,ISCAL1,J,LL,JDESC,MAXR,MAXD)
          ELSE
C             PRINT *,'2 05 YYY - TEXT - COMPRESSED MODE YYY=',LY
C             PRINT *,'TEXT - LOWEST = 0'
              IPTR(25) = IPTR(25) + IPTR(40) * 8
C                                   GET NBINC
C             CALL GBYTE (MSGA,NBINC,IPTR(25),6)
              IPTR(25)     = IPTR(25) + 6
              NBINC  = IPTR(40)
C             PRINT *,'TEXT    NBINC =',NBINC,IPTR(40)
C                                   FOR NUMBER OF OBSERVATIONS
              IPTR(31)      = IPTR(31) + 1
              KPRM          = IPTR(31) + IPTR(24)
              ISTART        = KPRM
              DO 1900 N   = 1, IDENT(14)
                  KPRM        = ISTART
                  NBITS       = IPTR(40) * 8
 1700             CONTINUE
C                 PRINT *,'1700',KDATA(N,KPRM),N,KPRM,NBITS
                  IF (NBITS.GT.MWDBIT) THEN
                      CALL GBYTE (MSGA,IDATA,IPTR(25),MWDBIT)
                      IPTR(25)     = IPTR(25) + MWDBIT
                      NBITS        = NBITS - MWDBIT
C                               CONVERTS ASCII TO EBCIDIC
C                               COMMENT OUT IF NOT IBM370 COMPUTER
                      IF (IPTR(37).EQ.0) THEN
                          CALL W3AI39 (IDATA,IPTR(45))
                      END IF
                      MSTACK(1,KPRM) = JDESC
                      MSTACK(2,KPRM) = 0
                      KDATA(N,KPRM) = IDATA
C                     PRINT *,'TEXT        ',N,KPRM,KDATA(N,KPRM)
C                          SET FOR NEXT PART
                      KPRM          = KPRM + 1
C                     PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA
C1701                 FORMAT (1X,I1,1X,6HKDATA=,A4,2X,I5,2X,I5,2X,I5,2X,
C    *                 I10)
                      GO TO 1700
                  ELSE IF (NBITS.EQ.MWDBIT) THEN
                      CALL GBYTE (MSGA,IDATA,IPTR(25),MWDBIT)
                      IPTR(25)     = IPTR(25) + MWDBIT
                      NBITS        = NBITS - MWDBIT
C                               CONVERTS ASCII TO EBCIDIC
C                               COMMENT OUT IF NOT IBM370 COMPUTER
                      IF (IPTR(37).EQ.0) THEN
                          CALL W3AI39 (IDATA,IPTR(45))
                      END IF
                      MSTACK(1,KPRM) = JDESC
                      MSTACK(2,KPRM) = 0
                      KDATA(N,KPRM) = IDATA
C                     PRINT *,'TEXT        ',N,KPRM,KDATA(N,KPRM)
C                          SET FOR NEXT PART
                      KPRM          = KPRM + 1
C                     PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA
                  ELSE IF (NBITS.GT.0) THEN
                      CALL GBYTE (MSGA,IDATA,IPTR(25),NBITS)
                      IPTR(25)     = IPTR(25) + NBITS
                      IBUF         = (MWDBIT - NBITS) / 8
                      IF (IBUF.GT.0) THEN
                          DO 1750 MP = 1, IBUF
                              IDATA  = IDATA * 256 + 32
 1750                     CONTINUE
                      END IF
C                               CONVERTS ASCII TO EBCIDIC
C                               COMMENT OUT IF NOT IBM370 COMPUTER
                      IF (IPTR(37).EQ.0) THEN
                          CALL W3AI39 (IDATA,IPTR(45))
                      END IF
                      MSTACK(1,KPRM) = JDESC
                      MSTACK(2,KPRM) = 0
                      KDATA(N,KPRM) = IDATA
C                     PRINT *,'TEXT        ',N,KPRM,KDATA(N,KPRM)
C                     PRINT 1701,2,KDATA(N,KPRM),N,KPRM,NBITS
                  END IF
C                 WRITE (6,1800)N,(KDATA(N,I),I=KPRS,KPRM)
C1800             FORMAT (2X,I4,2X,3A4)
 1900         CONTINUE

              IPTR(24)  = IPTR(24) + IPTR(40) / 4 - 1
              IF (MOD(IPTR(40),4).NE.0) IPTR(24) = IPTR(24) + 1
          END IF
          IPTR(18)  = 0
C  ---------------------------
      ELSE IF (LX.EQ.6) THEN
C                          SKIP NEXT DESCRIPTOR
C              SET TO PASS OVER DESCRIPTOR AND DATA
C                     IF DESCRIPTOR NOT IN TABLE B
          IPTR(36)   = LY
C         PRINT *,'SET TO SKIP',LY,' BIT FIELD'
          IPTR(31)       = IPTR(31) + 1
          KPRM           = IPTR(31) + IPTR(24)
          MSTACK(1,KPRM) = 34304 + LY
          MSTACK(2,KPRM) = 0
      ELSE
          IPTR(1)   = 5
      ENDIF
      RETURN
      END
      SUBROUTINE FI8807(IPTR,IWORK,ITBLD,ITBLD2,JDESC,KPTRD)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8807      PROCESS QUEUE DESCRIPTOR
C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 88-09-01
C
C ABSTRACT: SUBSTITUTE DESCRIPTOR QUEUE FOR QUEUE DESCRIPTOR
C
C PROGRAM HISTORY LOG:
C   88-09-01  CAVANAUGH
C   91-04-17  CAVANAUGH   IMPROVED HANDLING OF NESTED QUEUE DESCRIPTORS
C   91-05-28  CAVANAUGH   IMPROVED HANDLING OF NESTED QUEUE DESCRIPTORS
C                         BASED ON TESTS WITH LIVE DATA.
C
C USAGE:    CALL FI8807(IPTR,IWORK,ITBLD,ITBLD2,JDESC,KPTRD)
C   INPUT ARGUMENT LIST:
C     IWORK    - WORKING DESCRIPTOR LIST
C     IPTR     - SEE W3FI88 ROUTINE DOCBLOCK
C     LAST     - INDEX TO LAST DESCRIPTOR
C     ITBLD    - ARRAY CONTAINING DESCRIPTOR QUEUES
C     JDESC    - QUEUE DESCRIPTOR TO BE EXPANDED
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     ISTACK   - SEE ABOVE
C
C   SUBPROGRAMS CALLED:
C     LIBRARY:
C       W3LIB    - NONE
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  NAS
C
C$$$
C  ..................................................
C
C                       ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
C
      INTEGER        ITBLD2(20,*)
C  ..................................................
C
C                       NEW BASE TABLE D
C
      INTEGER        ITBLD(20,*)
C  ..................................................
C
      INTEGER        IPTR(*),JDESC,KPTRD(*)
      INTEGER        IWORK(*),IHOLD(15000)
C
      SAVE
C     PRINT *,' FI8807  F3 ENTRY',IPTR(11),IPTR(12)
C                                   SET FOR BINARY SEARCH IN TABLE D
      JLO  = 1
      JHI  = IPTR(20)
C     PRINT *,'LOOKING FOR QUEUE DESCRIPTOR',JDESC,IPTR(11),IPTR(12)
C
      JMID = KPTRD(MOD(JDESC,16384))
      IF (JMID.LT.0) THEN
          IPTR(1)  = 4
          RETURN
      END IF
C                              HAVE TABLE D MATCH
C     PRINT *,'D ',(ITBLD(LL,JMID),LL=1,20)
C     PRINT *,'TABLE D TO IHOLD'
      IK       = 0
      JK       = 0
      DO 200 KI = 2, 20
          IF (ITBLD(KI,JMID).NE.0) THEN
              IK        = IK + 1
              IHOLD(IK) = ITBLD(KI,JMID)
C             PRINT *,IK,IHOLD(IK)
          ELSE
              GO TO 300
          END IF
  200 CONTINUE
  300 CONTINUE
      KK       = IPTR(11)
      IF (KK.GT.IPTR(12)) THEN
C                          NOTHING MORE TO APPEND
C         PRINT *,'NOTHING MORE TO APPEND'
      ELSE
C                          APPEND TRAILING IWORK TO IHOLD
C         PRINT *,'APPEND FROM ',KK,' TO',IPTR(12)
          DO 500 I = KK, IPTR(12)
              IK  = IK + 1
              IHOLD(IK) = IWORK(I)
  500     CONTINUE
      END IF
C                                RESET IHOLD TO IWORK
C     PRINT *,' RESET IWORK STACK'
      KK       = IPTR(11) - 2
      DO 1000 I = 1, IK
          KK        = KK + 1
          IWORK(KK) = IHOLD(I)
 1000 CONTINUE
      IPTR(12)   = KK
C     PRINT *,' FI8807  F3 EXIT ',IPTR(11),IPTR(12)
C     DO 2000 I = 1, IPTR(12)
C         PRINT *,'EXIT  IWORK',I,IWORK(I)
C2000 CONTINUE
C                                RESET POINTERS
      IPTR(11)   = IPTR(11) - 1
      RETURN
      END
C -----------------------------------------------------
      SUBROUTINE FI8808(IPTR,IWORK,LF,LX,LY,JDESC)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8808
C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 89-01-17
C
C ABSTRACT:
C
C PROGRAM HISTORY LOG:
C   88-09-01  CAVANAUGH
C   YY-MM-DD  MODIFIER1   DESCRIPTION OF CHANGE
C
C USAGE:    CALL FI8808(IPTR,IWORK,LF,LX,LY,JDESC)
C   INPUT ARGUMENT LIST:
C     IPTR     - SEE W3FI88 ROUTINE DOCBLOCK
C     IWORK    - WORKING DESCRIPTOR LIST
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     IPTR     - SEE ABOVE
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  NAS
C
C$$$
      INTEGER       IPTR(*),IWORK(*),LF,LX,LY,JDESC
      SAVE
C
C     PRINT *,' FI8808 NEW DESCRIPTOR PICKUP'
      JDESC    = IWORK(IPTR(11))
      LY       = MOD(JDESC,256)
      IPTR(34) = LY
      LX       = MOD((JDESC/256),64)
      IPTR(33) = LX
      LF       = JDESC / 16384
      IPTR(32) = LF
C     PRINT *,' TEST DESCRIPTOR',LF,LX,LY,' AT',IPTR(11)
      IPTR(11) = IPTR(11) + 1
      RETURN
      END
      SUBROUTINE FI8809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8809      REFORMAT PROFILER W HGT INCREMENTS
C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 90-02-14
C
C ABSTRACT: REFORMAT DECODED PROFILER DATA TO SHOW HEIGHTS INSTEAD OF
C     HEIGHT INCREMENTS.
C
C PROGRAM HISTORY LOG:
C   90-02-14  CAVANAUGH
C
C USAGE:    CALL FI8809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
C   INPUT ARGUMENT LIST:
C     IDENT    - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM
C                  BUFR MESSAGE -
C         IDENT(1) -EDITION NUMBER     (BYTE 4, SECTION 1)
C         IDENT(2) -ORIGINATING CENTER (BYTES 5-6, SECTION 1)
C         IDENT(3) -UPDATE SEQUENCE    (BYTE 7, SECTION 1)
C         IDENT(4) -                   (BYTE 8, SECTION 1)
C         IDENT(5) -BUFR MESSAGE TYPE  (BYTE 9, SECTION 1)
C         IDENT(6) -BUFR MSG SUB-TYPE  (BYTE 10, SECTION 1)
C         IDENT(7) -                   (BYTES 11-12, SECTION 1)
C         IDENT(8) -YEAR OF CENTURY    (BYTE 13, SECTION 1)
C         IDENT(9) -MONTH OF YEAR      (BYTE 14, SECTION 1)
C         IDENT(10)-DAY OF MONTH       (BYTE 15, SECTION 1)
C         IDENT(11)-HOUR OF DAY        (BYTE 16, SECTION 1)
C         IDENT(12)-MINUTE OF HOUR     (BYTE 17, SECTION 1)
C         IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1)
C         IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3)
C         IDENT(15)-OBSERVED FLAG      (BYTE 7, BIT 1, SECTION 3)
C         IDENT(16)-COMPRESSION FLAG   (BYTE 7, BIT 2, SECTION 3)
C     MSTACK   - WORKING DESCRIPTOR LIST AND SCALING FACTOR
C     KDATA    - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
C                KDATA(REPORT NUMBER,PARAMETER NUMBER)
C                (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
C                 MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
C                 ARGUMENT MAXD)
C     KSET2    - INTERIM DATA ARRAY
C     KPROFL   - INTERIM DESCRIPTOR ARRAY
C     IPTR     - SEE W3FI88
C     MAXR     - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE
C                CONTAINED IN A BUFR MESSAGE
C     MAXD     - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT
C                MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE
C                DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST
C                OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE
C
C   OUTPUT FILES:
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  NAS
C
C$$$
C  ----------------------------------------------------------------
C
      INTEGER        ISW
      INTEGER        IDENT(*),KDATA(MAXR,MAXD)
      INTEGER        MSTACK(2,MAXD),IPTR(*)
      INTEGER        KPROFL(1700)
      INTEGER        KPROF2(1700)
      INTEGER        KSET2(1700)
C
C  ----------------------------------------------------------
      SAVE
C     PRINT *,'FI8809'
C                                LOOP FOR NUMBER OF SUBSETS/REPORTS
      DO 3000 I = 1, IDENT(14)
C                                INIT FOR DATA INPUT ARRAY
          MK         = 1
C                                INIT FOR DESC OUTPUT ARRAY
          JK         = 0
C                                LOCATION
          ISW        = 0
          DO 200 J = 1, 3
C                                    LATITUDE
              IF (MSTACK(1,MK).EQ.1282) THEN
                  ISW   = ISW + 1
                  GO TO 100
C                                    LONGITUDE
              ELSE IF (MSTACK(1,MK).EQ.1538) THEN
                  ISW   = ISW + 2
                  GO TO 100
C                                    HEIGHT ABOVE SEA LEVEL
              ELSE IF (MSTACK(1,MK).EQ.1793) THEN
                  IHGT  = KDATA(I,MK)
                  ISW   = ISW + 4
                  GO TO 100
              END IF
              GO TO 200
  100         CONTINUE
              JK             = JK + 1
C                                     SAVE DESCRIPTOR
              KPROFL(JK)     = MSTACK(1,MK)
C                                     SAVE SCALE
              KPROF2(JK)     = MSTACK(2,MK)
C                                      SAVE DATA
              KSET2(JK)  = KDATA(I,MK)
              MK         = MK + 1
  200     CONTINUE
          IF (ISW.NE.7) THEN
              PRINT *,'LOCATION ERROR PROCESSING PROFILER'
              IPTR(1)    = 200
              RETURN
          END IF
C  TIME
          ISW        = 0
          DO 400 J = 1, 7
C                                    YEAR
              IF (MSTACK(1,MK).EQ.1025) THEN
                  ISW   = ISW + 1
                  GO TO 300
C                                    MONTH
              ELSE IF (MSTACK(1,MK).EQ.1026) THEN
                  ISW   = ISW + 2
                  GO TO 300
C                                    DAY
              ELSE IF (MSTACK(1,MK).EQ.1027) THEN
                  ISW   = ISW + 4
                  GO TO 300
C                                    HOUR
              ELSE IF (MSTACK(1,MK).EQ.1028) THEN
                  ISW   = ISW + 8
                  GO TO 300
C                                    MINUTE
              ELSE IF (MSTACK(1,MK).EQ.1029) THEN
                  ISW   = ISW + 16
                  GO TO 300
C                                    TIME SIGNIFICANCE
              ELSE IF (MSTACK(1,MK).EQ.2069) THEN
                  ISW   = ISW + 32
                  GO TO 300
              ELSE IF (MSTACK(1,MK).EQ.1049) THEN
                  ISW   = ISW + 64
                  GO TO 300
              END IF
              GO TO 400
  300         CONTINUE
              JK         = JK + 1
C                             SAVE DESCRIPTOR
              KPROFL(JK) = MSTACK(1,MK)
C                                     SAVE SCALE
              KPROF2(JK)     = MSTACK(2,MK)
C                             SAVE DATA
              KSET2(JK)  = KDATA(I,MK)
              MK         = MK + 1
  400     CONTINUE
          IF (ISW.NE.127) THEN
              PRINT *,'TIME ERROR PROCESSING PROFILER',ISW
              IPTR(1)    = 201
              RETURN
          END IF
C  SURFACE DATA
          KRG        = 0
          ISW        = 0
          DO 600 J = 1, 10
C                                    WIND SPEED
              IF (MSTACK(1,MK).EQ.2818) THEN
                  ISW   = ISW + 1
                  GO TO 500
C                                    WIND DIRECTION
              ELSE IF (MSTACK(1,MK).EQ.2817) THEN
                  ISW   = ISW + 2
                  GO TO 500
C                                    PRESS REDUCED TO MSL
              ELSE IF (MSTACK(1,MK).EQ.2611) THEN
                  ISW   = ISW + 4
                  GO TO 500
C                                    TEMPERATURE
              ELSE IF (MSTACK(1,MK).EQ.3073) THEN
                  ISW   = ISW + 8
                  GO TO 500
C                                    RAINFALL RATE
              ELSE IF (MSTACK(1,MK).EQ.3342) THEN
                  ISW   = ISW + 16
                  GO TO 500
C                                    RELATIVE HUMIDITY
              ELSE IF (MSTACK(1,MK).EQ.3331) THEN
                  ISW   = ISW + 32
                  GO TO 500
C                                    1ST RANGE GATE OFFSET
              ELSE IF (MSTACK(1,MK).EQ.1982.OR.
     *                    MSTACK(1,MK).EQ.1983) THEN
C       CANNOT USE NORMAL PROCESSING FOR FIRST RANGE GATE, MUST SAVE
C        VALUE FOR LATER USE
                  IF (MSTACK(1,MK).EQ.1983) THEN
                      IHGT   = KDATA(I,MK)
                      MK     = MK + 1
                      KRG   = 1
                  ELSE
                      IF (KRG.EQ.0) THEN
                          INCRHT             = KDATA(I,MK)
                          MK    = MK + 1
                          KRG   = 1
C                         PRINT *,'INITIAL INCR =',INCRHT
                      ELSE
                          LHGT  = 500 + IHGT - KDATA(I,MK)
                          ISW   = ISW + 64
C                         PRINT *,'BASE HEIGHT=',LHGT,' INCR=',INCRHT
                      END IF
                  END IF
C                                    MODE #1
              ELSE IF (MSTACK(1,MK).EQ.8128) THEN
                  ISW   = ISW + 128
                  GO TO 500
C                                    MODE #2
              ELSE IF (MSTACK(1,MK).EQ.8129) THEN
                  ISW   = ISW + 256
                  GO TO 500
              END IF
              GO TO 600
  500         CONTINUE
C                              SAVE DESCRIPTOR
              JK             = JK + 1
              KPROFL(JK)     = MSTACK(1,MK)
C                                     SAVE SCALE
              KPROF2(JK)     = MSTACK(2,MK)
C                              SAVE DATA
              KSET2(JK)      = KDATA(I,MK)
C             IF (I.EQ.1) THEN
C                 PRINT *,'   ',JK,KPROFL(JK),KSET2(JK)
C             END IF
              MK             = MK + 1
  600     CONTINUE
          IF (ISW.NE.511) THEN
              PRINT *,'SURFACE ERROR PROCESSING PROFILER',ISW
              IPTR(1)    = 202
              RETURN
          END IF
C  43 LEVELS
          DO 2000 L = 1, 43
 2020         CONTINUE
              ISW        = 0
C                                    HEIGHT INCREMENT
              IF (MSTACK(1,MK).EQ.1982) THEN
C                 PRINT *,'NEW HEIGHT INCREMENT',KDATA(I,MK)
                  INCRHT  = KDATA(I,MK)
                  MK      = MK + 1
                  IF (LHGT.LT.(9250+IHGT)) THEN
                      LHGT    = IHGT + 500 - INCRHT
                  ELSE
                      LHGT    = IHGT + 9250 - INCRHT
                  END IF
              END IF
C    MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DATA
C          AT THIS POINT     - HEIGHT + INCREMENT + BASE VALUE
              LHGT       = LHGT + INCRHT
C             PRINT *,'LEVEL ',L,LHGT
              IF (L.EQ.37) THEN
                  LHGT       = LHGT + INCRHT
              END IF
              JK          = JK + 1
C                              SAVE DESCRIPTOR
              KPROFL(JK)  = 1798
C                                     SAVE SCALE
              KPROF2(JK)     = 0
C                              SAVE DATA
              KSET2(JK)  = LHGT
C             IF (I.EQ.10) THEN
C                 PRINT *,' '
C                 PRINT *,'HGT',JK,KPROFL(JK),KSET2(JK)
C             END IF
              ISW   = 0
              DO 800 J = 1, 9
  750             CONTINUE
                  IF (MSTACK(1,MK).EQ.1982) THEN
                      GO TO 2020
C                                    U VECTOR VALUE
                  ELSE IF (MSTACK(1,MK).EQ.3008) THEN
                      ISW   = ISW + 1
                      IF (KDATA(I,MK).GE.2047) THEN
                          VECTU              = 32767
                      ELSE
                          VECTU              = KDATA(I,MK)
                      END IF
                      MK    = MK + 1
                      GO TO 800
C                                    V VECTOR VALUE
                  ELSE IF (MSTACK(1,MK).EQ.3009) THEN
                      ISW   = ISW + 2
                      IF (KDATA(I,MK).GE.2047) THEN
                          VECTV              = 32767
                      ELSE
                          VECTV              = KDATA(I,MK)
                      END IF
                      MK    = MK + 1
C IF U VALUE IS ALSO AVAILABLE THEN GENERATE DDFFF
C     DESCRIPTORS AND DATA
                      IF (IAND(ISW,1).NE.0) THEN
                          IF (VECTU.EQ.32767.OR.VECTV.EQ.32767) THEN
C                                               SAVE DD DESCRIPTOR
                              JK             = JK + 1
                              KPROFL(JK)     = 2817
C                                     SAVE SCALE
                              KPROF2(JK)     = 0
C                                               SAVE DD DATA
                              KSET2(JK)      = 32767
C                                               SAVE FFF DESCRIPTOR
                              JK             = JK + 1
                              KPROFL(JK)     = 2818
C                                     SAVE SCALE
                              KPROF2(JK)     = 1
C                                               SAVE FFF DATA
                              KSET2(JK)      = 32767
                          ELSE
C                                               GENERATE DDFFF
                              CALL W3FC05 (VECTU,VECTV,DIR,SPD)
                              NDIR         = DIR
                              SPD          = SPD
                              NSPD         = SPD
C                             PRINT *,'                ',NDIR,NSPD
C                                               SAVE DD DESCRIPTOR
                              JK             = JK + 1
                              KPROFL(JK)     = 2817
C                                     SAVE SCALE
                              KPROF2(JK)     = 0
C                                               SAVE DD DATA
                              KSET2(JK)          = DIR
C                             IF (I.EQ.1) THEN
C                                 PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK)
C                             END IF
C                                               SAVE FFF DESCRIPTOR
                              JK             = JK + 1
                              KPROFL(JK)     = 2818
C                                     SAVE SCALE
                              KPROF2(JK)     = 1
C                                               SAVE FFF DATA
                              KSET2(JK)          = SPD
C                             IF (I.EQ.1) THEN
C                                 PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK)
C                             END IF
                          END IF
                      END IF
                      GO TO 800
C                                    W VECTOR VALUE
                  ELSE IF (MSTACK(1,MK).EQ.3010) THEN
                      ISW   = ISW + 4
                      GO TO 700
C                                    Q/C TEST RESULTS
                  ELSE IF (MSTACK(1,MK).EQ.8130) THEN
                      ISW   = ISW + 8
                      GO TO 700
C                                    U,V QUALITY IND
                ELSE IF(IAND(ISW,16).EQ.0.AND.MSTACK(1,MK).EQ.2070) THEN
                      ISW   = ISW + 16
                      GO TO 700
C                                    W QUALITY IND
                ELSE IF(IAND(ISW,32).EQ.0.AND.MSTACK(1,MK).EQ.2070) THEN
                      ISW   = ISW + 32
                      GO TO 700
C                                    SPECTRAL PEAK POWER
                  ELSE IF (MSTACK(1,MK).EQ.5568) THEN
                      ISW   = ISW + 64
                      GO TO 700
C                                    U,V VARIABILITY
                  ELSE IF (MSTACK(1,MK).EQ.3011) THEN
                      ISW   = ISW + 128
                      GO TO 700
C                                    W VARIABILITY
                  ELSE IF (MSTACK(1,MK).EQ.3013) THEN
                      ISW   = ISW + 256
                      GO TO 700
                  ELSE IF ((MSTACK(1,MK)/16384).NE.0) THEN
                      MK     = MK + 1
                      GO TO 750
                  END IF
                  GO TO 800
  700             CONTINUE
                  JK         = JK + 1
C                                      SAVE DESCRIPTOR
                  KPROFL(JK) = MSTACK(1,MK)
C                                     SAVE SCALE
                  KPROF2(JK)     = MSTACK(2,MK)
C                                      SAVE DATA
                  KSET2(JK)          = KDATA(I,MK)
                  MK         = MK + 1
C                 IF (I.EQ.1) THEN
C                     PRINT *,'   ',JK,KPROFL(JK),KSET2(JK)
C                 END IF
  800         CONTINUE
              IF (ISW.NE.511) THEN
                  PRINT *,'LEVEL ERROR PROCESSING PROFILER',ISW
                  IPTR(1)    = 203
                  RETURN
              END IF
 2000     CONTINUE
C                        MOVE DATA BACK INTO KDATA ARRAY
          DO 4000 LL = 1, JK
              KDATA(I,LL) = KSET2(LL)
 4000     CONTINUE
 3000 CONTINUE
C     PRINT *,'REBUILT ARRAY'
      DO 5000 LL = 1, JK
C                           DESCRIPTOR
          MSTACK(1,LL)  = KPROFL(LL)
C                           SCALE
          MSTACK(2,LL)  = KPROF2(LL)
C         PRINT *,LL,MSTACK(1,LL),(KDATA(I,LL),I=1,7)
 5000 CONTINUE
C                        MOVE REFORMATTED DESCRIPTORS TO MSTACK ARRAY
      IPTR(31) = JK
      RETURN
      END
      SUBROUTINE FI8810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8810      REFORMAT PROFILER EDITION 2  DATA
C   PRGMMR: KEYSER           ORG: NP22       DATE: 1995-06-07
C
C ABSTRACT: REFORMAT PROFILER DATA IN EDITION 2
C
C PROGRAM HISTORY LOG:
C 1993-01-27  CAVANAUGH
C 1995-06-07  KEYSER  A CORRECTION WAS MADE TO PREVENT
C                     UNNECESSARY LOOPING WHEN ALL REQUESTED
C                     DESCRIPTORS ARE MISSING.
C
C USAGE:    CALL FI8810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
C   INPUT ARGUMENT LIST:
C     IDENT    - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM
C                  BUFR MESSAGE -
C         IDENT(1) -EDITION NUMBER     (BYTE 4, SECTION 1)
C         IDENT(2) -ORIGINATING CENTER (BYTES 5-6, SECTION 1)
C         IDENT(3) -UPDATE SEQUENCE    (BYTE 7, SECTION 1)
C         IDENT(4) -                   (BYTE 8, SECTION 1)
C         IDENT(5) -BUFR MESSAGE TYPE  (BYTE 9, SECTION 1)
C         IDENT(6) -BUFR MSG SUB-TYPE  (BYTE 10, SECTION 1)
C         IDENT(7) -                   (BYTES 11-12, SECTION 1)
C         IDENT(8) -YEAR OF CENTURY    (BYTE 13, SECTION 1)
C         IDENT(9) -MONTH OF YEAR      (BYTE 14, SECTION 1)
C         IDENT(10)-DAY OF MONTH       (BYTE 15, SECTION 1)
C         IDENT(11)-HOUR OF DAY        (BYTE 16, SECTION 1)
C         IDENT(12)-MINUTE OF HOUR     (BYTE 17, SECTION 1)
C         IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1)
C         IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3)
C         IDENT(15)-OBSERVED FLAG      (BYTE 7, BIT 1, SECTION 3)
C         IDENT(16)-COMPRESSION FLAG   (BYTE 7, BIT 2, SECTION 3)
C     MSTACK   - WORKING DESCRIPTOR LIST AND SCALING FACTOR
C     KDATA    - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
C                KDATA(REPORT NUMBER,PARAMETER NUMBER)
C                (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
C                 MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
C                 ARGUMENT MAXD)
C     KSET2    - INTERIM DATA ARRAY
C     KPROFL   - INTERIM DESCRIPTOR ARRAY
C     IPTR     - SEE W3FI88
C     MAXR     - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE
C                CONTAINED IN A BUFR MESSAGE
C     MAXD     - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT
C                MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE
C                DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST
C                OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE
C
C   OUTPUT FILES:
C
C REMARKS:
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  NAS
C
C$$$
      INTEGER        ISW
      INTEGER        IDENT(*),KDATA(MAXR,MAXD)
      INTEGER        MSTACK(2,MAXD),IPTR(*)
      INTEGER        KPROFL(1700)
      INTEGER        KPROF2(1700)
      INTEGER        KSET2(1700)
C
      SAVE
C                             LOOP FOR NUMBER OF SUBSETS
      DO 3000 I = 1, IDENT(14)
          MK  = 1
          JK  = 0
          ISW  = 0
C         PRINT *,'IDENTIFICATION'
          DO 200 J = 1, 5
              IF (MSTACK(1,MK).EQ.257) THEN
C                            BLOCK NUMBER
                  ISW  = ISW + 1
              ELSE IF (MSTACK(1,MK).EQ.258) THEN
C                           STATION NUMBER
                  ISW  = ISW + 2
              ELSE IF (MSTACK(1,MK).EQ.1282) THEN
C                           LATITUDE
                  ISW  = ISW + 4
              ELSE IF (MSTACK(1,MK).EQ.1538) THEN
C                           LONGITUDE
                  ISW  = ISW + 8
              ELSE IF (MSTACK(1,MK).EQ.1793) THEN
C                           HEIGHT OF STATION
                  ISW  = ISW + 16
                  IHGT  = KDATA(I,MK)
              ELSE
                  MK  = MK + 1
                  GO TO 200
              END IF
              JK  = JK + 1
              KPROFL(JK)  = MSTACK(1,MK)
              KPROF2(JK)  = MSTACK(2,MK)
              KSET2(JK)   = KDATA(I,MK)
C             PRINT *,JK,KPROFL(JK),KSET2(JK)
              MK  = MK + 1
  200     CONTINUE
C         PRINT *,'LOCATION ',ISW
          IF (ISW.NE.31) THEN
              PRINT *,'LOCATION ERROR PROCESSING PROFILER'
              IPTR(10)  = 200
              RETURN
          END IF
C                      PROCESS TIME ELEMENTS
          ISW  = 0
          DO 400 J  = 1, 7
              IF (MSTACK(1,MK).EQ.1025) THEN
C                           YEAR
                  ISW  = ISW + 1
              ELSE IF (MSTACK(1,MK).EQ.1026) THEN
C                           MONTH
                  ISW  = ISW + 2
              ELSE IF (MSTACK(1,MK).EQ.1027) THEN
C                           DAY
                  ISW  = ISW + 4
              ELSE IF (MSTACK(1,MK).EQ.1028) THEN
C                           HOUR
                  ISW  = ISW + 8
              ELSE IF (MSTACK(1,MK).EQ.1029) THEN
C                           MINUTE
                  ISW  = ISW + 16
              ELSE IF (MSTACK(1,MK).EQ.2069) THEN
C                           TIME SIGNIFICANCE
                  ISW  = ISW + 32
              ELSE IF (MSTACK(1,MK).EQ.1049) THEN
C                           TIME DISPLACEMENT
                  ISW  = ISW + 64
              ELSE
                  MK  = MK + 1
                  GO TO 400
              END IF
              JK  = JK + 1
              KPROFL(JK)  = MSTACK(1,MK)
              KPROF2(JK)  = MSTACK(2,MK)
              KSET2(JK)   = KDATA(I,MK)
C             PRINT *,JK,KPROFL(JK),KSET2(JK)
              MK  = MK + 1
  400     CONTINUE
C         PRINT *,'TIME ',ISW
          IF (ISW.NE.127) THEN
              PRINT *,'TIME ERROR PROCESSING PROFILER'
              IPTR(1)  = 201
              RETURN
          END IF
C                  SURFACE DATA
          ISW  = 0
C         PRINT *,'SURFACE'
          DO 600 K  = 1, 8
C             PRINT *,MK,MSTACK(1,MK),JK,ISW
              IF (MSTACK(1,MK).EQ.2817) THEN
                  ISW  = ISW + 1
              ELSE IF (MSTACK(1,MK).EQ.2818) THEN
                  ISW  = ISW + 2
              ELSE IF (MSTACK(1,MK).EQ.2611) THEN
                  ISW  = ISW + 4
              ELSE IF (MSTACK(1,MK).EQ.3073) THEN
                  ISW  = ISW + 8
              ELSE IF (MSTACK(1,MK).EQ.3342) THEN
                  ISW  = ISW + 16
              ELSE IF (MSTACK(1,MK).EQ.3331) THEN
                  ISW  = ISW + 32
              ELSE IF (MSTACK(1,MK).EQ.1797) THEN
                  INCRHT  = KDATA(I,MK)
                  ISW  = ISW + 64
C                 PRINT *,'INITIAL INCREMENT = ',INCRHT
                  MK  = MK + 1
C                 PRINT *,JK,KPROFL(JK),KSET2(JK),' ISW=',ISW
                  GO TO 600
              ELSE IF (MSTACK(1,MK).EQ.6433) THEN
                  ISW  = ISW + 128
              END IF
              JK  = JK + 1
              KPROFL(JK)  = MSTACK(1,MK)
              KPROF2(JK)  = MSTACK(2,MK)
              KSET2(JK)   = KDATA(I,MK)
C             PRINT *,JK,KPROFL(JK),KSET2(JK),'ISW=',ISW
              MK  = MK + 1
  600     CONTINUE
          IF (ISW.NE.255) THEN
              PRINT *,'ERROR PROCESSING PROFILER',ISW
              IPTR(1)  = 204
              RETURN
          END IF
          IF (MSTACK(1,MK).NE.1797) THEN
              PRINT *,'ERROR PROCESSING HEIGHT INCREMENT IN PROFILER'
              IPTR(1)  = 205
              RETURN
          END IF
C                   MUST SAVE THIS HEIGHT VALUE
          LHGT  = 500 + IHGT - KDATA(I,MK)
C         PRINT *,'BASE HEIGHT = ',LHGT,' INCR = ',INCRHT
          MK  = MK + 1
          IF (MSTACK(1,MK).GE.16384) THEN
              MK  = MK + 1
          END IF
C              PROCESS LEVEL DATA
C         PRINT *,'LEVEL DATA'
          DO 2000 L = 1, 43
 2020         CONTINUE
C             PRINT *,'DESC',MK,MSTACK(1,MK),JK
              ISW  = 0
C                       HEIGHT INCREMENT
              IF (MSTACK(1,MK).EQ.1797) THEN
                  INCRHT  = KDATA(I,MK)
C                 PRINT *,'NEW HEIGHT INCREMENT = ',INCRHT
                  MK  = MK + 1
C                 IF (LHGT.LT.(9250+IHGT)) THEN
C                     LHGT  = IHGT + 500 - INCRHT
C                 ELSE
C                     LHGT  = IHGT + 9250 -INCRHT
C                 END IF
              END IF
C                    MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DA
C                     AT THIS POINT
              LHGT  = LHGT + INCRHT
C             PRINT *,'LEVEL ',L,LHGT
C             IF (L.EQ.37) THEN
C                 LHGT  = LHGT + INCRHT
C             END IF
              JK  = JK + 1
C                        SAVE DESCRIPTOR
              KPROFL(JK)  = 1798
C                       SAVE SCALE
              KPROF2(JK)  = 0
C                        SAVE DATA
              KSET2(JK)   = LHGT
C             PRINT *,KPROFL(JK),KSET2(JK),JK
              ISW  = 0
              ICON  = 1
              DO 800 J = 1, 10
750               CONTINUE
                  IF (MSTACK(1,MK).EQ.1797) THEN
                        GO TO 2020
                  ELSE IF (MSTACK(1,MK).EQ.6432) THEN
C                               HI/LO MODE
                      ISW  = ISW + 1
                  ELSE IF (MSTACK(1,MK).EQ.6434) THEN
C                               Q/C TEST
                      ISW  = ISW + 2
                  ELSE IF (MSTACK(1,MK).EQ.2070) THEN
                      IF (ICON.EQ.1) THEN
C                               FIRST PASS - U,V CONSENSUS
                           ISW  = ISW + 4
                           ICON  = ICON + 1
                      ELSE
C                               SECOND PASS - W CONSENSUS
                           ISW  = ISW + 64
                      END IF
                  ELSE IF (MSTACK(1,MK).EQ.2819) THEN
C                               U VECTOR VALUE
                      ISW  = ISW + 8
                      IF (KDATA(I,MK).GE.2047) THEN
                          VECTU  = 32767
                      ELSE
                          VECTU  = KDATA(I,MK)
                      END IF
                      MK  = MK + 1
                      GO TO 800
                  ELSE IF (MSTACK(1,MK).EQ.2820) THEN
C                               V VECTOR VALUE
                      ISW  = ISW + 16
                      IF (KDATA(I,MK).GE.2047) THEN
                          VECTV  = 32767
                      ELSE
                          VECTV  = KDATA(I,MK)
                      END IF
                      IF (IAND(ISW,1).NE.0) THEN
                          IF (VECTU.EQ.32767.OR.VECTV.EQ.32767) THEN
C                               SAVE DD DESCRIPTOR
                              JK  = JK + 1
                              KPROFL(JK)  = 2817
                              KPROF2(JK)  = 0
                              KSET2(JK)   = 32767
C                               SAVE FFF DESCRIPTOR
                              JK  = JK + 1
                              KPROFL(JK)  = 2818
                              KPROF2(JK)  = 1
                              KSET2(JK)   = 32767
                          ELSE
                              CALL W3FC05 (VECTU,VECTV,DIR,SPD)
                              NDIR  = DIR
                              SPD   = SPD
                              NSPD  = SPD
C                             PRINT *,'     ',NDIR,NSPD
C                               SAVE DD DESCRIPTOR
                              JK  = JK + 1
                              KPROFL(JK)  = 2817
                              KPROF2(JK)  = 0
                              KSET2(JK)   = NDIR
C                             IF (I.EQ.1) THEN
C                                 PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK)
C                             ENDIF
C                            SAVE FFF DESCRIPTOR
                              JK  = JK + 1
                              KPROFL(JK)  = 2818
                              KPROF2(JK)  = 1
                              KSET2(JK)   = NSPD
C                             IF (I.EQ.1) THEN
C                                 PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK)
C                             ENDIF
                          END IF
                          MK  = MK + 1
                          GO TO 800
                      END IF
                  ELSE IF (MSTACK(1,MK).EQ.2866) THEN
C                               SPEED STD DEVIATION
                      ISW  = ISW + 32
C -- A CHANGE BY KEYSER : POWER DESCR. BACK TO 5568
                  ELSE IF (MSTACK(1,MK).EQ.5568) THEN
C                               SIGNAL POWER
                      ISW  = ISW + 128
                  ELSE IF (MSTACK(1,MK).EQ.2822) THEN
C                               W COMPONENT
                      ISW  = ISW + 256
                  ELSE IF (MSTACK(1,MK).EQ.2867) THEN
C                              VERT STD DEVIATION
                      ISW  = ISW + 512
CVVVVVCHANGE#1 FIX BY KEYSER  -- 12/06/1994
C   NOTE: THIS FIX PREVENTS UNNECESSARY LOOPING WHEN ALL REQ. DESCR.
C         ARE MISSING.  WOULD GO INTO INFINITE LOOP EXCEPT EVENTUALLY
C         MSTACK ARRAY SIZE IS EXCEEDED AND GET FORTRAN ERROR INTERRUPT
CDAK              ELSE
                  ELSE IF ((MSTACK(1,MK)/16384).NE.0) THEN
CAAAAACHANGE#1 FIX BY KEYSER  -- 12/06/1994
                      MK  = MK + 1
                      GO TO 750
                  END IF
                  JK  = JK + 1
C                               SAVE DESCRIPTOR
                  KPROFL(JK)  = MSTACK(1,MK)
C                              SAVE SCALE
                  KPROF2(JK)  = MSTACK(2,MK)
C                               SAVE DATA
                  KSET2(JK)   = KDATA(I,MK)
                  MK  = MK + 1
C                 PRINT *,L,'TEST   ',JK,KPROFL(JK),KSET2(JK)
  800         CONTINUE
              IF (ISW.NE.1023) THEN
                  PRINT *,'LEVEL ERROR PROCESSING PROFILER',ISW
                  IPTR(1)  = 202
                  RETURN
              END IF
 2000     CONTINUE
C                           MOVE DATA BACK INTO KDATA ARRAY
          DO 5000 LL = 1, JK
C                           DATA
              KDATA(I,LL)   = KSET2(LL)
 5000     CONTINUE
 3000 CONTINUE
      DO 5005 LL = 1, JK
C                         DESCRIPTOR
          MSTACK(1,LL)  = KPROFL(LL)
C                          SCALE
          MSTACK(2,LL)  = KPROF2(LL)
C -- A CHANGE BY KEYSER : PRINT STATEMNT SHOULD BE HERE NOT IN 5000 LOOP
C             PRINT *,LL,MSTACK(1,LL),MSTACK(2,LL),(KDATA(I,LL),I=1,4)
 5005 CONTINUE
      IPTR(31)  = JK
      RETURN
      END
      SUBROUTINE  FI8811(IPTR,IDENT,MSTACK,KDATA,KNR,
     *                  LDATA,LSTACK,MAXD,MAXR)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8811      EXPAND DATA/DESCRIPTOR REPLICATION
C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 93-05-12
C
C ABSTRACT: EXPAND DATA AND DESCRIPTOR STRINGS
C
C PROGRAM HISTORY LOG:
C   93-05-12  CAVANAUGH
C   YY-MM-DD  MODIFIER2   DESCRIPTION OF CHANGE
C
C USAGE:    CALL FI8811(IPTR,IDENT,MSTACK,KDATA,KNR,
C    *                               LDATA,LSTACK,MAXD,MAXR)
C   INPUT ARGUMENT LIST:
C     IPTR     - SEE W3FI88 ROUTINE DOCBLOCK
C     IDENT    - SEE W3FI88 ROUTINE DOCBLOCK
C     MAXR     - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE
C                CONTAINED IN A BUFR MESSAGE
C     MAXD     - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT
C                MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE
C                DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST
C                OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE
C     KDATA    - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
C                KDATA(REPORT NUMBER,PARAMETER NUMBER)
C                (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
C                 MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
C                 ARGUMENT MAXD)
C     MSTACK   - LIST OF DESCRIPTORS AND SCALE VALUES
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     KDATA    - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
C                KDATA(REPORT NUMBER,PARAMETER NUMBER)
C                (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
C                 MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
C                 ARGUMENT MAXD)
C     MSTACK   - LIST OF DESCRIPTORS AND SCALE VALUES
C
C   SUBPROGRAMS CALLED:
C     LIBRARY:
C       W3LIB    -
C
C REMARKS: ERROR RETURN:
C    IPTR(1) =
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  NAS
C
C$$$
      INTEGER        IPTR(*)
      INTEGER        KNR(MAXR)
      INTEGER        KDATA(MAXR,MAXD),LDATA(MAXD)
      INTEGER        MSTACK(2,MAXD),LSTACK(2,MAXD)
      INTEGER        IDENT(*)
C
      SAVE
C
C     PRINT *,' DATA/DESCRIPTOR REPLICATION '
      DO 1000 I = 1, KNR(1)
C                           IF NOT REPLICATION DESCRIPTOR
          IF ((MSTACK(1,I)/16384).NE.1) THEN
              GO TO 1000
          END IF
C                           IF DELAYED REPLICATION DESCRIPTOR
          IF (MOD(MSTACK(1,I),256).EQ.0) THEN
C                               SAVE KX VALUE (NR DESC'S TO REPLICATE)
              KX = MOD((MSTACK(1,I)/256),64)
C                               IF NEXT DESC IS NOT 7947 OR 7948
C                                 (I.E., 0 31 011  OR 0 31 012)
              IF (MSTACK(1,I+1).NE.7947.AND.MSTACK(1,I+1).NE.7948) THEN
C                                    SKIP IT
                  GO TO 1000
              END IF
C                               GET NR REPS FROM KDATA
              NRREPS  = KDATA(1,I+1)
              LAST  = I + 1 + KX
C                               SAVE OFF TRAILING DESCS AND DATA
              KTRAIL = KNR(1) - I - 1 - KX
              DO 100 L = 1, KTRAIL
                  NX  = I + L + KX + 1
                  LDATA(L) = KDATA(1,NX)
                  LSTACK(1,L) = MSTACK(1,NX)
                  LSTACK(2,L) = MSTACK(2,NX)
  100         CONTINUE
C                              INSERT FX DESCS/DATA NR REPS TIMES
              LAST  = I + 1
              DO 400 J = 1, NRREPS
                  NX  = I + 2
                  DO 300 K = 1, KX
                      LAST  = LAST + 1
                      KDATA(1,LAST)  = KDATA(1,NX)
                      MSTACK(1,LAST) = MSTACK(1,NX)
                      MSTACK(2,LAST) = MSTACK(2,NX)
                      NX  = NX + 1
  300             CONTINUE

  400         CONTINUE
C                               RESTORE TRAILING DATA/DESCS
              DO 500 L = 1, KTRAIL
                  LAST  = LAST + 1
                  KDATA(1,LAST) = LDATA(L)
                  MSTACK(1,LAST)  = LSTACK(1,L)
                  MSTACK(2,LAST)  = LSTACK(2,L)
  500         CONTINUE
C                               RESET KNR(1)
              KNR(1)  = LAST
          END IF
 1000 CONTINUE
      RETURN
      END
      SUBROUTINE FI8812(IPTR,IUNITB,IUNITD,ISTACK,NRDESC,KPTRB,KPTRD,
     *                     IRF1SW,NEWREF,ITBLD,ITBLD2,
     *                     KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
     *                     KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8812      BUILD TABLE B SUBSET BASED ON BUFR SEC 3
C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 93-12-23
C
C ABSTRACT: BUILD A SUBSET OF TABLE B ENTRIES THAT CORRESPOND TO
C           THE DESCRIPTORS NEEDED FOR THIS MESSAGE
C
C PROGRAM HISTORY LOG:
C   93-05-12  CAVANAUGH
C   YY-MM-DD  MODIFIER2   DESCRIPTION OF CHANGE
C
C USAGE:    CALL FI8812(IPTR,IUNITB,IUNITD,ISTACK,NRDESC,KPTRB,KPTRD,
C    *      IRF1SW,NEWREF,ITBLD,ITBLD2,
C    *      KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
C    *      KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2)
C   INPUT ARGUMENT LIST:
C     IPTR     - SEE W3FI88 ROUTINE DOCBLOCK
C     IDENT    - SEE W3FI88 ROUTINE DOCBLOCK
C     ISTACK   - LIST OF DESCRIPTORS AND SCALE VALUES
C     IUNITB   -
C     IUNITD   -
C     ISTACK   -
C     NRDESC   -
C     KFXY2    -
C     ANAME2   -
C     AUNIT2   -
C     ISCAL2   -
C     IRFVL2   -
C     IWIDE2   -
C     IRF1SW   -
C     NEWREF   -
C     ITBLD2   -
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     KDATA    - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
C                KDATA(REPORT NUMBER,PARAMETER NUMBER)
C                (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
C                 MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
C                 ARGUMENT MAXD)
C     MSTACK   - LIST OF DESCRIPTORS AND SCALE VALUES
C     KFXY1    -
C     ANAME1   -
C     AUNIT1   -
C     ISCAL1   -
C     IRFVL1   -
C     IWIDE1   -
C     ITBLD    -
C
C   SUBPROGRAMS CALLED:
C     LIBRARY:
C       W3LIB    -
C
C REMARKS: ERROR RETURN:
C    IPTR(1) =
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  NAS
C
C$$$
C  ..................................................
C
C     NEW               BASE TABLE B
C                            MAY BE A COMBINATION OF MASTER TABLE B
C                            AND ANCILLARY TABLE B
C
      INTEGER        KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*)
      CHARACTER*40   ANAME1(*)
      CHARACTER*24   AUNIT1(*)
C  ..................................................
C
C        NEW            ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE
C
      INTEGER        KFXY2(*),ISCAL2(*),IRFVL2(*),IWIDE2(*)
      CHARACTER*64   ANAME2(*)
      CHARACTER*24   AUNIT2(*)
C  ..................................................
C
C                       ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
C
      INTEGER        ITBLD2(20,*)
C  ..................................................
C
C                       NEW BASE TABLE D
C
      INTEGER        ITBLD(20,*)
C  ..................................................
      INTEGER        IPTR(*),ISTACK(*),NRDESC,NWLIST(200)
      INTEGER        NEWREF(*),KPTRB(*),KPTRD(*)
      INTEGER        IUNITB,IUNITD,ICOPY(20000),NRCOPY,IELEM,IPOS
      CHARACTER*64   AHLD64
      CHARACTER*24   AHLD24
C
      SAVE
C
C     SCAN AND DISCARD REPLICATION AND OPERATOR DESCRIPTORS
C     REPLACING SEQUENCE DESCRIPTORS WITH THEIR CORRESPONDING
C     SET OF DESCRIPTORS ALSO ELIMINATING DUPLICATES.
C
C-----------------------------------------------------------
C     PRINT *,'ENTER FI8812'
C
      DO 10 I = 1, 16384
          KPTRB(I) = -1
   10 CONTINUE
C
C
C
      IF (IPTR(14).NE.0) THEN
          DO I = 1, IPTR(14)
              KPTRB(KFXY1(I)) = I
          ENDDO
          GO TO 9000
      END IF
C
C                        READ IN TABLE B
      PRINT *,'FI8812 - READING TABLE B'
      REWIND IUNITB
      I  = 1
 4000 CONTINUE
C
      READ(UNIT=IUNITB,FMT=20,ERR=9999,END=9000)MF,
     *                    MX,MY,
     *                    (ANAME1(I)(K:K),K=1,40),
     *                    (AUNIT1(I)(K:K),K=1,24),
     *                    ISCAL1(I),IRFVL1(1,I),IWIDE1(I)
   20 FORMAT(I1,I2,I3,40A1,24A1,I5,I15,1X,I4)
      KFXY1(I)  = MF*16384 + MX*256 + MY
C     PRINT *,MF,MX,MY,KFXY1(I)
 5000 CONTINUE
      KPTRB(KFXY1(I)) = I
      IPTR(14) = I
C     PRINT *,I
C     WRITE(6,21) MF,MX,MY,KFXY1(I),
C    *                    (ANAME1(I)(K:K),K=1,40),
C    *                    (AUNIT1(I)(K:K),K=1,24),
C    *                    ISCAL1(I),IRFVL1(1,I),IWIDE1(I)
   21 FORMAT(1X,I1,I2,I3,1X,I6,1X,40A1,
     *                                 2X,24A1,2X,I5,2X,I15,1X,I4)
      I = I + 1
      GO TO 4000
C ======================================================
 9999 CONTINUE
C                        ERROR READING TABLE B
      PRINT *,'FI8812 -  ERROR READING TABLE B - RECORD ',I
      IPTR(1)  = 9
 9000 CONTINUE
      IPTR(21) =  IPTR(14)
C     PRINT *,'EXIT FI8812 - IPTR(21) =',IPTR(21),' IPTR(1) =',IPTR(1)
      RETURN
      END
      SUBROUTINE FI8813 (IPTR,MAXR,MAXD,MSTACK,KDATA,IDENT,KPTRD,KPTRB,
     *         ITBLD,ANAME1,AUNIT1,KFXY1,ISCAL1,IRFVL1,IWIDE1,IUNITB)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8813      EXTRACT TABLE A, TABLE B, TABLE D ENTRIES
C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 94-03-04
C
C ABSTRACT: EXTRACT TABLE A, TABLE B, TABLE D ENTRIES FROM A
C   DECODED BUFR MESSAGE.
C
C PROGRAM HISTORY LOG:
C   94-03-04  CAVANAUGH
C   YY-MM-DD  MODIFIER1   DESCRIPTION OF CHANGE
C
C USAGE:    CALL FI8813 (IPTR,MAXR,MAXD,MSTACK,KDATA,IDENT,KPTRD,
C    *   KPTRB,ITBLD,ANAME1,AUNIT1,KFXY1,ISCAL1,IRFVL1,IWIDE1,IUNITB)
C   INPUT ARGUMENT LIST:
C     IPTR
C     MAXR
C     MAXD
C     MSTACK
C     KDATA
C     IDENT
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:
C     IUNITB
C     ITBLD1
C     ANAME1
C     AUNIT1
C     KFXY1
C     ISCAL1
C     IRFVL1
C     IWIDE1
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS
C   MACHINE:  NAS, CYBER, WHATEVER
C
C$$$
C  ..................................................
C
C        NEW            ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE
C
      INTEGER        KFXY1(*),ISCAL1(*),IRFVL1(*),IWIDE1(*)
      CHARACTER*40   ANAME1(*)
      CHARACTER*24   AUNIT1(*)
C  ..................................................
C
C                        TABLE D
C
      INTEGER        ITBLD(20,*)
C  ..................................................
      CHARACTER*32      SPACES
      CHARACTER*8       ASCCHR
      CHARACTER*32      AAAA
C
      INTEGER           I1(20),I2(20),I3(20),KPTRB(*)
      INTEGER           IPTR(*),MAXR,MAXD,MSTACK(2,MAXD)
      INTEGER           IXA, IXB, IXD, KDATA(MAXR,MAXD)
      INTEGER           IEXTRA,KPTRD(*)
      INTEGER           KEYSET,ISCSGN(200),IRFSGN(200)
      INTEGER           IDENT(*),IHOLD,JHOLD(8),IUNITB
      EQUIVALENCE       (IHOLD,ASCCHR),(JHOLD,AAAA)
      SAVE
      DATA              SPACES/'                                '/
      DATA              IEXTRA/0/
      DATA              KEYSET/0/

C  ==============================================================
C     PRINT *,'FI8813',IPTR(41),IPTR(42),IPTR(31),IPTR(21)
C                                 BUILD SPACE CONSTANT
C                                INITIALIZE ENTRY COUNTS
      IXA  = 0
C                       NUMBER IN TABLE B
      IXB  = IPTR(21)
C
C
C                           SET FOR COMPRESSED OR NON COMPRESSED
C                                     PROCESSING
C
C     PRINT *,'FI8813 - 2',IDENT(16),IDENT(14)
      IF (IDENT(16).EQ.0) THEN
          JK  = 1
      ELSE
          JK  = IDENT(14)
      END IF
C     PRINT *,'FI8813 - 3,  JK=',JK
C
C
C                              START PROCESSING ENTRIES
C     PRINT *,'START PROCESSING ENTRIES'
C
C     DO 995 I = 1, IPTR(31)
C         IF (IPTR(45).EQ.4) THEN
C             PRINT 9958,I,MSTACK(1,I),KDATA(1,I),KDATA(1,I)
C9958         FORMAT (1X,I5,2X,I5,2X,Z8,2X,A4)
C         ELSE
C             PRINT 9959,I,MSTACK(1,I),KDATA(1,I),KDATA(1,I)
C9959         FORMAT (1X,I5,2X,I5,2X,Z16,2X,A8)
C         END IF
C 995 CONTINUE
C     PRINT *,' '
      I       = 0
      IEXTRA  = 0
 1000 CONTINUE
C
C                               SET POINTER TO CORRECT DATA POSITION
C                                 I IS THE NUMBER OF DESCRIPTORS
C                                 IEXTRA IS THE NUMBER OF WORDS ADDED
C                                       FOR TEXT DATA
C
      I  = I + 1
      IF (I.GT.IPTR(31)) THEN
C                                 RETURN IF COMPLETED SEARCH
          GO TO 9000
      END IF
      KLK  = I + IEXTRA
C     PRINT *,'ENTRY',KLK,I,IPTR(31),IEXTRA,MSTACK(1,KLK)
C
C                               IF TABLE A ENTRY OR EDITION NUMBER
C                                OR IF DESCRIPTOR IS NOT IN CLASS 0
C                                    SKIP OVER
C
      IF (MSTACK(1,KLK).EQ.1) THEN
C         PRINT *,'A ENTRY'
          GO TO 1000
      ELSE IF (MSTACK(1,KLK).EQ.2) THEN
C         PRINT *,'A ENTRY LINE 1'
          IEXTRA  = IEXTRA + 32 / IPTR(45) - 1
          GO TO 1000
      ELSE IF (MSTACK(1,KLK).EQ.3) THEN
C         PRINT *,'A ENTRY LINE 2'
          IEXTRA  = IEXTRA + 32 / IPTR(45) - 1
          GO TO 1000
      ELSE IF (MSTACK(1,KLK).GE.34048.AND.MSTACK(1,KLK).LE.34303) THEN
          LY = MOD(MSTACK(1,KLK),256)
C         PRINT *,'CLASS C - HAVE',LY,' BYTES OF TEXT'
          IF (MOD(LY,IPTR(45)).EQ.0) THEN
              IWDS  = LY / IPTR(45)
          ELSE
              IWDS  = LY / IPTR(45) + 1
          END IF
          IEXTRA  = IEXTRA + IWDS - 1
          GO TO 1000
      ELSE IF (MSTACK(1,KLK).LT.10.OR.MSTACK(1,KLK).GT.255) THEN
C         PRINT *,MSTACK(1,KLK),'          NOT CLASS 0'
          GO TO 1000
      END IF
C
C                              MUST FIND F X Y KEY FOR TABLE B
C                              OR TABLE D ENTRY
C
      IZ  = 1
      KEYSET  = 0
   10 CONTINUE
      IF (I.GT.IPTR(31)) THEN
          GO TO 9000
      END IF
      KLK  = I + IEXTRA
      IF (MSTACK(1,KLK).GE.34048.AND.MSTACK(1,KLK).LE.34303) THEN
          LY = MOD(MSTACK(1,KLK),256)
C         PRINT *,'TABLE C - HAVE',LY,' TEXT BYTES'
          IF (MOD(LY,4).EQ.0) THEN
              IWDS  = LY / IPTR(45)
          ELSE
              IWDS  = LY / IPTR(45) + 1
          END IF
          IEXTRA  = IEXTRA + IWDS - 1
          I  = I + 1
          GO TO 10
      ELSE IF (MSTACK(1,KLK)/16384.NE.0) THEN
          IF (MOD(MSTACK(1,KLK),256).EQ.0) THEN
              I  = I + 1
          END IF
          I  = I + 1
          GO TO 10
      END IF
      IF (MSTACK(1,KLK).GE.10.AND.MSTACK(1,KLK).LE.12) THEN
C         PRINT *,'FIND KEY'
C
C                  MUST INCLUDE PROCESSING FOR COMPRESSED DATA
C
C                               BUILD DESCRIPTOR SEGMENT
C
          IF (MSTACK(1,KLK).EQ.10) THEN
              CALL FI8814 (KDATA(IZ,KLK),1,MF,IERR,IPTR)
C             PRINT *,'F =',MF,KDATA(IZ,KLK),IPTR(31),I,IEXTRA
              KEYSET  = IOR(KEYSET,4)
          ELSE IF (MSTACK(1,KLK).EQ.11) THEN
              CALL FI8814 (KDATA(IZ,KLK),2,MX,IERR,IPTR)
C             PRINT *,'X =',MX,KDATA(IZ1,KLK)
              KEYSET  = IOR(KEYSET,2)
          ELSE IF (MSTACK(1,KLK).EQ.12) THEN
              CALL FI8814 (KDATA(IZ,KLK),3,MY,IERR,IPTR)
C             PRINT *,'Y =',MY,KDATA(IZ,KLK)
              KEYSET  = IOR(KEYSET,1)
          END IF
C         PRINT *,'          KEYSET =',KEYSET
          I = I + 1
          GO TO 10
      END IF
      IF (KEYSET.EQ.7) THEN
C         PRINT *,'HAVE KEY DESCRIPTOR',MF,MX,MY
C
C                               TEST NEXT DESCRIPTOR FOR TABLE B
C                               OR TABLE D ENTRY, PROCESS ACCORDINGLY
C
          KLK  = I + IEXTRA
C         PRINT *,'DESC ',MSTACK(1,KLK),KLK,I,IEXTRA,KDATA(1,KLK)
          IF (MSTACK(1,KLK).EQ.30) THEN
              IXD  = IPTR(20) + 1
              ITBLD(1,IXD) =16384 * MF + 256 * MX + MY
C             PRINT *,'SEQUENCE DESCRIPTOR',MF,MX,MY,ITBLD(1,IXD)
              GO TO 300
          ELSE IF (MSTACK(1,KLK).GE.13.AND.MSTACK(1,KLK).LE.20) THEN
              KFXY1(IXB+IZ) = 16384 * MF + 256 * MX + MY
C             PRINT *,'ELEMENT DESCRIPTOR',MF,MX,MY,KFXY1(IXB+IZ),IXB+IZ
              KPTRB(KFXY1(IXB+IZ)) = IXB+IZ
              GO TO 200
          ELSE
          END IF
C         I = I + 1
C         IF (I.GT.IPTR(31)) THEN
C             GO TO 9000
C         END IF
C         GO TO 10
      END IF
      GO TO 1000
C  ==================================================================
  200 CONTINUE
      IBFLAG   = 1
   20 CONTINUE
      KLK  = I + IEXTRA
C     PRINT *,'ZZZ',KLK,I,IEXTRA,MSTACK(1,KLK),KDATA(IZ,KLK)
      IF (MSTACK(1,KLK).LT.13.OR.MSTACK(1,KLK).GT.20) THEN
              PRINT *,'IMPROPER SEQUENCE OF DESCRIPTORS IN LIST'
C  ===============================================================
      ELSE IF (MSTACK(1,KLK).EQ.13) THEN
C         PRINT *,'13      NAME',KLK
C
C                              ELEMENT NAME PART 1 - 32 BYTES
C                                    FOR THIS PARAMETER
          JJ  = IEXTRA
          DO 21 LL = 1, 32, IPTR(45)
              LLL    = LL + IPTR(45) - 1
              KQK = I + JJ
              IHOLD  = KDATA(IZ,KQK)
              IF (IPTR(37).EQ.0) THEN
C                 CALL W3AI39 (IDATA,IPTR(45))
              END IF
              ANAME1(IXB+IZ)(LL:LLL) = ASCCHR
              JJ  = JJ + 1
   21     CONTINUE
          IEXTRA  = IEXTRA + (32 / IPTR(45)) - 1
          IBFLAG   = IOR(IBFLAG,64)
C  ===============================================================
      ELSE IF (MSTACK(1,KLK).EQ.14) THEN
C         PRINT *,'14      NAME2',KLK
C
C                              ELEMENT NAME PART 2 - 32 BYTES
C
C                                    FOR THIS PARAMETER
          JJ  = IEXTRA
          DO 22 LL = 33, 64, IPTR(45)
              LLL    = LL + IPTR(45) - 1
              KQK = I + JJ
              IHOLD  = KDATA(IZ,KQK)
              IF (IPTR(37).EQ.0) THEN
C                 CALL W3AI39 (ASCCHR,IPTR(45))
              END IF
              ANAME1(IXB+IZ)(LL:LLL) = ASCCHR
              JJ  = JJ + 1
   22     CONTINUE
          IEXTRA  = IEXTRA + (32 / IPTR(45)) - 1
          IBFLAG   = IOR(IBFLAG,32)
C  ===============================================================
      ELSE IF (MSTACK(1,KLK).EQ.15) THEN
C         PRINT *,'15      UNITS',KLK
C
C                              UNITS NAME - 24 BYTES
C
C                                    FOR THIS PARAMETER
          JJ  = IEXTRA
          DO 23 LL = 1, 24, IPTR(45)
              LLL    = LL + IPTR(45) - 1
              KQK = I + JJ
              IHOLD  = KDATA(IZ,KQK)
              IF (IPTR(37).EQ.0) THEN
C                 CALL W3AI39 (ASCCHR,IPTR(45))
              END IF
              AUNIT1(IXB+IZ)(LL:LLL) = ASCCHR
              JJ  = JJ + 1
   23     CONTINUE
          IEXTRA  = IEXTRA + (24 / IPTR(45)) - 1
          IBFLAG   = IOR(IBFLAG,16)
C  ===============================================================
      ELSE IF (MSTACK(1,KLK).EQ.16) THEN
C         PRINT *,'16      SCALE SIGN'
C
C                               SCALE SIGN - 1 BYTE
C                              0 = POS, 1 = NEG
          IHOLD = KDATA(IZ,KLK)
          KLK  = I + IEXTRA
          IF (INDEX(ASCCHR,'-').EQ.0) THEN
              ISCSGN(IZ)  = 1
          ELSE
              ISCSGN(IZ)  = -1
          END IF
C  ===============================================================
      ELSE IF (MSTACK(1,KLK).EQ.17) THEN
C         PRINT *,'17      SCALE',KLK
C
C                               SCALE - 3 BYTES
C
          KLK = I + IEXTRA
          CALL FI8814(KDATA(IZ,KLK),3,ISCAL1(IXB+IZ),IERR,IPTR)
          IF (IERR.NE.0) THEN
              PRINT *,'NON-NUMERIC CHAR - CANNOT CONVERT'
              IPTR(1) = 888
              GO TO 9000
          END IF
          ISCAL1(IXB+IZ) = ISCAL1(IXB+IZ) * ISCSGN(IZ)
          IBFLAG   = IOR(IBFLAG,8)
C  ===============================================================
      ELSE IF (MSTACK(1,KLK).EQ.18) THEN
C         PRINT *,'18      REFERENCE SCALE',KLK
C
C                              REFERENCE SIGN - 1 BYTE
C                              0 = POS, 1 = NEG
C
          KLK  = I + IEXTRA
          IHOLD  = KDATA(IZ,KLK)
          IF (INDEX(ASCCHR,'-').EQ.0) THEN
              IRFSGN(IZ) =  1
          ELSE
              IRFSGN(IZ) = -1
          END IF
C  ===============================================================
      ELSE IF (MSTACK(1,KLK).EQ.19) THEN
C         PRINT *,'19      REFERENCE VALUE',KLK
C
C                              REFERENCE VALUE - 10 BYTES/ 3 WDS
C
          JJ  = IEXTRA
          KQK  = I + JJ
          KM  = 0
          DO 26 LL = 1, 12, IPTR(45)
              KQK = I + JJ
              KM  = KM + 1
              JHOLD(KM)  = KDATA(IZ,KQK)
              JJ  = JJ + 1
   26     CONTINUE
          CALL FI8814(AAAA,10,IRFVL1(IXB+IZ),IERR,IPTR)
          IF (IERR.NE.0) THEN
              PRINT *,'NON-NUMERIC CHARACTER-CANNOT CONVERT'
              IPTR(1)  = 888
              GO TO 9000
          END IF
          IRFVL1(IXB+IZ) = IRFVL1(IXB+IZ) * IRFSGN(IZ)
          IEXTRA  = IEXTRA + 10 / IPTR(45)
C         DO 261 IZ = 1, JK
C             PRINT *,'RFVAL',IXB+IZ,JK,IRFVL1(IXB+IZ)
C 261     CONTINUE
          IBFLAG   = IOR(IBFLAG,4)
C  ===============================================================
      ELSE
C         PRINT *,'20      WIDTH',KLK
C
C                              ELEMENT DATA WIDTH - 3 BYTES
C
C         DO 27 LL = 1, 24, IPTR(45)
              KLK = I + IEXTRA
C             DO 270 IZ = 1, JK
                  CALL FI8814(KDATA(IZ,KLK),3,IWIDE1(IXB+IZ),IERR,IPTR)
                  IF (IERR.NE.0) THEN
                      PRINT *,'NON-NUMERIC CHAR - CANNOT CONVERT'
                      IPTR(1) = 888
                      GO TO 9000
                  END IF
                  IF (IWIDE1(IXB+IZ).LT.1) THEN
                      IPTR(1) = 890
C                    PRINT *,'CLASS 0 DESCRIPTOR, WIDTH=0',KFXY1(IXB+IZ)
                      GO TO 9000
                  END IF
C 270         CONTINUE
C  27     CONTINUE
          IBFLAG   = IOR(IBFLAG,2)
      END IF
C                                       NO, IT ISN'T
C
C                             IF THERE ARE ENOUGH OF THE ELEMENTS
C                             NECESSARY TO ACCEPT A TABLE B ENTRY
C
C         PRINT *,'                      IBFLAG =',IBFLAG
      IF (IBFLAG.EQ.127) THEN
C         PRINT *,'COMPLETE TABLE B ENTRY'
C                  HAVE A COMPLETE TABLE B ENTRY
          IXB  = IXB + 1
C         PRINT *,'B',IXB,JK,KFXY1(IXB),ANAME1(IXB)
C         PRINT *,'     ',AUNIT1(IXB),ISCAL1(IXB),
C    *    IRFVL1(IXB),IWIDE1(IXB)
          IPTR(21) = IXB
          GO TO 1000
      END IF
      I  = I + 1
C
C                             CHECK NEXT DESCRIPTOR
C
      IF (I.GT.IPTR(31)) THEN
C                                 RETURN IF COMPLETED SEARCH
          GO TO 9000
      END IF
      GO TO 20
C  ==================================================================
  300 CONTINUE
      ISEQ  = 0
      IJK  = IPTR(20) + 1
C     PRINT *,'SEQUENCE DESCRIPTOR',MF,MX,MY,ITBLD(1,IXD),' FOR',IJK
   30 CONTINUE
      KLK  = I + IEXTRA
C     PRINT *,'HAVE A SEQUENCE DESCRIPTOR',KLK,KDATA(IZ,KLK)
      IF (MSTACK(1,KLK).EQ.30) THEN
C                             FROM TEXT FIELD (6 BYTES/2 WDS)
C                             STRIP OUT NEXT DESCRIPTOR IN SEQUENCE
C
C                             F - EXTRACT AND CONVERT TO DECIMAL
          JJ  = IEXTRA
          KK  = 0
          DO 351 LL = 1, 6, IPTR(45)
              KQK  = I + JJ
              KK = KK + 1
              JHOLD(KK)  = KDATA(1,KQK)
              JJ  = JJ + 1
              IF (LL.GT.1) IEXTRA  = IEXTRA + 1
  351     CONTINUE
C         PRINT 349,KDATA(1,KQK)
  349     FORMAT (6X,Z24)
C                                     CONVERT TO INTEGER
          CALL FI8814(AAAA,6,IHOLD,IERR,IPTR)
C         PRINT *,'                         ',IHOLD
          IF (IERR.NE.0) THEN
              PRINT *,'NON NUMERIC CHARACTER FOUND IN F X Y'
              IPTR(1)  = 888
              GO TO 9000
          END IF
C                                CONSTRUCT SEQUENCE DESCRIPTOR
          IFF  = IHOLD / 100000
          IXX  = MOD((IHOLD/1300),100)
          IYY  = MOD(IHOLD,1300)
C                                 INSERT IN PROPER SEQUENCE
          ITBLD(ISEQ+2,IJK) = 16384 * IFF + 256 * IXX + IYY
C         PRINT *,'    SEQUENCE',IZ,AAAA,IHOLD,ITBLD(ISEQ+2,IJK),
C    *                     IFF,IXX,IYY
          ISEQ  = ISEQ + 1
          IF (ISEQ.GT.18) THEN
              IPTR(1) = 30
              RETURN
          END IF
C                                SET TO LOOK AT NEXT DESCRIPTOR
          I  = I + 1
C         IF (IPTR(45).LT.6) THEN
C             IEXTRA  = IEXTRA + 1
C         END IF
          GO TO 30
      ELSE
C                     NEXT DESCRIPTOR IS NOT A SEQUENCE DESCRIPTOR
          IF (ISEQ.GE.1) THEN
C                           HAVE COMPLETE TABLE D ENTRY
              IPTR(20) = IPTR(20) + 1
C             PRINT *,'                        INTO LOCATION ',IPTR(20)
              LZ       = ITBLD(1,IJK)
              MZ       = MOD(LZ,16384)
              KPTRD(MZ) = IJK
              I  = I - 1
          END IF
      END IF
C                              GO TEST  NEXT DESCRIPTOR
      GO TO 1000
C  ==================================================================
 9000 CONTINUE
C     PRINT *,IPTR(21),' ENTRIES IN ANCILLARY TABLE B'
C     PRINT *,IPTR(20),' ENTRIES IN ANCILLARY TABLE D'
C     DO 9050 L = 1, 16384
C         IF (KPTRD(L).GT.0) PRINT *,' D',L+32768, KPTRD(L)
C9050 CONTINUE
C     IF (I.GE.IPTR(31)) THEN
C
C       FILE FOR MODIFIED TABLE B OUTPUT
          NUMNUT = IUNITB + 1
          REWIND NUMNUT
C
C             PRINT *,' HERE IS THE NEW TABLE B',IPTR(21)
              DO 2000 KB = 1, IPTR(21)
                  JF  = KFXY1(KB) / 16384
                  JX  = MOD((KFXY1(KB) / 256),64)
                  JY  = MOD(KFXY1(KB),256)
C                 WRITE (6,2001)JF,JX,JY,ANAME1(KB),
C    *                    AUNIT1(KB),ISCAL1(KB),IRFVL1(KB),IWIDE1(KB)
                  WRITE (NUMNUT,5000)JF,JX,JY,ANAME1(KB)(1:40),
     *               AUNIT1(KB)(1:24),ISCAL1(KB),IRFVL1(KB),IWIDE1(KB)
 5000             FORMAT(I1,I2,I3,A40,A24,I5,I15,I5)
 2000         CONTINUE
 2001         FORMAT (1X,I1,1X,I2,1X,I3,2X,A40,3X,A24,2X,I5,2X,I12,
     *                     2X,I4)
C
              ENDFILE NUMNUT
C
          IF (IPTR(20).NE.0) THEN
C                                  PRINT OUT TABLE
C             PRINT *,' HERE IS THE UPGRADED TABLE D'
C             DO 3000 KB = 1, IPTR(20)
C                 PRINT 3001,KB,(ITBLD(K,KB),K=1,15)
C3000         CONTINUE
C3001         FORMAT (16(1X,I5))
          END IF
C                                    EXIT ROUTINE, ALL DONE WITH PASS
C     END IF
      RETURN
      END
      SUBROUTINE FI8814 (ASCCHR,NPOS,NEWVAL,IERR,IPTR)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8814      CONVERT TEXT TO INTEGER
C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 94-03-04
C
C ABSTRACT: CONVERT TEXT CHARACTERS TO INTEGER VALUE
C
C PROGRAM HISTORY LOG:
C   94-03-04  CAVANAUGH
C   YY-MM-DD  MODIFIER2   DESCRIPTION OF CHANGE
C
C USAGE:    CALL FI8814 (ASCCHR,NPOS,NEWVAL,IERR,IPTR)
C   INPUT ARGUMENT LIST:
C     ASCCHR   -
C     NPOS     -
C     NEWVAL   -
C     IERR     -
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C   INPUT FILES:   (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C     DDNAME1  - GENERIC NAME & CONTENT
C
C   OUTPUT FILES:  (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C     DDNAME2  - GENERIC NAME & CONTENT AS ABOVE
C     FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS
C   MACHINE:  NAS, CYBER, WHATEVER
C
C$$$
      INTEGER      IERR, IHOLD, IPTR(*)
      CHARACTER*8  AHOLD
      CHARACTER*64 ASCCHR
      EQUIVALENCE  (IHOLD,AHOLD)

      SAVE
C  ----------------------------------------------------------
      IERR    = 0
      NEWVAL  = 0
      IFLAG  = 0
C
      DO 1000 I = 1, NPOS
          IHOLD  = 0
          AHOLD(IPTR(45):IPTR(45)) = ASCCHR(I:I)
          IF (IPTR(37).EQ.1) THEN
              IF (IHOLD.EQ.32) THEN
                  IF (IFLAG.EQ.0) GO TO 1000
                  GO TO 2000
              ELSE IF (IHOLD.LT.48.OR.IHOLD.GT.57) THEN
C                 PRINT*,' ASCII IHOLD =',IHOLD
                  IERR       = 1
                  RETURN
              ELSE
                  IFLAG  = 1
                  NEWVAL     = NEWVAL * 10 + IHOLD - 48
              END IF
          ELSE
              IF (IHOLD.EQ.64) THEN
                  IF (IFLAG.EQ.0) GO TO 1000
                  GO TO 2000
              ELSE IF (IHOLD.LT.240.OR.IHOLD.GT.249) THEN
C                 PRINT*,' EBCIDIC IHOLD =',IHOLD
                  IERR       = 1
                  RETURN
              ELSE
                  IFLAG  = 1
                  NEWVAL     = NEWVAL * 10 + IHOLD - 240
              END IF
          END IF
 1000 CONTINUE
 2000 CONTINUE
      RETURN
      END
      SUBROUTINE FI8815(IPTR,IDENT,JDESC,KDATA,KFXY3,MAXR,MAXD,
     *                                ANAME3,AUNIT3,
     *                                ISCAL3,IRFVL3,IWIDE3,
     *                                KEYSET,IBFLAG,IERR)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8815      EXTRACT TABLE A, TABLE B, TABLE D ENTRIES
C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 94-03-04
C
C ABSTRACT: EXTRACT TABLE A, TABLE B, ENTRIES FROM ACTIVE BUFR MESSAGE
C   TO BE RETAINED FOR USE DURING THE DECODING OF ACTIVE BUFR MESSAGE.
C   THESE WILL BE DISCARDED WHEN DECODING OF CURRENT MESSAGE IS COMPLETE
C
C PROGRAM HISTORY LOG:
C   94-03-04  CAVANAUGH
C   YY-MM-DD  MODIFIER1   DESCRIPTION OF CHANGE
C
C USAGE:    CALL FI8815(IPTR,IDENT,JDESC,KDATA,KFXY3,MAXR,MAXD,
C    *                                ANAME3,AUNIT3,
C    *                                ISCAL3,IRFVL3,IWIDE3,
C    *                                KEYSET,IBFLAG,IERR)
C   INPUT ARGUMENT LIST:
C     IPTR     -
C     MAXR     -
C     MAXD     -
C     MSTACK   -
C     KDATA    -
C     IDENT    -
C     INARG1   - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C     INARG2   - TYPE.  EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C   OUTPUT ARGUMENT LIST:
C     ANAME3   -
C     AUNIT3   -
C     KFXY3    -
C     ISCAL3   -
C     IRFVL3   -
C     IWIDE3   -
C     WRKARG   - GENERIC DESCRIPTION, ETC., AS ABOVE.
C     OUTARG1  - EXPLAIN COMPLETELY IF ERROR RETURN
C     ERRFLAG  - EVEN IF MANY LINES ARE NEEDED
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS
C   MACHINE:  NAS, CYBER
C
C$$$
      CHARACTER*64      ANAME3(*),SPACES
      CHARACTER*24      AUNIT3(*)
C
      INTEGER           IPTR(*),MAXR,MAXD,JDESC
      INTEGER           IXA, IXB, IXD, KDATA(MAXR,MAXD)
      INTEGER           IEXTRA
      INTEGER           KEYSET
      INTEGER           KFXY3(*),IDENT(*)
      INTEGER           ISCAL3(*),ISCSGN(150)
      INTEGER           IRFVL3(*),IRFSGN(150)
      INTEGER           IWIDE3(*)

      SAVE
C  ==============================================================
C     PRINT *,'FI8815'
      IEXTRA  = 0
C                                 BUILD SPACE CONSTANT
      DO 1 I = 1, 64
          SPACES(I:I)  = ' '
    1 CONTINUE
C                                INITIALIZE ENTRY COUNTS
      IXA  = 0
      IXB  = 0
      IXD  = 0
C
C                           SET FOR COMPRESSED OR NON COMPRESSED
C                                     PROCESSING
C
      IF (IDENT(16).EQ.0) THEN
          JK  = 1
      ELSE
          JK  = IDENT(14)
      END IF
C
C                           CLEAR NECESSARY ENTRIES
C
      DO 2 IY = 1, JK
C
C                           CLEAR NEXT TABLE B ENTRY
C
          KFXY3(IXB+IY)   = 0
          ANAME3(IXB+IY)(1:64)  = SPACES(1:64)
          AUNIT3(IXB+IY)(1:24)  = SPACES(1:24)
          ISCAL3(IXB+IY)  = 0
          IRFVL3(IXB+IY)  = 0
          IWIDE3(IXB+IY)  = 0
          ISCSGN(IY)      = 1
          IRFSGN(IY)      = 1
    2 CONTINUE
C
C                              START PROCESSING ENTRIES
C
      I  = 0
 1000 CONTINUE
C
C                               SET POINTER TO CORRECT DATA POSITION
C
      K  = I + IEXTRA
C
C                              MUST FIND F X Y KEY FOR TABLE B
C                              OR TABLE D ENTRY
C
      IF (JDESC.GE.10.AND.JDESC.LE.12) THEN
   10     CONTINUE
C
C                               BUILD DESCRIPTOR SEGMENT
C
          DO 20 LY  = 1,JK
              IF (JDESC.EQ.10) THEN
                  KFXY3(IXB+LY) = KDATA(K,1) * 16384 + KFXY3(IXB+LY)
                  KEYSET  = IOR(KEYSET,4)
                  I = I + 1
                  GO TO 10
              ELSE IF (JDESC.EQ.11) THEN
                  KFXY3(IXB+LY) = KDATA(K,1) * 256 + KFXY3(IXB+LY)
                  KEYSET  = IOR(KEYSET,2)
                  I = I + 1
                  GO TO 10
              ELSE IF (JDESC.EQ.12) THEN
                  KFXY3(IXB+LY) = KDATA(K,1) + KFXY3(IXB+LY)
                  KEYSET  = IOR(KEYSET,1)
              END IF
   20     CONTINUE
C  ==================================================================
      ELSE IF (JDESC.GE.13.AND.JDESC.LE.20) THEN
          DO 250 IZ = 1, JK
              IF (JDESC.EQ.13) THEN
C
C                              ELEMENT NAME PART 1 - 32 BYTES/8 WDS
C
                  CALL GBYTES (ANAME3(IXB+IZ),KDATA(K,IZ),0,32,0,8)
                  IBFLAG   = IOR(IBFLAG,16)
              ELSE IF (JDESC.EQ.14) THEN
C
C                              ELEMENT NAME PART 2 - 32 BYTES/8 WDS
C
                 CALL GBYTES(ANAME3(IXB+IZ)(33:33),KDATA(K,IZ),0,32,0,8)
              ELSE IF (JDESC.EQ.15) THEN
C
C                              UNITS NAME - 24 BYTES/6 WDS
C
                  CALL GBYTES (AUNIT3(IXB+IZ)(1:1),KDATA(K,IZ),0,32,0,6)
                  IBFLAG   = IOR(IBFLAG,8)
              ELSE IF (JDESC.EQ.16) THEN
C
C                              UNITS SCALE SIGN - 1 BYTE/ 1 WD
C                              0 = POS, 1 = NEG
                  IF (KDATA(K,1).NE.48) THEN
                      ISCSGN(IZ)  = -1
                  ELSE
                      ISCSGN(IZ)  = 1
                  END IF
              ELSE IF (JDESC.EQ.17) THEN
C
C                              UNITS SCALE - 3 BYTES/ 1 WD
C
                  CALL FI8814(KDATA(K,IZ),3,ISCAL3(IXB+IZ),IERR,IPTR)
                  IF (IERR.NE.0) THEN
                      PRINT *,'NON-NUMERIC CHARACTER - CANNOT CONVERT'
                      IPTR(1) = 888
                      RETURN
                  END IF
                  IBFLAG   = IOR(IBFLAG,4)
              ELSE IF (JDESC.EQ.18) THEN
C
C                              UNITS REFERENCE SIGN - 1 BYTE/ 1 WD
C                              0 = POS, 1 = NEG
C
                  IF (KDATA(K,1).EQ.48) THEN
                      IRFSGN(IZ) =  1
                  ELSE
                      IRFSGN(IZ) = -1
                  END IF
              ELSE IF (JDESC.EQ.19) THEN
C
C                              UNITS REFERENCE VALUE - 10 BYTES/ 3 WDS
C
                  CALL FI8814(KDATA(K,IZ),10,IRFVL3(IXB+IZ),IERR,IPTR)
                  IF (IERR.NE.0) THEN
                      PRINT *,'NON-NUMERIC CHARACTER-CANNOT CONVERT'
                      IPTR(1)  = 888
                      RETURN
                  END IF
                  IBFLAG   = IOR(IBFLAG,2)
              ELSE
C
C                              ELEMENT DATA WIDTH - 3 BYTES/ 1 WD
C
                  CALL FI8814(KDATA(K,1),3,IWIDE3(IXB+1),IERR,IPTR)
                  IF (IERR.NE.0) THEN
                      PRINT *,'NON-NUMERIC CHARACTER-CANNOT CONVERT'
                      IPTR(1)  = 888
                      RETURN
                  END IF
                  IBFLAG   = IOR(IBFLAG,1)
              END IF
  250     CONTINUE
      END IF
C  ==================================================================
 9000 RETURN
      END
      SUBROUTINE FI8818(IPTR,
     *                KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
     *                KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,
     *                KPTRB)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8818      MERGE ANCILLARY & STANDARD B ENTRIES
C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: YY-MM-DD
C
C ABSTRACT: START ABSTRACT HERE AND INDENT TO COLUMN 5 ON THE
C   FOLLOWING LINES.  SEE NMC HANDBOOK SECTION 3.1.1. FOR DETAILS
C
C PROGRAM HISTORY LOG:
C   YY-MM-DD  CAVANAUGH
C   YY-MM-DD  MODIFIER1   DESCRIPTION OF CHANGE
C
C USAGE:    CALL FI8818(IPTR,
C    *                KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
C    *                KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,KPTRB)
C   INPUT ARGUMENT LIST:
C     IPTR     -
C     KFXY1    -
C     ANAME1   -
C     AUNIT1   -
C     ISCAL1   -
C     IRFVL1   -
C     IWIDE1   -
C     KFXY2    -
C     ANAME2   -
C     AUNIT2   -
C     ISCAL2   -
C     IRFVL2   -
C     IWIDE2   -
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     IPTR     -
C     KFXY1    -
C     ANAME1   -
C     AUNIT1   -
C     ISCAL1   -
C     IRFVL1   -
C     IWIDE1   -
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS
C   MACHINE:  NAS, CYBER, WHATEVER
C
C$$$
C  ..................................................
C
C     NEW               BASE TABLE B
C                            MAY BE A COMBINATION OF MASTER TABLE B
C                            AND ANCILLARY TABLE B
C
      INTEGER        KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*)
      CHARACTER*40   ANAME1(*)
      CHARACTER*24   AUNIT1(*)
C  ..................................................
C
C        NEW            ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE
C
      INTEGER        KFXY2(*),ISCAL2(*),IRFVL2(*),IWIDE2(*)
      CHARACTER*64   ANAME2(*)
      CHARACTER*24   AUNIT2(*)
C  ..................................................
      INTEGER           IPTR(*),KPTRB(*)

      SAVE
C
C                       SET UP POINTERS
C     PRINT *,'FI8818-A',IPTR(21),IPTR(41)
      KAB   = 1
      KB    = 1
 1000 CONTINUE
C     PRINT *,KB,KAB,KFXY1(KB),KFXY2(KAB),IPTR(21)
      IF (KB.GT.IPTR(21)) THEN
C                                 NO MORE MASTER ENTRIES
C         PRINT *,'NO MORE MASTER ENTRIES'
          IF (KAB.GT.IPTR(41)) THEN
               GO TO 5000
          END IF
C                                  APPEND ANCILLARY ENTRY
          GO TO 2000
      ELSE IF (KB.LE.IPTR(21)) THEN
C                                  HAVE MORE MASTER ENTRIES
          IF (KAB.GT.IPTR(41)) THEN
C                                  NO MORE ANCILLARY ENTRIES
              GO TO 5000
          END IF
          IF (KFXY2(KAB).EQ.KFXY1(KB)) THEN
C                                  REPLACE MASTER ENTRY
              GO TO 3000
          ELSE IF (KFXY2(KAB).LT.KFXY1(KB)) THEN
C                                  INSERT ANCILLARY ENTRY
              GO TO 2000
          ELSE IF (KFXY2(KAB).GT.KFXY1(KB)) THEN
C                                  SKIP MASTER ENTRY
              KB  = KB + 1
          END IF
      END IF
      GO TO 1000
 2000 CONTINUE
      IPTR(21)  = IPTR(21) + 1
      KPTRB(KFXY2(KAB)) = IPTR(21)
C                                  APPEND ANCILLARY ENTRY
      KFXY1(IPTR(21))        = KFXY2(KAB)
      ANAME1(IPTR(21))(1:40) = ANAME2(KAB)(1:40)
      AUNIT1(IPTR(21))       = AUNIT2(KAB)
      ISCAL1(IPTR(21))       = ISCAL2(KAB)
      IRFVL1(1,IPTR(21))       = IRFVL2(KAB)
      IWIDE1(IPTR(21))       = IWIDE2(KAB)
C     PRINT *,IPTR(21),KFXY1(IPTR(21)),' APPENDED'
      KAB                   = KAB + 1
      GO TO 1000
 3000 CONTINUE
C                                  REPLACE MASTER ENTRY
      KFXY1(KB)       = KFXY2(KAB)
      ANAME1(KB)      = ANAME2(KAB)(1:40)
      AUNIT1(KB)      = AUNIT2(KAB)
      ISCAL1(KB)      = ISCAL2(KAB)
      IRFVL1(1,KB)    = IRFVL2(KAB)
      IWIDE1(KB)      = IWIDE2(KAB)
C     PRINT *,KB,KFXY1(KB),'REPLACED',IWIDE1(KB)
      KAB             = KAB + 1
      KB              = KB + 1
      GO TO 1000
 5000 CONTINUE
      IPTR(41)  = 0
C                                  PROCESSING COMPLETE
C     PRINT *,'FI8818-B',IPTR(21),IPTR(41)
C     DO 6000 I = 1, IPTR(21)
C         PRINT *,'FI8818-C',I,KFXY1(I),IWIDE1(I)
C6000 CONTINUE
      RETURN
      END
      SUBROUTINE FI8819(IPTR,ITBLD,ITBLD2,KPTRD)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8819      MERGE ANCILLARY & MASTER TABLE D
C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: YY-MM-DD
C
C ABSTRACT: MERGE TABLE D ENTRIES WITH THE ENTRIES FROM THE STANDARD
C   TABLE D. ASSURE THAT ENTRIES ARE SEQUENTIAL.
C
C PROGRAM HISTORY LOG:
C   YY-MM-DD  CAVANAUGH
C   YY-MM-DD  MODIFIER1   DESCRIPTION OF CHANGE
C
C USAGE:    CALL FI8819(IPTR,ITBLD,ITBLD2,KPTRD)
C   INPUT ARGUMENT LIST:
C     IPTR     -
C     ITBLD    -
C     ITBLD2   -
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     IPTR     -
C     ITBLD    -
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  NAS, CYBER
C
C$$$
C  ..................................................
C
C                       ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
C
      INTEGER        ITBLD2(20,*)
C  ..................................................
C
C                       NEW BASE TABLE D
C
      INTEGER        ITBLD(20,*)
C  ..................................................
      INTEGER           IPTR(*),KPTRD(*)

      SAVE
C     PRINT *,'FI8819-A',IPTR(20),IPTR(42)
C                       SET UP POINTERS
      DO 1000 I = 1, IPTR(42)
          IPTR(20) = IPTR(20) + 1
          DO 500 J = 1, 20
               ITBLD(J,IPTR(20)) = ITBLD2(J,I)
               MPTRD = MOD(ITBLD(J,IPTR(20)),16384)
               KPTRD(MPTRD) = IPTR(20)
  500     CONTINUE
 1000 CONTINUE
C  =======================================================
      IPTR(42) = 0
C     PRINT *,'MERGED TABLE D -- FI8819-B',IPTR(20),IPTR(42)
C     DO 6000 I = 1, IPTR(20)
C         WRITE (6,6001)I,(ITBLD(J,I),J=1,20)
C6001     FORMAT(15(1X,I5))
C6000 CONTINUE
      RETURN
      END
      SUBROUTINE FI8820 (ITBLD,IUNITD,IPTR,ITBLD2,KPTRD)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8820      READ IN BUFR TABLE D
C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 93-05-06
C
C ABSTRACT: READ IN BUFR TABLE D
C
C PROGRAM HISTORY LOG:
C   93-05-06  CAVANAUGH
C   YY-MM-DD  MODIFIER1   DESCRIPTION OF CHANGE
C
C USAGE:    CALL FI8820 (ITBLD,IUNITD,IPTR,ITBLD2,KPTRD)
C   INPUT ARGUMENT LIST:
C     IUNITD   - UNIT NUMBER FOR TABLE D INPUT
C     IPTR     - ARRAY OF WORKING VALUES
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     ITBLD    - ARRAY TO CONTAIN TABLE D
C
C REMARKS:
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  NAS
C
C$$$
C  ..................................................
C
C                       ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
C
      INTEGER        ITBLD2(20,*)
C  ..................................................
C
C                       NEW BASE TABLE D
C
      INTEGER        ITBLD(20,*)
C  ..................................................
C
      INTEGER       IHOLD(33),IPTR(*),KPTRD(*)
      LOGICAL       MORE

      SAVE
C
      MORE  = .TRUE.
      I  = 0
C
C                                  READ IN TABLE D, BUT JUST ONCE
C     PRINT *,'TABLE D SWITCH=',IPTR(20),' ANCILLARY D SW=',IPTR(42)
      IF (IPTR(20).EQ.0) THEN
          DO 1000 MM = 1, 16384
              KPTRD(MM) = -1
 1000     CONTINUE
          IERR  = 0
          PRINT *,'FI8820 - READING TABLE D'
          KEY = 0
  100     CONTINUE
C                                 READ NEXT TABLE D ENTRY
          READ(IUNITD,15,ERR=9998,END=9000)(IHOLD(M),M=1,33)
   15     FORMAT(11(I1,I2,I3,1X),3X)
C                                  BUILD KEY FROM MASTER D ENTRY
C                             INSERT NEW MASTER INTO TABLE B
          I  = I + 1
          IPTR(20)  = IPTR(20) + 1
          DO 25 JJ = 1, 41, 3
              KK = (JJ/3) + 1
              IF (JJ.LE.31) THEN
                  ITBLD(KK,I) = IHOLD(JJ)*16384 +
     *                                 IHOLD(JJ+1)*256 + IHOLD(JJ+2)
                   IF (ITBLD(KK,I).LT.1.OR.ITBLD(KK,I).GT.65535) THEN
                       ITBLD(KK,I) = 0
                       GO TO 25
                   END IF
              ELSE
                  ITBLD(KK,I)  = 0
              END IF
   25     CONTINUE
          MPTRD = MOD(ITBLD(1,I),16384)
          KPTRD(MPTRD) = I
   50     CONTINUE
C         WRITE (6,51)I,(ITBLD(L,I),L=1,15)
   51     FORMAT (7H TABLED,16(1X,I5))
          GO TO 100
      ELSE
C         PRINT *,'TABLE D IS IN PLACE'
      END IF
      GO TO 9999
 9000 CONTINUE
      CLOSE(UNIT=IUNITD,STATUS='KEEP')
      GO TO 9999
 9998 CONTINUE
      IPTR(1)  = 8
C
 9999 CONTINUE
C     PRINT *,'THERE ARE',IPTR(20),' ENTRIES IN TABLE D'
      RETURN
      END