      SUBROUTINE W3FI85(ISTEP,IUNITB,IUNITD,IBFSIZ,ISECT1,ISECT3,
     *    JIF,JDESC,NEWNR,IDATA,RDATA,ATEXT,KASSOC,
     *    KIF,KDESC,NRDESC,ISEC2D,ISEC2B,
     *    KDATA,KARY,KBUFR,IERRTN)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    W3FI85      GENERATE BUFR MESSAGE
C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 93-12-03
C
C ABSTRACT: USING INFORMATION AVAILABLE IN SUPPLIED ARRAYS, GENERATE
C   A BUFR MESSAGE (WMO CODE FM94).  THERE MAY BE  A SECTION 2
C   INCLUDED IN THE BUFR MESSAGE IF THE USER FOLLOWS PROPER PROCEDURE.
C   MESSAGES ARE CONSTRUCTED IN ACCORDANCE WITH BUFR EDITION 2. ENTRIES
C   FOR SECTION 1 MUST BE PASSED TO THIS ROUTINE IN THE ISECT1 ARRAY.
C   ENTRIES FOR SECTION 3 MUST BE PASSED TO THIS ROUTINE IN ISECT3.
C
C
C       IN THE EVENT THAT THE USER REQUESTS A REDUCTION OF REPORTS
C   IN A BUFR MESSAGE IF A PARTICULAR MESSAGE BECOMES OVERSIZED, THE
C   POSSIBILITY EXISTS OF THE LAST BLOCK OF DATA PRODUCING AN OVERSIZED
C   MESSAGE. THE USER MUST VERIFY THAT ISECT3(6) DOES IN FACT EQUAL
C   ZERO TO ASSURE THAT ALL OF THE DATA HAS BEEN INCLUDED AS OUTPUT.
C
C PROGRAM HISTORY LOG:
C   93-09-29  CAVANAUGH
C   94-03-22  J. HOPPA  - CORRECTED AN ERROR WHEN WRITING THE
C                         DESCRIPTORS INTO THE BUFR MESSAGE
C   94-03-31  J. HOPPA  - ADDED THE SUBSET NUMBER TO THE PARAMETER LIST
C                         OF SUBROUTINE FI8501
C   94-04-15  J. HOPPA  - ADDED KBUFR TO THE PARAMETER LIST OF
C                         SUBROUTINE FI8502
C   94-04-20  J. HOPPA  - ADDED THE KDATA PARAMETER COUNTER TO THE
C                         PARAMETER LIST OF SUBROUTINE FI8501
C   95-04-29  J. HOPPA  - CHANGED NQ AND N TO KARY(2)
C                       - CHANGED JK TO KARY(11)
C                       - ADDED AN ASSIGNMENT TO KARY(2) SO HAVE
C                         SOMETHING TO PASS TO SUBROUTINES
C                       - DELETED JK AND LL FROM CALL TO FI8501
C
C USAGE: CALL W3FI85(ISTEP,IUNITB,IUNITD,IBFSIZ,ISECT1,ISECT3,
C    *    JIF,JDESC,NEWNR,IDATA,RDATA,ATEXT,KASSOC,
C    *    KIF,KDESC,NRDESC,ISEC2D,ISEC2B,
C    *    KDATA,KARY,KBUFR,IERRTN)
C   INPUT ARGUMENT LIST:
C     ISTEP    - KEY FOR SELECTION OF PROCESSING STEP
C            1  = PROCESS INTEGER/TEXT ARRAY INTO KDATA
C            2  = PROCESS REAL/TEXT ARRAY INTO KDATA
C            3  = CONSTRUCT BUFR MESSAGE
C     IUNITB   - UNIT NUMBER OF DEVICE CONTAINING TABLE B
C     IUNITD   - UNIT NUMBER OF DEVICE CONTAINING TABLE D
C     IBFSIZ   - SIZE IN BYTES OF BUFR MESSAGE ARRAY (KBUFR)
C                  SHOULD BE A MULTIPLE OF WORD SIZE.
C     ISECT1   - CONTAINS INFORMATION TO ENTER INTO SECTION 1
C          ( 1) EDITION NUMBER
C          ( 2) BUFR MASTER TABLE NUMBER
C                   0 = METEOROLOGICAL
C                   OTHERS NOT YET DEFINED
C          ( 3) ORIGINATING CENTER - SUBCENTER NUMBER
C          ( 4) ORIGINATING CENTER NUMBER
C          ( 5) UPDATE SEQUENCE NUMBER
C          ( 6) OPTIONAL SECTION FLAG
C                   SHOULD BE SET TO ZERO UNLESS USER
C                   WRITE ADDITIONAL CODE TO ENTER LOCAL
C                   INFORMATION INTO SECTION 3
C          ( 7) BUFR MESSAGE TYPE
C          ( 8) BUFR MESSAGE SUB_TYPE
C          ( 9) MASTER TABLE VERSION NUMBER
C          (10) LOCAL TABLE VERSION NUMBER
C          (11) YEAR OF CENTURY    - REPRESENTATIVE OF DATA
C          (12) MONTH              - REPRESENTATIVE OF DATA
C          (13) DAY                - REPRESENTATIVE OF DATA
C          (14) HOUR               - REPRESENTATIVE OF DATA
C          (15) MINUTE             - REPRESENTATIVE OF DATA
C          (16)-(20)  UNUSED
C
C     ISECT3   - VALUES TO BE INSERTED INTO SECTION 3, AND
C                TO CONTROL REPORT REDUCTION FOR OVERSIZED MESSAGES
C          (1)  NUMBER OF SUBSETS
C                   DEFINES THE NUMBER OF SUBSETS BEING PASSED TO THE
C                   ENCODER ROUTINE FOR INCLUSION INTO A BUFR MESSAGE.
C                   IF THE USER HAS SPECIFIED THE USE OF THE
C                   SUBSET/REPORT REDUCTION ACTIVATION SWITCH, THEN
C                   A PART OF THOSE SUBSETS MAY BE USED FOR THE CURRENT
C                   MESSAGE AND THE REMAINDER RETAINED FOR A
C                   SUBSEQUENT MESSAGE.
C          (2)  OBSERVED FLAG
C                   0 = OBSERVED DATA
C                   1 = OTHER DATA
C          (3)  COMPRESSED FLAG
C                   0 = NONCOMPRESSED
C                   1 = COMPRESSED
C          (4)  SUBSET/REPORT REDUCTION ACTIVATION SWITCH
C                   USED TO CONTROL THE NUMBER OF REPORTS ENTERED INTO
C                   A BUFR MESSAGE WHEN MAXIMUM MESSAGE SIZE IS EXCEEDED
C                   0 = OPTION NOT ACTIVE
C                   1 = OPTION IS ACTIVE. UNUSED SUBSETS WILL BE
C                       SHIFTED TO LOW ORDER POSITIONS OF ENTRY ARRAY.
C                   2 = OPTION IS ACTIVE. UNUSED SUBSETS WILL REMAIN
C                       IN ENTRY POSITIONS.
C
C                       NOTE:- IF THIS FLAG IS SET TO ANY OTHER
C                       VALUES, PROGRAM WILL BE TERMINATED WITH AN
C                       ERROR CONDITION.
C          (5)  NUMBER OF REPORTS TO DECREMENT BY, IF OVERSIZED MESSAGE
C                   (MINIMUM VALUE = ONE).  IF ZERO IS ENTERED, IT WILL
C                   BE REPLACED BY ONE.
C          (6) NUMBER OF UNUSED REPORTS RETURNED TO USER
C          (7) NUMBER OF REPORTS INCLUDED IN MESSAGE
C          (8) NUMBER OF TABLE B ENTRIES AVAILABLE TO DECODER
C          (9) NUMBER OF TABLE D ENTRIES AVAILABLE TO DECODER
C         (10) TEXT INPUT FLAG
C                   0  = ASCII INPUT
C                   1  = EBCIDIC INPUT
C
C     JIF      - JDESC INPUT FORMAT FLAG
C                      0  = F X Y
C                      1  = DECIMAL FORMAT
C     JDESC    - LIST OF DESCRIPTORS TO GO INTO SECTION 3
C                 EACH DESCRIPTOR = F * 16384 + X * 256 + Y
C                     THEY MAY OR MAY NOT BE AN EXACT MATCH OF THE
C                     WORKING DESCRIPTOR LIST IN KDESC.  THIS SET OF
C                     DESCRIPTORS MAY CONTAIN SEQUENCE DESCRIPTORS TO
C                     PROVIDE ADDITIONAL COMPRESSION WITHIN THE BUFR
C                     MESSAGE.  THERE MAY BE AS FEW AS ONE SEQUENCE
C                     DESCRIPTOR, OR AS MANY DESCRIPTORS AS THERE ARE
C                     IN KDESC.
C     NEWNR    - NR OF DESCRIPTORS IN JDESC
C     IDATA    - INTEGER ARRAY DIMENSIONED BY THE NUMBER OF
C                DESCRIPTORS TO BE USED
C     RDATA    - REAL ARRAY DIMENSIONED BY THE NUMBER OF
C                DESCRIPTORS TO BE USED
C     ATEXT    - ARRAY CONTAINING ALL TEXT DATA ASSOCIATED WITH A
C                SPECIFIC REPORT.  ALL DATA IDENTIFIED AS TEXT DATA MUST
C                BE IN ASCII.
C     KASSOC   - INTEGER ARRAY DIMENSIONED BY THE NUMBER OF DESCRIPTORS
C                TO BE USED, CONTAINING THE ASSOCIATED FIELD VALUES
C                FOR ANY ENTRY IN THE DESCRIPTOR LIST.
C     KIF      - KDESC INPUT FORMAT FLAG
C                      0  = F X Y
C                      1  = DECIMAL FORMAT
C     KDESC    - LIST OF DESCRIPTORS TO GO INTO SECTION 3
C                     FULLY EXPANDED SET OF WORKING DESCRIPTORS. THERE
C                     SHOULD BE AN ELEMENT DESCRIPTOR FOR EVERY DATA
C                     ENTRY, BUT THERE SHOULD BE
C                            NO SEQUENCE DESCRIPTORS
C     NRDESC   - NR OF DESCRIPTORS IN KDESC
C     ISEC2D - DATA OR TEXT TO BE ENTERED INTO SECTION 2
C     ISEC2B - NUMBER OF BYTES OF DATA IN ISEC2D
C
C   OUTPUT ARGUMENT LIST:
C     KDATA    - SOURCE DATA ARRAY . A 2-DIMENSION INTEGER ARRAY
C                      WHERE KDATA(SUBSET,PARAM)
C                             SUBSET = SUBSET NUMBER
C                             PARAM  = PARAMETER NUMBER
C     KARY     - WORKING ARRAY FOR MESSAGE UNDER CONSTRUCTION
C            (1) UNUSED
C            (2) PARAMETER POINTER
C            (3) MESSAGE BIT POINTER
C            (4) DELAYED REPLICATION FLAG
C                   0 = NO DELAYED REPLICATION
C                   1 = CONTAINS DELAYED REPLICATION
C            (5) BIT POINTER FOR START OF SECTION 4
C            (6) UNUSED
C            (7) NR OF BITS FOR PARAMETER/DATA PACKING
C            (8) TOTAL BITS FOR ASCII DATA
C            (9) SCALE CHANGE VALUE
C           (10) INDICATOR (USED IN W3FI85)
C                                1 = NUMERIC DATA
C                                2 = TEXT DATA
C           (11) POINTER TO CURRENT POS IN KDESC
C           (12) UNUSED
C           (13) UNUSED
C           (14) UNUSED
C           (15) DATA TYPE
C           (16) UNUSED
C           (17) UNUSED
C           (18) WORDS ADDED FOR TEXT OR ASSOCIATED FIELDS
C           (19) LOCATION FOR TOTAL BYTE COUNT
C           (20) SIZE OF SECTION 0
C           (21) SIZE OF SECTION 1
C           (22) SIZE OF SECTION 2
C           (23) SIZE OF SECTION 3
C           (24) SIZE OF SECTION 4
C           (25) SIZE OF SECTION 5
C           (26) NR BITS ADDED BY TABLE C OPERATOR
C           (27) BIT WIDTH OF ASSOCIATED FIELD
C           (28) JDESC INPUT FORM FLAG
C                      0 = DESCRIPTOR IN F X Y FORM
C                                  F IN JDESC(1,I)
C                                  X IN JDESC(2,I)
C                                  Y IN JDESC(3,I)
C                      1 = DESCRIPTOR IN DECIMAL FORM IN JDESC(1,I)
C           (29) KDESC INPUT FORM FLAG
C                      0 = DESCRIPTOR IN F X Y FORM
C                                  F IN KDESC(1,I)
C                                  X IN KDESC(2,I)
C                                  Y IN KDESC(3,I)
C                      1 = DESCRIPTOR IN DECIMAL FORM IN KDESC(1,I)
C           (30) BUFR MESSAGE TOTAL BYTE COUNT
C     KBUFR    - ARRAY TO CONTAIN COMPLETED BUFR MESSAGE
C     IERRTN   - ERROR RETURN FLAG
C     KSEQ     - WORKING ARRAY FOR TABLE D INITIAL SEARCH KEY
C     KNUM     - WORKING ARRAY FOR TABLE D NUMBER OF DESC'S IN SEQ
C     KLIST    - WORKING ARRAY FOR TABLE D SEQUENCES
C     ANAME    - TABLE B  DESCRIPTOR NAMES
C     AUNITS   - TABLE B  DESCRIPTOR UNITS
C     LDESC    - TABLE B  DECIMAL EQUIV OF F X Y VALUES
C     KSCALE   - TABLE B  STANDARD SCALE VALUES
C     KFRVAL   - TABLE B  REFERENCE VALUES
C     KRFVSW   - TABLE B  SWITCHES TO INDICATE IF HAVE NEW/OLD REF VAL
C     NEWRFV   - TABLE B  NEW REFERENCE VALUES
C     KWIDTH   - ARRAY OF BIT WIDTHS FOR EACH ENTRY IN TABLE B
C
C REMARKS:
C         IERRTN    = 0    NORMAL RETURN, BUFR MESSAGE RESIDES IN KBUFR
C                          IF ISECT3(4)= 0, ALL REPORTS HAVE BEEN
C                                           PROCESSED INTO A BUFR
C                                           MESSAGE
C                          IF ISECT3(4)= 1, A BUFR MESSAGE HAS BEEN
C                                          GENERATED WITH ALL OR PART OF
C                                          THE DATA PASSED TO THIS
C                                          ROUTINE. ISECT3(6) CONTAINS
C                                          THE NUMBER OF REPORTS THAT
C                                          WERE NOT USED BUT ARE BEING
C                                          HELD FOR THE NEXT MESSAGE.
C                   = 1    BUFR MESSAGE CONSTRUCTION WAS HALTED
C                          BECAUSE CONTENTS EXCEEDED MAXIMUM SIZE
C                          (ONLY WHEN ISECT3(4) = 0)
C                   = 2    BUFR MESSAGE CONSTRUCTION WAS HALTED
C                          BECAUSE OF ENCOUNTER WITH A DESCRIPTOR
C                          NOT FOUND IN TABLE B.
C                   = 3    ROUTINE WAS CALLED WITH NO SUBSETS
C                   = 4    ERROR OCCURED WHILE READING TABLE B
C                   = 5    AN ATTEMPT WAS MADE TO EXPAND JDESC
C                          INTO KDESC, BUT A DESCRIPTOR INDICATING
C                          DELAYED REPLICATION WAS ENCOUNTERED
C                   = 6    ERROR OCCURED WHILE READING TABLE D
C                   = 7    DATA VALUE COULD NOT BE CONTAINED
C                          IN SPECIFIED BIT WIDTH
C                   = 8    DELAYED REPLICATION NOT PERMITTED
C                          IN COMPRESSED DATA FORMAT
C                   = 9    AN OPERATOR DESCRIPTOR 2 04 YYY OPENING
C                          AN ASSOCIATED FIELD (YYY NOT EQ ZERO)
C                          WAS NOT FOLLOWED BY THE DEFINING DESCRIPTOR
C                          0 31 021 (7957 DECIMAL).
C                   = 10   DELAYED REPLICATION DESCRIPTOR WAS NOT
C                          FOLLOWED BY DESCRIPTOR FOR DELAYED
C                          REPLICATION FACTOR.
C                                0 31 001
C                                0 31 002
C                                0 31 011
C                                0 31 012
C                   = 11   ENCOUNTERED A REFERENCE VALUE THAT FORCED A
C                          DATA ELEMENT TO BECOME NEGATIVE
C                   = 12   NO MATCHING TABLE D ENTRY FOR SEQUENCE
C                          DESCRIPTOR.
C                   = 13   ENCOUNTERED A NON-ACCEPTABLE DATA ENTRY FLAG.
C                          ISECT3(6) SHOULD BE 0 OR 1.
C                   = 14   CONVERTING DESCRIPTORS FXY->DECIMAL,
C                          NUMBER TO CONVERT = 0
C                   = 15   NO DESCRIPTORS SPECIFIED FOR SECTION 3
C                   = 16   INCOMPLETE TABLE B, NUMBER OF DESCRIPTORS
C                          IN TABLE B DOES NOT MATCH NUMBER OF
C                          DESCRIPTORS NEEDED TO CONSTRUCT BUFR MESSAGE
C                   = 20   INCORRECT ENTRY OF REPLICATION OR SEQUENCE
C                          DESCRIPTOR IN LIST OF REFERENCE VALUE CHANGES
C                   = 21   INCORRECT OPERATOR DESCRIPTOR IN LIST OF
C                          REFERENCE VALUE CHANGES
C                   = 22   ATTEMPTING TO ENTER NEW REFERENCE VALUE INTO
C                          TABLE B, BUT DESCRIPTOR DOES NOT EXIST IN
C                          CURRENT MODIFIED TABLE B
C
C ATTRIBUTES:
C   LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN
C   MACHINE:  HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256
C
C$$$
C
      REAL           RDATA(*)
