SUBROUTINE W3FI78(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX,
* MAXR,MAXD,IUNITB,IUNITD)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: W3FI78 BUFR MESSAGE DECODER
C PRGMMR: CAVANAUGH ORG: NMC421 DATE:93-03-17
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 SUBSTES 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 88-08-31 CAVANAUGH
C 90-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 91-01-18 CAVANAUGH PROGRAM/ROUTINES MODIFIED TO PROPERLY HANDLE
C SERIAL PROFILER DATA.
C 91-04-04 CAVANAUGH MODIFIED TO HANDLE TEXT SUPPLIED THRU
C DESCRIPTOR 2 05 YYY.
C 91-04-17 CAVANAUGH ERRORS IN EXTRACTING AND SCALING DATA
C CORRECTED. IMPROVED HANDLING OF NESTED
C QUEUE DESCRIPTORS IS ADDED.
C 91-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 91-07-26 CAVANAUGH - ADD ARRAY MTIME TO CALLING SEQUENCE TO
C PERMIT INCLUSION OF RECEIPT/TRANSFER TIMES
C TO IFOD MESSAGES.
C 91-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 91-11-21 CAVANAUGH - PROCESSING OF DESCRIPTOR 2 03 YYY
C HAS CORRECTED TO AGREE WITH FM94 STANDARDS.
C 91-12-19 CAVANAUGH - CALLS TO FI7803 AND FI7804 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 92-01-24 CAVANAUGH - ROUTINES FI7801, FI7803 AND FI7804
C HAVE BEEN MODIFIED TO HANDLE ASSOCIATED FIELDS
C ALL DESCRIPTORS ARE SET TO ECHO TO MSTACK(1,N)
C 92-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 92-06-29 CAVANAUGH - CORRECTED DESCRIPTOR DENOTING HEIGHT OF
C EACH WIND LEVEL FOR PROFILER CONVERSIONS.
C 92-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 KDESC - DESCRIPTOR
C ANAME - DESCRIPTOR NAME
C AUNITS - UNITS FOR DESCRIPTOR
C MSCALE - SCALE FOR VALUE OF DESCRIPTOR
C MREF - REFERENCE VALUE FOR DESCRIPTOR
C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR
C 92-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 92-10-02 CAVANAUGH - MODIFIED ROUTINE TO REFORMAT PROFILER DATA
C (FI7809) 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 92-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 92-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 10000 BYTES.
C 93-01-26 CAVANAUGH - SUBROUTINE FI7810 HAS BEEN ADDED TO PERMIT
C REFORMATTING OF PROFILER DATA IN EDITION 2.
C
C
C USAGE: CALL W3FI78(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX,
C 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 10000 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 1600, 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
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
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 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 LINES FROM TABLE D
C IPTR(21)- TABLE B SWITCH
C IPTR(22)- TABLE D SWITCH
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
C IPTR(27)- DATA SCALE CHANGE
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)- UNUSED
C IPTR(36)- NEXT DESCRIPTOR MAY BE UNDECIPHERABLE
C IPTR(37)- UNUSED
C IPTR(38)- UNUSED
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 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 (LAND)
C 1 = SURFACE (SHIP)
C 2 = VERTICAL SOUNDINGS OTHER THAN SATELLITE
C 3 = VERTICAL SOUNDINGS (SATELLITE)
C 4 = SNGL LVL UPPER-AIR OTHER THAN SATELLITE
C 5 = SNGL LVL UPPER-AIR (SATELLITE)
C 6 = RADAR
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
C ARRAYS CONTAINING DATA FROM TABLE B
C ANAME - DESCRIPTOR NAME
C AUNITS - UNITS FOR DESCRIPTOR
C MSCALE - SCALE FOR VALUE OF DESCRIPTOR
C MREF - REFERENCE VALUE FOR DESCRIPTOR
C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR
C INDEX - POINTER TO AVAILABLE SUBSET
C
C SUBPROGRAMS CALLED:
C LIBRARY:
C W3LIB - 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-5.
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 = 27 NON ZERO LOWEST ON TEXT DATA
C = 28 NBINC NOT NR OF CHARACTERS
C = 29 TABLE B APPEARS TO BE DAMAGED
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
C ON THE INITIAL CALL TO W3FI78 WITH A BUFR MESSAGE THE ARGUMENT
C INDEX MUST BE SET TO ZERO (INDEX = 0). ON THE RETURN FROM W3FI78
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 1. READ IN BUFR MESSAGE
C 2. SET INDEX = 0
C 3. CALL W3FI78( )
C 4. IF (IPTR(1).EQ.99) THEN
C NO MORE SUBSETS
C EITHER GO TO 1
C OR TERMINATE IN NO MORE BUFR MESSAGES
C END IF
C 5. IF (IPTR(1).NE.0) THEN
C ERROR CONDITION
C EITHER GO TO 1
C OR TERMINATE IN NO MORE BUFR MESSAGES
C END IF
C 6. THE VALUE OF INDEX INDICATES THE ACTIVE SUBSET SO
C IF INTERESTED IN GENERATING AN IFOD MESSAGE
C CALL W3FL05 ( )
C ELSE
C PROCESS DECODED INFORMATION AS REQUIRED
C END IF
C 7. GO TO 3
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 W3FI78), 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 W3FI78;
C UPPER AIR DATA AND SOME SATELLITE DATA REQUIRE
C A VALUE FOR MAXD OF 1600, 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 W3FI78)
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 W3FI78)
C
C
C ATTRIBUTES:
C LANGUAGE: CRAY CFT77 FORTRAN 77
C MACHINE: CRAY Y-MP8/832
C
C$$$
C
CHARACTER*40 ANAME(700)
CHARACTER*24 AUNITS(700)
C
C
C
INTEGER MSGA(*)
INTEGER IPTR(*)
INTEGER KDATA(MAXR,MAXD)
INTEGER MSTACK(2,MAXD)
C
INTEGER IVALS(1000)
INTEGER KNR(MAXR)
INTEGER IDENT(*)
INTEGER KDESC(2000)
INTEGER ISTACK(*)
INTEGER IWORK(2000)
INTEGER MSCALE(700)
INTEGER MREF(700,3)
INTEGER MWIDTH(700)
INTEGER INDEX
C
CHARACTER*4 DIRID(2)
C
LOGICAL SEC2
C
SAVE
C
C PRINT *,' W3FI78 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(39) = 0
ELSE IF (INDEX.LE.IDENT(14)) THEN
IF (IPTR(39).NE.0) THEN
CALL FI7801(IPTR,IDENT,MSGA,ISTACK,IWORK,ANAME,KDATA,
C
* IVALS,MSTACK,
* AUNITS,KDESC,MWIDTH,MREF,MSCALE,KNR,INDEX,MAXR,MAXD,
* IUNITB,IUNITD)
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 SUB-TYPE
CALL GBYTE (MSGA,IVALS,INOFST,8)
IDENT(6) = IVALS(1)
INOFST = INOFST + 8
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 W3FI78; 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 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 FI7801(IPTR,IDENT,MSGA,ISTACK,IWORK,ANAME,KDATA,IVALS,MSTACK,
* AUNITS,KDESC,MWIDTH,MREF,MSCALE,KNR,INDEX,MAXR,MAXD,
* IUNITB,IUNITD)
C
C PRINT *,'HAVE RETURNED FROM FI7801'
C IF (IPTR(1).NE.0) THEN
C RETURN
C END IF
C FURTHER PROCESSING REQUIRED FOR PROFILER DATA
IF (IDENT(5).EQ.2) THEN
IF (IDENT(6).EQ.7) THEN
C PRINT *,'BASIC PROFILER DATA'
C DO 153 I = 1, KNR(INDEX)
C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I)
C 153 CONTINUE
C PRINT *,'REFORMAT PROFILER DATA'
C
IF (IDENT(1).LT.2) THEN
CALL FI7809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
ELSE
CALL FI7810(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
RETURN
END
SUBROUTINE FI7801(IPTR,IDENT,MSGA,ISTACK,IWORK,ANAME,KDATA,IVALS,
* MSTACK,AUNITS,KDESC,MWIDTH,MREF,MSCALE,KNR,INDEX,MAXR,MAXD,
* IUNITB,IUNITD)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI7801 DATA EXTRACTION
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01
C
C ABSTRACT: CONTROL THE EXTRACTION OF DATA FROM SECTION 4 BASED ON
C DATA DESCRIPTORS.
C
C PROGRAM HISTORY LOG:
C 88-09-01 CAVANAUGH
C 91-01-18 CAVANAUGH CORRECTIONS TO PROPERLY HANDLE NON-COMPRESSED
C DATA.
C 91-09-23 CAVANAUGH CODING ADDED TO HANDLE SINGLE SUBSETS WITH
C DELAYED REPLICATION.
C 92-01-24 CAVANAUGH MODIFIED TO ECHO DESCRIPTORS TO MSTACK(1,N)
C
C USAGE: CALL FI7801(IPTR,IDENT,MSGA,ISTACK,IWORK,ANAME,KDATA,
C * MSTACK,AUNITS,KDESC,MWIDTH,MREF,MSCALE,KNR,INDEX,MAXR,MAXD,
C * IUNITB,IUNITD)
C
C INPUT ARGUMENT LIST:
C IPTR - SEE W3FI78 ROUTINE DOCBLOCK
C IDENT - SEE W3FI78 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 KDESC - 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 1600, 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 KDESC - SEE ABOVE
C ANAME - DESCRIPTOR NAME
C AUNITS - UNITS FOR DESCRIPTOR
C MSCALE - SCALE FOR VALUE OF DESCRIPTOR
C MREF - REFERENCE VALUE FOR DESCRIPTOR
C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR
C
C SUBPROGRAMS CALLED:
C LIBRARY:
C W3LIB - FI7802 FI7805 FI7806 FI7807 FI7808
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: CRAY CFT77 FORTRAN 77
C MACHINE: CRAY Y-MP8/832
C
C$$$
SAVE
C
CHARACTER*40 ANAME(*)
CHARACTER*24 AUNITS(*)
C
C
INTEGER MSGA(*),KDATA(MAXR,MAXD),IVALS(*)
C
INTEGER MSCALE(*),KNR(MAXR)
INTEGER LX,LY,LL,J
INTEGER MREF(700,3)
INTEGER MWIDTH(*)
INTEGER IHOLD(33)
INTEGER ITBLD(500,11)
INTEGER IPTR(*)
INTEGER IDENT(*)
INTEGER KDESC(*)
INTEGER ISTACK(*),IWORK(*)
C
INTEGER MSTACK(2,MAXD),KK
C
INTEGER JDESC
INTEGER INDEX
INTEGER ITEST(30)
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/
C
C PRINT *,' DECOLL FI7801'
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 *,'FI7801 - 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
C PRINT *,' READING TABLE B'
DO 150 I = 1, 700
IPTR(21) = I
C
READ(UNIT=IUNITB,FMT=20,ERR=9999,END=175)MF,
* MX,MY,
* (ANAME(I)(K:K),K=1,40),
* (AUNITS(I)(K:K),K=1,24),
* MSCALE(I),MREF(I,1),MWIDTH(I)
20 FORMAT(I1,I2,I3,40A1,24A1,I5,I15,1X,I4)
IF (MWIDTH(I).EQ.0) THEN
IPTR(1) = 29
RETURN
END IF
MREF(I,2) = 0
IPTR(14) = I
KDESC(I) = MF*16384 + MX*256 + MY
C PRINT *,I
C WRITE(6,21) MF,MX,MY,KDESC(I),
C * (ANAME(I)(K:K),K=1,40),
C * (AUNITS(I)(K:K),K=1,24),
C * MSCALE(I),MREF(I,1),MWIDTH(I)
21 FORMAT(1X,I1,I2,I3,1X,I6,1X,40A1,
* 2X,24A1,2X,I5,2X,I15,1X,I4)
150 CONTINUE
PRINT *,'HAVE READ LIMIT OF 700 TABLE B DESCRIPTORS'
PRINT *,'IF THERE ARE MORE THAT THAT, CORRECT READ LOOP'
175 CONTINUE
C
C CLOSE(UNIT=IUNITB,STATUS='KEEP')
C
IPTR(21) = 1
END IF
C DO WHILE MM <= MAXD
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 FI7808 (IPTR,IWORK,LF,LX,LY,JDESC,MAXD)
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)
IF (IPTR(11).GT.1600) THEN
IPTR(1) = 401
RETURN
END IF
C
KPRM = IPTR(31) + IPTR(24)
IF (KPRM.GT.1600) 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 *,'FI7801-1',KPRM,MSTACK(1,KPRM),
C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
CALL FI7805(IPTR,IDENT,MSGA,IWORK,LX,LY,
* 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.5) THEN
ELSE 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 *,'FI7801-2',KPRM,MSTACK(1,KPRM),
C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
END IF
CALL FI7806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK,
* MWIDTH,MREF,MSCALE,J,LL,KDESC,IWORK,JDESC,MAXR,MAXD)
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'
IF (IPTR(22).EQ.0) THEN
C READ IN TABLE D, BUT JUST ONCE
IERR = 0
C PRINT *,' READING TABLE D'
DO 50 I = 1, 500
READ(IUNITD,15,ERR=9998,END=75 )
* (IHOLD(J),J=1,33)
15 FORMAT(11(I1,I2,I3,1X),3X)
IPTR(20) = I
DO 25 JJ = 1, 31, 3
KK = (JJ/3) + 1
ITBLD(I,KK) = IHOLD(JJ)*16384 +
* IHOLD(JJ+1)*256 + IHOLD(JJ+2)
IF (ITBLD(I,KK).EQ.0) THEN
C PRINT 16,(ITBLD(I,L),L=1,11)
GO TO 50
END IF
25 CONTINUE
C PRINT 16,(ITBLD(I,L),L=1,11)
50 CONTINUE
16 FORMAT(1X,11(I6,1X))
75 CONTINUE
CLOSE(UNIT=IUNITD,STATUS='KEEP')
IPTR(22) = 1
ENDIF
CALL FI7807(IPTR,IWORK,ITBLD,JDESC,MAXD)
IF (IPTR(1).GT.0) THEN
RETURN
END IF
GO TO 14
C
C STANDARD DESCRIPTOR PROCESSING
ELSE
C PRINT *,'ENTRY',IPTR(31),JDESC,' AT',IPTR(25)
KPRM = IPTR(31) + IPTR(24)
CALL FI7802(IPTR,IDENT,MSGA,KDATA,KDESC,LL,MSTACK,
* AUNITS,MWIDTH,MREF,MSCALE,JDESC,IVALS,J,MAXR,MAXD)
C TURN OFF SKIP FLAG AFTER STD DESCRIPTOR
IPTR(36) = 0
IF (IPTR(1).GT.0) THEN
RETURN
ELSE
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
IF (IDENT(16).NE.0) THEN
C PRINT *,'RETURN WITH',IDENT(14),' COMPRESSED REPORTS'
ELSE
C PRINT *,'RETURN WITH',IPTR(17),' NON-COMPRESSED REPORTS'
END IF
RETURN
9998 CONTINUE
PRINT *,' ERROR READING TABLE D'
IPTR(1) = 8
RETURN
9999 CONTINUE
PRINT *,' ERROR READING TABLE B'
IPTR(1) = 9
RETURN
END
C -----------------------------------------------------
SUBROUTINE FI7802(IPTR,IDENT,MSGA,KDATA,KDESC,LL,MSTACK,AUNITS,
* MWIDTH,MREF,MSCALE,JDESC,IVALS,J,MAXR,MAXD)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI7802 PROCESS STANDARD DESCRIPTOR
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01
C
C ABSTRACT: PROCESS A STANDARD 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 FI7802(IPTR,IDENT,MSGA,KDATA,KDESC,LL,MSTACK,AUNITS,
C MWIDTH,MREF,MSCALE,JDESC,IVALS,J,MAXR,MAXD)
C INPUT ARGUMENT LIST:
C IPTR - SEE W3FI78 ROUTINE DOCBLOCK
C IDENT - SEE W3FI78 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 KDESC - IMAGE OF CURRENT DESCRIPTOR
C ANAME - 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 1600, 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 KDESC - SEE ABOVE
C ARRAYS CONTAINING DATA FROM TABLE B
C AUNITS - UNITS FOR DESCRIPTOR
C MSCALE - SCALE FOR VALUE OF DESCRIPTOR
C MREF - REFERENCE VALUE FOR DESCRIPTOR
C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR
C
C SUBPROGRAMS CALLED:
C LIBRARY:
C W3LIB - FI7803 FI7804
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: CRAY CFT77 FORTRAN 77
C MACHINE: CRAY Y-MP8/832
C
C$$$
SAVE
C TABLE B ENTRY
CHARACTER*24 ASKEY
CHARACTER*24 AUNITS(*)
C TABLE B ENTRY
INTEGER MSGA(*)
INTEGER IPTR(*)
INTEGER IDENT(*)
INTEGER J
INTEGER JDESC
INTEGER KDESC(*)
INTEGER MWIDTH(*),MSTACK(2,MAXD),MSCALE(*)
INTEGER MREF(700,3),KDATA(MAXR,MAXD),IVALS(*)
C TABLE B ENTRY
C
DATA ASKEY /'CCITT IA5 '/
C
C PRINT *,' FI7802 - STANDARD DESCRIPTOR PROCESSOR'
C GET A MATCH BETWEEN CURRENT
C DESCRIPTOR (JDESC) AND
C TABLE B ENTRY
C IF (KDESC(356).EQ.0) THEN
C PRINT *,'FI7802 - KDESC(356) WENT TO ZER0'
C IPTR(1) = 600
C RETURN
C END IF
K = 1
KK = IPTR(14)
IF (JDESC.GT.KDESC(KK)) THEN
K = KK + 1
END IF
10 CONTINUE
IF (K.GT.KK) THEN
IF (IPTR(36).NE.0) THEN
C HAVE SKIP FLAG
IF (IDENT(16).NE.0) THEN
C SKIP OVER COMPRESSED DATA
C LOWEST
IPTR(25) = IPTR(25) + IPTR(36)
C NBINC
CALL GBYTE (MSGA,IHOLD,IPTR(25),6)
IPTR(25) = IPTR(25) + 6
IPTR(31) = IPTR(31) + 1
KPRM = IPTR(31) + IPTR(24)
MSTACK(1,KPRM) = JDESC
MSTACK(2,KPRM) = 0
DO 50 I = 1, IPTR(14)
KDATA(I,KPRM) = 99999
50 CONTINUE
C PROCESS DIFFERENCES
IF (IHOLD.NE.0) THEN
IBITS = IHOLD * IDENT(14)
IPTR(25) = IPTR(25) + IBITS
END IF
ELSE
IPTR(31) = IPTR(31) + 1
KPRM = IPTR(31) + IPTR(24)
MSTACK(1,KPRM) = JDESC
MSTACK(2,KPRM) = 0
KDATA(IPTR(17),KPRM) = 99999
C SKIP OVER NON-COMPRESSED DATA
C PRINT *,'SKIP NON-COMPRESSED DATA'
IPTR(25) = IPTR(25) + IPTR(36)
END IF
RETURN
ELSE
PRINT *,'FI7802 - ERROR = 3'
PRINT *,JDESC,K,KK,J,KDESC(J)
PRINT *,' '
PRINT *,'TABLE B'
C DO 20 LL = 1, IPTR(14)
C PRINT *,LL,KDESC(LL)
C 20 CONTINUE
IPTR(1) = 3
RETURN
END IF
ELSE
J = ((KK - K) / 2) + K
END IF
IF (JDESC.EQ.KDESC(K)) THEN
J = K
GO TO 15
ELSE IF (JDESC.EQ.KDESC(KK))THEN
J = KK
GO TO 15
ELSE IF (JDESC.LT.KDESC(J)) THEN
K = K + 1
KK = J - 1
GO TO 10
ELSE IF (JDESC.GT.KDESC(J)) THEN
K = J + 1
KK = KK - 1
GO TO 10
END IF
15 CONTINUE
C HAVE A MATCH
C SET FLAG IF TEXT EVENT
IF (ASKEY(1:9).EQ.AUNITS(J)(1:9)) THEN
IPTR(18) = 1
IPTR(40) = MWIDTH(J) / 8
ELSE
IPTR(18) = 0
END IF
IF (IDENT(16).NE.0) THEN
C COMPRESSED
CALL FI7803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK,
* MWIDTH,MREF,MSCALE,J,JDESC,MAXR,MAXD)
IF (IPTR(1).NE.0) THEN
RETURN
END IF
ELSE
C NOT COMPRESSED
CALL FI7804(IPTR,MSGA,KDATA,IVALS,MSTACK,
* MWIDTH,MREF,MSCALE,J,LL,JDESC,MAXR,MAXD)
END IF
RETURN
END
C -----------------------------------------------------
SUBROUTINE FI7803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK,
* MWIDTH,MREF,MSCALE,J,JDESC,MAXR,MAXD)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI7803 PROCESS COMPRESSED DATA
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01
C
C ABSTRACT: PROCESS COMPRESSED DATA AND PLACE INDIVIDUAL ELEMENTS
C INTO OUTPUT ARRAY.
C
C PROGRAM HISTORY LOG:
C 88-09-01 CAVANAUGH
C 91-04-04 CAVANAUGH TEXT HANDLING PORTION OF THIS ROUTINE
C MODIFIED TO HANLE WIDTH OF FIELDS 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 91-06-21 CAVANAUGH PROCESSING OF TEXT DATA HAS BEEN CHANGED TO
C PROVIDE EXACT REPRODUCTION OF ALL CHARACTERS.
C
C USAGE: CALL FI7803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK,
C MWIDTH,MREF,MSCALE,J,JDESC,MAXR,MAXD)
C INPUT ARGUMENT LIST:
C IPTR - SEE W3FI78 ROUTINE DOCBLOCK
C IDENT - SEE W3FI78 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 1600, 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 MSCALE - SCALE FOR VALUE OF DESCRIPTOR
C MREF - REFERENCE VALUE FOR DESCRIPTOR
C MWIDTH - BIT WIDTH FOR VALUE OF DESCRIPTOR
C
C SUBPROGRAMS CALLED:
C LIBRARY:
C W3LIB - GBYTE GBYTES
C
C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
C
C ATTRIBUTES:
C LANGUAGE: CRAY CFT77 FORTRAN 77
C MACHINE: CRAY Y-MP8/832
C
C$$$
SAVE
C
INTEGER MSGA(*),JDESC,MSTACK(2,MAXD)
INTEGER IPTR(*),IVALS(*),KDATA(MAXR,MAXD)
INTEGER NRVALS,JWIDE,IDATA
INTEGER IDENT(*)
INTEGER MSCALE(*)
INTEGER MREF(700,3)
INTEGER J
INTEGER MWIDTH(*)
INTEGER KLOW(256)
C
LOGICAL TEXT
C
INTEGER MSK(28)
C
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
C
C PRINT *,' FI7803 COMPR J=',J,' MWIDTH(J) =',MWIDTH(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
IF (.NOT.TEXT) THEN
IF (IPTR(29).GT.0) THEN
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 EXTRACT DATA FOR ASSOCIATED FIELD
IF (NBINC.GT.0) THEN
CALL GBYTES (MSGA,IVALS,IPTR(25),NBINC,0,IPTR(14))
IPTR(25) = IPTR(25) + NBINC * IPTR(14)
DO 50 I = 1, IPTR(14)
KDATA(I,KPRM) = IVALS(I) + LOWEST
IF (KDATA(I,KPRM).GE.MSK(NBINC)) THEN
KDATA(I,KPRM) = 999999
END IF
50 CONTINUE
ELSE
DO 51 I = 1, IPTR(14)
IF (LOWEST.GE.MSK(NBINC)) THEN
KDATA(I,KPRM) = 999999
ELSE
KDATA(I,KPRM) = LOWEST
END IF
51 CONTINUE
END IF
END IF
C SET PARAMETER
C ISOLATE STANDARD BIT WIDTH
JWIDE = MWIDTH(J) + IPTR(26)
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 (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,' MWIDTH(J)=',
C * MWIDTH(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
111 FORMAT (1X,5HDATA ,I3,6(2X,I10))
IPTR(1) = 500
C RETURN
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 (MREF(J,2).EQ.0) THEN
KDATA(I,KPRM) = IVALS(I) + LOWEST + MREF(J,1)
ELSE
KDATA(I,KPRM) = IVALS(I) + LOWEST + MREF(J,3)
END IF
END IF
100 CONTINUE
C PRINT *,I,JDESC,LOWEST,MREF(J,1),MREF(J,3)
ELSE
IF (LOWEST.EQ.MSK(MWIDTH(J))) THEN
DO 105 I = 1, NRVALS
KDATA(I,KPRM) = 999999
105 CONTINUE
ELSE
IF (MREF(J,2).EQ.0) THEN
ICOMB = LOWEST + MREF(J,1)
ELSE
ICOMB = LOWEST + MREF(J,3)
END IF
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
IF (IPTR(27).NE.0) THEN
MSTACK(2,KPRM) = IPTR(27)
ELSE
MSTACK(2,KPRM) = MSCALE(J)
END IF
C WRITE (6,80) (DATA(I,KPRM),I=1,10)
C 80 FORMAT(2X,10(F10.2,1X))
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 GET NBINC
CALL GBYTE (MSGA,NBINC,IPTR(25),6)
C PRINT *,'NBINC =',NBINC
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 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.32) THEN
CALL GBYTE (MSGA,IDATA,IPTR(25),32)
IPTR(25) = IPTR(25) + 32
NBITS = NBITS - 32
C CONVERTS ASCII TO EBCIDIC
C COMMENT OUT IF NOT IBM370 COMPUTER
C PRINT *,IDATA
C CALL W3AI39 (IDATA,4)
MSTACK(1,KPRM) = JDESC
MSTACK(2,KPRM) = 0
KDATA(N,KPRM) = IDATA
C SET FOR NEXT PART
KPRM = KPRM + 1
IPTR(24) = IPTR(24) + 1
C PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA
1701 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 = (32 - 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
C CALL W3AI39 (IDATA,4)
MSTACK(1,KPRM) = JDESC
MSTACK(2,KPRM) = 0
KDATA(N,KPRM) = IDATA
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 FI7804(IPTR,MSGA,KDATA,IVALS,MSTACK,
* MWIDTH,MREF,MSCALE,J,LL,JDESC,MAXR,MAXD)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI7804 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 FI7804(IPTR,MSGA,KDATA,IVALS,MSTACK,
C MWIDTH,MREF,MSCALE,J,LL,JDESC,MAXR,MAXD)
C INPUT ARGUMENT LIST:
C IPTR - SEE W3FI78 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 1600, 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 MSCALE - SCALE FOR VALUE OF DESCRIPTOR
C MREF - REFERENCE VALUE FOR DESCRIPTOR
C MWIDTH - 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: CRAY CFT77 FORTRAN 77
C MACHINE: CRAY Y-MP8/832
C
C$$$
SAVE
C
INTEGER MSGA(*)
INTEGER IPTR(*),MREF(700,3),MSCALE(*)
INTEGER MWIDTH(*),JDESC
INTEGER IVALS(*)
INTEGER LSTBLK(3)
INTEGER KDATA(MAXR,MAXD),MSTACK(2,MAXD)
INTEGER J,LL
LOGICAL LKEY
C
C
INTEGER ITEST(30)
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/
C
C PRINT *,' FI7804 NOCMP',J,JDESC,MWIDTH(J),IPTR(26),IPTR(25)
IF ((IPTR(26)+MWIDTH(J)).LT.1) THEN
IPTR(1) = 501
RETURN
END IF
C -------- NOCMP --------
C ISOLATE BIT WIDTH
JWIDE = MWIDTH(J) + IPTR(26)
C IF NOT TEXT EVENT, PROCESS
IF (IPTR(18).NE.1) THEN
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 *,'FI7804-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
IF (IPTR(27).NE.0) THEN
MSTACK(2,KPRM) = IPTR(27)
ELSE
MSTACK(2,KPRM) = MSCALE(J)
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 (IVALS(1).EQ.ITEST(JWIDE)) THEN
KDATA(IPTR(17),KPRM) = 999999
ELSE
IF (MREF(J,2).EQ.0) THEN
KDATA(IPTR(17),KPRM) = IVALS(1) + MREF(J,1)
ELSE
KDATA(IPTR(17),KPRM) = IVALS(1) + MREF(J,3)
END IF
END IF
C PRINT *,'FI7804-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 *,'FI7804 ',KPRM,MSTACK(1,KPRM),
C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
ELSE
C IF TEXT EVENT, PROCESS TEXT
C PRINT *,' FOUND TEXT MODE ****** NOT COMPRESSED *********'
NRCHRS = IPTR(40)
NRBITS = NRCHRS * 8
C PRINT *,'CHARS =',NRCHRS,' BITS =',NRBITS
IPTR(31) = IPTR(31) + 1
KANY = 0
1800 CONTINUE
KANY = KANY + 1
IF (NRBITS.GT.32) THEN
CALL GBYTE (MSGA,IDATA,IPTR(25),32)
C PRINT 1801,KANY,IDATA,IPTR(17),KPRM
C1801 FORMAT (1X,I2,4X,Z8,2(4X,I4))
C CONVERTS ASCII TO EBCIDIC
C COMMENT OUT IF NOT IBM370 COMPUTER
C CALL W3AI39 (IDATA,4)
KPRM = IPTR(31) + IPTR(24)
KDATA(IPTR(17),KPRM) = IDATA
MSTACK(1,KPRM) = JDESC
MSTACK(2,KPRM) = 0
C PRINT *,KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM),
C * KDATA(IPTR(17),KPRM)
IPTR(25) = IPTR(25) + 32
NRBITS = NRBITS - 32
IPTR(24) = IPTR(24) + 1
GO TO 1800
ELSE IF (NRBITS.GT.0) THEN
C PRINT *,'LAST TEXT WORD'
CALL GBYTE (MSGA,IDATA,IPTR(25),NRBITS)
IPTR(25) = IPTR(25) + NRBITS
C CONVERTS ASCII TO EBCIDIC
C COMMENT OUT IF NOT IBM370 COMPUTER
C CALL W3AI39 (IDATA,4)
KPRM = IPTR(31) + IPTR(24)
KSHFT = 32 - NRBITS
IF (KSHFT.GT.0) THEN
KTRY = KSHFT / 8
DO 1722 LAK = 1, KTRY
IDATA = IDATA * 256 + 64
C PRINT 1723,IDATA
1723 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 *,KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM),
C * KDATA(IPTR(17),KPRM)
END IF
C TURN OFF TEXT
IPTR(18) = 0
END IF
RETURN
END
C -----------------------------------------------------
SUBROUTINE FI7805(IPTR,IDENT,MSGA,IWORK,LX,LY,
* KDATA,LL,KNR,MSTACK,MAXR,MAXD)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI7805 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 FI7805(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 W3FI78 ROUTINE DOCBLOCK
C IDENT - SEE W3FI78 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 1600, 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 FI7808
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: CRAY CFT77 FORTRAN 77
C MACHINE: CRAY Y-MP8/832
C
C$$$
SAVE
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(1000)
INTEGER IWORK(MAXD)
INTEGER IDENT(*)
C
C PRINT *,' REPLICATION FI7805'
C DO 100 I = 1, IPTR(13)
C PRINT *,I,IWORK(I)
C 100 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 *,'FI7805-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 FI7808(IPTR,IWORK,LF,LX,LY,JDESC,MAXD)
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
IPTR(1) = 12
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 *,'FI7805-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
C PRINT *,' SAVE OFF',NRSET,' DESCRIPTORS'
C PICK UP DESCRIPTORS TO BE REPLICATED
DO 1000 I = 1, NRSET
CALL FI7808(IPTR,IWORK,LF,LX,LY,JDESC,MAXD)
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 FI7808(IPTR,IWORK,LF,LX,LY,JDESC,MAXD)
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 *,'FI7805 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 *,'FI7805 B',ICURR,IWORK(ICURR)
ICURR = ICURR + 1
5000 CONTINUE
IPTR(12) = ICURR - 1
IPTR(11) = IPICK
RETURN
END
SUBROUTINE FI7806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK,
* MWIDTH,MREF,MSCALE,J,LL,KDESC,IWORK,JDESC,MAXR,MAXD)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI7806 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 PROPOSED
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 FI7806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK,
C * MWIDTH,MREF,MSCALE,J,LL,KDESC,IWORK,JDESC,MAXR,MAXD)
C INPUT ARGUMENT LIST:
C IPTR - SEE W3FI78 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 1600, 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 MSCALE - SCALE FOR VALUE OF DESCRIPTOR
C MREF - REFERENCE VALUE FOR DESCRIPTOR
C MWIDTH - 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: CRAY CFT77 FORTRAN 77
C MACHINE: CRAY Y-MP8/832
C
C$$$
SAVE
INTEGER IPTR(*),KDATA(MAXR,MAXD),IVALS(*)
INTEGER IDENT(*),IWORK(*)
INTEGER MSGA(*),MSTACK(2,MAXD)
INTEGER MREF(700,3),KDESC(*)
INTEGER MSCALE(*),MWIDTH(*)
INTEGER J,JDESC
INTEGER LL
INTEGER LX
INTEGER LY
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 FI7808 (IPTR,IWORK,LF,LX,LY,JDESC,MAXD)
IF (JDESC.EQ.33791) THEN
C IF 2 03 255 THEN RETURN
RETURN
ELSE
C FIND MATCHING TABLE B ENTRY
DO 500 LJ = 1, IPTR(14)
IF (JDESC.EQ.KDESC(LJ)) THEN
C TURN ON NEW REF VAL FLAG
MREF(LJ,2) = 1
C INSERT NEW REF VAL
CALL GBYTE (MSGA,MREF(LJ,3),IPTR(25),KYYY)
C GO GET NEXT DESCRIPTOR
GO TO 300
END IF
500 CONTINUE
C MATCHING DESCRIPTOR NOT FOUND, ERROR ERROR
PRINT *,'2 03 YYY - MATCHING DESCRIPTOR NOT FOUND'
STOP 203
END IF
ELSE IF (KYYY.EQ.0) THEN
C MUST TURN OFF ALL NEW
C REFERENCE VALUES
DO 400 I = 1, IPTR(14)
MREF(I,2) = 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
C PROCESS TEXT DATA
IPTR(40) = LY
IPTR(18) = 1
IF (IDENT(16).EQ.0) THEN
C PRINT *,'2 05 YYY - TEXT - NONCOMPRESSED MODE'
CALL FI7804(IPTR,MSGA,KDATA,IVALS,MSTACK,
* MWIDTH,MREF,MSCALE,J,LL,JDESC,MAXR,MAXD)
ELSE
C PRINT *,'2 05 YYY - TEXT - COMPRESSED MODE'
CALL FI7803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK,
* MWIDTH,MREF,MSCALE,J,JDESC,MAXR,MAXD)
IF (IPTR(1).NE.0) THEN
RETURN
END IF
ENDIF
IPTR(18) = 0
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 FI7807(IPTR,IWORK,ITBLD,JDESC,MAXD)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI7807 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 FI7807(IPTR,IWORK,ITBLD,JDESC,MAXD)
C INPUT ARGUMENT LIST:
C IWORK - WORKING DESCRIPTOR LIST
C IPTR - SEE W3FI78 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: CRAY CFT77 FORTRAN 77
C MACHINE: CRAY Y-MP8/832
C
C$$$
SAVE
C
INTEGER IPTR(*),JDESC
INTEGER IWORK(*),IHOLD(2000)
INTEGER ITBLD(500,11)
C
C PRINT *,' FI7807 F3 ENTRY',IPTR(11),IPTR(12)
C SET FOR BINARY SEARCH IN TABLE D
C DO 2020 I = 1, IPTR(12)
C PRINT *,'ENTRY IWORK',I,IWORK(I)
C2020 CONTINUE
JLO = 1
JHI = IPTR(20)
C PRINT *,'LOOKING FOR QUEUE DESCRIPTOR',JDESC
10 CONTINUE
JMID = (JLO + JHI) / 2
C PRINT *,JLO,ITBLD(JLO,1),JMID,ITBLD(JMID,1),JHI,ITBLD(JHI,1)
C
IF (JDESC.LT.ITBLD(JMID,1)) THEN
IF (JDESC.EQ.ITBLD(JLO,1)) THEN
JMID = JLO
GO TO 100
ELSE
JLO = JLO + 1
JHI = JMID - 1
IF (JLO.GT.JMID) THEN
IPTR(1) = 4
RETURN
END IF
GO TO 10
END IF
ELSE IF (JDESC.GT.ITBLD(JMID,1)) THEN
IF (JDESC.EQ.ITBLD(JHI,1)) THEN
JMID = JHI
GO TO 100
ELSE
JLO = JMID + 1
JHI = JHI - 1
IF (JLO.GT.JHI) THEN
IPTR(1) = 4
RETURN
END IF
GO TO 10
END IF
END IF
100 CONTINUE
C HAVE TABLE D MATCH
C PRINT *,'D ',(ITBLD(JMID,LL),LL=1,11)
C PRINT *,'TABLE D TO IHOLD'
IK = 0
JK = 0
DO 200 KI = 2, 11
IF (ITBLD(JMID,KI).NE.0) THEN
IK = IK + 1
IHOLD(IK) = ITBLD(JMID,KI)
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 *,' FI7807 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 FI7808(IPTR,IWORK,LF,LX,LY,JDESC,MAXD)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI7808
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 FI7808(IPTR,IWORK,LF,LX,LY,JDESC,MAXD)
C INPUT ARGUMENT LIST:
C IPTR - SEE W3FI78 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: CRAY CFT77 FORTRAN 77
C MACHINE: CRAY Y-MP8/832
C
C$$$
SAVE
INTEGER IPTR(*),IWORK(*),LF,LX,LY,JDESC
C
C PRINT *,' FI7808 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 *,' CURRENT DESCRIPTOR BEING TESTED IS',LF,LX,LY
IPTR(11) = IPTR(11) + 1
RETURN
END
SUBROUTINE FI7809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI7809 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 FI7809(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 W3FI78
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 1600, 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: CRAY CFT77 FORTRAN 77
C MACHINE: CRAY Y-MP8/832
C
C$$$
SAVE
C ----------------------------------------------------------------
C
INTEGER ISW
INTEGER IDENT(*),KDATA(MAXR,MAXD)
INTEGER MSTACK(2,MAXD),IPTR(*)
INTEGER KPROFL(1600)
INTEGER KPROF2(1600)
INTEGER KSET2(1600)
C
C ----------------------------------------------------------
C PRINT *,'FI7809'
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
650 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
850 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 FI7810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: FI7810 REFORMAT PROFILER EDITION 2 DATA
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-01-21
C
C ABSTRACT: REFORMAT PROFILER DATA IN EDITION 2
C
C PROGRAM HISTORY LOG:
C 93-01-27 CAVANAUGH
C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
C
C USAGE: CALL FI7810(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 W3FI78
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 1600, 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: CRAY CFT77 FORTRAN 77
C MACHINE: CRAY Y-MP8/832
C
C$$$
INTEGER ISW
INTEGER IDENT(*),KDATA(MAXR,MAXD)
INTEGER MSTACK(2,MAXD),IPTR(*)
INTEGER KPROFL(1600)
INTEGER KPROF2(1600)
INTEGER KSET2(1600)
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
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 DA
C AT THIS POINT
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 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
ELSE
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
850 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