SUBROUTINE W3FI88(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX,
* LDATA,LSTACK,MAXR,MAXD,IUNITB,IUNITD)
C
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: W3FI88 BUFR MESSAGE DECODER
C PRGMMR: KEYSER ORG: NP22 DATE: 2001-02-01
C
C ABSTRACT: THIS SET OF ROUTINES WILL DECODE A BUFR MESSAGE AND
C PLACE INFORMATION EXTRACTED FROM THE BUFR MESSAGE INTO SELECTED
C ARRAYS FOR THE USER. THE ARRAY KDATA CAN NOW BE SIZED BY THE USER
C BY INDICATING THE MAXIMUM NUMBER OF SUBSETS AND THE MAXIMUM
C NUMBER OF DESCRIPTORS THAT ARE EXPECTED IN THE COURSE OF DECODING
C SELECTED INPUT DATA. THIS ALLOWS FOR REALISTIC SIZING OF KDATA
C AND THE MSTACK ARRAYS. THIS VERSION ALSO ALLOWS FOR THE INCLUSION
C OF THE UNIT NUMBERS FOR TABLES B AND D INTO THE
C ARGUMENT LIST. THIS ROUTINE DOES NOT INCLUDE IFOD PROCESSING.
C
C PROGRAM HISTORY LOG:
C 1988-08-31 CAVANAUGH
C 1990-12-07 CAVANAUGH NOW UTILIZING GBYTE ROUTINES TO GATHER
C AND SEPARATE BIT FIELDS. THIS SHOULD IMPROVE
C (DECREASE) THE TIME IT TAKES TO DECODE ANY
C BUFR MESSAGE. HAVE ENTERED CODING THAT WILL
C PERMIT PROCESSING BUFR EDITIONS 1 AND 2.
C IMPROVED AND CORRECTED THE CONVERSION INTO
C IFOD FORMAT OF DECODED BUFR MESSAGES.
C 1991-01-18 CAVANAUGH PROGRAM/ROUTINES MODIFIED TO PROPERLY HANDLE
C SERIAL PROFILER DATA.
C 1991-04-04 CAVANAUGH MODIFIED TO HANDLE TEXT SUPPLIED THRU
C DESCRIPTOR 2 05 YYY.
C 1991-04-17 CAVANAUGH ERRORS IN EXTRACTING AND SCALING DATA
C CORRECTED. IMPROVED HANDLING OF NESTED
C QUEUE DESCRIPTORS IS ADDED.
C 1991-05-10 CAVANAUGH - ARRAY 'DATA' HAS BEEN ENLARGED TO REAL*8
C TO BETTER CONTAIN VERY LARGE NUMBERS MORE
C ACCURATELY. THE PREIOUS SIZE REAL*4 COULD NOT
C CONTAIN SUFFICIENT SIGNIFICANT DIGITS.
C - CODING HAS BEEN INTRODUCED TO PROCESS NEW
C TABLE C DESCRIPTOR 2 06 YYY WHICH PERMITS IN
C LINE PROCESSING OF A LOCAL DESCRIPTOR EVEN IF
C THE DESCRIPTOR IS NOT CONTAINED IN THE USERS
C TABLE B.
C - A SECOND ROUTINE TO PROCESS IFOD MESSAGES
C (IFOD0) HAS BEEN REMOVED IN FAVOR OF THE
C IMPROVED PROCESSING OF THE ONE
C REMAINING (IFOD1).
C - NEW CODING HAS BEEN INTRODUCED TO PERMIT
C PROCESSING OF BUFR MESSAGES BASED ON BUFR
C EDITION UP TO AND INCLUDING EDITION 2.
C PLEASE NOTE INCREASED SIZE REQUIREMENTS
C FOR ARRAYS IDENT(20) AND IPTR(40).
C 1991-07-26 CAVANAUGH - ADD ARRAY MTIME TO CALLING SEQUENCE TO
C PERMIT INCLUSION OF RECEIPT/TRANSFER TIMES
C TO IFOD MESSAGES.
C 1991-09-25 CAVANAUGH - ALL PROCESSING OF DECODED BUFR DATA INTO
C IFOD (A LOCAL USE REFORMAT OF BUFR DATA)
C HAS BEEN ISOLATED FROM THIS SET OF ROUTINES.
C FOR THOSE INTERESTED IN THE IFOD FORM,
C SEE W3FL05 IN THE W3LIB ROUTINES.
C PROCESSING OF BUFR MESSAGES CONTAINING
C DELAYED REPLICATION HAS BEEN ALTERED SO THAT
C SINGLE SUBSETS (REPORTS) AND AND A MATCHING
C DESCRIPTOR LIST FOR THAT PARTICULAR SUBSET
C WILL BE PASSED TO THE USER WILL BE PASSED TO
C THE USER ONE AT A TIME TO ASSURE THAT EACH
C SUBSET CAN BE FULLY DEFINED WITH A MINIMUM
C OF REPROCESSING.
C PROCESSING OF ASSOCIATED FIELDS HAS BEEN
C TESTED WITH MESSAGES CONTAINING NON-COMPRESSED
C DATA.
C IN ORDER TO FACILITATE USER PROCESSING
C A MATCHING LIST OF SCALE FACTORS ARE INCLUDED
C WITH THE EXPANDED DESCRIPTOR LIST (MSTACK).
C 1991-11-21 CAVANAUGH - PROCESSING OF DESCRIPTOR 2 03 YYY
C HAS CORRECTED TO AGREE WITH FM94 STANDARDS.
C 1991-12-19 CAVANAUGH - CALLS TO FI8803 AND FI8804 HAVE BEEN
C CORRECTED TO AGREE CALLED PROGRAM ARGUMENT
C LIST. SOME ADDITIONAL ENTRIES HAVE BEEN
C INCLUDED FOR COMMUNICATING WITH DATA ACCESS
C ROUTINES. ADDITIONAL ERROR EXIT PROVIDED FOR
C THE CASE WHERE TABLE B IS DAMAGED.
C 1992-01-24 CAVANAUGH - ROUTINES FI8801, FI8803 AND FI8804
C HAVE BEEN MODIFIED TO HANDLE ASSOCIATED FIELDS
C ALL DESCRIPTORS ARE SET TO ECHO TO MSTACK(1,N)
C 1992-05-21 CAVANAUGH - FURTHER EXPANSION OF INFORMATION COLLECTED
C FROM WITHIN UPPER AIR SOUNDINGS HAS PRODUCED
C THE NECESSITY TO EXPAND SOME OF THE PROCESSING
C AND OUTPUT ARRAYS. (SEE REMARKS BELOW)
C 1992-06-29 CAVANAUGH - CORRECTED DESCRIPTOR DENOTING HEIGHT OF
C EACH WIND LEVEL FOR PROFILER CONVERSIONS.
C 1992-07-23 CAVANAUGH - EXPANSION OF TABLE B REQUIRES ADJUSTMENT
C OF ARRAYS TO CONTAIN TABLE B VALUES NEEDED TO
C ASSIST IN THE DECODING PROCESS.
C ARRAYS CONTAINING DATA FROM TABLE B
C KFXY1 - DESCRIPTOR
C ANAME1 - DESCRIPTOR NAME
C AUNIT1 - UNITS FOR DESCRIPTOR
C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR
C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR
C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR
C 1992-09-09 CAVANAUGH - FIRST ENCOUNTER WITH OPERATOR DESCRIPTOR
C 2 05 YYY SHOWED ERROR IN DECODING. THAT ERROR
C IS CORRECTED WITH THIS IMPLEMENTATION. FURTHER
C TESTING OF UPPER AIR DATA HAS ENCOUNTERED
C THE CONDITION OF LARGE (MANY LEVEL) SOUNDINGS
C ARRAYS IN THE DECODER HAVE BEEN EXPANDED (AGAIN)
C TO ALLOW FOR THIS CONDITION.
C 1992-10-02 CAVANAUGH - MODIFIED ROUTINE TO REFORMAT PROFILER DATA
C (FI8809) TO SHOW DESCRIPTORS, SCALE VALUE AND
C DATA IN PROPER ORDER. CORRECTED AN ERROR THAT
C PREVENTED USER FROM ASSIGNING THE SECOND DIMENSION
C OF KDATA(500,*).
C 1992-10-20 CAVANAUGH - REMOVED ERROR THAT PREVENTED FULL
C IMPLEMENTATION OF PREVIOUS CORRECTIONS AND
C MADE CORRECTIONS TO TABLE B TO BRING IT UP TO
C DATE. CHANGES INCLUDE PROPER REFORMAT OF PROFILER
C DATA AND USER CAPABILITY FOR ASSIGNING SECOND
C DIMENSION OF KDATA ARRAY.
C 1992-12-09 CAVANAUGH - THANKS TO DENNIS KEYSER FOR THE SUGGESTIONS
C AND CODING, THIS IMPLEMENTATION WILL ALLOW THE
C INCLUSION OF UNIT NUMBERS FOR TABLES B & D, AND
C IN ADDITION ALLOWS FOR REALISTIC SIZING OF KDATA
C AND MSTACK ARRAYS BY THE USER. AS OF THIS
C IMPLEMENTATION, THE UPPER SIZE LIMIT FOR A BUFR
C MESSAGE ALLOWS FOR A MESSAGE SIZE GREATER THAN
C 15000 BYTES.
C 1993-01-26 CAVANAUGH - ROUTINE FI8810 HAS BEEN ADDED TO PERMIT
C REFORMATTING OF PROFILER DATA IN EDITION 2.
C 1993-05-13 CAVANAUGH - ROUTINE FI8811 HAS BEEN ADDED TO PERMIT
C PROCESSING OF RUN-LINE ENCODING. THIS PROVIDES FOR
C THE HANDLING OF DATA FOR GRAPHICS PRODUCTS.
C PLEASE NOTE THE ADDITION OF TWO ARGUMENTS IN THE
C CALLING SEQUENCE.
C 1993-12-01 CAVANAUGH - ROUTINE FI8803 TO CORRECT HANDLING OF
C ASSOCIATED FIELDS AND ARRAYS ASSOCIATED WITH
C TABLE B ENTRIES ENLARGED TO HANDLE LARGER TABLE B
C 1994-05-25 CAVANAUGH - ROUTINES HAVE BEEN MODIFIED TO CONSTRUCT A
C MODIFIED TABLE B I.E., IT IS TAILORED TO CONTAIN O
C THOSE DESCRIPTORS THAT WILL BE USED TO DECODE
C DATA IN CURRENT AND SUBSEQUENT BUFR MESSAGES.
C TABLE B AND TABLE D DESCRIPTORS WILL BE ISOLATED
C AND MERGED WITH THE MAIN TABLES FOR USE WITH
C FOLLOWING BUFR MESSAGES.
C THE DESCRIPTORS INDICATING THE REPLICATION OF
C DESCRIPTORS AND DATA ARE ACTIVATED WITH THIS
C IMPLEMENTATION.
C 1994-08-30 CAVANAUGH - ADDED STATEMENTS THAT WILL ALLOW USE OF
C THESE ROUTINES DIRECTLY ON THE CRAY WITH NO
C MODIFICATION. HANDLING OD TABLE D ENTRIES HAS BEEN
C MODIFIED TO PREVENT LOSS OF ANCILLARY ENTRIES.
C CODING HAS BEEN ADDED TO ALLOW PROCESSING ON
C EITHER AN 8 BYTE WORD OR 4 BYTE WORD MACHINE.
C
C FOR THOSE USERS OF THE BUFR DECODER THAT ARE
C PROCESSING SETS OF BUFR MESSAGES THAT INCLUDE
C TYPE 11 MESSAGES, CODING HAS BEEN ADDED TO ALLOW
C THE RECOVERY OF THE ADDED OR MODIFIED TABLE B
C ENTRIES BY WRITING THEM TO A DISK FILE AVAILABLE
C TO THE USER. THIS IS ACCOMPLISHED WITH NO CHANGE
C TO THE CALLING SEQUENCE. TABLE B ENTRIES WILL BE
C DESIGNATED AS FOLLOWS:
C
C IUNITB - IS THE UNIT NUMBER FOR THE MASTER
C TABLE B.
C IUNITB+1 - WILL BE THE UNIT NUMBER FOR THE
C TABLE B ENTRIES THAT ARE TO BE USED
C IN THE DECODING OF SUBSEQUENT MESSAGES.
C THIS DEVICE WILL BE FORMATTED THE SAME
C THE DISK FILE ON IUNITB.
C
C 1995-06-07 KEYSER- CORRECTED AN ERROR WHICH REQUIRED INPUT
C ARGUMENT "MAXD" TO BE NEARLY TWICE AS LARGE AS
C NEEDED FOR DECODING WIND PROFILER REPORTS (LIMIT
C UPPER BOUND FOR "IWORK" ARRAY WAS SET TO "MAXD",
C NOW IT IS SET TO 15000). ALSO, A CORRECTION WAS
C MADE IN THE WIND PROFILER PROCESSING TO PREVENT
C UNNECESSARY LOOPING WHEN ALL REQUESTED
C DESCRIPTORS ARE MISSING. ALSO CORRECTED AN
C ERROR WHICH RESULTED IN RETURNED SCALE IN
C "MSTACK(2, ..)" ALWAYS BEING SET TO ZERO FOR
C COMPRESSED DATA.
C 1996-02-15 CAVANAUGH- MODIFIED IDENTIFICATION OF ASCII/EBCDIC
C MACHINE. MODIFIED HANDLING OF TABLE B TO PERMIT
C FASTER PROCESSING OF MULTIPLE MESSAGES WITH
C CHANGING DATA TYPES AND/OR SUBTYPES.
C 1996-04-02 CAVANAUGH- DEACTIVATED EXTRANEOUS WRITE STATEMENT.
C ENLARGED ARRAYS FOR TABLE B ENTRIES TO CONTAIN
C UP TO 1300 ENTRIES IN PREPARATION FOR NEW
C ADDITIONS TO TABLE B.
C 2001-02-01 KEYSER- THE TABLE B FILE WILL NOW BE READ WHENEVER THE
C INPUT ARGUMENT "IUNITB" (TABLE B UNIT NUMBER)
C CHANGES FROM ITS VALUE IN THE PREVIOUS CALL TO
C THIS ROUTINE (NORMALLY IT IS ONLY READ THE
C FIRST TIME THIS ROUTINE IS CALLED)
C 2002-10-15 VUONG REPLACED FUNCTION ICHAR WITH MOVA2I
C
C
C USAGE: CALL W3FI88(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX,
C LDATA,LSTACK,MAXR,MAXD,IUNITB,IUNITD)
C
C INPUT ARGUMENT LIST:
C MSGA - ARRAY CONTAINING SUPPOSED BUFR MESSAGE
C SIZE IS DETERMINED BY USER, CAN BE GREATER
C THAN 15000 BYTES.
C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE
C CONTAINED IN A BUFR MESSAGE
C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT
C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE
C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST
C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE
C IUNITB - UNIT NUMBER OF DATA SET HOLDING TABLE B, THIS IS THE
C NUMBER OF A PAIR OF DATA SETS
C IUNITB+1 - UNIT NUMBER FOR A DATASET TO CONTAIN TABLE B ENTRIES
C FROM MASTER TABLE B AND TABLE B ENTRIES EXTRACTED
C FROM TYPE 11 BUFR MESSAGES THAT WERE USED TO DECODE
C CURRENT BUFR MESSAGES.
C IUNITD - UNIT NUMBER OF DATA SET HOLDING TABLE D
C
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C ISTACK - ORIGINAL ARRAY OF DESCRIPTORS EXTRACTED FROM
C SOURCE BUFR MESSAGE.
C
C MSTACK(A,B)-LEVEL B - DESCRIPTOR NUMBER (LIMITED TO VALUE OF
C INPUT ARGUMENT MAXD)
C
C LEVEL A = 1 DESCRIPTOR
C = 2 10**N SCALING TO RETURN TO ORIGINAL VALUE
C IPTR - UTILITY ARRAY (SHOULD HAVE AT LAST 42 ENTRIES)
C IPTR( 1)- ERROR RETURN
C IPTR( 2)- BYTE COUNT SECTION 1
C IPTR( 3)- POINTER TO START OF SECTION 1
C IPTR( 4)- BYTE COUNT SECTION 2
C IPTR( 5)- POINTER TO START OF SECTION 2
C IPTR( 6)- BYTE COUNT SECTION 3
C IPTR( 7)- POINTER TO START OF SECTION 3
C IPTR( 8)- BYTE COUNT SECTION 4
C IPTR( 9)- POINTER TO START OF SECTION 4
C IPTR(10)- START OF REQUESTED SUBSET, RESERVED FOR DAR
C IPTR(11)- CURRENT DESCRIPTOR PTR IN IWORK
C IPTR(12)- LAST DESCRIPTOR POS IN IWORK
C IPTR(13)- LAST DESCRIPTOR POS IN ISTACK
C IPTR(14)- NUMBER OF MASTER TABLE B ENTRIES
C IPTR(15)- REQUESTED SUBSET POINTER, RESERVED FOR DAR
C IPTR(16)- INDICATOR FOR EXISTANCE OF SECTION 2
C IPTR(17)- NUMBER OF REPORTS PROCESSED
C IPTR(18)- ASCII/TEXT EVENT
C IPTR(19)- POINTER TO START OF BUFR MESSAGE
C IPTR(20)- NUMBER OF ENTRIES FROM TABLE D
C IPTR(21)- NR TABLE B ENTRIES
C IPTR(22)- NR TABLE B ENTRIES FROM CURRENT MESSAGE
C IPTR(23)- CODE/FLAG TABLE SWITCH
C IPTR(24)- ADITIONAL WORDS ADDED BY TEXT INFO
C IPTR(25)- CURRENT BIT NUMBER
C IPTR(26)- DATA WIDTH CHANGE - ADD TO TABLE B WIDTH
C IPTR(27)- DATA SCALE CHANGE - MODIFIES TABLE B SCALE
C IPTR(28)- DATA REFERENCE VALUE CHANGE - ?????????
C IPTR(29)- ADD DATA ASSOCIATED FIELD
C IPTR(30)- SIGNIFY CHARACTERS
C IPTR(31)- NUMBER OF EXPANDED DESCRIPTORS IN MSTACK
C IPTR(32)- CURRENT DESCRIPTOR SEGMENT F
C IPTR(33)- CURRENT DESCRIPTOR SEGMENT X
C IPTR(34)- CURRENT DESCRIPTOR SEGMENT Y
C IPTR(35)- DATA/DESCRIPTOR REPLICATION IN PROGRESS
C 0 = NO
C 1 = YES
C IPTR(36)- NEXT DESCRIPTOR MAY BE UNDECIPHERABLE
C IPTR(37)- MACHINE TEXT TYPE FLAG
C 0 = EBCIDIC
C 1 = ASCII
C IPTR(38)- DATA/DESCRIPTOR REPLICATION FLAG
C 0 - DOES NOT EXIST IN CURRENT MESSAGE
C 1 - EXISTS IN CURRENT MESSAGE
C IPTR(39)- DELAYED REPLICATION FLAG
C 0 - NO DELAYED REPLICATION
C 1 - MESSAGE CONTAINS DELAYED REPLICATION
C IPTR(40)- NUMBER OF CHARACTERS IN TEXT FOR CURR DESCRIPTOR
C IPTR(41)- NUMBER OF ANCILLARY TABLE B ENTRIES
C IPTR(42)- NUMBER OF ANCILLARY TABLE D ENTRIES
C IPTR(43)- NUMBER OF ADDED TABLE B ENTRIES ENCOUNTERED WHILE
C PROCESSING A BUFR MESSAGE. THESE ENTRIES ONLY
C EXIST DURNG PROCESSING OF CURRENT BUFR MESSAGE
C IPTR(44)- BITS PER WORD
C IPTR(45)- BYTES PER WORD
C IDENT - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM
C BUFR MESSAGE -
C IDENT(1) -EDITION NUMBER (BYTE 4, SECTION 1)
C IDENT(2) -ORIGINATING CENTER (BYTES 5-6, SECTION 1)
C IDENT(3) -UPDATE SEQUENCE (BYTE 7, SECTION 1)
C IDENT(4) -OPTIONAL SECTION (BYTE 8, SECTION 1)
C IDENT(5) -BUFR MESSAGE TYPE (BYTE 9, SECTION 1)
C 0 = SURFACE DATA (LAND)
C 1 = SURFACE DATA (SHIP)
C 2 = VERTICAL SOUNDINGS (OTHER THAN SATELLITE)
C 3 = VERTICAL SOUNDINGS (SATELLITE)
C 4 = SINGLE LVL UPPER-AIR DATA(OTHER THAN SATELLITE)
C 5 = SINGLE LEVEL UPPER-AIR DATA (SATELLITE)
C 6 = RADAR DATA
C 7 = SYNOPTIC FEATURES
C 8 = PHYSICAL/CHEMICAL CONSTITUENTS
C 9 = DISPERSAL AND TRANSPORT
C 10 = RADIOLOGICAL DATA
C 11 = BUFR TABLES (COMPLETE, REPLACEMENT OR UPDATE)
C 12 = SURFACE DATA (SATELLITE)
C 21 = RADIANCES (SATELLITE MEASURED)
C 31 = OCEANOGRAPHIC DATA
C IDENT(6) -BUFR MSG SUB-TYPE (BYTE 10, SECTION 1)
C TYPE SBTYP
C 2 7 = PROFILER
C IDENT(7) - (BYTES 11-12, SECTION 1)
C IDENT(8) -YEAR OF CENTURY (BYTE 13, SECTION 1)
C IDENT(9) -MONTH OF YEAR (BYTE 14, SECTION 1)
C IDENT(10)-DAY OF MONTH (BYTE 15, SECTION 1)
C IDENT(11)-HOUR OF DAY (BYTE 16, SECTION 1)
C IDENT(12)-MINUTE OF HOUR (BYTE 17, SECTION 1)
C IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1)
C IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3)
C IDENT(15)-OBSERVED FLAG (BYTE 7, BIT 1, SECTION 3)
C IDENT(16)-COMPRESSION FLAG (BYTE 7, BIT 2, SECTION 3)
C IDENT(17)-MASTER TABLE NUMBER(BYTE 4, SECTION 1, ED 2 OR GTR)
C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
C KDATA(REPORT NUMBER,PARAMETER NUMBER)
C
C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
C ARGUMENT MAXD)
C INDEX - POINTER TO AVAILABLE SUBSET
C
C ===========================================================
C ARRAYS CONTAINING DATA FROM TABLE B
C NEW - BASE ARRAYS CONTAINING DATA FROM TABLE B
C KFXY1 - DECIMAL DESCRIPTOR VALUE OF F X Y VALUES
C ANAME1 - DESCRIPTOR NAME
C AUNIT1 - UNITS FOR DESCRIPTOR
C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR
C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR
C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR
C ===========================================================
C NEW - ANCILLARY ARRAYS CONTAINING DATA FROM TABLE B
C CONTAINING TABLE B ENTRIES EXTRACTED
C FROM TYPE 11 BUFR MESSAGES
C KFXY2 - DECIMAL DESCRIPTOR VALUE OF F X Y VALUES
C ANAME2 - DESCRIPTOR NAME
C AUNIT2 - UNITS FOR DESCRIPTOR
C ISCAL2 - SCALE FOR VALUE OF DESCRIPTOR
C IRFVL2 - REFERENCE VALUE FOR DESCRIPTOR
C IWIDE2 - BIT WIDTH FOR VALUE OF DESCRIPTOR
C ===========================================================
C NEW - ADDED ARRAYS CONTAINING DATA FROM TABLE B
C CONTAINING TABLE B ENTRIES EXTRACTED
C FROM NON-TYPE 11 BUFR MESSAGES
C THESE EXIST FOR THE LIFE OF CURRENT BUFR MESSAGE
C KFXY3 - DECIMAL DESCRIPTOR VALUE OF F X Y VALUES
C ANAME3 - DESCRIPTOR NAME
C AUNIT3 - UNITS FOR DESCRIPTOR
C ISCAL3 - SCALE FOR VALUE OF DESCRIPTOR
C IRFVL3 - REFERENCE VALUE FOR DESCRIPTOR
C IWIDE3 - BIT WIDTH FOR VALUE OF DESCRIPTOR
C ===========================================================
C
C SUBPROGRAMS CALLED:
C LIBRARY:
C UNIQUE - FI8801 FI8802 FI8803 FI8804 FI8805 FI8806
C FI8807 FI8808 FI8809 FI8810 FI8811 FI8812
C FI8813 FI8814 FI8815 FI8820
C W3LIB - W3AI39 W3FC05 GBYTE GBYTES
C
C REMARKS: ERROR RETURNS:
C IPTR(1) = 1 'BUFR' NOT FOUND IN FIRST 125 CHARACTERS
C = 2 '7777' NOT FOUND IN LOCATION DETERMINED BY
C BY USING COUNTS FOUND IN EACH SECTION. ONE OR
C MORE SECTIONS HAVE AN ERRONEOUS BYTE COUNT OR
C CHARACTERS '7777' ARE NOT IN TEST MESSAGE.
C = 3 MESSAGE CONTAINS A DESCRIPTOR WITH F=0 THAT DOES
C NOT EXIST IN TABLE B.
C = 4 MESSAGE CONTAINS A DESCRIPTOR WITH F=3 THAT DOES
C NOT EXIST IN TABLE D.
C = 5 MESSAGE CONTAINS A DESCRIPTOR WITH F=2 WITH THE
C VALUE OF X OUTSIDE THE RANGE 1-6.
C = 6 DESCRIPTOR ELEMENT INDICATED TO HAVE A FLAG VALUE
C DOES NOT HAVE AN ENTRY IN THE FLAG TABLE.
C (TO BE ACTIVATED)
C = 7 DESCRIPTOR INDICATED TO HAVE A CODE VALUE DOES
C NOT HAVE AN ENTRY IN THE CODE TABLE.
C (TO BE ACTIVATED)
C = 8 ERROR READING TABLE D
C = 9 ERROR READING TABLE B
C = 10 ERROR READING CODE/FLAG TABLE
C = 11 DESCRIPTOR 2 04 004 NOT FOLLOWED BY 0 31 021
C = 12 DATA DESCRIPTOR OPERATOR QUALIFIER DOES NOT FOLLOW
C DELAYED REPLICATION DESCRIPTOR.
C = 13 BIT WIDTH ON ASCII CHARACTERS NOT A MULTIPLE OF 8
C = 14 SUBSETS = 0, NO CONTENT BULLETIN
C = 20 EXCEEDED COUNT FOR DELAYED REPLICATION PASS
C = 21 EXCEEDED COUNT FOR NON-DELAYED REPLICATION PASS
C = 22 EXCEEDED COMBINED BIT WIDTH, BIT WIDTH > 32
C = 23 NO ELEMENT DESCRIPTORS FOLLOWING 2 03 YYY
C = 27 NON ZERO LOWEST ON TEXT DATA
C = 28 NBINC NOT NR OF CHARACTERS
C = 29 TABLE B APPEARS TO BE DAMAGED
C = 30 TABLE D ENTRY WITH MORE THAN 18 IN SEQUENCE
C BEING ENTERED FROM TYPE 11 MESSAGE
C = 99 NO MORE SUBSETS (REPORTS) AVAILABLE IN CURRENT
C BUFR MESAGE
C
C = 400 NUMBER OF SUBSETS EXCEEDS THE VALUE OF INPUT
C ARGUMENT MAXR; MUST INCREASE MAXR TO VALUE OF
C IDENT(14) IN CALLING PROGRAM
C
C = 401 NUMBER OF PARAMETERS (AND ASSOCIATED FIELDS)
C EXCEEDS LIMITS OF THIS PROGRAM.
C = 500 VALUE FOR NBINC HAS BEEN FOUND THAT EXCEEDS
C STANDARD WIDTH PLUS ANY BIT WIDTH CHANGE.
C CHECK ALL BIT WIDTHS UP TO POINT OF ERROR.
C = 501 CORRECTED WIDTH FOR DESCRIPTOR IS 0 OR LESS
C = 888 NON-NUMERIC CHARACTER IN CONVERSION REQUEST
C = 890 CLASS 0 ELEMENT DESCRIPTOR W/WIDTH OF 0
C
C ON THE INITIAL CALL TO W3FI88 WITH A BUFR MESSAGE THE ARGUMENT
C INDEX MUST BE SET TO ZERO (INDEX = 0). ON THE RETURN FROM W3FI88
C 'INDEX' WILL BE SET TO THE NEXT AVAILABLE SUBSET/REPORT. WHEN
C THERE ARE NO MORE SUBSETS AVAILABLE A 99 ERR RETURN WILL OCCUR.
C
C IF THE ORIGINAL BUFR MESSAGE DOES NOT CONTAIN DELAYED REPLICATION
C THE BUFR MESSAGE WILL BE COMPLETELY DECODED AND 'INDEX' WILL POINT
C TO THE FIRST DECODED SUBSET. THE USERS WILL THEN HAVE THE OPTION
C OF INDEXING THROUGH THE SUBSETS ON THEIR OWN OR BY RECALLING THIS
C ROUTINE (WITHOUT RESETTING 'INDEX') TO HAVE THE ROUTINE DO THE
C INDEXING.
C
C IF THE ORIGINAL BUFR MESSAGE DOES CONTAIN DELAYED REPLICATION
C ONE SUBSET/REPORT WILL BE DECODED AT A TIME AND PASSED BACK TO
C THE USER. THIS IS NOT AN OPTION.
C
C =============================================
C TO USE THIS ROUTINE
C =============================================
C THE ARRAYS TO CONTAIN THE OUTPUT INFORMATION ARE DEFINED
C AS FOLLOWS:
C
C KDATA(A,B) IS THE A DATA ENTRY (INTEGER VALUE)
C WHERE A IS THE MAXIMUM NUMBER OF REPORTS/SUBSETS
C THAT MAY BE CONTAINED IN THE BUFR MESSAGE (THIS
C IS NOW SET TO "MAXR" WHICH IS PASSED AS AN INPUT
C ARGUMENT TO W3FI88), AND WHERE B IS THE MAXIMUM
C NUMBER OF DESCRIPTOR COMBINATIONS THAT MAY
C BE PROCESSED (THIS IS NOW SET TO "MAXD" WHICH
C IS ALSO PASSED AS AN INPUT ARGUMENT TO W3FI88;
C UPPER AIR DATA AND SOME SATELLITE DATA REQUIRE
C A VALUE FOR MAXD OF 1700, BUT FOR MOST OTHER
C DATA A VALUE FOR MAXD OF 500 WILL SUFFICE)
C MSTACK(1,B) CONTAINS THE DESCRIPTOR THAT MATCHES THE
C DATA ENTRY (MAX. VALUE FOR B IS NOW "MAXD"
C WHICH IS PASSED AS AN INPUT ARGUMENT TO W3FI88)
C MSTACK(2,B) IS THE SCALE (POWER OF 10) TO BE APPLIED TO
C THE DATA (MAX. VALUE FOR B IS NOW "MAXD"
C WHICH IS PASSED AS AN INPUT ARGUMENT TO W3FI88)
C
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: NAS
C
C$$$
C
C
C THE MEMORY REQUIREMENTS FOR LSTACK AND LDATA ARE USED WITH
C RUN-LINE CODING PROVIDING FOR THE HANDLING OF DATA FOR
C GRAPHICS. I.E., RADAR DISPLAYS. IF THE DECODING PROCESS WILL
C NOT BE USED TO PROCESS THOSE TYPE OF MESSAGES, THEN THE
C VARIABLE SIZES FOR THE ARRAYS CAN BE MINIMIZED.
C IF THE DECODING PROCESS WILL BE USED TO DECODE THOSE MESSAGE
C TYPES, THEN MAXD MUST REFLECT THE MAXIMUM NUMBER OF
C DESCRIPTORS (FULLY EXPANDED LIST) TO BE EXPECTED IN THE
C MESSAGE.
C
INTEGER LDATA(MAXD)
INTEGER LSTACK(2,MAXD)
C
INTEGER MSGA(*)
INTEGER IPTR(*),KPTRB(16384),KPTRD(16384)
INTEGER KDATA(MAXR,MAXD)
INTEGER MSTACK(2,MAXD)
C
INTEGER IVALS(1000)
INTEGER KNR(MAXR)
INTEGER IDENT(*)
INTEGER ISTACK(*),IOLD11
cdak KEYSER fix 02/02/2001 VVVVV
INTEGER IOLDTB
cdak KEYSER fix 02/02/2001 AAAAA
INTEGER IWORK(15000)
INTEGER INDEX
C
INTEGER IIII
CHARACTER*1 BLANK
CHARACTER*4 DIRID(2)
C
LOGICAL SEC2
C ..................................................
C
C NEW BASE TABLE B
C MAY BE A COMBINATION OF MASTER TABLE B
C AND ANCILLARY TABLE B
C
INTEGER KFXY1(1300),ISCAL1(1300)
INTEGER IRFVL1(3,1300),IWIDE1(1300)
CHARACTER*40 ANAME1(1300)
CHARACTER*24 AUNIT1(1300)
C ..................................................
C
C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE
C
INTEGER KFXY2(200),ISCAL2(200),IRFVL2(200),IWIDE2(200)
CHARACTER*64 ANAME2(200)
CHARACTER*24 AUNIT2(200)
C ..................................................
C
C NEW ADDED TABLE B FROM NON-TYPE 11 BUFR MESSAGE
C
C INTEGER KFXY3(200),ISCAL3(200),IRFVL3(200),IWIDE3(200)
C CHARACTER*64 ANAME3(200)
C CHARACTER*24 AUNIT3(200)
C ..................................................
C
C NEW BASE TABLE D
C
INTEGER ITBLD(20,400)
C ..................................................
C
C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
C
INTEGER ITBLD2(20,50)
C ..................................................
C
SAVE
cdak KEYSER fix 02/02/2001 VVVVV
DATA IOLD11/0/
DATA IOLDTB/-99/
cdak KEYSER fix 02/02/2001 AAAAA
C
CALL W3FI01(LW)
IPTR(45) = LW
IPTR(44) = LW * 8
C
BLANK = ' '
IF (MOVA2I(BLANK).EQ.32) THEN
IPTR(37) = 1
C PRINT *,'ASCII MACHINE'
ELSE
IPTR(37) = 0
C PRINT *,'EBCDIC MACHINE'
END IF
C
C PRINT *,' W3FI88 DECODER'
C INITIALIZE ERROR RETURN
IPTR(1) = 0
IF (INDEX.GT.0) THEN
C HAVE RE-ENTRY
INDEX = INDEX + 1
C PRINT *,'RE-ENTRY LOOKING FOR SUBSET NR',INDEX
IF (INDEX.GT.IDENT(14)) THEN
C ALL SUBSETS PROCESSED
IPTR(1) = 99
IPTR(38) = 0
IPTR(39) = 0
ELSE IF (INDEX.LE.IDENT(14)) THEN
IF (IPTR(39).NE.0) THEN
DO 3000 J =1, IPTR(13)
IWORK(J) = ISTACK(J)
3000 CONTINUE
IPTR(12) = IPTR(13)
CALL FI8801(IPTR,IDENT,MSGA,ISTACK,IWORK,KDATA,IVALS,
* MSTACK,KNR,INDEX,MAXR,MAXD,
* KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,IRF1SW,INEWVL,
* KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,
* KFXY3,ANAME3,AUNIT3,ISCAL3,IRFVL3,IWIDE3,
* IUNITB,IUNITD,ITBLD,ITBLD2,KPTRB,KPTRD)
C
END IF
END IF
RETURN
ELSE
INDEX = 1
C PRINT *,'INITIAL ENTRY FOR THIS BUFR MESSAGE'
END IF
IPTR(39) = 0
C FIND 'BUFR' IN FIRST 125 CHARACTERS
DO 1000 KNOFST = 0, 999, 8
INOFST = KNOFST
CALL GBYTE (MSGA,IVALS,INOFST,8)
IF (IVALS(1).EQ.66) THEN
IPTR(19) = INOFST
INOFST = INOFST + 8
CALL GBYTE (MSGA,IVALS,INOFST,24)
IF (IVALS(1).EQ.5588562) THEN
C PRINT *,'FOUND BUFR AT',IPTR(19)
INOFST = INOFST + 24
GO TO 1500
END IF
END IF
1000 CONTINUE
PRINT *,'BUFR - START OF BUFR MESSAGE NOT FOUND'
IPTR(1) = 1
RETURN
1500 CONTINUE
IDENT(1) = 0
C TEST FOR EDITION NUMBER
C ======================
CALL GBYTE (MSGA,IDENT(1),INOFST+24,8)
C PRINT *,'THIS IS AN EDITION',IDENT(1),' BUFR MESSAGE'
C
IF (IDENT(1).GE.2) THEN
C GET TOTAL COUNT
CALL GBYTE (MSGA,IVALS,INOFST,24)
ITOTAL = IVALS(1)
KENDER = ITOTAL * 8 - 32 + IPTR(19)
CALL GBYTE (MSGA,ILAST,KENDER,32)
C IF (ILAST.EQ.926365495) THEN
C PRINT *,'HAVE TOTAL COUNT FROM SEC 0',IVALS(1)
C END IF
INOFST = INOFST + 32
C GET SECTION 1 COUNT
IPTR(3) = INOFST
CALL GBYTE (MSGA,IVALS,INOFST,24)
C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1)
INOFST = INOFST + 24
IPTR( 2) = IVALS(1)
C GET MASTER TABLE
CALL GBYTE (MSGA,IVALS,INOFST,8)
INOFST = INOFST + 8
IDENT(17) = IVALS(1)
C PRINT *,'BUFR MASTER TABLE NR',IDENT(17)
ELSE
IPTR(3) = INOFST
C GET SECTION 1 COUNT
CALL GBYTE (MSGA,IVALS,INOFST,24)
C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1)
INOFST = INOFST + 32
IPTR( 2) = IVALS(1)
END IF
C ======================
C ORIGINATING CENTER
CALL GBYTE (MSGA,IVALS,INOFST,16)
INOFST = INOFST + 16
IDENT(2) = IVALS(1)
C UPDATE SEQUENCE
CALL GBYTE (MSGA,IVALS,INOFST,8)
INOFST = INOFST + 8
IDENT(3) = IVALS(1)
C OPTIONAL SECTION FLAG
CALL GBYTE (MSGA,IVALS,INOFST,1)
IDENT(4) = IVALS(1)
IF (IDENT(4).GT.0) THEN
SEC2 = .TRUE.
ELSE
C PRINT *,' NO OPTIONAL SECTION 2'
SEC2 = .FALSE.
END IF
INOFST = INOFST + 8
C MESSAGE TYPE
CALL GBYTE (MSGA,IVALS,INOFST,8)
IDENT(5) = IVALS(1)
INOFST = INOFST + 8
C MESSAGE SUBTYPE
CALL GBYTE (MSGA,IVALS,INOFST,8)
IDENT(6) = IVALS(1)
INOFST = INOFST + 8
cdak KEYSER fix 02/02/2001 VVVVV
IF (IUNITB.NE.IOLDTB) THEN
C IF HAVE A CHANGE IN TABLE B UNIT NUMBER , READ TABLE B
IF(IOLDTB.NE.-99) PRINT *, 'W3FI88 - NEW TABLE B UNIT NUMBER'
IOLDTB = IUNITB
IPTR(14) = 0
IPTR(21) = 0
END IF
cdak KEYSER fix 02/02/2001 AAAAA
C IF HAVE CHANGE IN DATA TYPE , RESET TABLE B
IF (IOLD11.EQ.11) THEN
IOLD11 = IDENT(5)
IOLDSB = IDENT(6)
C JUST CONTINUE PROCESSING
ELSE IF (IOLD11.NE.11) THEN
IF (IDENT(5).EQ.11) THEN
IOLD11 = IDENT(5)
IPTR(21) = 0
ELSE IF (IDENT(5).NE.IOLD11) THEN
IOLD11 = IDENT(5)
IPTR(21) = 0
ELSE IF (IDENT(5).EQ.IOLD11) THEN
C IF HAVE A CHANGE IN SUBTYPE, RESET TABLE B
IF (IOLDSB.NE.IDENT(6)) THEN
IOLDSB = IDENT(6)
IPTR(21) = 0
C ELSE IF
END IF
END IF
END IF
C IF BUFR EDITION 0 OR 1 THEN
C NEXT 2 BYTES ARE BUFR TABLE VERSION
C ELSE
C BYTE 11 IS VER NR OF MASTER TABLE
C BYTE 12 IS VER NR OF LOCAL TABLE
IF (IDENT(1).LT.2) THEN
CALL GBYTE (MSGA,IVALS,INOFST,16)
IDENT(7) = IVALS(1)
INOFST = INOFST + 16
ELSE
C BYTE 11 IS VER NR OF MASTER TABLE
CALL GBYTE (MSGA,IVALS,INOFST,8)
IDENT(18) = IVALS(1)
INOFST = INOFST + 8
C BYTE 12 IS VER NR OF LOCAL TABLE
CALL GBYTE (MSGA,IVALS,INOFST,8)
IDENT(19) = IVALS(1)
INOFST = INOFST + 8
END IF
C YEAR OF CENTURY
CALL GBYTE (MSGA,IVALS,INOFST,8)
IDENT(8) = IVALS(1)
INOFST = INOFST + 8
C MONTH
CALL GBYTE (MSGA,IVALS,INOFST,8)
IDENT(9) = IVALS(1)
INOFST = INOFST + 8
C DAY
C PRINT *,'DAY AT ',INOFST
CALL GBYTE (MSGA,IVALS,INOFST,8)
IDENT(10) = IVALS(1)
INOFST = INOFST + 8
C HOUR
CALL GBYTE (MSGA,IVALS,INOFST,8)
IDENT(11) = IVALS(1)
INOFST = INOFST + 8
C MINUTE
CALL GBYTE (MSGA,IVALS,INOFST,8)
IDENT(12) = IVALS(1)
C RESET POINTER (INOFST) TO START OF
C NEXT SECTION
C (SECTION 2 OR SECTION 3)
INOFST = IPTR(3) + IPTR(2) * 8
IPTR(4) = 0
IPTR(5) = INOFST
IF (SEC2) THEN
C SECTION 2 COUNT
CALL GBYTE (MSGA,IPTR(4),INOFST,24)
INOFST = INOFST + 32
C PRINT *,'SECTION 2 STARTS AT',INOFST,' BYTES=',IPTR(4)
KENTRY = (IPTR(4) - 4) / 14
C PRINT *,'SHOULD BE A MAX OF',KENTRY,' REPORTS'
IF (IDENT(2).EQ.7) THEN
DO 2000 I = 1, KENTRY
CALL GBYTE (MSGA,KDSPL ,INOFST,16)
INOFST = INOFST + 16
CALL GBYTE (MSGA,LAT ,INOFST,16)
INOFST = INOFST + 16
CALL GBYTE (MSGA,LON ,INOFST,16)
INOFST = INOFST + 16
CALL GBYTE (MSGA,KDAHR ,INOFST,16)
INOFST = INOFST + 16
CALL GBYTE (MSGA,DIRID(1),INOFST,32)
INOFST = INOFST + 32
CALL GBYTE (MSGA,DIRID(2),INOFST,16)
INOFST = INOFST + 16
C PRINT *,KDSPL,LAT,LON,KDAHR,DIRID(1),DIRID(2)
2000 CONTINUE
END IF
C RESET POINTER (INOFST) TO START OF
C SECTION 3
INOFST = IPTR(5) + IPTR(4) * 8
END IF
C BIT OFFSET TO START OF SECTION 3
IPTR( 7) = INOFST
C SECTION 3 COUNT
CALL GBYTE (MSGA,IPTR(6),INOFST,24)
C PRINT *,'SECTION 3 STARTS AT',INOFST,' BYTES=',IPTR(6)
INOFST = INOFST + 24
C SKIP RESERVED BYTE
INOFST = INOFST + 8
C NUMBER OF DATA SUBSETS
CALL GBYTE (MSGA,IDENT(14),INOFST,16)
C
IF (IDENT(14).GT.MAXR) THEN
PRINT *,'THE NUMBER OF SUBSETS EXCEEDS THE MAXIMUM OF',MAXR
PRINT *,'PASSED INTO W3FI88; MAXR MUST BE INCREASED IN '
PRINT *,'THE CALLING PROGRAM TO AT LEAST THE VALUE OF'
PRINT *,IDENT(14),'TO BE ABLE TO PROCESS THIS DATA'
C
IPTR(1) = 400
RETURN
END IF
INOFST = INOFST + 16
C OBSERVED DATA FLAG
CALL GBYTE (MSGA,IVALS,INOFST,1)
IDENT(15) = IVALS(1)
INOFST = INOFST + 1
C COMPRESSED DATA FLAG
CALL GBYTE (MSGA,IVALS,INOFST,1)
IDENT(16) = IVALS(1)
INOFST = INOFST + 7
C CALCULATE NUMBER OF DESCRIPTORS
NRDESC = (IPTR( 6) - 8) / 2
IPTR(12) = NRDESC
IPTR(13) = NRDESC
C EXTRACT DESCRIPTORS
CALL GBYTES (MSGA,ISTACK,INOFST,16,0,NRDESC)
C PRINT *,'INITIAL DESCRIPTOR LIST OF',NRDESC,' DESCRIPTORS'
DO 10 L = 1, NRDESC
IWORK(L) = ISTACK(L)
C PRINT *,L,ISTACK(L)
10 CONTINUE
IPTR(13) = NRDESC
C ===============================================================
C
C CONSTRUCT A TABLE B TO MATCH THE
C LIST OF DESCRIPTORS FOR THIS MESSAGE
C
IF (IPTR(21).EQ.0) THEN
PRINT *,'W3FI88- TABLE B NOT YET ENTERED'
CALL FI8812(IPTR,IUNITB,IUNITD,ISTACK,NRDESC,KPTRB,KPTRD,
* IRF1SW,NEWREF,ITBLD,ITBLD2,
* KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
* KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2)
ELSE
C PRINT *,'W3FI88- TABLE B ALL READY IN PLACE'
IF (IPTR(41).NE.0) THEN
C PRINT *,'MERGE',IPTR(41),' ENTRIES INTO TABLE B'
C CALL FI8818(IPTR,KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
C * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,KPTRB)
END IF
END IF
IF (IPTR(1).NE.0) RETURN
C ================================================================
C RESET POINTER TO START OF SECTION 4
INOFST = IPTR(7) + IPTR(6) * 8
C BIT OFFSET TO START OF SECTION 4
IPTR( 9) = INOFST
C SECTION 4 COUNT
CALL GBYTE (MSGA,IVALS,INOFST,24)
C PRINT *,'SECTION 4 STARTS AT',INOFST,' VALUE',IVALS(1)
IPTR( 8) = IVALS(1)
INOFST = INOFST + 32
C SET FOR STARTING BIT OF DATA
IPTR(25) = INOFST
C FIND OUT IF '7777' TERMINATOR IS THERE
INOFST = IPTR(9) + IPTR(8) * 8
CALL GBYTE (MSGA,IVALS,INOFST,32)
C PRINT *,'SECTION 5 STARTS AT',INOFST,' VALUE',IVALS(1)
IF (IVALS(1).NE.926365495) THEN
PRINT *,'BAD SECTION COUNT'
IPTR(1) = 2
RETURN
ELSE
IPTR(1) = 0
END IF
C
CALL FI8801(IPTR,IDENT,MSGA,ISTACK,IWORK,KDATA,IVALS,
* MSTACK,KNR,INDEX,MAXR,MAXD,
* KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,IRF1SW,INEWVL,
* KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,
* KFXY3,ANAME3,AUNIT3,ISCAL3,IRFVL3,IWIDE3,
* IUNITB,IUNITD,ITBLD,ITBLD2,KPTRB,KPTRD)
C
C PRINT *,'HAVE RETURNED FROM FI8801'
IF (IPTR(1).NE.0) THEN
RETURN
END IF
C FURTHER PROCESSING REQUIRED FOR PROFILER DATA
IF (IDENT(5).EQ.2) THEN
IF (IDENT(6).EQ.7) THEN
C PRINT *,'REFORMAT PROFILER DATA'
C
C DO 7151 I = 1, 40
C IF (I.LE.20) THEN
C PRINT *,'IPTR(',I,')=',IPTR(I),
C * ' IDENT(',I,')= ',IDENT(I)
C ELSE
C PRINT *,'IPTR(',I,')=',IPTR(I)
C END IF
C7151 CONTINUE
C DO 152 I = 1, IPTR(31)
C PRINT *,MSTACK(1,I),MSTACK(2,I),(KDATA(J,I),J=1,5)
C 152 CONTINUE
IF (IDENT(1).LT.2) THEN
CALL FI8809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
ELSE
CALL FI8810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
END IF
C DO 151 I = 1, 40
C IF (I.LE.20) THEN
C PRINT *,'IPTR(',I,')=',IPTR(I),
C * ' IDENT(',I,')= ',IDENT(I)
C ELSE
C PRINT *,'IPTR(',I,')=',IPTR(I)
C END IF
C 151 CONTINUE
IF (IPTR(1).NE.0) THEN
RETURN
END IF
C
C DO 154 I = 1, IPTR(31)
C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I)
C 154 CONTINUE
END IF
END IF
C IF DATA/DESCRIPTOR REPLICATION FLAG IS ON,
C MUST COMPLETE EXPANSION OF DATA AND
C DESCRIPTORS.
IF (IPTR(38).EQ.1) THEN
CALL FI8811(IPTR,IDENT,MSTACK,KDATA,KNR,
* LDATA,LSTACK,MAXD,MAXR)
END IF
C
C IF HAVE A LIST OF TABLE ENTRIES FROM
C A BUFR MESSAGE TYPE 11
C PRINT OUT THE ENTRIES
C
IF (IDENT(5).EQ.11) THEN
C DO 100 I = 1, IPTR(31)+IPTR(24)
C PRINT *,I,MSTACK(1,I),(KDATA(J,I),J=1,4)
C 100 CONTINUE
CALL FI8813 (IPTR,MAXR,MAXD,MSTACK,KDATA,IDENT,KPTRD,KPTRB,
* ITBLD,ANAME1,AUNIT1,KFXY1,ISCAL1,IRFVL1,IWIDE1,IUNITB)
END IF
RETURN
END
SUBROUTINE FI8801(IPTR,IDENT,MSGA,ISTACK,IWORK,KDATA,IVALS,
* MSTACK,KNR,INDEX,MAXR,MAXD,
* KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,IRF1SW,INEWVL,
* KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,
* KFXY3,ANAME3,AUNIT3,ISCAL3,IRFVL3,IWIDE3,
* IUNITB,IUNITD,ITBLD,ITBLD2,KPTRB,KPTRD)
C
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8801 DATA EXTRACTION
C PRGMMR: KEYSER ORG: NP22 DATE: 1995-06-07
C
C ABSTRACT: CONTROL THE EXTRACTION OF DATA FROM SECTION 4 BASED ON
C DATA DESCRIPTORS.
C
C PROGRAM HISTORY LOG:
C 1988-09-01 CAVANAUGH
C 1991-01-18 CAVANAUGH CORRECTIONS TO PROPERLY HANDLE NON-COMPRESSED
C DATA.
C 1991-09-23 CAVANAUGH CODING ADDED TO HANDLE SINGLE SUBSETS WITH
C DELAYED REPLICATION.
C 1992-01-24 CAVANAUGH MODIFIED TO ECHO DESCRIPTORS TO MSTACK(1,N)
C 1995-06-07 KEYSER CORRECTED AN ERROR WHICH REQUIRED INPUT
C ARGUMENT "MAXD" TO BE NEARLY TWICE AS LARGE
C AS NEEDED FOR DECODING WIND PROFILER REPORTS
C (LIMIT UPPER BOUND FOR "IWORK" ARRAY WAS SET
C TO "MAXD", NOW IT IS SET TO 15000)
C
C USAGE: CALL FI8801(IPTR,IDENT,MSGA,ISTACK,IWORK,KDATA,IVALS,
C * MSTACK,KNR,INDEX,MAXR,MAXD,
C * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,IRF1SW,INEWVL,
C * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,
C * KFXY3,ANAME3,AUNIT3,ISCAL3,IRFVL3,IWIDE3,
C * IUNITB,IUNITD,ITBLD,ITBLD2,KPTRB)
C
C INPUT ARGUMENT LIST:
C IPTR - SEE W3FI88 ROUTINE DOCBLOCK
C IDENT - SEE W3FI88 ROUTINE DOCBLOCK
C MSGA - ARRAY CONTAINING BUFR MESSAGE
C ISTACK - ORIGINAL ARRAY OF DESCRIPTORS EXTRACTED FROM
C SOURCE BUFR MESSAGE.
C MSTACK - WORKING ARRAY OF DESCRIPTORS (EXPANDED)AND SCALING
C FACTOR
C KFXY1 - IMAGE OF CURRENT DESCRIPTOR
C INDEX -
C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE
C CONTAINED IN A BUFR MESSAGE
C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT
C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE
C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST
C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE
C IUNITB - UNIT NUMBER OF DATA SET HOLDING TABLE B
C IUNITD - UNIT NUMBER OF DATA SET HOLDING TABLE D
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C IWORK - WORKING DESCRIPTOR LIST
C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
C KDATA(REPORT NUMBER,PARAMETER NUMBER)
C
C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
C ARGUMENT MAXD)
C
C ISTACK - SEE ABOVE
C ARRAYS CONTAINING DATA FROM TABLE B
C KFXY1 - SEE ABOVE
C ANAME1 - DESCRIPTOR NAME
C AUNIT1 - UNITS FOR DESCRIPTOR
C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR
C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR
C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR
C
C SUBPROGRAMS CALLED:
C LIBRARY:
C W3LIB - FI8802 FI8805 FI8806 FI8807 FI8808
C
C REMARKS: ERROR RETURN:
C IPTR(1) = 8 ERROR READING TABLE B
C = 9 ERROR READING TABLE D
C = 11 ERROR OPENING TABLE B
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: NAS
C
C$$$
C ..................................................
C
C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE
C
INTEGER KFXY2(*),ISCAL2(*),IRFVL2(*),IWIDE2(*)
CHARACTER*64 ANAME2(*)
CHARACTER*24 AUNIT2(*)
C ..................................................
C
C NEW ADDED TABLE B FROM NON-TYPE 11 BUFR MESSAGE
C
INTEGER KFXY3(200),ISCAL3(200),IRFVL3(200),IWIDE3(200)
CHARACTER*64 ANAME3(200)
CHARACTER*24 AUNIT3(200)
C ..................................................
C
C NEW BASE TABLE B
C MAY BE A COMBINATION OF MASTER TABLE B
C AND ANCILLARY TABLE B
C
INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*)
CHARACTER*40 ANAME1(*)
CHARACTER*24 AUNIT1(*)
C ..................................................
C
C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
C
INTEGER ITBLD2(20,*)
C ..................................................
C
C NEW BASE TABLE D
C
INTEGER ITBLD(20,*)
C ..................................................
C
C
INTEGER MAXD, MAXR
C
INTEGER MSGA(*),KDATA(MAXR,MAXD),IVALS(*)
C
INTEGER KNR(MAXR)
INTEGER LX,LY,LL,J
C INTEGER IHOLD(33)
INTEGER IPTR(*),KPTRB(*),KPTRD(*)
INTEGER IDENT(*)
INTEGER ISTACK(*),IWORK(*)
C
INTEGER MSTACK(2,MAXD)
C
INTEGER JDESC
INTEGER INDEX
C
SAVE
C
C PRINT *,' DECOLL FI8801'
IF (INDEX.GT.1) THEN
GO TO 1000
END IF
C --------- DECOLL ---------------
IPTR(23) = 0
IPTR(26) = 0
IPTR(27) = 0
IPTR(28) = 0
IPTR(29) = 0
IPTR(30) = 0
IPTR(36) = 0
C INITIALIZE OUTPUT AREA
C SET POINTER TO BEGINNING OF DATA
C SET BIT
IPTR(17) = 1
1000 CONTINUE
C IPTR(12) = IPTR(13)
LL = 0
IPTR(11) = 1
IF (IPTR(10).EQ.0) THEN
C RE-ENTRY POINT FOR MULTIPLE
C NON-COMPRESSED REPORTS
ELSE
INDEX = IPTR(15)
IPTR(17) = INDEX
IPTR(25) = IPTR(10)
IPTR(10) = 0
IPTR(15) = 0
END IF
C PRINT *,'FI8801 - RPT',IPTR(17),' STARTS AT',IPTR(25)
IPTR(24) = 0
IPTR(31) = 0
C POINTING AT NEXT AVAILABLE DESCRIPTOR
MM = 0
IF (IPTR(21).EQ.0) THEN
NRDESC = IPTR(13)
CALL FI8812(IPTR,IUNITB,IUNITD,ISTACK,NRDESC,KPTRB,KPTRD,
* IRF1SW,NEWREF,ITBLD,ITBLD2,
* KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
* KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2)
END IF
10 CONTINUE
C PROCESS THRU THE FOLLOWING
C DEPENDING UPON THE VALUE OF 'F' (LF)
MM = MM + 1
12 CONTINUE
IF (MM.GT.MAXD) THEN
GO TO 200
END IF
C END OF CYCLE TEST (SERIAL/SEQUENTIAL)
IF (IPTR(11).GT.IPTR(12)) THEN
C PRINT *,' HAVE COMPLETED REPORT SEQUENCE'
IF (IDENT(16).NE.0) THEN
C PRINT *,' PROCESSING COMPRESSED REPORTS'
C REFORMAT DATA FROM DESCRIPTOR
C FORM TO USER FORM
RETURN
ELSE
C WRITE (6,1)
C 1 FORMAT (1H1)
C PRINT *,' PROCESSED SERIAL REPORT',IPTR(17),IPTR(25)
IPTR(17) = IPTR(17) + 1
IF (IPTR(17).GT.IDENT(14)) THEN
IPTR(17) = IPTR(17) - 1
GO TO 200
END IF
DO 300 I = 1, IPTR(13)
IWORK(I) = ISTACK(I)
300 CONTINUE
C RESET POINTERS
LL = 0
IPTR(1) = 0
IPTR(11) = 1
IPTR(12) = IPTR(13)
C IS THIS LAST REPORT ?
C PRINT *,'READY',IPTR(39),INDEX
IF (IPTR(39).GT.0) THEN
IF (INDEX.GT.0) THEN
C PRINT *,'HERE IS SUBSET NR',INDEX
RETURN
END IF
END IF
GO TO 1000
END IF
END IF
14 CONTINUE
C GET NEXT DESCRIPTOR
CALL FI8808 (IPTR,IWORK,LF,LX,LY,JDESC)
C PRINT *,IPTR(11)-1,'JDESC= ',JDESC,' AND NEXT ',
C * IPTR(11),IWORK(IPTR(11)),IPTR(31)
C PRINT *,IPTR(11)-1,'DESCRIPTOR',JDESC,LF,LX,LY,
C * ' FOR LOC',IPTR(17),IPTR(25)
CVVVVVCHANGE#2 FIX BY KEYSER -- 12/06/1994
C NOTE: THIS FIX NEEDED BECAUSE IWORK ARRAY DOES NOT HAVE TO BE
C LIMITED TO SIZE OF "MAXD" -- WASTES SPACE BECAUSE "MAXD"
C MUST BECOME OVER TWICE AS LARGE AS NEEDED FOR PROFILERS
C IN ORDER TO AVOID SATISFYING THIS BELOW IF TEST
CDAK IF (IPTR(11).GT.MAXD) THEN
IF (IPTR(11).GT.15000) THEN
CAAAAACHANGE#2 FIX BY KEYSER -- 12/06/1994
IPTR(1) = 401
RETURN
END IF
C
KPRM = IPTR(31) + IPTR(24)
IF (KPRM.GT.MAXD) THEN
IF (KPRM.GT.KOLD) THEN
PRINT *,'EXCEEDED ARRAY SIZE',KPRM,IPTR(31),
* IPTR(24)
KOLD = KPRM
END IF
END IF
C REPLICATION PROCESSING
IF (LF.EQ.1) THEN
C ---------- F1 ---------
IPTR(31) = IPTR(31) + 1
KPRM = IPTR(31) + IPTR(24)
MSTACK(1,KPRM) = JDESC
MSTACK(2,KPRM) = 0
KDATA(IPTR(17),KPRM) = 0
C PRINT *,'FI8801-1',KPRM,MSTACK(1,KPRM),
C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
CALL FI8805(IPTR,IDENT,MSGA,IWORK,LX,LY,
* KDATA,LL,KNR,MSTACK,MAXR,MAXD)
C * KDATA,LL,KNR,MSTACK,MAXR,MAXD)
IF (IPTR(1).NE.0) THEN
RETURN
ELSE
GO TO 12
END IF
C
C DATA DESCRIPTION OPERATORS
ELSE IF (LF.EQ.2)THEN
IF (LX.EQ.4) THEN
IPTR(31) = IPTR(31) + 1
KPRM = IPTR(31) + IPTR(24)
MSTACK(1,KPRM) = JDESC
MSTACK(2,KPRM) = 0
KDATA(IPTR(17),KPRM) = 0
C PRINT *,'FI8801-2',KPRM,MSTACK(1,KPRM),
C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
END IF
CALL FI8806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK,
* IWIDE1,IRFVL1,ISCAL1,J,LL,KFXY1,IWORK,JDESC,MAXR,MAXD,
* KPTRB)
IF (IPTR(1).NE.0) THEN
RETURN
END IF
GO TO 12
C DESCRIPTOR SEQUENCE STRINGS
ELSE IF (LF.EQ.3) THEN
C PRINT *,'F3 SEQUENCE DESCRIPTOR'
C READ IN TABLE D, BUT JUST ONCE
IF (IPTR(20).EQ.0) THEN
CALL FI8820 (ITBLD,IUNITD,IPTR,ITBLD2,KPTRD)
IF (IPTR(1).GT.0) THEN
RETURN
END IF
C ELSE
C IF (IPTR(42).NE.0) THEN
C PRINT *,'MERGE',IPTR(42),' ENTRIES INTO TABLE D'
C CALL FI8819(IPTR,ITBLD,ITBLD2,KPTRD)
C END IF
END IF
CALL FI8807(IPTR,IWORK,ITBLD,ITBLD2,JDESC,KPTRD)
IF (IPTR(1).GT.0) THEN
RETURN
END IF
GO TO 14
C
C ELEMENT DESCRIPTOR PROCESSING
C
ELSE
KPRM = IPTR(31) + IPTR(24)
CALL FI8802(IPTR,IDENT,MSGA,KDATA,KFXY1,LL,MSTACK,
* AUNIT1,IWIDE1,IRFVL1,ISCAL1,JDESC,IVALS,J,MAXR,MAXD,
* KPTRB)
C TURN OFF SKIP FLAG AFTER STD DESCRIPTOR
IPTR(36) = 0
IF (IPTR(1).GT.0) THEN
RETURN
ELSE
C
C IF ENCOUNTER CLASS 0 DESCRIPTOR
C NOT CONTAINED WITHIN A BUFR
C MESSAGE OF TYPE 11, THEN COLLECT
C ALL TABLE B ENTRIES FOR USE ON
C CURRENT BUFR MESSAGE
C
IF (JDESC.LE.20.AND.JDESC.GE.10) THEN
IF (IDENT(5).NE.11) THEN
C COLLECT TABLE B ENTRIES
CALL FI8815(IPTR,IDENT,JDESC,KDATA,
* KFXY3,MAXR,MAXD,ANAME3,AUNIT3,
* ISCAL3,IRFVL3,IWIDE3,
* KEYSET,IBFLAG,IERR)
IF (IERR.NE.0) THEN
END IF
IF (IAND(IBFLAG,16).NE.0) THEN
IF (IAND(IBFLAG,8).NE.0) THEN
IF (IAND(IBFLAG,4).NE.0) THEN
IF (IAND(IBFLAG,2).NE.0) THEN
IF (IAND(IBFLAG,1).NE.0) THEN
C HAVE A COMPLETE TABLE B ENTRY
IPTR(43) = IPTR(43) + IDENT(14)
KEYSET = 0
IBFLAG = 0
GO TO 1000
END IF
END IF
END IF
END IF
END IF
END IF
END IF
IF (IDENT(16).EQ.0) THEN
KNR(IPTR(17)) = IPTR(31)
ELSE
DO 310 KJ = 1, MAXR
KNR(KJ) = IPTR(31)
310 CONTINUE
END IF
GO TO 10
END IF
END IF
C END IF
C END DO WHILE
200 CONTINUE
C IF (IDENT(16).NE.0) THEN
C PRINT *,'RETURN WITH',IDENT(14),' COMPRESSED REPORTS'
C ELSE
C PRINT *,'RETURN WITH',IPTR(17),' NON-COMPRESSED REPORTS'
C END IF
RETURN
END
SUBROUTINE FI8802(IPTR,IDENT,MSGA,KDATA,KFXY1,LL,MSTACK,AUNIT1,
* IWIDE1,IRFVL1,ISCAL1,JDESC,IVALS,J,MAXR,MAXD,KPTRB)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8802 PROCESS ELEMENT DESCRIPTOR
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01
C
C ABSTRACT: PROCESS AN ELEMENT DESCRIPTOR (F = 0) AND STORE DATA
C IN OUTPUT ARRAY.
C
C PROGRAM HISTORY LOG:
C 88-09-01 CAVANAUGH
C 91-04-04 CAVANAUGH CHANGED TO PASS WIDTH OF TEXT FIELDS IN BYTES
C
C USAGE: CALL FI8802(IPTR,IDENT,MSGA,KDATA,KFXY1,LL,MSTACK,AUNIT1,
C IWIDE1,IRFVL1,ISCAL1,JDESC,IVALS,J,MAXR,MAXD,KPTRB)
C INPUT ARGUMENT LIST:
C IPTR - SEE W3FI88 ROUTINE DOCBLOCK
C IDENT - SEE W3FI88 ROUTINE DOCBLOCK
C MSGA - ARRAY CONTAINING BUFR MESSAGE
C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
C KDATA(REPORT NUMBER,PARAMETER NUMBER)
C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
C ARGUMENT MAXD)
C KFXY1 - IMAGE OF CURRENT DESCRIPTOR
C ANAME1 - LIST OF NAME OF DESCRIPTOR CONTENTS
C MSTACK -
C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE
C CONTAINED IN A BUFR MESSAGE
C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT
C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE
C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST
C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C KDATA - SEE ABOVE
C KFXY1 - SEE ABOVE
C ARRAYS CONTAINING DATA FROM TABLE B
C AUNIT1 - UNITS FOR DESCRIPTOR
C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR
C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR
C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR
C
C SUBPROGRAMS CALLED:
C LIBRARY:
C W3LIB - FI8803 FI8804
C
C REMARKS: ERROR RETURN:
C IPTR(1) = 3 - MESSAGE CONTAINS A DESCRIPTOR WITH F=0
C THAT DOES NOT EXIST IN TABLE B.
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: NAS
C
C$$$
C TABLE B ENTRY
CHARACTER*24 ASKEY
INTEGER MSGA(*)
INTEGER IPTR(*)
INTEGER KPTRB(*)
INTEGER IDENT(*)
INTEGER J
INTEGER JDESC
INTEGER MSTACK(2,MAXD)
INTEGER KDATA(MAXR,MAXD),IVALS(*)
C ..................................................
C
C NEW BASE TABLE B
C MAY BE A COMBINATION OF MASTER TABLE B
C AND ANCILLARY TABLE B
C
INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*)
C CHARACTER*40 ANAME1(*)
CHARACTER*24 AUNIT1(*)
C ..................................................
SAVE
C
DATA ASKEY /'CCITT IA5 '/
C
C PRINT *,' FI8802 - ELEMENT DESCRIPTOR ',JDESC,KPTRB(JDESC)
C FIND TABLE B ENTRY
J = KPTRB(JDESC)
C HAVE A MATCH
C SET FLAG IF TEXT EVENT
C PRINT *,'ASKEY=',ASKEY,'AUNIT1(',J,')=',AUNIT1(J),JDESC
IF (ASKEY(1:9).EQ.AUNIT1(J)(1:9)) THEN
IPTR(18) = 1
IPTR(40) = IWIDE1(J) / 8
ELSE
IPTR(18) = 0
END IF
C PRINT *,'FI8802 - BIT WIDTH =',IWIDE1(J),IPTR(18),' FOR',JDESC
IF (IDENT(16).NE.0) THEN
C COMPRESSED
CALL FI8803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK,
* IWIDE1,IRFVL1,ISCAL1,J,JDESC,MAXR,MAXD)
C IF (IPTR(1).NE.0) THEN
C RETURN
C END IF
ELSE
C NOT COMPRESSED
C PRINT *,' FROM FI8802',J
CALL FI8804(IPTR,MSGA,KDATA,IVALS,MSTACK,
* IWIDE1,IRFVL1,ISCAL1,J,LL,JDESC,MAXR,MAXD)
C IF (IPTR(1).NE.0) THEN
C RETURN
C END IF
END IF
RETURN
END
C -----------------------------------------------------
SUBROUTINE FI8803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK,
* IWIDE1,IRFVL1,ISCAL1,J,JDESC,MAXR,MAXD)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8803 PROCESS COMPRESSED DATA
C PRGMMR: KEYSER ORG: NP22 DATE: 1995-06-07
C
C ABSTRACT: PROCESS COMPRESSED DATA AND PLACE INDIVIDUAL ELEMENTS
C INTO OUTPUT ARRAY.
C
C PROGRAM HISTORY LOG:
C 1988-09-01 CAVANAUGH
C 1991-04-04 CAVANAUGH TEXT HANDLING PORTION OF THIS ROUTINE
C MODIFIED TO HANLE WIDTH OF FIELDS IN BYTES.
C 1991-04-17 CAVANAUGH TESTS SHOWED THAT THE SAME DATA IN COMPRESSED
C AND UNCOMPRESSED FORM GAVE DIFFERENT RESULTS.
C THIS HAS BEEN CORRECTED.
C 1991-06-21 CAVANAUGH PROCESSING OF TEXT DATA HAS BEEN CHANGED TO
C PROVIDE EXACT REPRODUCTION OF ALL CHARACTERS.
C 1994-04-11 CAVANAUGH CORRECTED PROCESSING OF DATA WHEN ALL VALUES
C THE SAME (NBINC = 0). CORRECTED TEST OF LOWEST
C VALUE AGAINST PROPER BIT MASK.
C 1995-06-07 KEYSER CORRECTED AN ERROR WHICH RESULTED IN
C RETURNED SCALE IN "MSTACK(2, ..)" ALWAYS
C BEING SET TO ZERO FOR COMPRESSED DATA. ALSO,
C SCALE CHANGES WERE NOT BEING RECOGNIZED.
C
C USAGE: CALL FI8803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK,
C IWIDE1,IRFVL1,ISCAL1,J,JDESC,MAXR,MAXD)
C INPUT ARGUMENT LIST:
C IPTR - SEE W3FI88 ROUTINE DOCBLOCK
C IDENT - SEE W3FI88 ROUTINE DOCBLOCK
C MSGA - ARRAY CONTAINING BUFR MESSAGE,MSTACK,
C IVALS - ARRAY OF SINGLE PARAMETER VALUES
C J -
C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE
C CONTAINED IN A BUFR MESSAGE
C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT
C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE
C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST
C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
C KDATA(REPORT NUMBER,PARAMETER NUMBER)
C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
C ARGUMENT MAXD)
C J -
C ARRAYS CONTAINING DATA FROM TABLE B
C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR
C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR
C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR
C
C SUBPROGRAMS CALLED:
C LIBRARY:
C W3LIB - GBYTE GBYTES W3AI39
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: NAS
C
C$$$
C
C ..................................................
C
C NEW BASE TABLE B
C MAY BE A COMBINATION OF MASTER TABLE B
C AND ANCILLARY TABLE B
C
C INTEGER KFXY1(*)
INTEGER ISCAL1(*)
INTEGER IRFVL1(3,*)
INTEGER IWIDE1(*)
C CHARACTER*40 ANAME1(*)
C CHARACTER*24 AUNIT1(*)
C ..................................................
INTEGER MAXD,MAXR
INTEGER MSGA(*),JDESC,MSTACK(2,MAXD)
INTEGER IPTR(*),IVALS(*),KDATA(MAXR,MAXD)
INTEGER NRVALS,JWIDE,IDATA
INTEGER IDENT(*)
INTEGER J
INTEGER KLOW(256)
C
LOGICAL TEXT
C
INTEGER MSK(32)
C
SAVE
C
DATA MSK /1, 3, 7, 15, 31, 63, 127,
C 1 2 3 4 5 6 7
* 255, 511, 1023, 2047, 4095,
C 8 9 10 11 12
* 8191, 16383, 32767, 65535,
C 13 14 15 16
* 131071, 262143, 524287,
C 17 18 19
* 1048575, 2097151, 4194303,
C 20 21 22
* 8388607, 16777215, 33554431,
C 23 24 25
* 67108863, 134217727, 268435455,
C 26 27 28
* 536870911, 1073741823, 2147483647,-1 /
C 29 30 31 32
CALL W3FI01(LW)
MWDBIT = IPTR(44)
IF (IPTR(45).EQ.8) THEN
I = 2147483647
MSK(32) = I + I + 1
END IF
C
C PRINT *,' FI8803 COMPR J=',J,' IWIDE1(J) =',IWIDE1(J),
C * ' EXTRA BITS =',IPTR(26),' START AT',IPTR(25)
IF (IPTR(18).EQ.0) THEN
TEXT = .FALSE.
ELSE
TEXT = .TRUE.
END IF
C PRINT *,'DESCRIPTOR',KPRM,JDESC
IF (.NOT.TEXT) THEN
IF (IPTR(29).GT.0.AND.JDESC.NE.7957) THEN
C PRINT *,'ASSOCIATED FIELD AT',IPTR(25)
C WORKING WITH ASSOCIATED FIELDS HERE
IPTR(31) = IPTR(31) + 1
KPRM = IPTR(31) + IPTR(24)
C GET LOWEST
CALL GBYTE (MSGA,LOWEST,IPTR(25),IPTR(29))
IPTR(25) = IPTR(25) + IPTR(29)
C GET NBINC
CALL GBYTE (MSGA,NBINC,IPTR(25),6)
IPTR(25) = IPTR(25) + 6
C PRINT *,'LOWEST=',LOWEST,' NBINC=',NBINC
IF (NBINC.GT.32) THEN
IPTR(1) = 22
RETURN
END IF
C EXTRACT DATA FOR ASSOCIATED FIELD
IF (NBINC.GT.0) THEN
CALL GBYTES (MSGA,IVALS,IPTR(25),NBINC,0,IPTR(21))
IPTR(25) = IPTR(25) + NBINC * IPTR(21)
DO 50 I = 1, IDENT(14)
KDATA(I,KPRM) = IVALS(I) + LOWEST
IF (NBINC.EQ.32) THEN
IF (KDATA(I,KPRM).EQ.MSK(NBINC)) THEN
KDATA(I,KPRM) = 999999
END IF
ELSE IF (KDATA(I,KPRM).GE.MSK(NBINC)) THEN
KDATA(I,KPRM) = 999999
END IF
50 CONTINUE
ELSE
DO 51 I = 1, IDENT(14)
KDATA(I,KPRM) = LOWEST
IF (NBINC.EQ.32) THEN
IF (LOWEST.EQ.MSK(32)) THEN
KDATA(I,KPRM) = 999999
END IF
ELSE IF(LOWEST.GE.MSK(NBINC)) THEN
KDATA(I,KPRM) = 999999
END IF
51 CONTINUE
END IF
END IF
C SET PARAMETER
C ISOLATE COMBINED BIT WIDTH
JWIDE = IWIDE1(J) + IPTR(26)
C
IF (JWIDE.GT.32) THEN
C TOO MANY BITS IN COMBINED
C BIT WIDTH
PRINT *,'ERR 22 - HAVE EXCEEDED COMBINED BIT WIDTH'
IPTR(1) = 22
RETURN
END IF
C SINGLE VALUE FOR LOWEST
NRVALS = 1
C LOWEST
C PRINT *,'PARAM',KPRM
CALL GBYTE (MSGA,LOWEST,IPTR(25),JWIDE)
C PRINT *,' LOWEST=',LOWEST,' AT BIT LOC ',IPTR(25)
IPTR(25) = IPTR(25) + JWIDE
C ISOLATE COMPRESSED BIT WIDTH
CALL GBYTE (MSGA,NBINC,IPTR(25),6)
C PRINT *,' NBINC=',NBINC,' AT BIT LOC',IPTR(25)
IF (NBINC.GT.32) THEN
C NBINC TOO LARGE
IPTR(1) = 22
RETURN
END IF
IF (IPTR(32).EQ.2.AND.IPTR(33).EQ.5) THEN
ELSE
IF (NBINC.GT.JWIDE) THEN
C PRINT *,'FOR DESCRIPTOR',JDESC
C PRINT *,J,'NBINC=',NBINC,' LOWEST=',LOWEST,' IWIDE1(J)=',
C * IWIDE1(J),' IPTR(26)=',IPTR(26),' AT BIT LOC',IPTR(25)
C DO 110 I = 1, KPRM
C WRITE (6,111)I,(KDATA(J,I),J=1,6)
C 110 CONTINUE
C 111 FORMAT (1X,5HDATA ,I3,6(2X,I10))
IPTR(1) = 500
PRINT *,'NBINC CALLS FOR LARGER BIT WIDTH THAN TABLE',
* ' B PLUS WIDTH CHANGES'
END IF
END IF
IPTR(25) = IPTR(25) + 6
C PRINT *,'LOWEST',LOWEST,' NBINC=',NBINC
C IF TEXT EVENT, PROCESS TEXT
C GET COMPRESSED VALUES
C PRINT *,'COMPRESSED VALUES - NONTEXT'
NRVALS = IDENT(14)
IPTR(31) = IPTR(31) + 1
KPRM = IPTR(31) + IPTR(24)
IF (NBINC.NE.0) THEN
CALL GBYTES (MSGA,IVALS,IPTR(25),NBINC,0,NRVALS)
IPTR(25) = IPTR(25) + NBINC * NRVALS
C RECALCULATE TO ORIGINAL VALUES
DO 100 I = 1, NRVALS
C PRINT *,IVALS(I),MSK(NBINC),NBINC
IF (IVALS(I).GE.MSK(NBINC)) THEN
KDATA(I,KPRM) = 999999
ELSE
IF (IRFVL1(2,J).EQ.0) THEN
JRV = IRFVL1(1,J)
ELSE
JRV = IRFVL1(3,J)
END IF
KDATA(I,KPRM) = IVALS(I) + LOWEST + JRV
END IF
100 CONTINUE
C PRINT *,I,JDESC,LOWEST,IRFVL1(1,J),IRFVL1(3,J)
ELSE
IF (LOWEST.EQ.MSK(JWIDE)) THEN
DO 105 I = 1, NRVALS
KDATA(I,KPRM) = 999999
105 CONTINUE
ELSE
IF (IRFVL1(2,J).EQ.0) THEN
JRV = IRFVL1(1,J)
ELSE
JRV = IRFVL1(3,J)
END IF
ICOMB = LOWEST + JRV
DO 106 I = 1, NRVALS
KDATA(I,KPRM) = ICOMB
106 CONTINUE
END IF
END IF
C PRINT *,'KPRM=',KPRM,' IPTR(25)=',IPTR(25)
MSTACK(1,KPRM) = JDESC
C WRITE (6,80) (KDATA(I,KPRM),I=1,10)
80 FORMAT(2X,10(F10.2,1X))
CVVVVVCHANGE#3 FIX BY KEYSER -- 12/06/1994
C NOTE: THIS FIX NEEDED BECAUSE THE RETURNED SCALE IN MSTACK(2,..)
C WAS ALWAYS '0' FOR COMPRESSED DATA, INCL. CHANGED SCALES)
MSTACK(2,KPRM) = ISCAL1(J) + IPTR(27)
CAAAAACHANGE#3 FIX BY KEYSER -- 12/06/1994
ELSE IF (TEXT) THEN
C PRINT *,' FOUND TEXT MODE IN COMPRESSED DATA',IPTR(40)
C GET LOWEST
C PRINT *,' PICKED UP LOWEST',(KLOW(K),K=1,IPTR(40))
DO 1906 K = 1, IPTR(40)
CALL GBYTE (MSGA,KLOW,IPTR(25),8)
IPTR(25) = IPTR(25) + 8
IF (KLOW(K).NE.0) THEN
IPTR(1) = 27
PRINT *,'NON-ZERO LOWEST ON TEXT DATA'
RETURN
END IF
1906 CONTINUE
C PRINT *,'TEXT - LOWEST = 0'
C GET NBINC
CALL GBYTE (MSGA,NBINC,IPTR(25),6)
IPTR(25) = IPTR(25) + 6
IF (NBINC.NE.IPTR(40)) THEN
IPTR(1) = 28
PRINT *,'NBINC IS NOT THE NUMBER OF CHARACTERS',NBINC
RETURN
END IF
C PRINT *,'TEXT NBINC =',NBINC
C FOR NUMBER OF OBSERVATIONS
IPTR(31) = IPTR(31) + 1
KPRM = IPTR(31) + IPTR(24)
ISTART = KPRM
I24 = IPTR(24)
DO 1900 N = 1, IDENT(14)
KPRM = ISTART
IPTR(24) = I24
NBITS = IPTR(40) * 8
1700 CONTINUE
C PRINT *,N,IDENT(14),'KPRM-B=',KPRM,IPTR(24),NBITS
IF (NBITS.GT.MWDBIT) THEN
CALL GBYTE (MSGA,IDATA,IPTR(25),MWDBIT)
IPTR(25) = IPTR(25) + MWDBIT
NBITS = NBITS - MWDBIT
IF (IPTR(37).EQ.0) THEN
C CONVERTS ASCII TO EBCIDIC
CALL W3AI39 (IDATA,LW)
END IF
MSTACK(1,KPRM) = JDESC
MSTACK(2,KPRM) = 0
KDATA(N,KPRM) = IDATA
C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM)
C SET FOR NEXT PART
KPRM = KPRM + 1
IPTR(24) = IPTR(24) + 1
C PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA
C1701 FORMAT (1X,I1,1X,6HKDATA=,A4,2X,I5,2X,I5,2X,I5,2X,I12)
GO TO 1700
ELSE IF (NBITS.GT.0) THEN
CALL GBYTE (MSGA,IDATA,IPTR(25),NBITS)
IPTR(25) = IPTR(25) + NBITS
IBUF = (IPTR(44) - NBITS) / 8
IF (IBUF.GT.0) THEN
DO 1750 MP = 1, IBUF
IDATA = IDATA * 256 + 32
1750 CONTINUE
END IF
C CONVERTS ASCII TO EBCIDIC
IF (IPTR(37).EQ.0) THEN
CALL W3AI39 (IDATA,LW)
END IF
MSTACK(1,KPRM) = JDESC
MSTACK(2,KPRM) = 0
KDATA(N,KPRM) = IDATA
C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM)
C PRINT 1701,2,KDATA(N,KPRM),N,KPRM,NBITS
NBITS = 0
END IF
C WRITE (6,1800)N,(KDATA(N,I),I=KPRS,KPRM)
C1800 FORMAT (2X,I4,2X,3A4)
1900 CONTINUE
END IF
RETURN
END
C -----------------------------------------------------
SUBROUTINE FI8804(IPTR,MSGA,KDATA,IVALS,MSTACK,
* IWIDE1,IRFVL1,ISCAL1,J,LL,JDESC,MAXR,MAXD)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8804 PROCESS SERIAL DATA
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01
C
C ABSTRACT: PROCESS DATA THAT IS NOT COMPRESSED
C
C PROGRAM HISTORY LOG:
C 88-09-01 CAVANAUGH
C 91-01-18 CAVANAUGH MODIFIED TO PROPERLY HANDLE NON-COMPRESSED
C DATA.
C 91-04-04 CAVANAUGH TEXT HANDLING PORTION OF THIS ROUTINE
C MODIFIED TO HANDLE FIELD WIDTH IN BYTES.
C 91-04-17 CAVANAUGH TESTS SHOWED THAT THE SAME DATA IN COMPRESSED
C AND UNCOMPRESSED FORM GAVE DIFFERENT RESULTS.
C THIS HAS BEEN CORRECTED.
C
C USAGE: CALL FI8804(IPTR,MSGA,KDATA,IVALS,MSTACK,
C IWIDE1,IRFVL1,ISCAL1,J,LL,JDESC,MAXR,MAXD)
C INPUT ARGUMENT LIST:
C IPTR - SEE W3FI88 ROUTINE DOCBLOCK
C MSGA - ARRAY CONTAINING BUFR MESSAGE
C IVALS - ARRAY OF SINGLE PARAMETER VALUES
C J -
C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE
C CONTAINED IN A BUFR MESSAGE
C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT
C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE
C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST
C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
C KDATA(REPORT NUMBER,PARAMETER NUMBER)
C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
C ARGUMENT MAXD)
C IVALS - SEE ABOVE
C J - SEE ABOVE
C ARRAYS CONTAINING DATA FROM TABLE B
C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR
C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR
C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR
C
C SUBPROGRAMS CALLED:
C LIBRARY:
C W3LIB - GBYTE
C
C REMARKS: ERROR RETURN:
C IPTR(1) = 13 - BIT WIDTH ON ASCII CHARS NOT A MULTIPLE OF 8
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: NAS
C
C$$$
C ..................................................
C
C NEW BASE TABLE B
C MAY BE A COMBINATION OF MASTER TABLE B
C AND ANCILLARY TABLE B
C
C INTEGER KFXY1(*)
INTEGER ISCAL1(*)
INTEGER IRFVL1(3,*)
INTEGER IWIDE1(*)
C CHARACTER*40 ANAME1(*)
C CHARACTER*24 AUNIT1(*)
C ..................................................
C
INTEGER MSGA(*),MAXD,MAXR
INTEGER IPTR(*)
INTEGER JDESC
INTEGER IVALS(*)
C INTEGER LSTBLK(3)
INTEGER KDATA(MAXR,MAXD),MSTACK(2,MAXD)
INTEGER J,LL
C LOGICAL LKEY
C
C
INTEGER ITEST(32)
C
SAVE
C
DATA ITEST /1,3,7,15,31,63,127,255,
* 511,1023,2047,4095,8191,16383,
* 32767, 65535,131071,262143,524287,
* 1048575,2097151,4194303,8388607,
* 16777215,33554431,67108863,134217727,
* 268435455,536870911,1073741823,
* 2147483647,-1/
C
MWDBIT = IPTR(44)
IF (IPTR(45).NE.4) THEN
I = 2147483647
ITEST(32) = I + I + 1
END IF
C
C PRINT *,' FI8804 NOCMP',J,JDESC,IWIDE1(J),IPTR(26),IPTR(25)
C -------- NOCMP --------
C IF NOT TEXT EVENT, PROCESS
IF (IPTR(18).EQ.0) THEN
C PRINT *,' NOT TEXT'
IF ((IPTR(26)+IWIDE1(J)).LT.1) THEN
C PRINT *,' FI8804 NOCMP',J,JDESC,IWIDE1(J),IPTR(26),IPTR(25)
IPTR(1) = 501
RETURN
END IF
C ISOLATE BIT WIDTH
JWIDE = IWIDE1(J) + IPTR(26)
C IF ASSOCIATED FIELD SW ON
IF (IPTR(29).GT.0) THEN
IF (JDESC.NE.7957.AND.JDESC.NE.7937) THEN
IPTR(31) = IPTR(31) + 1
KPRM = IPTR(31) + IPTR(24)
MSTACK(1,KPRM) = 33792 + IPTR(29)
MSTACK(2,KPRM) = 0
CALL GBYTE (MSGA,IVALS,IPTR(25),IPTR(29))
IPTR(25) = IPTR(25) + IPTR(29)
KDATA(IPTR(17),KPRM) = IVALS(1)
C PRINT *,'FI8804-A',KPRM,MSTACK(1,KPRM),
C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM)
END IF
END IF
IPTR(31) = IPTR(31) + 1
KPRM = IPTR(31) + IPTR(24)
MSTACK(1,KPRM) = JDESC
C IF (IPTR(27).NE.0) THEN
C MSTACK(2,KPRM) = IPTR(27)
C ELSE
MSTACK(2,KPRM) = ISCAL1(J) + IPTR(27)
C END IF
C GET VALUES
C CALL TO GET DATA OF GIVEN BIT WIDTH
CALL GBYTE (MSGA,IVALS,IPTR(25),JWIDE)
C PRINT *,'DATA TO',IPTR(17),KPRM,IVALS(1),JWIDE,IPTR(25)
IPTR(25) = IPTR(25) + JWIDE
C RETURN WITH SINGLE VALUE
IF (IRFVL1(2,J).EQ.0) THEN
JRV = IRFVL1(1,J)
ELSE
JRV = IRFVL1(3,J)
END IF
IF (JWIDE.EQ.32) THEN
IF (IVALS(1).EQ.ITEST(JWIDE)) THEN
KDATA(IPTR(17),KPRM) = 999999
ELSE
KDATA(IPTR(17),KPRM) = IVALS(1) + JRV
END IF
ELSE IF (IVALS(1).GE.ITEST(JWIDE)) THEN
KDATA(IPTR(17),KPRM) = 999999
ELSE
KDATA(IPTR(17),KPRM) = IVALS(1) + JRV
END IF
C PRINT *,'FI8804-B',KPRM,MSTACK(1,KPRM),
C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM)
C IF(JDESC.EQ.2049) THEN
C PRINT *,'VERT SIG =',KDATA(IPTR(17),KPRM)
C END IF
C PRINT *,'FI8804 ',KPRM,MSTACK(1,KPRM),
C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
ELSE
C PRINT *,' TEXT'
C PRINT *,' FOUND TEXT MODE ****** NOT COMPRESSED *********'
JWIDE = IPTR(40) * 8
C PRINT *,' WIDTH =',JWIDE,IPTR(40)
NRCHRS = IPTR(40)
NRBITS = JWIDE
C PRINT *,' CHARS =',NRCHRS,' BITS =',NRBITS
IPTR(31) = IPTR(31) + 1
KANY = 0
1800 CONTINUE
KANY = KANY + 1
C PRINT *,' NR BITS THIS PASS',NRBITS
IF (NRBITS.GT.MWDBIT) THEN
CALL GBYTE (MSGA,IDATA,IPTR(25),MWDBIT)
C PRINT 1801,KANY,IDATA,IPTR(17),KPRM,NRBITS
1801 FORMAT (1X,I2,4X,Z8,2(4X,I4))
C CONVERTS ASCII TO EBCIDIC
C COMMENT OUT IF NOT IBM370 COMPUTER
IF (IPTR(37).EQ.0) THEN
CALL W3AI39 (IDATA,IPTR(45))
END IF
KPRM = IPTR(31) + IPTR(24)
KDATA(IPTR(17),KPRM) = IDATA
MSTACK(1,KPRM) = JDESC
MSTACK(2,KPRM) = 0
C PRINT *,'BODY ',KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM),
C * KDATA(IPTR(17),KPRM)
IPTR(25) = IPTR(25) + MWDBIT
NRBITS = NRBITS - MWDBIT
IPTR(24) = IPTR(24) + 1
GO TO 1800
ELSE IF (NRBITS.GT.0) THEN
CALL GBYTE (MSGA,IDATA,IPTR(25),NRBITS)
IPTR(25) = IPTR(25) + NRBITS
C CONVERTS ASCII TO EBCIDIC
C COMMENT OUT IF NOT IBM370 COMPUTER
IF (IPTR(37).EQ.0) THEN
CALL W3AI39 (IDATA,IPTR(45))
END IF
KPRM = IPTR(31) + IPTR(24)
KSHFT = MWDBIT - NRBITS
IF (KSHFT.GT.0) THEN
KTRY = KSHFT / 8
DO 1722 LAK = 1, KTRY
IF (IPTR(37).EQ.0) THEN
IDATA = IDATA * 256 + 64
ELSE
IDATA = IDATA * 256 + 32
END IF
C PRINT 1723,IDATA
C1723 FORMAT (12X,Z8)
1722 CONTINUE
END IF
KDATA(IPTR(17),KPRM) = IDATA
C PRINT 1801,KANY,IDATA,KDATA(IPTR(17),KPRM),KPRM
MSTACK(1,KPRM) = JDESC
MSTACK(2,KPRM) = 0
C PRINT *,'TAIL ',KPRM,MSTACK(1,KPRM),
C * KDATA(IPTR(17),KPRM)
END IF
END IF
RETURN
END
C -----------------------------------------------------
SUBROUTINE FI8805(IPTR,IDENT,MSGA,IWORK,LX,LY,
* KDATA,LL,KNR,MSTACK,MAXR,MAXD)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8805 PROCESS A REPLICATION DESCRIPTOR
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01
C
C ABSTRACT: PROCESS A REPLICATION DESCRIPTOR, MUST EXTRACT NUMBER
C OF REPLICATIONS OF N DESCRIPTORS FROM THE DATA STREAM.
C
C PROGRAM HISTORY LOG:
C 88-09-01 CAVANAUGH
C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE
C
C USAGE: CALL FI8805(IPTR,IDENT,MSGA,IWORK,LX,LY,
C * KDATA,LL,KNR,MSTACK,MAXR,MAXD)
C INPUT ARGUMENT LIST:
C IWORK - WORKING DESCRIPTOR LIST
C IPTR - SEE W3FI88 ROUTINE DOCBLOCK
C IDENT - SEE W3FI88 ROUTINE DOCBLOCK
C LX - X PORTION OF CURRENT DESCRIPTOR
C LY - Y PORTION OF CURRENT DESCRIPTOR
C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE
C CONTAINED IN A BUFR MESSAGE
C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT
C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE
C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST
C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
C KDATA(REPORT NUMBER,PARAMETER NUMBER)
C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
C ARGUMENT MAXD)
C LX - SEE ABOVE
C LY - SEE ABOVE
C
C SUBPROGRAMS CALLED:
C LIBRARY:
C W3LIB - GBYTES FI8808
C
C REMARKS: ERROR RETURN:
C IPTR(1) = 12 DATA DESCRIPTOR QUALIFIER DOES NOT FOLLOW
C DELAYED REPLICATION DESCRIPTOR
C = 20 EXCEEDED COUNT FOR DELAYED REPLICATION PASS
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: NAS
C
C$$$
C
INTEGER IPTR(*)
INTEGER KNR(MAXR)
INTEGER ITEMP(2000)
INTEGER LL
INTEGER KTEMP(2000)
INTEGER KDATA(MAXR,MAXD)
INTEGER LX,MSTACK(2,MAXD)
INTEGER LY
INTEGER MSGA(*)
INTEGER KVALS(1300)
CVVVVVCHANGE#2 FIX BY KEYSER -- 12/06/1994
C NOTE: THIS FIX JUST CLEANS UP CODE SINCE IWORK ARRAY IS EARLIER
C DEFINED AS 15000 WORDS
INTEGER IWORK(*)
CDAK INTEGER IWORK(MAXD)
CAAAAACHANGE#2 FIX BY KEYSER -- 12/06/1994
INTEGER IDENT(*)
C
SAVE
C
C PRINT *,' REPLICATION FI8805'
C DO 7100 I = 1, IPTR(13)
C PRINT *,I,IWORK(I)
C7100 CONTINUE
C NUMBER OF DESCRIPTORS
NRSET = LX
C NUMBER OF REPLICATIONS
NRREPS = LY
ICURR = IPTR(11) - 1
IPICK = IPTR(11) - 1
C
IF (NRREPS.EQ.0) THEN
IPTR(39) = 1
C SAVE PRIMARY DELAYED REPLICATION DESCRIPTOR
C IPTR(31) = IPTR(31) + 1
C KPRM = IPTR(31) + IPTR(24)
C MSTACK(1,KPRM) = JDESC
C MSTACK(2,KPRM) = 0
C KDATA(IPTR(17),KPRM) = 0
C PRINT *,'FI8805-1',KPRM,MSTACK(1,KPRM),
C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
C DELAYED REPLICATION - MUST GET NUMBER OF
C REPLICATIONS FROM DATA.
C GET NEXT DESCRIPTOR
CALL FI8808(IPTR,IWORK,LF,LX,LY,JDESC)
C PRINT *,' DELAYED REPLICATION',LF,LX,LY,JDESC
C MUST BE DATA DESCRIPTION
C OPERATION QUALIFIER
IF (JDESC.EQ.7937.OR.JDESC.EQ.7947) THEN
JWIDE = 8
ELSE IF (JDESC.EQ.7938.OR.JDESC.EQ.7948) THEN
JWIDE = 16
ELSE IF (JDESC.EQ.7936) THEN
JWIDE = 1
ELSE
IPTR(1) = 12
RETURN
END IF
C THIS IF BLOCK IS SET TO HANDLE
C DATA/DESCRIPTOR REPLICATION
IF (JDESC.EQ.7947.OR.JDESC.EQ.7948) THEN
C SET DATA/DESCRIPTOR REPLICATION FLAG = ON
IPTR(38) = 1
C SAVE AS NEXT ENTRY IN KDATA, MSTACK
IPTR(31) = IPTR(31) + 1
KPRM = IPTR(31) + IPTR(24)
MSTACK(1,KPRM) = JDESC
MSTACK(2,KPRM) = 0
CALL GBYTE (MSGA,KVALS,IPTR(25),JWIDE)
IPTR(25) = IPTR(25) + JWIDE
KDATA(IPTR(17),KPRM) = KVALS(1)
RETURN
END IF
C SET SINGLE VALUE FOR SEQUENTIAL,
C MULTIPLE VALUES FOR COMPRESSED
IF (IDENT(16).EQ.0) THEN
C NON COMPRESSED
CALL GBYTE (MSGA,KVALS,IPTR(25),JWIDE)
C PRINT *,LF,LX,LY,JDESC,' NR OF REPLICATIONS',KVALS(1)
IPTR(25) = IPTR(25) + JWIDE
IPTR(31) = IPTR(31) + 1
KPRM = IPTR(31) + IPTR(24)
MSTACK(1,KPRM) = JDESC
MSTACK(2,KPRM) = 0
KDATA(IPTR(17),KPRM) = KVALS(1)
NRREPS = KVALS(1)
C PRINT *,'FI8805-2',KPRM,MSTACK(1,KPRM),
C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
ELSE
NRVALS = IDENT(14)
CALL GBYTES (MSGA,KVALS,IPTR(25),JWIDE,0,NRVALS)
IPTR(25) = IPTR(25) + JWIDE * NRVALS
IPTR(31) = IPTR(31) + 1
KPRM = IPTR(31) + IPTR(24)
MSTACK(1,KPRM) = JDESC
MSTACK(2,KPRM) = 0
KDATA(IPTR(17),KPRM) = KVALS(1)
DO 100 I = 1, NRVALS
KDATA(I,KPRM) = KVALS(I)
100 CONTINUE
NRREPS = KVALS(1)
END IF
ELSE
C PRINT *,'NOT DELAYED REPLICATION'
END IF
C RESTRUCTURE WORKING STACK W/REPLICATIONS
IF (NRREPS.EQ.0) THEN
C PRINT *,'RESTRUCTURING - NO REPLICATION'
IPTR(11) = IPICK + NRSET + 2
GO TO 9999
END IF
C PRINT *,' SAVE OFF',NRSET,' DESCRIPTORS'
C PICK UP DESCRIPTORS TO BE REPLICATED
DO 1000 I = 1, NRSET
CALL FI8808(IPTR,IWORK,LF,LX,LY,JDESC)
ITEMP(I) = JDESC
C PRINT *,'REPLICATION ',I,ITEMP(I)
1000 CONTINUE
C MOVE TRAILING DESCRIPTORS TO HOLD AREA
LAX = IPTR(12) - IPTR(11) + 1
C PRINT *,LAX,' TRAILING DESCRIPTORS TO HOLD AREA',IPTR(11),IPTR(12)
DO 2000 I = 1, LAX
CALL FI8808(IPTR,IWORK,LF,LX,LY,JDESC)
KTEMP(I) = JDESC
C PRINT *,' ',I,KTEMP(I)
2000 CONTINUE
C REPLICATIONS INTO ISTACK
C PRINT *,' MUST REPLICATE ',KX,' DESCRIPTORS',KY,' TIMES'
C PRINT *,'REPLICATIONS INTO STACK. LOC',ICURR
DO 4000 I = 1, NRREPS
DO 3000 J = 1, NRSET
IWORK(ICURR) = ITEMP(J)
C PRINT *,'FI8805 A',ICURR,IWORK(ICURR)
ICURR = ICURR + 1
3000 CONTINUE
4000 CONTINUE
C PRINT *,' TO LOC',ICURR-1
C RESTORE TRAILING DESCRIPTORS
C PRINT *,'TRAILING DESCRIPTORS INTO STACK. LOC',ICURR
DO 5000 I = 1, LAX
IWORK(ICURR) = KTEMP(I)
C PRINT *,'FI8805 B',ICURR,IWORK(ICURR)
ICURR = ICURR + 1
5000 CONTINUE
IPTR(12) = ICURR - 1
IPTR(11) = IPICK
9999 CONTINUE
C DO 5500 I = 1, IPTR(12)
C PRINT *,'FI8805 B',I,IWORK(I),IPTR(11)
C5500 CONTINUE
RETURN
END
SUBROUTINE FI8806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK,
* IWIDE1,IRFVL1,ISCAL1,J,LL,KFXY1,IWORK,JDESC,MAXR,MAXD,KPTRB)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8806 PROCESS OPERATOR DESCRIPTORS
C PRGMMR: CAVANAUGH ORG: W/NMCX42 DATE: 88-09-01
C
C ABSTRACT: EXTRACT AND SAVE INDICATED CHANGE VALUES FOR USE
C UNTIL CHANGES ARE RESCINDED, OR EXTRACT TEXT STRINGS INDICATED
C THROUGH 2 05 YYY.
C
C PROGRAM HISTORY LOG:
C 88-09-01 CAVANAUGH
C 91-04-04 CAVANAUGH MODIFIED TO HANDLE DESCRIPTOR 2 05 YYY
C 91-05-10 CAVANAUGH CODING HAS BEEN ADDED TO PROCESS PROPERLY
C TABLE C DESCRIPTOR 2 06 YYY.
C 91-11-21 CAVANAUGH CODING HAS BEEN ADDED TO PROPERLY PROCESS
C TABLE C DESCRIPTOR 2 03 YYY, THE CHANGE
C TO NEW REFERENCE VALUE FOR SELECTED
C DESCRIPTORS.
C
C USAGE: CALL FI8806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK,
C * IWIDE1,IRFVL1,ISCAL1,J,LL,KFXY1,IWORK,JDESC,MAXR,MAXD,KPTRB)
C INPUT ARGUMENT LIST:
C IPTR - SEE W3FI88 ROUTINE DOCBLOCK
C LX - X PORTION OF CURRENT DESCRIPTOR
C LY - Y PORTION OF CURRENT DESCRIPTOR
C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE
C CONTAINED IN A BUFR MESSAGE
C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT
C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE
C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST
C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE
C
C OUTPUT ARGUMENT LIST:
C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
C KDATA(REPORT NUMBER,PARAMETER NUMBER)
C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
C ARGUMENT MAXD)
C ARRAYS CONTAINING DATA FROM TABLE B
C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR
C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR
C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR
C
C REMARKS: ERROR RETURN:
C IPTR(1) = 5 - ERRONEOUS X VALUE IN DATA DESCRIPTOR OPERATOR
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: NAS
C
C$$$
C ..................................................
C
C NEW BASE TABLE B
C MAY BE A COMBINATION OF MASTER TABLE B
C AND ANCILLARY TABLE B
C
INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*)
C CHARACTER*40 ANAME1(*)
C CHARACTER*24 AUNIT1(*)
C ..................................................
INTEGER IPTR(*),KDATA(MAXR,MAXD),IVALS(*)
INTEGER IDENT(*),IWORK(*),KPTRB(*)
INTEGER MSGA(*),MSTACK(2,MAXD)
INTEGER J,JDESC
INTEGER LL
INTEGER LX
INTEGER LY
C
SAVE
C
C PRINT *,' F2 - DATA DESCRIPTOR OPERATOR'
IF (LX.EQ.1) THEN
C CHANGE BIT WIDTH
IF (LY.EQ.0) THEN
C PRINT *,' RETURN TO NORMAL WIDTH'
IPTR(26) = 0
ELSE
C PRINT *,' EXPAND WIDTH BY',LY-128,' BITS'
IPTR(26) = LY - 128
END IF
ELSE IF (LX.EQ.2) THEN
C CHANGE SCALE
IF (LY.EQ.0) THEN
C RESET TO STANDARD SCALE
IPTR(27) = 0
ELSE
C SET NEW SCALE
IPTR(27) = LY - 128
END IF
ELSE IF (LX.EQ.3) THEN
C CHANGE REFERENCE VALUE
C FOR EACH OF THOSE DESCRIPTORS BETWEEN
C 2 03 YYY WHERE Y LT 255 AND
C 2 03 255, EXTRACT THE NEW REFERENCE
C VALUE (BIT WIDTH YYY) AND PLACE
C IN TERTIARY TABLE B REF VAL POSITION,
C SET FLAG IN SECONDARY REFVAL POSITION
C THOSE DESCRIPTORS DO NOT HAVE DATA
C ASSOCIATED WITH THEM, BUT ONLY
C IDENTIFY THE TABLE B ENTRIES THAT
C ARE GETTING NEW REFERENCE VALUES.
KYYY = LY
IF (KYYY.GT.0.AND.KYYY.LT.255) THEN
C START CYCLING THRU DESCRIPTORS UNTIL
C TERMINATE NEW REF VALS IS FOUND
300 CONTINUE
CALL FI8808 (IPTR,IWORK,LF,LX,LY,JDESC)
IF (JDESC.EQ.33791) THEN
C IF 2 03 255 THEN RETURN
RETURN
END IF
C FIND MATCHING TABLE B ENTRY
LJ = KPTRB(JDESC)
IF (LJ.LT.1) THEN
C MATCHING DESCRIPTOR NOT FOUND, ERROR ERROR
PRINT *,'2 03 YYY - MATCHING DESCRIPTOR NOT FOUND'
IPTR(1) = 23
RETURN
END IF
C TURN ON SWITCH
IRFVL1(2,LJ) = 1
C INSERT NEW REFERENCE VALUE
CALL GBYTE (MSGA,IRFVL1(3,LJ),IPTR(25),KYYY)
GO TO 300
ELSE IF (KYYY.EQ.0) THEN
C MUST TURN OFF ALL NEW
C REFERENCE VALUES
DO 400 I = 1, IPTR(21)
IRFVL1(2,I) = 0
400 CONTINUE
END IF
C LX = 3
C MUST BE CONCLUDED WITH Y=255
ELSE IF (LX.EQ.4) THEN
C ASSOCIATED VALUES
IF (LY.EQ.0) THEN
IPTR(29) = 0
C PRINT *,'RESET ASSOCIATED VALUES',IPTR(29)
ELSE
IPTR(29) = LY
IF (IWORK(IPTR(11)).NE.7957) THEN
PRINT *,'2 04 YYY NOT FOLLOWED BY 0 31 021'
IPTR(1) = 11
END IF
C PRINT *,'SET ASSOCIATED VALUES',IPTR(29)
END IF
ELSE IF (LX.EQ.5) THEN
MWDBIT = IPTR(44)
C PROCESS TEXT DATA
IPTR(40) = LY
IPTR(18) = 1
J = KPTRB(JDESC)
IF (IDENT(16).EQ.0) THEN
C PRINT *,'FROM FI8806 - 2 05 YYY - NONCOMPRESSED TEXT',J
CALL FI8804(IPTR,MSGA,KDATA,IVALS,MSTACK,
* IWIDE1,IRFVL1,ISCAL1,J,LL,JDESC,MAXR,MAXD)
ELSE
C PRINT *,'2 05 YYY - TEXT - COMPRESSED MODE YYY=',LY
C PRINT *,'TEXT - LOWEST = 0'
IPTR(25) = IPTR(25) + IPTR(40) * 8
C GET NBINC
C CALL GBYTE (MSGA,NBINC,IPTR(25),6)
IPTR(25) = IPTR(25) + 6
NBINC = IPTR(40)
C PRINT *,'TEXT NBINC =',NBINC,IPTR(40)
C FOR NUMBER OF OBSERVATIONS
IPTR(31) = IPTR(31) + 1
KPRM = IPTR(31) + IPTR(24)
ISTART = KPRM
DO 1900 N = 1, IDENT(14)
KPRM = ISTART
NBITS = IPTR(40) * 8
1700 CONTINUE
C PRINT *,'1700',KDATA(N,KPRM),N,KPRM,NBITS
IF (NBITS.GT.MWDBIT) THEN
CALL GBYTE (MSGA,IDATA,IPTR(25),MWDBIT)
IPTR(25) = IPTR(25) + MWDBIT
NBITS = NBITS - MWDBIT
C CONVERTS ASCII TO EBCIDIC
C COMMENT OUT IF NOT IBM370 COMPUTER
IF (IPTR(37).EQ.0) THEN
CALL W3AI39 (IDATA,IPTR(45))
END IF
MSTACK(1,KPRM) = JDESC
MSTACK(2,KPRM) = 0
KDATA(N,KPRM) = IDATA
C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM)
C SET FOR NEXT PART
KPRM = KPRM + 1
C PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA
C1701 FORMAT (1X,I1,1X,6HKDATA=,A4,2X,I5,2X,I5,2X,I5,2X,
C * I10)
GO TO 1700
ELSE IF (NBITS.EQ.MWDBIT) THEN
CALL GBYTE (MSGA,IDATA,IPTR(25),MWDBIT)
IPTR(25) = IPTR(25) + MWDBIT
NBITS = NBITS - MWDBIT
C CONVERTS ASCII TO EBCIDIC
C COMMENT OUT IF NOT IBM370 COMPUTER
IF (IPTR(37).EQ.0) THEN
CALL W3AI39 (IDATA,IPTR(45))
END IF
MSTACK(1,KPRM) = JDESC
MSTACK(2,KPRM) = 0
KDATA(N,KPRM) = IDATA
C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM)
C SET FOR NEXT PART
KPRM = KPRM + 1
C PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA
ELSE IF (NBITS.GT.0) THEN
CALL GBYTE (MSGA,IDATA,IPTR(25),NBITS)
IPTR(25) = IPTR(25) + NBITS
IBUF = (MWDBIT - NBITS) / 8
IF (IBUF.GT.0) THEN
DO 1750 MP = 1, IBUF
IDATA = IDATA * 256 + 32
1750 CONTINUE
END IF
C CONVERTS ASCII TO EBCIDIC
C COMMENT OUT IF NOT IBM370 COMPUTER
IF (IPTR(37).EQ.0) THEN
CALL W3AI39 (IDATA,IPTR(45))
END IF
MSTACK(1,KPRM) = JDESC
MSTACK(2,KPRM) = 0
KDATA(N,KPRM) = IDATA
C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM)
C PRINT 1701,2,KDATA(N,KPRM),N,KPRM,NBITS
END IF
C WRITE (6,1800)N,(KDATA(N,I),I=KPRS,KPRM)
C1800 FORMAT (2X,I4,2X,3A4)
1900 CONTINUE
IPTR(24) = IPTR(24) + IPTR(40) / 4 - 1
IF (MOD(IPTR(40),4).NE.0) IPTR(24) = IPTR(24) + 1
END IF
IPTR(18) = 0
C ---------------------------
ELSE IF (LX.EQ.6) THEN
C SKIP NEXT DESCRIPTOR
C SET TO PASS OVER DESCRIPTOR AND DATA
C IF DESCRIPTOR NOT IN TABLE B
IPTR(36) = LY
C PRINT *,'SET TO SKIP',LY,' BIT FIELD'
IPTR(31) = IPTR(31) + 1
KPRM = IPTR(31) + IPTR(24)
MSTACK(1,KPRM) = 34304 + LY
MSTACK(2,KPRM) = 0
ELSE
IPTR(1) = 5
ENDIF
RETURN
END
SUBROUTINE FI8807(IPTR,IWORK,ITBLD,ITBLD2,JDESC,KPTRD)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8807 PROCESS QUEUE DESCRIPTOR
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01
C
C ABSTRACT: SUBSTITUTE DESCRIPTOR QUEUE FOR QUEUE DESCRIPTOR
C
C PROGRAM HISTORY LOG:
C 88-09-01 CAVANAUGH
C 91-04-17 CAVANAUGH IMPROVED HANDLING OF NESTED QUEUE DESCRIPTORS
C 91-05-28 CAVANAUGH IMPROVED HANDLING OF NESTED QUEUE DESCRIPTORS
C BASED ON TESTS WITH LIVE DATA.
C
C USAGE: CALL FI8807(IPTR,IWORK,ITBLD,ITBLD2,JDESC,KPTRD)
C INPUT ARGUMENT LIST:
C IWORK - WORKING DESCRIPTOR LIST
C IPTR - SEE W3FI88 ROUTINE DOCBLOCK
C LAST - INDEX TO LAST DESCRIPTOR
C ITBLD - ARRAY CONTAINING DESCRIPTOR QUEUES
C JDESC - QUEUE DESCRIPTOR TO BE EXPANDED
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C ISTACK - SEE ABOVE
C
C SUBPROGRAMS CALLED:
C LIBRARY:
C W3LIB - NONE
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: NAS
C
C$$$
C ..................................................
C
C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
C
INTEGER ITBLD2(20,*)
C ..................................................
C
C NEW BASE TABLE D
C
INTEGER ITBLD(20,*)
C ..................................................
C
INTEGER IPTR(*),JDESC,KPTRD(*)
INTEGER IWORK(*),IHOLD(15000)
C
SAVE
C PRINT *,' FI8807 F3 ENTRY',IPTR(11),IPTR(12)
C SET FOR BINARY SEARCH IN TABLE D
JLO = 1
JHI = IPTR(20)
C PRINT *,'LOOKING FOR QUEUE DESCRIPTOR',JDESC,IPTR(11),IPTR(12)
C
JMID = KPTRD(MOD(JDESC,16384))
IF (JMID.LT.0) THEN
IPTR(1) = 4
RETURN
END IF
C HAVE TABLE D MATCH
C PRINT *,'D ',(ITBLD(LL,JMID),LL=1,20)
C PRINT *,'TABLE D TO IHOLD'
IK = 0
JK = 0
DO 200 KI = 2, 20
IF (ITBLD(KI,JMID).NE.0) THEN
IK = IK + 1
IHOLD(IK) = ITBLD(KI,JMID)
C PRINT *,IK,IHOLD(IK)
ELSE
GO TO 300
END IF
200 CONTINUE
300 CONTINUE
KK = IPTR(11)
IF (KK.GT.IPTR(12)) THEN
C NOTHING MORE TO APPEND
C PRINT *,'NOTHING MORE TO APPEND'
ELSE
C APPEND TRAILING IWORK TO IHOLD
C PRINT *,'APPEND FROM ',KK,' TO',IPTR(12)
DO 500 I = KK, IPTR(12)
IK = IK + 1
IHOLD(IK) = IWORK(I)
500 CONTINUE
END IF
C RESET IHOLD TO IWORK
C PRINT *,' RESET IWORK STACK'
KK = IPTR(11) - 2
DO 1000 I = 1, IK
KK = KK + 1
IWORK(KK) = IHOLD(I)
1000 CONTINUE
IPTR(12) = KK
C PRINT *,' FI8807 F3 EXIT ',IPTR(11),IPTR(12)
C DO 2000 I = 1, IPTR(12)
C PRINT *,'EXIT IWORK',I,IWORK(I)
C2000 CONTINUE
C RESET POINTERS
IPTR(11) = IPTR(11) - 1
RETURN
END
C -----------------------------------------------------
SUBROUTINE FI8808(IPTR,IWORK,LF,LX,LY,JDESC)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8808
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 89-01-17
C
C ABSTRACT:
C
C PROGRAM HISTORY LOG:
C 88-09-01 CAVANAUGH
C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
C
C USAGE: CALL FI8808(IPTR,IWORK,LF,LX,LY,JDESC)
C INPUT ARGUMENT LIST:
C IPTR - SEE W3FI88 ROUTINE DOCBLOCK
C IWORK - WORKING DESCRIPTOR LIST
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C IPTR - SEE ABOVE
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: NAS
C
C$$$
INTEGER IPTR(*),IWORK(*),LF,LX,LY,JDESC
SAVE
C
C PRINT *,' FI8808 NEW DESCRIPTOR PICKUP'
JDESC = IWORK(IPTR(11))
LY = MOD(JDESC,256)
IPTR(34) = LY
LX = MOD((JDESC/256),64)
IPTR(33) = LX
LF = JDESC / 16384
IPTR(32) = LF
C PRINT *,' TEST DESCRIPTOR',LF,LX,LY,' AT',IPTR(11)
IPTR(11) = IPTR(11) + 1
RETURN
END
SUBROUTINE FI8809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8809 REFORMAT PROFILER W HGT INCREMENTS
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 90-02-14
C
C ABSTRACT: REFORMAT DECODED PROFILER DATA TO SHOW HEIGHTS INSTEAD OF
C HEIGHT INCREMENTS.
C
C PROGRAM HISTORY LOG:
C 90-02-14 CAVANAUGH
C
C USAGE: CALL FI8809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
C INPUT ARGUMENT LIST:
C IDENT - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM
C BUFR MESSAGE -
C IDENT(1) -EDITION NUMBER (BYTE 4, SECTION 1)
C IDENT(2) -ORIGINATING CENTER (BYTES 5-6, SECTION 1)
C IDENT(3) -UPDATE SEQUENCE (BYTE 7, SECTION 1)
C IDENT(4) - (BYTE 8, SECTION 1)
C IDENT(5) -BUFR MESSAGE TYPE (BYTE 9, SECTION 1)
C IDENT(6) -BUFR MSG SUB-TYPE (BYTE 10, SECTION 1)
C IDENT(7) - (BYTES 11-12, SECTION 1)
C IDENT(8) -YEAR OF CENTURY (BYTE 13, SECTION 1)
C IDENT(9) -MONTH OF YEAR (BYTE 14, SECTION 1)
C IDENT(10)-DAY OF MONTH (BYTE 15, SECTION 1)
C IDENT(11)-HOUR OF DAY (BYTE 16, SECTION 1)
C IDENT(12)-MINUTE OF HOUR (BYTE 17, SECTION 1)
C IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1)
C IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3)
C IDENT(15)-OBSERVED FLAG (BYTE 7, BIT 1, SECTION 3)
C IDENT(16)-COMPRESSION FLAG (BYTE 7, BIT 2, SECTION 3)
C MSTACK - WORKING DESCRIPTOR LIST AND SCALING FACTOR
C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
C KDATA(REPORT NUMBER,PARAMETER NUMBER)
C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
C ARGUMENT MAXD)
C KSET2 - INTERIM DATA ARRAY
C KPROFL - INTERIM DESCRIPTOR ARRAY
C IPTR - SEE W3FI88
C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE
C CONTAINED IN A BUFR MESSAGE
C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT
C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE
C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST
C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE
C
C OUTPUT FILES:
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: NAS
C
C$$$
C ----------------------------------------------------------------
C
INTEGER ISW
INTEGER IDENT(*),KDATA(MAXR,MAXD)
INTEGER MSTACK(2,MAXD),IPTR(*)
INTEGER KPROFL(1700)
INTEGER KPROF2(1700)
INTEGER KSET2(1700)
C
C ----------------------------------------------------------
SAVE
C PRINT *,'FI8809'
C LOOP FOR NUMBER OF SUBSETS/REPORTS
DO 3000 I = 1, IDENT(14)
C INIT FOR DATA INPUT ARRAY
MK = 1
C INIT FOR DESC OUTPUT ARRAY
JK = 0
C LOCATION
ISW = 0
DO 200 J = 1, 3
C LATITUDE
IF (MSTACK(1,MK).EQ.1282) THEN
ISW = ISW + 1
GO TO 100
C LONGITUDE
ELSE IF (MSTACK(1,MK).EQ.1538) THEN
ISW = ISW + 2
GO TO 100
C HEIGHT ABOVE SEA LEVEL
ELSE IF (MSTACK(1,MK).EQ.1793) THEN
IHGT = KDATA(I,MK)
ISW = ISW + 4
GO TO 100
END IF
GO TO 200
100 CONTINUE
JK = JK + 1
C SAVE DESCRIPTOR
KPROFL(JK) = MSTACK(1,MK)
C SAVE SCALE
KPROF2(JK) = MSTACK(2,MK)
C SAVE DATA
KSET2(JK) = KDATA(I,MK)
MK = MK + 1
200 CONTINUE
IF (ISW.NE.7) THEN
PRINT *,'LOCATION ERROR PROCESSING PROFILER'
IPTR(1) = 200
RETURN
END IF
C TIME
ISW = 0
DO 400 J = 1, 7
C YEAR
IF (MSTACK(1,MK).EQ.1025) THEN
ISW = ISW + 1
GO TO 300
C MONTH
ELSE IF (MSTACK(1,MK).EQ.1026) THEN
ISW = ISW + 2
GO TO 300
C DAY
ELSE IF (MSTACK(1,MK).EQ.1027) THEN
ISW = ISW + 4
GO TO 300
C HOUR
ELSE IF (MSTACK(1,MK).EQ.1028) THEN
ISW = ISW + 8
GO TO 300
C MINUTE
ELSE IF (MSTACK(1,MK).EQ.1029) THEN
ISW = ISW + 16
GO TO 300
C TIME SIGNIFICANCE
ELSE IF (MSTACK(1,MK).EQ.2069) THEN
ISW = ISW + 32
GO TO 300
ELSE IF (MSTACK(1,MK).EQ.1049) THEN
ISW = ISW + 64
GO TO 300
END IF
GO TO 400
300 CONTINUE
JK = JK + 1
C SAVE DESCRIPTOR
KPROFL(JK) = MSTACK(1,MK)
C SAVE SCALE
KPROF2(JK) = MSTACK(2,MK)
C SAVE DATA
KSET2(JK) = KDATA(I,MK)
MK = MK + 1
400 CONTINUE
IF (ISW.NE.127) THEN
PRINT *,'TIME ERROR PROCESSING PROFILER',ISW
IPTR(1) = 201
RETURN
END IF
C SURFACE DATA
KRG = 0
ISW = 0
DO 600 J = 1, 10
C WIND SPEED
IF (MSTACK(1,MK).EQ.2818) THEN
ISW = ISW + 1
GO TO 500
C WIND DIRECTION
ELSE IF (MSTACK(1,MK).EQ.2817) THEN
ISW = ISW + 2
GO TO 500
C PRESS REDUCED TO MSL
ELSE IF (MSTACK(1,MK).EQ.2611) THEN
ISW = ISW + 4
GO TO 500
C TEMPERATURE
ELSE IF (MSTACK(1,MK).EQ.3073) THEN
ISW = ISW + 8
GO TO 500
C RAINFALL RATE
ELSE IF (MSTACK(1,MK).EQ.3342) THEN
ISW = ISW + 16
GO TO 500
C RELATIVE HUMIDITY
ELSE IF (MSTACK(1,MK).EQ.3331) THEN
ISW = ISW + 32
GO TO 500
C 1ST RANGE GATE OFFSET
ELSE IF (MSTACK(1,MK).EQ.1982.OR.
* MSTACK(1,MK).EQ.1983) THEN
C CANNOT USE NORMAL PROCESSING FOR FIRST RANGE GATE, MUST SAVE
C VALUE FOR LATER USE
IF (MSTACK(1,MK).EQ.1983) THEN
IHGT = KDATA(I,MK)
MK = MK + 1
KRG = 1
ELSE
IF (KRG.EQ.0) THEN
INCRHT = KDATA(I,MK)
MK = MK + 1
KRG = 1
C PRINT *,'INITIAL INCR =',INCRHT
ELSE
LHGT = 500 + IHGT - KDATA(I,MK)
ISW = ISW + 64
C PRINT *,'BASE HEIGHT=',LHGT,' INCR=',INCRHT
END IF
END IF
C MODE #1
ELSE IF (MSTACK(1,MK).EQ.8128) THEN
ISW = ISW + 128
GO TO 500
C MODE #2
ELSE IF (MSTACK(1,MK).EQ.8129) THEN
ISW = ISW + 256
GO TO 500
END IF
GO TO 600
500 CONTINUE
C SAVE DESCRIPTOR
JK = JK + 1
KPROFL(JK) = MSTACK(1,MK)
C SAVE SCALE
KPROF2(JK) = MSTACK(2,MK)
C SAVE DATA
KSET2(JK) = KDATA(I,MK)
C IF (I.EQ.1) THEN
C PRINT *,' ',JK,KPROFL(JK),KSET2(JK)
C END IF
MK = MK + 1
600 CONTINUE
IF (ISW.NE.511) THEN
PRINT *,'SURFACE ERROR PROCESSING PROFILER',ISW
IPTR(1) = 202
RETURN
END IF
C 43 LEVELS
DO 2000 L = 1, 43
2020 CONTINUE
ISW = 0
C HEIGHT INCREMENT
IF (MSTACK(1,MK).EQ.1982) THEN
C PRINT *,'NEW HEIGHT INCREMENT',KDATA(I,MK)
INCRHT = KDATA(I,MK)
MK = MK + 1
IF (LHGT.LT.(9250+IHGT)) THEN
LHGT = IHGT + 500 - INCRHT
ELSE
LHGT = IHGT + 9250 - INCRHT
END IF
END IF
C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DATA
C AT THIS POINT - HEIGHT + INCREMENT + BASE VALUE
LHGT = LHGT + INCRHT
C PRINT *,'LEVEL ',L,LHGT
IF (L.EQ.37) THEN
LHGT = LHGT + INCRHT
END IF
JK = JK + 1
C SAVE DESCRIPTOR
KPROFL(JK) = 1798
C SAVE SCALE
KPROF2(JK) = 0
C SAVE DATA
KSET2(JK) = LHGT
C IF (I.EQ.10) THEN
C PRINT *,' '
C PRINT *,'HGT',JK,KPROFL(JK),KSET2(JK)
C END IF
ISW = 0
DO 800 J = 1, 9
750 CONTINUE
IF (MSTACK(1,MK).EQ.1982) THEN
GO TO 2020
C U VECTOR VALUE
ELSE IF (MSTACK(1,MK).EQ.3008) THEN
ISW = ISW + 1
IF (KDATA(I,MK).GE.2047) THEN
VECTU = 32767
ELSE
VECTU = KDATA(I,MK)
END IF
MK = MK + 1
GO TO 800
C V VECTOR VALUE
ELSE IF (MSTACK(1,MK).EQ.3009) THEN
ISW = ISW + 2
IF (KDATA(I,MK).GE.2047) THEN
VECTV = 32767
ELSE
VECTV = KDATA(I,MK)
END IF
MK = MK + 1
C IF U VALUE IS ALSO AVAILABLE THEN GENERATE DDFFF
C DESCRIPTORS AND DATA
IF (IAND(ISW,1).NE.0) THEN
IF (VECTU.EQ.32767.OR.VECTV.EQ.32767) THEN
C SAVE DD DESCRIPTOR
JK = JK + 1
KPROFL(JK) = 2817
C SAVE SCALE
KPROF2(JK) = 0
C SAVE DD DATA
KSET2(JK) = 32767
C SAVE FFF DESCRIPTOR
JK = JK + 1
KPROFL(JK) = 2818
C SAVE SCALE
KPROF2(JK) = 1
C SAVE FFF DATA
KSET2(JK) = 32767
ELSE
C GENERATE DDFFF
CALL W3FC05 (VECTU,VECTV,DIR,SPD)
NDIR = DIR
SPD = SPD
NSPD = SPD
C PRINT *,' ',NDIR,NSPD
C SAVE DD DESCRIPTOR
JK = JK + 1
KPROFL(JK) = 2817
C SAVE SCALE
KPROF2(JK) = 0
C SAVE DD DATA
KSET2(JK) = DIR
C IF (I.EQ.1) THEN
C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK)
C END IF
C SAVE FFF DESCRIPTOR
JK = JK + 1
KPROFL(JK) = 2818
C SAVE SCALE
KPROF2(JK) = 1
C SAVE FFF DATA
KSET2(JK) = SPD
C IF (I.EQ.1) THEN
C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK)
C END IF
END IF
END IF
GO TO 800
C W VECTOR VALUE
ELSE IF (MSTACK(1,MK).EQ.3010) THEN
ISW = ISW + 4
GO TO 700
C Q/C TEST RESULTS
ELSE IF (MSTACK(1,MK).EQ.8130) THEN
ISW = ISW + 8
GO TO 700
C U,V QUALITY IND
ELSE IF(IAND(ISW,16).EQ.0.AND.MSTACK(1,MK).EQ.2070) THEN
ISW = ISW + 16
GO TO 700
C W QUALITY IND
ELSE IF(IAND(ISW,32).EQ.0.AND.MSTACK(1,MK).EQ.2070) THEN
ISW = ISW + 32
GO TO 700
C SPECTRAL PEAK POWER
ELSE IF (MSTACK(1,MK).EQ.5568) THEN
ISW = ISW + 64
GO TO 700
C U,V VARIABILITY
ELSE IF (MSTACK(1,MK).EQ.3011) THEN
ISW = ISW + 128
GO TO 700
C W VARIABILITY
ELSE IF (MSTACK(1,MK).EQ.3013) THEN
ISW = ISW + 256
GO TO 700
ELSE IF ((MSTACK(1,MK)/16384).NE.0) THEN
MK = MK + 1
GO TO 750
END IF
GO TO 800
700 CONTINUE
JK = JK + 1
C SAVE DESCRIPTOR
KPROFL(JK) = MSTACK(1,MK)
C SAVE SCALE
KPROF2(JK) = MSTACK(2,MK)
C SAVE DATA
KSET2(JK) = KDATA(I,MK)
MK = MK + 1
C IF (I.EQ.1) THEN
C PRINT *,' ',JK,KPROFL(JK),KSET2(JK)
C END IF
800 CONTINUE
IF (ISW.NE.511) THEN
PRINT *,'LEVEL ERROR PROCESSING PROFILER',ISW
IPTR(1) = 203
RETURN
END IF
2000 CONTINUE
C MOVE DATA BACK INTO KDATA ARRAY
DO 4000 LL = 1, JK
KDATA(I,LL) = KSET2(LL)
4000 CONTINUE
3000 CONTINUE
C PRINT *,'REBUILT ARRAY'
DO 5000 LL = 1, JK
C DESCRIPTOR
MSTACK(1,LL) = KPROFL(LL)
C SCALE
MSTACK(2,LL) = KPROF2(LL)
C PRINT *,LL,MSTACK(1,LL),(KDATA(I,LL),I=1,7)
5000 CONTINUE
C MOVE REFORMATTED DESCRIPTORS TO MSTACK ARRAY
IPTR(31) = JK
RETURN
END
SUBROUTINE FI8810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8810 REFORMAT PROFILER EDITION 2 DATA
C PRGMMR: KEYSER ORG: NP22 DATE: 1995-06-07
C
C ABSTRACT: REFORMAT PROFILER DATA IN EDITION 2
C
C PROGRAM HISTORY LOG:
C 1993-01-27 CAVANAUGH
C 1995-06-07 KEYSER A CORRECTION WAS MADE TO PREVENT
C UNNECESSARY LOOPING WHEN ALL REQUESTED
C DESCRIPTORS ARE MISSING.
C
C USAGE: CALL FI8810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
C INPUT ARGUMENT LIST:
C IDENT - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM
C BUFR MESSAGE -
C IDENT(1) -EDITION NUMBER (BYTE 4, SECTION 1)
C IDENT(2) -ORIGINATING CENTER (BYTES 5-6, SECTION 1)
C IDENT(3) -UPDATE SEQUENCE (BYTE 7, SECTION 1)
C IDENT(4) - (BYTE 8, SECTION 1)
C IDENT(5) -BUFR MESSAGE TYPE (BYTE 9, SECTION 1)
C IDENT(6) -BUFR MSG SUB-TYPE (BYTE 10, SECTION 1)
C IDENT(7) - (BYTES 11-12, SECTION 1)
C IDENT(8) -YEAR OF CENTURY (BYTE 13, SECTION 1)
C IDENT(9) -MONTH OF YEAR (BYTE 14, SECTION 1)
C IDENT(10)-DAY OF MONTH (BYTE 15, SECTION 1)
C IDENT(11)-HOUR OF DAY (BYTE 16, SECTION 1)
C IDENT(12)-MINUTE OF HOUR (BYTE 17, SECTION 1)
C IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1)
C IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3)
C IDENT(15)-OBSERVED FLAG (BYTE 7, BIT 1, SECTION 3)
C IDENT(16)-COMPRESSION FLAG (BYTE 7, BIT 2, SECTION 3)
C MSTACK - WORKING DESCRIPTOR LIST AND SCALING FACTOR
C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
C KDATA(REPORT NUMBER,PARAMETER NUMBER)
C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
C ARGUMENT MAXD)
C KSET2 - INTERIM DATA ARRAY
C KPROFL - INTERIM DESCRIPTOR ARRAY
C IPTR - SEE W3FI88
C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE
C CONTAINED IN A BUFR MESSAGE
C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT
C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE
C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST
C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE
C
C OUTPUT FILES:
C
C REMARKS:
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: NAS
C
C$$$
INTEGER ISW
INTEGER IDENT(*),KDATA(MAXR,MAXD)
INTEGER MSTACK(2,MAXD),IPTR(*)
INTEGER KPROFL(1700)
INTEGER KPROF2(1700)
INTEGER KSET2(1700)
C
SAVE
C LOOP FOR NUMBER OF SUBSETS
DO 3000 I = 1, IDENT(14)
MK = 1
JK = 0
ISW = 0
C PRINT *,'IDENTIFICATION'
DO 200 J = 1, 5
IF (MSTACK(1,MK).EQ.257) THEN
C BLOCK NUMBER
ISW = ISW + 1
ELSE IF (MSTACK(1,MK).EQ.258) THEN
C STATION NUMBER
ISW = ISW + 2
ELSE IF (MSTACK(1,MK).EQ.1282) THEN
C LATITUDE
ISW = ISW + 4
ELSE IF (MSTACK(1,MK).EQ.1538) THEN
C LONGITUDE
ISW = ISW + 8
ELSE IF (MSTACK(1,MK).EQ.1793) THEN
C HEIGHT OF STATION
ISW = ISW + 16
IHGT = KDATA(I,MK)
ELSE
MK = MK + 1
GO TO 200
END IF
JK = JK + 1
KPROFL(JK) = MSTACK(1,MK)
KPROF2(JK) = MSTACK(2,MK)
KSET2(JK) = KDATA(I,MK)
C PRINT *,JK,KPROFL(JK),KSET2(JK)
MK = MK + 1
200 CONTINUE
C PRINT *,'LOCATION ',ISW
IF (ISW.NE.31) THEN
PRINT *,'LOCATION ERROR PROCESSING PROFILER'
IPTR(10) = 200
RETURN
END IF
C PROCESS TIME ELEMENTS
ISW = 0
DO 400 J = 1, 7
IF (MSTACK(1,MK).EQ.1025) THEN
C YEAR
ISW = ISW + 1
ELSE IF (MSTACK(1,MK).EQ.1026) THEN
C MONTH
ISW = ISW + 2
ELSE IF (MSTACK(1,MK).EQ.1027) THEN
C DAY
ISW = ISW + 4
ELSE IF (MSTACK(1,MK).EQ.1028) THEN
C HOUR
ISW = ISW + 8
ELSE IF (MSTACK(1,MK).EQ.1029) THEN
C MINUTE
ISW = ISW + 16
ELSE IF (MSTACK(1,MK).EQ.2069) THEN
C TIME SIGNIFICANCE
ISW = ISW + 32
ELSE IF (MSTACK(1,MK).EQ.1049) THEN
C TIME DISPLACEMENT
ISW = ISW + 64
ELSE
MK = MK + 1
GO TO 400
END IF
JK = JK + 1
KPROFL(JK) = MSTACK(1,MK)
KPROF2(JK) = MSTACK(2,MK)
KSET2(JK) = KDATA(I,MK)
C PRINT *,JK,KPROFL(JK),KSET2(JK)
MK = MK + 1
400 CONTINUE
C PRINT *,'TIME ',ISW
IF (ISW.NE.127) THEN
PRINT *,'TIME ERROR PROCESSING PROFILER'
IPTR(1) = 201
RETURN
END IF
C SURFACE DATA
ISW = 0
C PRINT *,'SURFACE'
DO 600 K = 1, 8
C PRINT *,MK,MSTACK(1,MK),JK,ISW
IF (MSTACK(1,MK).EQ.2817) THEN
ISW = ISW + 1
ELSE IF (MSTACK(1,MK).EQ.2818) THEN
ISW = ISW + 2
ELSE IF (MSTACK(1,MK).EQ.2611) THEN
ISW = ISW + 4
ELSE IF (MSTACK(1,MK).EQ.3073) THEN
ISW = ISW + 8
ELSE IF (MSTACK(1,MK).EQ.3342) THEN
ISW = ISW + 16
ELSE IF (MSTACK(1,MK).EQ.3331) THEN
ISW = ISW + 32
ELSE IF (MSTACK(1,MK).EQ.1797) THEN
INCRHT = KDATA(I,MK)
ISW = ISW + 64
C PRINT *,'INITIAL INCREMENT = ',INCRHT
MK = MK + 1
C PRINT *,JK,KPROFL(JK),KSET2(JK),' ISW=',ISW
GO TO 600
ELSE IF (MSTACK(1,MK).EQ.6433) THEN
ISW = ISW + 128
END IF
JK = JK + 1
KPROFL(JK) = MSTACK(1,MK)
KPROF2(JK) = MSTACK(2,MK)
KSET2(JK) = KDATA(I,MK)
C PRINT *,JK,KPROFL(JK),KSET2(JK),'ISW=',ISW
MK = MK + 1
600 CONTINUE
IF (ISW.NE.255) THEN
PRINT *,'ERROR PROCESSING PROFILER',ISW
IPTR(1) = 204
RETURN
END IF
IF (MSTACK(1,MK).NE.1797) THEN
PRINT *,'ERROR PROCESSING HEIGHT INCREMENT IN PROFILER'
IPTR(1) = 205
RETURN
END IF
C MUST SAVE THIS HEIGHT VALUE
LHGT = 500 + IHGT - KDATA(I,MK)
C PRINT *,'BASE HEIGHT = ',LHGT,' INCR = ',INCRHT
MK = MK + 1
IF (MSTACK(1,MK).GE.16384) THEN
MK = MK + 1
END IF
C PROCESS LEVEL DATA
C PRINT *,'LEVEL DATA'
DO 2000 L = 1, 43
2020 CONTINUE
C PRINT *,'DESC',MK,MSTACK(1,MK),JK
ISW = 0
C HEIGHT INCREMENT
IF (MSTACK(1,MK).EQ.1797) THEN
INCRHT = KDATA(I,MK)
C PRINT *,'NEW HEIGHT INCREMENT = ',INCRHT
MK = MK + 1
C IF (LHGT.LT.(9250+IHGT)) THEN
C LHGT = IHGT + 500 - INCRHT
C ELSE
C LHGT = IHGT + 9250 -INCRHT
C END IF
END IF
C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DA
C AT THIS POINT
LHGT = LHGT + INCRHT
C PRINT *,'LEVEL ',L,LHGT
C IF (L.EQ.37) THEN
C LHGT = LHGT + INCRHT
C END IF
JK = JK + 1
C SAVE DESCRIPTOR
KPROFL(JK) = 1798
C SAVE SCALE
KPROF2(JK) = 0
C SAVE DATA
KSET2(JK) = LHGT
C PRINT *,KPROFL(JK),KSET2(JK),JK
ISW = 0
ICON = 1
DO 800 J = 1, 10
750 CONTINUE
IF (MSTACK(1,MK).EQ.1797) THEN
GO TO 2020
ELSE IF (MSTACK(1,MK).EQ.6432) THEN
C HI/LO MODE
ISW = ISW + 1
ELSE IF (MSTACK(1,MK).EQ.6434) THEN
C Q/C TEST
ISW = ISW + 2
ELSE IF (MSTACK(1,MK).EQ.2070) THEN
IF (ICON.EQ.1) THEN
C FIRST PASS - U,V CONSENSUS
ISW = ISW + 4
ICON = ICON + 1
ELSE
C SECOND PASS - W CONSENSUS
ISW = ISW + 64
END IF
ELSE IF (MSTACK(1,MK).EQ.2819) THEN
C U VECTOR VALUE
ISW = ISW + 8
IF (KDATA(I,MK).GE.2047) THEN
VECTU = 32767
ELSE
VECTU = KDATA(I,MK)
END IF
MK = MK + 1
GO TO 800
ELSE IF (MSTACK(1,MK).EQ.2820) THEN
C V VECTOR VALUE
ISW = ISW + 16
IF (KDATA(I,MK).GE.2047) THEN
VECTV = 32767
ELSE
VECTV = KDATA(I,MK)
END IF
IF (IAND(ISW,1).NE.0) THEN
IF (VECTU.EQ.32767.OR.VECTV.EQ.32767) THEN
C SAVE DD DESCRIPTOR
JK = JK + 1
KPROFL(JK) = 2817
KPROF2(JK) = 0
KSET2(JK) = 32767
C SAVE FFF DESCRIPTOR
JK = JK + 1
KPROFL(JK) = 2818
KPROF2(JK) = 1
KSET2(JK) = 32767
ELSE
CALL W3FC05 (VECTU,VECTV,DIR,SPD)
NDIR = DIR
SPD = SPD
NSPD = SPD
C PRINT *,' ',NDIR,NSPD
C SAVE DD DESCRIPTOR
JK = JK + 1
KPROFL(JK) = 2817
KPROF2(JK) = 0
KSET2(JK) = NDIR
C IF (I.EQ.1) THEN
C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK)
C ENDIF
C SAVE FFF DESCRIPTOR
JK = JK + 1
KPROFL(JK) = 2818
KPROF2(JK) = 1
KSET2(JK) = NSPD
C IF (I.EQ.1) THEN
C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK)
C ENDIF
END IF
MK = MK + 1
GO TO 800
END IF
ELSE IF (MSTACK(1,MK).EQ.2866) THEN
C SPEED STD DEVIATION
ISW = ISW + 32
C -- A CHANGE BY KEYSER : POWER DESCR. BACK TO 5568
ELSE IF (MSTACK(1,MK).EQ.5568) THEN
C SIGNAL POWER
ISW = ISW + 128
ELSE IF (MSTACK(1,MK).EQ.2822) THEN
C W COMPONENT
ISW = ISW + 256
ELSE IF (MSTACK(1,MK).EQ.2867) THEN
C VERT STD DEVIATION
ISW = ISW + 512
CVVVVVCHANGE#1 FIX BY KEYSER -- 12/06/1994
C NOTE: THIS FIX PREVENTS UNNECESSARY LOOPING WHEN ALL REQ. DESCR.
C ARE MISSING. WOULD GO INTO INFINITE LOOP EXCEPT EVENTUALLY
C MSTACK ARRAY SIZE IS EXCEEDED AND GET FORTRAN ERROR INTERRUPT
CDAK ELSE
ELSE IF ((MSTACK(1,MK)/16384).NE.0) THEN
CAAAAACHANGE#1 FIX BY KEYSER -- 12/06/1994
MK = MK + 1
GO TO 750
END IF
JK = JK + 1
C SAVE DESCRIPTOR
KPROFL(JK) = MSTACK(1,MK)
C SAVE SCALE
KPROF2(JK) = MSTACK(2,MK)
C SAVE DATA
KSET2(JK) = KDATA(I,MK)
MK = MK + 1
C PRINT *,L,'TEST ',JK,KPROFL(JK),KSET2(JK)
800 CONTINUE
IF (ISW.NE.1023) THEN
PRINT *,'LEVEL ERROR PROCESSING PROFILER',ISW
IPTR(1) = 202
RETURN
END IF
2000 CONTINUE
C MOVE DATA BACK INTO KDATA ARRAY
DO 5000 LL = 1, JK
C DATA
KDATA(I,LL) = KSET2(LL)
5000 CONTINUE
3000 CONTINUE
DO 5005 LL = 1, JK
C DESCRIPTOR
MSTACK(1,LL) = KPROFL(LL)
C SCALE
MSTACK(2,LL) = KPROF2(LL)
C -- A CHANGE BY KEYSER : PRINT STATEMNT SHOULD BE HERE NOT IN 5000 LOOP
C PRINT *,LL,MSTACK(1,LL),MSTACK(2,LL),(KDATA(I,LL),I=1,4)
5005 CONTINUE
IPTR(31) = JK
RETURN
END
SUBROUTINE FI8811(IPTR,IDENT,MSTACK,KDATA,KNR,
* LDATA,LSTACK,MAXD,MAXR)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8811 EXPAND DATA/DESCRIPTOR REPLICATION
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-05-12
C
C ABSTRACT: EXPAND DATA AND DESCRIPTOR STRINGS
C
C PROGRAM HISTORY LOG:
C 93-05-12 CAVANAUGH
C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE
C
C USAGE: CALL FI8811(IPTR,IDENT,MSTACK,KDATA,KNR,
C * LDATA,LSTACK,MAXD,MAXR)
C INPUT ARGUMENT LIST:
C IPTR - SEE W3FI88 ROUTINE DOCBLOCK
C IDENT - SEE W3FI88 ROUTINE DOCBLOCK
C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE
C CONTAINED IN A BUFR MESSAGE
C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT
C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE
C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST
C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE
C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
C KDATA(REPORT NUMBER,PARAMETER NUMBER)
C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
C ARGUMENT MAXD)
C MSTACK - LIST OF DESCRIPTORS AND SCALE VALUES
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
C KDATA(REPORT NUMBER,PARAMETER NUMBER)
C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
C ARGUMENT MAXD)
C MSTACK - LIST OF DESCRIPTORS AND SCALE VALUES
C
C SUBPROGRAMS CALLED:
C LIBRARY:
C W3LIB -
C
C REMARKS: ERROR RETURN:
C IPTR(1) =
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: NAS
C
C$$$
INTEGER IPTR(*)
INTEGER KNR(MAXR)
INTEGER KDATA(MAXR,MAXD),LDATA(MAXD)
INTEGER MSTACK(2,MAXD),LSTACK(2,MAXD)
INTEGER IDENT(*)
C
SAVE
C
C PRINT *,' DATA/DESCRIPTOR REPLICATION '
DO 1000 I = 1, KNR(1)
C IF NOT REPLICATION DESCRIPTOR
IF ((MSTACK(1,I)/16384).NE.1) THEN
GO TO 1000
END IF
C IF DELAYED REPLICATION DESCRIPTOR
IF (MOD(MSTACK(1,I),256).EQ.0) THEN
C SAVE KX VALUE (NR DESC'S TO REPLICATE)
KX = MOD((MSTACK(1,I)/256),64)
C IF NEXT DESC IS NOT 7947 OR 7948
C (I.E., 0 31 011 OR 0 31 012)
IF (MSTACK(1,I+1).NE.7947.AND.MSTACK(1,I+1).NE.7948) THEN
C SKIP IT
GO TO 1000
END IF
C GET NR REPS FROM KDATA
NRREPS = KDATA(1,I+1)
LAST = I + 1 + KX
C SAVE OFF TRAILING DESCS AND DATA
KTRAIL = KNR(1) - I - 1 - KX
DO 100 L = 1, KTRAIL
NX = I + L + KX + 1
LDATA(L) = KDATA(1,NX)
LSTACK(1,L) = MSTACK(1,NX)
LSTACK(2,L) = MSTACK(2,NX)
100 CONTINUE
C INSERT FX DESCS/DATA NR REPS TIMES
LAST = I + 1
DO 400 J = 1, NRREPS
NX = I + 2
DO 300 K = 1, KX
LAST = LAST + 1
KDATA(1,LAST) = KDATA(1,NX)
MSTACK(1,LAST) = MSTACK(1,NX)
MSTACK(2,LAST) = MSTACK(2,NX)
NX = NX + 1
300 CONTINUE
400 CONTINUE
C RESTORE TRAILING DATA/DESCS
DO 500 L = 1, KTRAIL
LAST = LAST + 1
KDATA(1,LAST) = LDATA(L)
MSTACK(1,LAST) = LSTACK(1,L)
MSTACK(2,LAST) = LSTACK(2,L)
500 CONTINUE
C RESET KNR(1)
KNR(1) = LAST
END IF
1000 CONTINUE
RETURN
END
SUBROUTINE FI8812(IPTR,IUNITB,IUNITD,ISTACK,NRDESC,KPTRB,KPTRD,
* IRF1SW,NEWREF,ITBLD,ITBLD2,
* KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
* KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8812 BUILD TABLE B SUBSET BASED ON BUFR SEC 3
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-12-23
C
C ABSTRACT: BUILD A SUBSET OF TABLE B ENTRIES THAT CORRESPOND TO
C THE DESCRIPTORS NEEDED FOR THIS MESSAGE
C
C PROGRAM HISTORY LOG:
C 93-05-12 CAVANAUGH
C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE
C
C USAGE: CALL FI8812(IPTR,IUNITB,IUNITD,ISTACK,NRDESC,KPTRB,KPTRD,
C * IRF1SW,NEWREF,ITBLD,ITBLD2,
C * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
C * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2)
C INPUT ARGUMENT LIST:
C IPTR - SEE W3FI88 ROUTINE DOCBLOCK
C IDENT - SEE W3FI88 ROUTINE DOCBLOCK
C ISTACK - LIST OF DESCRIPTORS AND SCALE VALUES
C IUNITB -
C IUNITD -
C ISTACK -
C NRDESC -
C KFXY2 -
C ANAME2 -
C AUNIT2 -
C ISCAL2 -
C IRFVL2 -
C IWIDE2 -
C IRF1SW -
C NEWREF -
C ITBLD2 -
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
C KDATA(REPORT NUMBER,PARAMETER NUMBER)
C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
C ARGUMENT MAXD)
C MSTACK - LIST OF DESCRIPTORS AND SCALE VALUES
C KFXY1 -
C ANAME1 -
C AUNIT1 -
C ISCAL1 -
C IRFVL1 -
C IWIDE1 -
C ITBLD -
C
C SUBPROGRAMS CALLED:
C LIBRARY:
C W3LIB -
C
C REMARKS: ERROR RETURN:
C IPTR(1) =
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: NAS
C
C$$$
C ..................................................
C
C NEW BASE TABLE B
C MAY BE A COMBINATION OF MASTER TABLE B
C AND ANCILLARY TABLE B
C
INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*)
CHARACTER*40 ANAME1(*)
CHARACTER*24 AUNIT1(*)
C ..................................................
C
C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE
C
INTEGER KFXY2(*),ISCAL2(*),IRFVL2(*),IWIDE2(*)
CHARACTER*64 ANAME2(*)
CHARACTER*24 AUNIT2(*)
C ..................................................
C
C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
C
INTEGER ITBLD2(20,*)
C ..................................................
C
C NEW BASE TABLE D
C
INTEGER ITBLD(20,*)
C ..................................................
INTEGER IPTR(*),ISTACK(*),NRDESC,NWLIST(200)
INTEGER NEWREF(*),KPTRB(*),KPTRD(*)
INTEGER IUNITB,IUNITD,ICOPY(20000),NRCOPY,IELEM,IPOS
CHARACTER*64 AHLD64
CHARACTER*24 AHLD24
C
SAVE
C
C SCAN AND DISCARD REPLICATION AND OPERATOR DESCRIPTORS
C REPLACING SEQUENCE DESCRIPTORS WITH THEIR CORRESPONDING
C SET OF DESCRIPTORS ALSO ELIMINATING DUPLICATES.
C
C-----------------------------------------------------------
C PRINT *,'ENTER FI8812'
C
DO 10 I = 1, 16384
KPTRB(I) = -1
10 CONTINUE
C
C
C
IF (IPTR(14).NE.0) THEN
DO I = 1, IPTR(14)
KPTRB(KFXY1(I)) = I
ENDDO
GO TO 9000
END IF
C
C READ IN TABLE B
PRINT *,'FI8812 - READING TABLE B'
REWIND IUNITB
I = 1
4000 CONTINUE
C
READ(UNIT=IUNITB,FMT=20,ERR=9999,END=9000)MF,
* MX,MY,
* (ANAME1(I)(K:K),K=1,40),
* (AUNIT1(I)(K:K),K=1,24),
* ISCAL1(I),IRFVL1(1,I),IWIDE1(I)
20 FORMAT(I1,I2,I3,40A1,24A1,I5,I15,1X,I4)
KFXY1(I) = MF*16384 + MX*256 + MY
C PRINT *,MF,MX,MY,KFXY1(I)
5000 CONTINUE
KPTRB(KFXY1(I)) = I
IPTR(14) = I
C PRINT *,I
C WRITE(6,21) MF,MX,MY,KFXY1(I),
C * (ANAME1(I)(K:K),K=1,40),
C * (AUNIT1(I)(K:K),K=1,24),
C * ISCAL1(I),IRFVL1(1,I),IWIDE1(I)
21 FORMAT(1X,I1,I2,I3,1X,I6,1X,40A1,
* 2X,24A1,2X,I5,2X,I15,1X,I4)
I = I + 1
GO TO 4000
C ======================================================
9999 CONTINUE
C ERROR READING TABLE B
PRINT *,'FI8812 - ERROR READING TABLE B - RECORD ',I
IPTR(1) = 9
9000 CONTINUE
IPTR(21) = IPTR(14)
C PRINT *,'EXIT FI8812 - IPTR(21) =',IPTR(21),' IPTR(1) =',IPTR(1)
RETURN
END
SUBROUTINE FI8813 (IPTR,MAXR,MAXD,MSTACK,KDATA,IDENT,KPTRD,KPTRB,
* ITBLD,ANAME1,AUNIT1,KFXY1,ISCAL1,IRFVL1,IWIDE1,IUNITB)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8813 EXTRACT TABLE A, TABLE B, TABLE D ENTRIES
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-03-04
C
C ABSTRACT: EXTRACT TABLE A, TABLE B, TABLE D ENTRIES FROM A
C DECODED BUFR MESSAGE.
C
C PROGRAM HISTORY LOG:
C 94-03-04 CAVANAUGH
C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
C
C USAGE: CALL FI8813 (IPTR,MAXR,MAXD,MSTACK,KDATA,IDENT,KPTRD,
C * KPTRB,ITBLD,ANAME1,AUNIT1,KFXY1,ISCAL1,IRFVL1,IWIDE1,IUNITB)
C INPUT ARGUMENT LIST:
C IPTR
C MAXR
C MAXD
C MSTACK
C KDATA
C IDENT
C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C OUTPUT ARGUMENT LIST:
C IUNITB
C ITBLD1
C ANAME1
C AUNIT1
C KFXY1
C ISCAL1
C IRFVL1
C IWIDE1
C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE.
C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN
C ERRFLAG - EVEN IF MANY LINES ARE NEEDED
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS
C MACHINE: NAS, CYBER, WHATEVER
C
C$$$
C ..................................................
C
C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE
C
INTEGER KFXY1(*),ISCAL1(*),IRFVL1(*),IWIDE1(*)
CHARACTER*40 ANAME1(*)
CHARACTER*24 AUNIT1(*)
C ..................................................
C
C TABLE D
C
INTEGER ITBLD(20,*)
C ..................................................
CHARACTER*32 SPACES
CHARACTER*8 ASCCHR
CHARACTER*32 AAAA
C
INTEGER I1(20),I2(20),I3(20),KPTRB(*)
INTEGER IPTR(*),MAXR,MAXD,MSTACK(2,MAXD)
INTEGER IXA, IXB, IXD, KDATA(MAXR,MAXD)
INTEGER IEXTRA,KPTRD(*)
INTEGER KEYSET,ISCSGN(200),IRFSGN(200)
INTEGER IDENT(*),IHOLD,JHOLD(8),IUNITB
EQUIVALENCE (IHOLD,ASCCHR),(JHOLD,AAAA)
SAVE
DATA SPACES/' '/
DATA IEXTRA/0/
DATA KEYSET/0/
C ==============================================================
C PRINT *,'FI8813',IPTR(41),IPTR(42),IPTR(31),IPTR(21)
C BUILD SPACE CONSTANT
C INITIALIZE ENTRY COUNTS
IXA = 0
C NUMBER IN TABLE B
IXB = IPTR(21)
C
C
C SET FOR COMPRESSED OR NON COMPRESSED
C PROCESSING
C
C PRINT *,'FI8813 - 2',IDENT(16),IDENT(14)
IF (IDENT(16).EQ.0) THEN
JK = 1
ELSE
JK = IDENT(14)
END IF
C PRINT *,'FI8813 - 3, JK=',JK
C
C
C START PROCESSING ENTRIES
C PRINT *,'START PROCESSING ENTRIES'
C
C DO 995 I = 1, IPTR(31)
C IF (IPTR(45).EQ.4) THEN
C PRINT 9958,I,MSTACK(1,I),KDATA(1,I),KDATA(1,I)
C9958 FORMAT (1X,I5,2X,I5,2X,Z8,2X,A4)
C ELSE
C PRINT 9959,I,MSTACK(1,I),KDATA(1,I),KDATA(1,I)
C9959 FORMAT (1X,I5,2X,I5,2X,Z16,2X,A8)
C END IF
C 995 CONTINUE
C PRINT *,' '
I = 0
IEXTRA = 0
1000 CONTINUE
C
C SET POINTER TO CORRECT DATA POSITION
C I IS THE NUMBER OF DESCRIPTORS
C IEXTRA IS THE NUMBER OF WORDS ADDED
C FOR TEXT DATA
C
I = I + 1
IF (I.GT.IPTR(31)) THEN
C RETURN IF COMPLETED SEARCH
GO TO 9000
END IF
KLK = I + IEXTRA
C PRINT *,'ENTRY',KLK,I,IPTR(31),IEXTRA,MSTACK(1,KLK)
C
C IF TABLE A ENTRY OR EDITION NUMBER
C OR IF DESCRIPTOR IS NOT IN CLASS 0
C SKIP OVER
C
IF (MSTACK(1,KLK).EQ.1) THEN
C PRINT *,'A ENTRY'
GO TO 1000
ELSE IF (MSTACK(1,KLK).EQ.2) THEN
C PRINT *,'A ENTRY LINE 1'
IEXTRA = IEXTRA + 32 / IPTR(45) - 1
GO TO 1000
ELSE IF (MSTACK(1,KLK).EQ.3) THEN
C PRINT *,'A ENTRY LINE 2'
IEXTRA = IEXTRA + 32 / IPTR(45) - 1
GO TO 1000
ELSE IF (MSTACK(1,KLK).GE.34048.AND.MSTACK(1,KLK).LE.34303) THEN
LY = MOD(MSTACK(1,KLK),256)
C PRINT *,'CLASS C - HAVE',LY,' BYTES OF TEXT'
IF (MOD(LY,IPTR(45)).EQ.0) THEN
IWDS = LY / IPTR(45)
ELSE
IWDS = LY / IPTR(45) + 1
END IF
IEXTRA = IEXTRA + IWDS - 1
GO TO 1000
ELSE IF (MSTACK(1,KLK).LT.10.OR.MSTACK(1,KLK).GT.255) THEN
C PRINT *,MSTACK(1,KLK),' NOT CLASS 0'
GO TO 1000
END IF
C
C MUST FIND F X Y KEY FOR TABLE B
C OR TABLE D ENTRY
C
IZ = 1
KEYSET = 0
10 CONTINUE
IF (I.GT.IPTR(31)) THEN
GO TO 9000
END IF
KLK = I + IEXTRA
IF (MSTACK(1,KLK).GE.34048.AND.MSTACK(1,KLK).LE.34303) THEN
LY = MOD(MSTACK(1,KLK),256)
C PRINT *,'TABLE C - HAVE',LY,' TEXT BYTES'
IF (MOD(LY,4).EQ.0) THEN
IWDS = LY / IPTR(45)
ELSE
IWDS = LY / IPTR(45) + 1
END IF
IEXTRA = IEXTRA + IWDS - 1
I = I + 1
GO TO 10
ELSE IF (MSTACK(1,KLK)/16384.NE.0) THEN
IF (MOD(MSTACK(1,KLK),256).EQ.0) THEN
I = I + 1
END IF
I = I + 1
GO TO 10
END IF
IF (MSTACK(1,KLK).GE.10.AND.MSTACK(1,KLK).LE.12) THEN
C PRINT *,'FIND KEY'
C
C MUST INCLUDE PROCESSING FOR COMPRESSED DATA
C
C BUILD DESCRIPTOR SEGMENT
C
IF (MSTACK(1,KLK).EQ.10) THEN
CALL FI8814 (KDATA(IZ,KLK),1,MF,IERR,IPTR)
C PRINT *,'F =',MF,KDATA(IZ,KLK),IPTR(31),I,IEXTRA
KEYSET = IOR(KEYSET,4)
ELSE IF (MSTACK(1,KLK).EQ.11) THEN
CALL FI8814 (KDATA(IZ,KLK),2,MX,IERR,IPTR)
C PRINT *,'X =',MX,KDATA(IZ1,KLK)
KEYSET = IOR(KEYSET,2)
ELSE IF (MSTACK(1,KLK).EQ.12) THEN
CALL FI8814 (KDATA(IZ,KLK),3,MY,IERR,IPTR)
C PRINT *,'Y =',MY,KDATA(IZ,KLK)
KEYSET = IOR(KEYSET,1)
END IF
C PRINT *,' KEYSET =',KEYSET
I = I + 1
GO TO 10
END IF
IF (KEYSET.EQ.7) THEN
C PRINT *,'HAVE KEY DESCRIPTOR',MF,MX,MY
C
C TEST NEXT DESCRIPTOR FOR TABLE B
C OR TABLE D ENTRY, PROCESS ACCORDINGLY
C
KLK = I + IEXTRA
C PRINT *,'DESC ',MSTACK(1,KLK),KLK,I,IEXTRA,KDATA(1,KLK)
IF (MSTACK(1,KLK).EQ.30) THEN
IXD = IPTR(20) + 1
ITBLD(1,IXD) =16384 * MF + 256 * MX + MY
C PRINT *,'SEQUENCE DESCRIPTOR',MF,MX,MY,ITBLD(1,IXD)
GO TO 300
ELSE IF (MSTACK(1,KLK).GE.13.AND.MSTACK(1,KLK).LE.20) THEN
KFXY1(IXB+IZ) = 16384 * MF + 256 * MX + MY
C PRINT *,'ELEMENT DESCRIPTOR',MF,MX,MY,KFXY1(IXB+IZ),IXB+IZ
KPTRB(KFXY1(IXB+IZ)) = IXB+IZ
GO TO 200
ELSE
END IF
C I = I + 1
C IF (I.GT.IPTR(31)) THEN
C GO TO 9000
C END IF
C GO TO 10
END IF
GO TO 1000
C ==================================================================
200 CONTINUE
IBFLAG = 1
20 CONTINUE
KLK = I + IEXTRA
C PRINT *,'ZZZ',KLK,I,IEXTRA,MSTACK(1,KLK),KDATA(IZ,KLK)
IF (MSTACK(1,KLK).LT.13.OR.MSTACK(1,KLK).GT.20) THEN
PRINT *,'IMPROPER SEQUENCE OF DESCRIPTORS IN LIST'
C ===============================================================
ELSE IF (MSTACK(1,KLK).EQ.13) THEN
C PRINT *,'13 NAME',KLK
C
C ELEMENT NAME PART 1 - 32 BYTES
C FOR THIS PARAMETER
JJ = IEXTRA
DO 21 LL = 1, 32, IPTR(45)
LLL = LL + IPTR(45) - 1
KQK = I + JJ
IHOLD = KDATA(IZ,KQK)
IF (IPTR(37).EQ.0) THEN
C CALL W3AI39 (IDATA,IPTR(45))
END IF
ANAME1(IXB+IZ)(LL:LLL) = ASCCHR
JJ = JJ + 1
21 CONTINUE
IEXTRA = IEXTRA + (32 / IPTR(45)) - 1
IBFLAG = IOR(IBFLAG,64)
C ===============================================================
ELSE IF (MSTACK(1,KLK).EQ.14) THEN
C PRINT *,'14 NAME2',KLK
C
C ELEMENT NAME PART 2 - 32 BYTES
C
C FOR THIS PARAMETER
JJ = IEXTRA
DO 22 LL = 33, 64, IPTR(45)
LLL = LL + IPTR(45) - 1
KQK = I + JJ
IHOLD = KDATA(IZ,KQK)
IF (IPTR(37).EQ.0) THEN
C CALL W3AI39 (ASCCHR,IPTR(45))
END IF
ANAME1(IXB+IZ)(LL:LLL) = ASCCHR
JJ = JJ + 1
22 CONTINUE
IEXTRA = IEXTRA + (32 / IPTR(45)) - 1
IBFLAG = IOR(IBFLAG,32)
C ===============================================================
ELSE IF (MSTACK(1,KLK).EQ.15) THEN
C PRINT *,'15 UNITS',KLK
C
C UNITS NAME - 24 BYTES
C
C FOR THIS PARAMETER
JJ = IEXTRA
DO 23 LL = 1, 24, IPTR(45)
LLL = LL + IPTR(45) - 1
KQK = I + JJ
IHOLD = KDATA(IZ,KQK)
IF (IPTR(37).EQ.0) THEN
C CALL W3AI39 (ASCCHR,IPTR(45))
END IF
AUNIT1(IXB+IZ)(LL:LLL) = ASCCHR
JJ = JJ + 1
23 CONTINUE
IEXTRA = IEXTRA + (24 / IPTR(45)) - 1
IBFLAG = IOR(IBFLAG,16)
C ===============================================================
ELSE IF (MSTACK(1,KLK).EQ.16) THEN
C PRINT *,'16 SCALE SIGN'
C
C SCALE SIGN - 1 BYTE
C 0 = POS, 1 = NEG
IHOLD = KDATA(IZ,KLK)
KLK = I + IEXTRA
IF (INDEX(ASCCHR,'-').EQ.0) THEN
ISCSGN(IZ) = 1
ELSE
ISCSGN(IZ) = -1
END IF
C ===============================================================
ELSE IF (MSTACK(1,KLK).EQ.17) THEN
C PRINT *,'17 SCALE',KLK
C
C SCALE - 3 BYTES
C
KLK = I + IEXTRA
CALL FI8814(KDATA(IZ,KLK),3,ISCAL1(IXB+IZ),IERR,IPTR)
IF (IERR.NE.0) THEN
PRINT *,'NON-NUMERIC CHAR - CANNOT CONVERT'
IPTR(1) = 888
GO TO 9000
END IF
ISCAL1(IXB+IZ) = ISCAL1(IXB+IZ) * ISCSGN(IZ)
IBFLAG = IOR(IBFLAG,8)
C ===============================================================
ELSE IF (MSTACK(1,KLK).EQ.18) THEN
C PRINT *,'18 REFERENCE SCALE',KLK
C
C REFERENCE SIGN - 1 BYTE
C 0 = POS, 1 = NEG
C
KLK = I + IEXTRA
IHOLD = KDATA(IZ,KLK)
IF (INDEX(ASCCHR,'-').EQ.0) THEN
IRFSGN(IZ) = 1
ELSE
IRFSGN(IZ) = -1
END IF
C ===============================================================
ELSE IF (MSTACK(1,KLK).EQ.19) THEN
C PRINT *,'19 REFERENCE VALUE',KLK
C
C REFERENCE VALUE - 10 BYTES/ 3 WDS
C
JJ = IEXTRA
KQK = I + JJ
KM = 0
DO 26 LL = 1, 12, IPTR(45)
KQK = I + JJ
KM = KM + 1
JHOLD(KM) = KDATA(IZ,KQK)
JJ = JJ + 1
26 CONTINUE
CALL FI8814(AAAA,10,IRFVL1(IXB+IZ),IERR,IPTR)
IF (IERR.NE.0) THEN
PRINT *,'NON-NUMERIC CHARACTER-CANNOT CONVERT'
IPTR(1) = 888
GO TO 9000
END IF
IRFVL1(IXB+IZ) = IRFVL1(IXB+IZ) * IRFSGN(IZ)
IEXTRA = IEXTRA + 10 / IPTR(45)
C DO 261 IZ = 1, JK
C PRINT *,'RFVAL',IXB+IZ,JK,IRFVL1(IXB+IZ)
C 261 CONTINUE
IBFLAG = IOR(IBFLAG,4)
C ===============================================================
ELSE
C PRINT *,'20 WIDTH',KLK
C
C ELEMENT DATA WIDTH - 3 BYTES
C
C DO 27 LL = 1, 24, IPTR(45)
KLK = I + IEXTRA
C DO 270 IZ = 1, JK
CALL FI8814(KDATA(IZ,KLK),3,IWIDE1(IXB+IZ),IERR,IPTR)
IF (IERR.NE.0) THEN
PRINT *,'NON-NUMERIC CHAR - CANNOT CONVERT'
IPTR(1) = 888
GO TO 9000
END IF
IF (IWIDE1(IXB+IZ).LT.1) THEN
IPTR(1) = 890
C PRINT *,'CLASS 0 DESCRIPTOR, WIDTH=0',KFXY1(IXB+IZ)
GO TO 9000
END IF
C 270 CONTINUE
C 27 CONTINUE
IBFLAG = IOR(IBFLAG,2)
END IF
C NO, IT ISN'T
C
C IF THERE ARE ENOUGH OF THE ELEMENTS
C NECESSARY TO ACCEPT A TABLE B ENTRY
C
C PRINT *,' IBFLAG =',IBFLAG
IF (IBFLAG.EQ.127) THEN
C PRINT *,'COMPLETE TABLE B ENTRY'
C HAVE A COMPLETE TABLE B ENTRY
IXB = IXB + 1
C PRINT *,'B',IXB,JK,KFXY1(IXB),ANAME1(IXB)
C PRINT *,' ',AUNIT1(IXB),ISCAL1(IXB),
C * IRFVL1(IXB),IWIDE1(IXB)
IPTR(21) = IXB
GO TO 1000
END IF
I = I + 1
C
C CHECK NEXT DESCRIPTOR
C
IF (I.GT.IPTR(31)) THEN
C RETURN IF COMPLETED SEARCH
GO TO 9000
END IF
GO TO 20
C ==================================================================
300 CONTINUE
ISEQ = 0
IJK = IPTR(20) + 1
C PRINT *,'SEQUENCE DESCRIPTOR',MF,MX,MY,ITBLD(1,IXD),' FOR',IJK
30 CONTINUE
KLK = I + IEXTRA
C PRINT *,'HAVE A SEQUENCE DESCRIPTOR',KLK,KDATA(IZ,KLK)
IF (MSTACK(1,KLK).EQ.30) THEN
C FROM TEXT FIELD (6 BYTES/2 WDS)
C STRIP OUT NEXT DESCRIPTOR IN SEQUENCE
C
C F - EXTRACT AND CONVERT TO DECIMAL
JJ = IEXTRA
KK = 0
DO 351 LL = 1, 6, IPTR(45)
KQK = I + JJ
KK = KK + 1
JHOLD(KK) = KDATA(1,KQK)
JJ = JJ + 1
IF (LL.GT.1) IEXTRA = IEXTRA + 1
351 CONTINUE
C PRINT 349,KDATA(1,KQK)
349 FORMAT (6X,Z24)
C CONVERT TO INTEGER
CALL FI8814(AAAA,6,IHOLD,IERR,IPTR)
C PRINT *,' ',IHOLD
IF (IERR.NE.0) THEN
PRINT *,'NON NUMERIC CHARACTER FOUND IN F X Y'
IPTR(1) = 888
GO TO 9000
END IF
C CONSTRUCT SEQUENCE DESCRIPTOR
IFF = IHOLD / 100000
IXX = MOD((IHOLD/1300),100)
IYY = MOD(IHOLD,1300)
C INSERT IN PROPER SEQUENCE
ITBLD(ISEQ+2,IJK) = 16384 * IFF + 256 * IXX + IYY
C PRINT *,' SEQUENCE',IZ,AAAA,IHOLD,ITBLD(ISEQ+2,IJK),
C * IFF,IXX,IYY
ISEQ = ISEQ + 1
IF (ISEQ.GT.18) THEN
IPTR(1) = 30
RETURN
END IF
C SET TO LOOK AT NEXT DESCRIPTOR
I = I + 1
C IF (IPTR(45).LT.6) THEN
C IEXTRA = IEXTRA + 1
C END IF
GO TO 30
ELSE
C NEXT DESCRIPTOR IS NOT A SEQUENCE DESCRIPTOR
IF (ISEQ.GE.1) THEN
C HAVE COMPLETE TABLE D ENTRY
IPTR(20) = IPTR(20) + 1
C PRINT *,' INTO LOCATION ',IPTR(20)
LZ = ITBLD(1,IJK)
MZ = MOD(LZ,16384)
KPTRD(MZ) = IJK
I = I - 1
END IF
END IF
C GO TEST NEXT DESCRIPTOR
GO TO 1000
C ==================================================================
9000 CONTINUE
C PRINT *,IPTR(21),' ENTRIES IN ANCILLARY TABLE B'
C PRINT *,IPTR(20),' ENTRIES IN ANCILLARY TABLE D'
C DO 9050 L = 1, 16384
C IF (KPTRD(L).GT.0) PRINT *,' D',L+32768, KPTRD(L)
C9050 CONTINUE
C IF (I.GE.IPTR(31)) THEN
C
C FILE FOR MODIFIED TABLE B OUTPUT
NUMNUT = IUNITB + 1
REWIND NUMNUT
C
C PRINT *,' HERE IS THE NEW TABLE B',IPTR(21)
DO 2000 KB = 1, IPTR(21)
JF = KFXY1(KB) / 16384
JX = MOD((KFXY1(KB) / 256),64)
JY = MOD(KFXY1(KB),256)
C WRITE (6,2001)JF,JX,JY,ANAME1(KB),
C * AUNIT1(KB),ISCAL1(KB),IRFVL1(KB),IWIDE1(KB)
WRITE (NUMNUT,5000)JF,JX,JY,ANAME1(KB)(1:40),
* AUNIT1(KB)(1:24),ISCAL1(KB),IRFVL1(KB),IWIDE1(KB)
5000 FORMAT(I1,I2,I3,A40,A24,I5,I15,I5)
2000 CONTINUE
2001 FORMAT (1X,I1,1X,I2,1X,I3,2X,A40,3X,A24,2X,I5,2X,I12,
* 2X,I4)
C
ENDFILE NUMNUT
C
IF (IPTR(20).NE.0) THEN
C PRINT OUT TABLE
C PRINT *,' HERE IS THE UPGRADED TABLE D'
C DO 3000 KB = 1, IPTR(20)
C PRINT 3001,KB,(ITBLD(K,KB),K=1,15)
C3000 CONTINUE
C3001 FORMAT (16(1X,I5))
END IF
C EXIT ROUTINE, ALL DONE WITH PASS
C END IF
RETURN
END
SUBROUTINE FI8814 (ASCCHR,NPOS,NEWVAL,IERR,IPTR)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8814 CONVERT TEXT TO INTEGER
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-03-04
C
C ABSTRACT: CONVERT TEXT CHARACTERS TO INTEGER VALUE
C
C PROGRAM HISTORY LOG:
C 94-03-04 CAVANAUGH
C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE
C
C USAGE: CALL FI8814 (ASCCHR,NPOS,NEWVAL,IERR,IPTR)
C INPUT ARGUMENT LIST:
C ASCCHR -
C NPOS -
C NEWVAL -
C IERR -
C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE.
C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN
C ERRFLAG - EVEN IF MANY LINES ARE NEEDED
C
C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM)
C DDNAME1 - GENERIC NAME & CONTENT
C
C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
C DDNAME2 - GENERIC NAME & CONTENT AS ABOVE
C FT06F001 - INCLUDE IF ANY PRINTOUT
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS
C MACHINE: NAS, CYBER, WHATEVER
C
C$$$
INTEGER IERR, IHOLD, IPTR(*)
CHARACTER*8 AHOLD
CHARACTER*64 ASCCHR
EQUIVALENCE (IHOLD,AHOLD)
SAVE
C ----------------------------------------------------------
IERR = 0
NEWVAL = 0
IFLAG = 0
C
DO 1000 I = 1, NPOS
IHOLD = 0
AHOLD(IPTR(45):IPTR(45)) = ASCCHR(I:I)
IF (IPTR(37).EQ.1) THEN
IF (IHOLD.EQ.32) THEN
IF (IFLAG.EQ.0) GO TO 1000
GO TO 2000
ELSE IF (IHOLD.LT.48.OR.IHOLD.GT.57) THEN
C PRINT*,' ASCII IHOLD =',IHOLD
IERR = 1
RETURN
ELSE
IFLAG = 1
NEWVAL = NEWVAL * 10 + IHOLD - 48
END IF
ELSE
IF (IHOLD.EQ.64) THEN
IF (IFLAG.EQ.0) GO TO 1000
GO TO 2000
ELSE IF (IHOLD.LT.240.OR.IHOLD.GT.249) THEN
C PRINT*,' EBCIDIC IHOLD =',IHOLD
IERR = 1
RETURN
ELSE
IFLAG = 1
NEWVAL = NEWVAL * 10 + IHOLD - 240
END IF
END IF
1000 CONTINUE
2000 CONTINUE
RETURN
END
SUBROUTINE FI8815(IPTR,IDENT,JDESC,KDATA,KFXY3,MAXR,MAXD,
* ANAME3,AUNIT3,
* ISCAL3,IRFVL3,IWIDE3,
* KEYSET,IBFLAG,IERR)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8815 EXTRACT TABLE A, TABLE B, TABLE D ENTRIES
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-03-04
C
C ABSTRACT: EXTRACT TABLE A, TABLE B, ENTRIES FROM ACTIVE BUFR MESSAGE
C TO BE RETAINED FOR USE DURING THE DECODING OF ACTIVE BUFR MESSAGE.
C THESE WILL BE DISCARDED WHEN DECODING OF CURRENT MESSAGE IS COMPLETE
C
C PROGRAM HISTORY LOG:
C 94-03-04 CAVANAUGH
C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
C
C USAGE: CALL FI8815(IPTR,IDENT,JDESC,KDATA,KFXY3,MAXR,MAXD,
C * ANAME3,AUNIT3,
C * ISCAL3,IRFVL3,IWIDE3,
C * KEYSET,IBFLAG,IERR)
C INPUT ARGUMENT LIST:
C IPTR -
C MAXR -
C MAXD -
C MSTACK -
C KDATA -
C IDENT -
C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE.
C
C OUTPUT ARGUMENT LIST:
C ANAME3 -
C AUNIT3 -
C KFXY3 -
C ISCAL3 -
C IRFVL3 -
C IWIDE3 -
C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE.
C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN
C ERRFLAG - EVEN IF MANY LINES ARE NEEDED
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS
C MACHINE: NAS, CYBER
C
C$$$
CHARACTER*64 ANAME3(*),SPACES
CHARACTER*24 AUNIT3(*)
C
INTEGER IPTR(*),MAXR,MAXD,JDESC
INTEGER IXA, IXB, IXD, KDATA(MAXR,MAXD)
INTEGER IEXTRA
INTEGER KEYSET
INTEGER KFXY3(*),IDENT(*)
INTEGER ISCAL3(*),ISCSGN(150)
INTEGER IRFVL3(*),IRFSGN(150)
INTEGER IWIDE3(*)
SAVE
C ==============================================================
C PRINT *,'FI8815'
IEXTRA = 0
C BUILD SPACE CONSTANT
DO 1 I = 1, 64
SPACES(I:I) = ' '
1 CONTINUE
C INITIALIZE ENTRY COUNTS
IXA = 0
IXB = 0
IXD = 0
C
C SET FOR COMPRESSED OR NON COMPRESSED
C PROCESSING
C
IF (IDENT(16).EQ.0) THEN
JK = 1
ELSE
JK = IDENT(14)
END IF
C
C CLEAR NECESSARY ENTRIES
C
DO 2 IY = 1, JK
C
C CLEAR NEXT TABLE B ENTRY
C
KFXY3(IXB+IY) = 0
ANAME3(IXB+IY)(1:64) = SPACES(1:64)
AUNIT3(IXB+IY)(1:24) = SPACES(1:24)
ISCAL3(IXB+IY) = 0
IRFVL3(IXB+IY) = 0
IWIDE3(IXB+IY) = 0
ISCSGN(IY) = 1
IRFSGN(IY) = 1
2 CONTINUE
C
C START PROCESSING ENTRIES
C
I = 0
1000 CONTINUE
C
C SET POINTER TO CORRECT DATA POSITION
C
K = I + IEXTRA
C
C MUST FIND F X Y KEY FOR TABLE B
C OR TABLE D ENTRY
C
IF (JDESC.GE.10.AND.JDESC.LE.12) THEN
10 CONTINUE
C
C BUILD DESCRIPTOR SEGMENT
C
DO 20 LY = 1,JK
IF (JDESC.EQ.10) THEN
KFXY3(IXB+LY) = KDATA(K,1) * 16384 + KFXY3(IXB+LY)
KEYSET = IOR(KEYSET,4)
I = I + 1
GO TO 10
ELSE IF (JDESC.EQ.11) THEN
KFXY3(IXB+LY) = KDATA(K,1) * 256 + KFXY3(IXB+LY)
KEYSET = IOR(KEYSET,2)
I = I + 1
GO TO 10
ELSE IF (JDESC.EQ.12) THEN
KFXY3(IXB+LY) = KDATA(K,1) + KFXY3(IXB+LY)
KEYSET = IOR(KEYSET,1)
END IF
20 CONTINUE
C ==================================================================
ELSE IF (JDESC.GE.13.AND.JDESC.LE.20) THEN
DO 250 IZ = 1, JK
IF (JDESC.EQ.13) THEN
C
C ELEMENT NAME PART 1 - 32 BYTES/8 WDS
C
CALL GBYTES (ANAME3(IXB+IZ),KDATA(K,IZ),0,32,0,8)
IBFLAG = IOR(IBFLAG,16)
ELSE IF (JDESC.EQ.14) THEN
C
C ELEMENT NAME PART 2 - 32 BYTES/8 WDS
C
CALL GBYTES(ANAME3(IXB+IZ)(33:33),KDATA(K,IZ),0,32,0,8)
ELSE IF (JDESC.EQ.15) THEN
C
C UNITS NAME - 24 BYTES/6 WDS
C
CALL GBYTES (AUNIT3(IXB+IZ)(1:1),KDATA(K,IZ),0,32,0,6)
IBFLAG = IOR(IBFLAG,8)
ELSE IF (JDESC.EQ.16) THEN
C
C UNITS SCALE SIGN - 1 BYTE/ 1 WD
C 0 = POS, 1 = NEG
IF (KDATA(K,1).NE.48) THEN
ISCSGN(IZ) = -1
ELSE
ISCSGN(IZ) = 1
END IF
ELSE IF (JDESC.EQ.17) THEN
C
C UNITS SCALE - 3 BYTES/ 1 WD
C
CALL FI8814(KDATA(K,IZ),3,ISCAL3(IXB+IZ),IERR,IPTR)
IF (IERR.NE.0) THEN
PRINT *,'NON-NUMERIC CHARACTER - CANNOT CONVERT'
IPTR(1) = 888
RETURN
END IF
IBFLAG = IOR(IBFLAG,4)
ELSE IF (JDESC.EQ.18) THEN
C
C UNITS REFERENCE SIGN - 1 BYTE/ 1 WD
C 0 = POS, 1 = NEG
C
IF (KDATA(K,1).EQ.48) THEN
IRFSGN(IZ) = 1
ELSE
IRFSGN(IZ) = -1
END IF
ELSE IF (JDESC.EQ.19) THEN
C
C UNITS REFERENCE VALUE - 10 BYTES/ 3 WDS
C
CALL FI8814(KDATA(K,IZ),10,IRFVL3(IXB+IZ),IERR,IPTR)
IF (IERR.NE.0) THEN
PRINT *,'NON-NUMERIC CHARACTER-CANNOT CONVERT'
IPTR(1) = 888
RETURN
END IF
IBFLAG = IOR(IBFLAG,2)
ELSE
C
C ELEMENT DATA WIDTH - 3 BYTES/ 1 WD
C
CALL FI8814(KDATA(K,1),3,IWIDE3(IXB+1),IERR,IPTR)
IF (IERR.NE.0) THEN
PRINT *,'NON-NUMERIC CHARACTER-CANNOT CONVERT'
IPTR(1) = 888
RETURN
END IF
IBFLAG = IOR(IBFLAG,1)
END IF
250 CONTINUE
END IF
C ==================================================================
9000 RETURN
END
SUBROUTINE FI8818(IPTR,
* KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
* KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,
* KPTRB)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8818 MERGE ANCILLARY & STANDARD B ENTRIES
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: YY-MM-DD
C
C ABSTRACT: START ABSTRACT HERE AND INDENT TO COLUMN 5 ON THE
C FOLLOWING LINES. SEE NMC HANDBOOK SECTION 3.1.1. FOR DETAILS
C
C PROGRAM HISTORY LOG:
C YY-MM-DD CAVANAUGH
C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
C
C USAGE: CALL FI8818(IPTR,
C * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
C * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,KPTRB)
C INPUT ARGUMENT LIST:
C IPTR -
C KFXY1 -
C ANAME1 -
C AUNIT1 -
C ISCAL1 -
C IRFVL1 -
C IWIDE1 -
C KFXY2 -
C ANAME2 -
C AUNIT2 -
C ISCAL2 -
C IRFVL2 -
C IWIDE2 -
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C IPTR -
C KFXY1 -
C ANAME1 -
C AUNIT1 -
C ISCAL1 -
C IRFVL1 -
C IWIDE1 -
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS
C MACHINE: NAS, CYBER, WHATEVER
C
C$$$
C ..................................................
C
C NEW BASE TABLE B
C MAY BE A COMBINATION OF MASTER TABLE B
C AND ANCILLARY TABLE B
C
INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*)
CHARACTER*40 ANAME1(*)
CHARACTER*24 AUNIT1(*)
C ..................................................
C
C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE
C
INTEGER KFXY2(*),ISCAL2(*),IRFVL2(*),IWIDE2(*)
CHARACTER*64 ANAME2(*)
CHARACTER*24 AUNIT2(*)
C ..................................................
INTEGER IPTR(*),KPTRB(*)
SAVE
C
C SET UP POINTERS
C PRINT *,'FI8818-A',IPTR(21),IPTR(41)
KAB = 1
KB = 1
1000 CONTINUE
C PRINT *,KB,KAB,KFXY1(KB),KFXY2(KAB),IPTR(21)
IF (KB.GT.IPTR(21)) THEN
C NO MORE MASTER ENTRIES
C PRINT *,'NO MORE MASTER ENTRIES'
IF (KAB.GT.IPTR(41)) THEN
GO TO 5000
END IF
C APPEND ANCILLARY ENTRY
GO TO 2000
ELSE IF (KB.LE.IPTR(21)) THEN
C HAVE MORE MASTER ENTRIES
IF (KAB.GT.IPTR(41)) THEN
C NO MORE ANCILLARY ENTRIES
GO TO 5000
END IF
IF (KFXY2(KAB).EQ.KFXY1(KB)) THEN
C REPLACE MASTER ENTRY
GO TO 3000
ELSE IF (KFXY2(KAB).LT.KFXY1(KB)) THEN
C INSERT ANCILLARY ENTRY
GO TO 2000
ELSE IF (KFXY2(KAB).GT.KFXY1(KB)) THEN
C SKIP MASTER ENTRY
KB = KB + 1
END IF
END IF
GO TO 1000
2000 CONTINUE
IPTR(21) = IPTR(21) + 1
KPTRB(KFXY2(KAB)) = IPTR(21)
C APPEND ANCILLARY ENTRY
KFXY1(IPTR(21)) = KFXY2(KAB)
ANAME1(IPTR(21))(1:40) = ANAME2(KAB)(1:40)
AUNIT1(IPTR(21)) = AUNIT2(KAB)
ISCAL1(IPTR(21)) = ISCAL2(KAB)
IRFVL1(1,IPTR(21)) = IRFVL2(KAB)
IWIDE1(IPTR(21)) = IWIDE2(KAB)
C PRINT *,IPTR(21),KFXY1(IPTR(21)),' APPENDED'
KAB = KAB + 1
GO TO 1000
3000 CONTINUE
C REPLACE MASTER ENTRY
KFXY1(KB) = KFXY2(KAB)
ANAME1(KB) = ANAME2(KAB)(1:40)
AUNIT1(KB) = AUNIT2(KAB)
ISCAL1(KB) = ISCAL2(KAB)
IRFVL1(1,KB) = IRFVL2(KAB)
IWIDE1(KB) = IWIDE2(KAB)
C PRINT *,KB,KFXY1(KB),'REPLACED',IWIDE1(KB)
KAB = KAB + 1
KB = KB + 1
GO TO 1000
5000 CONTINUE
IPTR(41) = 0
C PROCESSING COMPLETE
C PRINT *,'FI8818-B',IPTR(21),IPTR(41)
C DO 6000 I = 1, IPTR(21)
C PRINT *,'FI8818-C',I,KFXY1(I),IWIDE1(I)
C6000 CONTINUE
RETURN
END
SUBROUTINE FI8819(IPTR,ITBLD,ITBLD2,KPTRD)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8819 MERGE ANCILLARY & MASTER TABLE D
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: YY-MM-DD
C
C ABSTRACT: MERGE TABLE D ENTRIES WITH THE ENTRIES FROM THE STANDARD
C TABLE D. ASSURE THAT ENTRIES ARE SEQUENTIAL.
C
C PROGRAM HISTORY LOG:
C YY-MM-DD CAVANAUGH
C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
C
C USAGE: CALL FI8819(IPTR,ITBLD,ITBLD2,KPTRD)
C INPUT ARGUMENT LIST:
C IPTR -
C ITBLD -
C ITBLD2 -
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C IPTR -
C ITBLD -
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: NAS, CYBER
C
C$$$
C ..................................................
C
C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
C
INTEGER ITBLD2(20,*)
C ..................................................
C
C NEW BASE TABLE D
C
INTEGER ITBLD(20,*)
C ..................................................
INTEGER IPTR(*),KPTRD(*)
SAVE
C PRINT *,'FI8819-A',IPTR(20),IPTR(42)
C SET UP POINTERS
DO 1000 I = 1, IPTR(42)
IPTR(20) = IPTR(20) + 1
DO 500 J = 1, 20
ITBLD(J,IPTR(20)) = ITBLD2(J,I)
MPTRD = MOD(ITBLD(J,IPTR(20)),16384)
KPTRD(MPTRD) = IPTR(20)
500 CONTINUE
1000 CONTINUE
C =======================================================
IPTR(42) = 0
C PRINT *,'MERGED TABLE D -- FI8819-B',IPTR(20),IPTR(42)
C DO 6000 I = 1, IPTR(20)
C WRITE (6,6001)I,(ITBLD(J,I),J=1,20)
C6001 FORMAT(15(1X,I5))
C6000 CONTINUE
RETURN
END
SUBROUTINE FI8820 (ITBLD,IUNITD,IPTR,ITBLD2,KPTRD)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI8820 READ IN BUFR TABLE D
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-05-06
C
C ABSTRACT: READ IN BUFR TABLE D
C
C PROGRAM HISTORY LOG:
C 93-05-06 CAVANAUGH
C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
C
C USAGE: CALL FI8820 (ITBLD,IUNITD,IPTR,ITBLD2,KPTRD)
C INPUT ARGUMENT LIST:
C IUNITD - UNIT NUMBER FOR TABLE D INPUT
C IPTR - ARRAY OF WORKING VALUES
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C ITBLD - ARRAY TO CONTAIN TABLE D
C
C REMARKS:
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: NAS
C
C$$$
C ..................................................
C
C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
C
INTEGER ITBLD2(20,*)
C ..................................................
C
C NEW BASE TABLE D
C
INTEGER ITBLD(20,*)
C ..................................................
C
INTEGER IHOLD(33),IPTR(*),KPTRD(*)
LOGICAL MORE
SAVE
C
MORE = .TRUE.
I = 0
C
C READ IN TABLE D, BUT JUST ONCE
C PRINT *,'TABLE D SWITCH=',IPTR(20),' ANCILLARY D SW=',IPTR(42)
IF (IPTR(20).EQ.0) THEN
DO 1000 MM = 1, 16384
KPTRD(MM) = -1
1000 CONTINUE
IERR = 0
PRINT *,'FI8820 - READING TABLE D'
KEY = 0
100 CONTINUE
C READ NEXT TABLE D ENTRY
READ(IUNITD,15,ERR=9998,END=9000)(IHOLD(M),M=1,33)
15 FORMAT(11(I1,I2,I3,1X),3X)
C BUILD KEY FROM MASTER D ENTRY
C INSERT NEW MASTER INTO TABLE B
I = I + 1
IPTR(20) = IPTR(20) + 1
DO 25 JJ = 1, 41, 3
KK = (JJ/3) + 1
IF (JJ.LE.31) THEN
ITBLD(KK,I) = IHOLD(JJ)*16384 +
* IHOLD(JJ+1)*256 + IHOLD(JJ+2)
IF (ITBLD(KK,I).LT.1.OR.ITBLD(KK,I).GT.65535) THEN
ITBLD(KK,I) = 0
GO TO 25
END IF
ELSE
ITBLD(KK,I) = 0
END IF
25 CONTINUE
MPTRD = MOD(ITBLD(1,I),16384)
KPTRD(MPTRD) = I
50 CONTINUE
C WRITE (6,51)I,(ITBLD(L,I),L=1,15)
51 FORMAT (7H TABLED,16(1X,I5))
GO TO 100
ELSE
C PRINT *,'TABLE D IS IN PLACE'
END IF
GO TO 9999
9000 CONTINUE
CLOSE(UNIT=IUNITD,STATUS='KEEP')
GO TO 9999
9998 CONTINUE
IPTR(1) = 8
C
9999 CONTINUE
C PRINT *,'THERE ARE',IPTR(20),' ENTRIES IN TABLE D'
RETURN
END