C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: W3UNPK77 DECODES SINGLE REPORT FROM BUFR MESSAGES
C PRGMMR: KEYSER ORG: NP22 DATE: 2002-03-05
C
C ABSTRACT: THIS SUBROUTINE DECODES A SINGLE REPORT FROM BUFR MESSAGES
C IN A JBUFR-TYPE DATA FILE. CURRENTLY WIND PROFILER, NEXRAD (VAD)
C WIND AND GOES SOUNDING/RADIANCE DATA TYPES ARE VALID. REPORT IS
C RETURNED IN QUASI-OFFICE NOTE 29 UNPACKED FORMAT (SEE REMARKS 4.).
C
C PROGRAM HISTORY LOG:
C 1996-12-16 KEYSER -- ORIGINAL AUTHOR (BASED ON W3LIB ROUTINE W3FI77)
C 1997-06-02 KEYSER -- ADDED NEXRAD (VAD) WIND DATA TYPE
C 1997-06-16 KEYSER -- ADDED GOES SOUNDING/RADIANCE DATA TYPE
C 1997-09-18 KEYSER -- ADDED INSTRUMENT DATA USED IN PROCESSING,
C SOLAR ZENITH ANGLE, AND SATELLITE ZENITH ANGLE
C TO LIST OF PARAMETERS RETURNED FROM GOES
C SOUNDING/RADIANCE DATA TYPE
C 1998-07-09 KEYSER -- MODIFIED WIND PROFILER CAT. 11 (HEIGHT, HORIZ.
C SIGNIFICANCE, VERT. SIGNIFICANCE) TO ACCOUNT
C FOR UPDATES TO BUFRTABLE MNEMONICS IN /dcom;
C CHANGED CHAR. 6 OF GOES STNID TO BE UNIQUE FOR
C TWO DIFFERENT EVEN OR ODD SATELLITE ID'S
C (EVERY OTHER EVEN OR ODD SAT. ID NOW GETS SAME
C CHAR. 6 TAG)
C 1998-08-19 KEYSER -- SUBROUTINE NOW Y2K AND FORTRAN 90 COMPLIANT
C 1999-03-16 KEYSER -- INCORPORATED BOB KISTLER'S CHANGES NEEDED
C TO PORT THE CODE TO THE IBM SP
C 1999-05-17 KEYSER -- MADE CHANGES NECESSARY TO PORT THIS ROUTINE TO
C THE IBM SP
C 1999-09-26 KEYSER -- CHANGES TO MAKE CODE MORE PORTABLE
C 2002-03-05 KEYSER -- ACCOUNTS FOR CHANGES IN INPUT PROFLR (WIND
C PROFILER) BUFR DUMP FILE AFTER 3/2002: CAT. 10
C SURFACE DATA NOW ALL MISSING (MNEMONICS "PMSL",
C "WDIR1","WSPD1", "TMDB", "REHU", "REQV" NO
C LONGER AVAILABLE); CAT. 11 MNEMONICS "ACAVH",
C "ACAVV", "SPP0", AND "NPHL" NO LONGER
C AVAILABLE; HEADER MNEMONIC "NPSM" IS NO LONGER
C AVAILABLE, HEADER MNEMONIC "TPSE" REPLACES
C "TPMI" (AVG. TIME IN MINUTES STILL OUTPUT);
C NUMBER OF UPPER-AIR LEVELS INCR. FROM 43 TO UP
C TO 64 (SIZE OF OUTPUT "RDATA" ARRAY INCR. FROM
C 600 TO 1200 TO ACCOUNT FOR THIS) (WILL STILL
C WORK PROPERLY FOR INPUT PROFLR DUMP FILES PRIOR
C TO 3/2002)
C
C
C USAGE: CALL W3UNPK77(IDATE,IHE,IHL,LUNIT,RDATA,IRET)
C INPUT ARGUMENT LIST:
C IDATE - 4-WORD ARRAY HOLDING "CENTRAL" DATE TO PROCESS
C - (YYYY, MM, DD, HH)
C IHE - NUMBER OF WHOLE HOURS RELATIVE TO "IDATE" FOR DATE OF
C - EARLIEST BUFR MESSAGE THAT IS TO BE DECODED; EARLIEST
C - DATE IS "IDATE" + "IHE" HOURS (IF "IHE" IS POSITIVE,
C - LATEST MESSAGE DATE IS AFTER "IDATE"; IF "IHE" IS
C - NEGATIVE LATEST MESSAGE DATE IS PRIOR TO "IDATE")
C - EXAMPLE: IF IHE=1, THEN EARLIEST DATE IS 1-HR AFTER
C - IDATE; IF IHE=-3, THEN EARLIEST DATE IS 3-HR PRIOR
C - TO IDATE
C IHL - NUMBER OF WHOLE HOURS RELATIVE TO "IDATE" FOR DATE OF
C - LATEST BUFR MESSAGE THAT IS TO BE DECODED; LATEST
C - DATE IS "IDATE" + ("IHL" HOURS PLUS 59 MIN) IF "IHL"
C - IS POSITIVE (LATEST MESSAGE DATE IS AFTER "IDATE"),
C - AND "IDATE" + ("IHL"+1 HOURS MINUS 1 MIN) IF "IHL"
C - IS NEGATIVE (LATEST MESSAGE DATE IS PRIOR TO "IDATE")
C - EXAMPLE: IF IHL=3, THEN LATEST DATE IS 3-HR 59-MIN
C - AFTER IDATE; IF IHL=-2, THEN LATEST DATE IS 1-HR 1-MIN
C - PRIOR TO IDATE
C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE
C IRET - CONTROLS DEGREE OF UNIT 6 PRINTOUT (.GE. 0 -LIMITED
C - PRINTOUT; = -1 SOME ADDITIONAL DIAGNOSTIC PRINTOUT;
C = .LT. -1 -EXTENSIVE PRINTOUT) (SEE REMARKS 3.)
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C RDATA - SINGLE REPORT RETURNED AN A QUASI-OFFICE NOTE 29
C - UNPACKED FORMAT (SEE REMARKS 4.) (MINIMUM SIZE IS
C - 1200 WORDS)
C IRET - RETURN CODE AS FOLLOWS:
C IRET = 0 ---> REPORT SUCCESSFULLY RETURNED
C IRET > 0 ---> NO REPORT RETURNED DUE TO:
C = 1 ---> ALL REPORTS READ IN, END
C = 2 ---> LAT AND/OR LON DATA MISSING
C = 3 ---> RESERVED
C = 4 ---> SOME/ALL DATE INFORMATION MISSING
C = 5 ---> NO DATA LEVELS PROCESSED (ALL LEVELS ARE MISSING)
C = 6 ---> NUMBER OF LEVELS IN REPORT HEADER IS NOT 1
C = 7 ---> NUMBER OF LEVELS IN ANOTHER SINGLE LEVEL SEQUENCE
C IS NOT 1
C
C INPUT FILES:
C UNIT AA - (WHERE AA IS LUNIT ABOVE) FILE HOLDING THE DATA
C - IN THE FORM OF BUFR MESSAGES
C
C OUTPUT FILES:
C UNIT 06 - PRINTOUT
C
C SUBPROGRAMS CALLED:
C UNIQUE - UNPK7701 UNPK7702 UNPK7703 UNPK7704 UNPK7705
C - UNPK7706 UNPK7707 UNPK7708 UNPK7709
C LIBRARY:
C W3LIB - W3FI04 W3MOVDAT W3DIFDAT ERREXIT
C BUFRLIB - DATELEN DUMPBF OPENBF READMG UFBCNT
C - READSB UFBINT CLOSBF
C
C REMARKS: 1) A CONDITION CODE (STOP) OF 15 WILL OCCUR IF THE INPUT
C DATES FOR START AND/OR STOP TIME ARE SPECIFIED INCORRECTLY.
C 2) A CONDITION CODE (STOP) OF 22 WILL OCCUR IF THE
C CHARACTERS ON THIS MACHINE ARE NEITHER ASCII NOR EBCDIC.
C 3) THE INPUT ARGUMENT "IRET" SHOULD BE SET PRIOR TO EACH
C CALL TO THIS SUBROUTINE.
C
C ***************************************************************
C 4)
C BELOW IS THE FORMAT OF AN UNPACKED REPORT IN OUTPUT ARRAY RDATA
C (EACH WORD REPRESENTS A FULL-WORD ACCORDING TO THE MACHINE)
C N O T E : THIS IS THE SAME FORMAT AS FOR W3LIB ROUTINE W3FI77
C EXCEPT WHERE NOTED
C ***************************************************************
C
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C FORMAT FOR WIND PROFILER REPORTS
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C HEADER
C WORD CONTENT UNIT FORMAT
C ---- ---------------------- ------------------- ---------
C 1 LATITUDE 0.01 DEGREES REAL
C 2 LONGITUDE 0.01 DEGREES WEST REAL
C 3 TIME SIGNIFICANCE (BUFR CODE TABLE "0 08 021") INTEGER
C 4 OBSERVATION TIME 0.01 HOURS (UTC) REAL
cvvvvvdak port
C 5 YEAR/MONTH 4-CHAR. 'YYMM' CHARACTER
caaaaadak port
C LEFT-JUSTIFIED
C 6 DAY/HOUR 4-CHARACTERS 'DDHH' CHARACTER
C 7 STATION ELEVATION METERS REAL
C 8 SUBMODE/EDITION NO. (SM X 10) + ED. NO. INTEGER
C (ED. NO.=2, CONSTANT; SEE &,~)
C 9 REPORT TYPE 71 (CONSTANT) INTEGER
C 10 AVERAGING TIME MINUTES INTEGER
C (NEGATIVE MEANS PRIOR TO OBS. TIME)
C 11 STN. ID. (FIRST 4 CHAR.) 4-CHARACTERS CHARACTER
C LEFT-JUSTIFIED
C 12 STN. ID. (LAST 2 CHAR.) 2-CHARACTERS CHARACTER
C LEFT-JUSTIFIED
C
C 13-34 ZEROED OUT - NOT USED INTEGER
C 35 CATEGORY 10, NO. LEVELS COUNT INTEGER
C 36 CATEGORY 10, DATA INDEX COUNT INTEGER
C 37 CATEGORY 11, NO. LEVELS COUNT INTEGER
C 38 CATEGORY 11, DATA INDEX COUNT INTEGER
C 39-42 ZEROED OUT - NOT USED INTEGER
C
C 43-END UNPACKED DATA GROUPS (FOLLOWS) REAL
C
C CATEGORY 10 - WIND PROFILER SFC DATA (EACH LEVEL, SEE WORD 35 ABOVE)
C WORD PARAMETER UNITS FORMAT
C ---- --------- ----------------- -------------
C(SEE @)1 SEA-LEVEL PRESSURE 0.1 MILLIBARS REAL
C(SEE *)2 STATION PRESSURE 0.1 MILLIBARS REAL
C(SEE @)3 HORIZ. WIND DIR. DEGREES REAL
C(SEE @)4 HORIZ. WIND SPEED 0.1 M/S REAL
C(SEE @)5 AIR TEMPERATURE 0.1 DEGREES K REAL
C(SEE @)6 RELATIVE HUMIDITY PERCENT REAL
C(SEE @)7 RAINFALL RATE 0.0000001 M/S REAL
C
C CATEGORY 11 - WIND PROFILER UPPER-AIR DATA (FIRST LEVEL IS SURFACE)
C (EACH LEVEL, SEE WORD 37 ABOVE)
C WORD PARAMETER UNITS FORMAT
C ---- --------- ----------------- -------------
C 1 HEIGHT ABOVE SEA-LVL METERS REAL
C 2 HORIZ. WIND DIR. DEGREES REAL
C 3 HORIZ. WIND SPEED 0.1 M/S REAL
C 4 QUALITY CODE (SEE %) INTEGER
C 5 VERT. WIND COMP. (W) 0.01 M/S REAL
C(SEE @)6 HORIZ. CONSENSUS NO. (SEE $) INTEGER
C(SEE @)7 VERT. CONSENSUS NO. (SEE $) INTEGER
C(SEE @)8 SPECTRAL PEAK POWER DB REAL
C 9 HORIZ. WIND SPEED 0.1 M/S REAL
C STANDARD DEVIATION 0.1 M/S REAL
C 10 VERT. WIND COMPONENT 0.1 M/S REAL
C STANDARD DEVIATION 0.1 M/S REAL
C(SEE @)11 MODE (SEE #) INTEGER
C
C *- ALWAYS MISSING
C &- THIS IS A CHANGE FROM FORMAT IN W3LIB ROUTINE W3FI77
C %- 0 - MEDIAN AND SHEAR CHECKS BOTH PASSED
C 2 - MEDIAN AND SHEAR CHECK RESULTS INCONCLUSIVE
C 4 - MEDIAN CHECK PASSED; SHEAR CHECK FAILED
C 8 - MEDIAN CHECK FAILED; SHEAR CHECK PASSED
C 12 - MEDIAN AND SHEAR CHECKS BOTH FAILED
C $- NO. OF INDIVIDUAL 6-MINUTE AVERAGE MEASUREMENTS THAT WERE
C INCLUDED IN FINAL ESTIMATE OF AVERAGED WIND (RANGE: 0, 2-10)
C (BASED ON A ONE-HOUR AVERAGE)
C #- 1 - DATA FROM LOW MODE
C 2 - DATA FROM HIGH MODE
C 3 - MISSING
C @- THIS PARAMETER IS NO LONGER AVAILABLE AFTER 3/2002 AND IS SET
C TO MISSING (99999 FOR INTEGER OR 99999. FOR REAL)
C ~- SUBMODE IS NO LONGER AVAILABLE AFTER 3/2002 AND IS SET TO 3
C (ITS MISSING VALUE)
C
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C FORMAT FOR GOES SOUNDING/RADIANCE REPORTS
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C HEADER
C WORD CONTENT UNIT FORMAT
C ---- ---------------------- ------------------- ---------
C 1 LATITUDE 0.01 DEGREES REAL
C 2 LONGITUDE 0.01 DEGREES WEST REAL
C 3 FIELD OF VIEW NUMBER NUMERIC INTEGER
C 4 OBSERVATION TIME 0.01 HOURS (UTC) REAL
cvvvvvdak port
C 5 YEAR/MONTH 4-CHAR. 'YYMM' CHARACTER
caaaaadak port
C LEFT-JUSTIFIED
C 6 DAY/HOUR 4-CHARACTERS 'DDHH' CHARACTER
C 7 STATION ELEVATION METERS REAL
C 8 PROCESS. TECHNIQUE (=21-CLEAR; INTEGER
C 8 PROCESS. TECHNIQUE =23-CLOUD-CORRECTED)
C 9 REPORT TYPE 61 (CONSTANT) INTEGER
C 10 QUALITY FLAG (BUFR CODE TABLE "0 33 002") INTEGER
C 11 STN. ID. (FIRST 4 CHAR.) 4-CHARACTERS CHARACTER
C LEFT-JUSTIFIED
C 12 STN. ID. (LAST 2 CHAR.) 2-CHARACTERS CHARACTER
C LEFT-JUSTIFIED (SEE %)
C
C 13-26 ZEROED OUT - NOT USED
C 27 CATEGORY 08, NO. LEVELS COUNT INTEGER
C 28 CATEGORY 08, DATA INDEX COUNT INTEGER
C 29-38 ZEROED OUT - NOT USED
C 39 CATEGORY 12, NO. LEVELS COUNT INTEGER
C 40 CATEGORY 12, DATA INDEX COUNT INTEGER
C 41 CATEGORY 13, NO. LEVELS COUNT INTEGER
C 42 CATEGORY 13, DATA INDEX COUNT INTEGER
C
C 43-END UNPACKED DATA GROUPS (FOLLOWS) REAL
C
C CATEGORY 12 - SATELLITE SOUNDING LEVEL DATA (FIRST LEVEL IS SURFACE;
C EACH LEVEL, SEE 39 ABOVE)
C WORD PARAMETER UNITS FORMAT
C ---- --------- ----------------- -------------
C 1 PRESSURE 0.1 MILLIBARS REAL
C 2 GEOPOTENTIAL METERS REAL
C 3 TEMPERATURE 0.1 DEGREES C REAL
C 4 DEWPOINT TEMPERATURE 0.1 DEGREES C REAL
C 5 NOT USED SET TO MISSING REAL
C 6 NOT USED SET TO MISSING REAL
C 7 QUALITY MARKERS 4-CHARACTERS CHARACTER
C LEFT-JUSTIFIED (SEE &)
C
C CATEGORY 13 - SATELLITE RADIANCE "LEVEL" DATA (EACH "LEVEL", SEE
C 41 ABOVE)
C WORD PARAMETER UNITS FORMAT
C ---- --------- ----------------- -------------
C 1 CHANNEL NUMBER NUMERIC INTEGER
C 2 BRIGHTNESS TEMP. 0.01 DEG. KELVIN REAL
C 3 QUALITY MARKERS 4-CHARACTERS CHARACTER
C LEFT-JUSTIFIED (SEE &&)
C
C CATEGORY 08 - ADDITIONAL (MISCELLANEOUS) DATA (EACH LEVEL, SEE @
C BELOW)
C WORD PARAMETER UNITS FORMAT
C ---- --------- ----------------- -------------
C 1 VARIABLE SEE @ BELOW REAL
C 2 CODE FIGURE SEE @ BELOW REAL
C 3 MARKERS 2-CHARACTERS CHARACTER
C LEFT-JUSTIFIED (SEE #)
C
C %- SIXTH CHARACTER OF STATION ID IS A TAGGED AS FOLLOWS:
C "I" - GOES-EVEN-1 (252, 256, ...) SAT. , CLEAR COLUMN RETR.
C "J" - GOES-EVEN-1 (252, 256, ...) SAT. , CLD-CORRECTED RETR.
C "L" - GOES-ODD-1 (253, 257, ...) SAT. , CLEAR COLUMN RETR.
C "M" - GOES-ODD-1 (253, 257, ...) SAT. , CLD-CORRECTED RETR.
C "O" - GOES-EVEN-2 (254, 258, ...) SAT. , CLEAR COLUMN RETR.
C "P" - GOES-EVEN-2 (254, 258, ...) SAT. , CLD-CORRECTED RETR.
C "Q" - GOES-ODD-2 (251, 255, ...) SAT. , CLEAR COLUMN RETR.
C "R" - GOES-ODD-2 (251, 255, ...) SAT. , CLD-CORRECTED RETR.
C "?" - EITHER SATELLITE AND/OR RETRIEVAL TYPE UNKNOWN
C &- FIRST CHARACTER IS Q.M. FOR GEOPOTENTIAL
C SECOND CHARACTER IS Q.M. FOR TEMPERATURE
C THIRD CHARACTER IS Q.M. FOR DEWPOINT TEMPERATURE
C FOURTH CHARACTER IS NOT USED
C " " - INDICATES DATA NOT SUSPECT
C "Q" - INDICATES DATA ARE SUSPECT
C "F" - INDICATES DATA ARE BAD
C &&- FIRST CHARACTER IS Q.M. FOR BRIGHTNESS TEMPERATURE
C SECOND-FOURTH CHARACTERS ARE NOT USED
C " " - INDICATES DATA NOT SUSPECT
C "Q" - INDICATES DATA ARE SUSPECT
C "F" - INDICATES DATA ARE BAD
C @- NUMBER OF "LEVELS" FROM WORD 27. MAXIMUM IS 12, AND ARE ORDERED
C AS FOLLOWS (IF A DATUM ARE MISSING THAT LEVEL NOT STORED)
C 1 - LIFTED INDEX ---------- .01 DEG. KELVIN -- C. FIG. 250.
C 2 - TOTAL PRECIP. WATER -- .01 MILLIMETERS -- C. FIG. 251.
C 3 - 1. TO .9 SIGMA P.WATER- .01 MILLIMETERS -- C. FIG. 252.
C 4 - .9 TO .7 SIGMA P.WATER- .01 MILLIMETERS -- C. FIG. 253.
C 5 - .7 TO .3 SIGMA P.WATER- .01 MILLIMETERS -- C. FIG. 254.
C 6 - SKIN TEMPERATURE ----- .01 DEG. KELVIN -- C. FIG. 255.
C 7 - CLOUD TOP TEMPERATURE- .01 DEG. KELVIN -- C. FIG. 256.
C 8 - CLOUD TOP PRESSURE --- .1 MILLIBARS ----- C. FIG. 257.
C 9 - CLOUD AMOUNT (BUFR TBL. C.T. 0-20-011) -- C. FIG. 258.
C 10 - INSTR. DATA USED IN PROC.
C (BUFR TBL. C.T. 0-02-021) -- C. FIG. 259.
C 11 - SOLAR ZENITH ANGLE --- .01 DEGREE ------- C. FIG. 260.
C 12 - SAT. ZENITH ANGLE ---- .01 DEGREE ------- C. FIG. 261.
C #- FIRST CHARACTER IS Q.M. FOR THE DATUM
C " " - INDICATES DATA NOT SUSPECT
C "Q" - INDICATES DATA ARE SUSPECT
C "F" - INDICATES DATA ARE BAD
C SECOND CHARACTER IS NOT USED
C
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C FORMAT FOR NEXRAD (VAD) WIND REPORTS
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C HEADER
C WORD CONTENT UNIT FORMAT
C ---- ---------------------- ------------------- ---------
C 1 LATITUDE 0.01 DEGREES REAL
C 2 LONGITUDE 0.01 DEGREES WEST REAL
C 3 ** RESERVED ** SET TO 99999 INTEGER
C 4 OBSERVATION TIME 0.01 HOURS (UTC) REAL
cvvvvvdak port
C 5 YEAR/MONTH 4-CHAR. 'YYMM' CHARACTER
caaaaadak port
C LEFT-JUSTIFIED
C 6 DAY/HOUR 4-CHARACTERS 'DDHH' CHARACTER
C 7 STATION ELEVATION METERS REAL
C 8 ** RESERVED ** SET TO 99999 INTEGER
C
C 9 REPORT TYPE 72 (CONSTANT) INTEGER
C 10 ** RESERVED ** SET TO 99999 INTEGER
C 11 STN. ID. (FIRST 4 CHAR.) 4-CHARACTERS CHARACTER
C LEFT-JUSTIFIED
C 12 STN. ID. (LAST 2 CHAR.) 2-CHARACTERS CHARACTER
C LEFT-JUSTIFIED
C
C 13-18 ZEROED OUT - NOT USED INTEGER
C 19 CATEGORY 04, NO. LEVELS COUNT INTEGER
C 20 CATEGORY 04, DATA INDEX COUNT INTEGER
C 21-42 ZEROED OUT - NOT USED INTEGER
C
C 43-END UNPACKED DATA GROUPS (FOLLOWS) REAL
C
C CATEGORY 04 - UPPER-AIR WINDS-BY-HEIGHT DATA(FIRST LEVEL IS SURFACE)
C (EACH LEVEL, SEE WORD 19 ABOVE)
C WORD PARAMETER UNITS FORMAT
C ---- --------- ----------------- -------------
C 1 HEIGHT ABOVE SEA-LVL METERS REAL
C 2 HORIZ. WIND DIR. DEGREES REAL
C 3 HORIZ. WIND SPEED 0.1 M/S (SEE *) REAL
C 4 QUALITY MARKERS 4-CHARACTERS CHARACTER
C LEFT-JUSTIFIED (SEE %)
C
C *- UNITS HERE DIFFER FROM THOSE IN TRUE UNPACKED OFFICE NOTE 29
C (WHERE UNITS ARE KNOTS)
C %- THE FIRST THREE CHARACTERS ARE ALWAYS BLANK, THE FOURTH
C CHARACTER IS A "CONFIDENCE LEVEL" WHICH IS RELATED TO THE ROOT-
C MEAN-SQUARE VECTOR ERROR FOR THE HORIZONTAL WIND. IT IS
C DEFINED AS FOLLOWS:
C 'A' = RMS OF 1.9 KNOTS
C 'B' = RMS OF 3.9 KNOTS
C 'C' = RMS OF 5.8 KNOTS
C 'D' = RMS OF 7.8 KNOTS
C 'E' = RMS OF 9.7 KNOTS
C 'F' = RMS OF 11.7 KNOTS
C 'G' = RMS > 13.6 KNOTS
CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C
C FOR ALL REPORT TYPES, MISSING VALUES ARE:
C 99999. FOR REAL
C 99999 FOR INTEGER
C 9'S FOR CHARACTERS IN WORD 5, 6 OF HEADER
C BLANK FOR CHARACTERS IN WORD 11, 12 OF HEADER
C AND FOR CHARACTERS IN ANY CATEGORY LEVEL
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 90
C MACHINE: IBM-SP, CRAY, SGI
C
C$$$
SUBROUTINE W3UNPK77(IDATE,IHE,IHL,LUNIT,RDATA,IRET)
CHARACTER*4 CBUFR
INTEGER IDATE(4),LSDATE(4),jdate(8),IDATA(1200)
dimension rinc(5)
REAL RDATA(*),RDATX(1200)
COMMON /PK77BB/kdate(8),ldate(8),IPRINT
COMMON /PK77CC/INDEX
COMMON /PK77DD/LSHE,LSHL,ICDATE(5),IDDATE(5)
COMMON /PK77FF/IFOV(3),KNTSAT(250:260)
SAVE
EQUIVALENCE (RDATX,IDATA)
DATA ITM/0/,LUNITL/-99/,KOUNT/0/
IPRINT = 0
IF(IRET.LT.0) IPRINT = IABS(IRET)
IRET = 0
IF(ITM.EQ.0) THEN
C-----------------------------------------------------------------------
C FIRST AND ONLY TIME INTO THIS SUBROUTINE DO A FEW THINGS....
ITM = 1
IFOV = 0
KNTSAT = 0
C DETERMINE MACHINE WORD LENGTH IN BYTES (=8 FOR CRAY) AND TYPE OF
C CHARACTER SET {ASCII(ICHTP=0) OR EBCDIC(ICHTP=1)}
CALL W3FI04(IENDN,ICHTP,LW)
PRINT 2213, LW, ICHTP, IENDN
2213 FORMAT(/' ---> W3UNPK77: CALL TO W3FI04 RETURNS: LW = ',I3,
$ ', ICHTP = ',I3,', IENDN = ',I3/)
IF(ICHTP.GT.1) THEN
C CHARACTERS ON THIS MACHINE ARE NEITHER ASCII OR EBCDIC!! -- STOP 22
PRINT 217
217 FORMAT(' *** W3UNPK77 ERROR: CHARACTERS ON THIS MACHINE ',
$ 'ARE NEITHER ASCII NOR EBCDIC - STOP 22'/)
CALL ERREXIT(22)
END IF
C-----------------------------------------------------------------------
END IF
IF(LUNIT.NE.LUNITL) THEN
C-----------------------------------------------------------------------
C IF THE INPUT DATA UNIT NUMBER ARGUMENT IS DIFFERENT THAT THE LAST TIME
C THIS SUBR. WAS CALLED, PRINT NEW HEADER, SET JRET = 1
LUNITL = LUNIT
JRET = 1
PRINT 101, LUNIT
101 FORMAT(//' ---> W3UNPK77: VERSION 03/05/2002: JBUFR DATA SET ',
$ 'READ FROM UNIT ',I4/)
C-----------------------------------------------------------------------
ELSE
C FOR SUBSEQUENT TIMES INTO THIS SUBR. W/ SAME LUNIT AS LAST TIME,
C TEST INPUT DATE & HR RANGE ARGUMENTS AGAINST THEIR VALUES THE LAST
C TIME SUBR. CALLED -- IF THEY ARE DIFFERENT, SET JRET = 1 (ELSE
C JRET = 0), WILL TEST JRET SOON
JRET = 1
DO I = 4,1,-1
IF(IDATE(I).NE.LSDATE(I)) GO TO 88
ENDDO
IF(IHE.NE.LSHE.OR.IHL.NE.LSHL) GO TO 88
JRET = 0
88 CONTINUE
C-----------------------------------------------------------------------
END IF
IF(JRET.EQ.1) THEN
PRINT 6680
6680 FORMAT(/' JRET = 1 - REWIND DATA FILE & SET-UP TO DO DATE CHECK'/)
C-----------------------------------------------------------------------
C COME HERE IF FIRST CALL TO SUBROUTINE OR IF INPUT DATA UNIT NUMBER OR
C IF INPUT DATE/TIME OR RANGE IN TIME HAS BEEN CHANGED FROM LAST CALL
C CLOSE BUFR DATA SET (IN CASE OPEN FROM PREVIOUS RUN)
C REWIND INPUT BUFR DATA SET, GET CENTER TIME AND DUMP TIME,
C OPEN BUFR DATA SET
C SET-UP TO DETERMINE IF BUFR MESSAGE IS WITHIN REQUESTED DATES
C (ALSO SET INDEX=0, FORCES BUFR MSG TO BE READ BEFORE RPTS ARE DECODED)
C-----------------------------------------------------------------------
CALL CLOSBF(LUNIT)
REWIND LUNIT
READ(LUNIT,END=9999,ERR=9999) CBUFR
IF(CBUFR.NE.'BUFR') GO TO 9999
call datelen(10)
CALL DUMPBF(LUNIT,ICDATE,IDDATE)
cppppp
print *,'CENTER DATE (ICDATE) = ',icdate
print *,'DUMP DATE (IDDATE) = ',iddate
cppppp
if(icdate(1).le.0) then
C COME HERE IF CENTER DATE COULD NOT BE READ FROM FIRST DUMMY MESSAGE
C - RETURN WITH IRET = 1
print *, ' *** W3UNPK77 ERROR: CENTER DATE COULD NOT BE ',
$ 'OBTAINED FROM INPUT FILE ON UNIT ',lunit
go to 9998
end if
if(iddate(1).le.0) then
C COME HERE IF DUMP DATE COULD NOT BE READ FROM SECOND DUMMY MESSAGE
C - RETURN WITH IRET = 1
print *, ' *** W3UNPK77 ERROR: DUMP DATE COULD NOT BE ',
$ 'OBTAINED FROM INPUT FILE ON UNIT ',lunit
go to 9998
end if
IF(ICDATE(1).LT.100) THEN
C If 2-digit year returned in ICDATE(1), must use "windowing" technique
C to create a 4-digit year
C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS
C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT
C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE)
PRINT *, '##W3UNPK77 - THE FOLLOWING SHOULD NEVER ',
$ 'HAPPEN!!!!!'
PRINT *, '##W3UNPK77 - 2-DIGIT YEAR IN ICDATE(1) ',
$ 'RETURNED FROM DUMPBF (ICDATE IS: ',ICDATE,') - USE ',
$ 'WINDOWING TECHNIQUE TO OBTAIN 4-DIGIT YEAR'
IF(ICDATE(1).GT.20) THEN
ICDATE(1) = 1900 + ICDATE(1)
ELSE
ICDATE(1) = 2000 + ICDATE(1)
ENDIF
PRINT *, '##WW3UNPK77 - CORRECTED ICDATE(1) WITH 4-DIGIT ',
$ 'YEAR, ICDATE NOW IS: ',ICDATE
ENDIF
IF(IDDATE(1).LT.100) THEN
C If 2-digit year returned in IDDATE(1), must use "windowing" technique
C to create a 4-digit year
C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS
C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT
C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE)
PRINT *, '##W3UNPK77 - THE FOLLOWING SHOULD NEVER ',
$ 'HAPPEN!!!!!'
PRINT *, '##W3UNPK77 - 2-DIGIT YEAR IN IDDATE(1) ',
$ 'RETURNED FROM DUMPBF (IDDATE IS: ',IDDATE,') - USE ',
$ 'WINDOWING TECHNIQUE TO OBTAIN 4-DIGIT YEAR'
IF(IDDATE(1).GT.20) THEN
IDDATE(1) = 1900 + IDDATE(1)
ELSE
IDDATE(1) = 2000 + IDDATE(1)
ENDIF
PRINT *, '##W3UNPK77 - CORRECTED IDDATE(1) WITH 4-DIGIT ',
$ 'YEAR, IDDATE NOW IS: ',IDDATE
END IF
C OPEN BUFR FILE - READ IN DICTIONARY MESSAGES (TABLE A, B, D ENTRIES)
CALL OPENBF(LUNIT,'IN',LUNIT)
PRINT 100, LUNIT
100 FORMAT(/5X,'===> BUFR DATA SET IN UNIT',I3,' SUCCESSFULLY ',
$ 'OPENED FOR INPUT; DCTNY MESSAGES CONTAIN BUFR TABLES A,B,D'/)
INDEX = 0
KOUNT = 0
jdate(1:3) = idate(1:3)
jdate(4) = 0
jdate(5) = idate(4)
jdate(6:8) = 0
PRINT 6681, IDATE
6681 FORMAT(/' %%% REQUESTED "CENTRAL" DATE IS :',I5,3I3,' 0'/)
C DETERMINE EARLIEST DATE FOR ACCEPTING BUFR MESSAGES FOR DECODING
call w3movdat((/0.,real(ihe),0.,0.,0./),jdate,kdate)
print 6682, (kdate(i),i=1,3),kdate(5),kdate(6)
6682 FORMAT(/' --> EARLIEST DATE FOR ACCEPTING BUFR MSGS IS:',I5,4I3/)
C DETERMINE LATEST DATE FOR ACCEPTING BUFR MESSAGES FOR DECODING
if(ihl.ge.0) then
xminl = (ihl * 60) + 59
else
xminl = ((ihl + 1) * 60) - 1
end if
call w3movdat((/0.,0.,xminl,0.,0./),jdate,ldate)
print 6683, (ldate(i),i=1,3),ldate(5),ldate(6)
6683 FORMAT(/' --> LATEST DATE FOR ACCEPTING BUFR MSGS IS:',I5,4I3/)
call w3difdat(ldate,kdate,3,rinc)
IF(rinc(3).LT.0) THEN
PRINT 104
104 FORMAT(' *** W3UNPK77 ERROR: DATES SPECIFIED INCORRECTLY -',
$ ' STOP 15'/)
CALL ERREXIT(15)
END IF
C-----------------------------------------------------------------------
END IF
C SUBR. UNPK7701 RETURNS A SINGLE DECODED REPORT FROM BUFR MESSAGE
CALL UNPK7701(LUNIT,ITP,IRET)
C IRET=1 MEANS ALL DATA HAVE BEEN DECODED FOR SPECIFIED TIME PERIOD
C (REWIND DATA FILE AND RETURN W/ IRET=1)
C IRET.GE.2 MEANS REPORT NOT RETURNED DUE TO ERROR IN DECODING (RETURN)
C (ACTUALLY IRET.GE.2 CURRENTLY CANNOT HAPPEN OUT OF UNPK7701)
IF(IRET.GE.1) THEN
IF(IRET.EQ.1) THEN
REWIND LUNIT
IF(ITP.EQ.2) THEN
PRINT 8101, IFOV
8101 FORMAT(/' ---> W3UNPK77: SUMMARY OF GOES REPORT COUNTS GROUPED',
$ ' BY F-O-V NO. (PRIOR TO ANY FILTERING BY CALLING PROGRAM)'/15X,
$ '# WITH F-O-V NO. 00 TO 02:',I6,' - GET "BAD" Q.MARK'/15X,
$ '# WITH F-O-V NO. 03 TO 09:',I6,' - GET "SUSPECT" Q.MARK'/15X,
$ '# WITH F-O-V NO. 10 TO 25:',I6,' - GET "NEUTRAL" Q.MARK'/20X,
$ '(NOTE: RADIANCES ALWAYS HAVE NEUTRAL Q.MARK)'/)
PRINT 8102
8102 FORMAT(/' ---> W3UNPK77: SUMMARY OF GOES REPORT COUNTS GROUPED',
$ ' BY SATELLITE ID (PRIOR TO ANY FILTERING BY CALLING PROGRAM)'/)
DO IDSAT = 250,259
IF(KNTSAT(IDSAT).GT.0) PRINT 8103, IDSAT,KNTSAT(IDSAT)
ENDDO
8103 FORMAT(15X,'NUMBER FROM SAT. ID',I4,4X,':',I6)
IF(KNTSAT(260).GT.0) PRINT 8104
8104 FORMAT(15X,'NUMBER FROM UNKNOWN SAT. ID:',I6)
PRINT 8105
8105 FORMAT(/)
END IF
END IF
GO TO 99
END IF
KOUNT = KOUNT + 1
C INITIALIZE THE OUTPUT ON29 ARRAY
CALL UNPK7702(RDATA,ITP)
IF(ITP.EQ.1) THEN
C-----------------------------------------------------------------------
C THE FOLLOWING PERTAINS TO WIND PROFILER REPORTS
C-----------------------------------------------------------------------
C STORE THE HEADER INFORMATION INTO ON29 FORMAT
CALL UNPK7703(LUNIT,RDATA,IRET)
C IRET.GE.2 MEANS RPT NOT RETURNED DUE TO MSG DATA IN HDR (RETURN)
IF(IRET.GE.2) GO TO 99
C STORE THE SURFACE DATA INTO ON29 FORMAT (CATEGORY 10)
CALL UNPK7704(LUNIT,RDATA)
C STORE THE UPPER-AIR DATA INTO ON29 FORMAT (CATEGORY 11)
CALL UNPK7705(LUNIT,RDATA)
RDATX(1:1200) = RDATA(1:1200)
IF(IDATA(35)+IDATA(37).EQ.0) IRET = 5
ELSE IF(ITP.EQ.2) THEN
C-----------------------------------------------------------------------
C THE FOLLOWING PERTAINS TO GOES SOUNDING/RADIANCE REPORTS
C-----------------------------------------------------------------------
C STORE THE HEADER INFORMATION INTO ON29 FORMAT
CALL UNPK7708(LUNIT,RDATA,KOUNT,IRET)
C IRET.GE.2 MEANS RPT NOT RETURNED DUE TO MSG DATA IN HDR (RETURN)
IF(IRET.GE.2) GO TO 99
C STORE THE UPPER-AIR DATA/RADIANCE INTO ON29 FORMAT (CATEGORY 12, 13)
CALL UNPK7709(LUNIT,RDATA,IRET)
ELSE IF(ITP.EQ.3) THEN
C-----------------------------------------------------------------------
C THE FOLLOWING PERTAINS TO NEXRAD (VAD) WIND REPORTS
C-----------------------------------------------------------------------
C STORE THE HEADER INFORMATION INTO ON29 FORMAT
CALL UNPK7706(LUNIT,RDATA,IRET)
C IRET.GE.2 MEANS RPT NOT RETURNED DUE TO MSG DATA IN HDR (RETURN)
IF(IRET.GE.2) GO TO 99
C STORE THE UPPER-AIR DATA INTO ON29 FORMAT (CATEGORY 4)
CALL UNPK7707(LUNIT,RDATA,IRET)
C-----------------------------------------------------------------------
END IF
99 CONTINUE
C PRIOR TO RETURNING SAVE INPUT DATE & HR RANGE ARGUMENTS FROM THIS CALL
lsdate = idate
LSHE = IHE
LSHL = IHL
RETURN
C-----------------------------------------------------------------------
9999 CONTINUE
C COME HERE IF NULL OR NON-BUFR FILE IS INPUT - RETURN WITH IRET = 1
PRINT *, ' *** W3UNPK77 ERROR: INPUT FILE IN UNIT ',LUNIT,' IS ',
$ 'EITHER A NULL OR NON-BUFR FILE'
9998 continue
REWIND LUNIT
IRET = 1
lsdate = idate
LSHE = IHE
LSHL = IHL
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: UNPK7701 READS A SINGLE REPORT OUT OF BUFR DATASET
C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1996-12-16
C
C ABSTRACT: CALLS BUFRLIB ROUTINES TO READ IN A BUFR MESSAGE AND THEN
C READ A SINGLE REPORT (SUBSET) OUT OF THE MESSAGE.
C
C PROGRAM HISTORY LOG:
C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR
C
C USAGE: CALL UNPK7701(LUNIT,ITP,IRET)
C INPUT ARGUMENT LIST:
C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C ITP - THE TYPE OF REPORT THAT HAS BEEN DECODED {=1 -
C - WIND PROFILER, =2 - GOES SNDG, =3 - NEXRAD(VAD) WIND}
C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK
C
C INPUT FILES:
C UNIT AA - (WHERE AA IS LUNIT ABOVE) FILE HOLDING THE DATA
C - IN THE FORM OF BUFR MESSAGES
C
C OUTPUT FILES:
C UNIT 06 - PRINTOUT
C
C REMARKS: CALLED BY SUBROUTINE W3UNPK77.
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 90
C MACHINE: IBM-SP, CRAY, SGI
C
C$$$
SUBROUTINE UNPK7701(LUNIT,ITP,IRET)
CHARACTER*8 SUBSET
integer mdate(4),ndate(8)
dimension rinc(5)
COMMON /PK77BB/kdate(8),ldate(8),IPRINT
COMMON /PK77CC/INDEX
COMMON /PK77DD/LSHE,LSHL,ICDATE(5),IDDATE(5)
SAVE
DATA IREC/0/
10 CONTINUE
C=======================================================================
IF(INDEX.EQ.0) THEN
C READ IN NEXT BUFR MESSAGE
CALL READMG(LUNIT,SUBSET,IBDATE,JRET)
IF(JRET.NE.0) THEN
C-----------------------------------------------------------------------
PRINT 101
101 FORMAT(' ---> W3UNPK77: ALL BUFR MESSAGES READ IN AND DECODED'/)
IRET = 1
RETURN
C-----------------------------------------------------------------------
END IF
if(ibdate.lt.100000000) then
c If input BUFR file does not return messages with a 4-digit year,
c something is wrong (even non-compliant BUFR messages should
c construct a 4-digit year as long as datelen(10) has been called
print *, '##W3UNP777/UNPK7701 - A 10-digit Sect. 1 BUFR ',
$ 'message date was not returned in unit ',lunit,' - ',
$ 'problem with BUFR file - ier = 1'
iret = 1
return
end if
CALL UFBCNT(LUNIT,IREC,ISUB)
MDATE(1) = IBDATE/1000000
MDATE(2) = MOD((IBDATE/10000),100)
MDATE(3) = MOD((IBDATE/100),100)
MDATE(4) = MOD(IBDATE,100)
C ALL JBUFR MESSAGES CURRENTLY HAVE "00" FOR MINUTES IN SECTION 1
ndate(1:3) = mdate(1:3)
ndate(4) = 0
ndate(5) = mdate(4)
ndate(6:8) = 0
IF(IPRINT.GE.1) THEN
PRINT *,'HAVE SUCCESSFULLY READ IN A BUFR MESSAGE'
PRINT 103
103 FORMAT(' BUFR FOUND BEGINNING AT BYTE 1 OF MESSAGE')
PRINT 105, IREC,MDATE,SUBSET
105 FORMAT(8X,'HAVE READ IN A BUFR MESSAGE NO.',I3,', DATE: ',
$ I6,3I4,' 0; TABLE A ENTRY = ',A8,' AND EDIT. NO. = 2'/)
END IF
IF(SUBSET.EQ.'NC002007') THEN
IF(IPRINT.GE.1) PRINT *, 'THIS MESSAGE CONTAINS WIND ',
$ 'PROFILER REPORTS'
ITP = 1
ELSE IF(SUBSET.EQ.'NC002008') THEN
IF(IPRINT.GE.1) PRINT *, 'THIS MESSAGE CONTAINS NEXRAD ',
$ '(VAD) WIND REPORTS'
ITP = 3
ELSE IF(SUBSET.EQ.'NC003001') THEN
IF(IPRINT.GE.1) PRINT *, 'THIS MESSAGE CONTAINS GOES ',
$ 'SOUNDING/RADIANCE REPORTS'
ITP = 2
ELSE
PRINT 107, IREC
107 FORMAT(' *** W3UNPK77 WARNING: BUFR MESSAGE NO.',I3,' CONTAINS ',
$ 'REPORTS THAT CANNOT BE DECODED BY W3UNPK77, TRY READING NEXT ',
$ 'MSG'/)
INDEX = 0
GO TO 10
END IF
call w3difdat(kdate,ndate,3,rinc)
kmin = rinc(3)
call w3difdat(ldate,ndate,3,rinc)
lmin = rinc(3)
C CHECK DATE OF MESSAGE AGAINST SPECIFIED TIME RANGES
if((kmin.gt.0.or.lmin.lt.0).AND.IREC.GT.2) then
PRINT 106, IREC,MDATE
106 FORMAT(' BUFR MESSAGE NO.',I3,' WITH DATE:',I5,3I3,' 0 NOT W/I',
$ ' REQ. TIME RANGE, TRY READING NEXT MSG'/)
INDEX = 0
GO TO 10
END IF
END IF
C=======================================================================
C READ NEXT SUBSET (REPORT) IN MESSAGE
IF(IPRINT.GT.1) PRINT *,'CALL READSB'
CALL READSB(LUNIT,JRET)
IF(IPRINT.GT.1) PRINT *,'BACK FROM READSB'
IF(JRET.NE.0) THEN
IF(INDEX.GT.0) THEN
C ALL SUBSETS IN THIS MESSAGE PROCESSED, READ IN NEXT MESSAGE (IF ALL
C MESSAGES READ IN NO MORE DATA TO PROCESS)
IF(IPRINT.GT.1) PRINT *, 'ALL REPORTS IN THIS MESSAGE ',
$ 'DECODED, GO ON TO NEXT MESSAGE'
ELSE
C THERE WERE NO SUBSETS FOUND IN THIS BUFR MESSAGE, GOOD CHANCE IT IS
C ONE OF TWO DUMMY MESSAGES AT TOP OF FILE INDICATING CENTER TIME AND
C DATA DUMP TIME ONLY; READ IN NEXT MESSAGE
IF(IREC.EQ.1) THEN
PRINT 4567, ICDATE
4567 FORMAT(/'===> BUFR MESSAGE NO. 1 IS A DUMMY MESSAGE CONTAINING ',
$ 'ONLY CENTER DATE (',I5,4I3,') - NO DATA - GO ON TO NEXT ',
$ 'MESSAGE'/)
ELSE IF(IREC.EQ.2) THEN
PRINT 4568, IDDATE
4568 FORMAT(/'===> BUFR MESSAGE NO. 2 IS A DUMMY MESSAGE CONTAINING ',
$ 'ONLY DUMP DATE (',I5,4I3,') - NO DATA - GO ON TO NEXT ',
$ 'MESSAGE'/)
ELSE
PRINT 4569, IREC,MDATE
4569 FORMAT(/'===> BUFR MESSAGE NO.',I3,' (DATE:',I5,3I3,' 0) ',
$ 'CONTAINS ZERO REPORTS FOR SOME UNEXPLAINED REASON - GO ON TO ',
$ 'NEXT MESSAGE'/)
END IF
END IF
INDEX = 0
GO TO 10
END IF
C-----------------------------------------------------------------------
IF(IPRINT.GT.1) PRINT *, 'READY TO PROCESS NEW DECODED REPORT'
C***********************************************************************
C A SINGLE REPORT HAS BEEN SUCCESSFULLY DECODED
C***********************************************************************
INDEX = INDEX + 1
IF(IPRINT.GE.1) PRINT *, 'WORKING WITH SUBSET NUMBER ',INDEX
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: UNPK7702 INITIALIZES THE OUTPUT ARRAY FOR A REPORT
C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1996-12-16
C
C ABSTRACT: INITIALIZES THE OUTPUT ARRAY WHICH HOLDS A SINGLE REPORT
C IN THE QUASI-OFFICE NOTE 29 UNPACKED FORMAT TO ALL MISSING.
C
C PROGRAM HISTORY LOG:
C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR
C
C USAGE: CALL UNPK7702(RDATA,ITP)
C INPUT ARGUMENT LIST:
C ITP - THE TYPE OF REPORT THAT HAS BEEN DECODED {=1 -
C - WIND PROFILER, =2 - GOES SNDG, =3 - NEXRAD(VAD) WIND}
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C RDATA - SINGLE REPORT RETURNED AN A QUASI-OFFICE NOTE 29
C UNPACKED FORMAT; ALL DATA ARE MISSING
C
C REMARKS: CALLED BY SUBROUTINE W3UNPK77.
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 90
C MACHINE: IBM-SP, CRAY, SGI
C
C$$$
SUBROUTINE UNPK7702(RDATA,ITP)
REAL RDATA(*),RDATX(1200)
INTEGER IDATA(1200),IRTYP(3)
CHARACTER*8 COB
C
SAVE
C
EQUIVALENCE (RDATX,IDATA),(COB,IOB)
DATA XMSG/99999./,IMSG/99999/,IRTYP/71,61,72/
RDATX(1) = XMSG
RDATX(2) = XMSG
IDATA(3) = IMSG
RDATX(4) = XMSG
COB = '999999 '
IDATA(5) = IOB
COB = '9999 '
IDATA(6) = IOB
RDATX(7) = XMSG
IDATA(8) = IMSG
IDATA(9) = IRTYP(ITP)
IDATA(10) = IMSG
COB = ' '
IDATA(11) = IOB
IDATA(12) = IOB
C
C ALL TYPES -- LOAD ZEROS INTO THE DEFINING WORD PAIRS
C
IDATA(13:42) = 0
C
C ALL TYPES -- LOAD MISSINGS INTO THE DATA PORTION
C
RDATX(43:1200) = XMSG
IF(ITP.EQ.1) THEN
C
C PROFILER -- LOAD INTEGER MISSING WHERE APPROPRIATE
C (Current limit of 104 Cat. 11 levels)
C
IDATA(53:1200:11) = IMSG
IDATA(55:1200:11) = IMSG
IDATA(56:1200:11) = IMSG
IDATA(60:1200:11) = IMSG
ELSE IF(ITP.EQ.2) THEN
C
C GOES -- LOAD DEFAULT OF BLANK CHARACTERS INTO CAT. 12
C LEVEL QUALITY MARKERS
C (Current limit of 50 Cat. 12 levels)
C (could be expanded if need be)
C
IDATA(49:392:7) = IOB
C
C GOES -- LOAD DEFAULT OF BLANK CHARACTER INTO FIRST CAT. 08
C LEVEL QUALITY MARKER
C (Current limit of 9 Cat. 08 levels)
C (could be expanded if need be)
C
IDATA(395:419:3) = IOB
C GOES -- LOAD INTEGER MISSING INTO CAT. 13 LEVEL CHANNEL NUMBER
C -- LOAD DEFAULT OF BLANK CHARACTER INTO CAT. 13 LEVEL
C QUALITY MARKER
C (Current limit of 60 Cat. 13 levels)
C (could be expanded if need be)
C
IDATA(420:599:3) = IMSG
IDATA(422:599:3) = IOB
ELSE IF(ITP.EQ.3) THEN
C
C VADWND -- LOAD DEFAULT OF BLANK CHARACTER INTO HGHT CAT. 04
C LEVEL QUALITY MARKER
C (Current limit of 70 Cat. 04 levels)
C (could be expanded if need be)
C
IDATA(46:1200:4) = IOB
END IF
RDATA(1:1200) = RDATX(1:1200)
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: UNPK7703 FILLS IN HEADER IN O-PUT ARRAY - PFLR RPT
C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-03-05
C
C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN
C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE
C HEADER DATA FOR WIND PROFILER REPORT. HEADER IS THEN FILLED INTO
C THE OUTPUT ARRAY WHICH HOLDS A SINGLE WIND PROFILER REPORT IN THE
C QUASI-OFFICE NOTE 29 UNPACKED FORMAT.
C
C PROGRAM HISTORY LOG:
C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR
C 2002-03-05 KEYSER -- ACCOUNTS FOR CHANGES IN INPUT PROFLR (WIND
C PROFILER) BUFR DUMP FILE AFTER 3/2002: MNEMONIC
C "NPSM" IS NO LONGER AVAILABLE, MNEMONIC "TPSE"
C REPLACES "TPMI" (AVG. TIME IN MINUTES STILL
C OUTPUT) (WILL STILL WORK PROPERLY FOR INPUT
C PROFLR DUMP FILES PRIOR TO 3/2002)
C
C USAGE: CALL UNPK7703(LUNIT,RDATA,IRET)
C INPUT ARGUMENT LIST:
C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE
C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29
C - UNPACKED FORMAT WITH ALL DATA INITIALIZED AS MISSING
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29
C - UNPACKED FORMAT WITH HEADER INFORMATION FILLED IN
C - (ALL OTHER DATA REMAINS MISSING)
C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK
C
C OUTPUT FILES:
C UNIT 06 - PRINTOUT
C
C REMARKS: CALLED BY SUBROUTINE W3UNPK77.
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 90
C MACHINE: IBM-SP, CRAY, SGI
C
C$$$
SUBROUTINE UNPK7703(LUNIT,RDATA,IRET)
CHARACTER*6 STNID
CHARACTER*8 COB
CHARACTER*35 HDR1,HDR2
INTEGER IDATA(1200)
REAL(8) HDR_8(16)
REAL HDR(16),RDATA(*),RDATX(1200)
COMMON /PK77BB/kdate(8),ldate(8),IPRINT
SAVE
EQUIVALENCE (RDATX,IDATA),(COB,IOB)
DATA XMSG/99999./,IMSG/99999/
DATA HDR1/'CLAT CLON TSIG SELV NPSM TPSE WMOB '/
DATA HDR2/'WMOS YEAR MNTH DAYS HOUR MINU TPMI '/
RDATX(1:1200) = RDATA(1:1200)
HDR_8 = 10.0E10
CALL UFBINT(LUNIT,HDR_8,16,1,NLEV,HDR1//HDR2);HDR=HDR_8
IF(NLEV.NE.1) THEN
C.......................................................................
C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED --
C SET IRET = 6 AND RETURN
PRINT 217, NLEV
217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',I5,') ',
$ 'IS NOT WHAT IS EXPECTED (1) - IRET = 6'/)
IRET = 6
RETURN
C.......................................................................
END IF
C LATITUDE (STORED AS REAL)
M = 1
IF(IPRINT.GT.1) PRINT 199, HDR(1),M
199 FORMAT(5X,'HDR HERE IS: ',F17.4,'; INDEX IS: ',I3)
IF(HDR(1).LT.XMSG) THEN
RDATX(1) = NINT(HDR(1) * 100.)
NNNNN = 1
IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN)
198 FORMAT(5X,'DATA(',I5,') STORED AS: ',F10.2)
ELSE
IRET = 2
PRINT 102
102 FORMAT(' *** W3UNPK77 ERROR: LAT MISSING FOR WIND PROFILER ',
$ 'REPORT'/)
RETURN
END IF
C LONGITUDE (STORED AS REAL)
M = 2
IF(IPRINT.GT.1) PRINT 199, HDR(2),M
IF(HDR(2).LT.XMSG) THEN
RDATX(2) = NINT(MOD((36000.-(HDR(2)*100.)),36000.))
NNNNN = 2
IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN)
ELSE
IRET = 2
PRINT 104
104 FORMAT(' *** W3UNPK77 ERROR: LON MISSING FOR WIND PROFILER ',
$ 'REPORT'/)
RETURN
END IF
C TIME SIGNIFICANCE (STORED AS INTEGER)
M = 3
IF(IPRINT.GT.1) PRINT 199, HDR(3),M
IF(HDR(3).LT.XMSG) IDATA(3) = NINT(HDR(3))
NNNNN = 3
IF(IPRINT.GT.1) PRINT 197, NNNNN,IDATA(NNNNN)
197 FORMAT(5X,'IDATA(',I5,') STORED AS: ',I10)
C STATION ELEVATION (FROM REPORTED STN. HGHT; STORED IN OUTPUT)
C (STORED AS REAL)
M = 4
IF(IPRINT.GT.1) PRINT 199, HDR(4),M
IF(HDR(4).LT.XMSG) RDATX(7) = NINT(HDR(4))
NNNNN = 7
IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN)
C SUBMODE INFORMATION
C EDITION NUMBER (ALWAYS = 2)
C (PACKED AS SUBMODE TIMES 10 PLUS EDITION NUMBER - INTEGER)
C {NOTE: After 3/2002, the submode information is no longer
C available and is stored as missing (3).}
M = 5
IEDTN = 2
IDATA(8) = (3 * 10) + IEDTN
IF(IPRINT.GT.1) PRINT 199, HDR(5),M
IF(HDR(5).LT.XMSG) IDATA(8) = (NINT(HDR(5)) * 10) + IEDTN
NNNNN = 8
IF(IPRINT.GT.1) PRINT 197, NNNNN,IDATA(NNNNN)
C AVERAGING TIME (STORED AS INTEGER)
C (NOTE: Prior to 3/2002, this is decoded in minutes, after
C 3/2002 this is decoded in seconds - in either case
C it is stored in minutes)
M = 6
IF(IPRINT.GT.1) PRINT 199, HDR(6),M
IF(IPRINT.GT.1) PRINT 199, HDR(14),M
IF(HDR(6).LT.XMSG) THEN
IDATA(10) = NINT(HDR(6)/60.)
ELSE IF(HDR(14).LT.XMSG) THEN
IDATA(10) = NINT(HDR(14))
END IF
NNNNN = 10
IF(IPRINT.GT.1) PRINT 197, NNNNN,IDATA(NNNNN)
C-----------------------------------------------------------------------
C STATION IDENTIFICATION (STORED AS CHARACTER)
C (OBTAINED FROM ENCODED WMO BLOCK/STN NUMBERS)
STNID = ' '
C WMO BLOCK NUMBER (STORED AS CHARACTER)
M = 7
IF(IPRINT.GT.1) PRINT 199, HDR(7),M
IF(HDR(7).LT.XMSG) WRITE(STNID(1:2),'(I2.2)') NINT(HDR(7))
C WMO STATION NUMBER (STORED AS CHARACTER)
M = 8
IF(IPRINT.GT.1) PRINT 199, HDR(8),M
IF(HDR(8).LT.XMSG) WRITE(STNID(3:5),'(I3.3)') NINT(HDR(8))
COB(1:4) = STNID(1:4)
IDATA(11) = IOB
NNNNN = 11
IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4)
196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A4,'"')
COB(1:4) = STNID(5:6)//' '
IDATA(12) = IOB
NNNNN = 12
IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4)
cvvvvvdak port
C LOAD THE YEAR/MONTH (STORED AS CHARACTER IN FORM YYMM)
caaaaadak port
M = 9
IF(IPRINT.GT.1) PRINT 199, HDR(9),M
IYEAR = IMSG
IF(HDR(9).LT.XMSG) IYEAR = NINT(HDR(9))
M = 10
IF(IPRINT.GT.1) PRINT 199, HDR(10),M
IF(HDR(10).LT.XMSG.AND.IYEAR.LT.IMSG) THEN
cvvvvvdak port
IYEAR = MOD(IYEAR,100)
caaaaadak port
IYEAR = NINT(HDR(10)) + (IYEAR * 100)
cvvvvvdak port
cdak WRITE(COB,'(I6.6,2X)') IYEAR
WRITE(COB,'(I4.4,4X)') IYEAR
caaaaadak port
IDATA(5) = IOB
NNNNN = 5
IF(IPRINT.GT.1) PRINT 9196, NNNNN,COB(1:6)
9196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A6,'"')
ELSE
GO TO 30
END IF
C LOAD THE DAY/HOUR (STORED AS CHARACTER IN FORM DDHH)
C AND THE OBSERVATION TIME (STORED AS REAL)
M = 11
IF(IPRINT.GT.1) PRINT 199, HDR(11),M
IDAY = IMSG
IF(HDR(11).LT.XMSG) IDAY = NINT(HDR(11))
M = 12
IF(IPRINT.GT.1) PRINT 199, HDR(12),M
IF(HDR(12).LT.XMSG.AND.IDAY.LT.IMSG) THEN
IHRT = NINT(HDR(12))
M = 13
IF(IPRINT.GT.1) PRINT 199, HDR(13),M
IF(HDR(13).GE.XMSG) GO TO 30
RMNT = HDR(13)
RDATX(4) = NINT((IHRT * 100.) + (RMNT * 100.)/60.)
NNNNN = 4
IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN)
IHRT = IHRT + (IDAY * 100)
WRITE(COB(1:4),'(I4.4)') IHRT
IDATA(6) = IOB
NNNNN = 6
IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4)
ELSE
GO TO 30
END IF
RDATA(1:1200) = RDATX(1:1200)
RETURN
30 CONTINUE
IRET = 4
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: UNPK7704 FILLS CAT.10 INTO O-PUT ARRAY - PFLR RPT
C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-03-05
C
C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN
C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE
C SURFACE DATA FOR WIND PROFILER REPORT. SURFACE DATA ARE THEN
C FILLED INTO THE OUTPUT ARRAY AS CATEGORY 10. THE OUPUT ARRAY
C HOLDS A SINGLE WIND PROFILER REPORT IN THE QUASI-OFFICE NOTE 29
C UNPACKED FORMAT.
C
C PROGRAM HISTORY LOG:
C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR
C 2002-03-05 KEYSER -- ACCOUNTS FOR CHANGES IN INPUT PROFLR (WIND
C PROFILER) BUFR DUMP FILE AFTER 3/2002: SURFACE
C DATA NOW ALL MISSING (MNEMONICS "PMSL",
C "WDIR1","WSPD1", "TMDB", "REHU", "REQV" NO
C LONGER AVAILABLE) (WILL STILL WORK PROPERLY FOR
C INPUT PROFLR DUMP FILES PRIOR TO 3/2002)
C
C USAGE: CALL UNPK7704(LUNIT,RDATA)
C INPUT ARGUMENT LIST:
C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE
C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29
C - UNPACKED FORMAT WITH ONLY HEADER INFORMATION FILLED
C - IN (ALL OTHER DATA REMAINS MISSING)
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29
C - UNPACKED FORMAT WITH SURFACE INFORMATION FILLED IN
C - (AS WELL AS THE HEADER; ALL OTHER DATA REMAINS
C - MISSING)
C
C OUTPUT FILES:
C UNIT 06 - PRINTOUT
C
C REMARKS: CALLED BY SUBROUTINE W3UNPKB7. AFTER 3/2002, THERE IS
C NO SURFACE DATA AVAILABLE.
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 90
C MACHINE: IBM-SP, CRAY, SGI
C
C$$$
SUBROUTINE UNPK7704(LUNIT,RDATA)
CHARACTER*40 SRFC
INTEGER IDATA(1200)
REAL(8) SFC_8(8)
REAL SFC(8),RDATA(*),RDATX(1200)
COMMON /PK77BB/kdate(8),ldate(8),IPRINT
SAVE
EQUIVALENCE (RDATX,IDATA)
DATA XMSG/99999./
DATA SRFC/'PMSL WDIR1 WSPD1 TMDB REHU REQV '/
RDATX(1:1200) = RDATA(1:1200)
SFC_8 = 10.0E10
CALL UFBINT(LUNIT,SFC_8,8,1,NLEV,SRFC);SFC=SFC_8
IF(NLEV.NE.1) THEN
C.......................................................................
C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED --
PRINT 217, NLEV
217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',I5,') ',
$ 'IS NOT WHAT IS EXPECTED (1) - NO SFC DATA PROCESSED'/)
GO TO 99
C.......................................................................
END IF
C MSL PRESSURE (STORED AS REAL)
M = 1
IF(IPRINT.GT.1) PRINT 199, SFC(1),M
199 FORMAT(5X,'SFC HERE IS: ',F17.4,'; INDEX IS: ',I3)
IF((SFC(1)*0.1).LT.XMSG) RDATX(43) = NINT(SFC(1) * 0.1)
NNNNN = 43
IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(43)
198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2)
C SURFACE HORIZONTAL WIND DIRECTION (STORED AS REAL)
M = 2
IF(IPRINT.GT.1) PRINT 199, SFC(2),M
IF(SFC(2).LT.XMSG) RDATX(43+2) = NINT(SFC(2))
NNNNN = 43 + 2
IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(43+2)
C SURFACE HORIZONTAL WIND SPEED (STORED AS REAL)
M = 3
IF(IPRINT.GT.1) PRINT 199, SFC(3),M
IF(SFC(3).LT.XMSG) RDATX(43+3) = NINT(SFC(3) * 10.)
NNNNN = 43 + 3
IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(43+3)
C SURFACE TEMPERATURE (STORED AS REAL)
M = 4
IF(IPRINT.GT.1) PRINT 199, SFC(4),M
IF(SFC(4).LT.XMSG) RDATX(43+4) = NINT(SFC(4) * 10.)
NNNNN = 43 + 4
IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(43+4)
C RELATIVE HUMIDITY (STORED AS REAL)
M = 5
IF(IPRINT.GT.1) PRINT 199, SFC(5),M
IF(SFC(5).LT.XMSG) RDATX(43+5) = NINT(SFC(5))
NNNNN = 43 + 5
IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(43+5)
C RAINFALL RATE (STORED AS REAL)
M = 6
IF(IPRINT.GT.1) PRINT 199, SFC(6),M
IF(SFC(6).LT.XMSG) RDATX(43+6) = NINT(SFC(6) * 1.E7)
NNNNN = 43 + 6
IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(43+6)
C SET CATEGORY COUNTERS FOR SURFACE DATA
IDATA(35) = 1
IDATA(36) = 43
99 CONTINUE
IF(IPRINT.GT.1) PRINT *, 'IDATA(35)=',IDATA(35),'; IDATA(36)=',
$ IDATA(36)
RDATA(1:1200) = RDATX(1:1200)
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: UNPK7705 FILLS CAT.11 INTO O-PUT ARRAY - PFLR RPT
C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-03-05
C
C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN
C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE
C UPPER-AIR DATA FOR WIND PROFILER REPORT. UPPER-AIR DATA ARE THEN
C FILLED INTO THE OUTPUT ARRAY AS CATEGORY 11. THE OUPUT ARRAY
C HOLDS A SINGLE WIND PROFILER REPORT IN THE QUASI-OFFICE NOTE 29
C UNPACKED FORMAT.
C
C PROGRAM HISTORY LOG:
C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR
C 1998-07-09 KEYSER -- MODIFIED WIND PROFILER CAT. 11 (HEIGHT, HORIZ.
C SIGNIFICANCE, VERT. SIGNIFICANCE) PROCESSING
C TO ACCOUNT FOR UPDATES TO BUFRTABLE MNEMONICS
C IN /dcom
C 2002-03-05 KEYSER -- ACCOUNTS FOR CHANGES IN INPUT PROFLR (WIND
C PROFILER) BUFR DUMP FILE AFTER 3/2002:
C MNEMONICS "ACAVH", "ACAVV", "SPP0", AND "NPHL"
C NO LONGER AVAILABLE; (WILL STILL WORK PROPERLY
C FOR INPUT PROFLR DUMP FILES PRIOR TO 3/2002)
C
C USAGE: CALL UNPK7705(LUNIT,RDATA)
C INPUT ARGUMENT LIST:
C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE
C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29
C - UNPACKED FORMAT WITH ONLY HEADER AND SURFACE
C - INFORMATION FILLED IN (UPPER-AIR DATA MISSING)
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29
C - UNPACKED FORMAT WITH UPPER-AIR INFORMATION FILLED
C - IN (ALL DATA FOR REPORT NOW FILLED)
C
C OUTPUT FILES:
C UNIT 06 - PRINTOUT
C
C REMARKS: CALLED BY SUBROUTINE W3UNPK77.
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 90
C MACHINE: IBM-SP, CRAY, SGI
C
C$$$
SUBROUTINE UNPK7705(LUNIT,RDATA)
CHARACTER*31 UAIR1,UAIR2
CHARACTER*16 UAIR3
INTEGER IDATA(1200)
REAL(8) UAIR_8(16,255)
REAL UAIR(16,255),RDATA(*),RDATX(1200)
COMMON /PK77BB/kdate(8),ldate(8),IPRINT
SAVE
EQUIVALENCE (RDATX,IDATA)
DATA XMSG/99999./
DATA UAIR1/'HEIT WDIR WSPD NPQC WCMP ACAVH '/
DATA UAIR2/'ACAVV SPP0 SDHS SDVS NPHL '/
DATA UAIR3/'HAST ACAV1 ACAV2'/
RDATX(1:1200) = RDATA(1:1200)
NSFC = 0
ILVL = 0
ILC = 0
C FIRST UPPER-AIR LEVEL IS THE SURFACE INFORMATION
IF(IPRINT.GT.1) PRINT 1078, ILC,ILVL
1078 FORMAT(' ATTEMPTING 1ST (SFC) LVL WITH ILC =',I5,'; NO. LEVELS ',
$ 'PROCESSED TO NOW =',I5)
RDATX(50+ILC) = RDATX(7)
IF(IPRINT.GT.1) PRINT 198, 50+ILC,RDATX(50+ILC)
198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2)
IF(RDATX(50+ILC).LT.XMSG) NSFC = 1
IF(IDATA(35).GE.1) THEN
RDATX(50+ILC+1) = RDATX(IDATA(36)+2)
RDATX(50+ILC+2) = RDATX(IDATA(36)+3)
END IF
IF(IPRINT.GT.1) PRINT 198, 50+ILC+1,RDATX(50+ILC+1)
IF(RDATX(50+ILC+1).LT.XMSG) NSFC = 1
IF(IPRINT.GT.1) PRINT 198, 50+ILC+2,RDATX(50+ILC+2)
IF(RDATX(50+ILC+2).LT.XMSG) NSFC = 1
ILVL = ILVL + 1
ILC = ILC + 11
IF(IPRINT.GT.1) PRINT *,'HAVE COMPLETED LEVEL ',ILVL,' WITH ',
$ 'NSFC=',NSFC,'; GOING INTO NEXT LEVEL WITH ILC=',ILC
UAIR_8 = 10.0E10
CALL UFBINT(LUNIT,UAIR_8,16,255,NLEV,UAIR1//UAIR2//UAIR3)
UAIR=UAIR_8
IF(NLEV.EQ.0) THEN
C.......................................................................
C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO --
IF(NSFC.EQ.0) THEN
C ... NO UPPER AIR DATA PROCESSED
PRINT 217
217 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA PROCESSED FOR THIS',
$ ' REPORT -- NLEV = 0 AND NSFC = 0'/)
GO TO 99
ELSE
C ... ONLY FIRST (SURFACE) UPPER AIR LEVEL DATA PROCESSED
PRINT 218
218 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA ABOVE FIRST (SURFACE) ',
$ 'LEVEL PROCESSED FOR THIS REPORT -- NLEV = 0 AND NSFC > 0'/)
GO TO 98
END IF
C.......................................................................
END IF
IF(IPRINT.GT.1) PRINT 1068, NLEV
1068 FORMAT(' THIS REPORT CONTAINS ',I3,' LEVELS OF DATA (NOT ',
$ 'INCLUDING BOTTOM -SURFACE- LEVEL)')
DO I = 1,NLEV
IF(IPRINT.GT.1) PRINT 1079, ILC,ILVL
1079 FORMAT(' ATTEMPTING NEW LEVEL WITH ILC =',I5,'; NO. LEVELS ',
$ 'PROCESSED TO NOW =',I5)
C HEIGHT ABOVE SEA-LEVEL (STORED AS REAL)
C (NOTE: At one time, possibly even now, the height above sea
C level was erroneously stored under mnemonic "HAST"
C when it should have been stored under mnemonic "HEIT".
C ("HAST" is defined as the height above the station.)
C Will test first for valid data in "HEIT" - if missing,
C then will use data in "HAST" - this will allow this
C routine to transition w/o change when the fix is made.)
IF(UAIR(1,I).LT.XMSG) THEN
M = 1
IF(IPRINT.GT.1) PRINT 199, UAIR(1,I),M
199 FORMAT(5X,'UAIR HERE IS: ',F17.4,'; INDEX IS: ',I3)
RDATX(50+ILC) = NINT(UAIR(1,I))
ELSE
M = 12
IF(IPRINT.GT.1) PRINT 199, UAIR(12,I),M
IF(UAIR(12,I).LT.XMSG) RDATX(50+ILC) = NINT(UAIR(12,I))
END IF
IF(IPRINT.GT.1) PRINT 198, 50+ILC,RDATX(50+ILC)
ILVL = ILVL + 1
C HORIZONTAL WIND DIRECTION (STORED AS REAL)
M = 2
IF(IPRINT.GT.1) PRINT 199, UAIR(2,I),M
IF(UAIR(2,I).LT.XMSG) RDATX(50+ILC+1) = NINT(UAIR(2,I))
IF(IPRINT.GT.1) PRINT 198, 50+ILC+1,RDATX(50+ILC+1)
C HORIZONTAL WIND SPEED (STORED AS REAL)
M = 3
IF(IPRINT.GT.1) PRINT 199, UAIR(3,I),M
IF(UAIR(3,I).LT.XMSG) RDATX(50+ILC+2) =NINT(UAIR(3,I) * 10.)
IF(IPRINT.GT.1) PRINT 198, 50+ILC+2,RDATX(50+ILC+2)
C QUALITY CODE (STORED AS INTEGER)
M = 4
IF(IPRINT.GT.1) PRINT 199, UAIR(4,I),M
IF(UAIR(4,I).LT.XMSG) IDATA(50+ILC+3) = NINT(UAIR(4,I))
IF(IPRINT.GT.1) PRINT 197, 50+ILC+3,IDATA(50+ILC+3)
197 FORMAT(5X,'IDATA(',I5,') STORED AS: ',I10)
C VERTICAL WIND COMPONENT (W) (STORED AS REAL)
M = 5
IF(IPRINT.GT.1) PRINT 199, UAIR(5,I),M
IF(UAIR(5,I).LT.XMSG) RDATX(50+ILC+4) = NINT(UAIR(5,I) * 100.)
IF(IPRINT.GT.1) PRINT 198, 50+ILC+4,RDATX(50+ILC+4)
C HORIZONTAL CONSENSUS NUMBER (STORED AS INTEGER)
C (NOTE: Prior to 2/18/1999, the horizonal consensus number was
C stored under mnemonic "ACAV1".
C From 2/18/1999 through 3/2002, the horizontal consensus
C number was stored under mnemonic "ACAVH".
C After 3/2002, the horizontal consensus number is no
C longer stored.
C Will test first for valid data in "ACAVH" - if missing,
C then will test for data in "ACAV1" - this will allow
C this routine to work properly with historical data.)
IF(IPRINT.GT.1) PRINT 199, UAIR(6,I),M
IF(IPRINT.GT.1) PRINT 199, UAIR(13,I),M
IF(UAIR(6,I).LT.XMSG) THEN
M = 6
IDATA(50+ILC+5) = NINT(UAIR(6,I))
ELSE
M = 13
IF(UAIR(13,I).LT.XMSG) IDATA(50+ILC+5) = NINT(UAIR(13,I))
END IF
IF(IPRINT.GT.1) PRINT 197, 50+ILC+5,IDATA(50+ILC+5)
C VERTICAL CONSENSUS NUMBER (STORED AS INTEGER)
C (NOTE: Prior to 2/18/1999, the vertical consensus number was
C stored under mnemonic "ACAV2".
C From 2/18/1999 through 3/2002, the vertical consensus
C number was stored under mnemonic "ACAVV".
C After 3/2002, the vertical consensus number is no
C longer stored.
C Will test first for valid data in "ACAVV" - if missing,
C then will test for data in "ACAV2" - this will allow
C this routine to work properly with historical data.)
IF(IPRINT.GT.1) PRINT 199, UAIR(7,I),M
IF(IPRINT.GT.1) PRINT 199, UAIR(14,I),M
IF(UAIR(7,I).LT.XMSG) THEN
M = 7
IDATA(50+ILC+6) = NINT(UAIR(7,I))
ELSE
M = 14
IF(UAIR(14,I).LT.XMSG) IDATA(50+ILC+6) = NINT(UAIR(14,I))
END IF
IF(IPRINT.GT.1) PRINT 197, 50+ILC+6,IDATA(50+ILC+6)
C SPECTRAL PEAK POWER (STORED AS REAL)
C (NOTE: After 3/2002, the spectral peak power is no longer
C stored.)
M = 8
IF(IPRINT.GT.1) PRINT 199, UAIR(8,I),M
IF(UAIR(8,I).LT.XMSG) RDATX(50+ILC+7) = NINT(UAIR(8,I))
IF(IPRINT.GT.1) PRINT 198, 50+ILC+7,RDATX(50+ILC+7)
C HORIZONTAL WIND SPEED STANDARD DEVIATION (STORED AS REAL)
M = 9
IF(IPRINT.GT.1) PRINT 199, UAIR(9,I),M
IF(UAIR(9,I).LT.XMSG) RDATX(50+ILC+8)=NINT(UAIR(9,I) * 10.)
IF(IPRINT.GT.1) PRINT 198, 50+ILC+8,RDATX(50+ILC+8)
C VERTICAL WIND COMPONENT STANDARD DEVIATION (STORED AS REAL)
M = 10
IF(IPRINT.GT.1) PRINT 199, UAIR(10,I),M
IF(UAIR(10,I).LT.XMSG) RDATX(50+ILC+9) =NINT(UAIR(10,I) * 10.)
IF(IPRINT.GT.1) PRINT 198, 50+ILC+9,RDATX(50+ILC+9)
C MODE INFORMATION (STORED AS INTEGER)
C (NOTE: After 3/2002, the mode information is no longer stored.)
M = 11
IF(IPRINT.GT.1) PRINT 199, UAIR(11,I),M
IF(UAIR(11,I).LT.XMSG) IDATA(50+ILC+10) = NINT(UAIR(11,I))
IF(IPRINT.GT.1) PRINT 197, 50+ILC+10,IDATA(50+ILC+10)
C.......................................................................
ILC = ILC + 11
IF(IPRINT.GT.1) PRINT *,'HAVE COMPLETED LEVEL ',ILVL,
$ '; GOING INTO NEXT LEVEL WITH ILC=',ILC
ENDDO
C SET CATEGORY COUNTERS FOR UPPER-AIR DATA
98 CONTINUE
IDATA(37) = ILVL
IDATA(38) = 50
99 CONTINUE
IF(IPRINT.GT.1) PRINT *, 'NSFC=',NSFC,'; IDATA(37)=',IDATA(37),
$ '; IDATA(38)=',IDATA(38)
RDATA(1:1200) = RDATX(1:1200)
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: UNPK7706 FILLS IN HEADER IN O-PUT ARRAY - VADW RPT
C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1997-06-02
C
C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN
C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE
C HEADER DATA FOR NEXRAD (VAD) WIND REPORT. HEADER IS THEN FILLED
C INTO THE OUTPUT ARRAY WHICH HOLDS A SINGLE VAD WIND REPORT IN THE
C QUASI-OFFICE NOTE 29 UNPACKED FORMAT.
C
C PROGRAM HISTORY LOG:
C 1997-06-02 D. A. KEYSER NP22 - ORIGINAL AUTHOR
C
C USAGE: CALL UNPK7706(LUNIT,RDATA,IRET)
C INPUT ARGUMENT LIST:
C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE
C RDATA - SINGLE NEXRAD (VAD) REPORT IN A QUASI-OFFICE NOTE 29
C - UNPACKED FORMAT WITH ALL DATA INITIALIZED AS MISSING
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C RDATA - SINGLE NEXRAD (VAD) REPORT IN A QUASI-OFFICE NOTE 29
C - UNPACKED FORMAT WITH HEADER INFORMATION FILLED IN
C - (ALL OTHER DATA REMAINS MISSING)
C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK
C
C OUTPUT FILES:
C UNIT 06 - PRINTOUT
C
C REMARKS: CALLED BY SUBROUTINE W3UNPK77.
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 90
C MACHINE: IBM-SP, CRAY, SGI
C
C$$$
SUBROUTINE UNPK7706(LUNIT,RDATA,IRET)
CHARACTER*8 STNID,COB
CHARACTER*45 HDR1
INTEGER IDATA(1200)
REAL(8) HDR_8(9)
REAL HDR(9),RDATA(*),RDATX(1200)
COMMON /PK77BB/kdate(8),ldate(8),IPRINT
SAVE
EQUIVALENCE (RDATX,IDATA),(STNID,HDR_8(4)),(COB,IOB)
DATA XMSG/99999./,IMSG/99999/
DATA HDR1/'CLAT CLON SELV RPID YEAR MNTH DAYS HOUR MINU '/
RDATX(1:1200) = RDATA(1:1200)
HDR_8 = 10.0E10
CALL UFBINT(LUNIT,HDR_8,9,1,NLEV,HDR1);HDR=HDR_8
IF(NLEV.NE.1) THEN
C.......................................................................
C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED --
C SET IRET = 6 AND RETURN
PRINT 217, NLEV
217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',I5,') ',
$ 'IS NOT WHAT IS EXPECTED (1) - IRET = 6'/)
IRET = 6
RETURN
C.......................................................................
END IF
C LATITUDE (STORED AS REAL)
M = 1
IF(IPRINT.GT.1) PRINT 199, HDR(1),M
199 FORMAT(5X,'HDR HERE IS: ',F17.4,'; INDEX IS: ',I3)
IF(HDR(1).LT.XMSG) THEN
RDATX(1) = NINT(HDR(1) * 100.)
NNNNN = 1
IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN)
198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2)
ELSE
IRET = 2
PRINT 102
102 FORMAT(' *** W3UNPK77 ERROR: LAT MISSING FOR VAD WIND REPORT'/)
RETURN
END IF
C LONGITUDE (STORED AS REAL)
M = 2
IF(IPRINT.GT.1) PRINT 199, HDR(2),M
IF(HDR(2).LT.XMSG) THEN
RDATX(2) = NINT(MOD((36000.-(HDR(2)*100.)),36000.))
NNNNN = 2
IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN)
ELSE
IRET = 2
PRINT 104
104 FORMAT(' *** W3UNPK77 ERROR: LON MISSING FOR VAD WIND REPORT'/)
RETURN
END IF
C STATION ELEVATION (FROM REPORTED STN. HGHT; STORED IN OUTPUT)
C (STORED AS REAL)
M = 3
IF(IPRINT.GT.1) PRINT 199, HDR(3),M
IF(HDR(3).LT.XMSG) RDATX(7) = NINT(HDR(3))
NNNNN = 7
IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN)
C STATION IDENTIFICATION (STORED AS CHARACTER)
C ('99'//LAST 3-CHARACTERS OF PRODUCT SOURCE ID//' ')
M = 4
IF(IPRINT.GT.1) PRINT 299, STNID,M
299 FORMAT(5X,'HDR HERE IS: ',9X,A8,'; INDEX IS: ',I3)
COB(1:4) = '99'//STNID(2:3)
IDATA(11) = IOB
NNNNN = 11
IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4)
196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A4,'"')
COB(1:4) = STNID(4:4)//' '
IDATA(12) = IOB
NNNNN = 12
IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4)
cvvvvvdak port
C LOAD THE YEAR/MONTH (STORED AS CHARACTER IN FORM YYMM)
caaaaadak port
M = 5
IF(IPRINT.GT.1) PRINT 199, HDR(5),M
IYEAR = IMSG
IF(HDR(5).LT.XMSG) IYEAR = NINT(HDR(5))
M = 6
IF(IPRINT.GT.1) PRINT 199, HDR(6),M
IF(HDR(6).LT.XMSG.AND.IYEAR.LT.IMSG) THEN
cvvvvvdak port
IYEAR = MOD(IYEAR,100)
caaaaadak port
IYEAR = NINT(HDR(6)) + (IYEAR * 100)
cvvvvvdak port
cdak WRITE(COB,'(I6.6,2X)') IYEAR
WRITE(COB,'(I4.4,4X)') IYEAR
caaaaadak port
IDATA(5) = IOB
NNNNN = 5
IF(IPRINT.GT.1) PRINT 9196, NNNNN,COB(1:6)
9196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A6,'"')
ELSE
GO TO 30
END IF
C LOAD THE DAY/HOUR (STORED AS CHARACTER IN FORM DDHH)
C AND THE OBSERVATION TIME (STORED AS REAL)
M = 7
IF(IPRINT.GT.1) PRINT 199, HDR(7),M
IDAY = IMSG
IF(HDR(7).LT.XMSG) IDAY = NINT(HDR(7))
M = 8
IF(IPRINT.GT.1) PRINT 199, HDR(8),M
IF(HDR(8).LT.XMSG.AND.IDAY.LT.IMSG) THEN
IHRT = NINT(HDR(8))
M = 9
IF(IPRINT.GT.1) PRINT 199, HDR(9),M
IF(HDR(9).GE.XMSG) GO TO 30
RMNT = HDR(9)
RDATX(4) = NINT((IHRT * 100.) + (RMNT * 100.)/60.)
NNNNN = 4
IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN)
IHRT = IHRT + (IDAY * 100)
WRITE(COB(1:4),'(I4.4)') IHRT
IDATA(6) = IOB
NNNNN = 6
IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4)
ELSE
GO TO 30
END IF
RDATA(1:1200) = RDATX(1:1200)
RETURN
30 CONTINUE
IRET = 4
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: UNPK7707 FILLS CAT. 4 INTO O-PUT ARRAY - VADW RPT
C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1997-06-02
C
C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN
C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE
C UPPER-AIR DATA FOR NEXRAD (VAD) WIND REPORT. UPPER-AIR DATA ARE
C THEN FILLED INTO THE OUTPUT ARRAY AS CATEGORY 4. THE OUPUT ARRAY
C HOLDS A SINGLE VAD WIND REPORT IN THE QUASI-OFFICE NOTE 29
C UNPACKED FORMAT.
C
C PROGRAM HISTORY LOG:
C 1997-06-02 D. A. KEYSER NP22 - ORIGINAL AUTHOR
C
C USAGE: CALL UNPK7707(LUNIT,RDATA,IRET)
C INPUT ARGUMENT LIST:
C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE
C RDATA - SINGLE NEXRAD (VAD) REPORT IN A QUASI-OFFICE NOTE 29
C - UNPACKED FORMAT WITH ONLY HEADER INFORMATION FILLED
C - IN (CATEGORY 4 DATA MISSING)
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C RDATA - SINGLE NEXRAD (VAD) REPORT IN A QUASI-OFFICE NOTE 29
C - UNPACKED FORMAT WITH CATEGORY 4 INFORMATION FILLED IN
C - (ALL DATA FOR REPORT NOW FILLED)
C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK
C
C OUTPUT FILES:
C UNIT 06 - PRINTOUT
C
C REMARKS: CALLED BY SUBROUTINE W3UNPK77.
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 90
C MACHINE: IBM-SP, CRAY, SGI
C
C$$$
SUBROUTINE UNPK7707(LUNIT,RDATA,IRET)
CHARACTER*1 CRMS(0:12)
CHARACTER*8 COB
CHARACTER*25 UAIR1
INTEGER IDATA(1200)
REAL(8) UAIR_8(5,255)
REAL UAIR(5,255),RDATA(*),RDATX(1200)
COMMON /PK77BB/kdate(8),ldate(8),IPRINT
SAVE
EQUIVALENCE (RDATX,IDATA),(COB,IOB)
DATA XMSG/99999./
DATA UAIR1/'HEIT WDIR WSPD RMSW QMWN '/
DATA CRMS/' ','A',' ','B',' ','C',' ','D',' ','E',' ','F',' '/
RDATX(1:1200) = RDATA(1:1200)
NSFC = 0
ILVL = 0
ILC = 0
C FIRST CATEGORY 4 LEVEL UPPER-AIR LEVEL CONTAINS ONLY HEIGHT (ELEV)
IF(IPRINT.GT.1) PRINT 1078, ILC,ILVL
1078 FORMAT(' ATTEMPTING 1ST (SFC) LVL WITH ILC =',I5,'; NO. LEVELS ',
$ 'PROCESSED TO NOW =',I5)
RDATX(43+ILC) = RDATX(7)
IF(IPRINT.GT.1) PRINT 198, 43+ILC,RDATX(43+ILC)
198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2)
IF(RDATX(43+ILC).LT.XMSG) NSFC = 1
C NOTE: The following was added because of a problem on the sgi-ha
C platform related to equivalencing character and non-character
C -- for now the addition of these two lines will set the quality
C mark for sfc. cat . 4 level to the correct value of " "
C rather than to "9999" - Mary McCann notified SGI of this
C problem on 08-21-1998
cob = ' '
idata(43+ilc+3) = iob
ILVL = ILVL + 1
ILC = ILC + 4
IF(IPRINT.GT.1) PRINT *,'HAVE COMPLETED LEVEL ',ILVL,' WITH ',
$ 'NSFC=',NSFC,'; GOING INTO NEXT LEVEL WITH ILC=',ILC
UAIR_8 = 10.0E10
CALL UFBINT(LUNIT,UAIR_8,5,255,NLEV,UAIR1);UAIR=UAIR_8
IF(NLEV.EQ.0) THEN
C.......................................................................
C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO --
IF(NSFC.EQ.0) THEN
C ... NO UPPER AIR DATA PROCESSED
PRINT 217
217 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA PROCESSED FOR THIS',
$ ' REPORT -- NLEV = 0 AND NSFC = 0'/)
GO TO 99
ELSE
C ... ONLY FIRST (SURFACE) UPPER AIR LEVEL DATA PROCESSED
PRINT 218
218 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA ABOVE FIRST (SURFACE) ',
$ 'LEVEL PROCESSED FOR THIS REPORT -- NLEV = 0 AND NSFC > 0'/)
GO TO 98
END IF
C.......................................................................
END IF
IF(IPRINT.GT.1) PRINT 1068, NLEV
1068 FORMAT(' THIS REPORT CONTAINS ',I3,' LEVELS OF DATA (NOT ',
$ 'INCLUDING BOTTOM -SURFACE- LEVEL)')
DO I = 1,NLEV
IF(IPRINT.GT.1) PRINT 1079, ILC,ILVL
1079 FORMAT(' ATTEMPTING NEW LEVEL WITH ILC =',I5,'; NO. LEVELS ',
$ 'PROCESSED TO NOW =',I5)
C HEIGHT ABOVE SEA-LEVEL (STORED AS REAL)
M = 1
IF(IPRINT.GT.1) PRINT 199, UAIR(1,I),M
199 FORMAT(5X,'UAIR HERE IS: ',F17.4,'; INDEX IS: ',I3)
IF(UAIR(1,I).LT.XMSG) THEN
RDATX(43+ILC) = NINT(UAIR(1,I))
C ... WE HAVE A VALID CATEGORY 4 LEVEL -- THERE IS A VALID HEIGHT
ILVL = ILVL + 1
ELSE
C ... WE DO NOT HAVE A VALID CATEGORY 4 LEVEL -- THERE IS NO VALID
C HEIGHT GO ON TO NEXT INPUT LEVEL
IF(IPRINT.GT.1) PRINT *, 'HEIGHT MISSING ON INPUT ',
$ ' LEVEL ',I,', ALL OTHER DATA SET TO MSG ON THIS LEVEL'
GO TO 10
END IF
IF(IPRINT.GT.1) PRINT 198, 43+ILC,RDATX(43+ILC)
C HORIZONTAL WIND DIRECTION (STORED AS REAL)
M = 2
IF(IPRINT.GT.1) PRINT 199, UAIR(2,I),M
IF(UAIR(2,I).LT.XMSG) RDATX(43+ILC+1) = NINT(UAIR(2,I))
IF(IPRINT.GT.1) PRINT 198, 43+ILC+1,RDATX(43+ILC+1)
C HORIZONTAL WIND SPEED (STORED AS REAL) (OUTPUT STORED
C AS METERS/SECOND TIMES TEN, NOT IN KNOTS AS ON29 WOULD
C INDICATE FOR CAT. 4 WIND SPEED)
M = 3
IF(IPRINT.GT.1) PRINT 199, UAIR(3,I),M
IF(UAIR(3,I).LT.XMSG) RDATX(43+ILC+2) =NINT(UAIR(3,I) * 10.)
IF(IPRINT.GT.1) PRINT 198, 43+ILC+2,RDATX(43+ILC+2)
C CONFIDENCE LEVEL (BASED ON RMS VECTOR WIND ERROR)
C (NOTE: CONVERTED TO ORIGINAL LETTER INDICATOR AND PACKED
C IN BYTE 4 OF CATEGORY 4 QUALITY MARKER LOCATION -- SEE
C W3UNPK77 DOCBLOCK REMARKS 5. FOR UNPACKED VAD WIND REPORT
C LAYOUT FOR VALUES
M = 4
IF(IPRINT.GT.1) PRINT 199, UAIR(4,I),M
IF(UAIR(4,I).LT.XMSG) THEN
C ... CONVERT FROM M/S TO KNOTS
CDAKCDAK KRMS = INT(1.93333 * UAIR(4,I))
KRMS = INT(1.9425 * UAIR(4,I))
COB = ' '
IF(KRMS.LT.13) THEN
COB(4:4) = CRMS(KRMS)
ELSE
COB(4:4) = 'G'
END IF
IDATA(43+ILC+3) = IOB
END IF
IF(IPRINT.GT.1) PRINT 196, 43+ILC+3,COB(1:4)
196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A4,'"')
C ON29 WIND QUALITY MARKER (CURRENTLY NOT STORED)
M = 5
IF(IPRINT.GT.1) PRINT 199, UAIR(5,I),M
C.......................................................................
ILC = ILC + 4
IF(IPRINT.GT.1) PRINT *,'HAVE COMPLETED LEVEL ',ILVL,
$ '; GOING INTO NEXT LEVEL WITH ILC=',ILC
10 CONTINUE
ENDDO
C SET CATEGORY COUNTERS FOR UPPER-AIR DATA
98 CONTINUE
IDATA(19) = ILVL
99 CONTINUE
IF(IDATA(19).EQ.0) THEN
IDATA(20) = 0
IRET = 5
ELSE
IDATA(20) = 43
END IF
IF(IPRINT.GT.1) PRINT *, 'NSFC=',NSFC,'; IDATA(37)=',IDATA(37),
$ '; IDATA(38)=',IDATA(38)
RDATA(1:1200) = RDATX(1:1200)
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: UNPK7708 FILLS IN HEADER IN O-PUT ARRAY - GOES SND
C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1998-07-09
C
C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN
C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE
C HEADER DATA FOR GOES SOUNDING REPORT. HEADER IS THEN FILLED INTO
C THE OUTPUT ARRAY WHICH HOLDS A SINGLE GOES SOUNDING REPORT IN THE
C QUASI-OFFICE NOTE 29 UNPACKED FORMAT.
C
C PROGRAM HISTORY LOG:
C 1997-06-05 D. A. KEYSER NP22 - ORIGINAL AUTHOR
C 1998-07-09 KEYSER -- CHANGED CHAR. 6 OF GOES STNID TO BE UNIQUE FOR
C TWO DIFFERENT EVEN OR ODD SATELLITE ID'S
C (EVERY OTHER EVEN OR ODD SAT. ID NOW GETS SAME
C CHAR. 6 TAG)
C
C USAGE: CALL UNPK7708(LUNIT,RDATA,KOUNT,IRET)
C INPUT ARGUMENT LIST:
C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE
C RDATA - SINGLE GOES SNDG REPORT IN A QUASI-OFFICE NOTE 29
C - UNPACKED FORMAT WITH ALL DATA INITIALIZED AS MISSING
C KOUNT - NUMBER OF REPORTS PROCESSED INCLUDING THIS ONE
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C RDATA - SINGLE GOES SNDG REPORT IN A QUASI-OFFICE NOTE 29
C - UNPACKED FORMAT WITH HEADER INFORMATION FILLED IN
C - (ALL OTHER DATA REMAINS MISSING)
C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK
C
C OUTPUT FILES:
C UNIT 06 - PRINTOUT
C
C REMARKS: CALLED BY SUBROUTINE W3UNPK77.
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 90
C MACHINE: IBM-SP, CRAY, SGI
C
C$$$
SUBROUTINE UNPK7708(LUNIT,RDATA,KOUNT,IRET)
CHARACTER*1 C6TAG(3,0:3)
CHARACTER*8 STNID,COB
CHARACTER*35 HDR1,HDR2
INTEGER IDATA(1200)
REAL(8) HDR_8(12)
REAL HDR(12),RDATA(*),RDATX(1200)
COMMON /PK77BB/kdate(8),ldate(8),IPRINT
COMMON /PK77FF/IFOV(3),KNTSAT(250:260)
SAVE
EQUIVALENCE (RDATX,IDATA),(COB,IOB)
DATA XMSG/99999./,IMSG/99999/
DATA HDR1/'CLAT CLON ACAV GSDP QMRK SAID YEAR '/
DATA HDR2/'MNTH DAYS HOUR MINU SECO '/
C CURRENT LIST OF SATELLITE IDENTIFIERS (BUFR C.F. 0-01-007)
C -----------------------------------------------------------
C GOES 6 -- 250 GOES 9 -- 253 GOES 12 -- 256
C GOES 7 -- 251 GOES 10 -- 254 GOES 13 -- 257
C GOES 8 -- 252 GOES 11 -- 255 GOES 14 -- 258
C IDSAT = -- EVEN1 -- --- ODD1 -- -- EVEN2 -- --- ODD2 --
C Sat. No. - 252,256,... 253,257,... 250,254,... 251,255,...
C IRTYP = CLR COR UNKN CLR COR UNKN CLR COR UNKN CLR COR UNKN
C --- --- ---- --- --- ---- --- --- ---- --- --- ----
DATA C6TAG/'I','J','?', 'L','M','?', 'O','P','?', 'Q','R','?' /
RDATX(1:1200) = RDATA(1:1200)
HDR_8 = 10.0E10
CALL UFBINT(LUNIT,HDR_8,12,1,NLEV,HDR1//HDR2);HDR=HDR_8
IF(NLEV.NE.1) THEN
C.......................................................................
C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED --
C SET IRET = 6 AND RETURN
PRINT 217, NLEV
217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',I5,') ',
$ 'IS NOT WHAT IS EXPECTED (1) - IRET = 6'/)
IRET = 6
RETURN
C.......................................................................
END IF
C LATITUDE (STORED AS REAL)
M = 1
IF(IPRINT.GT.1) PRINT 199, HDR(1),M
199 FORMAT(5X,'HDR HERE IS: ',F17.4,'; INDEX IS: ',I3)
IF(HDR(1).LT.XMSG) THEN
RDATX(1) = NINT(HDR(1) * 100.)
NNNNN = 1
IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN)
198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2)
ELSE
IRET = 2
PRINT 102
102 FORMAT(' *** W3UNPK77 ERROR: LAT MISSING FOR GOES SOUNDING'/)
RETURN
END IF
C LONGITUDE (STORED AS REAL)
M = 2
IF(IPRINT.GT.1) PRINT 199, HDR(2),M
IF(HDR(2).LT.XMSG) THEN
RDATX(2) = NINT(MOD((36000.-(HDR(2)*100.)),36000.))
NNNNN = 2
IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN)
ELSE
IRET = 2
PRINT 104
104 FORMAT(' *** W3UNPK77 ERROR: LON MISSING FOR GOES SOUNDING'/)
RETURN
END IF
C NUMBER OF FIELDS OF VIEW - SAMPLE SIZE (STORED AS INTEGER)
M = 3
IF(IPRINT.GT.1) PRINT 199, HDR(3),M
IF(HDR(3).LT.XMSG) IDATA(3) = NINT(HDR(3))
NNNNN = 3
IF(IPRINT.GT.1) PRINT 197, NNNNN,IDATA(NNNNN)
197 FORMAT(5X,'IDATA(',I5,') STORED AS: ',I10)
C STATION ELEVATION (FROM HEIGHT OF FIRST -SURFACE- LEVEL)
C (STORED AS REAL) -- STORED IN SUBROUTINE UNPK7709
C RETRIEVAL TYPE (GEOSTATIONARY SATELLITE DATA-PROCESSING
C TECHNIQUE USED) (STORED AS INTEGER)
M = 4
IF(IPRINT.GT.1) PRINT 199, HDR(4),M
IF(HDR(4).LT.XMSG) IDATA(8) = NINT(HDR(4))
IRTYP = 3
IF(IDATA(8).EQ.21) THEN
IRTYP = 1
ELSE IF(IDATA(8).EQ.23) THEN
IRTYP = 2
END IF
NNNNN = 8
IF(IPRINT.GT.1) PRINT 197, NNNNN,IDATA(NNNNN)
C PRODUCT QUALITY BIT FLAGS - QUALITY INFO. (STORED AS INTEGER)
M = 5
IF(IPRINT.GT.1) PRINT 199, HDR(5),M
IF(HDR(5).LT.XMSG) IDATA(10) = NINT(HDR(5))
NNNNN = 10
IF(IPRINT.GT.1) PRINT 197, NNNNN,IDATA(NNNNN)
C STATION IDENTIFICATION (STORED AS CHARACTER)
C (FIRST 5-CHARACTERS OBTAINED FROM 5-DIGIT COUNT NUMBER,
C 6'TH CHARACTER OBTAINED FROM SAT. ID/RETRIEVAL TYPE TAG)
WRITE(STNID(1:5),'(I5.5)') MIN(KOUNT,99999)
C DECODE THE SATELLITE ID
M = 6
IDSAT = 2
IF(IPRINT.GT.1) PRINT 199, HDR(6),M
IF(HDR(6).LT.XMSG) THEN
IDSAT = MOD(NINT(HDR(6)),4)
IF(NINT(HDR(6)).GT.249.AND.NINT(HDR(6)).LT.260) THEN
KNTSAT(NINT(HDR(6))) = KNTSAT(NINT(HDR(6))) + 1
ELSE
KNTSAT(260) = KNTSAT(260) + 1
END IF
END IF
IF(IPRINT.GT.1) PRINT 2197, IDSAT,IRTYP
2197 FORMAT(5X,'IDSAT IS: ',I10,', IRTYP IS: ',I10)
STNID(6:6) = C6TAG(IRTYP,IDSAT)
COB(1:4) = STNID(1:4)
IDATA(11) = IOB
NNNNN = 11
IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4)
196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A4,'"')
COB(1:4) = STNID(5:6)//' '
IDATA(12) = IOB
NNNNN = 12
IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4)
cvvvvvdak port
C LOAD THE YEAR/MONTH (STORED AS CHARACTER IN FORM YYMM)
caaaaadak port
M = 7
IF(IPRINT.GT.1) PRINT 199, HDR(7),M
IYEAR = IMSG
IF(HDR(7).LT.XMSG) IYEAR = NINT(HDR(7))
M = 8
IF(IPRINT.GT.1) PRINT 199, HDR(8),M
IF(HDR(8).LT.XMSG.AND.IYEAR.LT.IMSG) THEN
cvvvvvdak port
IYEAR = MOD(IYEAR,100)
caaaaadak port
IYEAR = NINT(HDR(8)) + (IYEAR * 100)
cvvvvvdak port
cdak WRITE(COB,'(I6.6,2X)') IYEAR
WRITE(COB,'(I4.4,4X)') IYEAR
caaaaadak port
IDATA(5) = IOB
NNNNN = 5
IF(IPRINT.GT.1) PRINT 9196, NNNNN,COB(1:6)
9196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A6,'"')
ELSE
GO TO 30
END IF
C LOAD THE DAY/HOUR (STORED AS CHARACTER IN FORM DDHH)
C AND THE OBSERVATION TIME (STORED AS REAL)
M = 9
IF(IPRINT.GT.1) PRINT 199, HDR(9),M
M = 10
IF(IPRINT.GT.1) PRINT 199, HDR(10),M
IF(HDR(10).LT.XMSG.AND.HDR(9).LT.IMSG) THEN
M = 11
IF(IPRINT.GT.1) PRINT 199, HDR(11),M
IF(HDR(11).GE.XMSG) GO TO 30
M = 12
IF(IPRINT.GT.1) PRINT 199, HDR(12),M
IF(HDR(12).GE.XMSG) GO TO 30
RDATX(4) = NINT(((HDR(10) + ((HDR(11) * 60.) + HDR(12))/3600.)
$ * 100.) + 0.0000000001)
NNNNN = 4
IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN)
IDAYHR = NINT(HDR(10)) + (NINT(HDR(9)) * 100)
WRITE(COB(1:4),'(I4.4)') IDAYHR
IDATA(6) = IOB
NNNNN = 6
IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4)
ELSE
GO TO 30
END IF
RDATA(1:1200) = RDATX(1:1200)
RETURN
30 CONTINUE
IRET = 4
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: UNPK7709 FILLS CAT. 12,8 TO O-PUT ARRAY -GOES SNDG
C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1997-06-05
C
C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN
C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE
C UPPER-AIR (SOUNDING) AND ADDITIONAL DATA FOR GOES SOUNDING. UPPER-
C AIR DATA ARE THEN FILLED INTO THE OUTPUT ARRAY AS CATEGORY 12
C (SATELLITE SOUNDING) AND ADDITIONAL DATA ARE FILLED AS CATEGORY 8.
C THE OUPUT ARRAY HOLDS A SINGLE GOES SOUNDING IN THE QUASI-OFFICE
C NOTE 29 UNPACKED FORMAT.
C
C PROGRAM HISTORY LOG:
C 1997-06-05 D. A. KEYSER NP22 - ORIGINAL AUTHOR
C
C USAGE: CALL UNPK7709(LUNIT,RDATA,IRET)
C INPUT ARGUMENT LIST:
C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE
C RDATA - SINGLE GOES SNDG REPORT IN A QUASI-OFFICE NOTE 29
C - UNPACKED FORMAT WITH ONLY HEADER INFORMATION FILLED
C - IN (CATEGORY 12 AND 8 DATA MISSING)
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C RDATA - SINGLE GOES SNDG REPORT IN A QUASI-OFFICE NOTE 29
C - UNPACKED FORMAT WITH CATEGORY 12 AND 8 INFORMATION
C - FILLED IN (ALL DATA FOR REPORT NOW FILLED)
C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK
C
C OUTPUT FILES:
C UNIT 06 - PRINTOUT
C
C REMARKS: CALLED BY SUBROUTINE W3UNPK77.
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 90
C MACHINE: IBM-SP, CRAY, SGI
C
C$$$
SUBROUTINE UNPK7709(LUNIT,RDATA,IRET)
CHARACTER*1 CQMFLG
CHARACTER*8 COB
CHARACTER*37 CAT8A,CAT8B
CHARACTER*48 UAIR1,RAD1
INTEGER IDATA(1200),ICDFG(12)
REAL(8) UAIR_8(4,255),CAT8_8(12),RTCSF_8,RAD_8(2,255)
REAL UAIR(4,255),CAT8(12),RDATA(*),RDATX(1200),SC8(12),RAD(2,255)
COMMON /PK77BB/kdate(8),ldate(8),IPRINT
COMMON /PK77FF/IFOV(3),KNTSAT(250:260)
SAVE
EQUIVALENCE (RDATX,IDATA),(COB,IOB)
DATA XMSG/99999./,YMSG/99999.8/
DATA UAIR1/'PRLC HGHT TMDB TMDP '/
DATA RAD1 /'CHNM TMBR '/
DATA CAT8A/'GLFTI PH2O PH2O19 PH2O97 PH2O73 TMSK '/
DATA CAT8B/'GCDTT CDTP CLAM SIDU SOEL ELEV '/
DATA ICDFG/ 50 , 51 , 52 , 53 , 54 , 55 , 56 ,57 ,58,59, 60 , 61 /
DATA SC8/100.,100.,100.,100.,100.,100.,100.,10.,1.,1.,100.,100./
RDATX(1:1200) = RDATA(1:1200)
C ALL NON-RADIANCE DATA WILL BE Q.C.'D ACCORDING TO NUMBER OF FIELDS-OF-
C VIEW FOR RETRIEVAL: 0-2 --> BAD, 3-9 --> SUSPECT, 10-25 OR MISSING
C --> NEUTRAL
CQMFLG = ' '
IF(IDATA(3).LT.3) THEN
CQMFLG = 'F'
IFOV(1) = IFOV(1) + 1
ELSE IF(IDATA(3).LT.10.OR.IDATA(10).EQ.1) THEN
CQMFLG = 'Q'
IF(IDATA(3).LT.10) IFOV(2) = IFOV(2) + 1
END IF
IF(IDATA(3).GT.9) IFOV(3) = IFOV(3) + 1
C***********************************************************************
C FILL CATEGORY 12 PART OF OUTPUT
C***********************************************************************
ILVL = 0
ILC = 0
UAIR_8 = 10.0E10
CALL UFBINT(LUNIT,UAIR_8,4,255,NLEV,UAIR1);UAIR=UAIR_8
IF(NLEV.EQ.0) THEN
C.......................................................................
C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO --
PRINT 217
217 FORMAT(/' ##W3UNPK77: NO UPPER-AIR (SOUNDING) DATA PROCESSED ',
$ 'FOR THIS REPORT -- NLEV = 0'/)
GO TO 98
ELSE IF(NLEV.GT.50) THEN
C.......................................................................
C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS GREATER THAN LIMIT OF 50 --
PRINT 218
218 FORMAT(/' ##W3UNPK77: NO UPPER-AIR (SOUNDING) DATA PROCESSED ',
$ 'FOR THIS REPORT -- NLEV > 50'/)
GO TO 98
C.......................................................................
END IF
IF(IPRINT.GT.1) PRINT 1068, NLEV
1068 FORMAT(' THIS REPORT CONTAINS',I4,' INPUT LEVELS OF SOUNDING ',
$ 'DATA')
DO I = 1,NLEV
IF(IPRINT.GT.1) PRINT 1079, I,ILC,ILVL
1079 FORMAT(' ATTEMPTING NEW CAT. 12 INPUT LEVEL NUMBER',I4,' WITH ',
$ 'ILC =',I5,'; NO. LEVELS PROCESSED TO NOW =',I5)
C LEVEL PRESSURE (STORED AS REAL)
M = 1
IF(IPRINT.GT.1) PRINT 199, UAIR(1,I),M
199 FORMAT(5X,'UAIR HERE IS: ',F17.4,'; INDEX IS: ',I3)
IF(I.EQ.1) THEN
PSFC = UAIR(1,I) * 0.1
ELSE IF(UAIR(1,I)*0.1.GE.YMSG) THEN
C WE DO NOT HAVE A VALID CATEGORY 12 LEVEL -- THERE IS NO VALID PRESSURE
C -- GO ON TO NEXT INPUT LEVEL (IF SFC LEVEL MSG, CONTINUE PROCESSING)
IF(IPRINT.GT.1) PRINT *, 'PRESSURE MISSING ON INPUT',
$ ' LEVEL ',I,', SKIP THE PROCESSING OF THIS LEVEL'
GO TO 10
ELSE IF(UAIR(1,I)*0.1.GE.PSFC) THEN
C WE DO NOT HAVE A VALID CATEGORY 12 LEVEL -- THE INPUT LEVEL PRESSURE
C IS BELOW THE SURFACE PRESSURE -- GO ON TO THE NEXT INPUT LEVEL
IF(IPRINT.GT.1) PRINT *,'PRESSURE ON INPUT LEVEL ',I,
$ ' IS BELOW GROUND, SKIP THE PROCESSING OF THIS LEVEL'
GO TO 10
END IF
C WE HAVE A VALID CATEGORY 12 LEVEL -- THERE IS A VALID PRESSURE
IF(UAIR(1,I)*0.1.LT.XMSG) RDATX(43+ILC) = NINT(UAIR(1,I)*0.1)
ILVL = ILVL + 1
IF(IPRINT.GT.1) PRINT 198, 43+ILC,RDATX(43+ILC)
198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2)
C GEOPOTENTIAL HEIGHT (STORED AS REAL)
M = 2
IF(IPRINT.GT.1) PRINT 199, UAIR(2,I),M
IF(UAIR(2,I).LT.XMSG) RDATX(43+ILC+1) = NINT(UAIR(2,I))
IF(IPRINT.GT.1) PRINT 198, 43+ILC+1,RDATX(43+ILC+1)
IF(I.EQ.1) THEN
IF(IPRINT.GT.1) PRINT *, 'THIS IS SURFACE LEVEL, SO ',
$ 'STORE HEIGHT ALSO AS ELEVATION IN HEADER'
IF(UAIR(2,1).LT.XMSG) RDATX(7) = NINT(UAIR(2,1))
NNNNN = 7
IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN)
END IF
C TEMPERATURE (STORED AS REAL)
M = 3
IF(IPRINT.GT.1) PRINT 199, UAIR(3,I),M
ITMP = NINT(UAIR(3,I)*100.)
IF(UAIR(3,I).LT.XMSG)
$ RDATX(43+ILC+2) = NINT((ITMP - 27315) * 0.1)
IF(IPRINT.GT.1) PRINT 198, 43+ILC+2,RDATX(43+ILC+2)
C DEWPOINT TEMPERATURE (STORED AS REAL)
M = 4
IF(IPRINT.GT.1) PRINT 199, UAIR(4,I),M
ITMP = NINT(UAIR(4,I)*100.)
IF(UAIR(4,I).LT.XMSG)
$ RDATX(43+ILC+3) = NINT((ITMP - 27315) * 0.1)
IF(IPRINT.GT.1) PRINT 198, 43+ILC+3,RDATX(43+ILC+3)
C QUALITY MARKERS (STORED AS CHARACTER)
COB = CQMFLG//CQMFLG//CQMFLG//' '
IDATA(43+ILC+6) = IOB
IF(IPRINT.GT.1) PRINT 196, 43+ILC+6,COB(1:4)
196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A4,'"')
C.......................................................................
ILC = ILC + 7
IF(I+1.LE.NLEV.AND.IPRINT.GT.1) PRINT *,'HAVE COMPLETED ',
$ 'LEVEL ',ILVL,'; GOING INTO NEXT LEVEL WITH ILC=',ILC
10 CONTINUE
ENDDO
C SET CATEGORY COUNTERS FOR CATEGORY 12 (SOUNDING) DATA
IDATA(39) = ILVL
98 CONTINUE
IF(IPRINT.GT.1) PRINT *, IDATA(39),' CAT. 12 LEVELS PROCESSED'
IF(IDATA(39).GT.0) IDATA(40) = 43
C***********************************************************************
C FILL CATEGORY 8 PART OF OUTPUT
C WILL ATTEMPT TO FILL 12 "LEVELS"
C LVL 1- LIFTED INDEX (DEG. K X 100 - RELATIVE) -------- CODE FIG. 250.
C LVL 2- TOTAL COLUMN PRECIPITABLE WATER (MM X 100) ---- CODE FIG. 251.
C LVL 3- 1. TO .9 SIGMA LAYER PRECIP. WATER (MM X 100) - CODE FIG. 252.
C LVL 4- .9 TO .7 SIGMA LAYER PRECIP. WATER (MM X 100) - CODE FIG. 253.
C LVL 5- .7 TO .3 SIGMA LAYER PRECIP. WATER (MM X 100) - CODE FIG. 254.
C LVL 6- SKIN TEMPERATURE (DEG. K X 100) --------------- CODE FIG. 255.
C LVL 7- CLOUD TOP TEMPERATURE (DEG. K X 100) ---------- CODE FIG. 256.
C LVL 8- CLOUD TOP PRESSURE (MB X 10) ------------------ CODE FIG. 257.
C LVL 9- CLOUD AMOUNT (C. FIG. BUFR TABLE 0-20-011) ---- CODE FIG. 258.
C LVL 10- INSTR. DATA USED IN PROC.
C (C. FIG. BUFR TABLE 0-02-021) --- CODE FIG. 259.
C LVL 11- SOLAR ZENITH ANGLE (SOLAR ELEV) (DEG. X 100) -- CODE FIG. 260.
C LVL 12- SATELLITE ZENITH ANGLE (ELEV) (DEG. X 100) --- CODE FIG. 261.
C
C IF DATA ONE ANY LEVEL ARE MISSING, THAT LEVEL IS NOT PROCESSED
C***********************************************************************
ILVL = 0
ILC = 0
CAT8_8 = 10.0E10
CALL UFBINT(LUNIT,CAT8_8,12,1,NLEV8,CAT8A//CAT8B);CAT8=CAT8_8
IF(NLEV8.NE.1) THEN
IF(NLEV8.EQ.0) THEN
C.......................................................................
C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO --
PRINT 318
318 FORMAT(/' ##W3UNPK77: NO ADDITIONAL (CAT. 8) DATA PROCESSED FOR ',
$ 'THIS REPORT -- NLEV8 = 0'/)
GO TO 99
C.......................................................................
ELSE
C.......................................................................
C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED --
C SET IRET = 7 AND RETURN
PRINT 219, NLEV8
219 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',I5,') ',
$ 'IS NOT WHAT IS EXPECTED (1) - IRET = 7'/)
IRET = 7
RETURN
C.......................................................................
END IF
END IF
C THE TEMPERATURE CHANNEL SELECTION FLAG WILL BE USED LATER TO
C DETERMINE Q. MARK FOR SKIN TEMPERATURE (IF 0 - OK, OTHERWISE - BAD)
RTCSF_8 = 10.0E10
CALL UFBINT(LUNIT,RTCSF_8,1,1,NLEV0,'TCSF');RTCSF=RTCSF_8
ITCSF = 1
M = 1
IF(IPRINT.GT.1) PRINT 299, RTCSF,M
299 FORMAT(5X,'RTCSF HERE IS: ',F17.4,'; INDEX IS: ',I3)
IF(RTCSF.LT.XMSG) ITCSF = NINT(RTCSF)
IF(IPRINT.GT.1) PRINT 1798, ITCSF
1798 FORMAT(5X,'ITCSF IS: ',I10)
C LOOP THROUGH THE 12 POSSIBLE ADDITIONAL DATA
DO M = 1,12
IF(IPRINT.GT.1) PRINT 6079, M,ILC,ILVL
6079 FORMAT(' ATTEMPTING MISCEL. INPUT',I5,' WITH ILC =',I5,'; NO. ',
$ 'OUTPUT CAT. 8 LVLS PROCESSED TO NOW =',I5)
IF(IPRINT.GT.1) PRINT 399, CAT8(M),M
399 FORMAT(5X,'CAT8 HERE IS: ',F17.4,'; INDEX IS: ',I3)
IF(CAT8(M).LT.XMSG) THEN
C WE HAVE A VALID CATEGORY 8 "LEVEL"
ILVL = ILVL + 1
C STORE THE DATUM IN WORD 1 OF THE CAT. 8 LEVEL
RDATX(393+ILC) = NINT(CAT8(M) * SC8(M))
IF(IPRINT.GT.1) PRINT 198, 393+ILC,RDATX(393+ILC)
C STORE THE CAT. 8 CODE FIGURE IN WORD 2 OF THE CAT. 8 LEVEL
RDATX(393+ILC+1) = REAL(200+ICDFG(M))
IF(IPRINT.GT.1) PRINT 198, 393+ILC+1,RDATX(393+ILC+1)
C STORE THE QUALITY MARKER IN BYTE 1 OF WORD 3 OF THE CAT. 8 LEVEL
COB = CQMFLG//' '
C IF THIS DATUM IS SKIN TEMPERATURE AND THE TEMPERATURE CHANNEL
C SELECTION FLAG IS BAD (.NE. 0), SET QUALITY MARKER TO "F"
IF(M.EQ.6.AND.ITCSF.NE.0) COB(1:1) = 'F'
IDATA(393+ILC+2) = IOB
IF(IPRINT.GT.1) PRINT 196, 393+ILC+2,COB(1:4)
ILC = ILC + 3
IF(M.LT.12.AND.IPRINT.GT.1) PRINT *,'HAVE COMPLETED OUTPUT',
$ ' LVL',ILVL,'; GOING INTO NEXT INPUT DATUM WITH ILC=',ILC
ELSE
IF(IPRINT.GT.1) PRINT *, 'DATUM MISSING ON INPUT ',M,
$ ', GO ON TO NEXT INPUT DATUM (NO. LVLS PROCESSED SO ',
$ 'FAR=',ILVL,'; ILC=',ILC,')'
END IF
ENDDO
C SET CATEGORY COUNTERS FOR CATEGORY 8 (ADDITIONAL) DATA
IDATA(27) = ILVL
99 CONTINUE
IF(IPRINT.GT.1) PRINT *, IDATA(27),' CAT. 08 LEVELS PROCESSED'
IF(IDATA(27).GT.0) IDATA(28) = 393
C***********************************************************************
C FILL CATEGORY 13 PART OF OUTPUT (RADIANCES)
C***********************************************************************
ILVL = 0
ILC = 0
RAD_8 = 10.0E10
CALL UFBINT(LUNIT,RAD_8,2,255,NLEV13,RAD1);RAD=RAD_8
IF(NLEV13.EQ.0) THEN
C.......................................................................
C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO --
PRINT 417
417 FORMAT(/' ##W3UNPK77: NO RADIANCE DATA PROCESSED FOR THIS ',
$ 'REPORT -- NLEV13 = 0'/)
GO TO 100
ELSE IF(NLEV13.GT.60) THEN
C.......................................................................
C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS GREATER THAN LIMIT OF 60 --
PRINT 418
418 FORMAT(/' ##W3UNPK77: NO RADIANCE DATA PROCESSED FOR THIS ',
$ 'REPORT -- NLEV13 > 60'/)
GO TO 100
C.......................................................................
END IF
IF(IPRINT.GT.1) PRINT 2068, NLEV13
2068 FORMAT(' THIS REPORT CONTAINS',I4,' INPUT LEVELS (CHANNELS) OF ',
$ 'RADIANCE DATA')
DO I = 1,NLEV13
IF(IPRINT.GT.1) PRINT 2079, I,ILC,ILVL
2079 FORMAT(' ATTEMPTING NEW CAT. 13 INPUT "LEVEL" NUMBER',I4,' WITH ',
$ 'ILC =',I5,'; NO. LEVELS (CHANNELS) PROCESSED TO NOW =',I5)
C CHANNEL NUMBER (STORED AS INTEGER)
M = 1
IF(IPRINT.GT.1) PRINT 499, RAD(1,I),M
499 FORMAT(5X,'RAD HERE IS: ',F17.4,'; INDEX IS: ',I3)
IF(RAD(1,I).GE.YMSG) THEN
C WE DO NOT HAVE A VALID CATEGORY 13 LEVEL -- THERE IS NO VALID CHANNEL
C NUMBER -- GO ON TO NEXT INPUT LEVEL
IF(IPRINT.GT.1) PRINT *, 'CHANNEL NUMBER MISSING ON INPUT',
$ ' LEVEL ',I,', SKIP THE PROCESSING OF THIS LEVEL'
GO TO 210
END IF
C WE HAVE A VALID CATEGORY 13 LEVEL -- THERE IS A VALID CHANNEL NUMBER
IDATA(429+ILC) = NINT(RAD(1,I))
ILVL = ILVL + 1
IF(IPRINT.GT.1) PRINT 197, 429+ILC,IDATA(429+ILC)
197 FORMAT(5X,'IDATA(',I5,') STORED AS: ',I10)
C BRIGHTNESS TEMPERATURE (STORED AS REAL)
M = 2
IF(IPRINT.GT.1) PRINT 499, RAD(2,I),M
IF(RAD(2,I).LT.XMSG) RDATX(429+ILC+1) = NINT(RAD(2,I) * 100.)
IF(IPRINT.GT.1) PRINT 198, 429+ILC+1,RDATX(429+ILC+1)
C QUALITY MARKERS (STORED AS CHARACTER)
COB = ' '
IDATA(429+ILC+2) = IOB
IF(IPRINT.GT.1) PRINT 196, 429+ILC+2,COB(1:4)
C.......................................................................
ILC = ILC + 3
IF(I+1.LE.NLEV13.AND.IPRINT.GT.1) PRINT *,'HAVE COMPLETED ',
$ 'LEVEL ',ILVL,'; GOING INTO NEXT LEVEL WITH ILC=',ILC
210 CONTINUE
ENDDO
C SET CATEGORY COUNTERS FOR CATEGORY 13 (RADIANCE) DATA
IDATA(41) = ILVL
100 CONTINUE
IF(IPRINT.GT.1) PRINT *, IDATA(41),' CAT. 13 LEVELS PROCESSED'
IF(IDATA(41).GT.0) IDATA(42) = 429
IF(IDATA(27)+IDATA(39)+IDATA(41).EQ.0) IRET = 5
IF(IPRINT.GT.1) PRINT *,'IDATA(39)=',IDATA(39),'; IDATA(40)=',
$ IDATA(40),'; IDATA(27)=',IDATA(27),'; IDATA(28)=',IDATA(28),
$ '; IDATA(41)=',IDATA(41),'; IDATA(42)=',IDATA(42)
RDATA(1:1200) = RDATX(1:1200)
RETURN
END