C
      INTEGER        IDATA(*),LOWEST,MAXVAL,JSTART
      INTEGER        KARY(*),MISG,LL
      INTEGER        KDESC(3,*),KASSOC(*)
      INTEGER        IBITS(32)
      INTEGER        ZEROS(255)
      INTEGER        INDEXB(16383)
      CHARACTER*9    CCITT
      CHARACTER*4    AHOLD(2)
      CHARACTER*1    ATEXT(*)
      LOGICAL*1      TEXT
      LOGICAL*1      MSGFLG,DUPFLG
C  =====================================
C      INFORMATION REQUIRED FOR CONSTRUCTION OF BUFR MESSAGE
      INTEGER        ISECT1(*)
      INTEGER        ISEC2B,ISEC2D(255)
      INTEGER        ISECT3(*)
      INTEGER        JDESC(3,*)
      INTEGER        NEWNR
      INTEGER        KDATA(500,*)
      INTEGER        KBUFR(*)
C  =====================================
C                   TABLE B INFORMATION
      INTEGER        LDESC(800),KT(800)
      INTEGER        KSCALE(800)
      INTEGER        KRFVAL(800),KRFVSW(800),NEWRFV(800)
      INTEGER        KWIDTH(800)
      CHARACTER*40   ANAME(800)
      CHARACTER*25   AUNITS(800)
C  =====================================
C                   TABLE D INFORMATION
      INTEGER        KSEQ(300),KNUM(300)
      INTEGER        KLIST(300,10)
C  =====================================
      SAVE
C
      DATA  CCITT /'CCITT IA5'/
      DATA  IBITS /         1,          3,          7,         15,
     *                     31,         63,        127,        255,
     *                    511,       1023,       2047,       4095,
     *                   8191,      16383,      32767,      65535,
     *             Z'0001FFFF',Z'0003FFFF',Z'0007FFFF',Z'000FFFFF',
     *             Z'001FFFFF',Z'003FFFFF',Z'007FFFFF',Z'00FFFFFF',
     *             Z'01FFFFFF',Z'03FFFFFF',Z'07FFFFFF',Z'0FFFFFFF',
     *             Z'1FFFFFFF',Z'3FFFFFFF',Z'7FFFFFFF',Z'FFFFFFFF'/
      DATA  LL    /0/
      DATA  MISG  /99999/
      DATA  ZEROS /255*0/
C  =====================================
C                               THERE MUST BE DESCRIPTORS IN JDESC
C                               AND A COUNT IN NEWNR
C  =====================================
      IF (NEWNR.EQ.0) THEN
          IERRTN  = 15
          RETURN
      END IF
C  =====================================
C     IF INPUT FORM IS F X Y SEGMENTS THEN
C                      CONVERT INPUT FORM OF JDESC FROM FXY TO DECIMAL
C  =====================================
      IF (JIF.EQ.0) THEN
C                            CONVERT TO DECIMAL
          CALL FI8505(JIF,JDESC,NEWNR,IERRTN)
          IF (IERRTN.NE.0) THEN
              RETURN
          END IF
      END IF
C  =====================================
C     IF PROCESSING DELAYED REPLICATION, MUST RELOAD
C            KDESC FROM JDESC
C  =====================================
      IF (KARY(4).NE.0) THEN
          NRDESC  = 0
      END IF
C  =====================================
C     IF ONLY HAVE JDESC, NEWNR CREATE KDESC, NRDESC
C  =====================================
C                      IF ONLY HAVE JDESC, NEWNR CREATE KDESC, NRDESC
      IF (NRDESC.EQ.0) THEN
          DO 50 I = 1, NEWNR
              KDESC(1,I)  = JDESC(1,I)
   50     CONTINUE
          NRDESC  = NEWNR
          KIF     = 1
      ELSE IF (NRDESC.NE.0) THEN
C                      KDESC ALL READY EXISTS
          IF (KIF.EQ.0) THEN
C                      CONVERT INPUT FORM OF KDESC FROM FXY TO DECIMAL
              CALL FI8505(KIF,KDESC,NRDESC,IERRTN)
              IF (IERRTN.NE.0) THEN
                  RETURN
              END IF
          END IF
      END IF
C  =====================================
C     READ IN TABLE B SUBSET, IF NOT ALL READY IN PLACE
C  =====================================
      IF (ISECT3(8).EQ.0) THEN
          CALL FI8512(IUNITB,ISECT3,KDESC,NRDESC,KARY,IERRTN,
     *               LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW,
     *               IUNITD,KSEQ,KNUM,KLIST,INDEXB)
          IF (IERRTN.NE.0) GO TO 9000
      END IF
C  =====================================
C     ROUTE TO SELECTED PROCESSING
C  =====================================
      KSUB  = ISECT3(1)
      IF (ISTEP.EQ.1) THEN
C                          PROCESSING INTEGER DATA INPUT
          CALL FI8508(ISTEP,IUNITB,IDATA,KDESC,NRDESC,ATEXT,KSUB,KARY,
     *            KDATA,LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KRFVSW,ISECT3,
     *            KWIDTH,KASSOC,IUNITD,KSEQ,KNUM,KLIST,IERRTN,INDEXB)
          RETURN
      ELSE IF (ISTEP.EQ.2) THEN
C                          PROCESSING REAL DATA INPUT
          CALL FI8509(ISTEP,IUNITB,RDATA,KDESC,NRDESC,ATEXT,KSUB,KARY,
     *            KDATA,LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KRFVSW,ISECT3,
     *            KWIDTH,KASSOC,IUNITD,KSEQ,KNUM,KLIST,IERRTN,INDEXB)
          RETURN
      ELSE IF (ISTEP.NE.3) THEN
          IERRTN  = 20
          RETURN
      END IF
C  =====================================
C     IF INDICATING ZERO SUBSETS, HAVE AN ERROR CONDITION
C  =====================================
      IF (ISECT3(1).LE.0) THEN
          IERRTN  = 3
          RETURN
      END IF
C  =====================================
C     SET FOR BUFR MESSAGE
C  =====================================
C
C                                 CLEAR OUTPUT AREA
C                      BYTES IN EACH FULL WORD
      KWORD  = 4
C
C                               GET NUMBER OF SUBSETS
C
      MXRPTS    = ISECT3(1)
      ISECT3(7) = ISECT3(1)
      ISECT3(6) = ISECT3(1)
C
C                       RE-START POINT FOR PACKING FEWER SUBSETS ?
C
    5 CONTINUE
C
      KARY(18) = 0
      KARY(26) = 0
C  =====================================
C     ENTER 'BUFR'          -  SECTION 0
C                      CONSTRUCT UNDER RULES OF EDITION 2
C  =====================================
      KARY(3)        = 0
      NBUFR          = 1112884818
      CALL SBYTE (KBUFR,NBUFR,KARY(3),32)
      KARY(3)        = KARY(3) + 32
C                             SAVE POINTER FOR TOTAL BYTE COUNT
C                                   IN MESSAGE
      KARY(19)       = KARY(3)
      KARY(3)        = KARY(3) + 24
C                    SET EDITION NR IN PLACE
      CALL SBYTE (KBUFR,2,KARY(3),8)
      KARY(3)        = KARY(3) + 8
      KARY(20)       = 8
C     PRINT *,'SECTION 0'
C  =====================================
C     COMPLETE ENTRIES FOR  -  SECTION 1
C  =====================================
C  ----- 1,3              SECTION COUNT
      KARY(21)       = 18
      CALL SBYTE (KBUFR,KARY(21),KARY(3),24)
      KARY(3)        = KARY(3) + 24
C  ----- 4                  RESERVED
      CALL SBYTE (KBUFR,0,KARY(3),8)
      KARY(3)        = KARY(3) + 8
C  ----- 5               ORIGINATING SUB-CENTER
      CALL SBYTE (KBUFR,ISECT1(3),KARY(3),8)
      KARY(3)        = KARY(3) + 8
C  ----- 6               ORIGINATING CENTER
      CALL SBYTE (KBUFR,ISECT1(4),KARY(3),8)
      KARY(3)        = KARY(3) + 8
C  ----- 7               UPDATE SEQUENCE NUMBER
      CALL SBYTE (KBUFR,ISECT1(5),KARY(3),8)
      KARY(3)        = KARY(3) + 8
C  ----- 8
C                        INDICATE NO SECTION 2
      CALL SBYTE (KBUFR,ISECT1(6),KARY(3),1)
      KARY(3)        = KARY(3) + 1
      CALL SBYTE (KBUFR,0,KARY(3),7)
      KARY(3)        = KARY(3) + 7
C  ----- 9            BUFR MESSAGE TYPE
      CALL SBYTE (KBUFR,ISECT1(7),KARY(3),8)
      KARY(3)        = KARY(3) + 8
C  ----- 10            BUFR MESSAGE SUB-TYPE
      CALL SBYTE (KBUFR,ISECT1(8),KARY(3),8)
      KARY(3)        = KARY(3) + 8
C  ----- 11            VERSION OF MASTER TABLE
      CALL SBYTE (KBUFR,ISECT1(9),KARY(3),8)
      KARY(3)        = KARY(3) + 8
C  ----- 12            VERSION OF LOCAL TABLE
      CALL SBYTE (KBUFR,ISECT1(10),KARY(3),8)
      KARY(3)        = KARY(3) + 8
C  ----- 13            YEAR
      CALL SBYTE (KBUFR,ISECT1(11),KARY(3),8)
      KARY(3)        = KARY(3) + 8
C  ----- 14            MONTH
      CALL SBYTE (KBUFR,ISECT1(12),KARY(3),8)
      KARY(3)        = KARY(3) + 8
C  ---- 15             DAY
      CALL SBYTE (KBUFR,ISECT1(13),KARY(3),8)
      KARY(3)        = KARY(3) + 8
C  ----- 16            HOUR
      CALL SBYTE (KBUFR,ISECT1(14),KARY(3),8)
      KARY(3)        = KARY(3) + 8
C  ----- 17            MINUTE
      CALL SBYTE (KBUFR,ISECT1(15),KARY(3),8)
      KARY(3)        = KARY(3) + 8
C  ----- 18            FILL
      CALL SBYTE (KBUFR,0,KARY(3),8)
      KARY(3)        = KARY(3) + 8
C     PRINT *,'SECTION 1'
C  =====================================
C     SKIP                  -  SECTION 2
C  =====================================
      IF (ISECT1(6).NE.0) THEN
C                  BUILD SECTION COUNT
          KARY(22) = 4 + ISEC2B
          IF (MOD(KARY(22),2).NE.0) KARY(22) = KARY(22) + 1
C                        INSERT SECTION COUNT
          CALL SBYTE (KBUFR,KARY(22),KARY(3),24)
          KARY(3)  = KARY(3) + 24
C                        INSERT RESERVED POSITION
          CALL SBYTE (KBUFR,0,KARY(3),8)
          KARY(3)  = KARY(3) + 8
C                        INSERT SECTION 2 DATA
          CALL SBYTES(KBUFR,ISEC2D,KARY(3),8,0,ISEC2B)
          KARY(3)  = KARY(3) + (ISEC2B * 8)
          IF (MOD(ISEC2B,2).NE.0) THEN
              CALL SBYTE (KBUFR,0,KARY(3),8)
              KARY(3)  = KARY(3) + 8
          END IF
      ELSE
          KARY(22)       = 0
      END IF
C  =====================================
C     MAKE PREPARATIONS FOR SECTION 3 DESCRIPTORS
C  =====================================
      KARY(23)        = 7 + NEWNR*2 + 1
C                             SECTION 3 SIZE
      CALL SBYTE (KBUFR,KARY(23),KARY(3),24)
      KARY(3)         = KARY(3) + 24
C                             RESERVED BYTE
      CALL SBYTE (KBUFR,0,KARY(3),8)
      KARY(3)         = KARY(3) + 8
C                           NUMBER OF SUBSETS
      CALL SBYTE (KBUFR,ISECT3(1),KARY(3),16)
      KARY(3)         = KARY(3) + 16
C                          SET OBSERVED DATA SWITCH
      CALL SBYTE (KBUFR,ISECT3(2),KARY(3),1)
      KARY(3)         = KARY(3) + 1
C                          SET COMPRESSED DATA SWITCH
      CALL SBYTE (KBUFR,ISECT3(3),KARY(3),1)
      KARY(3)         = KARY(3) + 1
      CALL SBYTE (KBUFR,0,KARY(3),6)
      KARY(3)         = KARY(3) + 6
C  =====================================
C     DESCRIPTORS         -  SECTION 3
C  =====================================
      DO 37 KH = 1, NEWNR
C         PRINT *,'INSERTING',JDESC(1,KH),' INTO SECTION 3'
          CALL SBYTE (KBUFR,JDESC(1,KH),KARY(3),16)
          KARY(3)         = KARY(3) + 16
   37 CONTINUE
C                          FILL TO TWO BYTE BOUNDARY
      CALL SBYTE (KBUFR,0,KARY(3),8)
      KARY(3)        = KARY(3) + 8
C     PRINT *,'SECTION 3'
C  =====================================
C     INITIALIZE FOR        -  SECTION 4
C  =====================================
C                              SAVE POINTER TO COUNT POSITION
C     PRINT *,'START OF SECTION 4',KARY(3)
      KARY(5)        = KARY(3)
      KARY(3)        = KARY(3) + 24
      CALL SBYTE (KBUFR,0,KARY(3),8)
      KARY(3)        = KARY(3) + 8
