C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: W3UNPKB7 C PRGMMR: KEYSER ORG: NP22 DATE: 2016-11-30 C C ABSTRACT: THIS SUBROUTINE DECODES A SINGLE REPORT FROM BUFR MESSAGES C IN AN NCEP BUFR DATA FILE. CURRENTLY WIND PROFILER {EXCEPT FOR, C THOSE ORIGINATING FROM PILOT (PIBAL) FORMAT BULLETINS, SEE C SUBROUTINE IW3UNPBF FOR THESE}, NEXRAD (VAD) WIND (FROM BOTH RADAR C CODED MESSAGE AND FROM LEVEL 2 DECODER), GOES SOUNDING/RADIANCE, C ERS SCATTEROMETER WIND, QUIKSCAT SCATTEROMETER WIND, WINDSAT C SCATTEROMETER WIND (NAVY OR NESDIS), ASCAT SCATTEROMETER WIND, RASS C AND GPS-IPW DATA TYPES ARE VALID. REPORT IS RETURNED IN QUASI- C IW3UNPBF UNPACKED FORMAT (SEE REMARKS 5) AND DIRECTLY FROM BUFR C FORMAT (SEE REMARKS 6). IN ADDITION THE ASCII STATION ID IS C RETURNED FOR EACH DECODED REPORT. ALSO, INFORMATION ABOUT THE C INPUT DATA SET ITSELF (NAME, CENTER DATE, DUMP TIME) AND THE BUFR C MESSAGE TYPE IS RETURNED. C C PROGRAM HISTORY LOG: C 1998-02-17 D. A. KEYSER -- ORIGINAL AUTHOR (BASED ON W3LIB ROUTINE C W3UNPK77) C 1998-06-14 D. A. KEYSER -- MODIFIED WIND PROFILER CAT. 11 (HEIGHT, C HORIZ. SIGNIFICANCE, VERT. SIGNIFICANCE) AND VAD WIND HEADER C (STATION ID) PROCESSING TO ACCOUNT FOR UPDATES TO BUFRTABLE C MNEMONICS IN /dcom; CHANGED CHAR. 6 OF GOES STNID TO BE UNIQUE C FOR TWO DIFFERENT EVEN OR ODD SATELLITE ID'S (EVERY OTHER EVEN OR C ODD SAT. ID NOW GETS SAME CHAR. 6 TAG) C 1998-06-15 D. A. KEYSER -- REDEFINED UNITS FOR UNPACKED WORDS 1 C (LATITUDE), 2 (LONGITUDE), 4 (OBS. TIME) AND 11 (RECEIPT TIME) - C ALL TO CONFORM WITH UNPACKED IW3UNPBF FORMAT AND TO STREAMLINE C PROCESSING IN PREPDATA PROGRAM C 1998-09-21 D. A. KEYSER -- SUBROUTINE NOW Y2K AND FORTRAN 90 C COMPLIANT C 1998-10-09 D. A. KEYSER -- CORRECTED ERROR IN RETURNING GOES C CAT. 8 DATA WHEN GREATER THAN 9 "LEVELS" ARE PRESENT C 1999-01-20 D. A. KEYSER -- INCORPORATED BOB KISTLER'S CHANGES NEEDED C TO PORT THE CODE TO THE IBM SP C 1999-02-12 D. A. KEYSER -- ADDED ERS SCATTEROMETER WINDS HERE NOW C THAT THEY ARE PACKED IN AN NCEP BUFR FILE C 1999-05-17 D. A. KEYSER -- MADE FURTHER CHANGES NECESSARY TO PORT C THIS ROUTINE TO THE IBM SP C 1999-11-02 D. A. KEYSER -- CHANGES TO MAKE CODE MORE PORTABLE C 2000-03-30 D. A. KEYSER -- CHANGE TO BY-PASS TIME-WINDOW CHECKS ON C BUFR MESSAGES IF TIME WINDOW VALUES ARE -6 AND +6 HOURS, RESP. C 2000-09-22 D. A. KEYSER -- ADDED QUIKSCAT SCATTEROMETER WINDS HERE C NOW THAT THEY ARE PACKED IN A NCEP BUFR FILE; CORRECTED VALUE C FOR RETURNED RAINFALL RATE IN CAT. 10 FOR WIND PROFILER REPORTS C 2000-12-05 D. A. KEYSER -- CHANGE TO BY-PASS TIME-WINDOW CHECKS ON C BUFR MESSAGES IF TIME WINDOW VALUES ARE .LE. -3 AND .GE. +2 C HOURS, RESP. (WAS .LE. -6 AND .GE. +6) SINCE NO DATA DUMPS WILL C EVER BE GREATER THAN THIS TIME WINDOW SPAN; GOES SOUNDING C PROCESSING MODIFIED TO NOT CREATE STN. ID IF IT HAS ALREADY BEEN C CREATED BY BUFR_DUPSAT, ERS SCATTEROMETER PROCESSING MODIFIED TO C NOT CREATE STN. IF IT HAS ALREADY BEEN CREATED BY WAVE_DATASORT C AND QUIKSCAT SCATTEROMETER PROCESSING MODIFIED TO NOT CREATE STN. C ID IF IT HAS ALREADY BEEN CREATED BY WAVE_DCODQUIKSCAT C (OTHERWISE, MODIFIED TO CREATE AN 8-CHARACTER STN. ID FOR ALL 3 C TYPES) C 2001-04-06 D. A. KEYSER -- RETURNS WITH IRET = 8 IF A BUFR MESSAGE C READ IN HAS THE SUBSET "NC002009" - THIS INDICATES THE MESSAGE C CONTAINS WIND PROFILER REPORTS ORIGINATING FROM PILOT (PIBAL) C FORMAT BULLETINS WHICH THIS SUBR. CANNOT PROCESS; ADDED "SUBSET" C (BUFR MESSAGE TYPE) AS AN OUTPUT ARGUMENT; THE GOES SOUNDING/ C RADIANCE CAT. 8 TYPES ARE NO LONGER SCALED, BUT STORED IN THE C SAME UNITS/ SCALING AS FOUND UPON INPUT; THE GOES SOUNDING/ C RADIANCE CAT. 13 BRIGHTNESS TEMPERATURES ARE NOW STORED AS DEG. C K (PRECISE TO 10**2) RATHER THAN AS DEG. K X 100; HEADER WORD 5 C NOW RETURNS COMPLETE DATE (YYYYMMDDHH) AND HEADER WORD 6 (WAS C DDHH) NOW RETURNS SATELLITE ID FOR GOES, ERS AND QUIKSCAT REPORTS C (FOR OTHERS IT'S MISSING); FOR GOES SOUNDINGS NOW SKIPS CAT. 12 C LEVELS WHERE RETRIEVED GEOPOTENTIAL HGHT IS .LE. ELEVATION C (LOWEST RETRIEVED HEIGHT); FOR GOES SOUNDINGS NOW UNPACKS SURFACE C PRESSURE INTO CAT. 8 CODE FIGURE 262 C 2001-06-19 D. A. KEYSER -- RECOGNIZES BUFR TYPE/SUBTYPE 003/002 AS C GOES 1x1 (HI-RES) DATA, PART OF THE "GOESND" DUMP FILE; STORES C CLOUD COVER RATHER THAN CLOUD AMOUNT IN OUTPUT CAT. 8, C.F. 258 C FOR GOES HI-RES REPORTS; GOES HI-RES REPORTS HAVE UNKNOWN PATH C AND GET PROPER STNID CHAR. 8 CHARACTER IDENTIFYING THE SAT. C NUMBER AND GET "H" IN STNID CHAR. 1 TO UNIQUELY IDENTIFY THEM C (IF STNID IS GENERATED HERE) C 2001-07-10 D. A. KEYSER -- FOR GOESND REPORTS, NOW KEEPS SEPARATE C COUNT OF REPORTS WITH MISSING # FOV (E.G., CLOUD-TOP REPORTS), C BEFORE THESE WERE GROUPED WITH # FOV 10-25 C 2001-08-20 D. A. KEYSER -- FOR QUIKSCAT REPORTS, HEADER WORD 10 C NOW RETURNS NUMBER OF ORIGINAL REPORTS USED TO GENERATE SUPEROBS C SINCE THIS IS NOW AVAILABLE IN INPUT REPROCESSED QKSWND DUMP C FILE (FOR NON-SUPEROBS, HARDWIRED TO 1) C 2002-01-28 D. A. KEYSER -- THE QUALITY CODE FOR WIND PROFILER LEVELS C IS NOW SET TO 14 IF THE DECODED QN29 WIND QUALITY MARKER IS 12 C (REJECT LIST) OR 14 (SDM PURGE), OTHERWISE IT IS SET TO THE C DECODED QUALITY CODE VALUE (BEFORE THE ON29 Q.M. WAS IGNORED); C THE WIND Q.M. FOR VAD WINDS LEVELS IS NOW SET TO THE DECODED QN29 C WIND QUALITY MARKER IF IT IS 12 (REJECT LIST) OR 14 (SDM PURGE), C OTHERWISE IT IS SET TO THE NUMERICAL INDICATOR FOR THE DECODED C RMS VECTOR WIND ERROR (BEFORE THE ON29 Q.M. WAS IGNORED) C 2002-03-05 D. A. KEYSER -- ACCOUNTS FOR CHANGES IN INPUT PROFLR C (WIND PROFILER BUFR DUMP FILE AFTER 5/2002: CAT. 10 SURFACE DATA C NOW ALL MISSING (MNEMONICS "PMSL","WDIR1","WSPD1", "TMDB", C "REHU", "REQV" NO LONGER AVAILABLE); CAT. 11 MNEMONICS "ACAVH", C "ACAVV", "SPP0", AND "NPHL" NO LONGER AVAILABLE; HEADER MNEMONIC C "NPSM" IS NO LONGER AVAILABLE; HEADER MNEMONIC "TPSE" REPLACES C "TPMI" (AVG. TIME IN MINUTES STILL OUTPUT); NUMBER OF UPPER-AIR C LEVELS INCR. FROM 43 TO UP TO 64 (SIZE OF OUTPUT "RDATA" ARRAY C INCR. FROM 720 TO 1200 TO ACCOUNT FOR THIS) (WILL STILL WORK C PROPERLY FOR INPUT PROFLR DUMP FILES PRIOR TO 5/2002) C 2002-07-03 D. A. KEYSER -- COMBINED INDIVIDUAL SUBROUTINES FOR C PROCESSING HEADER INFORMATION FOR ALL TYPES INTO A SINGLE NEW C SUBROUTINE SINCE ALL WERE VERY SIMILAR; ADDED PROCESSING OF GPS- C IPW REPORTS HERE NOW THAT THEY ARE PACKED IN AN NCEP BUFR FILE C (GPSIPW - RETURNED IN NEW CATEGORY 14) C 2004-02-02 D. A. KEYSER -- ADDED COOPERATIVE AGENCY (002/011) AND C JAPANESE (002/013) WIND PROFILERS TO PROCESSING FOR WIND C PROFILERS NOT ORIGINATING FROM PILOT (PIBAL) BULLETINS; ADDED C PROCESSING OF NPN AND CAP RASS REPORTS HERE (002/012) NOW THAT C THEY ARE PACKED IN AN NCEP BUFR FILE (RASSDA - RETURNED IN NEW C DATA LEVEL CATEGORY 15); ADDED NEW INPUT ARGUMENT "SUBSKP" - SEE C DESCRIPTION BELOW C 2004-09-09 D. A. KEYSER -- ADDED LOGIC TO HANDLE GOES 1x1 (SFOV) C SOUNDING (RADIANCE/RETRIEVAL) DATA: DOES NOT Q.C. ANY 1x1 DATA C (CLOUD AS BEFORE, BUT NOW ALSO SNDGS) BY NUMBER OF FOV's (STILL C DOES SO FOR NON-RADIANCE 5x5 DATA); FOR GOES PW RETRIEVALS, IF C TPW IS NOT FOUND UNDER LOCAL MNEMONIC "PH2O", NOW LOOKS FOR IT IN C WMO MNEMONIC "TPWT", THIS ALLOWS FOR TRANSITION FROM "PH2O" TO C "TPWT" IN REPORTS IN DUMP FILES (~ MID-2004) AND ALSO ALLOWS C HISTORICAL RERUNS TO READ OLD DUMP FILES C 2005-03-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM BUFR_LISTDUMPS): C 2007-09-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM PREPOBS_PREPDATA): C BUG FIX: REMOVED THIRD ARG. IN CALLS TO UNPKB709 AND UNPKB710 C (SUBROUTINES ONLY HAVE TWO ARG.) C 2006-07-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM BUFR_LISTDUMPS): C 2007-09-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM PREPOBS_PREPDATA): C MODIFIED TO HANDLE NAVY WINDSAT SCATTEROMETER WINDS (READ FROM C MESSAGE TYPES NC012138, GETS DUMP REPORT TYPE 583, OUTPUT IN C "RDATA" CAT. 10 AND SOME ELEMENTS IN "RDATA2"); ADDED RETURN C ARGUMENT "RDATA2", 1-DIM 21-WORD ARRAY WHICH HOLDS ADDITIONAL C VALUES DECODED DIRECTLY FROM BUFR (AND NOT IN "RDATA" ARRAY); C MOVED REPORT-TYPE SPECIFIC VALUES OUT OF RETURNED HEADER IN C "RDATA" TO NEW "RDATA2" ARRAY (CLEANS UP HEADER PROCESSING); C RAINFALL RATE IN CAT. 10 NOW RETURNED IN ORIGINAL BUFR UNITS OF C KG/((M**2)*SEC) INSTEAD OF MM/HOUR (WINDSAT IS ONLY TYPE TO C RETURN THIS); FOLDED SUBROUTINE UNPKB708 INTO UNPKB704 SINCE BOTH C HAD PROCESSED DATA INTO CATEGORY 10 (UNPKB708 HANDLED C SCATTEROMETER REPORTS, UNPKB704 HANDLED WIND PROFILER REPORTS) C 2007-09-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM BUFR_LISTDUMPS): C 2007-09-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM PREPOBS_PREPDATA): C MODIFIED TO HANDLE NESDIS WINDSAT SCATTEROMETER WINDS (READ FROM C MESSAGE TYPE NC012139), PROCESSING IS IDENTICAL TO NAVY WINDSAT C SCATTEROMETER WINDS; HANDLES GOES 1x1 F-O-V SNDGS/RADIANCES IN C DUMP FILE "GOESFV" (SUBSET "NC003003"); CODE FIGURE 258 REFERS C ONLY TO CLOUD AMOUNT (HAD ALSO PREVIOUSLY REFERRED TO CLOUD COVER C FOR GOES 1x1 SNDGS - GOES 1x1 AND 5x5 SNDGS NOW BOTH PROCESS C CLOUD AMOUNT) C 2008-09-25 D. A. KEYSER -- ADDED ASCAT SCATTEROMETER WINDS HERE NOW C THAT THEY ARE PACKED IN A NCEP BUFR FILE (GET DUMP REPORT TYPE C 584), RETURNED IN CATEGORY 10, EXPANDED 1-DIM OUTPUT ARRAY RDATA2 C FROM 21 TO 24 WORDS TO HOLD NEW ANCILLARY INFO FOR ASCAT REPORTS C {WIND VECTOR CELL QUALITY (MNEMONIC WVCQ, BUFR F.T. 0-21-155), C BACKSCATTER DISTANCE (MNEMONIC BSCD, NUMERIC), LIKELIHOOD C COMPUTED FOR SOLUTION (MNEMONIC LKCS, NUMERIC) C 2012-11-30 J. WOOLLEN -- INITIAL PORT TO WCOSS; RESET BMISS TO C A VALUE (10E08) WHICH WILL NOT CAUSE INTEGER OVERFLOW WHICH CAN C BE UNPREDICTABLE (PRIOR BMISS VALUE WAS 10E10) C 2013-02-14 D. A. KEYSER -- FINAL CHANGES TO RUN ON WCOSS; OBTAIN C VALUE OF BMISS SET IN CALLING PROGRAM VIA CALL TO BUFRLIB ROUTINE C GETBMISS RATHER THAN HARDWIRING IT TO 10E08 (OR 10E10); USE C BUFRLIB FUNCTION IBFMS TO DETERMINE IF A VARIABLE READ FROM BUFR C FILE IS MISSING (I.E. RETURNED AS BMISS); USE FORMATTED PRINT C STATEMENTS WHERE PREVIOUSLY UNFORMATTED PRINT WAS USED (WCOSS C SPLITS UNFORMATTED PRINT AT 80 CHARACTERS); MAXIMUM NUMBER OF C CAT. 11 WIND PROFILER LEVELS THAT CAN BE PROCESSED (EXCLUDING C BOTTOM SURFACE LEVEL) REDUCED FROM 103 TO 102 AS FORMER CAUSED AN C OVERFLOW OF THE CURRENT 1200 WORD LIMIT IN RDATA ARRAY; FOR ANY C "GOESND" OR "GOESFV" DUMP FILES WITH CENTER TIME 2013022512 OR C LATER, NO ATTEMPT IS MADE TO DECODE GOES SOUNDINGS (PROFILES) AS C THESE WERE REMOVED AT THIS TIME FROM THE 1X1 GOES RADIANCE FILES C PROVIDED BY NESDIS (INGESTED INTO FROM TANK b003/xx003) C 2014-03-13 D. A. KEYSER -- MODIFIED TO HANDLE VAD WINDS FROM LEVEL C 2 DECODER (SUBSET "NC002017") {IN ADDITION TO THOSE FROM RADAR C CODED MESSAGE (SUBSET "NC002008")}; PARAMETERIZED MAXIMUM NUMBER C OF LEVELS ALLOWED FOR EACH CATEGORY AND CALCULATED PARAMETER C "IDMAX" (SIZE OF OUTPUT "RDATA" ARRAY) BASED ON THESE, ALL ARE C NOW PLACED IN INCLUDE FILE 'inc_w3unpkb7.inc' {IN HERE, MAXIMUM C NUMBER OF CAT. 04 WINDS-BY-HEIGHT LEVELS (EXCLUDING FIRST, C SURFACE, LEVEL), "ILVLMX_04", INCREASED FROM 64 TO 254 TO ACCOUNT C FOR MORE LEVELS IN NEW VAD WINDS FROM LEVEL 2 DECODER, AND C MAXIMUM NUMBER OF CAT. 11 WIND PROFILER LEVELS (EXCLUDING FIRST, C SURFACE, LEVEL), "ILVLMX_11", INCREASED FROM 102 TO 200 TO C ACCOUNT FOR SOME MAP PROFILERS WITH MORE LEVELS THAN BEFORE, THE C RESULTING "IDMAX" IS NOW 2270, UP FROM 1200 BEFORE} C 2015-04-16 JWhiting -- RDATA2 is expanded to size 25 in order to C store total cloud cover (TOCC) (present in dumps of GOES cloud C reports) (stored in subr. UNPKB707). C 2015-12-18 D. A. Keyser -- Updated to decode variables specific to C the new WMO BUFR format for GNSS ground-based data (in dump file C "gpsipw" under subset "NC012004") in order to process GPS-Met C reports from this feed. Namely: C CLATH (high-res lat) --> stored as lat in header array returned C to calling program C CLONH (high-res lon) --> stored as lon in header array returned C to calling program C STSN (station name) --> stored as STNID returned to calling C program C TMDBST (dry-bulb temperature to nearest 0.1K) --> stored in C cat. 14 returned to calling program C APDS (atmospheric path delay in satellite signal, m, from C replication where azimuth angle is zero deg. and elevation C angle is 90 deg.) --> this is defined as ZENITH TOTAL DELAY and C is stored in cat. 14 returned to calling program C APDE (error in atmospheric path delay in satellite signal, m, C from replication where azimuth angle is zero deg. and elevation C angle is 90 deg.) --> this is defined as ERROR IN ZENITH TOTAL C DELAY and is stored in cat. 14 returned to calling program C (Note: will still also properly decode variables in current C production non-standard BUFR format GPS ground-based data (in dump C file "gpsipw" under subset "NC012003"). C 2016-08-15 JWhiting -- Added variable 'subset' to UNPKB709 argument C list so as to allow its use in testing for whether reports are C from new GNSS ground-based data streams (subset=NC012004); this C replaces potentially ambiguous test on missing TDEL data from C previous GPS-IPW data streams. C 2016-11-30 D. A. KEYSER -- C Added new output real, double-precision argument array RDATA8_8 of C length 2 to return full-precision latitude and longitude for a C report. C BENEFIT: Although lat and lon are returned in RDATA(1:2) these are C at machine precison, which is normally R*4. Now that C many reports in the dumps store lat/lon at 0.001 or even C 0.00001 degree precision, and now that PREPBUFR encodes C YOB (lat) and XOB (lon) at 0.00001 degree precision, this C change will ensure that lat/lon is always accurate to C 0.00001 degrees in all downstream processing. C 2020-01-06 J. Dong -- In subroutine W3UNPKB7, changed the windowing C decade from 20 to 40 for cases when the year is represented by C 2 digits instead of 4. C 2020-08-20 J. DONG -- C - Added processing to encode BUFR format VAD wind (NC002018) C profiler wind (NC002014) tanks into prepbufr files. C - Defined IDSDAT to eliminate Boundary Run-Time Check Failures. C C C C USAGE: CALL W3UNPKB7(IDATE,IHE,IHL,LUNIT,RDATA,STNID,DSNAME, C RDATA2,RDATA8_8,IDSDAT,IDSDMP_8,SUBSET,SUBSKP, C 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 - EARLIEST MESSAGE DATE IS AFTER "IDATE"; IF "IHE" IS C - NEGATIVE, EARLIEST MESSAGE DATE IS PRIOR TO "IDATE") C - EXAMPLE: IF IHE=1, THEN EARLIEST DATE IS 1-HR AFTER C - IDATE; IF IHE=-2, THEN EARLIEST DATE IS 2-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=2, THEN LATEST DATE IS 2-HR 59-MIN C - AFTER IDATE; IF IHL=-2, THEN LATEST DATE IS 1-HR 1-MIN C - PRIOR TO IDATE C NOTE: THERE IS NO LIMIT ON THE VALUES FOR "IHE" AND "IHL", C HOWEVER IF IHE IS .LE. -3 AND IHL IS .GE. +2, THEN IT C IS ASSUMED THAT ALL BUFR MESSAGES IN THE FILE ARE TO BE C PROCESSED REGARDLESS OF THEIR TIME SO IT DOESN'T MAKE C ANY SENSE TO SPECIFY VALUES OUTSIDE THIS RANGE. C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE C SUBSKP - TWO-DIMENSIONAL LOGICAL ARRAY WHERE ELEMENT 1 REFERS C - TO A PARTICULAR BUFR TYPE (RANGE 0-255) AND ELEMENT 2 C - REFERS TO A PARTICULAR BUFR SUBTYPE (RANGE 0-200). IF C - SUBSKP IS SET TO TRUE FOR A PARTICULAR BUFR TYPE AND C - SUBTYPE, THEN ANY BUFR MESSAGE OF THIS TYPE READ IN C - WILL BE SKIPPED OVER {NO SUBSETS (REPORTS) WILL BE C - DECODED OUT OF IT AND RETURNED TO THE CALLING PROGRAM, C - INSTEAD THIS SUBROUTINE WILL MOVE ON TO READ THE NEXT C - BUFR MESSAGE IN THE FILE AND AGAIN USE SUBSKP TO SEE C - IF ANY SUBSETS SHOULD BE DECODED OUT OF IT}. THIS C - ALLOWS THIS SUBROUTINE TO QUICKLY PASS BY ANY BUFR C - MESSAGES WITH A TYPE/SUBTYPE THAT THE CALLING PROGRAM C - DOES NOT WANT DECODED. THE LENGTH OF THIS ARRAY C - SHOULD ALWAYS BE HARDWIRED TO (0:255,0:200). 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: C RDATA - SINGLE REPORT RETURNED AN A QUASI-IW3UNPBF C - UNPACKED FORMAT (SEE REMARKS 5) (MINIMUM SIZE IS C - 1500 WORDS) (NOTE: DOES NOT INCLUDE STATION ID) C STNID - CHARACTER*8 SINGLE REPORT STATION IDENTIFICATION (UP C - TO 8 CHARACTERS, LEFT-JUSTIFIED) (SEE REMARKS 4 FOR C - INFORMATION ON STRUCTURE OF GOES SOUNDING STNID) C DSNAME - CHARACTER*8 DATA SET NAME (SAME FOR ALL REPORTS IN C - A COMMON INPUT DATA SET - SEE OUTPUT ARGUMENT LIST C - BELOW FOR IRET=1 CASE) C RDATA2 - 25-WORD ARRAY CONTAINING ADDITIONAL REPORT DATA NOT C - PRESENT IN RDATA ARRAY (DECODED DIRECTLY FROM BUFR) C - (SEE REMARKS 6 FOR CONTENT) C RDATA8_8 - 2-WORD REAL*8 ARRAY CONTAINING ADDITIONAL REPORT DATA C (LATITUDE AND LONGITUDE) (SEE REMARKS 7 FOR CONTENT) C IDSDAT - INTEGER DATA SET CENTER DATE IN FORM YYYYMMDDHH (SAME C - FOR ALL REPORTS IN A COMMON INPUT DATA SET - SEE C - OUTPUT ARGUMENT LIST BELOW FOR IRET=1 CASE) C IDSDMP_8 - INTEGER*8 DATA SET DUMP TIME IN FORM YYYYMMDDHHMM C - (SAME FOR ALL REPORTS IN A COMMON INPUT DATA SET - SEE C - OUTPUT ARGUMENT LIST BELOW FOR IRET=1 CASE) C SUBSET - CHARACTER*8 BUFR MESSAGE TYPE (SAME FOR ALL REPORTS C - IN A COMMON BUFR MESSAGE) C IRET - RETURN CODE AS FOLLOWS: C = 0 OBSERVATION READ AND UNPACKED INTO OUTPUT ARGUMENT C LOCATIONS (SEE ABOVE). SEE REMARKS FOR CONTENTS. C NEXT CALL TO W3UNPKB7 WILL RETURN NEXT OBSERVATION C IN DATA SET. C = 1 INFORMATION ABOUT THE BUFR DATASET IS RETURNED IN C THE OUTPUT ARGUMENTS DSNAME, IDSDAT, IDSDMP_8 (SEE C OUTPUT ARGUMENT LIST ABOVE) C C THIS SHOULD ALWAYS OCCUR AFTER THE FIRST CALL TO C THIS SUBROUTINE FOR A NEW UNIT NUMBER (I.E., A NEW C DATA SET) OR IF THE INPUT DATE/TIME OR RANGE IN TIME C HAS BEEN CHANGED FROM LAST CALL (I.E., A DATA SET C IS ABOUT TO BE READ FROM THE TOP). NO REPORT IS C UNPACKED AT THIS POINT, AND ONLY DSNAME, IDSDAT, AND C IDSDMP_8 CONTAIN INFORMATION. ALL SUBSEQUENT CALLS C TO W3UNPKB7 SHOULD RETURN THE OBSERVATIONS IN THIS C DATA SET, SEQUENTIALLY, (IRET=0) UNTIL THE END OF C FILE IS ENCOUNTERED (IRET=2). THE VALUES STORED IN C DSNAME, IDSDAT, AND IDSDMP_8 WILL CONTINUE TO BE C RETURNED ALONG WITH EACH REPORT WHEN IRET = 0. C = 2 FOR NORMAL END-OF-FILE ENCOUNTERED. C = 3 LAT AND/OR LON DATA MISSING -- NO REPORT RETURNED. C = 4 SOME/ALL DATE INFORMATION MISSING -- NO REPORT C RETURNED. C = 5 NO "CATEGORY" DATA LEVELS PROCESSED (ALL LEVELS ARE C MISSING) -- NO REPORT RETURNED. C = 6 NUMBER OF LEVELS IN REPORT HEADER IS NOT 1 -- NO C REPORT RETURNED. C = 7 NUMBER OF LEVELS IN ANOTHER SINGLE LEVEL SEQUENCE IS C NOT 1 -- NO REPORT RETURNED. C = 8 REPORT IS A WIND PROFILER ORIGINATING FROM PILOT C (PIBAL) FORMAT BULLETINS -- NO REPORT RETURNED. 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 - STANDARD OUTPUT PRINT C C SUBPROGRAMS CALLED: C UNIQUE - UNPKB701 UNPKB702 UNPKB703 UNPKB704 UNPKB705 C - UNPKB706 UNPKB707 UNPKB709 UNPKB710 C LIBRARY: C W3NCO - W3FI04 W3MOVDAT W3DIFDAT ERREXIT C BUFRLIB - DATELEN DUMPBF OPENBF READMG UFBCNT C - READSB UFBINT CLOSBF NMSUB GETBMISS C - IBFMS CBFMS READLC UFBREP C C REMARKS: C 1) A CONDITION CODE (STOP) OF 15 WILL OCCUR IF THE INPUT DATES FOR C START AND/OR STOP TIME ARE SPECIFIED INCORRECTLY. C C C C 2) A CONDITION CODE (STOP) OF 22 WILL OCCUR IF THE CHARACTERS ON C THIS MACHINE ARE NEITHER ASCII NOR EBCDIC. C C C C 3) THE INPUT ARGUMENT "IRET" SHOULD BE SET PRIOR TO EACH CALL TO C THIS SUBROUTINE. C C C C 4) FOR GOES SOUNDING/RADIANCE REPORTS, THE EIGHTH CHARACTER OF C STATION ID (stnid) IS A TAGGED AS FOLLOWS: C "I" - GOES-EVEN-1 (252, 256, ...) SAT. , CLEAR COLUMN RETR. C "J" - GOES-EVEN-1 (252, 256, ...) SAT. , CLOUDY RETRIEVAL C "K" - GOES-EVEN-1 (252, 256, ...) SAT. , UNKNOWN PATH C C "L" - GOES-ODD-1 (253, 257, ...) SAT. , CLEAR COLUMN RETR. C "M" - GOES-ODD-1 (253, 257, ...) SAT. , CLOUDY RETRIEVAL C "N" - GOES-ODD-1 (253, 257, ...) SAT. , UNKNOWN PATH C C "O" - GOES-EVEN-2 (254, 258, ...) SAT. , CLEAR COLUMN RETR. C "P" - GOES-EVEN-2 (254, 258, ...) SAT. , CLOUDY RETRIEVAL C "S" - GOES-EVEN-2 (254, 258, ...) SAT. , UNKNOWN PATH C C "Q" - GOES-ODD-2 (251, 255, ...) SAT. , CLEAR COLUMN RETR. C "R" - GOES-ODD-2 (251, 255, ...) SAT. , CLOUDY RETRIEVAL C "T" - GOES-ODD-2 (251, 255, ...) SAT. , UNKNOWN PATH C C "?" - SATELLITE UNKNOWN C C C C 5) CONTENTS OF AN UNPACKED REPORT IN THE "RDATA" ARRAY (MISSING C INTEGER DATA ARE SET TO IMISS (99999); MISSING REAL DATA ARE C SET TO XMISS (99999.) C C (NOTE: DOES NOT INCLUDE STATION IDENTIFICATION AND "RDATA2" ARRAY C OUTPUT; LATITUDE AND LONGITUDE IN RDATA(1:2) ARE ALSO C OUTPUT IN REAL*8 IN "RDATA8_8" - SEE OUTPUT ARGUMENT C "STNID" ABOVE, "RDATA2" CONTENTS IN REMARKS 6. BELOW AND C "RDATA8_8" CONTENTS IN REMARKS 7. BELOW) C C *************************************************************** C WORD CONTENT UNIT FORMAT C ---- ---------------------- ------------------- --------- C 1 LATITUDE DEGREES (N+,S-) REAL C 2 LONGITUDE DEGREES EAST REAL C 3 NOT USED MISSING REAL C 4 OBSERVATION TIME HOURS (UTC) REAL C 5 DATE YYYYMMDDHH INTEGER C 6 SATELLITE ID (BUFR CODE TABLE 0-01-007) INTEGER C (SEE @) C 7 STATION ELEVATION METERS REAL C 8 INSTRUMENT TYPE (SEE $) INTEGER C 9 DUMP REPORT TYPE (SEE &) INTEGER C 10 DUMP REPORT SUBTYPE MISSING INTEGER C 11 RECEIPT TIME HOURS (UTC) REAL C 12 NOT USED MISSING REAL C C 13-18 ZEROED OUT - NOT USED C 19 CATEGORY 4, NO. LEVELS COUNT INTEGER C 20 CATEGORY 4, DATA INDEX COUNT INTEGER C 21-26 ZEROED OUT - NOT USED C 27 CATEGORY 8, NO. LEVELS COUNT INTEGER C 28 CATEGORY 8, DATA INDEX COUNT INTEGER C 29-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 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 43 CATEGORY 14, NO. LEVELS COUNT INTEGER C 44 CATEGORY 14, DATA INDEX COUNT INTEGER C 45 CATEGORY 15, NO. LEVELS COUNT INTEGER C 46 CATEGORY 15, DATA INDEX COUNT INTEGER C 47-52 ZEROED OUT - NOT USED INTEGER C C 53-END UNPACKED DATA GROUPS (SEE BELOW) MIXED C C @ - WORD 6, SATELLITE ID, IS CURRENTLY SET TO MISSING FOR C ALL TYPES EXCEPT: C GOES SOUNDING/RADIANCE (DUMP RPT TYPE 061) C ERS SCATTEROMETER (DUMP RPT TYPE 581) C QUIKSCAT SCATTEROMETER (DUMP RPT TYPE 582) C WINDSAT SCATTEROMETER (NAVY or NESDIS) (DUMP RPT TYPE 583) C ASCAT SCATTEROMETER (DUMP RPT TYPE 584) C C $ - WORD 8, INSTRUMENT TYPE, IS CURRENTLY SET TO MISSING FOR C ALL TYPES EXCEPT: C GOES SOUNDING/RADIANCE (DUMP REPORT TYPE 061) C Processing technique C 21 Clear C 23 Cloudy C C & - DUMP REPORT TYPES: C 061 - GOES sounding/radiance C 071 - NOAA Profiler Network (NPN) wind C 072 - NEXRAD (VAD) wind (from both Radar Coded Message and C from Level 2 decoder) C 074 - GPS-IPW C 075 - Cooperative Agency Profiler (CAP) wind C 076 - Japanese Meteological Agency (JMA) profiler wind C 077 - NOAA Profiler Network (NPN) or Cooperative Agency C Profiler (CAP) RASS temperature C 581 - ERS scatterometer C 582 - QuikSCAT scatterometer C 583 - WindSat scatterometer (NAVY or NESDIS) C 584 - ASCAT scatterometer C C *************************************************************** C C DATA ARE UNPACKED INTO FIXED LOCATIONS IN WORDS 1-12 AND INTO C INDEXED LOCATIONS IN WORD 53 AND FOLLOWING. EACH LEVEL IN C THE INPUT BUFR REPORT IS STORED IN THE "DATA LEVEL CATEGORIES" C DESCRIBED BELOW, BASED ON THE TYPE OF DATA. EACH DATA LEVEL C CATEGORY HAS A LAYOUT IN LOCATIONS IN ARRAY RDATA THAT MAY BE C FOUND BY USING THE CORRESPONDING INDEX AMOUNT FROM WORDS 14, C 16, ..., 46, IN ARRAY RDATA. FOR INSTANCE, IF A REPORT IS C UNPACKED INTO ONE OR MORE CATEGORY 4 DATA LEVEL GROUPS (WIND C DATA AT VARIABLE HEIGHT LEVELS) THAT DATA WILL BE SPECIFIED IN C THE UNPACKED BINARY FORMAT AS DESCRIBED BELOW UNDER DATA LEVEL C CATEGORY 4. THE NUMBER OF LEVELS WILL BE STORED IN WORD C 19 OF OBS AND THE INDEX OF THE FIRST LEVEL OF UNPACKED DATA IN C THE OUTPUT ARRAY WILL BE STORED IN WORD 20. THE SECOND LEVEL, C IF ANY, WILL BE STORED BEGINNING FIVE WORDS FURTHER ON, AND SO C FORTH UNTIL THE COUNT IN WORD 19 IS EXHAUSTED. THE FIELD C LAYOUT IN EACH DATA LEVEL CATEGORY IS GIVEN BELOW... C C C DATA LEVEL CATEGORY 4 - WINDS AT VARIABLE HEIGHTS (FIRST LEVEL C IS SURFACE) (EACH LEVEL, SEE WORD 19 C ABOVE) C (Currently used only by VAD wind reports) C C WORD PARAMETER UNITS FORMAT C ---- --------- ----------------- ------------- C 1 HEIGHT ABOVE SEA METERS REAL C LEVEL C 2 HORIZONTAL WIND DEGREES REAL C DIRECTION (VAD FROM RADAR CODED MESSAGE) C U-COMPONENT WIND METERS/SEC REAL C (VAD FROM LEVEL 2 DECODER) C 3 HORIZONTAL WIND 0.1 METERS/SEC REAL C SPEED (VAD FROM RADAR CODED MESSAGE) C V-COMPONENT WIND METERS/SEC REAL C (VAD FROM LEVEL 2 DECODER) C 4 QUALITY MARKER FOR (hardwired to 2.) REAL C HEIGHT C 5 QUALITY MARKER FOR (SEE %) REAL C WIND C C %- VALUES FROM 1-7 INDICATE A "CONFIDENCE LEVEL" WHICH IS RELATED C TO THE ROOT-MEAN-SQUARE VECTOR ERROR FOR THE HORIZONTAL WIND. C IT IS DEFINED AS FOLLOWS: C 1.0 = RMS OF 1.9 KNOTS C 2.0 = RMS OF 3.9 KNOTS C 3.0 = RMS OF 5.8 KNOTS C 4.0 = RMS OF 7.8 KNOTS (DEFAULT) C 5.0 = RMS OF 9.7 KNOTS C 6.0 = RMS OF 11.7 KNOTS C 7.0 = RMS > 13.6 KNOTS C VALUE 12 INDICATES THE WIND IS FLAGGED DUE TO ITS BEING ON THE C REJECT LIST C VALUE 14 INDICATES THE WIND IS FLAGGED DUE TO ITS BEING PURGED C MANUALLY BY THE NCEP SDM C C C DATA LEVEL CATEGORY 10 - SURFACE LEVEL (EACH LEVEL, SEE WORD 35 C ABOVE) C (Currently used by wind profiler, ERS scatterometer, QuikSCAT C scatterometer, WindSat scatterometer and ASCAT scatterometer C reports) C C WORD PARAMETER UNITS FORMAT C ---- --------- ----------------- ------------- C 1 SEA-LEVEL PRESSURE 0.1 MILLIBARS REAL C 2 STATION PRESSURE 0.1 MILLIBARS REAL C 3 HORIZ. WIND DIR. DEGREES REAL C 4 HORIZ. WIND SPEED 0.1 METERS/SEC REAL C 5 AIR TEMPERATURE 0.1 KELVIN REAL C 6 RELATIVE HUMIDITY PERCENT REAL C 7 RAINFALL RATE KG/((METER**2)*SEC) REAL C C Note: For wind profiler, word 2 always missing; words 1, 3-7 C no longer available after 5/2002 (missing) C For ERS, QuikSCAT and ASCAT scatterometer, words 1,2, 5-7 C always missing C For WindSat scatterometer, words 1,2, 5-6 always missing C C C DATA LEVEL CATEGORY 11 - UPPER-AIR LEVEL (FIRST LEVEL IS SURFACE) C (EACH LEVEL, SEE WORD 37 ABOVE) C (Currently used only by wind profiler reports) C 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 METERS/SEC REAL C 4 QUALITY CODE (SEE %) INTEGER C 5 VERT. WIND COMP. (W) 0.01 METERS/SEC REAL C(SEE @)6 HORIZ. CONSENSUS NO. (SEE $) INTEGER C(SEE @)7 VERT. CONSENSUS NO. (SEE $) INTEGER C 8 - NOAA Profiler Network (NPN) and Cooperative Agency (CAP): C (SEE @) SPECTRAL PEAK POWER DB REAL C - Japanese: C SIG-TO-NOISE RATIO DB REAL C 9 HORIZ. WIND SPEED 0.1 METERS/SEC REAL C STANDARD DEVIATION C 10 VERT. WIND COMPONENT 0.1 METERS/SEC REAL C STANDARD DEVIATION C(SEE @)11 MODE (SEE #) INTEGER C C *- ALWAYS MISSING C %- 0 - MEDIAN AND SHEAR CHECKS BOTH PASSED (NPN and CAP) C - DATA NOT SUSPECT (JAPANESE) C 1 - DATA SUSPECT (JAPANESE) C 2 - MEDIAN AND SHEAR CHECK RESULTS INCONCLUSIVE (NPN and CAP) C 3 - QUALITY INFORMATION NOT GIVEN (JAPANESE) C 4 - MEDIAN CHECK PASSED; SHEAR CHECK FAILED (NPN and CAP) C 8 - MEDIAN CHECK FAILED; SHEAR CHECK PASSED (NPN and CAP) C 12 - MEDIAN AND SHEAR CHECKS BOTH FAILED (NPN and CAP) C 14 - THE WIND IS FLAGGED DUE TO EITHER: C BEING ON THE REJECT LIST, OR C BEING PURGED MANUALLY BY THE NCEP SDM 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 5/2002 AND IS SET C TO MISSING C C C DATA LEVEL CATEGORY 12 - SATELLITE SOUNDING LEVEL (FIRST LEVEL IS C SURFACE) (EACH LEVEL, SEE WORD 39 ABOVE) C (Currently used only by GOES sounding/radiance reports) C 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 Q.M. FOR GEOPOT (SEE &) REAL C 8 Q.M. FOR TEMPERATURE (SEE &) REAL C 9 Q.M. FOR DEWPT TEMP (SEE &) REAL C C &- 2.0 - INDICATES DATA NOT SUSPECT C 3.0 - INDICATES DATA ARE SUSPECT C 13.0 - INDICATES DATA ARE BAD C C C DATA LEVEL CATEGORY 13 - SATELLITE RADIANCE "LEVEL" (EACH C "LEVEL", SEE WORD 41 ABOVE) C (Currently used only by GOES sounding/radiance reports) C C WORD PARAMETER UNITS FORMAT C ---- --------- ----------------- ------------- C 1 CHANNEL NUMBER NUMERIC INTEGER C 2 BRIGHTNESS TEMP. KELVIN REAL C 3 Q.M. FOR BTEMP (SEE &) REAL C C &- 2.0 - INDICATES DATA NOT SUSPECT C 3.0 - INDICATES DATA ARE SUSPECT C 13.0 - INDICATES DATA ARE BAD C C C DATA LEVEL CATEGORY 14 - GPS-IPW DATA (FIRST LEVEL IS SURFACE) C (EACH LEVEL, SEE WORD 43 ABOVE) C (Currently used only by GPS-IPW reports) C C WORD PARAMETER UNITS FORMAT C ---- --------- ----------------- ------------- C 1 STATION PRESSURE MILLIBARS REAL C 2 AIR TEMPERATURE KELVIN REAL C 3 RELATIVE HUMIDITY PERCENT REAL C 4 TOTAL PRECIP. WATER MILLIMETERS REAL C 5 ZENITH TOTAL DELAY METERS REAL C 6 ERROR IN ZENITH METERS REAL C TOTAL DELAY C 7 HYDROSTATIC DELAY METERS REAL C 8 ERROR IN HYDROSTATIC METERS REAL C DELAY C 9 WEIGHTED MEAN KELVIN REAL C TEMPERATURE C 10 WET DELAY MAPPING NUMERIC REAL C FUNCTION C C C DATA LEVEL CATEGORY 15 - RASS DATA (FIRST LEVEL IS SURFACE) C (EACH LEVEL, SEE WORD 45 ABOVE) C (Currently used only by RASS reports) C C WORD PARAMETER UNITS FORMAT C ---- --------- ----------------- ------------- C 1 HEIGHT ABOVE SEA-LVL METERS REAL C 2 VIRTUAL TEMPERATURE KELVIN REAL C 3 QUALITY CODE (SEE %) INTEGER C 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 14 - THE WIND IS FLAGGED DUE TO EITHER: C BEING ON THE REJECT LIST, OR C BEING PURGED MANUALLY BY THE NCEP SDM C C C DATA LEVEL CATEGORY 08 - ADDITIONAL (MISCELLANEOUS) DATA (EACH C "LEVEL", SEE @ BELOW) C (Currently used only by GOES sounding/radiance reports) C C WORD PARAMETER UNITS FORMAT C ---- --------- ----------------- ------------- C 1 VARIABLE (SEE @) REAL C 2 CODE FIGURE (SEE @) REAL C 3 Q.M. FOR THE DATUM (SEE &) REAL C 4 NOT USED REAL C C @- NUMBER OF "LEVELS" FROM WORD 27. MAXIMUM IS "ILVLMX_08" C (CURRENTLY SET TO 13), AND ARE ORDERED AS FOLLOWS (IF A DATUM C ARE MISSING THAT LEVEL NOT STORED) C 1 - LIFTED INDEX ---------- KELVIN ----------- C. FIG. 250. C 2 - TOTAL PRECIP. WATER -- MILLIMETERS ------ C. FIG. 251. C 3 - 1. TO .9 SIGMA P.WATER- MILLIMETERS ------ C. FIG. 252. C 4 - .9 TO .7 SIGMA P.WATER- MILLIMETERS ------ C. FIG. 253. C 5 - .7 TO .3 SIGMA P.WATER- MILLIMETERS ------ C. FIG. 254. C 6 - SKIN TEMPERATURE ----- KELVIN ----------- C. FIG. 255. C 7 - CLOUD TOP TEMPERATURE- KELVIN ----------- C. FIG. 256. C 8 - CLOUD TOP PRESSURE --- 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 --- DEGREE ----------- C. FIG. 260. C 12 - SAT. ZENITH ANGLE ---- DEGREE ----------- C. FIG. 261. C 13 - SURFACE PRESSURE ----- MILLIBARS -------- C. FIG. 262. C C &- 2.0 - INDICATES DATA NOT SUSPECT C 3.0 - INDICATES DATA ARE SUSPECT C 13.0 - INDICATES DATA ARE BAD C C C C 6) CONTENTS OF AN UNPACKED REPORT IN THE "RDATA2" ARRAY (DECODED C DIRECTLY FROM BUFR, ALL VALUES ARE IN REAL FORMAT; MISSING DATA C ARE SET TO "BMISS", AS IN BUFR) C C WORD CONTENT BUFR FXY UNIT C ---- ---------------------------------------- -------- ---------- C 1 TIME SIGNIFICANCE 0-08-021 CODE TABLE C 2 TOTAL NUMBER (WITH RESPECT TO 0-08-022 NUMERIC C ACCUMULATION OR AVERAGE) (i.e., F-O-V C number for GOES sounding/radiance; # of C orig. reports used to generate superob C for QuikSCAT, WindSAT and ASCAT - for C non-superobs, hardwired to 1) C 3 ACROSS-SWATH CELL NUMBER 0-06-034 NUMERIC C 4 ALONG-TRACK ROW NUMBER 0-05-034 NUMERIC C 5 WIND PROFILER SUBMODE INFORMATION 0-25-033 CODE TABLE C Note: Submode is missing after 5/2002 C (no longer available) C 6 TIME PERIOD OR DISPLACEMENT 0-04-025 MINUTE C (i.e., AVERAGING TIME) C Note: A negative number means prior to C observation time C 7 QUALITY INFORMATION 0-33-002 CODE TABLE C 8 SEAWINDS PROBABILITY OF RAIN 0-21-120 NUMERIC C C 9 SEA SURFACE TEMPERATURE 0-22-043 KELVIN C 10 TOTAL WATER VAPOR 0-13-096 KG/METER**2 C 11 TOTAL CLOUD LIQUID WATER 0-13-097 KG/METER**2 C 12 WINDSAT SURFACE TYPE 0-20-219 CODE TABLE C 13 MODEL WIND DIRECTION AT 10 METERS 0-11-081 DEGREES C 14 MODEL WIND SPEED AT 10 METERS 0-11-082 METERS/SEC C 15 WINDSAT EDR Q.C. FLAG # 1 0-33-200 FLAG TABLE C 16 CHI-SQUARED (OF THE WIND VECTOR 0-33-199 NUMERIC C RETRIEVAL) C 17 ESTIMATED ERROR COVARIANCE FOR WIND 0-33-201 DEGREES C DIRECTION RETRIEVAL C 18 ESTIMATED ERROR COVARIANCE FOR WIND 0-33-246 METERS/SEC C SPEED RETRIEVAL C 19 ESTIMATED ERROR COVARIANCE FOR SEA 0-33-245 KELVIN C SURFACE TEMPERATURE RETRIEVAL C 20 ESTIMATED ERROR COVARIANCE FOR TOTAL 0-33-248 KG/METER**2 C CLOUD LIQUID WATER RETRIEVAL C 21 ESTIMATED ERROR COVARIANCE FOR TOTAL 0-33-247 KG/METER**2 C WATER VAPOR RETRIEVAL C 22 WIND VECTOR CELL QUALITY 0-21-155 FLAG TABLE C 23 BACKSCATTER DISTANCE 0-21-156 NUMERIC C 24 LIKELIHOOD COMPUTED FOR SOLUTION 0-21-104 NUMERIC C 25 TOTAL CLOUD COVER 0-21-010 PERCENT C C C C 7) CONTENTS OF AN UNPACKED REPORT IN THE "RDATA8_8" ARRAY C (ALL VALUES ARE IN REAL*8`FORMAT; MISSING DATA ARE SET TO C "BMISS") C C WORD CONTENT UNIT C ---- -------------------------------- ------------------- C 1 LATITUDE DEGREES (N+,S-) C 2 LONGITUDE DEGREES (E+,W-) C C C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ SUBROUTINE W3UNPKB7(IDATE,IHE,IHL,LUNIT,RDATA,STNID,DSNAME,RDATA2, $ rdata8_8,IDSDAT,IDSDMP_8,SUBSET,SUBSKP,IRET) C Include parameters common to more than one subroutine C ----------------------------------------------------- include 'inc_w3unpkb7.inc' CHARACTER*8 STNID,SUBSET,DSNAME,CBUFR REAL RINC_O(5),RINC_I(5),RDATA2(25),RDATA(*),RDATX(IDMAX) REAL(8) RDATA2_8(25),rdata8_8(2) REAL(8) BMISS,GETBMISS INTEGER IDATE(4),LSDATE(4),IDATA(IDMAX),JDATE(8) INTEGER(8) IDSDAT,IDSDMP_8,IDDATE_8(5) LOGICAL SUBSKP(0:255,0:200),SKIP_CAT12 COMMON /PKB7AA/BMISS COMMON /PKB7BB/KDATE(8),LDATE(8),KTIMCH,IPRINT,SKIP_CAT12 COMMON /PKB7CC/INDEX COMMON /PKB7DD/LSHE,LSHL,ICDATE(5),IDDATE(5) COMMON /PKB7FF/IFOV(4,2),KNTSAT(250:260) COMMON /PKB7HH/NPRINT(0:255,0:200) SAVE EQUIVALENCE (RDATX,IDATA) DATA ITM/0/,LUNITL/-99/ 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 AND TYPE OF CHARACTER SET C {ASCII(ICHTP=0) OR EBCDIC(ICHTP=1)} CALL W3FI04(IENDN,ICHTP,LW) PRINT 2213, LW, ICHTP, IENDN 2213 FORMAT(/' ---> W3UNPKB7: 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(' *** W3UNPKB7 ERROR: CHARACTERS ON THIS MACHINE ', $ 'ARE NEITHER ASCII NOR EBCDIC - STOP 22'/) CALL ERREXIT(22) END IF IDAT10 = 1000000*IDATE(1)+10000*IDATE(2)+100*IDATE(3)+IDATE(4) SKIP_CAT12 = IDAT10.GE.2013022512 C----------------------------------------------------------------------- END IF IF(LUNIT.NE.LUNITL) THEN C----------------------------------------------------------------------- C IF THE INPUT DATA UNIT NUMBER ARGUMENT IS DIFFERENT THAN THE LAST TIME C THIS SUBR. WAS CALLED, PRINT NEW HEADER, SET JRET = 1 LUNITL = LUNIT JRET = 1 PRINT 101, LUNIT 101 FORMAT(//' ---> W3UNPKB7: WCOSS VERSION 01/06/2020: NCEP ', $ 'BUFR DATA SET READ FROM UNIT ',I4/) BMISS = GETBMISS() print'(1X)' print'(" BUFRLIB value for missing passed into W3UNPKB7 is: ", $ G0)', bmiss print'(1X)' IF(IPRINT.GE.1) THEN print *, 'IDATS= ',IDATS print *, 'ILVLMX_04= ',ILVLMX_04 print *, 'ILVLMX_08= ',ILVLMX_08 print *, 'ILVL_10 = ',ILVL_10 print *, 'ILVLMX_11= ',ILVLMX_11 print *, 'ILVLMX_12= ',ILVLMX_12 print *, 'ILVLMX_13= ',ILVLMX_13 print *, 'ILVL_14 = ',ILVL_14 print *, 'ILVLMX_15= ',ILVLMX_15 print *, 'IDMAX_VAD= ',IDMAX_VAD print *, 'IDMAX_PROF= ',IDMAX_PROF print *, 'IDMAX_SCAT= ',IDMAX_SCAT print *, 'IDMAX_GOES= ',IDMAX_GOES print *, 'IDMAX_GPS= ',IDMAX_GPS print *, 'IDMAX_RASS= ',IDMAX_RASS print *, 'IDMAX= ',IDMAX END IF 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 C TEST THAT THE DATA SET IS NOT-NULL AND THAT IT IS BUFR C GET CENTER TIME, DUMP TIME, AND DATA SET NAME FOR RETURN C OPEN BUFR DATA SET C SET INDEX=0, FORCES THE NEXT CALL TO THIS SUBROUTINE TO C READ IN A BUFR MESSAGE BEFORE ANY REPORTS ARE DECODED) C SET-UP TO DETERMINE IF BUFR MESSAGE IS WITHIN REQUESTED DATES C RETURN WITH IRET = 1 (NO REPORTS RETURNED UNTIL NEXT CALL) C----------------------------------------------------------------------- CALL CLOSBF(LUNIT) REWIND LUNIT READ(LUNIT,END=9999,ERR=8888,FMT='(A8)') CBUFR IF(CBUFR(1:4).EQ.'BUFR') THEN C COME HERE IF UNBLOCKED BUFR FILE IS INPUT PRINT'(" W3UNPKB7 - INPUT FILE ON UNIT ",I0, " IS", $ " UNBLOCKED NCEP BUFR"/)', LUNIT ELSE IF(CBUFR(5:8).EQ.'BUFR') THEN C COME HERE IF BLOCKED BUFR FILE IS INPUT PRINT'(" W3UNPKB7 - INPUT FILE ON UNIT ",I0, " IS", $ " BLOCKED NCEP BUFR"/)', LUNIT ELSE C COME HERE IF NON-BUFR FILE IS INPUT - RETURN WITH IRET = 2 PRINT 8764, LUNIT 8764 FORMAT(' *** W3UNPKB7 ERROR: INPUT FILE ON UNIT ',I2,' IS ', $ 'NOT BUFR -- ALL DONE WITH THIS FILE (IRET = 2)') GO TO 9998 END IF CALL DATELEN(10) CALL DUMPBF(LUNIT,ICDATE,IDDATE) print'(" CENTER DATE (ICDATE) = ",5(I0,1X))', icdate print'(" DUMP DATE (IDDATE) = ",5(I0,1X))', iddate IF(ICDATE(1).LE.0) THEN C COME HERE IF CENTER DATE COULD NOT BE READ FROM FIRST DUMMY MESSAGE C - RETURN WITH IRET = 2 PRINT'(" *** W3UNPKB7 ERROR: CENTER DATE COULD NOT BE ", $ "OBTAINED FROM INPUT FILE ON UNIT ",I0)', 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 = 2 PRINT'(" *** W3UNPKB7 ERROR: DUMP DATE COULD NOT BE ", $ "OBTAINED FROM INPUT FILE ON UNIT ",I0)', 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'(" ##W3UNPKB7 - THE FOLLOWING SHOULD NEVER ", $ "HAPPEN!!!!!")' PRINT'(" ##W3UNPKB7 - 2-DIGIT YEAR IN ICDATE(1) RETURNED ", $ "FROM DUMPBF (ICDATE IS: ",I5,4I3.2,") - USE WINDOWING ", $ "TECHNIQUE TO OBTAIN 4-DIGIT YEAR")', ICDATE C IF ICDATE=41~99 THEN ICDATE=1941~1999 C IF ICDATE=00~40 THEN ICDATE=2000~2040 IF(ICDATE(1).GT.40) THEN ICDATE(1) = 1900 + ICDATE(1) ELSE ICDATE(1) = 2000 + ICDATE(1) ENDIF PRINT'(" ##W3UNPKB7 - CORRECTED ICDATE(1) WITH 4-DIGIT ", $ "YEAR, ICDATE NOW IS: ",I5,4I3.2)', ICDATE ENDIF IDSDAT = ICDATE(1)*1000000+ICDATE(2)*10000+ICDATE(3)*100+ $ ICDATE(4) 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'(" ##W3UNPKB7 - THE FOLLOWING SHOULD NEVER ", $ "HAPPEN!!!!!")' PRINT'(" ##W3UNPKB7 - 2-DIGIT YEAR IN IDDATE(1) RETURNED ", $ "FROM DUMPBF (IDDATE IS: ",I5,4I3.2,") - USE WINDOWING ", $ "TECHNIQUE TO OBTAIN 4-DIGIT YEAR")', IDDATE C IF IDDATE=41~99 THEN IDDATE=1941~1999 C IF IDDATE=00~40 THEN IDDATE=2000~2040 IF(IDDATE(1).GT.40) THEN IDDATE(1) = 1900 + IDDATE(1) ELSE IDDATE(1) = 2000 + IDDATE(1) ENDIF PRINT'(" ##W3UNPKB7 - CORRECTED IDDATE(1) WITH 4-DIGIT ", $ "YEAR, IDDATE NOW IS: ",I5,4I3.2)', IDDATE END IF IDDATE_8 = IDDATE IDSDMP_8 = IDDATE_8(1)*100000000+IDDATE_8(2)*1000000+ $ IDDATE_8(3)*10000+IDDATE_8(4)*100+IDDATE_8(5) 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'/) c....................................................................... C This next call, I believe, is needed only because SUBSET is not C returned in DUMPBF and we need it in order to return dsname - C after dsname is retrieved then close and reopen data set .. call readmg(lunit,subset,ibdate,kret) if(subset.eq.'NC002007' .or. subset.eq.'NC002009' .or. $ subset.eq.'NC002011' .or. subset.eq.'NC002013' .or. $ subset.eq.'NC002014' ) then dsname = 'PROFLR ' else if(subset.eq.'NC002008' .or. subset.EQ.'NC002017' .or. $ subset.EQ.'NC002018' ) then dsname = 'VADWND ' else if(subset.EQ.'NC003001' .or. subset.EQ.'NC003002') then dsname = 'GOESND ' else if(subset.EQ.'NC003003') then dsname = 'GOESFV ' else if(subset.EQ.'NC012008') then dsname = 'ERS1DA ' else if(subset.EQ.'NC012137') then dsname = 'QKSWND ' else if(subset.EQ.'NC012003' .or. subset.EQ.'NC012004') then dsname = 'GPSIPW ' else if(subset.EQ.'NC002012') then dsname = 'RASSDA ' else if(subset.EQ.'NC012138' .or. subset.EQ.'NC012139') then dsname = 'WDSATR ' else if(subset.EQ.'NC012122') then dsname = 'ASCATW ' else dsname = '????????' end if call closbf(lunit) call openbf(lunit,'IN',lunit) ccccc CALL OPENBF(0,'QUIET',1) ! will generate diagnostic print if ccccc ! an embedded BUFR table is read c....................................................................... INDEX = 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'/) IF(IHE.LE.-3.AND.IHL.GE.2) THEN KTIMCH = 0 PRINT 6998 6998 FORMAT(/' --> W3UNPKB7: THERE IS NO TIME WINDOW CONSTRAINT FOR ', $ 'ACCEPTING BUFR MESSAGES'/) KDATE = 0 LDATE = 0 ELSE KTIMCH = 1 RINC_I = 0. RINC_I(2) = REAL(IHE) C DETERMINE EARLIEST DATE FOR ACCEPTING BUFR MESSAGES FOR DECODING CALL W3MOVDAT(RINC_I,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 RINC_I = 0. RINC_I(3) = XMINL CALL W3MOVDAT(RINC_I,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_O) IF(RINC_O(3).LT.0) THEN PRINT 104 104 FORMAT(' *** W3UNPKB7 ERROR: DATES SPECIFIED INCORRECTLY - STOP ', $ '15'/) CALL ERREXIT(15) END IF NPRINT = 0 END IF IRET = 1 GO TO 99 C----------------------------------------------------------------------- END IF C SUBR. UNPKB701 RETURNS A SINGLE DECODED REPORT FROM BUFR MESSAGE CALL UNPKB701(LUNIT,ITP,SUBSET,SUBSKP,IRET) IF(IRET.EQ.2) THEN C IRET=2 MEANS ALL DATA HAVE BEEN DECODED FOR SPECIFIED TIME PERIOD C (REWIND DATA FILE AND RETURN W/ IRET=2) REWIND LUNIT IF(ITP.EQ.4) THEN IF(MAX(IFOV(1,1),IFOV(2,1),IFOV(3,1),IFOV(4,1)).GT.0) THEN PRINT 8101, (IFOV(III,1),III=1,4) 8101 FORMAT(/' ---> W3UNPKB7: SUMMARY OF GOES 5X5 REPORT COUNTS ', $ 'GROUPED BY F-O-V NO. (PRIOR TO ANY FILTERING BY CALLING ', $ 'PROGRAM)'/15X, $ '# WITH F-O-V NO. 00 TO 02:',I8,' - GET "BAD" Q.MARK'/15X, $ '# WITH F-O-V NO. 03 TO 09:',I8,' - GET "SUSPECT" Q.MARK'/15X, $ '# WITH F-O-V NO. 10 TO 25:',I8,' - GET "NEUTRAL" Q.MARK'/15X, $ '# WITH MISSING F-O-V: ',I8,' - GET "NEUTRAL" Q.MARK'/20X, $ '(NOTE: RADIANCES ALWAYS HAVE NEUTRAL Q.MARK REGARDLESS OF FOV ', $ 'NUMBER)'/) END IF IF(MAX(IFOV(1,2),IFOV(2,2),IFOV(3,2),IFOV(4,2)).GT.0) THEN PRINT 8201, (IFOV(III,2),III=1,4) 8201 FORMAT(/' ---> W3UNPKB7: SUMMARY OF GOES 1X1 REPORT COUNTS ', $ 'GROUPED BY F-O-V NO. (PRIOR TO ANY FILTERING BY CALLING ', $ 'PROGRAM)'/15X,'(ALL GET "NEUTRAL" Q. MARK)'/15X, $ '# WITH F-O-V NO. 01: ',I8/15X, $ '# WITH F-O-V NO. 02: ',I8/15X, $ '# WITH F-O-V NO. 03: ',I8/15X, $ '# WITH F-O-V > 3 (INCL. MISSING):',I8,/20X, $ '(NOTE: RADIANCES ALWAYS HAVE NEUTRAL Q.MARK REGARDLESS OF FOV ', $ 'NUMBER)'/) END IF PRINT 8102 8102 FORMAT(/' ---> W3UNPKB7: 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,' : ',I8) IF(KNTSAT(260).GT.0) PRINT 8104, KNTSAT(260) 8104 FORMAT(15X,'NUMBER FROM UNKNOWN SAT. ID:',I8) PRINT 8105 8105 FORMAT(/) END IF GO TO 99 ELSE IF(IRET.EQ.8) THEN GO TO 99 END IF C INITIALIZE THE OUTPUT ARRAY CALL UNPKB702(RDATA,STNID,ITP) C STORE THE HEADER INFORMATION INTO UNPACKED QUASI-IW3UNPBF FORMAT rdata8_8 = bmiss CALL UNPKB703(LUNIT,RDATA,rdata8_8,STNID,SUBSET,ITP,IRET) C IRET.GE.3 MEANS RPT NOT RETURNED DUE TO MISSING DATA IN HEADR (RETURN) IF(IRET.GE.3) GO TO 99 IF(ITP.EQ.1.OR.ITP.EQ.2.OR.ITP.EQ.3.OR.ITP.EQ.14) THEN C----------------------------------------------------------------------- C THE FOLLOWING PERTAINS TO WIND PROFILER REPORTS NOT ORIGINATING C FROM PILOT (PIBAL) FORMAT BULLETINS) C----------------------------------------------------------------------- C STORE THE SURFACE DATA INTO UNPACKED QUASI-IW3UNPBF FORMAT (CAT. 10) CALL UNPKB704(LUNIT,RDATA,ITP,IRET) C STORE THE UPPER-AIR DATA INTO UNPACKED QUASI-IW3UNPBF FORMAT (CAT. 11) CALL UNPKB705(LUNIT,RDATA,ITP) RDATX(1:IDMAX) = RDATA(1:IDMAX) IF(IDATA(35)+IDATA(37).EQ.0) THEN IRET = 5 GO TO 99 END IF C STORE BUFR DATA DIRECTLY INTO RDATA2 ARRAY RDATA2_8 = BMISS CALL UFBINT(LUNIT,RDATA2_8(1),1,1,NLEV,'TSIG') IF(NLEV.GT.1) THEN IRET = 7 GO TO 99 END IF CALL UFBINT(LUNIT,RDATA2_8(5),2,1,NLEV,'NPSM TPSE') IF(NLEV.GT.1) THEN IRET = 7 GO TO 99 END IF C For NPN and CAP wind profilers prior to 5/2002, AVERAGING TIME is C decoded in minutes, after 5/2002 it is decoded in seconds (in either C case it is stored in minutes) IF(IBFMS(RDATA2_8(6)).EQ.0) THEN RDATA2_8(6) = NINT(RDATA2_8(6)/60.) ELSE CALL UFBINT(LUNIT,RDATA2_8(6),1,1,NLEV,'TPMI') IF(NLEV.GT.1) THEN IRET = 7 GO TO 99 END IF END IF RDATA2 = RDATA2_8 ELSE IF(ITP.EQ.4) THEN C----------------------------------------------------------------------- C THE FOLLOWING PERTAINS TO GOES SOUNDING/RADIANCE REPORTS C----------------------------------------------------------------------- C STORE BUFR DATA DIRECTLY INTO RDATA2 ARRAY RDATA2_8 = BMISS CALL UFBINT(LUNIT,RDATA2_8(2),1,1,NLEV,'ACAV') IF(NLEV.GT.1) THEN IRET = 7 GO TO 99 END IF CALL UFBINT(LUNIT,RDATA2_8(7),1,1,NLEV,'QMRK') IF(NLEV.GT.1) THEN IRET = 7 GO TO 99 END IF RDATA2 = RDATA2_8 C STORE THE UPPER-AIR DATA/RADIANCES/RETRIEVALS INTO UNPACKED QUASI- C IW3UNPBF FORMAT (CATEGORY 12, 13, 08) CALL UNPKB707(LUNIT,RDATA,RDATA2,subset,IRET) IF(IRET.GE.5) THEN RDATA2 = BMISS GO TO 99 END IF ELSE IF(ITP.EQ.5 .OR. ITP.EQ.12 .OR. ITP.EQ.13) THEN C----------------------------------------------------------------------- C THE FOLLOWING PERTAINS TO NEXRAD (VAD) WIND REPORTS C ITP = 5 - VAD WINDS FROM RADAR CODED MESSAGE C ITP = 12 - VAD WINDS FROM LEVEL 2 DECODER C ITP = 13 - VAD WINDS FROM EUROPE, NEW ZEALAND C----------------------------------------------------------------------- C STORE THE UPPER-AIR DATA INTO UNPACKED QUASI-IW3UNPBF FORMAT (CAT. 4) CALL UNPKB706(LUNIT,RDATA,ITP,IRET) ELSE IF(ITP.EQ.6) THEN C----------------------------------------------------------------------- C THE FOLLOWING PERTAINS TO ERS SCATTEROMETER WIND REPORTS C----------------------------------------------------------------------- C STORE THE SURFACE DATA INTO UNPACKED QUASI-IW3UNPBF FORMAT (CAT. 10) CALL UNPKB704(LUNIT,RDATA,ITP,IRET) ELSE IF(ITP.EQ.7) THEN C----------------------------------------------------------------------- C THE FOLLOWING PERTAINS TO QUIKSCAT SCATTEROMETER WIND REPORTS C----------------------------------------------------------------------- C STORE THE SURFACE DATA INTO UNPACKED QUASI-IW3UNPBF FORMAT (CAT. 10) CALL UNPKB704(LUNIT,RDATA,ITP,IRET) IF(IRET.GE.5) GO TO 99 C STORE BUFR DATA DIRECTLY INTO RDATA2 ARRAY RDATA2_8 = BMISS CALL UFBINT(LUNIT,RDATA2_8(2),1,1,NLEV,'ACAV') IF(NLEV.GT.1) THEN IRET = 7 GO TO 99 END IF CALL UFBINT(LUNIT,RDATA2_8(3),2,1,NLEV,'CTCN ATRN') IF(NLEV.GT.1) THEN IRET = 7 GO TO 99 END IF CALL UFBINT(LUNIT,RDATA2_8(8),1,1,NLEV,'SPRR') IF(NLEV.GT.1) THEN IRET = 7 GO TO 99 END IF RDATA2 = RDATA2_8 ELSE IF(ITP.EQ.8) THEN C----------------------------------------------------------------------- C THE FOLLOWING PERTAINS TO GPS INTEGRATED PRECIPITABLE WATER REPORTS C----------------------------------------------------------------------- C STORE THE GPS-IPW DATA INTO UNPACKED QUASI-IW3UNPBF FORMAT (CAT. 14) CALL UNPKB709(LUNIT,RDATA,subset) RDATX(1:IDMAX) = RDATA(1:IDMAX) IF(IDATA(43).EQ.0) THEN IRET = 5 GO TO 99 END IF ELSE IF(ITP.EQ.9) THEN C----------------------------------------------------------------------- C THE FOLLOWING PERTAINS TO NPN AND CAP RASS REPORTS C----------------------------------------------------------------------- C STORE THE RASS DATA INTO UNPACKED QUASI-IW3UNPBF FORMAT (CAT. 15) CALL UNPKB710(LUNIT,RDATA) RDATX(1:IDMAX) = RDATA(1:IDMAX) IF(IDATA(45).EQ.0) THEN IRET = 5 GO TO 99 END IF C STORE BUFR DATA DIRECTLY INTO RDATA2 ARRAY RDATA2_8 = BMISS CALL UFBINT(LUNIT,RDATA2_8(1),1,1,NLEV,'TSIG') IF(NLEV.GT.1) THEN IRET = 7 GO TO 99 END IF CALL UFBINT(LUNIT,RDATA2_8(6),1,1,NLEV,'TPSE') IF(NLEV.GT.1) THEN IRET = 7 GO TO 99 END IF C For NPN and CAP RASS prior to 5/2002, AVERAGING TIME is decoded in C minutes, after 5/2002 it is decoded in seconds (in either case it is C stored in minutes) IF(IBFMS(RDATA2_8(6)).EQ.0) THEN RDATA2_8(6) = NINT(RDATA2_8(6)/60.) ELSE CALL UFBINT(LUNIT,RDATA2_8(6),1,1,NLEV,'TPMI') IF(NLEV.GT.1) THEN IRET = 7 GO TO 99 END IF END IF RDATA2 = RDATA2_8 ELSE IF(ITP.EQ.10) THEN C----------------------------------------------------------------------- C THE FOLLOWING PERTAINS TO WINDSAT SCATTEROMETER WIND REPORTS C (NAVY OR NESDIS) C----------------------------------------------------------------------- C STORE THE SURFACE DATA INTO UNPACKED QUASI-IW3UNPBF FORMAT (CAT. 10) CALL UNPKB704(LUNIT,RDATA,ITP,IRET) IF(IRET.GE.5) GO TO 99 C STORE BUFR DATA DIRECTLY INTO RDATA2 ARRAY RDATA2_8 = BMISS CALL UFBINT(LUNIT,RDATA2_8(2), 1,1,NLEV,'ACAV') IF(NLEV.GT.1) THEN IRET = 7 GO TO 99 END IF CALL UFBINT(LUNIT,RDATA2_8(9), 6,1,NLEV, $ 'SST1 MRWVC MRLWC WSST MWD10 MWS10') IF(NLEV.GT.1) THEN IRET = 7 GO TO 99 END IF CALL UFBINT(LUNIT,RDATA2_8(15),7,1,NLEV, $ 'WSEQC1 CHSQ PHER SPDE SSTE CLDE VPRE') IF(NLEV.GT.1) THEN IRET = 7 GO TO 99 END IF RDATA2 = RDATA2_8 ELSE IF(ITP.EQ.11) THEN C----------------------------------------------------------------------- C THE FOLLOWING PERTAINS TO ASCAT SCATTEROMETER WIND REPORTS C----------------------------------------------------------------------- C STORE THE SURFACE DATA INTO UNPACKED QUASI-IW3UNPBF FORMAT (CAT. 10) CALL UNPKB704(LUNIT,RDATA,ITP,IRET) IF(IRET.GE.5) GO TO 99 C STORE BUFR DATA DIRECTLY INTO RDATA2 ARRAY RDATA2_8 = BMISS CALL UFBINT(LUNIT,RDATA2_8(2),1,1,NLEV,'ACAV') IF(NLEV.GT.1) THEN IRET = 7 GO TO 99 END IF CALL UFBINT(LUNIT,RDATA2_8(3),1,1,NLEV,'CTCN') IF(NLEV.GT.1) THEN IRET = 7 GO TO 99 END IF CALL UFBINT(LUNIT,RDATA2_8(22),3,1,NLEV,'WVCQ BSCD LKCS') IF(NLEV.GT.1) THEN IRET = 7 GO TO 99 END IF RDATA2 = RDATA2_8 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----------------------------------------------------------------------- 8888 CONTINUE C COME HERE IF ERROR READING 1ST RECORD OF INPUT FILE- RETURN W/ IRET= 2 PRINT 7765, LUNIT 7765 FORMAT(' *** W3UNPKB7 ERROR: ERROR READING FIRST RECORD OF INPUT', $ ' FILE ON UNIT ',I2,' -- ALL DONE WITH THIS FILE (IRET = 2)') GO TO 9998 C----------------------------------------------------------------------- 9999 CONTINUE C COME HERE IF NULL FILE IS INPUT - RETURN WITH IRET = 2 PRINT 8765, LUNIT 8765 FORMAT(' *** W3UNPKB7 ERROR: INPUT FILE ON UNIT ',I2,' IS ', $ 'EMPTY (NULL) -- ALL DONE WITH THIS FILE (IRET = 2)') C----------------------------------------------------------------------- 9998 CONTINUE REWIND LUNIT IRET = 2 LSDATE = IDATE LSHE = IHE LSHL = IHL RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UNPKB701 C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2014-03-13 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 1999-02-12 D. A. KEYSER NP22-- ADDED ERS SCATTEROMETER WINDS HERE C NOW THAT THEY ARE PACKED IN A NCEP BUFR FILE C 2000-09-22 D. A. KEYSER NP22-- ADDED QUIKSCAT SCATTEROMETER WINDS C HERE NOW THAT THEY ARE PACKED IN A NCEP BUFR FILE C 2002-07-03 D. A. KEYSER NP22 -- ADDED PROCESSING OF GPS-IPW REPORTS C HERE NOW THAT THEY ARE PACKED IN AN NCEP BUFR FILE (GPSIPW - C RETURNED IN NEW CATEGORY 14) C 2004-02-02 D. A. KEYSER -- ADDED NEW INPUT "SUBSKP" - SEE C DESCRIPTION BELOW C 2006-07-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM BUFR_LISTDUMPS): C 2007-09-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM PREPOBS_PREPDATA): C MODIFIED TO HANDLE NAVY WINDSAT SCATTEROMETER WINDS (READ FROM C MESSAGE TYPE NC012138) C 2007-09-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM BUFR_LISTDUMPS): C 2007-09-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM PREPOBS_PREPDATA): C MODIFIED TO HANDLE NESDIS WINDSAT SCATTEROMETER WINDS (READ FROM C MESSAGE TYPE NC012139), PROCESSING IS IDENTICAL TO NAVY WINDSAT C SCATTEROMETER WINDS; HANDLES GOES 1x1 F-O-V SNDGS RADIANCES IN C SUBSET "NC003003" C 2008-09-25 D. A. KEYSER -- ADDED ASCAT SCATTEROMETER WINDS HERE NOW C THAT THEY ARE PACKED IN A NCEP BUFR FILE C 2014-03-13 D. A. KEYSER -- MODIFIED TO HANDLE VAD WINDS FROM LEVEL C 2 DECODER (SUBSET "NC002017") {IN ADDITION TO THOSE FROM RADAR C CODED MESSAGE (SUBSET "NC002008")} C 2020-08-20 J. DONG -- ADDED HONG KONG PROFILER WINDS (NC002014) AND C VAD WINDS FROM EUROPE AND NEW ZEALAND (NC002018) C C USAGE: CALL UNPKB701(LUNIT,ITP,SUBSET,SUBSKP,IRET) C INPUT ARGUMENT LIST: C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE C SUBSKP - TWO-DIMENSIONAL LOGICAL ARRAY WHERE ELEMENT 1 REFERS C - TO A PARTICULAR BUFR TYPE (RANGE 0-255) AND ELEMENT 2 C - REFERS TO A PARTICULAR BUFR SUBTYPE (RANGE 0-200). IF C - SUBSKP IS SET TO TRUE FOR A PARTICULAR BUFR TYPE AND C - SUBTYPE, THEN ANY BUFR MESSAGE OF THIS TYPE READ IN C - WILL BE SKIPPED OVER {NO SUBSETS (REPORTS) WILL BE C - DECODED OUT OF IT AND RETURNED TO THE CALLING PROGRAM, C - INSTEAD THIS SUBROUTINE WILL MOVE ON TO READ THE NEXT C - BUFR MESSAGE IN THE FILE AND AGAIN USE SUBSKP TO SEE C - IF ANY SUBSETS SHOULD BE DECODED OUT OF IT}. THIS C - ALLOWS THIS SUBROUTINE TO QUICKLY PASS BY ANY BUFR C - MESSAGES WITH A TYPE/SUBTYPE THAT THE CALLING PROGRAM C - DOES NOT WANT DECODED. THE LENGTH OF THIS ARRAY C - SHOULD ALWAYS BE HARDWIRED TO (0:255,0:200). C C OUTPUT ARGUMENT LIST: C ITP - THE TYPE OF REPORT THAT HAS BEEN DECODED {=1 - NPN C - WIND PROFILER, =2 - CAP WIND PROFILER, =3 - JMA WIND C - PROFILER, =4 - GOES SNDG, =5 - NEXRAD (VAD) WIND FROM C - RADAR CODED MESSAGE; =6 - ERS SCATTEROMETER WIND, =7 - C - QUIKSCAT SCATTEROMETER WIND, =8 - GPS-IPW, =9 - NPN C - or CAP RASS, =10 - WINDSAT SCATTEROMETER WIND (NAVY OR C - NESDIS), =11 - ASCAT SCATTEROMETER WIND, =12 - NEXRAD C - (VAD) WIND FROM LEVEL 2 DECODER, =13 - NON-NEXRAD (VAD) C - WIND FROM OTHER COUNTRIES (EUROPE, NEW ZEALAND), C - =14 - WIND PROFILER FROM HONG KONG} C SUBSET - CHARACTER*8 BUFR MESSAGE TYPE (SAME FOR ALL REPORTS C - IN A COMMON BUFR MESSAGE) C IRET - RETURN CODE AS DESCRIBED IN W3UNPKB7 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 W3UNPKB7. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ SUBROUTINE UNPKB701(LUNIT,ITP,SUBSET,SUBSKP,IRET) CHARACTER*8 SUBSET,SUBSET_LAST INTEGER MDATE(4),NDATE(8) LOGICAL SUBSKP(0:255,0:200),SKIP_CAT12 DIMENSION RINC_O(5) COMMON /PKB7BB/KDATE(8),LDATE(8),KTIMCH,IPRINT,SKIP_CAT12 COMMON /PKB7CC/INDEX COMMON /PKB7DD/LSHE,LSHL,ICDATE(5),IDDATE(5) COMMON /PKB7HH/NPRINT(0:255,0:200) SAVE DATA IREC/0/,JREC/0/,SUBSET_LAST/'xxxxxxxx'/ 10 CONTINUE C======================================================================= IF(INDEX.EQ.0) THEN C READ IN NEXT BUFR MESSAGE CALL READMG(LUNIT,SUBSET,IBDATE,KRET) IF(KRET.NE.0) THEN C----------------------------------------------------------------------- PRINT 101 101 FORMAT(' ---> W3UNPKB7: ALL BUFR MESSAGES READ IN AND DECODED'/) IRET = 2 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'(" ##W3UNPKB7/UNPKB701 - A 10-DIGIT SECT. 1 BUFR ", $ "MESSAGE DATE WAS NOT RETURNED IN UNIT ",I0," - PROBLEM ", $ "WITH BUFR FILE - IRET = 2")', LUNIT IRET = 2 RETURN END IF IF(SUBSET.NE.SUBSET_LAST) THEN JREC = 0 SUBSET_LAST = SUBSET END IF CALL UFBCNT(LUNIT,IREC,ISUB) JREC = JREC + 1 MDATE(1) = IBDATE/1000000 MDATE(2) = MOD((IBDATE/10000),100) MDATE(3) = MOD((IBDATE/100),100) MDATE(4) = MOD(IBDATE,100) 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 NOAA ", $ "PROFILER NETWORK WIND REPORTS")' ITP = 1 ELSE IF(SUBSET.EQ.'NC002011') THEN IF(IPRINT.GE.1) PRINT'(" THIS MESSAGE CONTAINS ", $ "COOPERATIVE AGENCY PROFILER WIND REPORTS")' ITP = 2 ELSE IF(SUBSET.EQ.'NC002013') THEN IF(IPRINT.GE.1) PRINT'(" THIS MESSAGE CONTAINS JAPANESE ", $ "METEOROLOGICAL AGENCY PROFILER WIND REPORTS")' ITP = 3 ELSE IF(SUBSET.EQ.'NC002014') THEN IF(IPRINT.GE.1) PRINT'(" THIS MESSAGE CONTAINS OTHER ", $ "(e.g., HONG KONG) PROFILER WIND REPORTS")' ITP = 14 ELSE IF(SUBSET.EQ.'NC002008') THEN IF(IPRINT.GE.1) PRINT'(" THIS MESSAGE CONTAINS NEXRAD ", $ "(VAD) WIND REPORTS FROM RADAR CODED MESSAGE")' ITP = 5 ELSE IF(SUBSET.EQ.'NC002017') THEN IF(IPRINT.GE.1) PRINT'(" THIS MESSAGE CONTAINS NEXRAD ", $ "(VAD) WIND REPORTS FROM LEVEL 2 DECODER")' ITP = 12 ELSE IF(SUBSET.EQ.'NC002018') THEN IF(IPRINT.GE.1) PRINT'(" THIS MESSAGE CONTAINS NEXRAD ", $ "(VAD) WIND REPORTS FROM EUROPE AND NEW ZEALAND")' ITP = 13 ELSE IF(SUBSET.EQ.'NC003001' .or. SUBSET.EQ.'NC003002' .or. $ SUBSET.EQ.'NC003003') THEN IF(IPRINT.GE.1) PRINT'(" THIS MESSAGE CONTAINS GOES ", $ "SOUNDING/RADIANCE REPORTS")' ITP = 4 ELSE IF(SUBSET.EQ.'NC012008') THEN IF(IPRINT.GE.1) PRINT'(" THIS MESSAGE CONTAINS ERS ", $ "SCATTEROMETER WIND REPORTS")' ITP = 6 ELSE IF(SUBSET.EQ.'NC012137') THEN IF(IPRINT.GE.1) PRINT'(" THIS MESSAGE CONTAINS QUIKSCAT ", $ "SCATTEROMETER WIND REPORTS")' ITP = 7 ELSE IF(SUBSET.EQ.'NC002009') THEN PRINT 217 217 FORMAT(/'##W3UNPKB7: THIS MESSAGE CONTAINS WIND PROFILER ', $ 'REPORTS ORIGINATING FROM PILOT (PIBAL) BULLETINS - IRET = 8'/) IRET = 8 RETURN ELSE IF(SUBSET.EQ.'NC012003' .OR. SUBSET.EQ.'NC012004') then IF(IPRINT.GE.1) PRINT'(" THIS MESSAGE CONTAINS GPS-IPW ", $ "REPORTS")' ITP = 8 ELSE IF(SUBSET.EQ.'NC002012') THEN IF(IPRINT.GE.1) PRINT'(" THIS MESSAGE CONTAINS NOAA ", $ "PROFILER NETWORK AND COOPERATIVE AGENCY RASS TEMPERATURE", $ " REPORTS")' ITP = 9 ELSE IF(SUBSET.EQ.'NC012138' .OR. SUBSET.EQ.'NC012139') THEN IF(IPRINT.GE.1) PRINT'(" THIS MESSAGE CONTAINS WINDSAT ", $ "SCATTEROMETER WIND REPORTS FROM THE NAVY OR NESDIS")' ITP = 10 ELSE IF(SUBSET.EQ.'NC012122') THEN IF(IPRINT.GE.1) PRINT'(" THIS MESSAGE CONTAINS ASCAT ", $ "SCATTEROMETER WIND REPORTS")' ITP = 11 ELSE PRINT 107, IREC,SUBSET 107 FORMAT(' *** W3UNPKB7 WARNING: BUFR MESSAGE NO.',I3,' CONTAINS ', $ 'REPORTS THAT CANNOT BE DECODED (SUBSET = ',A8,'), TRY READING ', $ 'NEXT MSG'/) INDEX = 0 GO TO 10 END IF JSUB = NMSUB(LUNIT) READ(SUBSET(3:5),'(I3)') IINDEX READ(SUBSET(6:8),'(I3)') JINDEX IF(IINDEX.LE.255 .AND. JINDEX.LE.200) THEN IF(SUBSKP(IINDEX,JINDEX)) THEN IF(JSUB.GT.0.AND.NPRINT(IINDEX,JINDEX).EQ.0) THEN C There may be messages with no reports present (e.g., the center time C and dump time messages which may be present even if no reports are C present in subsequent messages), so key on the FIRST message of C this type/subtype with reports present for the diagnostic print PRINT 1234, SUBSET 1234 FORMAT(/' ---> W3UNPKB7: BUFR MESSAGE WITH TABLE ENTRY "',A8, $ '" (AND CONTAINING SUBSETS) READ - ALL MESSAGES WITH THIS BUFR ', $ 'TYPE/SUBTYPE'/20X,'ARE SKIPPED AS DIRECTED BY CALLING PROGRAM'/) NPRINT(IINDEX,JINDEX) = 1 END IF INDEX = 0 GO TO 10 END IF END IF IF(KTIMCH.EQ.1) THEN C CHECK DATE OF MESSAGE AGAINST SPEC. TIME RANGES IF DOING TIME CHECK C ALL NCEP BUFR 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 CALL W3DIFDAT(KDATE,NDATE,3,RINC_O) KMIN = RINC_O(3) CALL W3DIFDAT(LDATE,NDATE,3,RINC_O) LMIN = RINC_O(3) 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 END IF C======================================================================= C READ NEXT SUBSET (REPORT) IN MESSAGE IF(IPRINT.GT.1) PRINT'(" CALL READSB")' CALL READSB(LUNIT,KRET) IF(IPRINT.GT.1) PRINT'(" BACK FROM READSB")' IF(KRET.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(JREC.EQ.1) THEN PRINT 4567, IREC,ICDATE,SUBSET 4567 FORMAT(/'===> BUFR MESSAGE NO. ',I4,' IS A DUMMY CONTAINING ONLY', $ ' CENTER DATE (',I4,4I3.2,') FOR MSG TYPE ',A8,' - GO ON TO ', $ 'NEXT MESSAGE'/) ELSE IF(JREC.EQ.2) THEN PRINT 4568, IREC,IDDATE,SUBSET 4568 FORMAT(/'===> BUFR MESSAGE NO. ',I4,' IS A DUMMY CONTAINING ONLY', $ ' DUMP DATE (',I4,4I3.2,') FOR MSG TYPE ',A8,' - 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 ",I0)', INDEX RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UNPKB702 C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2014-03-13 C C ABSTRACT: INITIALIZES THE OUTPUT ARRAY WHICH HOLDS A SINGLE REPORT C IN THE QUASI-IW3UNPBF UNPACKED FORMAT TO ALL MISSING. C C PROGRAM HISTORY LOG: C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR C 1999-02-12 D. A. KEYSER NP22-- ADDED ERS SCATTEROMETER WINDS HERE C NOW THAT THEY ARE PACKED IN A NCEP BUFR FILE C 2000-09-22 D. A. KEYSER NP22-- ADDED QUIKSCAT SCATTEROMETER WINDS C HERE NOW THAT THEY ARE PACKED IN A NCEP BUFR FILE C 2002-07-03 D. A. KEYSER NP22 -- ADDED PROCESSING OF GPS-IPW REPORTS C HERE NOW THAT THEY ARE PACKED IN AN NCEP BUFR FILE (GPSIPW - C RETURNED IN NEW CATEGORY 14) C 2004-02-02 D. A. KEYSER NP22 -- ADDED PROCESSING OF RASS REPORTS C HERE NOW THAT THEY ARE PACKED IN AN NCEP BUFR FILE (RASSDA - C RETURNED IN NEW DATA LEVEL CATEGORY 15) C 2008-09-25 D. A. KEYSER -- ADDED ASCAT SCATTEROMETER WINDS HERE NOW C THAT THEY ARE PACKED IN A NCEP BUFR FILE C 2014-03-13 D. A. KEYSER -- MODIFIED TO HANDLE VAD WINDS FROM LEVEL C 2 DECODER (SUBSET "NC002017") {IN ADDITION TO THOSE FROM RADAR C CODED MESSAGE (SUBSET "NC002008")}; PARAMETERIZED MAXIMUM NUMBER C OF LEVELS ALLOWED FOR EACH CATEGORY AND CALCULATED PARAMETER C "IDMAX" (SIZE OF OUTPUT "RDATA" ARRAY) BASED ON THESE, ALL ARE C NOW PLACED IN INCLUDE FILE 'inc_w3unpkb7.inc' {IN HERE, MAXIMUM C NUMBER OF CAT. 04 WINDS-BY-HEIGHT LEVELS (EXCLUDING FIRST, C SURFACE, LEVEL), "ILVLMX_04", INCREASED FROM 64 TO 254 TO ACCOUNT C FOR MORE LEVELS IN NEW VAD WINDS FROM LEVEL 2 DECODER, AND C MAXIMUM NUMBER OF CAT. 11 WIND PROFILER LEVELS (EXCLUDING FIRST, C SURFACE, LEVEL), "ILVLMX_11", INCREASED FROM 102 TO 200 TO C ACCOUNT FOR SOME MAP PROFILERS WITH MORE LEVELS THAN BEFORE, THE C RESULTING "IDMAX" IS NOW 2270, UP FROM 1200 BEFORE} C C USAGE: CALL UNPKB702(RDATA,STNID,ITP) C INPUT ARGUMENT LIST: C ITP - THE TYPE OF REPORT THAT HAS BEEN DECODED {=1 - NPN C - WIND PROFILER, =2 - CAP WIND PROFILER, =3 - JMA WIND C - PROFILER, =4 - GOES SNDG, =5 - NEXRAD (VAD) WIND FROM C - RADAR CODED MESSAGE; =6 - ERS SCATTEROMETER WIND, =7 - C - QUIKSCAT SCATTEROMETER WIND, =8 - GPS-IPW, =9 - NPN C - or CAP RASS, =10 - WINDSAT SCATTEROMETER WIND (NAVY OR C - NESDIS), =11 - ASCAT SCATTEROMETER WIND; =12 - NEXRAD C - (VAD) WIND FROM LEVEL 2 DECODER} C OUTPUT ARGUMENT LIST: C RDATA - SINGLE REPORT RETURNED AN A QUASI-IW3UNPBF C - UNPACKED FORMAT; ALL DATA ARE MISSING (NOTE: DOES NOT C - INCLUDE STATION ID) C STNID - CHARACTER*8 SINGLE REPORT STATION IDENTIFICATION (UP C - TO 8 CHARACTERS, LEFT-JUSTIFIED - HERE INITIALIZED AS C - "????????" FOR GOES SOUNDINGS, ERS SCATTEROMETER, C - QUIKSCAT SCATTEROMETER, WINDSAT SCATTEROMETER AND C - ASCAT SCATTEROMETER AND AS BLANKS FOR ALL OTHER TYPES) C C REMARKS: CALLED BY SUBROUTINE W3UNPKB7. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ SUBROUTINE UNPKB702(RDATA,STNID,ITP) C Include parameters common to more than one subroutine C ----------------------------------------------------- include 'inc_w3unpkb7.inc' REAL RDATA(*),RDATX(IDMAX) INTEGER IDATA(IDMAX) CHARACTER*8 STNID COMMON /PKB7GG/IDATS_04,IDATS_08,IDATS_10,IDATS_11,IDATS_12, $ IDATS_13,IDATS_14,IDATS_15 SAVE EQUIVALENCE (RDATX,IDATA) DATA XMISS/99999./,IMISS/99999/ IDATS_04 = 0 IDATS_08 = 0 IDATS_10 = 0 IDATS_11 = 0 IDATS_12 = 0 IDATS_13 = 0 IDATS_14 = 0 IDATS_15 = 0 RDATX(1) = XMISS RDATX(2) = XMISS RDATA(3) = XMISS RDATX(4) = XMISS IDATA(5) = 999999 IDATA(6) = 999999 RDATX(7) = XMISS IDATA(8) = IMISS IDATA(9) = IMISS IDATA(10) = IMISS RDATX(11) = XMISS RDATX(12) = XMISS STNID = ' ' C ALL TYPES -- LOAD ZEROS INTO THE DEFINING WORD PAIRS IDATA(13:IDATS-1) = 0 C ALL TYPES -- LOAD MISSINGS INTO THE DATA PORTION RDATX(IDATS:IDMAX) = XMISS IF(ITP.EQ.1.OR.ITP.EQ.2.OR.ITP.EQ.3.OR.ITP.EQ.14) THEN C WIND PROFILER -- LOAD INTEGER MISSING WHERE APPROPRIATE C {Current limit of "ILVLMX_11" Cat. 11 levels, not C counting first (surface) level} C (if this is expanded, "IDMAX" will increase) IDATS_10 = IDATS IDATS_11 = IDATS_10 + (ILVL_10 * 7) IDATA(IDATS_11+ 3:IDMAX:11) = IMISS IDATA(IDATS_11+ 5:IDMAX:11) = IMISS IDATA(IDATS_11+ 6:IDMAX:11) = IMISS IDATA(IDATS_11+10:IDMAX:11) = IMISS ELSE IF(ITP.EQ.4) THEN C GOES -- LOAD DEFAULT OF "????????" FOR STN. ID. STNID = '????????' C GOES -- LOAD DEFAULT OF 2.0 INTO CAT. 12 LEVEL QUALITY MARKERS C (Current limit of "ILVLMX_12" Cat. 12 levels) C (could be expanded somewhat w/o changing "IDMAX" if need be) IDATS_12 = IDATS RDATA(IDATS_12+6:IDATS_12+6+((ILVLMX_12-1)*9):9) = 2.0 RDATA(IDATS_12+7:IDATS_12+7+((ILVLMX_12-1)*9):9) = 2.0 RDATA(IDATS_12+8:IDATS_12+8+((ILVLMX_12-1)*9):9) = 2.0 C GOES -- LOAD DEFAULT OF 2.0 INTO FIRST CAT. 08 LEVEL QUALITY MARKER C (Current limit of "ILVLMX_08" Cat. 08 levels) C (could be expanded somewhat w/o changing "IDMAX" if need be C but source in w3unpkb7.f would have to be changed!!) IDATS_08 = IDATS_12 + (ILVLMX_12 * 9) RDATA(IDATS_08+2:IDATS_08+2+((ILVLMX_08-1)*4):4) = 2.0 C GOES -- LOAD INTEGER MISSING INTO CAT. 13 LEVEL CHANNEL NUMBER C -- LOAD DEFAULT OF 2.0 INTO CAT. 13 LEVEL QUALITY MARKER C (Current limit of "ILVLMX_13" Cat. 13 levels) C (could be expanded somewhat w/o changing "IDMAX" if need be) IDATS_13 = IDATS_08 + (ILVLMX_08 * 4) IDATA(IDATS_13+0:IDATS_13+0+((ILVLMX_13-1)*3):3) = IMISS RDATA(IDATS_13+2:IDATS_13+2+((ILVLMX_13-1)*3):3) = 2.0 ELSE IF(ITP.EQ.5 .OR. ITP.EQ.12 .OR. ITP.EQ.13) THEN C VADWND -- LOAD DEFAULT OF 2.0 INTO HGHT CAT. 04 LEVEL QUALITY MARKER C -- LOAD DEFAULT OF 4.0 INTO WIND CAT. 04 LEVEL QUALITY MARKER C {Current limit of "ILVLMX_04" Cat. 04 levels, not counting C first (surface) level} C (could be expanded somewhat w/o changing "IDMAX" if need be) IDATS_04 = IDATS RDATA(IDATS_04+3:IDMAX:5) = 2.0 RDATA(IDATS_04+4:IDMAX:5) = 4.0 ELSE IF(ITP.EQ.6.OR.ITP.EQ.7.OR.ITP.EQ.10.OR.ITP.EQ.11) THEN C ERS, QUIKSCAT, WINDSAT OR ASCAT -- LOAD DEFAULT OF "????????" FOR C STN. ID. IDATS_10 = IDATS STNID = '????????' ELSE IF(ITP.EQ.8) THEN C GPS-IPW -- IDATS_14 = IDATS ELSE IF(ITP.EQ.9) THEN C {Current limit of "ILVLMX_15" Cat. 15 levels, not counting C first (surface) level} C (could be expanded somewhat w/o changing "IDMAX" if need be) IDATS_15 = IDATS IDATA(IDATS_15+2:IDMAX:3) = IMISS END IF RDATA(1:IDMAX) = RDATX(1:IDMAX) RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UNPKB703 C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2016-11-30 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 ALL REPORTS. THE HEADER IS THEN FILLED INTO THE C OUTPUT ARRAY WHICH HOLDS A SINGLE REPORT IN THE QUASI-IW3UNPBF C UNPACKED FORMAT. C C PROGRAM HISTORY LOG: C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR (HANDLED PROFILER C REPORTS ONLY C 1997-06-02 D. A. KEYSER NP22 - WROTE SIMILAR SUBROUTINE TO HANDLE C VAD WINDS ONLY C 1997-06-05 D. A. KEYSER NP22 - WROTE SIMILAR SUBROUTINE TO HANDLE C GOES SOUNDINGS ONLY C 1998-06-14 D. A. KEYSER -- MODIFIED VAD WIND HEADER (STATION ID) C PROCESSING TO ACCOUNT FOR UPDATES TO BUFRTABLE MNEMONICS IN /dcom C 1998-06-15 D. A. KEYSER NP22 - CHANGED CHAR. 6 OF GOES STNID TO BE C UNIQUE FOR TWO DIFFERENT EVEN OR ODD SATELLITE ID'S (EVERY OTHER C EVEN OR ODD SAT. ID NOW GETS SAME CHAR. 6 TAG) C 1999-02-12 D. A. KEYSER NP22 - WROTE SIMILAR SUBROUTINE TO HANDLE C ERS SCATTEROMETER WINDS ONLY C 2000-09-22 D. A. KEYSER NP22-- ADDED QUIKSCAT SCATTEROMETER WINDS C TO ERS SCATTEROMETER SUBROUTINE NOW THAT THEY ARE PACKED IN BUFR C 2000-12-05 D. A. KEYSER -- MODIFIED GOES, ERS AND QUIKSCAT TO NOT C CREATE STN. ID IF IT HAS ALREADY BEEN CREATED BY BUFR_DUPSAT C (GOES), WAVE_DATASORT (ERS), OR WAVE_DCODQUIKSCAT (QUIKSCAT) C (LOOKS FOR "RPID" IN INPUT FILE) (OTHERWISE, MODIFIED TO CREATE C AN 8-CHARACTER STN. ID) C 2001-04-06 D. A. KEYSER NP22 - HEADER WORD 5 NOW RETURNS COMPLETE C DATE (YYYYMMDDHH) AND HEADER WORD 6 IS NOW MISSING EXCEPT FOR C GOES, ERS AND QUIKSCAT WHERE WORD 6 NOW RETURNS SATELLITE ID C 2001-06-19 D. A. KEYSER -- FOR GOES, RECOGNIZES BUFR TYPE/SUBTYPE C 003/002 AS GOES 1x1 (HI-RES) DATA, PART OF THE "GOESND" DUMP FILE C ("SUBSET" ADDED TO INPUT ARGUMENT LIST); GOES HI-RES REPORTS HAVE C UNKNOWN PATH AND GET PROPER STNID CHAR. 8 CHARACTER IDENTIFYING C THE SAT. NUMBER (IF STNID IS GENERATED HERE) C 2001-08-20 D. A. KEYSER -- FOR QUIKSCAT, HEADER WORD 10 NOW RETURNS C NUMBER OF ORIGINAL REPORTS USED TO GENERATE SUPEROBS SINCE THIS C IS NOW AVAILABLE IN INPUT REPROCESSED QKSWND DUMP FILE (FOR C NON-SUPEROBS, HARDWIRED TO 1) C 2002-03-05 D. A. KEYSER -- ACCOUNTS FOR CHANGES IN INPUT PROFLR C (WIND PROFILER BUFR DUMP FILE AFTER 5/2002: MNEMONIC "NPSM" IS NO C LONGER AVAILABLE; MNEMONIC "TPSE" REPLACES "TPMI" (AVG. TIME IN C MINUTES STILL OUTPUT) (WILL STILL WORK PROPERLY FOR INPUT PROFLR C DUMP FILES PRIOR TO 5/2002) C 2002-07-03 D. A. KEYSER -- COMBINED INDIVIDUAL SUBROUTINES FOR C PROCESSING HEADER INFORMATION FOR ALL TYPES INTO THIS SINGLE NEW C SUBROUTINE SINCE ALL WERE VERY SIMILAR; ADDED PROCESSING OF GPS- C IPW REPORTS HERE NOW THAT THEY ARE PACKED IN AN NCEP BUFR FILE C (GPSIPW - RETURNED IN NEW CATEGORY 14) C 2004-02-02 D. A. KEYSER -- ADDED COOPERATIVE AGENCY (002/011) AND C JAPANESE (002/013) WIND PROFILERS TO PROCESSING FOR WIND C PROFILERS NOT ORIGINATING FROM PILOT (PIBAL) BULLETINS; ADDED C PROCESSING OF NPN AND CAP RASS REPORTS HERE (002/012) NOW THAT C THEY ARE PACKED IN AN NCEP BUFR FILE (RASSDA - RETURNED IN NEW C DATA LEVEL CATEGORY 15) C 2006-07-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM BUFR_LISTDUMPS): C 2007-09-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM PREPOBS_PREPDATA): C MOVED REPORT-TYPE SPECIFIC VALUES OUT OF RETURNED HEADER IN C "RDATA" TO NEW "RDATA2" ARRAY (CLEANS UP HEADER PROCESSING) C 2007-09-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM BUFR_LISTDUMPS): C 2007-09-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM PREPOBS_PREPDATA): C HANDLES GOES 1x1 F-O-V SNDGS RADIANCES IN SUBSET "NC003003" C 2008-09-25 D. A. KEYSER -- ADDED ASCAT SCATTEROMETER WINDS HERE NOW C THAT THEY ARE PACKED IN A NCEP BUFR FILE (GET DUMP REPORT TYPE C 584) C 2014-03-13 D. A. KEYSER -- MODIFIED TO HANDLE VAD WINDS FROM LEVEL C 2 DECODER (SUBSET "NC002017") {IN ADDITION TO THOSE FROM RADAR C CODED MESSAGE (SUBSET "NC002008")} C 2016-11-30 D. A. KEYSER -- C Added new output real, double-precision argument array RDATA8_8 of C length 2 to return full-precision latitude and longitude for a C report. C BENEFIT: Although lat and lon are returned in RDATA(1:2) these are C at machine precison, which is normally R*4. Now that C many reports in the dumps store lat/lon at 0.001 or even C 0.00001 degree precision, and now that PREPBUFR encodes C YOB (lat) and XOB (lon) at 0.00001 degree precision, this C change will ensure that lat/lon is always accurate to C 0.00001 degrees in all downstream processing. C 2020-08-20 J. DONG -- C - Added processing to encode newly available VAD wind (NC002018) C and profiler wind (NC002014) tanks into prepbufr files. C C USAGE: CALL UNPKB703(LUNIT,RDATA,RDATA8_8,STNID,SUBSET,ITP,IRET) C INPUT ARGUMENT LIST: C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE C RDATA - SINGLE REPORT IN A QUASI-IW3UNPBF UNPACKED FORMAT WITH C - ALL DATA INITIALIZED AS MISSING (NOTE: DOES NOT C - INCLUDE STATION ID) C RDATA8_8 - 2-WORD REAL*8 ARRAY CONTAINING ADDITIONAL REPORT DATA C (LATITUDE AND LONGITUDE) (SEE REMARKS 7 FOR CONTENT) C STNID - CHARACTER*8 SINGLE REPORT STATION IDENTIFICATION (UP C - TO 8 CHARACTERS, LEFT-JUSTIFIED - HERE INITIALIZED AS C - EITHER BLANKS OR "????????") C SUBSET - CHARACTER*8 BUFR MESSAGE TYPE (SAME FOR ALL REPORTS C - IN A COMMON BUFR MESSAGE) C ITP - THE TYPE OF REPORT THAT HAS BEEN DECODED {=1 - NPN C - WIND PROFILER, =2 - CAP WIND PROFILER, =3 - JMA WIND C - PROFILER, =4 - GOES SNDG, =5 - NEXRAD (VAD) WIND FROM C - RADAR CODED MESSAGE; =6 - ERS SCATTEROMETER WIND, =7 - C - QUIKSCAT SCATTEROMETER WIND, =8 - GPS-IPW, =9 - NPN C - or CAP RASS, =10 - WINDSAT SCATTEROMETER WIND (NAVY OR C - NESDIS), =11 - ASCAT SCATTEROMETER WIND; =12 - NEXRAD C - (VAD) WIND FROM LEVEL 2 DECODER} C C OUTPUT ARGUMENT LIST: C RDATA - SINGLE REPORT IN A QUASI-IW3UNPBF UNPACKED FORMAT WITH C - HEADER INFORMATION FILLED IN (ALL OTHER DATA REMAINS C - MISSING) (NOTE: DOES NOT INCLUDE - STATION ID) C STNID - CHARACTER*8 SINGLE REPORT STATION IDENTIFICATION (UP C - TO 8 CHARACTERS, LEFT-JUSTIFIED - HERE FILLED IN) C IRET - RETURN CODE AS DESCRIBED IN W3UNPKB7 DOCBLOCK C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY SUBROUTINE W3UNPKB7. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ SUBROUTINE UNPKB703(LUNIT,RDATA,rdata8_8,STNID,SUBSET,ITP,IRET) C Include parameters common to more than one subroutine C ----------------------------------------------------- include 'inc_w3unpkb7.inc' CHARACTER*1 C8TAG(3,0:3) CHARACTER*8 STNID,SID,SUBSET character*20 sid_gnss CHARACTER*60 HDRSTR, HDRSTR2 INTEGER IDATA(IDMAX),KOUNTG(3,0:3),IRPTYP(14) LOGICAL SKIP_CAT12 REAL(8) HDR_8(12),RPID_8,VAR_8,BMISS,rdata8_8(2) REAL HDR(12),RDATA(*),RDATX(IDMAX) COMMON /PKB7AA/BMISS COMMON /PKB7BB/KDATE(8),LDATE(8),KTIMCH,IPRINT,SKIP_CAT12 COMMON /PKB7FF/IFOV(4,2),KNTSAT(250:260) SAVE EQUIVALENCE (RDATX,IDATA),(RPID_8,SID) DATA XMISS/99999./,YMISS/99999.8/,IRPTYP/71,75,76,61,72,581,582, $ 74,77,583,584,72,72,76/ DATA HDRSTR/ $ 'CLAT CLON SELV YEAR MNTH DAYS HOUR MINU SECO RCHR RCMI SAID '/ DATA HDRSTR2/ $'CLATH CLONH HSMSL YEAR MNTH DAYS HOUR MINU SECO RCHR RCMI SAID '/ DATA ITIMESG/0/,KOUNTG/12*0/,ITIMESS/0/,KOUNTS/0/ C----------------------------------------------------------------------- C FOR GOES SOUNDING DATA ONLY: C CURRENT LIST OF SATELLITE IDENTIFIERS (BUFR C.F. 0-01-007) C ----------------------------------------------------------- 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 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 --- --- ---- --- --- ---- --- --- ---- --- --- ---- C DATA C8TAG/'I','J','K', 'L','M','N', 'O','P','S', 'Q','R','T' / C----------------------------------------------------------------------- IF(ITP.EQ.4) THEN IF(ITIMESG.EQ.0) THEN KOUNTG = 0 ITIMESG = 1 END IF ELSE IF(ITP.EQ.6.OR.ITP.EQ.7.OR.ITP.EQ.10.OR.ITP.EQ.11) THEN IF(ITIMESS.EQ.0) THEN KOUNTS = 0 ITIMESS = 1 END IF END IF RDATX(1:IDMAX) = RDATA(1:IDMAX) HDR_8 = BMISS IF(ITP.EQ.14.OR.ITP.EQ.13) THEN CALL UFBINT(LUNIT,HDR_8,12,1,NLEV,HDRSTR2);HDR=HDR_8 ELSE CALL UFBINT(LUNIT,HDR_8,12,1,NLEV,HDRSTR);HDR=HDR_8 END IF IF(NLEV.NE.1) GO TO 9999 C----------------------------------------- C Output header - Word 1 (Stored as Real) C----------------------------------------- C LATITUDE M = 1 N = 1 if(hdr_8(m).ge.bmiss) then call ufbint(lunit,HDR_8(m),12,1,nlev,'CLATH') hdr(m) = hdr_8(m) end if IF(IPRINT.GT.1) PRINT 199, hdr_8(M),M 199 FORMAT(5X,'HDR_8 HERE IS: ',F18.5,'; INDEX IS: ',I3) IF(hdr_8(M).LT.bmiss) THEN RDATX(N) = HDR(M) IF(IPRINT.GT.1) PRINT 198, N,RDATX(N) 198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2) rdata8_8(1) = hdr_8(M) if(iprint.gt.1) print *, 'RDATA8_8(1) STORED AS: ',rdata8_8(1) ELSE IRET = 3 PRINT 102 102 FORMAT(' *** W3UNPKB7 ERROR: LAT MISSING'/) RETURN END IF C----------------------------------------- C Output header - Word 2 (Stored as Real) C----------------------------------------- C LONGITUDE M = 2 N = 2 if(hdr_8(m).ge.bmiss) then call ufbint(lunit,HDR_8(m),12,1,nlev,'CLONH') hdr(m) = hdr_8(m) end if IF(IPRINT.GT.1) PRINT 199, hdr_8(M),M IF(hdr_8(M).LT.bmiss) THEN C Important: According to BUFR Manual, CLON (0-06-002) - represented C here by "HDR(M)" - should be in units of Degrees West - and East + C (-180.0 to +180.0); however some BUFR data sets (e.g., PREPBUFR) are C known to encode 0-06-002 in units of Degrees East (0.0 to 359.99) -- C So we use the following conversion to work in either case ... RDATX(N) = 360. - MOD(360.-HDR(M),360.) IF(RDATX(N).EQ.360.0) RDATX(N) = 0.0 IF(IPRINT.GT.1) PRINT 198, N,RDATX(N) rdata8_8(2) = hdr_8(M) if(iprint.gt.1) print *, 'RDATA8_8(2) STORED AS: ',rdata8_8(2) ELSE IRET = 3 PRINT 104 104 FORMAT(' *** W3UNPKB7 ERROR: LON MISSING'/) RETURN END IF C------------------------------------------- C Output header - Word 6 (Stored as Integer) C------------------------------------------- C SATELLITE ID (GOES Soundings/Radiances, ERS Scatterometer, C QuikSCAT Scatterometer, WindSat Scatterometer, C ASCAT Scatterometer) M = 12 N = 6 IF(ITP.EQ.4.OR.ITP.EQ.6.OR.ITP.EQ.7.OR.ITP.EQ.10.OR.ITP.EQ.11)THEN IF(IPRINT.GT.1) PRINT 199, HDR(M),M IF(ITP.EQ.4) THEN IDSAT = 2 IF(HDR(M).LT.XMISS) THEN cfix? IF(HDR(M).LT.YMISS) THEN IDATA(N) = NINT(HDR(M)) IDSAT = MOD(IDATA(N),4) IF(IDATA(N).GT.249.AND.IDATA(N).LT.260) THEN KNTSAT(IDATA(N)) = KNTSAT(IDATA(N)) + 1 ELSE KNTSAT(260) = KNTSAT(260) + 1 END IF END IF ELSE IF(HDR(M).LT.XMISS) IDATA(N) = NINT(HDR(M)) cfix? IF(HDR(M).LT.YMISS) IDATA(N) = NINT(HDR(M)) END IF IF(IPRINT.GT.1) PRINT 197, N,IDATA(N) 197 FORMAT(5X,'IDATA(',I5,') STORED AS: ',I10) END IF C----------------------------------------- C Output header - Word 7 (Stored as Real) C----------------------------------------- C STATION ELEVATION C GOES Soundings: Obtained from height of first C (surface) level, stored later in C subroutine UNPKB707 C ERS, QuikSCAT, WindSat or ASCAT C Scatterometer: Hardwired to 10 meters C All other types: Obtained from reported station C height and stored here M = 3 N = 7 IF(ITP.EQ.6.OR.ITP.EQ.7.OR.ITP.EQ.10.OR.ITP.EQ.11) THEN RDATX(N) = 10. IF(IPRINT.GT.1) PRINT 198, N,RDATX(N) ELSE IF(ITP.NE.4) THEN IF(HDR(M).LT.XMISS) RDATX(N) = NINT(HDR(M)) cfix? IF(HDR(M).LT.YMISS) RDATX(N) = NINT(HDR(M)) IF(IPRINT.GT.1) PRINT 199, HDR(M),M IF(IPRINT.GT.1) PRINT 198, N,RDATX(N) END IF C-------------------------------------------- C Output header - Word 8 (Stored as Integer) C-------------------------------------------- C INSTRUMENT TYPE C GOES Soundings: RETRIEVAL TYPE (GEOSTATIONARY SATELLITE C DATA-PROCESSING TECHNIQUE USED) M = 13 N = 8 IF(ITP.EQ.4) THEN CALL UFBINT(LUNIT,VAR_8,1,1,NLEV,'GSDP') VAR = VAR_8 IF(NLEV.GT.1) GO TO 9999 IF(VAR.LT.XMISS) IDATA(N) = NINT(VAR) cfix? IF(VAR.LT.YMISS) IDATA(N) = NINT(VAR) IF(IPRINT.GT.1) PRINT 199, VAR,M IF(IPRINT.GT.1) PRINT 197, N,IDATA(N) END IF C------------------------------------------- C Output header - Word 9 (Stored as Integer) C------------------------------------------- C REPORT TYPE N = 9 IDATA(N) = IRPTYP(ITP) IF(IPRINT.GT.1) PRINT 197, N,IDATA(N) C------------------------------------------------- C Output argument - "STNID" (Stored as Character) C------------------------------------------------- C STATION IDENTIFICATION M = 14 if(subset.eq.'NC012004') then C....................................................................... C GPS Integrated Precipitable Water from new "GNSS" BUFR feed: C....................................................................... call readlc(lunit,sid_gnss,'STSN') if(sid_gnss.eq.' ') nlev = 0 if(nlev.eq.0) go to 9999 sid = sid_gnss(1:4)//sid_gnss(6:9) if(iprint.gt.1) print 299, sid,m C STNID is stored directly from STSN(1:4)//STSN(6:9) stnid = sid else CALL UFBINT(LUNIT,RPID_8,1,1,NLEV,'RPID ') cpppppppppp cc print'(" rpid_8,icbfms(sid,8): ",G0,1X,I0)', rpid_8,icbfms(sid,8) cpppppppppp IF(ICBFMS(SID,8).NE.0) NLEV = 0 C above line not working right - may return 0 when missing, so use next C two lines below temporarily until this is fixed (readlc will return C all blanks for sid when mnemonic "RPID" not found) - dak 2/19/13 call readlc(lunit,sid,'RPID') cpppppppppp cc print'(" sid = ",A)', sid cpppppppppp if(sid.eq.' ') nlev = 0 IF(ITP.LE.3.OR.ITP.EQ.14) THEN C....................................................................... C Wind Profiler: C....................................................................... IF(NLEV.EQ.1) THEN C. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . C If decoded RPID is not missing set STNID to it C (test on "NLEV" for missing "RPID" - valid RPID_8 can be > BMISS!) C. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . IF(IPRINT.GT.1) PRINT 299, SID,M 299 FORMAT(5X,'RPID HERE IS: ',9X,A8,'; INDEX IS: ',I3) IF(IPRINT.GT.1) PRINT 2198 2198 FORMAT(5X,'STN. ID PRESENT IN INPUT FILE, DO NOT GENERATE HERE') STNID = SID ELSE C. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . C If decoded RPID is missing then generate STNID from C decoded WMO block/stn numbers C. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . IF(IPRINT.GT.1) PRINT 2188 2188 FORMAT(5X,'STN. ID NOT PRESENT IN INPUT FILE, USE WMO BLOCK/', $ 'STATION NUMBER TO GENERATE IT HERE'/) CALL UFBINT(LUNIT,VAR_8,1,1,NLEV,'WMOB') ! Block Number VAR = VAR_8 IF(NLEV.GT.1) GO TO 9999 IF(IPRINT.GT.1) PRINT 199, VAR,M IF(VAR.LT.XMISS) WRITE(STNID(1:2),'(I2.2)') NINT(VAR) cfix? IF(VAR.LT.YMISS) WRITE(STNID(1:2),'(I2.2)') NINT(VAR) CALL UFBINT(LUNIT,VAR_8,1,1,NLEV,'WMOS') ! Station Number VAR = VAR_8 IF(NLEV.GT.1) GO TO 9999 IF(IPRINT.GT.1) PRINT 199, VAR,M IF(VAR.LT.XMISS) WRITE(STNID(3:5),'(I3.3)') NINT(VAR) cfix? IF(VAR.LT.YMISS) WRITE(STNID(3:5),'(I3.3)') NINT(VAR) END IF ELSE IF(ITP.EQ.5 .OR. ITP.EQ.12 .OR. ITP.EQ.13) THEN C....................................................................... C NEXRAD (VAD) Wind: C....................................................................... IF(NLEV.NE.1) GO TO 9999 IF(IPRINT.GT.1) PRINT 299, SID,M IF(ITP.EQ.5 .AND. SID(5:7).EQ.' ') THEN C. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . C RCM VAD Winds Before 02/18/1999 --> C Decoded RPID contains only the 4-character Product Source ID C STNID is stored as: C '99'//last 3-characters of Product Source ID//' ' C. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . STNID = '99'//SID(2:4)//' ' ELSE C. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . C After 02/18/1999 --> C STNID is stored directly from RPID as: C RCM VAD: 4-character Product Source ID//3-character RCM ID//' ' C NEW VAD: 4-character Product Source ID//' ' C. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . STNID = SID END IF ELSE IF(ITP.EQ.4) THEN C....................................................................... C GOES Soundings: C....................................................................... IF(NLEV.NE.1.OR.(SID(8:8).LT.'A'.OR.SID(8:8).GT.'Z')) THEN C. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . C If decoded RPID is missing or if the eighth character of RPID is not C "A"-"Z", then this subr. must generate STNID C (indicates an input data dump file prior to Dec. 2000) C (test on "NLEV" for missing "RPID" - valid RPID_8 can be > BMISS!) C C STNID Generated as Follows: C Characters 1-7 obtained from 7-digit count number (specific C to Satellite ID/Retrieval Type) C (For SFOV retrievals, character 1 replaced with "H") C Character 8 obtained from Satellite ID/Retrieval Type Tag C. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . IRTYP = 3 ! Unknown retrieval type (default) IF(IDATA(8).EQ.21) THEN IRTYP = 1 ! Clear retrieval type ELSE IF(IDATA(8).EQ.23) THEN IRTYP = 2 ! Cloudy retrieval type END IF IF(IPRINT.GT.1) PRINT 2197, IDSAT,IRTYP 2197 FORMAT(5X,'STN. ID NOT PRESENT IN INPUT FILE, MUST GENERATE HERE'/ $ 5X,'IDSAT IS: ',I10,', IRTYP IS: ',I10) STNID(8:8) = C8TAG(IRTYP,IDSAT) KOUNTG(IRTYP,IDSAT) = MIN(KOUNTG(IRTYP,IDSAT)+1,9999999) WRITE(STNID(1:7),'(I7.7)') KOUNTG(IRTYP,IDSAT) IF(SUBSET.EQ.'NC003002' .or. SUBSET.EQ.'NC003003') $ STNID(1:1) = 'H' ELSE C. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . C If decoded RPID is NOT missing AND if the eighth character of C RPID is "A"-"Z", then the dump program BUFR_DUPSAT has already C created the proper Station ID in RPID - generate STNID from RPID C (indicates an input data dump file after Dec. 2000) C. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . IF(IPRINT.GT.1) PRINT 2198 STNID = SID END IF ELSE IF(ITP.EQ.6.OR.ITP.EQ.7.OR.ITP.EQ.10.OR.ITP.EQ.11) THEN C....................................................................... C ERS, QuikSCAT, WindSat or ASCAT Scatterometer: C....................................................................... IF(NLEV.NE.1.OR.(SID(8:8).LT.'A'.OR.SID(8:8).GT.'Z')) THEN C. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . C If decoded RPID is missing or if the eighth character of RPID is not C "A"-"Z", then this subr. must generate STNID C (indicates an input reprocessed data dump file prior to Dec. 2000) C (test on "NLEV" for missing "RPID" - valid RPID_8 can be > BMISS!) C C STNID Generated as Follows: C Characters 1-7 obtained from 7-digit count number C Character 8 is "E" for ERS, "Q" for QuikSCAT, "W" for C WindSat or "A" for ASCAT C (Note: Reprocessed QuikSCAT data dumps never contained C SUPERobs and reports were always from Satellite ID C 281 prior to Dec. 2000 - this means 2'nd character C was never "S" and 8'th character was always "Q") C. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . IF(IPRINT.GT.1) PRINT 2197 IF(ITP.EQ.6) THEN STNID(8:8) = 'E' ELSE IF(ITP.EQ.7) THEN STNID(8:8) = 'Q' ELSE IF(ITP.EQ.10) THEN STNID(8:8) = 'W' ELSE IF(ITP.EQ.11) THEN STNID(8:8) = 'A' END IF KOUNTS = MIN(KOUNTS+1,9999999) WRITE(STNID(1:7),'(I7.7)') KOUNTS ELSE C. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . C If decoded RPID is NOT missing AND if the eighth character of C RPID is "A"-"Z", then the dump program WAVE_DATASORT (ERS), C WAVE_DCODQUIKSCAT (QuikSCAT, ASCAT) or BUFR_DCODWINDSAT C (WindSat) has already created the proper Station ID in RPID - C generate STNID from RPID (indicates an input reprocessed dump C file after Dec. 2000) C. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . IF(IPRINT.GT.1) PRINT 2198 STNID = SID END IF ELSE IF(ITP.EQ.8.OR.ITP.EQ.9) THEN C....................................................................... C GPS Integrated Precipitable Water or RASS: C....................................................................... IF(NLEV.NE.1) GO TO 9999 IF(IPRINT.GT.1) PRINT 299, SID,M C STNID is stored directly from RPID STNID = SID C....................................................................... END IF end if IF(IPRINT.GT.1) PRINT 196, STNID 196 FORMAT(5X,'STNID STORED IN CHARACTER AS: "',A8,'"') C--------------------------------------------- C Output header - Word 4 (Stored as Real) C OBSERVATION TIME C Output header - Word 5 (Stored as Integer) C DATE (STORED IN FORM YYYYMMDDHH) C--------------------------------------------- M = 4 IF(IPRINT.GT.1) PRINT 199, HDR(M),M M = 5 IF(IPRINT.GT.1) PRINT 199, HDR(M),M M = 6 IF(IPRINT.GT.1) PRINT 199, HDR(M),M M = 7 IF(IPRINT.GT.1) PRINT 199, HDR(M),M M = 8 IF(IPRINT.GT.1) PRINT 199, HDR(M),M M = 9 IF(IPRINT.GT.1) PRINT 199, HDR(M),M IF(HDR(9).GE.XMISS) HDR(9) = 0. IF(MIN(HDR(4),HDR(5),HDR(6),HDR(7),HDR(8)).GE.XMISS) GO TO 30 cfix? IF(HDR(9).GE.YMISS) HDR(9) = 0. cfix? IF(MIN(HDR(4),HDR(5),HDR(6),HDR(7),HDR(8)).GE.YMISS) GO TO 30 N = 4 RDATX(N) = (HDR(7) + ((HDR(8) * 60.) + HDR(9))/3600.) cdak $ + 0.0001 ! don't make this adjustment now that we store obs time ! to 10**5 in PREPBUFR IF(IPRINT.GT.1) PRINT 198, N,RDATX(N) N = 5 IDATA(N) = (NINT(HDR(4)) * 1000000) + (NINT(HDR(5)) * 10000) + $ (NINT(HDR(6)) * 100) + NINT(HDR(7)) IF(IPRINT.GT.1) PRINT 197, N,IDATA(5) C--------------------------------------------- C Output header - Word 11 (Stored as Real) C RECEIPT TIME C--------------------------------------------- M = 10 IF(IPRINT.GT.1) PRINT 199, HDR(M),M M = 11 IF(IPRINT.GT.1) PRINT 199, HDR(M),M IF(MAX(HDR(10),HDR(11)).LT.XMISS) THEN N = 11 RDATX(N) = (HDR(10) + ((HDR(11) * 60.))/3600.) + 0.0001 IF(IPRINT.GT.1) PRINT 198, N,RDATX(N) END IF RDATA(1:IDMAX) = RDATX(1:IDMAX) RETURN C----------------------------------------------------------------------- 30 CONTINUE C PROBLEM: SOME OR ALL DATE INFORMATION IS MISSING -- C SET IRET = 4 AND RETURN PRINT 317 317 FORMAT(/'##W3UNPKB7: SOME OR ALL DATE INFORMATION IS MISSING - ', $ 'IRET = 4'/) IRET = 4 RETURN C----------------------------------------------------------------------- 9999 CONTINUE C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED -- C SET IRET = 6 AND RETURN PRINT 217, NLEV 217 FORMAT(/'##W3UNPKB7: THE NUMBER OF DECODED "LEVELS" (=',I5,') ', $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 6'/) IRET = 6 RETURN C----------------------------------------------------------------------- END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UNPKB704 C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2008-09-25 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 REPORTS NOT ORIGINATING FROM PILOT C (PIBAL) FORMAT BULLETINS, AND 10 METER DATA FOR ERS SCATTEROMETER, C QUIKSCAT SCATTEROMETER, WINDSAT (NAVY OR NESDIS) SCATTEROMETER OR C ASCAT SCATTEROMETER WIND REPORTS. SURFACE DATA ARE THEN FILLED C INTO THE OUTPUT ARRAY AS DATA LEVEL CATEGORY 10. THE OUTPUT ARRAY C HOLDS A SINGLE WIND PROFILER, ERS SCATTEROMETER, QUIKSCAT C SCATTEROMETER, WINDSAT SCATTEROMETER OR ASCAT SCATTEROMETER REPORT C IN THE QUASI-IW3UNPBF UNPACKED FORMAT. C C PROGRAM HISTORY LOG: C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR (WIND PROFILER ONLY) C 1999-02-12 D. A. KEYSER -- ADDED ERS SCATTEROMETER WINDS HERE NOW C THAT THEY ARE PACKED IN A NCEP BUFR FILE C 2000-09-22 D. A. KEYSER -- CORRECTED VALUE FOR RETURNED RAINFALL; C ADDED QUIKSCAT SCATTEROMETER WINDS HERE NOW THAT THEY ARE PACKED C IN A NCEP BUFR FILE C 2002-03-05 D. A. KEYSER -- ACCOUNTS FOR CHANGES IN INPUT PROFLR C (WIND PROFILER BUFR DUMP FILE AFTER 5/2002: SURFACE DATA NOW ALL C MISSING (MNEMONICS "PMSL","WDIR1","WSPD1", "TMDB", "REHU", "REQV" C NO LONGER AVAILABLE) (WILL STILL WORK PROPERLY FOR INPUT PROFLR C DUMP FILES PRIOR TO 5/2002) C 2006-07-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM BUFR_LISTDUMPS): C 2007-09-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM PREPOBS_PREPDATA): C ADDED WINDSAT SCATTEROMETER WINDS HERE NOW THAT THEY ARE PACKED C IN A NCEP BUFR FILE; RAINFALL RATE NOW RETURNED IN ORIGINAL BUFR C UNITS OF KG/((M**2)*SEC) INSTEAD OF MM/HOUR (WINDSAT IS ONLY TYPE C TO RETURN THIS) C 2008-09-25 D. A. KEYSER -- ADDED ASCAT SCATTEROMETER WINDS HERE NOW C THAT THEY ARE PACKED IN A NCEP BUFR FILE C 2020-08-20 J. DONG -- ADDED TO HANDLE PROFILER WIND FROM HONG KONG C C USAGE: CALL UNPKB704(LUNIT,RDATA,ITP,IRET) C INPUT ARGUMENT LIST: C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE C RDATA - SINGLE WIND PROFILER, ERS SCATTEROMETER, QUIKSCAT C - SCATTEROMETER, WINDSAT SCATTEROMETER OR ASCAT C - SCATTEROMETER REPORT IN A QUASI-IW3UNPBF UNPACKED C - FORMAT WITH ONLY HEADER INFORMATION FILLED IN (ALL C - OTHER DATA REMAINS MISSING) C ITP - THE TYPE OF REPORT THAT HAS BEEN DECODED {=1 - NPN C - WIND PROFILER, =2 - CAP WIND PROFILER, =3 - JMA WIND C - PROFILER, =6 - ERS SCATTEROMETER WIND, =7 - QUIKSCAT C - SCATTEROMETER WIND, =10 - WINDSAT SCATTEROMETER WIND C - (NAVY OR NESDIS), =11 - ASCAT SCATTEROMETER WIND} C - =14 - HONG KONG WIND PROFILER C C OUTPUT ARGUMENT LIST: C RDATA - SINGLE WIND PROFILER, ERS SCATTEROMETER, QUIKSCAT C - SCATTEROMETER, WINDSAT SCATTEROMETER OR ASCAT C - SCATTEROMETER REPORT IN A QUASI-IW3UNPBF UNPACKED C - FORMAT WITH SURFACE INFORMATION FILLED IN (AS WELL AS C - HEADER INFORMATION) C IRET - RETURN CODE AS DESCRIBED IN W3UNPKB7 DOCBLOCK C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY SUBROUTINE W3UNPKB7. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ SUBROUTINE UNPKB704(LUNIT,RDATA,ITP,IRET) C Include parameters common to more than one subroutine C ----------------------------------------------------- include 'inc_w3unpkb7.inc' CHARACTER*40 SRFCP,SRFCS INTEGER IDATA(IDMAX) REAL(8) SFC_8(8),BMISS REAL SFC(8),RDATA(*),RDATX(IDMAX) LOGICAL SKIP_CAT12 COMMON /PKB7AA/BMISS COMMON /PKB7BB/kdate(8),ldate(8),KTIMCH,IPRINT,SKIP_CAT12 COMMON /PKB7GG/IDATS_04,IDATS_08,IDATS_10,IDATS_11,IDATS_12, $ IDATS_13,IDATS_14,IDATS_15 SAVE EQUIVALENCE (RDATX,IDATA) DATA XMISS/99999./ DATA SRFCP/'PMSL WDIR1 WSPD1 TMDB REHU REQV '/ DATA SRFCS/'PMSL WD10 WS10 TMDB REHU REQV '/ RDATX(1:IDMAX) = RDATA(1:IDMAX) SFC_8 = BMISS IF(ITP.LE.3.OR.ITP.EQ.14) THEN ! wind profiler CALL UFBINT(LUNIT,SFC_8,8,1,NLEV,SRFCP);SFC=SFC_8 ILVL = 1 ELSE ! scatterometer CALL UFBINT(LUNIT,SFC_8,8,1,NLEV,SRFCS);SFC=SFC_8 ILVL = 0 END IF IF(NLEV.NE.1) THEN C....................................................................... C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED -- IF(ITP.LE.3.OR.ITP.EQ.14) THEN ! for wind profiler return but don't ! reset iret PRINT 217, NLEV 217 FORMAT(/'##W3UNPKB7: THE NUMBER OF DECODED "LEVELS" (=',I5,') ', $ 'IS NOT WHAT IS EXPECTED (1) - NO SFC DATA PROCESSED'/) GO TO 99 ELSE ! for scatterometer set iret = 7 and return PRINT 218, NLEV 218 FORMAT(/'##W3UNPKB7: THE NUMBER OF DECODED "LEVELS" (=',I5,') ', $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 7'/) IRET = 7 RETURN END IF 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.XMISS) THEN ILVL = 1 RDATX(IDATS_10) = NINT(SFC(1) * 0.1) END IF NNNNN = IDATS_10 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(IDATS_10) 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.XMISS) THEN ILVL = 1 RDATX(IDATS_10+2) = NINT(SFC(2)) END IF NNNNN = IDATS_10 + 2 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(IDATS_10+2) C SURFACE HORIZONTAL WIND SPEED (STORED AS REAL) M = 3 IF(IPRINT.GT.1) PRINT 199, SFC(3),M IF(SFC(3).LT.XMISS) THEN ILVL = 1 RDATX(IDATS_10+3) = NINT(SFC(3) * 10.) END IF NNNNN = IDATS_10 + 3 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(IDATS_10+3) C SURFACE TEMPERATURE (STORED AS REAL) M = 4 IF(IPRINT.GT.1) PRINT 199, SFC(4),M IF(SFC(4).LT.XMISS) THEN ILVL = 1 RDATX(IDATS_10+4) = NINT(SFC(4) * 10.) END IF NNNNN = IDATS_10 + 4 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(IDATS_10+4) C RELATIVE HUMIDITY (STORED AS REAL) M = 5 IF(IPRINT.GT.1) PRINT 199, SFC(5),M IF(SFC(5).LT.XMISS) THEN ILVL = 1 RDATX(IDATS_10+5) = NINT(SFC(5)) END IF NNNNN = IDATS_10 + 5 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(IDATS_10+5) C RAINFALL RATE (STORED AS REAL) M = 6 IF(IPRINT.GT.1) PRINT 199, SFC(6),M IF(SFC(6).LT.XMISS) THEN ILVL = 1 RDATX(IDATS_10+6) = SFC(6) END IF NNNNN = IDATS_10 + 6 IF(IPRINT.GT.1) PRINT 198, NNNNN,(RDATX(IDATS_10+6)*3600.) C SET DATA LEVEL CATEGORY COUNTERS FOR SURFACE DATA IDATA(35) = ILVL IF(IPRINT.GT.1) PRINT'(1X,I0," CAT. 10 LEVELS PROCESSED")', $ IDATA(35) IF(IDATA(35).GT.0) IDATA(36) = IDATS_10 IF(IDATA(35).EQ.0) IRET = 5 ! Can only happen for scatterometer ! because for wind profiler ! IDATA(35)=1 even if all parameters ! here are missing 99 CONTINUE IF(IPRINT.GT.1) PRINT'(" IDATA(35)=",I0,"; IDATA(36)=",I0)', $ IDATA(35),IDATA(36) RDATA(1:IDMAX) = RDATX(1:IDMAX) RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UNPKB705 C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2014-03-13 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 NOT ORIGINATING FROM PILOT C (PIBAL) FORMAT BULLETINS. UPPER-AIR DATA ARE THEN FILLED INTO THE C OUTPUT ARRAY AS DATA LEVEL CATEGORY 11. THE OUTPUT ARRAY HOLDS A C SINGLE WIND PROFILER REPORT IN THE QUASI-IW3UNPBF UNPACKED FORMAT. C C PROGRAM HISTORY LOG: C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR C 1998-06-14 D. A. KEYSER -- MODIFIED WIND PROFILER CAT. 11 (HEIGHT, C HORIZ. SIGNIFICANCE, VERT. SIGNIFICANCE) PROCESSING TO ACCOUNT C FOR UPDATES TO BUFRTABLE MNEMONICS IN /dcom C 2002-01-28 D. A. KEYSER -- THE QUALITY CODE FOR WIND PROFILER LEVELS C IS NOW SET TO 14 IF THE DECODED QN29 WIND QUALITY MARKER IS 12 C (REJECT LIST) OR 14 (SDM PURGE), OTHERWISE IT IS SET TO THE C DECODED QUALITY CODE VALUE (BEFORE THE ON29 Q.M. WAS IGNORED) C 2002-03-05 D. A. KEYSER -- ACCOUNTS FOR CHANGES IN INPUT PROFLR C (WIND PROFILER BUFR DUMP FILE AFTER 5/2002: MNEMONICS "ACAVH", C "ACAVV", "SPP0", AND "NPHL" NO LONGER AVAILABLE (WILL STILL WORK C PROPERLY FOR INPUT PROFLR DUMP FILES PRIOR TO 5/2002) C 2014-03-13 D. A. KEYSER -- MAXIMUM NUMBER OF CAT. 11 WIND PROFILER C LEVELS ALLOWED (EXCLUDING FIRST, SURFACE, LEVEL), "ILVLMX_11", C INCREASED FROM 102 TO 200 TO ACCOUNT FOR SOME MAP PROFILERS WITH C MORE LEVELS THAN BEFORE C C USAGE: CALL UNPKB705(LUNIT,RDATA,ITP) C INPUT ARGUMENT LIST: C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-IW3UNPBF C - UNPACKED FORMAT WITH ONLY HEADER AND SURFACE C - INFORMATION FILLED IN (UPPER-AIR DATA MISSING) C ITP - THE TYPE OF WIND PROFILER REPORT THAT HAS BEEN C - DECODED {=1 - NOAA Profiler Network (NPN), C - =2 - COOPERATIVE AGENCY PROFILERS (CAP), C - =3 - JAPAN AND HONG KONG} C C OUTPUT ARGUMENT LIST: C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-IW3UNPBF C - UNPACKED FORMAT WITH UPPER-AIR INFORMATION FILLED IN C - (ALL DATA FOR REPORT NOW FILLED) C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY SUBROUTINE W3UNPKB7. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ SUBROUTINE UNPKB705(LUNIT,RDATA,ITP) C Include parameters common to more than one subroutine C ----------------------------------------------------- include 'inc_w3unpkb7.inc' CHARACTER*33 UAIR1,UAIR2,UAIR3 INTEGER IDATA(IDMAX) LOGICAL SKIP_CAT12 REAL(8) UAIR1_8(6,255),UAIR2_8(6,255),UAIR3_8(5,255),BMISS REAL UAIR(17,255),RDATA(*),RDATX(IDMAX) COMMON /PKB7AA/BMISS COMMON /PKB7BB/kdate(8),ldate(8),KTIMCH,IPRINT,SKIP_CAT12 COMMON /PKB7GG/IDATS_04,IDATS_08,IDATS_10,IDATS_11,IDATS_12, $ IDATS_13,IDATS_14,IDATS_15 SAVE EQUIVALENCE (RDATX,IDATA) DATA XMISS/99999./ DATA UAIR1/'HEIT WDIR WSPD QMWN NPQC WCMP '/ DATA UAIR2/'ACAVH ACAVV SPP0 SDHS SDVS NPHL '/ DATA UAIR3/'HAST ACAV1 ACAV2 QMRK STNR '/ RDATX(1:IDMAX) = RDATA(1:IDMAX) 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(IDATS_11+ILC) = RDATX(7) IF(IPRINT.GT.1) PRINT 198, IDATS_11+ILC,RDATX(IDATS_11+ILC) 198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2) IF(RDATX(IDATS_11+ILC).LT.XMISS) NSFC = 1 IF(IDATA(35).GE.1) THEN RDATX(IDATS_11+ILC+1) = RDATX(IDATA(36)+2) RDATX(IDATS_11+ILC+2) = RDATX(IDATA(36)+3) END IF IF(IPRINT.GT.1) PRINT 198, IDATS_11+ILC+1,RDATX(IDATS_11+ILC+1) IF(RDATX(IDATS_11+ILC+1).LT.XMISS) NSFC = 1 IF(IPRINT.GT.1) PRINT 198, IDATS_11+ILC+2,RDATX(IDATS_11+ILC+2) IF(RDATX(IDATS_11+ILC+2).LT.XMISS) NSFC = 1 ILVL = ILVL + 1 ILC = ILC + 11 IF(IPRINT.GT.1) PRINT'(" HAVE COMPLETED LEVEL ",I0," WITH NSFC=", $ I0,"; GOING INTO NEXT LEVEL WITH ILC=",I0)', ILVL,NSFC,ILC UAIR1_8 = BMISS UAIR2_8 = BMISS UAIR3_8 = BMISS CALL UFBINT(LUNIT,UAIR1_8,6,255,NLEV1,UAIR1) CALL UFBINT(LUNIT,UAIR2_8,6,255,NLEV2,UAIR2) CALL UFBINT(LUNIT,UAIR3_8,5,255,NLEV3,UAIR3) NLEV = MAX(NLEV1,NLEV2,NLEV3) UAIR( 1: 6,:) = UAIR1_8(:,:) UAIR( 7:12,:) = UAIR2_8(:,:) UAIR(13:17,:) = UAIR3_8(:,:) IF(IPRINT.GT.1) PRINT 1068, NLEV 1068 FORMAT(' THIS REPORT CONTAINS ',I3,' LEVELS OF DATA (NOT ', $ 'INCLUDING BOTTOM -SURFACE- LEVEL)') 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(/'##W3UNPKB7: 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(/'##W3UNPKB7: NO UPPER-AIR DATA ABOVE FIRST (SURFACE) ', $ 'LEVEL PROCESSED FOR THIS REPORT -- NLEV = 0 AND NSFC > 0'/) GO TO 98 END IF C....................................................................... ELSE IF(NLEV.GT.ILVLMX_11) THEN C PROBLEM: THE NUMBER OF DECODED "LEVELS" {EXCLUDING BOTTOM (SURFACE) C LEVEL} IS .GT. LIMIT OF "ILVLMX_11" -- PRINT 2186, NLEV,ILVLMX_11,ILVLMX_11 2186 FORMAT(/'##W3UNPKB7: NUMBER OF UPPER-AIR LEVELS FOR THIS ', $ 'REPORT (=',I3,') EXCEEDS LIMIT OF ',I0,' CAT. 11 LEVELS ', $ '(EXCLUDING BOTTOM, SFC, LVL) -- '/' ONLY FIRST ',I0, $ ' UPPER-AIR LEVELS PLUS THE SURFACE LEVEL WILL BE PROCESSED'/) NLEV = ILVLMX_11 C....................................................................... END IF 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: Prior to 2/18/1999, the height above sea level was C erroneously stored under mnemonic "HAST" when it should C have been stored under mnemonic "HEIT". This was C corrected after this date. ("HAST" is defined as the C 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 work properly with historical data. IF(UAIR(1,I).LT.XMISS) 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(IDATS_11+ILC) = NINT(UAIR(1,I)) ELSE M = 13 IF(IPRINT.GT.1) PRINT 199, UAIR(13,I),M IF(UAIR(13,I).LT.XMISS) RDATX(IDATS_11+ILC)=NINT(UAIR(13,I)) END IF IF(IPRINT.GT.1) PRINT 198, IDATS_11+ILC,RDATX(IDATS_11+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.XMISS) RDATX(IDATS_11+ILC+1) = NINT(UAIR(2,I)) IF(IPRINT.GT.1) PRINT 198, IDATS_11+ILC+1,RDATX(IDATS_11+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.XMISS)RDATX(IDATS_11+ILC+2)=NINT(UAIR(3,I)*10.) IF(IPRINT.GT.1) PRINT 198, IDATS_11+ILC+2,RDATX(IDATS_11+ILC+2) C QUALITY CODE (STORED AS INTEGER) C IF SDMEDIT/QUIPS WIND QUALITY MARKER IS 12 (REJECT LIST) OR C 14 (SDM PURGE) THEN A VALUE OF 14 IS STORED FOR THE QUALITY C CODE; OTHERWISE THE DECODED QUALITY CODE IS STORED DIRECTLY M = 4 IF(IPRINT.GT.1) PRINT 199, UAIR(4,I),M M = 5 IF(IPRINT.GT.1) PRINT 199, UAIR(5,I),M M = 16 IF(IPRINT.GT.1) PRINT 199, UAIR(16,I),M IF(UAIR(4,I).EQ.12.OR.UAIR(4,I).EQ.14) THEN IDATA(IDATS_11+ILC+3) = 14 ELSE IF(UAIR(5,I).LT.XMISS) THEN ! NPN or CAP IDATA(IDATS_11+ILC+3) = NINT(UAIR(5,I)) ELSE IF(UAIR(16,I).LT.XMISS) THEN ! Japanese IDATA(IDATS_11+ILC+3) = NINT(UAIR(16,I)) END IF IF(IPRINT.GT.1) PRINT 197, IDATS_11+ILC+3,IDATA(IDATS_11+ILC+3) 197 FORMAT(5X,'IDATA(',I5,') STORED AS: ',I10) C VERTICAL WIND COMPONENT (W) (STORED AS REAL) M = 6 IF(IPRINT.GT.1) PRINT 199, UAIR(6,I),M IF(UAIR(6,I).LT.XMISS)RDATX(IDATS_11+ILC+4)=NINT(UAIR(6,I)*100.) IF(IPRINT.GT.1) PRINT 198, IDATS_11+ILC+4,RDATX(IDATS_11+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 5/2002, the horizontal consensus C number was stored under mnemonic "ACAVH". C After 5/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(7,I),M IF(IPRINT.GT.1) PRINT 199, UAIR(14,I),M IF(UAIR(7,I).LT.XMISS) THEN M = 7 IDATA(IDATS_11+ILC+5) = NINT(UAIR(7,I)) ELSE M = 14 IF(UAIR(14,I).LT.XMISS)IDATA(IDATS_11+ILC+5)=NINT(UAIR(14,I)) END IF IF(IPRINT.GT.1) PRINT 197, IDATS_11+ILC+5,IDATA(IDATS_11+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 5/2002, the vertical consensus C number was stored under mnemonic "ACAVV". C After 5/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(UAIR(8,I).LT.XMISS) THEN M = 8 IF(IPRINT.GT.1) PRINT 199, UAIR(8,I),M IDATA(IDATS_11+ILC+6) = NINT(UAIR(8,I)) ELSE IF(UAIR(15,I).LT.XMISS) THEN M = 15 IF(IPRINT.GT.1) PRINT 199, UAIR(15,I),M IDATA(IDATS_11+ILC+6)=NINT(UAIR(15,I)) END IF IF(IPRINT.GT.1) PRINT 197, IDATS_11+ILC+6,IDATA(IDATS_11+ILC+6) IF(ITP.NE.3) THEN C NPN AND CAP: SPECTRAL PEAK POWER (STORED AS REAL) C (NOTE: After 5/2002, the spectral peak power is no longer C stored.) M = 9 ELSE C JAPANESE: SIGNAL-TO-NOISE RATIO (STORED AS REAL) M = 17 END IF IF(IPRINT.GT.1) PRINT 199, UAIR(M,I),M IF(UAIR(M,I).LT.XMISS) RDATX(IDATS_11+ILC+7) = NINT(UAIR(M,I)) IF(IPRINT.GT.1) PRINT 198, IDATS_11+ILC+7,RDATX(IDATS_11+ILC+7) C HORIZONTAL WIND SPEED STANDARD DEVIATION (STORED AS REAL) M = 10 IF(IPRINT.GT.1) PRINT 199, UAIR(10,I),M IF(UAIR(10,I).LT.XMISS)RDATX(IDATS_11+ILC+8)=NINT(UAIR(10,I)*10.) IF(IPRINT.GT.1) PRINT 198, IDATS_11+ILC+8,RDATX(IDATS_11+ILC+8) C VERTICAL WIND COMPONENT STANDARD DEVIATION (STORED AS REAL) M = 11 IF(IPRINT.GT.1) PRINT 199, UAIR(11,I),M IF(UAIR(11,I).LT.XMISS)RDATX(IDATS_11+ILC+9)=NINT(UAIR(11,I)*10.) IF(IPRINT.GT.1) PRINT 198, IDATS_11+ILC+9,RDATX(IDATS_11+ILC+9) C MODE INFORMATION (STORED AS INTEGER) C (NOTE: After 5/2002, the mode information is no longer stored.) M = 12 IF(IPRINT.GT.1) PRINT 199, UAIR(12,I),M IF(UAIR(12,I).LT.XMISS) IDATA(IDATS_11+ILC+10)=NINT(UAIR(12,I)) IF(IPRINT.GT.1)PRINT 197,IDATS_11+ILC+10,IDATA(IDATS_11+ILC+10) C....................................................................... ILC = ILC + 11 IF(IPRINT.GT.1) PRINT'(" HAVE COMPLETED LEVEL ",I0,"; GOING ", $ "INTO NEXT LEVEL WITH ILC=",I0)', ILVL,ILC ENDDO C SET DATA LEVEL CATEGORY COUNTERS FOR UPPER-AIR DATA 98 CONTINUE IDATA(37) = ILVL IDATA(38) = IDATS_11 99 CONTINUE IF(IPRINT.GT.1) PRINT'(" NSFC=",I0,"; IDATA(37)=",I0, $ "; IDATA(38)=",I0)', NSFC,IDATA(37),IDATA(38) RDATA(1:IDMAX) = RDATX(1:IDMAX) RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UNPKB706 C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2014-03-13 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 (FROM BOTH RADAR CODED C MESSAGE AND FROM LEVEL 2 DECODER). UPPER-AIR DATA ARE THEN FILLED C INTO THE OUTPUT ARRAY AS DATA LEVEL CATEGORY 4. THE OUTPUT ARRAY C HOLDS A SINGLE VAD WIND REPORT IN THE QUASI-IW3UNPBF UNPACKED C FORMAT. C C PROGRAM HISTORY LOG: C 1997-06-02 D. A. KEYSER NP22 - ORIGINAL AUTHOR C 2002-01-28 D. A. KEYSER -- THE WIND Q.M. FOR VAD WINDS LEVELS IS C NOW SET TO THE DECODED QN29 WIND QUALITY MARKER IF IT IS 12 C (REJECT LIST) OR 14 (SDM PURGE), OTHERWISE IT IS SET TO THE C NUMERICAL INDICATOR FOR THE DECODED RMS VECTOR WIND ERROR C (BEFORE THE ON29 Q.M. WAS IGNORED) C 2014-03-13 D. A. KEYSER -- MODIFIED TO HANDLE VAD WINDS FROM LEVEL C 2 DECODER (SUBSET "NC002017") {IN ADDITION TO THOSE FROM RADAR C CODED MESSAGE (SUBSET "NC002008")}; MAXIMUM NUMBER OF CAT. 04 C WINDS-BY-HEIGHT LEVELS ALLOWED (EXCLUDING FIRST, SURFACE, LEVEL), C "ILVLMX_04", INCREASED FROM 64 TO 254 TO ACCOUNT FOR MORE LEVELS C IN NEW VAD WINDS FROM LEVEL 2 DECODER C 2020-08-20 J. DONG -- MODIFIED TO HANDLE OTHER VAD WINDS FROM EUROPE C AND NEW ZEALAND (NC002018) C C USAGE: CALL UNPKB706(LUNIT,RDATA,ITP,IRET) C INPUT ARGUMENT LIST: C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE C RDATA - SINGLE NEXRAD (VAD) REPORT IN A QUASI-IW3UNPBF C - UNPACKED FORMAT WITH ONLY HEADER INFORMATION FILLED C - IN (CATEGORY 4 DATA MISSING) C ITP - THE TYPE OF REPORT THAT HAS BEEN DECODED {=5 - C - NEXRAD (VAD) WIND FROM RADAR CODED MESSAGE; =12 - C - NEXRAD (VAD) WIND FROM LEVEL 2 DECODER; =13 - C - NEXRAD (VAD) WIND FROM EUROPE AND NEW ZEALAND} C C OUTPUT ARGUMENT LIST: C RDATA - SINGLE NEXRAD (VAD) REPORT IN A QUASI-IW3UNPBF C - UNPACKED FORMAT WITH CATEGORY 4 INFORMATION FILLED IN C - (ALL DATA FOR REPORT NOW FILLED) C IRET - RETURN CODE AS DESCRIBED IN W3UNPKB7 DOCBLOCK C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY SUBROUTINE W3UNPKB7. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ SUBROUTINE UNPKB706(LUNIT,RDATA,ITP,IRET) C Include parameters common to more than one subroutine C ----------------------------------------------------- include 'inc_w3unpkb7.inc' CHARACTER*25 UAIR1,UAIR2,UAIR3 INTEGER IDATA(IDMAX) INTEGER QFV LOGICAL SKIP_CAT12 REAL(8) UAIR_8(5,255),BMISS,UFBINT2_8(10,255) REAL RMS(0:12),UAIR(5,255),RDATA(*),RDATX(IDMAX) COMMON /PKB7AA/BMISS COMMON /PKB7BB/kdate(8),ldate(8),KTIMCH,IPRINT,SKIP_CAT12 COMMON /PKB7GG/IDATS_04,IDATS_08,IDATS_10,IDATS_11,IDATS_12, $ IDATS_13,IDATS_14,IDATS_15 SAVE EQUIVALENCE (RDATX,IDATA) DATA XMISS/99999./ DATA UAIR1/'HEIT WDIR WSPD QMWN RMSW '/ DATA UAIR2/'HEIT UWND VWND QMWN QFV2 '/ DATA UAIR3/'HEIT WDIR WSPD QMWN QMRK '/ DATA RMS/1.,1.,2.,2.,3.,3.,4.,4.,5.,5.,6.,6.,7./ RDATX(1:IDMAX) = RDATA(1:IDMAX) NSFC = 0 ILVL = 0 ILC = 0 C FIRST CATEGORY 4 DATA 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(IDATS_04+ILC) = RDATX(7) IF(IPRINT.GT.1) PRINT 198, IDATS_04+ILC,RDATX(IDATS_04+ILC) 198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2) IF(RDATX(IDATS_04+ILC).LT.XMISS) NSFC = 1 ILVL = ILVL + 1 ILC = ILC + 5 IF(IPRINT.GT.1) PRINT'(" HAVE COMPLETED LEVEL ",I0," WITH NSFC=", $ I0,"; GOING INTO NEXT LEVEL WITH ILC=",I0)', ILVL,NSFC,ILC UAIR_8 = BMISS IF(ITP.EQ.5) THEN CALL UFBINT(LUNIT,UAIR_8,5,255,NLEV,UAIR1);UAIR=UAIR_8 ELSE IF(ITP.EQ.12) THEN CALL UFBINT(LUNIT,UAIR_8,5,255,NLEV,UAIR2);UAIR=UAIR_8 ELSE IF(ITP.EQ.13) THEN C CALL UFBINT(LUNIT,UAIR_8,5,255,NLEV,UAIR3);UAIR=UAIR_8 CALL UFBSEQ(LUNIT,UFBINT2_8(1,1),10,255,NLEV,'WPLVL') DO I=1,NLEV IF(UFBINT2_8(1,I).LT.BMISS) UAIR(1,I)=UFBINT2_8(1,I) IF(UFBINT2_8(4,I).LT.BMISS) UAIR(2,I)=UFBINT2_8(4,I) IF(UFBINT2_8(5,I).LT.BMISS) UAIR(3,I)=UFBINT2_8(5,I) IF(UFBINT2_8(3,I).LT.BMISS) UAIR(4,I)=UFBINT2_8(3,I) IF(UFBINT2_8(6,I).LT.BMISS) UAIR(5,I)=UFBINT2_8(6,I) ENDDO END IF IF(IPRINT.GT.1) PRINT 1068, NLEV 1068 FORMAT(' THIS REPORT CONTAINS ',I3,' LEVELS OF DATA (NOT ', $ 'INCLUDING BOTTOM -SURFACE- LEVEL)') 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(/'##W3UNPKB7: 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(/'##W3UNPKB7: NO UPPER-AIR DATA ABOVE FIRST (SURFACE) ', $ 'LEVEL PROCESSED FOR THIS REPORT -- NLEV = 0 AND NSFC > 0'/) GO TO 98 END IF C....................................................................... ELSE IF(NLEV.GT.ILVLMX_04) THEN C PROBLEM: THE NUMBER OF DECODED "LEVELS" {EXCLUDING BOTTOM (SURFACE) C LEVEL} IS .GT. LIMIT OF "ILVLMX_04" -- PRINT 2186, NLEV,ILVLMX_04,ILVLMX_04 2186 FORMAT(/'##W3UNPKB7: NUMBER OF UPPER-AIR LEVELS FOR THIS ', $ 'REPORT (=',I3,') EXCEEDS LIMIT OF ',I0,' CAT. 04 LEVELS ', $ '(EXCLUDING BOTTOM, SFC, LVL) -- '/' ONLY FIRST ',I0, $ ' UPPER-AIR LEVELS PLUS THE SURFACE LEVEL WILL BE PROCESSED'/) NLEV = ILVLMX_04 C....................................................................... END IF 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.XMISS) THEN RDATX(IDATS_04+ILC) = NINT(UAIR(1,I)) C ... WE HAVE A VALID CATEGORY 4 DATA LEVEL -- THERE IS A VALID C HEIGHT ILVL = ILVL + 1 ELSE C ... WE DO NOT HAVE A VALID CATEGORY 4 DATA LEVEL -- THERE IS NO C VALID HEIGHT GO ON TO NEXT INPUT LEVEL IF(IPRINT.GT.1) PRINT'(" HEIGHT MISSING ON INPUT LEVEL ", $ I0,", ALL OTHER DATA SET TO MSG ON THIS LEVEL")', I CYCLE END IF IF(IPRINT.GT.1) PRINT 198, IDATS_04+ILC,RDATX(IDATS_04+ILC) C HORIZONTAL WIND DIRECTION (STORED AS REAL) (VAD FROM RADAR C CODED MESSAGE) C HORIZONTAL U-COMP WIND (STORED AS REAL) (VAD FROM LEVEL 2 C DECODER) M = 2 IF(IPRINT.GT.1) PRINT 199, UAIR(2,I),M IF(UAIR(2,I).LT.XMISS) RDATX(IDATS_04+ILC+1) = UAIR(2,I) IF(IPRINT.GT.1) PRINT 198, IDATS_04+ILC+1,RDATX(IDATS_04+ILC+1) C HORIZONTAL WIND SPEED (STORED AS REAL) (VAD FROM RADAR C CODED MESSAGE) C HORIZONTAL V-COMP WIND (STORED AS REAL) (VAD FROM LEVEL 2 C DECODER) M = 3 IF(IPRINT.GT.1) PRINT 199, UAIR(3,I),M IF(UAIR(3,I).LT.XMISS) THEN IF(ITP.EQ.5 .OR. ITP.EQ.13) THEN RDATX(IDATS_04+ILC+2) = NINT(UAIR(3,I)*10.) ELSE IF(ITP.EQ.12) THEN RDATX(IDATS_04+ILC+2) = UAIR(3,I) END IF END IF IF(IPRINT.GT.1) PRINT 198, IDATS_04+ILC+2,RDATX(IDATS_04+ILC+2) C WIND QUALITY MARKER -- C IF SDMEDIT/QUIPS WIND QUALITY MARKER IS 12 (REJECT LIST) OR C 14 (SDM PURGE) THEN THIS VALUE IS STORED; OTHERWISE IT IS C BASED ON CONFIDENCE LEVEL (WHICH IS ITSELF BASED ON RMS C VECTOR WIND ERROR) C (NOTE: THE LATTER IS CONVERTED TO NUMERICAL INDICATOR -- C SEE W3UNPKB7 DOCBLOCK REMARKS 5 FOR UNPACKED VAD WIND C REPORT LAYOUT FOR VALUES) M = 4 IF(IPRINT.GT.1) PRINT 199, UAIR(4,I),M M = 5 IF(IPRINT.GT.1) PRINT 199, UAIR(5,I),M IF(UAIR(4,I).EQ.12.OR.UAIR(4,I).EQ.14) THEN RDATX(IDATS_04+ILC+4) = UAIR(4,I) ELSE IF(UAIR(5,I).LT.XMISS) THEN C ... CONVERT FROM METERS/SEC TO KNOTS IF (ITP.EQ.5) THEN CDAKCDAK KRMS = INT(1.93333 * UAIR(5,I)) KRMS = INT(1.9425 * UAIR(5,I)) CDONG:DEBUG IF(KRMS.GE.0.AND.KRMS.LT.13) THEN RDATX(IDATS_04+ILC+4) = RMS(KRMS) ELSE RDATX(IDATS_04+ILC+4) = 7.0 END IF ELSE IF (ITP.EQ.12) THEN QFV = UAIR(5,I) IF(QFV .EQ. 0) THEN RDATX(IDATS_04+ILC+4) = 1.0 ELSE IF(QFV .EQ. 1.0) THEN RDATX(IDATS_04+ILC+4) = 2.0 ELSE RDATX(IDATS_04+ILC+4) = 7.0 END IF ELSE IF (ITP.EQ.13) THEN QFV = UAIR(5,I) IF(QFV .EQ. 0) THEN RDATX(IDATS_04+ILC+4) = 1.0 ELSE IF(QFV .EQ. 1.0) THEN RDATX(IDATS_04+ILC+4) = 2.0 ELSE RDATX(IDATS_04+ILC+4) = 7.0 END IF END IF END IF IF(IPRINT.GT.1) PRINT 198, IDATS_04+ILC+4,RDATX(IDATS_04+ILC+4) C....................................................................... ILC = ILC + 5 IF(IPRINT.GT.1) PRINT'(" HAVE COMPLETED LEVEL ",I0,"; GOING ", $ "INTO NEXT LEVEL WITH ILC=",I0)', ILVL,ILC ENDDO C SET DATA LEVEL 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) = IDATS_04 END IF IF(IPRINT.GT.1) PRINT'(" NSFC=",I0,"; IDATA(37)=",I0, $ "; IDATA(38)=",I0)', NSFC,IDATA(37),IDATA(38) RDATA(1:IDMAX) = RDATX(1:IDMAX) RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UNPKB707 C PRGMMR: WHITING ORG: EMC DATE: 2015-04-16 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), ADDITIONAL DATA, AND RADIANCES FOR GOES C SOUNDING/RADIANCE REPORT. UPPER-AIR DATA ARE THEN FILLED INTO THE C OUTPUT ARRAY AS DATA LEVEL CATEGORY 12 (SATELLITE SOUNDING), C ADDITIONAL DATA ARE FILLED AS DATA LEVEL CATEGORY 8 (ADDITIONAL C DATA) AND RADIANCE DATA ARE FILLED AS DATA LEVEL CATEGORY 13 C (SATELLITE RADIANCE) THE OUTPUT ARRAY HOLDS A SINGLE GOES SOUNDING C IN THE QUASI-IW3UNPBF UNPACKED FORMAT. C C PROGRAM HISTORY LOG: C 1997-06-05 D. A. KEYSER NP22 - ORIGINAL AUTHOR C ????-??-?? D. A. KEYSER NP22 - ADDED CAT. 13 (RADIANCE) PROCESSING C 2001-04-06 D. A. KEYSER NP22 - CAT. 8 TYPES ARE NO LONGER SCALED, C BUT STORED IN THE SAME UNITS/SCALING AS FOUND UPON INPUT; CAT. 13 C BRIGHTNESS TEMPERATURES ARE NOW STORED AS DEG. K (PRECISE TO C 10**2) RATHER THAN AS DEG. K X 100; NOW SKIPS CAT. 12 LEVELS C WHERE RETRIEVED GEOPOTENTIAL HGHT IS .LE. ELEVATION (LOWEST C RETRIEVED HEIGHT); NOW UNPACKS SURFACE PRESSURE INTO CAT. 8 CODE C FIGURE 262 C 2001-06-19 D. A. KEYSER -- RECOGNIZES BUFR TYPE/SUBTYPE 003/002 AS C GOES 1x1 (HI-RES) DATA, PART OF THE "GOESND" DUMP FILE ("SUBSET" C ADDED TO INPUT ARGUMENT LIST); STORES CLOUD COVER RATHER THAN C CLOUD AMOUNT IN OUTPUT CAT. 8, C.F. 258 FOR GOES HI-RES REPORTS C 2001-07-10 D. A. KEYSER -- NOW KEEPS SEPARATE COUNT OF REPORTS WITH C MISSING # FOV (E.G., CLOUD-TOP REPORTS), BEFORE THESE WERE C GROUPED WITH # FOV 10-25 C 2004-09-09 D. A. KEYSER -- ADDED LOGIC TO HANDLE GOES 1x1 (SFOV) C SOUNDING (RADIANCE/RETRIEVAL) DATA: DOES NOT Q.C. ANY 1x1 DATA C (CLOUD AS BEFORE, BUT NOW ALSO SNDGS) BY NUMBER OF FOV's (STILL C DOES SO FOR NON-RADIANCE 5x5 DATA); FOR GOES PW RETRIEVALS, IF C TPW IS NOT FOUND UNDER LOCAL MNEMONIC "PH2O", NOW LOOKS FOR IT IN C WMO MNEMONIC "TPWT", THIS ALLOWS FOR TRANSITION FROM "PH2O" TO C "TPWT" IN REPORTS IN DUMP FILES (~ MID-2004) AND ALSO ALLOWS C HISTORICAL RERUNS TO READ OLD DUMP FILES C 2006-07-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM BUFR_LISTDUMPS): C 2007-09-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM PREPOBS_PREPDATA): C NUMBER OF FIELDS-OF-VIEW (USED IN Q.C. PROCESSING) IS NOW C OBTAINED FROM WORD 2 OF NEW "RDATA2" ARRAY (HOLDS VALUES DECODED C DIRECTLY FROM BUFR) RATHER FROM WORD 3 OF HEADER IN "RDATA" ARRAY C 2007-09-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM BUFR_LISTDUMPS): C 2007-09-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM PREPOBS_PREPDATA): C HANDLES GOES 1x1 F-O-V SNDGS/RADIANCES IN SUBSET "NC003003"; CODE C FIGURE 258 REFERS ONLY TO CLOUD AMOUNT (HAD ALSO PREVIOUSLY C REFERRED TO CLOUD COVER FOR GOES 1x1 SNDGS - GOES 1x1 AND 5x5 C SNDGS NOW BOTH PROCESS CLOUD AMOUNT) C 2013-02-14 D. A. KEYSER -- FOR ANY "GOESND" OR "GOESFV" DUMP FILES C WITH CENTER TIME 2013022512 OR LATER, NO ATTEMPT IS MADE TO C DECODE GOES SOUNDINGS (PROFILES) AS THESE WERE REMOVED AT THIS C TIME FROM THE 1X1 GOES RADIANCE FILES PROVIDED BY NESDIS C (INGESTED INTO FROM TANK b003/xx003) C 2015-04-16 JWhiting -- RDATA2(25) stores total cloud cover (TOCC) C (present in dumps of GOES cloud reports). C C USAGE: CALL UNPKB707(LUNIT,RDATA,RDATA2,subset,IRET) C INPUT ARGUMENT LIST: C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE C RDATA - SINGLE GOES SNDG REPORT IN A QUASI-IW3UNPBF C - UNPACKED FORMAT WITH ONLY HEADER INFORMATION FILLED C - IN (CATEGORY 12, 8 AND 13 8 DATA MISSING) C RDATA2 - 25-WORD ARRAY CONTAINING ADDITIONAL REPORT DATA NOT C - PRESENT IN RDATA ARRAY (DECODED DIRECTLY FROM BUFR) C - (ONLY WORDS 2 AND 7 FILLED IN - SEE W3UNPKB7 DOCBLOCK C - REMARKS 6 FOR CONTENT) C SUBSET - CHARACTER*8 BUFR MESSAGE TYPE (SAME FOR ALL REPORTS C - IN A COMMON BUFR MESSAGE) C C OUTPUT ARGUMENT LIST: C RDATA - SINGLE GOES SNDG REPORT IN A QUASI-IW3UNPBF C - UNPACKED FORMAT WITH CATEGORY 12, 8 AND 13 C - INFORMATION FILLED IN (ALL DATA FOR REPORT NOW C - FILLED) C IRET - RETURN CODE AS DESCRIBED IN W3UNPKB7 DOCBLOCK C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY SUBROUTINE W3UNPKB7. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ SUBROUTINE UNPKB707(LUNIT,RDATA,RDATA2,subset,IRET) C Include parameters common to more than one subroutine C ----------------------------------------------------- include 'inc_w3unpkb7.inc' character*8 subset CHARACTER*37 CAT8A,CAT8B CHARACTER*48 UAIR1,RAD1 INTEGER IDATA(IDMAX),ICDFG(ILVLMX_08) LOGICAL SKIP_CAT12 REAL(8) UAIR_8(4,255),CAT8_8(12),RTCSF_8,RAD_8(2,255),BMISS REAL(8) TOCC_8 REAL UAIR(4,255),CAT8(ILVLMX_08),SCALE(ILVLMX_08),RDATA(*), $ RDATX(IDMAX),RAD(2,255),ZMISS(ILVLMX_08),RDATA2(25) COMMON /PKB7AA/BMISS COMMON /PKB7BB/KDATE(8),LDATE(8),KTIMCH,IPRINT,SKIP_CAT12 COMMON /PKB7FF/IFOV(4,2),KNTSAT(250:260) COMMON /PKB7GG/IDATS_04,IDATS_08,IDATS_10,IDATS_11,IDATS_12, $ IDATS_13,IDATS_14,IDATS_15 SAVE EQUIVALENCE (RDATX,IDATA) DATA XMISS/99999./,YMISS/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 ZMISS/ 99999., 99999., 99999., 99999., 99999., $ 99999., 99999., 999999., 99999., 99999., $ 99999., 99999., 99999./ DATA ICDFG/ 50, 51, 52, 53, 54, 55, $ 56, 57, 58, 59, 60, 61, 62/ DATA SCALE/ 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, $ 1.0, .01, 1.0, 1.0, 1.0, 1.0, 1.0/ RDATX(1:IDMAX) = RDATA(1:IDMAX) QMFLG = 2.0 IF(SUBSET(8:8).EQ.'1') THEN C ALL NON-RADIANCE 5x5 FOV DATA WILL BE Q.C.'D ACCORDING TO NUMBER OF C FIELDS-OF-VIEW FOR RETRIEVAL: 0-2 --> BAD, 3-9 --> SUSPECT, 10-25 C OR MISSING --> NEUTRAL IF(NINT(RDATA2(2)).LT.3) THEN QMFLG = 13.0 IFOV(1,1) = IFOV(1,1) + 1 ELSE IF(NINT(RDATA2(2)).LT.10.OR.NINT(RDATA2(7)).EQ.1) THEN QMFLG = 3.0 IF(NINT(RDATA2(2)).LT.10) IFOV(2,1) = IFOV(2,1) + 1 END IF IF(NINT(RDATA2(2)).GT.25) THEN IFOV(4,1) = IFOV(4,1) + 1 ELSE IF(NINT(RDATA2(2)).GT.9) THEN IFOV(3,1) = IFOV(3,1) + 1 END IF ELSE C ALL NON-RADIANCE 1x1 FOV DATA GET NEUTRAL Q. MARK REGARDLESS OF C FIELD-OF-VIEW NUMBER (BUT STILL KEEP TRACK OF COUNTS BY FOV) IF(NINT(RDATA2(2)).GT.0.AND.NINT(RDATA2(2)).LT.4) THEN IFOV(NINT(RDATA2(2)),2) = IFOV(NINT(RDATA2(2)),2) + 1 ELSE IFOV(4,2) = IFOV(4,2) + 1 END IF END IF PSFC = XMISS IF(SKIP_CAT12) GO TO 98 ! skip attempt to process soundings if ! center dump date is 2013022512 or later C*********************************************************************** C FILL DATA LEVEL CATEGORY 12 PART OF OUTPUT C*********************************************************************** ILVL = 0 ILC = 0 UAIR_8 = BMISS ELEV = -99999. CALL UFBINT(LUNIT,UAIR_8,4,255,NLEV,UAIR1);UAIR=UAIR_8 IF(IPRINT.GT.1) PRINT 1068, NLEV 1068 FORMAT(' THIS REPORT CONTAINS',I4,' INPUT LEVELS OF SOUNDING ', $ 'DATA') IF(NLEV.EQ.0) THEN C....................................................................... C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO -- if (subset.eq.'NC003002') go to 98 ! Currently all of the ! cloud 1x1 reports ! have none (remove this ! if NESDIS ever combines ! cloud and PW/rad. 1x1's) PRINT 217 217 FORMAT(/'##W3UNPKB7: NO UPPER-AIR (SOUNDING) DATA PROCESSED ', $ 'FOR THIS REPORT -- NLEV = 0'/) GO TO 98 C....................................................................... ELSE IF(NLEV.GT.ILVLMX_12) THEN C PROBLEM: THE NO. OF DECODED "LEVELS" IS .GT. LIMIT OF "ILVLMX_12" -- PRINT 2186, NLEV,ILVLMX_12,ILVLMX_12 2186 FORMAT(/'##W3UNPKB7: NUMBER OF UPPER-AIR LEVELS FOR THIS ', $ 'REPORT (=',I3,') EXCEEDS LIMIT OF ',I0,' CAT. 12 LEVELS -- ', $ 'ONLY FIRST ',I0,' LEVELS WILL BE PROCESSED'/) NLEV = ILVLMX_12 C....................................................................... END IF 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, ELEVATION (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 IF(UAIR(1,I).LT.999999.) PSFC = UAIR(1,I) * 0.01 IF(UAIR(2,1).LT.XMISS) THEN ELEV = UAIR(2,1) ELSE C....................................................................... C PROBLEM: THE ELEVATION IS MISSING -- PRINT 6217 6217 FORMAT(/'##W3UNPKB7: NO UPPER-AIR (SOUNDING) DATA ', $ 'PROCESSED FOR THIS REPORT -- ELEV IS MISSING'/) GO TO 98 C....................................................................... END IF ELSE IF(UAIR(1,I)*0.1.GE.YMISS) 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 ", $ I0,", SKIP THE PROCESSING OF THIS LEVEL")', I CYCLE ELSE IF(UAIR(1,I)*0.01.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 ",I0, $ " IS BELOW GROUND, SKIP THE PROCESSING OF THIS LEVEL")', I CYCLE ELSE IF(UAIR(2,I).LE.ELEV) THEN C WE DO NOT HAVE A VALID CATEGORY 12 LEVEL -- THE INPUT LEVEL C GEOPOTENTIAL HEIGHT IS NOT GREATER THAN THE ELEVATION -- GO ON TO THE C NEXT INPUT LEVEL IF(IPRINT.GT.1) PRINT'(" GEOPOTENTIAL HEIGHT ON INPUT ", $ "LEVEL ",I0," IS .LE. ELEVATION, SKIP THE PROCESSING OF ", $ "THIS LEVEL")', I CYCLE END IF C WE HAVE A VALID CATEGORY 12 LEVEL -- THERE IS A VALID PRESSURE AND C THE GEOPOTENTIAL HEIGHT IS GREATER THAN THE ELEVATION IF(UAIR(1,I)*0.1.LT.XMISS)RDATX(IDATS_12+ILC)=NINT(UAIR(1,I)*0.1) ILVL = ILVL + 1 IF(IPRINT.GT.1) PRINT 198, IDATS_12+ILC,RDATX(IDATS_12+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.XMISS) RDATX(IDATS_12+ILC+1) = NINT(UAIR(2,I)) IF(IPRINT.GT.1) PRINT 198, IDATS_12+ILC+1,RDATX(IDATS_12+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.XMISS) 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.XMISS) $ RDATX(IDATS_12+ILC+2) = NINT((ITMP - 27315) * 0.1) IF(IPRINT.GT.1) PRINT 198, IDATS_12+ILC+2,RDATX(IDATS_12+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.XMISS) $ RDATX(IDATS_12+ILC+3) = NINT((ITMP - 27315) * 0.1) IF(IPRINT.GT.1) PRINT 198, IDATS_12+ILC+3,RDATX(IDATS_12+ILC+3) C GEOPOTENTIAL QUALITY MARKER (STORED AS REAL) RDATX(IDATS_12+ILC+6) = QMFLG IF(IPRINT.GT.1) PRINT 198, IDATS_12+ILC+6,RDATX(IDATS_12+ILC+6) C TEMPERATURE QUALITY MARKER (STORED AS REAL) RDATX(IDATS_12+ILC+7) = QMFLG IF(IPRINT.GT.1) PRINT 198, IDATS_12+ILC+7,RDATX(IDATS_12+ILC+7) C DEWPOINT TEMPERATURE QUALITY MARKER (STORED AS REAL) RDATX(IDATS_12+ILC+8) = QMFLG IF(IPRINT.GT.1) PRINT 198, IDATS_12+ILC+8,RDATX(IDATS_12+ILC+8) C....................................................................... ILC = ILC + 9 IF(I+1.LE.NLEV.AND.IPRINT.GT.1) PRINT'(" HAVE COMPLETED ", $ "LEVEL ",I0,"; GOING INTO NEXT LEVEL WITH ILC=",I0)', ILVL,ILC ENDDO C SET DATA LEVEL CATEGORY COUNTERS FOR CATEGORY 12 (SNDG) DATA IDATA(39) = ILVL 98 CONTINUE IF(IPRINT.GT.1) PRINT'(1X,I0," CAT. 12 LEVELS PROCESSED")', $ IDATA(39) IF(IDATA(39).GT.0) IDATA(40) = IDATS_12 C*********************************************************************** C FILL DATA LEVEL CATEGORY 8 PART OF OUTPUT C WILL ATTEMPT TO FILL "ILVLMX_08" (CURRENTLY 13) "LEVELS" C C LVL 1: LIFTED INDEX (DEG. K TO 10**2 PREC. - RELATIVE) -CODE FIG. 250 C LVL 2: TOTAL COLUMN PRECIP. WATER (MM TO 10**1 PREC.) - CODE FIG. 251 C LVL 3: 1. TO .9 SIGMA LYR P.WATER (MM TO 10**1 PREC.) - CODE FIG. 252 C LVL 4: .9 TO .7 SIGMA LYR P.WATER (MM TO 10**1 PREC.) - CODE FIG. 253 C LVL 5: .7 TO .3 SIGMA LYR P.WATER (MM TO 10**1 PREC.) - CODE FIG. 254 C LVL 6: SKIN TEMPERATURE (DEG. K TO 10**2 PREC.) ------- CODE FIG. 255 C LVL 7: CLOUD TOP TEMPERATURE (DEG. K TO 10**2 PREC.) -- CODE FIG. 256 C LVL 8: CLOUD TOP PRESSURE (MB TO 10**1 PREC.) --------- 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. TO 10**2 PREC.) C -- CODE FIG. 260 C LVL 12: SATELLITE ZENITH ANGLE (ELEV) (DEG. TO 10**2 PREC.) C -- CODE FIG. 261 C LVL 13: SURFACE PRESSURE (MB TO 10**1 PREC.) ----------- CODE FIG. 262 C C IF DATA ONE ANY LEVEL ARE MISSING, THAT LEVEL IS NOT PROCESSED C*********************************************************************** ILVL = 0 ILC = 0 CAT8_8 = BMISS nlev8 = 0 CALL UFBINT(LUNIT,CAT8_8,12,1,NLEV8,CAT8A//CAT8B) C Get total cloud cover for GOES cloud reports (in msg type NC003002) C ------------------------------------------------------------------- CALL UFBINT(LUNIT,TOCC_8,1,1,NRET,'TOCC') RDATA2(25)=TOCC_8 C Sometime in mid-2004, "TPWT" will replace "PH2O" for tpw - if one C is missing, look for the other (for historical reruns) C ----------------------------------------------------------------- IF(IBFMS(CAT8_8(2)).NE.0) $ CALL UFBINT(LUNIT,CAT8_8(2),1,1,LLEV8,'TPWT') CAT8(1:12)=CAT8_8 CAT8(13) = PSFC IF(NLEV8.NE.1) THEN IF(NLEV8.EQ.0) THEN C....................................................................... C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO -- PRINT 318 318 FORMAT(/'##W3UNPKB7: 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(/'##W3UNPKB7: 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 = BMISS 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.XMISS) ITCSF = NINT(RTCSF) IF(IPRINT.GT.1) PRINT 1798, ITCSF 1798 FORMAT(5X,'ITCSF IS: ',I10) C LOOP THROUGH THE "ILVLMX_08" POSSIBLE ADDITIONAL DATA "LEVELS" DO M = 1,ILVLMX_08 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.ZMISS(M)) THEN C WE HAVE A VALID CATEGORY 8 DATA "LEVEL" ILVL = ILVL + 1 C STORE THE DATUM IN WORD 1 OF THE CAT. 8 DATA LEVEL RDATX(IDATS_08+ILC) = CAT8(M)*SCALE(M) IF(IPRINT.GT.1) PRINT 198, IDATS_08+ILC,RDATX(IDATS_08+ILC) C STORE THE CAT. 8 CODE FIGURE IN WORD 2 OF THE CAT. 8 DATA LEVEL RDATX(IDATS_08+ILC+1) = REAL(200+ICDFG(M)) IF(IPRINT.GT.1)PRINT 198,IDATS_08+ILC+1,RDATX(IDATS_08+ILC+1) C STORE THE DATUM QUALITY MARKER IN WORD 3 OF THE CAT. 8 DATA LEVEL RDATX(IDATS_08+ILC+2) = QMFLG C IF THIS DATUM IS SKIN TEMPERATURE AND THE TEMPERATURE CHANNEL C SELECTION FLAG IS BAD (.NE. 0), SET QUALITY MARKER TO 13.0 (BAD) IF(M.EQ.6.AND.ITCSF.NE.0) RDATX(IDATS_08+ILC+2) = 13.0 IF(IPRINT.GT.1)PRINT 198,IDATS_08+ILC+2,RDATX(IDATS_08+ILC+2) C....................................................................... ILC = ILC + 4 IF(M.LT.ILVLMX_08.AND.IPRINT.GT.1) PRINT'(" HAVE COMPLETED", $ " OUTPUT LVL",I0,"; GOING INTO NEXT INPUT DATUM WITH ILC=", $ I0)', ILVL,ILC ELSE IF(IPRINT.GT.1) PRINT'(" DATUM MISSING ON INPUT ",I0, $ ", GO ON TO NEXT INPUT DATUM (NO. LVLS PROCESSED SO FAR=", $ I0,"; ILC=",I0,")")', M,ILVL,ILC END IF ENDDO C SET DATA LEVEL CATEGORY COUNTERS FOR CATEGORY 8 (ADD'L) DATA IDATA(27) = ILVL 99 CONTINUE IF(IPRINT.GT.1) PRINT'(1X,I0," CAT. 08 LEVELS PROCESSED")', $ IDATA(27) IF(IDATA(27).GT.0) IDATA(28) = IDATS_08 C*********************************************************************** C FILL DATA LEVEL CATEGORY 13 PART OF OUTPUT (RADIANCES) C*********************************************************************** ILVL = 0 ILC = 0 RAD_8 = BMISS CALL UFBINT(LUNIT,RAD_8,2,255,NLEV13,RAD1);RAD=RAD_8 IF(IPRINT.GT.1) PRINT 2068, NLEV13 2068 FORMAT(' THIS REPORT CONTAINS',I4,' INPUT LEVELS (CHANNELS) OF ', $ 'RADIANCE DATA') IF(NLEV13.EQ.0) THEN C....................................................................... C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO -- if (subset.eq.'NC003002') go to 100 ! Currently all of the ! cloud 1x1 reports ! have none (remove this ! if NESDIS ever combines ! cloud and PW/rad. 1x1's) PRINT 417 417 FORMAT(/'##W3UNPKB7: NO RADIANCE DATA PROCESSED FOR THIS ', $ 'REPORT -- NLEV13 = 0'/) GO TO 100 C....................................................................... ELSE IF(NLEV13.GT.ILVLMX_13) THEN C PROBLEM: THE NO. OF DECODED "LEVELS" IS .GT. LIMIT OF "ILVLMX_13" -- PRINT 2187, NLEV13,ILVLMX_13,ILVLMX_13 2187 FORMAT(/'##W3UNPKB7: NUMBER OF RADIANCE CHANNELS FOR THIS ', $ 'REPORT (=',I3,') EXCEEDS LIMIT OF ',I0,' CAT. 13 CHANNELS ', $ '-- ONLY FIRST ',I0,' CHANNELS WILL BE PROCESSED'/) NLEV13 = ILVLMX_13 C....................................................................... END IF 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.YMISS) THEN C WE DO NOT HAVE A VALID CATEGORY 13 DATA LEVEL -- THERE IS NO VALID C CHANNEL NUMBER -- GO ON TO NEXT INPUT LEVEL IF(IPRINT.GT.1) PRINT'(" CHANNEL NUMBER MISSING ON INPUT", $ " LEVEL ",I0,", SKIP THE PROCESSING OF THIS LEVEL")', I CYCLE END IF C WE HAVE A VALID CATEGORY 13 DATA LEVEL -- THERE IS A VALID CHANNEL C NUMBER IDATA(IDATS_13+ILC) = NINT(RAD(1,I)) ILVL = ILVL + 1 IF(IPRINT.GT.1) PRINT 197, IDATS_13+ILC,IDATA(IDATS_13+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.XMISS) RDATX(IDATS_13+ILC+1) = RAD(2,I) IF(IPRINT.GT.1) PRINT 198, IDATS_13+ILC+1,RDATX(IDATS_13+ILC+1) C QUALITY MARKERS (STORED AS REAL) -- CURRENTLY HARDWIRED TO 2.0 C (NEUTRAL - DEFAULT) RDATX(IDATS_13+ILC+2) = 2.0 IF(IPRINT.GT.1) PRINT 198, IDATS_13+ILC+2,RDATX(IDATS_13+ILC+2) C....................................................................... ILC = ILC + 3 IF(I+1.LE.NLEV13.AND.IPRINT.GT.1) PRINT'(" HAVE COMPLETED ", $ "LEVEL ",I0,"; GOING INTO NEXT LEVEL WITH ILC=",I0)', ILVL,ILC 210 CONTINUE ENDDO C SET CATEGORY COUNTERS FOR DATA LVL CATEGORY 13 (RADIANCE) DATA IDATA(41) = ILVL 100 CONTINUE IF(IPRINT.GT.1) PRINT'(1X,I0," CAT. 13 LEVELS PROCESSED")', $ IDATA(41) IF(IDATA(41).GT.0) IDATA(42) = IDATS_13 IF(IDATA(27)+IDATA(39)+IDATA(41).EQ.0) IRET = 5 IF(IPRINT.GT.1) PRINT'(" IDATA(39)=",I0,"; IDATA(40)=",I0, $ "; IDATA(27)=",I0,"; IDATA(28)=",I0,"; IDATA(41)=",I0, $ "; IDATA(42)=",I0)', IDATA(39),IDATA(40),IDATA(27),IDATA(28), $ IDATA(41),IDATA(42) RDATA(1:IDMAX) = RDATX(1:IDMAX) RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UNPKB709 C PRGMMR: JWhiting ORG: EMC DATE: 2016-08-15 C C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE C GPS-IPW (INTEGRATED PRECIPITABLE WATER) DATA. GPS-IPW DATA ARE C THEN FILLED INTO THE OUTPUT ARRAY AS DATA LEVEL CATEGORY 14. THE C OUTPUT ARRAY HOLDS A SINGLE GPS-IPW REPORT IN THE QUASI-IW3UNPBF C UNPACKED FORMAT. C C PROGRAM HISTORY LOG: C 2002-07-03 D. A. KEYSER NP22 - ORIGINAL AUTHOR C 2016-08-15 JWhiting - Added variable 'subset' to arg list; tested C on 'subset' to determine if new GNSS/GPS-Met zenith total delay C data fields need to be read (this replaces potentially ambiguous C test on missing TDEL data from previous GPS-IPW data streams). C C USAGE: CALL UNPKB709(LUNIT,RDATA,SUBSET) C INPUT ARGUMENT LIST: C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE C RDATA - SINGLE GPS-IPW REPORT IN A QUASI-IW3UNPBF UNPACKED C - FORMAT WITH ONLY HEADER INFORMATION FILLED IN (ALL C - OTHER DATA REMAINS MISSING) C SUBSET - CHARACTER*8 BUFR MESSAGE TYPE (SAME FOR ALL REPORTS C - IN A COMMON BUFR MESSAGE) C C OUTPUT ARGUMENT LIST: C RDATA - SINGLE GPS-IPW REPORT IN A QUASI-IW3UNPBF UNPACKED C - FORMAT WITH GPS-IPW INFORMATION FILLED IN (ALL DATA C - FOR REPORT NOW FILLED) C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY SUBROUTINE W3UNPKB7. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ SUBROUTINE UNPKB709(LUNIT,RDATA,subset) C Include parameters common to more than one subroutine C ----------------------------------------------------- include 'inc_w3unpkb7.inc' CHARACTER*50 CAT14S character*8 subset INTEGER IDATA(IDMAX) LOGICAL SKIP_CAT12 REAL(8) CAT14_8(10),BMISS,gnssrpsq_8(6,255) REAL CAT14(10),RDATA(*),RDATX(IDMAX) COMMON /PKB7AA/BMISS COMMON /PKB7BB/kdate(8),ldate(8),KTIMCH,IPRINT,SKIP_CAT12 COMMON /PKB7GG/IDATS_04,IDATS_08,IDATS_10,IDATS_11,IDATS_12, $ IDATS_13,IDATS_14,IDATS_15 SAVE EQUIVALENCE (RDATX,IDATA) DATA XMISS/99999./ DATA CAT14S/'PRES TMDB REHU TPWT TDEL ETDL HSDL EHSD WMTM WDMF '/ RDATX(1:IDMAX) = RDATA(1:IDMAX) CAT14_8 = BMISS CALL UFBINT(LUNIT,CAT14_8,10,1,NLEV,CAT14S);CAT14=CAT14_8 IF(NLEV.NE.1) THEN C....................................................................... C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED -- PRINT 217, NLEV 217 FORMAT(/'##W3UNPKB7: THE NUMBER OF DECODED "LEVELS" (=',I5,') ', $ 'IS NOT WHAT IS EXPECTED (1) - NO GPS-IPW DATA PROCESSED'/) GO TO 99 C....................................................................... END IF C STATION PRESSURE (STORED AS REAL - MB TO 10**1 PRECISION) M = 1 IF(IPRINT.GT.1) PRINT 199, CAT14(M),M 199 FORMAT(5X,'CAT14 HERE IS: ',F17.4,'; INDEX IS: ',I3) IF((CAT14(M)*0.01).LT.XMISS) RDATX(IDATS_14) = CAT14(M) * 0.01 NNNNN = IDATS_14 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(IDATS_14) 198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2) C AIR TEMPERATURE (STORED AS REAL - KELVIN TO 10**2 PRECISION) M = 2 if(cat14(m).ge.xmiss) then call ufbint(lunit,cat14_8(m),10,1,nlev,'TMDBST') cat14(m) = cat14_8(m) endif IF(IPRINT.GT.1) PRINT 199, CAT14(M),M IF(CAT14(M).LT.XMISS) RDATX(IDATS_14+1) = CAT14(M) NNNNN = IDATS_14 + 1 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(IDATS_14+1) C RELATIVE HUMIDITY (STORED AS REAL - PERCENT TO 10**0 PRECISION) M = 3 IF(IPRINT.GT.1) PRINT 199, CAT14(M),M IF(CAT14(M).LT.XMISS) RDATX(IDATS_14+2) = CAT14(M) NNNNN = IDATS_14 + 2 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(IDATS_14+2) C TOTAL PRECIPITABLE WATER (STORED AS REAL - MM TO 10**3 PREC.) M = 4 IF(IPRINT.GT.1) PRINT 199, CAT14(M),M IF(CAT14(M).LT.XMISS) RDATX(IDATS_14+3) = CAT14(M) NNNNN = IDATS_14 + 3 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(IDATS_14+3) C ZENITH TOTAL DELAY (STORED AS REAL - M TO 10**4 PRECISION) M = 5 if (subset.eq.'NC012004') then ! new GPS-Met feed call ufbrep(lunit,gnssrpsq_8,6,255,irep, $ 'SCLF PTID BEARAZ ELEV APDS APDE') C ZTD is obtained from "atmospheric path delay in satellite C signal" (m) from replication where azimuth angle is zero deg. C and elevation angle is 90 deg.) C Likewise, the Error in ZTD (used below) is obtained from C "error in atmospheric path delay in satellite signal" (m) from C this same replication. C (slant angles are discarded for now) do jrep = 1,irep if(gnssrpsq_8(3,jrep).eq.0..and.gnssrpsq_8(4,jrep).eq.90.) $ then cat14_8(m:m+1) = gnssrpsq_8(5:6,jrep) cat14(m:m+1) = cat14_8(m:m+1) exit end if enddo end if IF(IPRINT.GT.1) PRINT 199, CAT14(M),M IF(CAT14(M).LT.XMISS) RDATX(IDATS_14+4) = CAT14(M) NNNNN = IDATS_14 + 4 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(IDATS_14+4) C ERROR IN ZENITH TOTAL DELAY (STORED AS REAL - M TO 10**4 PREC.) M = 6 IF(IPRINT.GT.1) PRINT 199, CAT14(M),M IF(CAT14(M).LT.XMISS) RDATX(IDATS_14+5) = CAT14(M) NNNNN = IDATS_14 + 5 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(IDATS_14+5) C HYDROSTATIC DELAY (STORED AS REAL - M TO 10**4 PRECISION) M = 7 IF(IPRINT.GT.1) PRINT 199, CAT14(M),M IF(CAT14(M).LT.XMISS) RDATX(IDATS_14+6) = CAT14(M) NNNNN = IDATS_14 + 6 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(IDATS_14+6) C ERROR IN HYDROSTATIC DELAY (STORED AS REAL - M TO 10**4 PREC.) M = 8 IF(IPRINT.GT.1) PRINT 199, CAT14(M),M IF(CAT14(M).LT.XMISS) RDATX(IDATS_14+7) = CAT14(M) NNNNN = IDATS_14 + 7 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(IDATS_14+7) C WEIGHTED MEAN TEMPERATURE (STORED AS REAL - K TO 10**2 PREC.) M = 9 IF(IPRINT.GT.1) PRINT 199, CAT14(M),M IF(CAT14(M).LT.XMISS) RDATX(IDATS_14+8) = CAT14(M) NNNNN = IDATS_14 + 8 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(IDATS_14+8) C WET DELAY MAPPING FUNCTION (STORED AS REAL - C NUMERIC TO 10**3 PRECISION) M = 10 IF(IPRINT.GT.1) PRINT 199, CAT14(M),M IF(CAT14(M).LT.XMISS) RDATX(IDATS_14+9) = CAT14(M) NNNNN = IDATS_14 + 9 IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(IDATS_14+9) C SET DATA LEVEL CATEGORY COUNTERS FOR GPS-IPW DATA IDATA(43) = 1 IDATA(44) = IDATS_14 99 CONTINUE IF(IPRINT.GT.1) PRINT'("IDATA(43)=",I0)', IDATA(43) RDATA(1:IDMAX) = RDATX(1:IDMAX) RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: UNPKB710 C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2004-02-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 NPN OR CAP RASS REPORT. UPPER-AIR DATA ARE THEN C FILLED INTO THE OUTPUT ARRAY AS DATA LEVEL CATEGORY 15. THE OUTPUT C ARRAY HOLDS A SINGLE RASS REPORT IN THE QUASI-IW3UNPBF UNPACKED C FORMAT. C C PROGRAM HISTORY LOG: C 2004-02-02 D. A. KEYSER NP22 - ORIGINAL AUTHOR C C USAGE: CALL UNPKB710(LUNIT,RDATA) C INPUT ARGUMENT LIST: C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE C RDATA - SINGLE RASS REPORT IN A QUASI-IW3UNPBF UNPACKED C - FORMAT WITH ONLY HEADER INFORMATION FILLED IN C - (CATEGORY 15 DATA MISSING) C C OUTPUT ARGUMENT LIST: C RDATA - SINGLE RASS REPORT IN A QUASI-IW3UNPBF UNPACKED C - FORMAT WITH CATEGORY 15 INFORMATION FILLED IN (ALL C - DATA FOR REPORT NOW FILLED) C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C REMARKS: CALLED BY SUBROUTINE W3UNPKB7. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ SUBROUTINE UNPKB710(LUNIT,RDATA) C Include parameters common to more than one subroutine C ----------------------------------------------------- include 'inc_w3unpkb7.inc' CHARACTER*20 CAT15S INTEGER IDATA(IDMAX) LOGICAL SKIP_CAT12 REAL(8) CAT15_8(4,255),BMISS REAL CAT15(4,255),RDATA(*),RDATX(IDMAX) COMMON /PKB7AA/BMISS COMMON /PKB7BB/kdate(8),ldate(8),KTIMCH,IPRINT,SKIP_CAT12 COMMON /PKB7GG/IDATS_04,IDATS_08,IDATS_10,IDATS_11,IDATS_12, $ IDATS_13,IDATS_14,IDATS_15 SAVE EQUIVALENCE (RDATX,IDATA) DATA XMISS/99999./ DATA CAT15S/'HEIT TMVR QMAT NPQC '/ RDATX(1:IDMAX) = RDATA(1:IDMAX) NSFC = 0 ILVL = 0 ILC = 0 C FIRST CATEGORY 15 DATA 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(IDATS_15+ILC) = RDATX(7) IF(IPRINT.GT.1) PRINT 198, IDATS_15+ILC,RDATX(IDATS_15+ILC) 198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2) IF(RDATX(IDATS_15+ILC).LT.XMISS) NSFC = 1 ILVL = ILVL + 1 ILC = ILC + 3 IF(IPRINT.GT.1) PRINT'(" HAVE COMPLETED LEVEL ",I0," WITH NSFC=", $ I0,"; GOING INTO NEXT LEVEL WITH ILC=",I0)', ILVL,NSFC,ILC CAT15_8 = BMISS CALL UFBINT(LUNIT,CAT15_8,4,255,NLEV,CAT15S);CAT15=CAT15_8 IF(IPRINT.GT.1) PRINT 1068, NLEV 1068 FORMAT(' THIS REPORT CONTAINS ',I3,' LEVELS OF DATA (NOT ', $ 'INCLUDING BOTTOM -SURFACE- LEVEL)') 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(/'##W3UNPKB7: 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(/'##W3UNPKB7: NO UPPER-AIR DATA ABOVE FIRST (SURFACE) ', $ 'LEVEL PROCESSED FOR THIS REPORT -- NLEV = 0 AND NSFC > 0'/) GO TO 98 END IF C....................................................................... ELSE IF(NLEV.GT.ILVLMX_15) THEN C PROBLEM: THE NUMBER OF DECODED "LEVELS" {EXCLUDING BOTTOM (SURFACE) C LEVEL} IS .GT. LIMIT OF "ILVLMX_15" -- PRINT 2186, NLEV,ILVLMX_15,ILVLMX_15 2186 FORMAT(/'##W3UNPKB7: NUMBER OF UPPER-AIR LEVELS FOR THIS ', $ 'REPORT (=',I3,') EXCEEDS LIMIT OF ',I0,' CAT. 15 LEVELS ', $ '(EXCLUDING BOTTOM, SFC, LVL) -- '/' ONLY FIRST ',I0, $ ' UPPER-AIR LEVELS PLUS THE SURFACE LEVEL WILL BE PROCESSED'/) NLEV = ILVLMX_15 C....................................................................... END IF 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 - METERS TO 10**0 PREC.) M = 1 IF(IPRINT.GT.1) PRINT 199, CAT15(1,I),M 199 FORMAT(5X,'CAT15 HERE IS: ',F17.4,'; INDEX IS: ',I3) IF(CAT15(1,I).LT.XMISS) THEN RDATX(IDATS_15+ILC) = NINT(CAT15(1,I)) C ... WE HAVE A VALID CATEGORY 15 DATA LEVEL -- THERE IS A VALID C HEIGHT ILVL = ILVL + 1 ELSE C ... WE DO NOT HAVE A VALID CATEGORY 15 DATA LEVEL -- THERE IS C NO VALID HEIGHT GO ON TO NEXT INPUT LEVEL IF(IPRINT.GT.1) PRINT'(" HEIGHT MISSING ON INPUT LEVEL ", $ I0,", ALL OTHER DATA SET TO MSG ON THIS LEVEL")', I CYCLE END IF IF(IPRINT.GT.1) PRINT 198, IDATS_15+ILC,RDATX(IDATS_15+ILC) C VIRTUAL TEMPERATURE (STORED AS REAL - KELVIN TO 10**2 PRECISION) M = 2 IF(IPRINT.GT.1) PRINT 199, CAT15(2,I),M IF(CAT15(2,I).LT.XMISS) RDATX(IDATS_15+ILC+1) = CAT15(2,I) IF(IPRINT.GT.1) PRINT 198, IDATS_15+ILC+1,RDATX(IDATS_15+ILC+1) C QUALITY CODE (STORED AS INTEGER - NUMERIC) C IF SDMEDIT/QUIPS TEMPERATURE QUALITY MARKER IS 12 (REJECT C LIST) OR 14 (SDM PURGE) THEN A VALUE OF 14 IS STORED FOR THE C QUALITY CODE; OTHERWISE THE DECODED QUALITY CODE IS STORED C DIRECTLY M = 3 IF(IPRINT.GT.1) PRINT 199, CAT15(3,I),M M = 4 IF(IPRINT.GT.1) PRINT 199, CAT15(4,I),M IF(CAT15(3,I).EQ.12.OR.CAT15(3,I).EQ.14) THEN IDATA(IDATS_15+ILC+2) = 14 ELSE IF(CAT15(4,I).LT.XMISS) THEN IDATA(IDATS_15+ILC+2) = NINT(CAT15(4,I)) END IF IF(IPRINT.GT.1) PRINT 197, IDATS_15+ILC+2,IDATA(IDATS_15+ILC+2) 197 FORMAT(5X,'IDATA(',I5,') STORED AS: ',I10) C....................................................................... ILC = ILC + 3 IF(IPRINT.GT.1) PRINT'(" HAVE COMPLETED LEVEL ",I0,"; GOING ", $ "INTO NEXT LEVEL WITH ILC=",I0)', ILVL,ILC ENDDO C SET DATA LEVEL CATEGORY COUNTERS FOR UPPER-AIR DATA 98 CONTINUE IDATA(45) = ILVL IDATA(46) = IDATS_15 99 CONTINUE IF(IPRINT.GT.1) PRINT'(" NSFC=",I0,"; IDATA(45)=",I0, $ "; IDATA(46)=",I0)', NSFC,IDATA(45),IDATA(46) RDATA(1:IDMAX) = RDATX(1:IDMAX) RETURN END