C                              SKIP TO FIRST DATA POSITION
C  =====================================
C     BIT PATTERNS          -  SECTION 4
C  =====================================
      KEND4  = IBFSIZ * 8 - 32
C                          PACK ALL DATA INTO BUFR MESSAGE
C
      IF (ISECT3(3).EQ.0) THEN
C                        **********************************************
C                        *                                            *
C                        *      PROCESS AS NON-COMPRESSED MESSAGE     *
C                        *                                            *
C                        **********************************************
          CALL FI8506(ISTEP,ISECT3,KARY,JDESC,NEWNR,KDESC,NRDESC,
     *           LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW,NEWRFV,
     *           KSEQ,KNUM,KLIST,IBFSIZ,
     *           KDATA,KBUFR,IERRTN,INDEXB)
          IF (IERRTN.NE.0) THEN
              IF (IERRTN.EQ.1) GO TO 5500
              RETURN
          END IF
      ELSE
C                        **********************************************
C                        *                                            *
C                        *      PROCESS AS COMPRESSED MESSAGE         *
C                        *                                            *
C                        **********************************************
          KARY(18)  = 0
C                          MUST LOOK AT EVERY DESCRIPTOR IN KDESC
          KARY(11)  = 1
 3000     CONTINUE
          IF (KARY(11).GT.NRDESC) THEN
              GO TO 5200
          ELSE
C         DO 5000 JK = 1, NRDESC
C                              RE-ENTRY POINT FOR INSERTION OF
C                              REPLICATION OR SEQUENCES
 4000         CONTINUE
C                             ISOLATE TABLE
              KFUNC      = KDESC(1,KARY(11)) / 16384
C                             ISOLATE CLASS
              KCLASS     = MOD(KDESC(1,KARY(11)),16384) / 256
              KSEG       = MOD(KDESC(1,KARY(11)),256)
              KARY(2) = KARY(11) + KARY(18)
              IF (KFUNC.EQ.1) THEN
C                            DELAYED REPLICATION NOT ALLOWED
C                            IN COMPRESSED MESSAGE
                  IF (KSEG.EQ.0) THEN
                      IERRTN  = 8
                      RETURN
                  END IF
C                            REPLICATION DESCRIPTOR
                  CALL FI8501(KARY,ISTEP,KCLASS,KSEG,IDATA,RDATA,
     *                  KDATA,LL,KDESC,NRDESC,IERRTN)
C                 GO TO 4000
              ELSE IF (KFUNC.EQ.2) THEN
                  CALL FI8502(*4000,KBUFR,KCLASS,KSEG,
     *                     KDESC,NRDESC,I,ISTEP,
     *            KARY,KDATA,ISECT3,KRFVSW,NEWRFV,LDESC,IERRTN,INDEXB)
                  IF (IERRTN.NE.0) THEN
                      RETURN
                  END IF
                  GO TO 5000
              ELSE IF (KFUNC.EQ.3) THEN
                  CALL FI8503(KARY(11),KDESC,NRDESC,
     *                     ISECT3,IUNITD,KSEQ,KNUM,KLIST,IERRTN)
                  IF (IERRTN.NE.0) THEN
                      RETURN
                  END IF
                  GO TO 4000
              END IF
C                      FALL THRU WITH ELEMENT DESCRIPTOR
C                      POINT TO CORRECT TABLE B ENTRY
              L  = INDEXB(KDESC(1,KARY(11)))
              IF (L.LT.0) THEN
                  IERRTN  = 2
C                 PRINT *,'W3FI85 - IERRTN = 2'
                  RETURN
              END IF
C
              IF (AUNITS(L)(1:9).EQ.CCITT) THEN
                  TEXT  = .TRUE.
              ELSE
                  TEXT  = .FALSE.
              END IF
              KARY(7) = KWIDTH(L)
C
              IF (TEXT) THEN
C                                     PROCESS TEXT DATA
                  KBZ = KARY(3) + (ISECT3(1) + 1) * KARY(7) + 6
                  IF (KBZ.GT.KEND4) THEN
                      GO TO 5500
                  END IF
C                             NBINC IS NUMBER OF CHARS
                  NBINC     = KARY(7) / 8
C                              LOWEST = 0
                  CALL SBYTES(KBUFR,ZEROS,KARY(3),8,0,NBINC)
                  KARY(3)   = KARY(3) + KARY(7)
                  CALL SBYTE (KBUFR,NBINC,KARY(3),6)
                  KARY(3)   = KARY(3) + 6
C                               HOW MANY FULL WORDS
                  NKPASS    = KARY(7) / 32
C                           HOW MANY BYTES IN PARTIAL WORD
                  KREM      = MOD(KARY(7),32)
C                 KSKIP     = KARY(7) - 32
                  DO 4080 NSS = 1, ISECT3(1)
C                            POINT TO TEXT FOR THIS SUBSET
                      KARY(2)   = KARY(11) + KARY(18)
                      IF (NKPASS.GE.1) THEN
C                          PROCESS TEXT IN A SUBSET
                          DO 4070 NPP = 1, NKPASS
C                                 PROCESS FULL WORDS
                              IF (ISECT3(10).EQ.1) THEN
                                  CALL W3AI38 (KDATA(NSS,KARY(2)),4)
                              END IF
                              CALL SBYTE (KBUFR,KDATA(NSS,KARY(2)),
     *                               KARY(3),32)
                              KARY(3)  = KARY(3) + 32
C                                 POINT TO NEXT DATA WORD FOR MORE TEXT
                              KARY(2) = KARY(2) + 1
 4070                     CONTINUE
                      END IF
C                          PROCESS PARTIALS - LESS THAN 4 BYTES
                      IF (KREM.GT.0) THEN
                          IF (ISECT3(10).EQ.1) THEN
                              CALL W3AI38 (KDATA(NSS,KARY(2)),4)
                          END IF
                          CALL SBYTE (KBUFR,KDATA(NSS,KARY(2)),
     *                               KARY(3),KREM)
                          KARY(3)  = KARY(3) + KREM
                      END IF
 4080             CONTINUE
C                              ADJUST EXTRA WORD COUNT
                  IF (KREM.GT.0) THEN
                      KARY(18)  = KARY(18) + NKPASS
                  ELSE
                      KARY(18)  = KARY(18) + NKPASS - 1
                  END IF
C  -------------------------------------------------------------
                  GO TO 5000
              ELSE
                  KARY(2) = KARY(11) + KARY(18)
                  KARY(7) = KWIDTH(L) + KARY(26)
C
C                               NON TEXT/NUMERIC DATA
C
C                             PROCESS ASSOCIATED FIELD DATA
                  IF (KARY(27).GT.0.AND.KDESC(1,KARY(11)).NE.7957) THEN
                      DUPFLG  = .TRUE.
                      DO 4130 J = 2, ISECT3(1)
                          IF (KDATA(J,KARY(2)).NE.KDATA(1,KARY(2)))THEN
                              DUPFLG = .FALSE.
                              GO TO 4131
                          END IF
 4130                 CONTINUE
 4131                 CONTINUE
                      IF (DUPFLG) THEN
C                                  ALL VALUES ARE EQUAL
                          KBZ = KARY(3) + KARY(7) + 6
                          IF (KBZ.GT.KEND4) THEN
                              GO TO 5500
                          END IF
                          NBINC  = 0
C                                 ENTER COMMON VALUE
                          IF (KDATA(1,KARY(2)).EQ.MISG) THEN
                              CALL SBYTE(KBUFR,IBITS(KARY(7)),
     *                               KARY(3),KARY(27))
                          ELSE
                              CALL SBYTE(KBUFR,KDATA(1,KARY(2)),
     *                               KARY(3),KARY(27))
                          END IF
                          KARY(3)  = KARY(3) + KARY(27)
C                                       ENTER NBINC
                          CALL SBYTE (KBUFR,NBINC,KARY(3),6)
                          KARY(3)  = KARY(3) + 6
                      ELSE
C                               MIX OF MISSING AND VALUES
C                               GET LARGEST DIFFERENCE VALUE
                          MSGFLG = .FALSE.
                          DO 4132 J = 1, ISECT3(7)
                              IF (KDATA(J,KARY(2)).EQ.MISG) THEN
                                  MSGFLG = .TRUE.
                                  GO TO 4133
                              END IF
 4132                     CONTINUE
 4133                     CONTINUE
                          DO 4134 J = 1, ISECT3(7)
                              IF (KDATA(J,KARY(2)).LT.IBITS(KARY(27))
     *                                .AND.KDATA(J,KARY(2)).GE.0.AND.
     *                                KDATA(J,KARY(2)).NE.MISG) THEN
                                  LOWEST = KDATA(J,KARY(2))
                                  MAXVAL = KDATA(J,KARY(2))
                                  JSTART = J + 1
                                  GO TO 4135
                              END IF
 4134                     CONTINUE
 4135                     CONTINUE
                          DO 4136 J = JSTART, ISECT3(7)
                              IF (KDATA(J,KARY(2)).NE.MISG) THEN
                                 IF (KDATA(J,KARY(2)).LT.LOWEST) THEN
                                          LOWEST = KDATA(J,KARY(2))
                                 ELSE IF(KDATA(J,KARY(2)).GT.MAXVAL)THEN
                                          MAXVAL = KDATA(J,KARY(2))
                                 END IF
                              END IF
 4136                     CONTINUE
                          MXDIFF  = MAXVAL - LOWEST
C                              FIND NBINC
                          MXBITS  = KARY(27)
                          DO 4142 LJ = 1, MXBITS
                              NBINC = LJ
                              IF (MXDIFF.LT.IBITS(LJ)) THEN
                                  GO TO 4143
                              END IF
 4142                     CONTINUE
 4143                     CONTINUE
                          KBZ = KARY(3) + MXBITS + 6 + ISECT3(1) * NBINC
                          IF (KBZ.GT.KEND4) THEN
                              GO TO 5500
                          END IF
                          IF (NBINC.GT.MXBITS) THEN
                              IERRTN  = 3
                              RETURN
                          END IF
C                               ENTER LOWEST
                          CALL SBYTE(KBUFR,LOWEST,KARY(3),MXBITS)
                          KARY(3)  = KARY(3) + MXBITS
                          CALL SBYTE(KBUFR,NBINC,KARY(3),6)
                          KARY(3)  = KARY(3) + 6
C                               GET DIFFERENCE VALUES
                          IF (MSGFLG) THEN
                              DO 4144 M = 1, ISECT3(1)
                                  IF (KDATA(M,KARY(2)).EQ.MISG) THEN
                                      KT(M)  = IBITS(NBINC)
                                  ELSE
                                      KT(M)  = KDATA(M,KARY(2)) - LOWEST
                                  END IF
 4144                         CONTINUE
                          ELSE
                              DO 4146 M = 1, ISECT3(1)
                                  KT(M)  = KDATA(M,KARY(2)) - LOWEST
 4146                         CONTINUE
                          END IF
C                                ENTER DATA VALUES
                          CALL SBYTES(KBUFR,KT,KARY(3),NBINC,
     *                                          0,ISECT3(1))
                          KARY(3)  = KARY(3) + ISECT3(1) * NBINC
                      END IF
                      KARY(18)  = KARY(18) + 1
                  END IF
C  ---------------------------------------------------
C                            STANDARD DATA
C  ---------------------------------------------------
                  KARY(2) = KARY(11) + KARY(18)
                  MXBITS = KARY(7) + KARY(26)
                  DUPFLG = .TRUE.
                  DO 4030 J = 2, ISECT3(7)
                      IF (KDATA(J,KARY(2)).NE.KDATA(1,KARY(2))) THEN
                          DUPFLG = .FALSE.
                          GO TO 4031
                      END IF
 4030             CONTINUE
 4031             CONTINUE
                  IF (DUPFLG) THEN
C                                  ALL VALUES ARE EQUAL
                      KBZ = KARY(3) + KARY(7) + 6
                      IF (KBZ.GT.KEND4) THEN
                          GO TO 5500
                      END IF
                      NBINC  = 0
C                                 ENTER COMMON VALUE
                      IF (KDATA(1,KARY(2)).EQ.MISG) THEN
                          CALL SBYTE(KBUFR,IBITS(MXBITS),
     *                               KARY(3),MXBITS)
                      ELSE
                          CALL SBYTE(KBUFR,KDATA(1,KARY(2)),
     *                               KARY(3),MXBITS)
                      END IF
                      KARY(3)  = KARY(3) + KARY(7)
C                                       ENTER NBINC
                      CALL SBYTE (KBUFR,NBINC,KARY(3),6)
                      KARY(3)  = KARY(3) + 6
                  ELSE
C                               MIX OF MISSING AND VALUES
C                               GET LARGEST DIFFERENCE VALUE
                      MSGFLG = .FALSE.
                      DO 4032 J = 1, ISECT3(7)
                          IF (KDATA(J,KARY(2)).EQ.MISG) THEN
                              MSGFLG = .TRUE.
                              GO TO 4033
                          END IF
 4032                 CONTINUE
 4033                 CONTINUE
                      DO 4034 J = 1, ISECT3(7)
                          IF (KDATA(J,KARY(2)).NE.MISG) THEN
                              LOWEST = KDATA(J,KARY(2))
                              MAXVAL = KDATA(J,KARY(2))
C                             PRINT *,' '
C                             PRINT *,'START VALUES',LOWEST,MAXVAL,
C    *                            'J=',J,' KARY(2)=',KARY(2)
                              GO TO 4035
                          END IF
 4034                 CONTINUE
 4035                 CONTINUE
                      DO 4036 J = 1, ISECT3(1)
                          IF (KDATA(J,KARY(2)).NE.MISG) THEN
                             IF (KDATA(J,KARY(2)).LT.LOWEST) THEN
                                          LOWEST = KDATA(J,KARY(2))
C                                PRINT *,'NEW LOWEST=',LOWEST,J
                             ELSE IF (KDATA(J,KARY(2)).GT.MAXVAL) THEN
                                      MAXVAL = KDATA(J,KARY(2))
C                                PRINT *,'NEW MAXVAL=',MAXVAL,J
                             END IF
                          END IF
 4036                 CONTINUE
                      MXDIFF  = MAXVAL - LOWEST
C                              FIND NBINC
                      DO 4042 LJ = 1, MXBITS
                          NBINC = LJ
                          IF (MXDIFF.LT.IBITS(LJ)) GO TO 4043
                          IF (NBINC.EQ.MXBITS) GO TO 4043
 4042                 CONTINUE
 4043                 CONTINUE
                      KBZ = KARY(3) + MXBITS  + 38 + ISECT3(1) * NBINC
                      IF (KBZ.GT.KEND4) THEN
                          GO TO 5500
                      END IF
C                     PRINT 4444,KARY(11),KDESC(1,KARY(11)),LOWEST,
C    *                 MAXVAL,MXDIFF,KARY(7),NBINC,ISECT3(1),ISECT3(7)
C4444                 FORMAT(9(1X,I8))
C                               ENTER LOWEST
C                                 ADJUST WITH REFERENCE VALUE
                      IF (KRFVSW(L).EQ.0) THEN
                          JRV  = KRFVAL(L)
                      ELSE
                          JRV  = NEWRFV(L)
                      END IF
                      LVAL  = LOWEST - JRV
                      CALL SBYTE(KBUFR,LVAL,KARY(3),MXBITS)
                          KARY(3)  = KARY(3) + MXBITS
                      IF (NBINC.GT.MXBITS) THEN
                          IERRTN  = 3
                          RETURN
                      END IF
                      CALL SBYTE(KBUFR,NBINC,KARY(3),6)
                      KARY(3)  = KARY(3) + 6
C                                GET DIFFERENCE VALUES
                      IF (MSGFLG) THEN
                          DO 4044 M = 1, ISECT3(1)
                              IF (KDATA(M,KARY(2)).EQ.MISG) THEN
                                  KT(M)  = IBITS(NBINC)
                              ELSE
                                  KT(M)  = KDATA(M,KARY(2)) - LOWEST
                              END IF
 4044                     CONTINUE
                      ELSE
                          DO 4046 M = 1, ISECT3(1)
                              KT(M)  = KDATA(M,KARY(2)) - LOWEST
 4046                     CONTINUE
                      END IF
C                                ENTER DATA VALUES
                      CALL SBYTES(KBUFR,KT,KARY(3),NBINC,
     *                                             0,ISECT3(1))
                      KARY(3)  = KARY(3) + ISECT3(1) * NBINC
                  END IF
                  GO TO 5000
              END IF
C  -------------------------------------------------------------
 5000         CONTINUE
              KARY(11) = KARY(11) + 1
              GO TO 3000
          ENDIF
 5200     CONTINUE
      END IF
      ISECT3(6) = 0
      GO TO 6000
 5500 CONTINUE
C                       THE SEGMENT OF CODE BETWEEN STATEMENTS
C                       5500-6000 ARE ACTIVATED IF AND WHEN THE
C                       MAXIMUM MESSAGE SIZE HAS BEEN EXCEEDED
C
C           ARE WE REDUCING IF OVERSIZED  ???
      IF (ISECT3(4).NE.0) THEN
C                                   INCREMENT REDUCTION COUNT
          ISECT3(6)  = ISECT3(6) + ISECT3(5)
C                                   REDUCE NUMBER TO INCLUDE
          ISECT3(7)  = ISECT3(1) - ISECT3(5)
          ISECT3(1)  = ISECT3(7)
          PRINT *,'REDUCED BY ',ISECT3(5),' ON THIS PASS'
          GO TO 5
      ELSE
          IERRTN = 1
          RETURN
      END IF
 6000 CONTINUE
C  ---------------------------------------------------------------
C                                 FILL IN SECTION 4 OCTET COUNT
      NBUFR  = MOD((KARY(3) - KARY(5)),16)
C                                 MAY BE NECESSARY TO ADJUST COUNT
      IF (NBUFR.NE.0) THEN
          KARY(3)   = KARY(3) + 16 - NBUFR
      END IF
      KARY(24)  = (KARY(3) - KARY(5)) / 8
      CALL SBYTE (KBUFR,KARY(24),KARY(5),24)
C     PRINT *,'SECTION 4'
C  =====================================
C     ENDING KEY  '7777'    -  SECTION 5
C  =====================================
      KARY(25)    = 4
      NBUFR       = 926365495
      CALL SBYTE (KBUFR,NBUFR,KARY(3),32)
      KARY(3)     = KARY(3) + 32
C                  CONSTRUCT TOTAL BYTE COUNT FOR SECTION 0
      ITOTAL      = KARY(3) / 8
      CALL SBYTE (KBUFR,ITOTAL,32,24)
      KARY(30)    = ITOTAL
C     WRITE (6,8601) ITOTAL
 8601 FORMAT (1X,22HTHIS MESSAGE CONTAINS ,I10,6H BYTES)
C  =======================================
C                 KBUFR CONTAINS A COMPLETED MESSAGE
      IF (ISECT3(4).NE.0.AND.ISECT3(5).NE.0) THEN
C                 ADJUST KDATA ARRAY
          NR   = MXRPTS - ISECT3(1)
          ISECT3(7) = ISECT3(7) + 1
          DO 7500 I = 1, NR
              DO 7000 J = 1, NRDESC
                  KDATA(I,J)  = KDATA(ISECT3(7),J)
 7000         CONTINUE
              ISECT3(7) = ISECT3(7) + 1
 7500     CONTINUE
          KARY(14)  = NR
      ELSE
          ISECT3(7) = ISECT3(1)
      END IF
C  =======================================
      IERRTN = 0
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE FI8501(KARY,ISTEP,KCLASS,KSEG,IDATA,RDATA,
     *                  KDATA,NSUB,KDESC,NRDESC,IERRTN)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8501      PERFORM REPLICATION OF DESCRIPTORS
C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 93-12-03
C
C ABSTRACT: HAVE ENCOUNTERED A REPLICATION DESCRIPTOR . IT MAY INCLUDE
C           DELAYED REPLICATION OR NOT.  THAT DECISION SHOULD HAVE BEEN
C           MADE PRIOR TO CALLING THIS ROUTINE.
C
C PROGRAM HISTORY LOG:
C   93-12-03  CAVANAUGH
C   94-03-25  HOPPA       ADDED LINE TO INITIALIZE NXTPTR TO CORRECT
C                         AN ERROR IN THE STANDARD REPLICATION.
C   94-03-28  HOPPA       CORRECTED AN ERROR IN THE STANDARD REPLICATION
C                         THAT WAS ADDING EXTRA ZEROS TO THE BUFR
C                         MESSAGE AFTER THE REPLICATED DATA.
C   94-03-31  HOPPA       ADDED THE SUBSET NUMBER TO THE PARAMETER LIST.
C                         CORRECTED THE EQUATION FOR THE NUMBER OF
C                         REPLICATIONS WITH DELAYED REPLICATION.
C                         (ISTART AND K DON'T EXIST)
C   94-04-19  HOPPA       SWITCHED THE VARIABLES NEXT AND NXTPRT
C   94-04-20  HOPPA       ADDED THE KDATA PARAMETER COUNTER TO THE
C                         PARAMETER LIST.  IN THE ASSIGNMENT OF NREPS
C                         WHEN HAVE DELAYED REPLICATION, CHANGED INDEX
C                         IN KDATA FROM N TO K.
C   94-04-29  HOPPA     - REMOVED N AND K FROM THE INPUT LIST
C                       - CHANGED N TO KARY(11) AND K TO KARY(2)
C
C USAGE:    CALL FI8501(KARY,ISTEP,KCLASS,KSEG,IDATA,RDATA,
C    *                  KDATA,N,NSUB,KDESC,NRDESC,IERRTN)
C   INPUT ARGUMENT LIST:
C     ISTEP    -
C     KCLASS   -
C     KKSEG    -
C     IDATA    -
C     RDATA    -
C     KDATA    -
C     N        - CURRENT POSITION IN DESCRIPTOR LIST
C     NSUB     - CURRENT SUBSET
C     KDESC    - LIST OF DESCRIPTORS
C     NRDESC   - NUMBER OF DESCRIPTORS IN KDESC
C
C   OUTPUT ARGUMENT LIST:
C     N        - CURRENT POSITION IN DESCRIPTOR LIST
C     KDESC    - MODIFIED LIST OF DESCRIPTORS
C     NRDESC   - NEW NUMBER OF DESCRIPTORS IN KDESC
C     IERRTN   - ERROR RETURN VALUE
C
C REMARKS:
C
C ATTRIBUTES:
C   LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN
C   MACHINE:  HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256
C
C$$$
C
      REAL         RDATA(*)
C
      INTEGER      IDATA(*),NREPS,KARY(*)
      INTEGER      KCLASS,KSEG
      INTEGER      KDESC(3,*),NRDESC,KDATA(500,*)
      INTEGER      IERRTN
      INTEGER      ITAIL(1600)
      INTEGER      IHOLD(1600),ISTEP
C
      SAVE
C
C                    TEST KFUNC FOR DESCRIPTOR TYPE
C                    DO REPLICATION
C  ****************************************************************
      IERRTN  = 0
C                            REPLICATION DESCRIPTOR
C                                 STANDARD REPLICATION WILL SIMPLY
C                                 BE PROCESSED FROM ITS DESCRIPTOR
C                                 PARTS
C
C                            DELAYED REPLICATION DESCRIPTOR
C                                 MUST BE FOLLOWED BY ONE OF THE
C                                 DESCRIPTORS FOR A DELAYED
C                                 REPLICATION FACTOR
C                                       0 31 001  (7937 DECIMAL)
C                                       0 31 002  (7938 DECIMAL)
C                                       0 31 011  (7947 DECIMAL)
C                                       0 31 012  (7948 DECIMAL)
      IF (KSEG.NE.0) THEN
C                       HAVE NUMBER OF REPLICATIONS AS KSEG
          NREPS  = KSEG
          IPUT   = KARY(11)
          NEXT   = IPUT + 1
          NXTPTR = IPUT + 1 + KCLASS
      ELSE IF (KSEG.EQ.0) THEN
          IF (KDESC(1,KARY(11)+1).EQ.7937.OR.
     *                    KDESC(1,KARY(11)+1).EQ.7938.OR.
     *                    KDESC(1,KARY(11)+1).EQ.7947.OR.
     *                    KDESC(1,KARY(11)+1).EQ.7948) THEN
C             PRINT *,'HAVE DELAYED REPLICATION'
              KARY(4)  = 1
C                                  MOVE REPLICATION DEFINITION
              KDESC(1,KARY(11))  = KDESC(1,KARY(11)+1)
C                                  MUST DETERMINE HOW MANY REPLICATIONS
              IF (ISTEP.EQ.1) THEN
                  NREPS = IDATA(KARY(11))
              ELSE IF (ISTEP.EQ.2) THEN
                  NREPS = RDATA(KARY(11))
              ELSE
                  NREPS = KDATA(NSUB,KARY(2))
              END IF
              IPUT      = KARY(11) + 1
              NXTPTR    = IPUT + KCLASS + 1
              NEXT      = IPUT + 1
C                              POINT TO REPLICATION DESCRIPTOR
          END IF
      ELSE
          IERRTN  = 10
          RETURN
      END IF
C                                 EXTRACT DESCRIPTORS TO BE REPLICATED
C                     IF NREPS = 0, THIS LIST OF DESCRIPTORS IS NOT TO
C                        BE USED IN DEFINING THE DATA,
C                     OTHERWISE
C                        IT WILL BE USED TO DEFINE THE DATA
      IF (NREPS.NE.0) THEN
          DO 1000 IJ = 1, KCLASS
              IHOLD(IJ)  = KDESC(1,NEXT)
              NEXT  = NEXT + 1
 1000     CONTINUE
C                      SKIP THE NUMBER OF DESCRIPTORS DEFINED BY KCLASS
      END IF
C                                   SAVE OFF TAIL OF DESC STREAM
C               START AT FIRST POSITION OF TAIL
      IGOT    = 0
      DO 1100 IJ = NXTPTR, NRDESC
          IGOT         = IGOT + 1
          ITAIL(IGOT)  = KDESC(1,IJ)
 1100 CONTINUE
C                                   INSERT ALL REPLICATED DESC'S
      IF (NREPS.NE.0) THEN
          DO 1300 KR = 1, NREPS
              DO 1200 KD = 1, KCLASS
                  KDESC(1,IPUT) = IHOLD(KD)
                  IPUT          = IPUT + 1
 1200         CONTINUE
 1300     CONTINUE
      END IF
C                                   RESTORE TAIL
      DO 1400 ITL = 1, IGOT
          KDESC(1,IPUT) = ITAIL(ITL)
          IPUT          = IPUT + 1
 1400 CONTINUE
C
C                               RESET NUMBER OF DESCRIPTORS IN KDESC
      NRDESC  = IPUT - 1
C  ****************************************************************
      RETURN
      END
      SUBROUTINE FI8502(*,KBUFR,KCLASS,KSEG,KDESC,NRDESC,I,ISTEP,
     *          KARY,KDATA,ISECT3,KRFVSW,NEWRFV,LDESC,IERRTN,INDEXB)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8502      PROCESS AN OPERATOR DESCRIPTOR
C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 93-12-03
C
C ABSTRACT: HAVE ENCOUNTERED AN OPERATOR DESCRIPTOR
C
C
C PROGRAM HISTORY LOG:
C   93-12-03  CAVANAUGH
C   94-04-15  J. HOPPA  - ADDED KBUFR TO INPUT PARAMETER LIST.
C                       - ADDED BLOCK OF DATA TO CORRECTLY USE SBYTE
C                         WHEN WRITING A 205YYY DESCRIPTOR TO THE
C                         BUFR MESSAGE.
C                         THE PREVIOUS WAY DIDN'T WORK BECAUSE KDATA
C                         WAS GETTING INCREMETED BY THE KSUB VALUE,
C                         NOT THE PARAM VALUE.
C   94-04-29  J. HOPPA  - CHANGED K TO KARY(2)
C                       - REMOVED A LINE THAT BECAME OBSOLETE WITH
C                         ABOVE CHANGE
C   94-05-18  J. HOPPA  - ADDED A KARY(2) INCREMENT
C
C USAGE:    CALL FI8502(*,KCLASS,KSEG,KDESC,NRDESC,I,ISTEP,
C    *          KARY,KDATA,ISECT3,KRFVSW,NEWRFV,LDESC,IERRTN,INDEXB)
C   INPUT ARGUMENT LIST:
C     KCLASS   -
C     KSEG     -
C     KDESC    -
C     NRDESC   -
C     I        -
C     ISTEP    -
C     KARY     -
C
C   OUTPUT ARGUMENT LIST:
C     KDESC    -
C     NRDESC   -
C     KARY     -
C     IERRTN   - ERROR RETURN VALUE
C
C REMARKS:
C
C ATTRIBUTES:
C   LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN
C   MACHINE:  HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256
C
C$$$
C
      INTEGER      KCLASS,KSEG,ZEROES(255)
      INTEGER      KRFVSW(*),NEWRFV(*),LDESC(*)
      INTEGER      I,KDESC(3,*),KDATA(500,*),ISECT3(*)
      INTEGER      NRDESC
      INTEGER      KARY(*)
      INTEGER      IERRTN
      INTEGER      NLEFT
C
      SAVE
C
      DATA  ZEROES/255*0/
C
C  ****************************************************************
      IERRTN  = 0
C                            OPERATOR DESCRIPTOR
      IF (KCLASS.EQ.1) THEN
C                  BITS ADDED TO DESCRIPTOR WIDTH
          IF (ISTEP.EQ.3) THEN
              IF (KSEG.NE.0) THEN
                  KARY(26)  = KSEG - 128
              ELSE
                  KARY(26)  = 0
              END IF
          END IF
      ELSE IF (KCLASS.EQ.2) THEN
C                  NEW SCALE VALUE
          IF (ISTEP.EQ.3) THEN
              IF (KSEG.EQ.0) THEN
                  KARY(9)  = 0
              ELSE
                  KARY(9)  = KSEG - 128
              END IF
          END IF
      ELSE IF (KCLASS.EQ.3) THEN
C                  CHANGE REFERENCE VALUE
C                                  MUST ACCEPT INTO OUTPUT THE
C                                  REFERENCE VALUE CHANGE AND ACTIVATE
C                                  THE CHANGE WHILE PROCESSING
          IF (ISTEP.EQ.3) THEN
C                       HAVE OPERATOR DESCRIPTOR FOR REFERENCE VALUES
              IF (KSEG.EQ.0) THEN
                  DO 100 IQ = 1, ISECT3(8)
C                                RESET ALL NEW REFERENCE VALUES
                      KRFVSW(IQ)  = 0
  100             CONTINUE
              END IF
  200         CONTINUE
C                                GET NEXT DESCRIPTOR
              KARY(11)  = KARY(11) + 1
              IF (KDESC(1,KARY(11)).GT.16383) THEN
C                                NOT AN ELEMENT DESCRIPTOR
                  NFUNC  = KDESC(1,KARY(11)) / 16384
                  IF (NFUNC.EQ.1.OR.NFUNC.EQ.3) THEN
                      IERRTN  = 20
                      PRINT *,'INCORRECT ENTRY OF REPLICATION OR ',
     *                     'SEQUENCE DESCRIPTOR IN LIST OF ',
     *                     'REFERENCE VALUE CHANGES'
                      RETURN
                  END IF
                  NCLASS = (KDESC(1,KARY(11)) - NFUNC*16384) / 256
                  IF (NCLASS.EQ.3) THEN
                      NSEG  = MOD(KDESC(1,KARY(11)),256)
                      IF (NSEG.EQ.255) THEN
                          RETURN
                      END IF
                  END IF
                  IERRTN  = 21
                  PRINT *,'INCORRECT OPERATOR DESCRIPTOR ENTRY ',
     *                    'IN LIST OF REFERENCE VALUE CHANGES'
                  RETURN
              END IF
C                               ELEMENT DESCRIPTOR W/NEW REFERENCE VALUE
C                               FIND MATCH FOR CURRENT DESCRIPTOR
              IQ  = INDEXB(KDESC(1,KARY(11)))
              IF (IQ.LT.1) THEN
                  IERRTN  = 22
                  PRINT *,'ATTEMPTING TO ENTER NEW REFERENCE VALUE ',
     *                'INTO TABLE B, BUT DESCRIPTOR DOES NOT EXIST IN ',
     *                'CURRENT MODIFIED TABLE B'
                  RETURN
              END IF
          END IF
      ELSE IF (KCLASS.EQ.4) THEN
C                  SET/RESET ASSOCIATED FIELD WIDTH
          IF (ISTEP.EQ.3) THEN
              KARY(27)  = KSEG
          END IF
      ELSE IF (KCLASS.EQ.5) THEN
C                  SET TO PROCESS TEXT/ASCII DATA
C                                  SET TO TEXT
C                                      PROCESS TEXT

          KARY(2)  = KARY(11) + KARY(18)
          IF (ISTEP.EQ.3) THEN
C                            KSEG TELLS HOW MANY BYTES EACH ITERATION
              IF (MOD(KSEG,4).NE.0) THEN
                  ITER  = KSEG / 4 + 1
              ELSE
                  ITER   = KSEG / 4
              END IF
C                             POINT AT CORRECT KDATA WORD
              IF (ISECT3(3).NE.0) THEN
C                           COMPRESSED
C  ---------------------------------------------------
                  CALL SBYTES(KBUFR,ZEROES,KARY(3),32,0,ITER)
                  KARY(3)  = KARY(3) + KSEG * 8
C
                  CALL SBYTE (KBUFR,KSEG*8,KARY(3),6)
                  KARY(3)  = KARY(3) + 6
C                             TEXT ENTRY BY SUBSET
                  DO 2000 M = 1, ISECT3(1)
                      JAY  = KARY(3)
C                                 NUMBER OF SUBSETS
                      DO 1950 KL  = 1, ITER
C                                 NUMBER OF WORDS
                          KK  = KARY(2) + KL - 1
                          IF (ISECT3(10).EQ.1) THEN
                              CALL W3AI38(KDATA(M,KK),4)
                          END IF
                          CALL SBYTE (KBUFR,KDATA(M,KK),JAY,32)
                          JAY  = JAY + 32
 1950                 CONTINUE
                      KARY(3)  = KARY(3) + KSEG * 8
 2000             CONTINUE
C  ---------------------------------------------------
              ELSE
C                           NOT COMPRESSED

C       CALL SBYTE FOR EACH KDATA VALUE (4 CHARACTERS PER VALUE).
C        AN ADDITIONAL CALL IS DONE IF HAVE A VALUE WITH LESS THAN
C        4 CHARACTERS.
                  NBIT = 32
                  NLEFT = MOD(KSEG,4)
                  DO 3000 J=KARY(2),ITER+KARY(2)-1
                      IF((J.EQ.(ITER+KARY(2)-1)).AND.(NLEFT.NE.0))THEN
                          NBIT = 8 * NLEFT
                      ENDIF
                      IF (ISECT3(10).NE.0) THEN
                          CALL W3AI38 (KDATA(I,J),4)
                      END IF
                      CALL SBYTE(KBUFR,KDATA(I,J),KARY(3),NBIT)
                      KARY(3) = KARY(3) + NBIT
 3000             CONTINUE

C                           ADJUST FOR EXTRA WORDS
                  KARY(18)  = KARY(18) + ITER - 1
              END IF
              KARY(2) = KARY(2) + ITER
          END IF
      ELSE IF (KCLASS.EQ.6) THEN
C                  SET TO SKIP PROCESSING OF NEXT DESCRIPTOR
C                  IF IT IS NOT IN BUFR TABLE B
C                  DURING THE ENCODING PROCESS, THIS HAS NO MEANING
C                  ELIMINATE IN PROCESSING
C                  MOVE DESCRIPTOR LIST UP ONE POSITION AND RESTART
C                  PROCESSING AT SAME LOCATION.
          KM  = I - 1
          DO 9000 KL = I+1, NRDESC
              KM         = KM + 1
              KDESC(1,KM)  = KDESC(1,KL)
 9000     CONTINUE
          NRDESC  = KM
          RETURN 1
      END IF
C  ****************************************************************
      RETURN
      END
      SUBROUTINE FI8503(I,KDESC,NRDESC,
     *                     ISECT3,IUNITD,KSEQ,KNUM,KLIST,IERRTN)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8503      EXPAND SEQUENCE DESCRIPTOR
C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 93-12-03
C
C ABSTRACT: HAVE ENCOUNTERED A SEQUENCE DESCRIPTOR.  MUST PERFORM
C           PROPER REPLACMENT OF DESCRIPTORS IN LINE.
C
C PROGRAM HISTORY LOG:
C   93-12-03  CAVANAUGH
C   YY-MM-DD  MODIFIER1   DESCRIPTION OF CHANGE
C
C USAGE:    CALL FI8503(I,KDESC,NRDESC,
C    *                     ISECT3,IUNITD,KSEQ,KNUM,KLIST,IERRTN)
C   INPUT ARGUMENT LIST:
C     I        - CURRENT POSITION IN DESCRIPTOR LIST
C     KDESC    - LIST OF DESCRIPTORS
C     NRDESC   - NUMBER OF DESCRIPTORS IN KDESC
C     IUNITD   -
C     KSEQ     -
C     KNUM     -
C     KLIST    -
C
C   OUTPUT ARGUMENT LIST:
C     I        - CURRENT POSITION IN DESCRIPTOR LIST
C     KDESC    - MODIFIED LIST OF DESCRIPTORS
C     NRDESC   - NEW NUMBER OF DESCRIPTORS IN KDESC
C     IERRTN   - ERROR RETURN VALUE
C
C REMARKS:
C
C ATTRIBUTES:
C   LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN
C   MACHINE:  HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256
C
C$$$
C
      INTEGER      I
      INTEGER      KDESC(3,*)
      INTEGER      NRDESC
      INTEGER      ISECT3(*)
      INTEGER      IUNITD
      INTEGER      KSEQ(*)
      INTEGER      KNUM(*)
      INTEGER      KLIST(300,*)
      INTEGER      IERRTN
      INTEGER      ITAIL(1600)
C     INTEGER      IHOLD(200)
C
      SAVE
C
C  ****************************************************************
      IERRTN  = 0
C                            READ IN TABLE D IF NEEDED
      IF (ISECT3(9).EQ.0) THEN
          CALL FI8513 (IUNITD,ISECT3,KSEQ,
     *                                     KNUM,KLIST,IERRTN)
          IF (IERRTN.NE.0) THEN
C             PRINT *,'EXIT  FI8503A'
              RETURN
          END IF
      END IF
C                           HAVE TABLE D
C
C                    FIND MATCHING SEQUENCE DESCRIPTOR
      DO 100 L = 1, ISECT3(9)
          IF (KDESC(1,I).EQ.KSEQ(L)) THEN
C   JEN - DELETE NEXT PRINT LINE
C             PRINT *,'FOUND ',KDESC(1,I)
C                              HAVE A MATCH
              GO TO 200
          END IF
  100 CONTINUE
      IERRTN  = 12
      RETURN
  200 CONTINUE
C                    REPLACE SEQUENCE DESCRIPTOR WITH IN LINE SEQUENCE
      IPUT    = I
C                           SAVE TAIL
      ISTART  = I + 1
      KK  = 0
      DO 400 IJ  = ISTART, NRDESC
          KK  = KK + 1
          ITAIL(KK)  = KDESC(1,IJ)
  400 CONTINUE
C                           INSERT SEQUENCE OF DESCRIPTORS AT
C                                    CURRENT LOCATION
      KL  = 0
      DO 600 KQ = 1, KNUM(L)
          KDESC(1,IPUT)  = KLIST(L,KQ)
          IPUT = IPUT + 1
  600 CONTINUE

C                           RESTORE TAIL
      DO 800 KL = 1, KK
          KDESC(1,IPUT) = ITAIL(KL)
          IPUT  = IPUT + 1
  800 CONTINUE
C                            RESET NUMBER OF DESCRIPTORS IN KDESC
      NRDESC  = IPUT - 1
C  JEN - DELETE NEXT PRINT LINE
C     PRINT *,' NRDESC IS ',NRDESC

C                           RESET CURRENT POSITION & RETURN
      RETURN
      END
      SUBROUTINE FI8505(MIF,MDESC,NR,IERRTN)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8505      CONVERT DESCRIPTORS FXY TO DECIMAL
C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 93-12-03
C
C ABSTRACT: CONSTRUCT DECIMAL DESCRIPTOR VALUES FROM F X AND Y SEGMENTS
C
C PROGRAM HISTORY LOG:
C   93-12-03  CAVANAUGH
C   YY-MM-DD  MODIFIER1   DESCRIPTION OF CHANGE
C   YY-MM-DD  MODIFIER2   DESCRIPTION OF CHANGE
C
C USAGE:    CALL FI8505(MIF,MDESC,NR,IERRTN)
C   INPUT ARGUMENT LIST:
C     MIF      - INPUT FLAG
C     MDESC    - LIST OF DESCRIPTORS IN F X Y FORM
C     NR       - NUMBER OF DESCRIPTORS IN MDESC
C
C   OUTPUT ARGUMENT LIST:
C     MDESC    - LIST OF DESCRIPTORS IN DECIMAL FORM
C     IERRTN   - ERROR RETURN VALUE
C
C REMARKS:
C
C ATTRIBUTES:
C   LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN
C   MACHINE:  HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256
C
C$$$
C
      INTEGER      MDESC(3,*), NR
C
      SAVE
C
      IF (NR.EQ.0) THEN
          IERRTN  = 14
          RETURN
      END IF
C
      DO 100 I = 1, NR
          MDESC(1,I)  = MDESC(1,I) * 16384 + MDESC(2,I) * 256
     *                     + MDESC(3,I)
C   JEN - DELETE NEXT PRINT LINE
C     PRINT *,MDESC(2,I),MDESC(3,I),' BECOMES ',MDESC(1,I)
  100 CONTINUE
      MIF  = 1
      RETURN
      END
      SUBROUTINE FI8506(ISTEP,ISECT3,KARY,JDESC,NEWNR,KDESC,NRDESC,
     *           LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW,NEWRFV,
     *           KSEQ,KNUM,KLIST,IBFSIZ,
     *           KDATA,KBUFR,IERRTN,INDEXB)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8506      PROCESS DATA IN NON-COMPRESSED FORMAT
C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 93-12-03
C
C ABSTRACT: PROCESS DATA INTO NON-COMPRESSED FORMAT FOR INCLUSION INTO
C           SECTION 4 OF THE BUFR MESSAGE
C
C PROGRAM HISTORY LOG:
C   93-12-03  CAVANAUGH
C   94-03-24  J. HOPPA   - CHANGED THE INNER LOOP FROM A DO LOOP TO A
C                          GOTO LOOP SO NRDESC ISN'T A SET VALUE.
C                        - CORRECTED A VALUE IN THE CALL TO FI8503.
C   94-03-31  J. HOPPA   - CORRECTED AN ERROR IN SENDING THE SUBSET
C                          NUMBER RATHER THAN THE DESCRIPTOR NUMBER
C                          TO SUBROUTINE FI8501.
C                        - ADDED THE SUBSET NUMBER TO THE FI8501
C                          PARAMETER LIST.
C   94-04015  J. HOPPA   - ADDED LINE TO KEEP THE PARAMETER POINTER
C                          KARY(2) UP TO DATE.  THIS VARIABLE IS USED
C                          IN SUBROUTINE FI8502.
C                        - ADDED KBUFR TO THE PARAMETER LIST IN THE CALL
C                          TO SUBROUTINE FI8502.
C                        - CORRECTED AN INFINITE LOOP WHEN HAVE AN
C                          OPERATOR DESCRIPTOR THAT WAS CAUSED BY
C                          A CORRECTION MADE 94-03-24
C   94-04-20  J. HOPPA   - ADDED K TO CALL TO SUBROUTINE W3FI01
C   94-04-29  J. HOPPA   - CHANGED N TO KARY(11) AND K TO KARY(2)
C                        - REMOVED K AND N FROM THE CALL TO FI8501
C   94-05-03  J. HOPPA   - ADDED AN INCREMENT TO KARY(11) TO PREVENT
C                          AND INFINITE LOOP WHEN HAVE A MISSING VALUE
C   94-05-18  J. HOPPA   - CHANGED SO INCREMENTS KARY(2) AFTER EACH
C                          CALL TO SBYTE AND DELETED
C                          KARY(2) = KARY(11) + KARY(18)
C
C
C USAGE     CALL FI8506(ISTEP,ISECT3,KARY,JDESC,NEWNR,KDESC,NRDESC,
C    *           LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW,NEWRFV,
C    *           KSEQ,KNUM,KLIST,
C    *           KDATA,KBUFR,IERRTN,INDEXB)
C
C   INPUT ARGUMENT LIST:
C     ISTEP    -
C     ISECT3   -
C     KARY     -
C     JDESC    -
C     NEWNR    -
C     KDESC    -
C     NRDESC   -
C     LDESC    -
C     ANAME    -
C     AUNITS   -
C     KSCALE   -
C     KRFVAL   -
C     KWIDTH   -
C     KRFVSW   -
C     NEWRFV   -
C     KSEQ     -
C     KNUM     -
C     KLIST    -
C
C   OUTPUT ARGUMENT LIST:
C     KDATA    -
C     KBUFR    -
C     IERRTN   -
C
C REMARKS:
C
C ATTRIBUTES:
C   LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN
C   MACHINE:  HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256
C
C$$$
C
C  -------------------------------------------------------------
      INTEGER        ISTEP,INDEXB(*)
      INTEGER        KBUFR(*)
      INTEGER        ISECT3(*)
      INTEGER        KARY(*)
      INTEGER        NRDESC,NEWNR,KDESC(3,*),JDESC(3,*)
      INTEGER        KDATA(500,*)
      INTEGER        KRFVSW(*),KSCALE(*),KRFVAL(*),KWIDTH(*),NEWRFV(*)
      INTEGER        IERRTN
      INTEGER        LDESC(*)
      INTEGER        IBITS(32)
      INTEGER        MISG
      INTEGER        KSEQ(*),KNUM(*),KLIST(300,*)
      CHARACTER*40   ANAME(*)
      CHARACTER*25   AUNITS(*)
      CHARACTER*9    CCITT
      LOGICAL        TEXT
C
      SAVE
C  -------------------------------------------------------------
      DATA  IBITS /         1,          3,          7,         15,
     *                     31,         63,        127,        255,
     *                    511,       1023,       2047,       4095,
     *                   8191,      16383,      32767,      65535,
     *             Z'0001FFFF',Z'0003FFFF',Z'0007FFFF',Z'000FFFFF',
     *             Z'001FFFFF',Z'003FFFFF',Z'007FFFFF',Z'00FFFFFF',
     *             Z'01FFFFFF',Z'03FFFFFF',Z'07FFFFFF',Z'0FFFFFFF',
     *             Z'1FFFFFFF',Z'3FFFFFFF',Z'7FFFFFFF',Z'FFFFFFFF'/
      DATA  CCITT /'CCITT IA5'/
      DATA  MISG /99999/
C  -------------------------------------------------------------
       KEND = IBFSIZ * 8 - 32
C                        **********************************************
C                        *                                            *
C                        *      PROCESS AS NON-COMPRESSED MESSAGE     *
C                        *                                            *
C                        *   I POINTS TO SUBSET                       *
C                        *   N POINTS TO DESCRIPTOR                   *
C                        *   K ADJUSTS N TO CORRECT DATA ENTRY        *
C                        *                                            *
C                        **********************************************
      DO 4500 I = 1, ISECT3(1)
C                                  OUTER LOOP FOR EACH SUBSET
C                              DO UNTIL ALL DESCRIPTORS HAVE
C                                  BEEN PROCESSED
C                              SET ADDED BIT FOR WIDTH TO 0
          KARY(26)  = 0
C                             SET ASSOCIATED FIELD WIDTH TO 0
          KARY(27)  = 0
          KARY(18)  = 0
C                    IF MESSAGE CONTAINS DELAYED REPLICATION
C                      WE NEED TO EXPAND THE ORIGINAL DESCRIPTOR LIST
C                      TO MATCH THE INPUT DATA.
C                      START WITH JDESC
          IF (KARY(4).NE.0) THEN
              DO 100 M = 1, NEWNR
                  KDESC(1,M) = JDESC(1,M)
  100         CONTINUE
              NRDESC  = NEWNR
          END IF
          KARY(11) = 1
          KARY(2) = 1
 4300     CONTINUE
          IF(KARY(11).GT.NRDESC) GOTO 4305
C                                  INNER LOOP FOR PARAMETER
 4200         CONTINUE
C             KARY(2) = KARY(11) + KARY(18)
C             PRINT *,'LOOKING AT DESCRIPTOR',KARY(11),
C    *                         KDESC(1,KARY(11)),
C    *                         KARY(2),KDATA(I,KARY(2))
C
C                                  PROCESS ONE DESCRIPTOR AT A TIME
C
C                             ISOLATE TABLE
C
              KFUNC      = KDESC(1,KARY(11)) / 16384
C                             ISOLATE CLASS
              KCLASS     = MOD(KDESC(1,KARY(11)),16384) / 256
              KSEG       = MOD(KDESC(1,KARY(11)),256)
              IF (KFUNC.EQ.1) THEN
C                            REPLICATION DESCRIPTOR
                  CALL FI8501(KARY,ISTEP,KCLASS,KSEG,IDATA,RDATA,
     *                  KDATA,I,KDESC,NRDESC,IERRTN)
                  IF (IERRTN.NE.0) THEN
                      RETURN
                  END IF
                  GO TO 4200
              ELSE IF (KFUNC.EQ.2) THEN
C                            OPERATOR DESCRIPTOR
                  CALL FI8502(*4200,KBUFR,KCLASS,KSEG,
     *                                            KDESC,NRDESC,I,ISTEP,
     *            KARY,KDATA,ISECT3,KRFVSW,NEWRFV,LDESC,IERRTN,INDEXB)
                  IF (IERRTN.NE.0) THEN
                      RETURN
                  END IF
                  KARY(11) = KARY(11) + 1
                  GO TO 4300
              ELSE IF (KFUNC.EQ.3) THEN
C                            SEQUENCE DESCRIPTOR
                  CALL FI8503(KARY(11),KDESC,NRDESC,
     *                     ISECT3,IUNITD,KSEQ,KNUM,KLIST,IERRTN)
                  IF (IERRTN.NE.0) THEN
                      RETURN
                  END IF
                  GO TO 4200
              END IF
C                                 FALL THRU WITH ELEMENT DESCRIPTOR
C                                 FIND MATCHING TABLE B ENTRY
              LK  = INDEXB(KDESC(1,KARY(11)))
              IF (LK.LT.1) THEN
C                               FALL THRU WITH NO MATCHING B ENTRY
                  PRINT *,'FI8506 3800',KARY(11),KDESC(1,KARY(11)),
     *                     NRDESC,LK,LDESC(LK)
                  IERRTN  = 2
                  RETURN
              END IF
C
              IF (AUNITS(LK).EQ.CCITT) THEN
                  TEXT  = .TRUE.
              ELSE
                  TEXT  = .FALSE.
              END IF
C
              IF (TEXT) THEN
                  JWIDE  = KWIDTH(LK)
 3775             CONTINUE
                  IF (JWIDE.GT.32) THEN
                      IF(ISECT3(10).NE.0) THEN
                          CALL W3AI38 (KDATA(I,KARY(2)),4)
                      END IF
                      IF ((KARY(3)+32).GT.KEND) THEN
                          IERRTN = 1
                          RETURN
                      END IF
                      CALL SBYTE (KBUFR,KDATA(I,KARY(2)),KARY(3),32)
                      KARY(3)  = KARY(3) + 32
C                                 ADD A WORD HERE ONLY
                      KARY(18)  = KARY(18) + 1
C                     KARY(2)  = KARY(11) + KARY(18)
                      KARY(2) = KARY(2) + 1
                      JWIDE  = JWIDE - 32
                      GO TO 3775
                  ELSE IF (JWIDE.EQ.32) THEN
                      IF(ISECT3(10).NE.0) THEN
                          CALL W3AI38 (KDATA(I,KARY(2)),4)
                      END IF
                      IF ((KARY(3)+32).GT.KEND) THEN
                          IERRTN = 1
                          RETURN
                      END IF
                      CALL SBYTE (KBUFR,KDATA(I,KARY(2)),KARY(3),32)
                      KARY(3)  = KARY(3) + 32
                      KARY(2) = KARY(2) + 1
                      JWIDE  = JWIDE - 32
                  ELSE IF (JWIDE.GT.0) THEN
                      IF(ISECT3(10).NE.0) THEN
                          CALL W3AI38 (KDATA(I,KARY(2)),4)
                      END IF
                      IF ((KARY(3)+JWIDE).GT.KEND) THEN
                          IERRTN = 1
                          RETURN
                      END IF
                      CALL SBYTE (KBUFR,KDATA(I,KARY(2)),KARY(3),JWIDE)
                      KARY(3)  = KARY(3) + JWIDE
                      KARY(2) = KARY(2) + 1
                  END IF
              ELSE
C                               NOT TEXT
                  IF (KARY(27).NE.0.AND.KDESC(1,KARY(11)).NE.7957) THEN
C                                 ENTER ASSOCIATED FIELD
                      IF ((KARY(3)+KARY(27)).GT.KEND) THEN
                          IERRTN = 1
                          RETURN
                      END IF
                      CALL SBYTE (KBUFR,KDATA(I,KARY(2)),KARY(3),
     *                     KARY(27))
                      KARY(3)  = KARY(3) + KARY(27)
                      KARY(18)  = KARY(18) + 1
C                     KARY(2)  = KARY(11) + KARY(18)
                      KARY(2) = KARY(2) + 1
                  END IF
C
                  JWIDE  = KWIDTH(LK) + KARY(26)
                  IF (KDATA(I,KARY(2)).EQ.MISG) THEN
C                                 MISSING DATA, SET ALL BITS ON
                      IF ((KARY(3)+JWIDE).GT.KEND) THEN
                          IERRTN = 1
                          RETURN
                      END IF
                      CALL SBYTE (KBUFR,IBITS(JWIDE),KARY(3),JWIDE)
                      KARY(3)  = KARY(3) + JWIDE
                      KARY(2) = KARY(2) + 1
                      KARY(11) = KARY(11) + 1
                      GO TO 4300
                  END IF
C                                 CAN DATA BE CONTAINED IN SPECIFIED
C                                          BIT WIDTH, IF NOT - ERROR
                  IF (KDATA(I,KARY(2)).GT.IBITS(JWIDE)) THEN
                      IERRTN = 1
                      RETURN
                  END IF
C                                 ADJUST WITH REFERENCE VALUE
                  IF (KRFVSW(LK).EQ.0) THEN
                      JRV  = KRFVAL(LK)
                  ELSE
                      JRV  = NEWRFV(LK)
                  END IF
C
                  KDATA(I,KARY(2)) = KDATA(I,KARY(2)) - JRV
C                                      IF NEW VALUE IS NEGATIVE - ERROR
                  IF (KDATA(I,KARY(2)).LT.0) THEN
                      IERRTN  = 11
                      RETURN
                  END IF
C                                 PACK DATA INTO OUTPUT ARRAY
                  IF ((KARY(3)+JWIDE).GT.KEND) THEN
                      IERRTN = 1
                      RETURN
                  END IF
                  CALL SBYTE (KBUFR,KDATA(I,KARY(2)),KARY(3),JWIDE)
                  KARY(2) = KARY(2) + 1
                  KARY(3)  = KARY(3) + JWIDE
              END IF
          KARY(11) = KARY(11) + 1
          GOTO 4300
 4305     CONTINUE
C                              RESET ALL REFERENCE VALUES TO ORIGINAL
          DO 4310 LX = 1, ISECT3(8)
              KRFVSW(LX)  = 0
 4310     CONTINUE
 4500 CONTINUE
      RETURN
      END
      SUBROUTINE FI8508(ISTEP,IUNITB,IDATA,KDESC,NRDESC,ATEXT,KSUB,KARY,
     *            KDATA,LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KRFVSW,ISECT3,
     *            KWIDTH,KASSOC,IUNITD,KSEQ,KNUM,KLIST,IERRTN,INDEXB)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8508      COMBINE INTEGER/TEXT DATA
C   PRGMMR: CAVANAUGH             W/NMC42    DATE: 93-12-03
C
C ABSTRACT: CONSTRUCT INTEGER SUBSET FROM REAL AND TEXT DATA
C
C PROGRAM HISTORY LOG:
C   93-12-03  CAVANAUGH
C   YY-MM-DD  MODIFIER1   DESCRIPTION OF CHANGE
C   94-03-31  HOPPA       ADDED KSUB TO FI8501 PARAMETER LIST.
C   94-04-18  HOPPA       ADDED DUMMY VARIABLE IDUM TO FI8502 PARAMETER
C                         LIST.
C   94-04-20  HOPPA       ADDED DUMMY VARIABLE LL TO FI8501 PARAMETER
C                         LIST.
C   94-04-29  HOPPA     - CHANGED I TO KARY(11)
C                       - ADDED A KARY(2) ASSIGNMENT SO HAVE SOMETHING
C                         TO PASS TO SUBROUTINES ** TEST THIS **
C                       - REMOVED I AND LL FROM CALL TO FI8501
C   94-05-13  HOPPA     - ADDED CODE TO CALCULATE KWORDS WHEN KFUNC=2
C   94-05-18  HOPPA     - DELETED KARY(2) ASSIGNMENT
C
C
C USAGE:    CALL FI8508(ISTEP,IUNITB,IDATA,KDESC,NRDESC,ATEXT,KSUB,KARY,
C    *            KDATA,LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KRFVSW,ISECT3,
C    *            KWIDTH,KASSOC,IUNITD,KSEQ,KNUM,KLIST,IERRTN,INDEXB)
C   INPUT ARGUMENT LIST:
C     ISTEP    -
C     IUNITB   - UNIT NUMBER OF DEVICE CONTAINING TABLE B
C     IDATA    - INTEGER WORKING ARRAY
C     KDESC    - EXPANDED DESCRIPTOR SET
C     NRDESC   - NUMBER OF DESCRIPTORS IN KDESC
C     ATEXT    - TEXT DATA FOR CCITT IA5 AND TEXT OPERATOR FIELDS
C     KSUB     - SUBSET NUMBER
C     KARY     - WORKING ARRAY
C     ISECT3   -
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     KDATA    - ARRAY CONTAINING INTEGER SUBSETS
C     LDESC    - LIST OF TABLE B DESCRIPTORS (DECIMAL)
C     ANAME    - LIST OF DESCRIPTOR NAMES
C     AUNITS   - UNITS FOR EACH DESCRIPTOR
C     KSCALE   - BASE 10 SCALE FACTOR FOR EACH DESCRIPTOR
C     KRFVAL   - REFERENCE VALUE FOR EACH DESCRIPTOR
C     KRFVSW   -
C     NEWRFV   -
C     KWIDTH   - STANDARD BIT WIDTH TO CONTAIN EACH VALUE
C                FOR SPECIFIC DESCRIPTOR
C     KASSOC   -
C     IERRTN   - ERROR RETURN FLAG
C
C
C REMARKS:
C
C ATTRIBUTES:
C   LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN
C   MACHINE:  HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256
C
C$$$
C                         TAKE EACH NON-TEXT ENTRY OF SECTION 2
C                               ACCEPT IT
C
C                         TAKE EACH TEXT ENTRY
C                               INSERT INTO INTEGER ARRAY,
C                               ADDING FULL WORDS AS NECESSARY
C                               MAKE SURE ANY LAST WORD HAS TEXT DATA
C                               RIGHT JUSTIFIED
C  ---------------------------------------------------------------------
C                          PASS BACK CONVERTED ENTRY TO LOCATION
C                          SPECIFIED BY USER
C
C                          REFERENCE VALUE WILL BE APPLIED DURING
C                          ENCODING OF MESSAGE
C  ---------------------------------------------------------------------
      INTEGER          IUNITB,IUNITD,KSEQ(*),KNUM(*),KLIST(300,*)
      INTEGER          KDESC(3,*),NRDESC,KASSOC(*)
      INTEGER          IDATA(*),ISTEP
      INTEGER          KDATA(500,*)
      INTEGER          KARY(*),INDEXB(*)
      INTEGER          KSUB,K
      INTEGER          LDESC(*)
      INTEGER          IBITS(32)
      INTEGER          KSCALE(*)
      INTEGER          KRFVAL(*)
      INTEGER          KRFVSW(*)
      INTEGER          KWIDTH(*)
      INTEGER          MISG
      INTEGER          MPTR,ISECT3(*)
      CHARACTER*1      ATEXT(*)
      CHARACTER*1      AHOLD1(256)
      INTEGER          IHOLD4(64)
      CHARACTER*25     AUNITS(*)
      CHARACTER*25     CCITT
      CHARACTER*40     ANAME(*)
C
      SAVE
C
      EQUIVALENCE      (AHOLD1,IHOLD4)
C
C  =====================================
      DATA  CCITT /'CCITT IA5                '/
      DATA  IBITS /         1,          3,          7,         15,
     *                     31,         63,        127,        255,
     *                    511,       1023,       2047,       4095,
     *                   8191,      16383,      32767,      65535,
     *             Z'0001FFFF',Z'0003FFFF',Z'0007FFFF',Z'000FFFFF',
     *             Z'001FFFFF',Z'003FFFFF',Z'007FFFFF',Z'00FFFFFF',
     *             Z'01FFFFFF',Z'03FFFFFF',Z'07FFFFFF',Z'0FFFFFFF',
     *             Z'1FFFFFFF',Z'3FFFFFFF',Z'7FFFFFFF',Z'FFFFFFFF'/
      DATA  MISG  /99999/
C
      IF (ISECT3(8).EQ.0) THEN
          CALL FI8512(IUNITB,ISECT3,KDESC,NRDESC,KARY,IERRTN,
     *               LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW,
     *               IUNITD,KSEQ,KNUM,KLIST,INDEXB)
          IF (IERRTN.NE.0) THEN
              RETURN
          END IF
      END IF
C                         HAVE TABLE B AVAILABLE NOW
C
C                         LOOK AT EACH DATA ENTRY
C                              CONVERT NON TEXT
C                              MOVE TEXT
C
      KPOS  = 0
      MPTR  = 0
      KARY(11) = 0
 1000 CONTINUE
      KARY(11) = KARY(11) + 1
      IF (KARY(11).GT.NRDESC) GO TO 1500
C
C                  RE-ENTRY POINT FOR REPLICATION AND SEQUENCE DESCR'S
C
  500 CONTINUE
      KFUNC  = KDESC(1,KARY(11)) / 16384
      KL  = KDESC(1,KARY(11)) - 16384 * KFUNC
      KCLASS  = KL / 256
      KSEG    = MOD(KL,256)
C     KARY(2) = KARY(11) + KARY(18)
      IF (KFUNC.EQ.1) THEN
C                              REPLICATION DESCRIPTOR
          CALL FI8501(KARY,ISTEP,KCLASS,KSEG,IDATA,RDATA,
     *                  KDATA,KSUB,KDESC,NRDESC,IERRTN)
          IF (IERRTN.NE.0) THEN
              RETURN
          END IF
          GO TO 500
      ELSE IF (KFUNC.EQ.2) THEN
          IF (KCLASS.EQ.5) THEN
C                        HANDLE TEXT OPERATORS
CC
              KAVAIL  = IDATA(KARY(11))
C                                 UNUSED POSITIONS IN LAST WORD
              KREM  = MOD(KAVAIL,4)
              IF (KREM.NE.0) THEN
                  KWORDS  = KAVAIL / 4 + 1
              ELSE
                  KWORDS  = KAVAIL / 4
              END IF
CC
              JWIDE  = KSEG * 8
              GO TO 1200
          END IF
      ELSE IF (KFUNC.EQ.3) THEN
C                          SEQUENCE DESCRIPTOR - ERROR
          CALL FI8503(KARY(11),KDESC,NRDESC,
     *                     ISECT3,IUNITD,KSEQ,KNUM,KLIST,IERRTN)
          IF (IERRTN.NE.0) THEN
              RETURN
          END IF
          GO TO 500
      ELSE
C
C                         FIND MATCHING DESCRIPTOR
C
          K  = INDEXB(KDESC(1,KARY(11)))
          IF (K.LT.1) THEN
              PRINT *,'FI8508-NOT FOUND',KARY(11),KDESC(1,KARY(11)),
     *           ISECT3(8),LDESC(K)
              IERRTN  = 2
              RETURN
          END IF
C                           HAVE MATCHING DESCRIPTOR
  200     CONTINUE
          IF (AUNITS(K)(1:9).NE.CCITT(1:9)) THEN
              IF (KARY(27).NE.0) THEN
                  IF (KDESC(1,KARY(11)).LT.7937.OR.
     *                           KDESC(1,KARY(11)).GT.8191) THEN
C                        ASSOC FLD FOR ALL BUT CLASS 31
                      KPOS  = KPOS + 1
                      IF (KASSOC(KARY(11)).EQ.IBITS(KARY(27))) THEN
                          KDATA(KSUB,KPOS)  = MISG
                      ELSE
                          KDATA(KSUB,KPOS)  = KASSOC(KARY(11))
                      END IF
                  END IF
              END IF
C                        IF NOT MISSING DATA
              IF (IDATA(KARY(11)).EQ.99999) THEN
                  KPOS  = KPOS + 1
                  KDATA(KSUB,KPOS)  = MISG
              ELSE
C                           PROCESS INTEGER VALUES
                  KPOS  = KPOS + 1
                  KDATA(KSUB,KPOS) = IDATA(KARY(11))
              END IF
          ELSE
C                         PROCESS TEXT
C                                 NUMBER OF BYTES REQUIRED BY TABLE B
              KREQ    = KWIDTH(K) / 8
C                                   NUMBER BYTES AVAILABLE IN ATEXT
              KAVAIL  = IDATA(KARY(11))
C                                 UNUSED POSITIONS IN LAST WORD
              KREM  = MOD(KAVAIL,4)
              IF (KREM.NE.0) THEN
                  KWORDS  = KAVAIL / 4 + 1
              ELSE
                  KWORDS  = KAVAIL / 4
              END IF
C                                 MOVE TEXT CHARACTERS TO KDATA
              JWIDE   = KWIDTH(K)
              GO TO 1200
          END IF
      END IF
      GO TO 1000
 1200 CONTINUE
  300 CONTINUE
      NPTR  = MPTR
      DO 400 IJ = 1, KWORDS
              KPOS  = KPOS + 1
              CALL GBYTE(ATEXT,KDATA(KSUB,KPOS),NPTR,32)
              NPTR  = NPTR + 32
  400     CONTINUE
      MPTR  = MPTR + JWIDE
      GO TO 1000
 1500 CONTINUE
      RETURN
      END
      SUBROUTINE FI8509(ISTEP,IUNITB,RDATA,KDESC,NRDESC,ATEXT,KSUB,KARY,
     *            KDATA,LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KRFVSW,ISECT3,
     *            KWIDTH,KASSOC,IUNITD,KSEQ,KNUM,KLIST,IERRTN,INDEXB)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8509      CONVERT REAL/TEXT INPUT TO INTEGER
C   PRGMMR: CAVANAUGH             W/NMC42    DATE: 93-12-03
C
C ABSTRACT: CONSTRUCT INTEGER SUBSET FROM REAL AND TEXT DATA
C
C PROGRAM HISTORY LOG:
C   93-12-03  CAVANAUGH
C   94-03-31  HOPPA       ADDED KSUB TO THE FI8501 PARAMETER LIST.
C   94-04-18  HOPPA       ADDED DUMMY VARIABLE IDUM TO FI8502 PARAMETER
C                         LIST.
C   94-04-20  HOPPA       ADDED DUMMY VARIABLE LL TO FI8501 PARAMETER
C                         LIST.
C   94-04-29  HOPPA     - CHANGED I TO KARY(11)
C                       - ADDED A KARY(2) ASSIGNMENT SO HAVE SOMETHING
C                         TO PASS TO SUBROUTINES ** TEST THIS **
C                       - REMOVED I AND LL FROM CALL TO FI8501
C   94-05-18  HOPPA     - DELETED KARY(2) ASSIGNMENT
C
C USAGE:    CALL FI8509(ISTEP,IUNITB,RDATA,KDESC,NRDESC,ATEXT,KSUB,KARY,
C    *            KDATA,LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KRFVSW,ISECT3,
C    *            KWIDTH,KASSOC,IUNITD,KSEQ,KNUM,KLIST,IERRTN,INDEXB)
C   INPUT ARGUMENT LIST:
C     IUNITB   - UNIT NUMBER OF DEVICE CONTAINING TABLE B
C     RDATA    - REAL WORKING ARRAY
C     KDESC    - EXPANDED DESCRIPTOR SET
C     NRDESC   - NUMBER OF DESCRIPTORS IN KDESC
C     ATEXT    - TEXT DATA FOR CCITT IA5 AND TEXT OPERATOR FIELDS
C     KSUB     - SUBSET NUMBER
C     KARY     - WORKING ARRAY
C     ISECT3   -
C     IUNITD   -
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     KDATA    - ARRAY CONTAINING INTEGER SUBSETS
C     LDESC    - LIST OF TABLE B DESCRIPTORS (DECIMAL)
C     ANAME    - LIST OF DESCRIPTOR NAMES
C     AUNITS   - UNITS FOR EACH DESCRIPTOR
C     KSCALE   - BASE 10 SCALE FACTOR FOR EACH DESCRIPTOR
C     KRFVAL   - REFERENCE VALUE FOR EACH DESCRIPTOR
C     KRFVSW   -
C     NEWRFV   -
C     KASSOC   -
C     KWIDTH   - STANDARD BIT WIDTH TO CONTAIN EACH VALUE
C                FOR SPECIFIC DESCRIPTOR
C     IERRTN   - ERROR RETURN FLAG
C     KSEG     -
C     KNUM     -
C     KLIST    -
C
C REMARKS:
C
C ATTRIBUTES:
C   LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN
C   MACHINE:  HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256
C
C$$$
C                         TAKE EACH NON-TEXT ENTRY OF SECTION 2
C                               SCALE IT
C                               ROUND IT
C                               CONVERT TO INTEGER
C
C                         TAKE EACH TEXT ENTRY
C                               INSERT INTO INTEGER ARRAY,
C                               ADDING FULL WORDS AS NECESSARY
C                               MAKE SURE ANY LAST WORD HAS TEXT DATA
C                               RIGHT JUSTIFIED
C                          PASS BACK CONVERTED ENTRY TO LOCATION
C                          SPECIFIED BY USER
C
C                          REFERENCE VALUE WILL BE APPLIED DURING
C                          ENCODING OF MESSAGE
C  ---------------------------------------------------------------------
      REAL              RDATA(*)
      INTEGER          IUNITB,IUNITD,KSEQ(*),KNUM(*),KLIST(300,*)
      INTEGER          IBITS(32),INDEXB(*)
      INTEGER          KDESC(3,*),ISTEP
      INTEGER          KDATA(500,*)
      INTEGER          KASSOC(*)
      INTEGER          KARY(*)
      INTEGER          KSUB,K
      INTEGER          LDESC(*)
      INTEGER          NRDESC
      INTEGER          IERRTN
      INTEGER          KSCALE(*)
      INTEGER          KRFVAL(*)
      INTEGER          KRFVSW(*)
      INTEGER          KWIDTH(*)
      INTEGER          MPTR,ISECT3(*)
      INTEGER          MISG
      CHARACTER*1      AHOLD1(256)
      INTEGER          IHOLD4(64)
      CHARACTER*1      ATEXT(*)
      CHARACTER*25     AUNITS(*)
      CHARACTER*25     CCITT
      CHARACTER*40     ANAME(*)
C
      SAVE
C  =====================================
      EQUIVALENCE      (AHOLD1,IHOLD4)
C
      DATA   IBITS/         1,          3,          7,         15,
     *                     31,         63,        127,        255,
     *                    511,       1023,       2047,       4095,
     *                   8191,      16383,      32767,      65535,
     *             Z'0001FFFF',Z'0003FFFF',Z'0007FFFF',Z'000FFFFF',
     *             Z'001FFFFF',Z'003FFFFF',Z'007FFFFF',Z'00FFFFFF',
     *             Z'01FFFFFF',Z'03FFFFFF',Z'07FFFFFF',Z'0FFFFFFF',
     *             Z'1FFFFFFF',Z'3FFFFFFF',Z'7FFFFFFF',Z'FFFFFFFF'/
C
      DATA  CCITT /'CCITT IA5                '/
      DATA  MISG  /99999/
C  =====================================
C
      IF (ISECT3(8).EQ.0) THEN
          CALL FI8512(IUNITB,ISECT3,KDESC,NRDESC,KARY,IERRTN,
     *               LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW,
     *               IUNITD,KSEQ,KNUM,KLIST,INDEXB)
          IF (IERRTN.NE.0) THEN
              RETURN
          END IF
      END IF
C                         HAVE TABLE B AVAILABLE NOW
C
C                         LOOK AT EACH DATA ENTRY
C                              CONVERT NON TEXT
C                              MOVE TEXT
C
      KPOS  = 0
      MPTR  = 0
      KARY(11) = 0
 1000 CONTINUE
      KARY(11) = KARY(11) + 1
      IF (KARY(11).GT.NRDESC) GO TO 1500
C                         RE-ENRY POINT FOR REPLICATION AND
C                          SEQUENCE DESCRIPTORS
  500 CONTINUE
      KFUNC  = KDESC(1,KARY(11)) / 16384
      KL  = KDESC(1,KARY(11)) - 16384 * KFUNC
      KCLASS  = KL / 256
      KSEG    = MOD(KL,256)
C     KARY(2) = KARY(11) + KARY(18)
      IF (KFUNC.EQ.1) THEN
C                              REPLICATION DESCRIPTOR
          CALL FI8501(KARY,ISTEP,KCLASS,KSEG,IDATA,RDATA,
     *                  KDATA,KSUB,KDESC,NRDESC,IERRTN)
          IF (IERRTN.NE.0) THEN
              RETURN
          END IF
          GO TO 500
      ELSE IF (KFUNC.EQ.2) THEN
C                        HANDLE OPERATORS
          IF (KCLASS.EQ.5) THEN
C                                   NUMBER BYTES AVAILABLE IN ATEXT
              KAVAIL  = RDATA(KARY(11))
C                                 UNUSED POSITIONS IN LAST WORD
              KREM  = MOD(KAVAIL,4)
              IF (KREM.NE.0) THEN
                  KWORDS  = KAVAIL / 4 + 1
              ELSE
                  KWORDS  = KAVAIL / 4
              END IF
              JWIDE  = KSEG * 8
              GO TO 1200
          ELSE IF (KCLASS.EQ.2) THEN
              IF (KSEG.EQ.0) THEN
                  KARY(9) = 0
              ELSE
                  KARY(9) = KSEG - 128
              END IF
              GO TO 1200
          END IF
      ELSE IF (KFUNC.EQ.3) THEN
C                          SEQUENCE DESCRIPTOR - ERROR
          CALL FI8503(I,KDESC,NRDESC,
     *                     ISECT3,IUNITD,KSEQ,KNUM,KLIST,IERRTN)
          IF (IERRTN.NE.0) THEN
              RETURN
          END IF
          GO TO 500
      ELSE
C
C                         FIND MATCHING DESCRIPTOR
C
          K  = INDEXB(KDESC(1,KARY(11)))
          IF (K.LT.1) THEN
              IERRTN  = 2
C             PRINT *,'FI8509 - IERRTN = 2'
              RETURN
          END IF
C                           HAVE MATCHING DESCRIPTOR
  200     CONTINUE
          IF (AUNITS(K)(1:9).NE.CCITT(1:9)) THEN
              IF (KARY(27).NE.0) THEN
                  IF (KDESC(1,KARY(11)).LT.7937.OR.
     *                           KDESC(1,KARY(11)).GT.8191) THEN
C                        ASSOC FLD FOR ALL BUT CLASS 31
                      KPOS  = KPOS + 1
                      IF (KASSOC(KARY(11)).EQ.IBITS(KARY(27))) THEN
                          KDATA(KSUB,KPOS)  = MISG
                      ELSE
                          KDATA(KSUB,KPOS)  = KASSOC(KARY(11))
                      END IF
                  END IF
              END IF
C                        IF NOT MISSING DATA
              IF (RDATA(KARY(11)).EQ.99999.) THEN
                  KPOS  = KPOS + 1
                  KDATA(KSUB,KPOS)  = MISG
              ELSE
C                           PROCESS REAL VALUES
                  IF (KSCALE(K).NE.0) THEN
C                                    SCALING ALLOWING FOR CHANGE SCALE
                      SCALE  = 10. **(IABS(KSCALE(K)) + KARY(9))
                      IF (KSCALE(K).LT.0) THEN
                          RDATA(KARY(11)) = RDATA(KARY(11)) / SCALE
                      ELSE
                          RDATA(KARY(11)) = RDATA(KARY(11)) * SCALE
                      END IF
                  END IF
C                          PERFORM ROUNDING
                  RDATA(KARY(11)) = RDATA(KARY(11)) +
     *                              SIGN(0.5,RDATA(KARY(11)))
C                          CONVERT TO INTEGER
                  KPOS  = KPOS + 1
                  KDATA(KSUB,KPOS) = RDATA(KARY(11))
C
              END IF
          ELSE
C                       PROCESS TEXT
C                                NUMBER OF BYTES REQUIRED BY TABLE B
              KREQ    = KWIDTH(K) / 8
C                                   NUMBER BYTES AVAILABLE IN ATEXT
              KAVAIL  = RDATA(KARY(11))
C                                 UNUSED POSITIONS IN LAST WORD
              KREM  = MOD(KAVAIL,4)
              IF (KREM.NE.0) THEN
                  KWORDS  = KAVAIL / 4 + 1
              ELSE
                  KWORDS  = KAVAIL / 4
              END IF
C                                 MOVE TEXT CHARACTERS TO KDATA
              JWIDE   = KWIDTH(K)
              GO TO 1200
          END IF
      END IF
      GO TO 1000
 1200 CONTINUE
  300 CONTINUE
      NPTR  = MPTR
      DO 400 IJ = 1, KWORDS
          KPOS  = KPOS + 1
          CALL GBYTE(ATEXT,KDATA(KSUB,KPOS),NPTR,32)
          NPTR  = NPTR + 32
  400 CONTINUE
      MPTR  = MPTR + JWIDE
      GO TO 1000
 1500 CONTINUE
C     DO 2000 I = 1, KPOS
C2000 CONTINUE
      RETURN
      END
      SUBROUTINE FI8511(ISECT3,KARY,JIF,JDESC,NEWNR,
     *                        KIF,KDESC,NRDESC,IERRTN)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8511      REBUILD KDESC FROM JDESC
C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 93-12-03
C
C ABSTRACT: CONSTRUCT WORKING DESCRIPTOR LIST FROM LIST OF DESCRIPTORS
C           IN SECTION 3.
C
C PROGRAM HISTORY LOG:
C   93-12-03  CAVANAUGH
C   YY-MM-DD  MODIFIER1   DESCRIPTION OF CHANGE
C
C USAGE:    CALL FI8511(ISECT3,KARY,JIF,JDESC,NEWNR,
C    *                        KIF,KDESC,NRDESC,IERRTN)
C   INPUT ARGUMENT LIST:
C     IUNITD   - UNIT NUMBER OF TABLE D
C     ISECT3   -
C     KARY     - UTILITY - ARRAY SEE MAIN ROUTINE
C     JIF      - DESCRIPTOR INPUT FORM FLAG
C     JDESC    - LIST OF DESCRIPTORS FOR SECTION 3
C     NEWNR    - NUMBER OF DESCRIPTORS IN JDESC
C     KSEQ     - SEQUENCE DESCRIPTOR KEY
C     KNUM     - NR OF DESCRIPTORS IN SEQUENCE
C     KLIST    - LIST OF DESCRIPTORS IN SEQUENCE
C
C   OUTPUT ARGUMENT LIST:
C     KIF      - DESCRIPTOR FORM
C     KDESC    - WORKING LIST OF DESCRIPTORS
C     NRDESC   - NUMBER OF DESCRIPTORS IN KDESC
C     IERRTN   - ERROR RETURN
C                 IERRTN = 0  NORMAL RETURN
C                 IERRTN = 5  FOUND DELAYED REPLICATION DURING
C                             EXPANSION
C
C REMARKS:
C
C ATTRIBUTES:
C   LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN
C   MACHINE:  HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256
C
C$$$
C
      INTEGER      JDESC(3,*), NEWNR, KDESC(3,*), NRDESC
      INTEGER      KARY(*),IERRTN,KIF,JIF
      INTEGER      ISECT3(*)
C
      SAVE
C
      IF (NEWNR.EQ.0) THEN
          IERRTN  = 3
          RETURN
      END IF
C
      NRDESC = NEWNR
      IF (JIF.EQ.0) THEN
          JIF    = 1
          DO  90 I = 1, NEWNR
             KDESC(1,I) = JDESC(1,I)*16384 + JDESC(2,I)*256 + JDESC(3,I)
             JDESC(1,I) = JDESC(1,I)*16384 + JDESC(2,I)*256 + JDESC(3,I)
   90     CONTINUE
      ELSE
          DO 100 I = 1, NEWNR
              KDESC(1,I)  = JDESC(1,I)
  100     CONTINUE
          NRDESC  = NEWNR
      END IF
      KIF    = 1
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE FI8512(IUNITB,ISECT3,KDESC,NRDESC,KARY,IERRTN,
     *               LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW,
     *               IUNITD,KSEQ,KNUM,KLIST,INDEXB)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8512      READ IN TABLE B
C   PRGMMR: CAVANAUGH       ORG: W/NMC42    DATE: 93-12-03
C
C ABSTRACT: READ IN TAILORED SET OF TABLE B DESCRIPTORS
C
C PROGRAM HISTORY LOG:
C   93-12-03  CAVANAUGH
C   YY-MM-DD  MODIFIER1   DESCRIPTION OF CHANGE
C   94-04-18  HOPPA       AN ERROR HAS BEEN CORRECTED TO PREVENT LATER
C                         SEARCHING TABLE B IF THERE ARE ONLY OPERATOR
C                         DESCRIPTORS IN THE DESCRIPTOR LIST.
C   94-05-17  HOPPA       CHANGED THE LOOP FOR EXPANDING SEQUENCE
C                         DESCRIPTORS FROM A DO LOOP TO A GOTO LOOP
C
C USAGE:    CALL FI8512(IUNITB,ISECT3,KDESC,NRDESC,KARY,IERRTN,
C    *               LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW,
C    *               IUNITD,KSEQ,KNUM,KLIST,INDEXB)
C   INPUT ARGUMENT LIST:
C     IUNITB   - UNIT WHERE TABLE B ENTRIES RESIDE
C     KDESC    - WORKING DESCRIPTOR LIST
C     NRDESC   - NUMBER OF DESCRIPTORS IN KDESC
C     IUNITD   - UNIT WHERE TABLE D ENTRIES RESIDE
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     KARY     -
C     IERRTN   -
C     LDESC    - DESCRIPTORS IN TABLE B (DECIMAL VALUES)
C     ANAME    - ARRAY CONTAINING NAMES OF DESCRIPTORS
C     AUNITS   - ARRAY CONTAINING UNITS OF DESCRIPTORS
C     KSCALE   - SCALE VALUES FOR EACH DESCRIPTOR
C     KRFVAL   - REFERENCE VALUES FOR EACH DESCRIPTOR
C     WIDTH    - BIT WIDTH OF EACH DESCRIPTOR
C     KRFVSW   - NEW REFERENCE VALUE SWITCH
C     KSEQ     - SEQUENCE DESCRIPTOR
C     KNUM     - NUMBER OF DESCRIPTORS IN SEQUENCE
C     KLIST    - SEQUENCE OF DESCRIPTORS
C
C REMARKS:
C
C ATTRIBUTES:
C   LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN
C   MACHINE:  HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256
C
C$$$
C
      INTEGER    KARY(*),LDESC(*),KSCALE(*),KRFVAL(*),KWIDTH(*)
      INTEGER    KDESC(3,*), NRDESC, IUNITB, IERRTN, KRFVSW(*)
      INTEGER    ISECT3(*),KEY(3,1600),INDEXB(*)
      INTEGER    IUNITD,KSEQ(*),KNUM(*),KLIST(300,*)
      CHARACTER*40   ANAME(*)
      CHARACTER*25   AUNITS(*)
C
      INTEGER    MDESC(800),MR,I,J
C
      SAVE
C
C  ===================================================================
      IERRTN  = 0
      DO 100 I = 1, 30
          KARY(I)  = 0
  100 CONTINUE
C INITIALIZE DESCRIPTOR POINTERS TO MISSING
      DO 105 I = 1, 16383
          INDEXB(I) = -1
  105 CONTINUE
C
C  ===================================================================
C                                MAKE A COPY OF THE DESCRIPTOR LIST
C                                   ELIMINATING REPLICATION/OPERATORS
      J  = 0
      DO 110 I = 1, NRDESC
          IF (KDESC(1,I).GE.49152.OR.KDESC(1,I).LT.16384) THEN
              J  = J + 1
              KEY(1,J)  = KDESC(1,I)
          END IF
  110 CONTINUE
      KCNT  = J
C  ===================================================================
C                                REPLACE ALL SEQUENCE DESCRIPTORS
C  JEN - FIXED NEXT BLOCK
C     DO 300 I = 1, KCNT
      I = 1
  300 IF(I.LE.KCNT)THEN
  200     CONTINUE
          IF (KEY(1,I).GE.49152) THEN
              CALL FI8503(I,KEY,KCNT,
     *                     ISECT3,IUNITD,KSEQ,KNUM,KLIST,IERRTN)
              IF (IERRTN.NE.0) THEN
                  RETURN
              END IF
              GO TO 200
          END IF
          I=I+1
          GOTO 300
      ENDIF
C 300 CONTINUE
C  ===================================================================
C                                ISOLATE SINGLE COPIES OF DESCRIPTORS
      MR  = 1
C        THE FOLLOWING LINE IS TO PREVENT LATER SEARCHING TABLE B WHEN
C        HAVE ONLY OPERATOR DESCRIPTORS
      IF(KCNT.EQ.0) GOTO 9000
      MDESC(MR)  = KEY(1,1)
      DO 500 I = 2, KCNT
          DO 400 J = 1, MR
              IF (KEY(1,I).EQ.MDESC(J)) THEN
                  GO TO 500
              END IF
  400     CONTINUE
          MR  = MR + 1
          MDESC(MR)  = KEY(1,I)
  500 CONTINUE
C  ===================================================================
C                                SORT INTO ASCENDING ORDER
C                                READ IN MATCHING ENTRIES FROM TABLE B
      DO 700 KCUR = 1, MR
          NEXT  = KCUR + 1
          IF (NEXT.LE.MR) THEN
              DO 600 LR  = NEXT, MR
                  IF (MDESC(KCUR).GT.MDESC(LR)) THEN
                      IHOLD       = MDESC(LR)
                      MDESC(LR)   = MDESC(KCUR)
                      MDESC(KCUR) = IHOLD
                  END IF
  600         CONTINUE
          END IF
  700 CONTINUE
C  ===================================================================
      REWIND IUNITB
C
C                             READ IN A MODIFIED TABLE B -
C                             MODIFIED TABLE B CONTAINS ONLY
C                             THOSE DESCRIPTORS ASSOCIATED WITH
C                             CURRENT DATA.
C
      KTRY  = 0
      DO 1500 NRTBLB = 1, MR
 1000     CONTINUE
 1001     FORMAT (I1,I2,I3,A40,A25,I4,8X,I7,I5)
          READ (IUNITB,1001,END=2000,ERR=8000)KF,KX,KY,ANAME(NRTBLB),
     *     AUNITS(NRTBLB),KSCALE(NRTBLB),KRFVAL(NRTBLB),KWIDTH(NRTBLB)
          KRFVSW(NRTBLB) = 0
          LDESC(NRTBLB)  = KX*256 + KY
C
          IF (LDESC(NRTBLB).EQ.MDESC(NRTBLB)) THEN
C             PRINT *,'1001',NRTBLB,LDESC(NRTBLB)
C             PRINT *,LDESC(NRTBLB),ANAME(NRTBLB),KSCALE(NRTBLB),
C    *               KRFVAL(NRTBLB),KWIDTH(NRTBLB)
              KTRY  = KTRY + 1
              INDEXB(LDESC(NRTBLB)) = KTRY
C             PRINT *,'INDEX(',LDESC(NRTBLB),' = ',KTRY
          ELSE IF (LDESC(NRTBLB).GT.MDESC(NRTBLB)) THEN
C             PRINT *,'FI8512 - IERRTN=2'
              IERRTN  = 2
              RETURN
          ELSE
              GO TO 1000
          END IF
 1500 CONTINUE
      IF (KTRY.NE.MR) THEN
          PRINT *,'DO NOT HAVE A COMPLETE SET OF TABLE B ENTRIES'
          IERRTN  = 2
          RETURN
      END IF
C     DO 1998 I = 1, 16383, 30
C         WRITE (6,1999) (INDEXB(I+J),J=0,23)
C1998 CONTINUE
C1999 FORMAT(30(1X,I3))
C
 2000 CONTINUE
      IERRTN     = 0
      ISECT3(8)  = MR
      GO TO 9000
 8000 CONTINUE
      IERRTN = 4
 9000 CONTINUE
      RETURN
      END
      SUBROUTINE FI8513 (IUNITD,ISECT3,KSEQ,KNUM,KLIST,IERRTN)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    FI8513      READ IN TABLE D
C   PRGMMR: CAVANAUGH             W/NMC42    DATE: 93-12-03
C
C ABSTRACT: READ IN TABLE D
C
C PROGRAM HISTORY LOG:
C   93-12-03  CAVANAUGH
C   YY-MM-DD  MODIFIER1   DESCRIPTION OF CHANGE
C
C USAGE:    CALL FI8513 (IUNITD,ISECT3,KSEQ,KNUM,KLIST,IERRTN)
C   INPUT ARGUMENT LIST:
C     IUNITD   - UNIT NUMBER OF INPUT DEVICE
C     KARY     - WORK ARRAY
C
C   OUTPUT ARGUMENT LIST:
C     KSEQ     - KEY FOR SEQUENCE DESCRIPTORS
C     KNUM     - NUMBER IF DESCRIPTORS IN LIST
C     KLIST    - DESCRIPTORS LIST
C     IERRTN   - ERROR RETURN FLAG
C
C REMARKS:
C
C ATTRIBUTES:
C   LANGUAGE: IBM VS FORTRAN, CRAY CFT77 FORTRAN
C   MACHINE:  HDS, CRAY C916-128, Y-MP8/864, Y-MP EL92/256
C
C$$$
C
      INTEGER      IUNITD, ISECT3(*)
      INTEGER      KSEQ(*),KNUM(*),KLIST(300,*)
      INTEGER      KKF(10),KKX(10),KKY(10),KF,KX,KY
C
      SAVE
C
      REWIND IUNITD
      J     = 0
      IERRTN  = 0
 1000 CONTINUE
      READ (IUNITD,1001,END=9000,ERR=8000)KF,KX,KY,
     *                KKF(1),KKX(1),KKY(1),
     *                KKF(2),KKX(2),KKY(2),
     *                KKF(3),KKX(3),KKY(3),
     *                KKF(4),KKX(4),KKY(4),
     *                KKF(5),KKX(5),KKY(5),
     *                KKF(6),KKX(6),KKY(6),
     *                KKF(7),KKX(7),KKY(7),
     *                KKF(8),KKX(8),KKY(8),
     *                KKF(9),KKX(9),KKY(9),
     *                KKF(10),KKX(10),KKY(10)
 1001 FORMAT (11(I1,I2,I3,1X),3X)
      J  = J + 1
C                             BUILD SEQUENCE KEY
      KSEQ(J)  = 16384*KF + 256*KX + KY
      DO 2000 LM = 1, 10
C                             BUILD KLIST
          KLIST(J,LM) = 16384*KKF(LM) + 256*KKX(LM) + KKY(LM)
          IF(KLIST(J,LM).NE.0) THEN
              KNUM(J)  = LM
          END IF
 2000 CONTINUE
      GO TO 1000
 8000 CONTINUE
      IERRTN  = 6
 9000 CONTINUE
      ISECT3(9) = J
      RETURN
      END
