C$$$ MAIN PROGRAM DOCUMENTATION BLOCK C C MAIN PROGRAM: BUFR_LISTDUMPS C PRGMMR: DONG ORG: NP22 DATE: 2020-08-20 C C ABSTRACT: LISTS CONTENTS OF A TIME-WINDOWED BUFR DATA DUMP FILE. C THE STANDARD OUTPUT IS IN AN EASY-TO-READ FORMAT. NOTE: THIS C PROGRAM CAN HANDLE EVERY CURRENT BUFR DATA DUMP FILE EXCEPT C FOR RTOVS AND ATOVS. THE ADPUPA DUMP IS SORTED IN ASCENDING C ORDER OF STATION ID. ALL OTHER DATA TYPES ARE CURRENTLY NOT C SORTED. C C PROGRAM HISTORY LOG: C 2000-03-28 D.A. KEYSER -- ORIGINAL AUTHOR C 2000-06-07 D.A. KEYSER -- ADDED SORTING OF ADPUPA DATA IN ASCENDING C ORDER OF STATION ID; USER CAN NOW SPECIFY LAT/LON BOUNDARY FOR C LISTING "UPPER-AIR" (ADPUPA, AIRCAR, AIRCFT, SATWND, SPSSMI) C REPORTS; CAN NOW LIST SSM/I RAIN RATE REPORTS IN EASY-TO-READ C FORMAT; IMPROVED FORMAT FOR LISTING SATWND REPORTS C 2000-09-22 D.A. KEYSER -- ACCOUNTS FOR WIND PROFILER RAINFALL RATE C NOW RETURNED IN PROPER UNITS BY W3UNPKB7; CAN NOW LIST QUIKSCAT C SCATTEROMETER WIND REPORTS IN AN EASY-TO-READ FORMAT C 2000-12-05 D.A. KEYSER -- ACCOUNTS FOR A CHANGE IN CAT. 6 MOISTURE C VARIABLE, NOW SPECIFIC HUMIDITY (FLOATING POINT) IN G/KG RATHER C THAN DEWPOINT DEPRESSION IN X10 DEG. C C 2001-04-06 D.A. KEYSER -- CAN NOW LIST SSM/I SURFACE TEMPERATURE C REPORTS IN EASY-TO-READ FORMAT; UNITS FOR INPUT SSM/I RAIN C RATE CHANGED FROM MM/HR TO MM/SEC (PRECISE TO 10**6) TO ACCOUNT C FOR CHANGE IN IW3UNPBF (STILL LISTED IN UNITS OF MM/HR); UNITS C FOR INPUT SSM/I WIND SPEED, PWATER AND SFC. TEMP. CHANGED FROM C M/S*10, MM*10, K*100, RESP. TO M/S, MM, K WITH FLOATING POINT C PRECISON TO 10**1, 10**1, 10**2, RESP. TO ACCOUNT FOR CHANGE IN C IW3UNPBF; MEAN AND STD. DEV FOR SSM/I PRODUCTS NOW LISTED TO C NEAREST HUNDREDTH UNIT (WAS NEAREST TENTH); CAN NOW PROCESS A C WIND PROFILER DATA DUMP FILE CONTAINING BOTH TYPES 002/007 C (NOAA/FSL) AND 002/009 {THOSE ORIGINATING FROM PILOT (PIBAL) C BULLETINS}; UNITS FOR INPUT GOES BRIGHT. TEMPS, LI, PWATER C (TOTAL AND LAYERS), SKIN TEMP, ZENITH ANGLE (SOLAR AND C SATELLITE), CLOUD TOP TEMP AND CLOUD TOP PRESSURE CHANGED FROM C K*100, K*100, MM*100, K*100, DEG*100, K*100, MB*10, RESP. TO K, C K, MM, K, DEG, K, MB WITH FLOATING POINT PRECISION TO 10**2, C 10**2, 10**2, 10**2, 10**2, 10**2, 10**1, RESP. TO ACCOUNT FOR C CHANGE IN W3UNPKB7; ACCOUNTS FOR CHANGE IN W3UNPKB7 WHICH C RETURNS FULL DATE (YYYYMMDDHH) IN HEADER WORD 5 (WIND PROFILER, C VAD WIND AND GOES RADIANCE/SOUNDING/RETREIVAL REPORTS) AND C SATELLITE ID IN HEADER WORD 6 (GOES RADIANCE/SOUNDING/RETREIVAL C ERS SCATTEROMETER AND QUIKSCAT SCATTEROMETER REPORTS), INCLUDES C SATELLITE ID IN LISTING FOR VALID TYPES; ACCOUNTS FOR CHANGE IN C IW3UNPBF WHICH RETURNS SATELLITE ID IN HEADER WORD 6 (SATWINDS C ONLY), INCLUDES SATELLITE ID IN LISTING FOR SATWINDS; IMPROVED C FORMAT FOR LISTING SSM/I BRIGHTNESS TEMPS; NOW INCLUDES SURFACE C PRESSURE (MB PRECISE TO 10**1) IN LISTING FOR GOES RETRIEVALS C (FROM CAT. 8, CF 262) C 2001-06-19 D.A. KEYSER -- CAN NOW LIST GOES CLOUD TOP REPORTS C CONTAINING CLOUD TOP PRESSURE, CLOUD COVER AND CLOUD TOP C TEMPERATURE WHICH CAN NOW BE PART OF THE "GOESND" DATA DUMP FILE C 2001-08-20 D.A. KEYSER -- ACCOUNTS FOR CHANGE IN W3UNPKB7 WHICH C RETURNS NUMBER OF ORIGINAL REPORTS USED TO GENERATE SUPEROB C (ACAV) IN HEADER WORD 10 (QUIKSCAT ONLY), INCLUDES THIS IN C LISTING FOR QUIKSCAT C 2002-03-05 D.A. KEYSER -- SUBR. W3UNPKB7 ARGUMENT RDATA MUST BE C DIMENSIONED AT LEAST 1200 NOW TO ACCOUNT FOR 64 POSSIBLE WIND C PROFILER LEVELS FROM NOAA/FSL, RDATA INCREASED FROM 800 TO 1200 C IN THIS PROGRAM C 2002-07-05 D.A. KEYSER -- CAN NOW LIST MESONET REPORTS FROM THE C "MSONET" DATA DUMP FILE USING SUBROUTINE LISTSFC AND GPS-IPW C REPORTS FROM THE "GPSIPW" DATA DUMP FILE USING NEW SUBROUTINE C LISTGPSIPW C 2004-02-02 KEYSER -- MODIFIED TO LIST ELEVATION Q.M. IN SUBR. C LISTSFC SINCE SUBR. IW3UNPBF CAN NOW PROCESS MOBILE SURFACE LAND C SYNOPTIC REPORTS OUT OF ADPSFC DUMP FILE; SUBR. IW3UNPBF CAN NOW C PROCESS E-AMDAR AIRCRAFT REPORTS OUT OF THE AIRCFT DUMP FILE; C MODIFIED LISTING OF CATEGORY 8 MESONET DATA (MORE VARIABLES NOW C RETURNED FROM SUBR. IW3UNPBF); ACCOUNTS FOR TRANSITION OF MESONET C REPORTS FROM LOW- TO HIGH-RESOLUTION LAT/LON IN EARLY 2004 (AND C LAT/LON LISTING IN LISTSFC NOW CARRIES FOUR SIGNIFICANT DIGITS C INSTEAD OF TWO); ARRAY SUBSKP BUMPED UP FROM (0:12,200) TO C (0:255,0:200) AND NOW IT CAN ALSO BE READ IN FOR NON-UPA AND NON- C SFC TYPES IN NAMELIST PDATA (ADDED AS A NEW INPUT ARGUMENT IN C W3UNPKB7); ACARS FLIGHT NUMBER NOW STORED IN RESERVE WORD 2 C (CHARACTER) BY IW3UNPBF, SO IT IS LISTED; IW3UNPBF CAN SELECT C DIFFERENT WIND AND HEIGHT ASSIGN. PRESSURE FOR GOES SATWNDS C (ALTHOUGH STILL HARDWIRED TO "FINAL" VALUES); NOW RETURNS NEW C ARRAY "ADATA2" OUT OF CALL TO IW3UNPBF, CURRENTLY JUST 2-WORDS C WHERE WORD 1 IS "RESTRICTIONS ON REDISTRIBUTION" (BUFR F.T. C 0-35-200) AND WORD 2 IS "EXPIRATION OF RESTRICTIONS ON C REDISTRIBUTION" (HRS), THESE ARE CURRENTLY NOT LISTED; SUBR. C W3UNPKB7 ADDED COOPERATIVE AGENCY PROFILER (CAP) (002/011) AND C JAPANESE (002/013) PROFILER WINDS TO PROCESSING FOR WIND C PROFILERS NOT ORIGINATING FROM PILOT (PIBAL) BULLETINS; NOAA C PROFILER NETWORK (NPN) AND COOPERATIVE AGENCY PROFILER (CAP) RASS C REPORTS (002/012) NOW PROCESSED FROM "RASSDA" DATA DUMP FILE BY C SUBR. W3UNPKB7 AND LISTED HERE USING NEW SUBROUTINE LISTRASS; C ADDED LOGIC TO HANDLE FUTURE MODIS (AQUA/TERRA) WINDS IN SUBR. C IW3UNPBF C 2004-09-09 KEYSER -- SUBR. LISTGOESNDGS NO LONGER SELECTS WHAT TO C PRINT SIMPLY BY WHETHER REPORT IS A 1x1 ("H" IN 1ST CHAR. OF C STNID) OR 5x5 REPORT, THIS IS BECAUSE 1x1 REPORTS COULD NOW C CONTAIN BOTH CLOUD REPORTS (AS BEFORE) AND SOUNDING/RADIANCE C REPORTS - SUBR. NOW TESTS FOR MISSING CLOUD DATA TO NOT PRINT C CLOUD INFO, MISSING PSFC AND TPW TO NOT PRINT RETRIEVAL INFO AND C ZERO BRIGHTNESS TEMP LEVELS TO NOT PRINT RADIANCE INFO; NOW C RETURNS 41-WORD (RATHER THAN 2-WORD) ARRAY "ADATA2" OUT OF CALL C TO IW3UNPBF, WHERE WORDS 3-41 CONTAIN ALTIMETER SETTING, SEA- C SURFACE TEMPERATURE, SINGLE-LEVEL SENSIBLE WEATHER ELEMENTS AND C SST Q.M.; RETURNS NEW ARGUMENTS "ADATA3" {(5,255,5)} AND "NDATA3" C {(5)} OUT OF CALL TO IW3UNPBF WHERE ADATA3 CONTAINS MULTIPLE- C LEVEL SENSIBLE WEATHER ELEMENTS AND NDATA3 DEFINES THE NUMBER OF C LEVELS OF DATA IN THE ADATA3(X,Y,1), ADATA3(X,Y,2), C ADATA3(X,Y,3), ADATA3(X,Y,4) AND ADATA3(X,Y,5) ARRAYS (SEE C IW3UNPBF DOCBLOCK FOR MORE INFO) - THESE ARRAYS ARE PRINTED IN C LISTUPA AND LISTSFC; INFORMATION THAT HAD BEEN IN CATEGORIES 7, C 51, 52 AND 8 RETURNED FROM IW3UNPBF BUT IS NOW RETURNED IN ADATA2 C AND ADATA3 IS NOW IGNORED IN LISTUPA AND LISTSFC (IT IS NOW C MISSING - RESERVED); NO ATTEMPT IS MADE IN LISTUPA TO PRINT DATA C IN CATEGORY 7 SINCE IT IS NO LONGER CONSIDERED IN IW3UNPBF; NO C ATTEMPT IS MADE IN LISTSFC TO PRINT DATA IN CATEGORY 52 SINCE IT C IS LONGER CONSIDERED IN IW3UNPBF C 2005-03-14 KEYSER -- NOW PRINTS QI W/ FCST AND QI W/O FCST FOR CAT 6 C SATELLITE WIND REPORTS (READ FROM CAT 8 C.F. 356 AND 357, RESP.) C (RFF FROM CAT 8 C.F. 355 STILL PRINTED AS WELL) C 2006-07-14 D. A. KEYSER -- BUMP UP ARRAY SIZE FOR UNPACKED REPORT C FROM IW3UNPBF FROM 2500 TO 3000; CAN NOW LIST WINDSAT C SCATTEROMETER REPORTS FROM THE "WDSATR" DATA DUMP FILE USING C SUBROUTINE LISTWNDSAT; INCREASED THE MAXIMUM NUMBER OF ADPUPA C REPORTS THAT CAN BE SORTED FROM 1200 TO 20000; MODIFIED TO HANDLE C RETURN OF NEW ARGUMENT "RDATA2" FROM CALLS TO W3UNPKB7 [1-DIM C 21-WORD ARRAY WHICH HOLDS ADDITIONAL VALUES DECODED DIRECTLY FROM C BUFR (AND NOT IN "RDATA" ARRAY), FOR SOME PARAMETERS REPLACING C WHAT HAD BEEN RETURNED IN "RDATA" ARRAY (IN THE HEADER)]; NO C LONGER PRINTS EDITION NUMBER IN LISTING OF WIND PROFILER REPORTS C (WAS ALWAYS HARDWIRED TO 2) C 2007-09-14 D. A. KEYSER -- BUMP UP ARRAY SIZE FOR UNPACKED REPORT C FROM IW3UNPBF FROM 3000 TO 3500; INCLUDES NESDIS PERCENT C CONFIDENCE BASED ON EXPECTED ERROR (Q.C.) (READ FROM CAT. 8 CODE C FIGURE 358) IN LISTING FOR CAT. 6 SATELLITE-DERIVED WIND REPORTS; C EXPANDED ARRAYS ADATA3 FROM (5,255,5) TO (5,255,7) AND NDATA3 C FROM (5) TO (7) (RETURNED OUT OF CALL TO IW3UNPBF) TO ACCOUNT FOR C PROCESSING/LISTING OF ADDITIONAL MULTIPLE-LEVEL SENSIBLE WEATHER C ELEMENTS CONTAINING SEQUENCES OF AIRFRAME ICING, HEIGHT OF BOTTOM C AND TOP OF ICING LAYER (IN RECCOS, PIREPS, E-AMDAR, CANADIAN C AMDAR, TAMDAR), AND DEGREE OF TURBULENCE, HEIGHT OF BOTTOM AND C TOP OF TURBULENCE LAYER (IN RECCOS AND ALL AIRCRAFT), THE C EXPANDED TURBULENCE INFORMATION REPLACES THE SINGLE DEGREE OF C TURBULENCE VALUE WHICH HAD BEEN RETURNED FROM IW3UNPBF IN CAT. 8, C CODE FIGURE 916; ACCOUNTS FOR GOES 1x1 SNDG/RETR/RADIANCES IN C DUMP FILE "GOESFV"; ALL PRINT STATEMENTS NOW FORMATTED TO PRINT C OBS TIME TO NEAREST 0.00001 HR (WAS TO NEAREST 0.001 HOUR - C CHANGED BECAUSE PREPBUFR NOW ENCODES OBS TIME TO THIS PRECISION); C IMPROVED DOCUMENTATION AT TOP OF LISTINGS FOR "ADPUPA", "AIRCFT", C "AIRCAR", "SATWND", "ADPSFC", "MSONET", "SFCSHP", "SFCBOG" AND C "GOESND" DUMPS; CORRECTED ERROR WHICH PREVENTED "SFCBOG" PMSL C FROM BEING LISTED C 2008-04-10 D. A. KEYSER -- CHANGE IN SUBROUTINE IW3UNPBF TO HANDLE C RADIOSONDE TYPES > 99 WHICH WILL SOON BE INTRODUCED INTO THE BUFR C DATABASE (BASED ON NOVEMBER 2007 WMO BUFR UPDATE) C 2008-09-12 D. A. KEYSER -- MODIFIED TO RECOGNIZE THAT TAMDAR REPORTS C CAN NOW APPEAR IN "aircft" DUMP MESSAGE TYPES NC004012 (PENAIR) C AND NC004013 (CHAUTAUQUA) IN ADDITION TO MESSAGE TYPE NC004008 C (MESABA) C 2008-09-25 D. A. KEYSER -- BUMPED UP ARRAY SIZE FOR "ADATA2", C RETURNED OUT OF CALL TO IW3UNPBF, FROM 41 TO 42, NEW WORD 42 C HOLDS ACARS MOISTURE QUALITY WHICH IS NOW LISTED; BUMPED UP ARRAY C SIZE FOR "RDATA2", RETURNED OUT OF CALL TO W3UNPKB7, FROM 21 TO C 24, WHERE NEW WORDS 22-24 HOLD NEW ASCAT VARIABLES WIND VECTOR C CELL QUALITY, BACKSCATTER DISTANCE AND LIKELIHOOD COMPUTED FOR C SOLUTION; HANDLES "REPROCESSED" ASCAT WINDS IN "ascatw" DUMP C FILE C 2010-06-07 D. A. KEYSER -- ADDED LISTING OF ALTIMETER Q.M. FOR C ADPSFC REPORTS SINCE THIS CAN NOW BE PRESENT IN SOME CASES FOR C METARS (CURRENTLY WHEN SDMEDIT PRESSURE Q.M. IS 12 OR 14 IN C WHICH CASE IW3UNPBF STORES THIS AS ALTIMETER Q.M.) C 2012-11-27 D. A. KEYSER -- ALLOW REPORT SEQUENCE NUMBER (CAT. 8, C CODE FIG. 21) TO NOW BE AS LARGE AS 999999 IN UPPER-AIR LISTING C (ALL OTHER CODE FIGS. UPPER LIMIT REMAINS 99999) (NEEDED BECAUSE C THERE CAN NOW BE > 99999 MDCRS REPORTS IN A MONOLITHIC "AIRCAR" C DUMP FILE, PRIOR TO THIS VALUE WAS LISTED AS LIMIT OF 99999 FOR C ALL REPORTS WITH SEQUENCE NUMBER > 99999) C 2013-02-14 D. A. KEYSER -- CHANGES TO RUN ON WCOSS; ADDED CALL TO C BUFRLIB ROUTINE SETBMISS(10E08_8) TO RESET BMISS TO A VALUE C (10E08_8) WHICH WILL NOT CAUSE INTEGER OVERFLOW WHICH CAN BE C UNPREDICTABLE (PRIOR BMISS VALUE WAS 10E10_8); PASS BMISS VIA C COMMON BLOCK RATHER THAN HARDWIRING IT TO 10E08_8 IN MANY C DIFFERENT SUBROUTINES; USE FORMATTED PRINT STATEMENTS WHERE C PREVIOUSLY UNFORMATTED PRINT WAS USED (WCOSS SPLITS UNFORMATTED C PRINT AT 80 CHARACTERS) C 2014-04-22 D. A. KEYSER -- BUMPED UP ARRAY SIZE FOR "ADATA2", C RETURNED OUT OF CALL TO IW3UNPBF, FROM 42 TO 43, NEW WORD 43 C HOLDS SATELLITE ZENITH ANGLE (DEGREES, SATWND TYPES ONLY) WHICH C IS NOW LISTED; ADDED OPTION TO SORT LISTING OF "ADPSFC" DUMP BY C REPORT ID AND WITHIN REQUESTED OBS TIME (HARDWIRED TO NOT DO C SORTING). ABORTS WITH RC=65 IF > 40000 ADPSFC REPORTS (EXCEEDS C SORT LIMIT). PRINTING FORMAT CHANGED FOR SOME TYPES TO SQUEEZE C MORE INFORMATION ON A LINE. CHANGES TO ALLOW FOR LISTING OF NEW C VAD WIND REPORTS FROM LEVEL 2 DECODER. ARRAY RDATA RETURNED FROM C W3UNPKB7 INCREASED FROM 1200 TO 2500 WORDS (IDATA WHICH IS C EQUIVALENCED TO RDATA INCREASED AS WELL). C 2015-01-30 D. A. KEYSER -- In subr. LISTUPA, the key of SATWND data C listed updated to include new instrument type 19 {IR (short-wave) C imager automated winds (high density)}. C 2015-03-09 D. A. KEYSER -- In subr. LISTUPA, for aircraft report C types (only), CBULL (new variable returned from IW3UNPBF) is now C listed (contains WMO bulletin header and originator) in place of C header character reserve word 1 (which only contained WMO C bulletin originator in characters 1-4) (key for AIRCAR and AIRCFT C data updated). C 2015-04-16 D. A. KEYSER -- In subr. LISTGOESNDGS, now correctly lists C total cloud cover from GOES cloud reports in dump file "goesnd" C as the value of TOCC from RDATA2(25) passed from W3UNPKB7 (had C looked for it in cat 8 c.f. 258 passed in from W3UNPKB7 in RDATA C array but this was changed long ago to hold cloud amount and not C total cloud cover, and the former is missing in GOES cloud C reports). RDATA2 is expanded to size 25 in W3UNPKB7 in order to C store TOCC, and this is accounted for here in listdumps.f C 2015-12-18 D. A. Keyser -- Listing of total zenith delay from "gpsipw" C dump in whole cm is now rounded rather than truncated. Listing of C hydrostatic delay from "gpsipw" dump in whole cm is now rounded C rather than truncated. Listing from "gpsipw" dump now denotes C total zenith delay as "ZTD" rather than "TDEL" and error in total C zenith delay as "eZTD" rather than as "ETDL". C 2016-08-28 D. A. Keyser -- In subr. LISTGPSIPW, now lists lat and lon C to nearest 0.00001 degree rather than to nearest 0.01 degree. New C WMO format GNSS ground-based data (in dump file "gpsipw" under C subset 'NC012004) stores CLATH/CLONH rather than CLAT/CLON as with C previous production non-standard BUFR format GPS ground-based data C from GSD (had been in dump file "gpsipw" under subset 'NC012003). C 2016-02-09 S. MELCHIOR -- Adjusted code to accommodate the processing C of three new aircraft data types: Korean AMDAR (BUFR), Catch-All C AMDAR (BUFR) and TAMDAR (Panasonic/AirDAT BUFR). Latitude, C longitude, and moisture are available in higher precision in new C version 7 BUFR format (for Catch-All AMDAR, MDCRS and E-AMDAR) so C print statements for dumps from "aircar", "aircft" and "adpupa" C (latter for future) in subr. LISTUPA were modified to account for C increased precision (only lat/lon for "adpupa") (lat/lon format C changed to list 5 significant digits instead of 2; moisture format C changed to list 6 significant digits instead of 3). All C references to E-ADAS have been changed to E-AMDAR. C 2016-11-25 D. A. KEYSER -- All in subr. LISTUPA: Correct info in "KEY C FOR DATA LISTED" printout for AIRCFT types. For TAMDAR from C Panasonic or AirDAT only, lists "observer identification" (OBSVR, C returned from IW3UNPBF in bytes 1-4 of header reserve character C word 1) (due to change in both this code and in subr. IW3UNPBF), C lists "type of commercial aircraft" (ACTP, returned from IW3UNPBF C in header reserve character word 2) (due solely to change in subr. C IW3UNPBF), and lists instantaneous altitude rate (IALR, returned C from IW3UNPBF in cat.8 c.f. 932) (due solely to change in subr. C IW3UNPBF). For AMDAR types other than European, Canadian and C Korean originating from BUFR (referred to as "Catch-all" AMDAR) C lists "aircraft flight number" (ACID, returned from IW3UNPBF in C header reserve character word 2) (due solely to change in subr. C IW3UNPBF). C 2016-11-30 D. A. KEYSER -- Reads new output real, double-precision C argument arrays ADATA_8 and RDATA8_8, both of length 2, in calls C to IW3UNPBF and W3UNPKB7, resp. This returns latitude and C longitude for each report which is then stored in R*8 variables C ALAT_8 and ALON_8 prior to listing for the following dump types: C AIRCFT, AIRCAR and ADPUPA in subr. LISTUPA; ADPSFC, SFCSHP and C MSONET in subr. LISTSFC (also here format changed to list 5 C significant digits instead of 4); ASCATW in subr. LISTQKSWND (also C here format changed to list 5 significant digits instead of 2); C and GPSIPW in subr. LISTGPSIPW (already lists to 5 significant C digits). C BENEFIT: Replaces lat/lon returned in ADATA(1:2) and RDATA(1:2) in C calls to IW3UNPBF and W3UNPKB7, resp. for these types, C which are just at machine precison (normally R*4). Now C that reports in these dumps can store lat/lon at 0.00001 C degree precision (e.g., AIRCFT and AIRCAR dumps with C switch to v7 BUFR), this change will ensure that lat/lon C is always accurate to 0.00001 degrees in these listings. C 2017-10-13 D. A. KEYSER -- Added minutes to every print statement C that includes the central dump time. Central dump time minutes is C obtained from Section 1 of first (dummy) message of input dump C file via call to BUFRLIB routine IUPVS01. C BENEFIT: Until now, central dump time minutes was always zero. C However, with the implementation of the new RTMA_RU, C central dump time can now also have minutes = 15, 30 C or 45 (since the RTMA_RU runs 4 times per hour). This C change allows the print statements to reflect this new C center dump time format. C 2018-03-28 D. A. KEYSER -- In subr. LISTUPA: For SATWND types, prints C lat and lon to nearest 0.00001 degree for GOES-16 and up reports C since these have high-res lat/lon in their tanks. All other C SATWND types continue to print lat and lon to nearest 0.01 degree C since they still have low-res lat/lon in their tanks (however the C format statement is modified to add three blanks after the lat and C lon to keep the alignment correct between GOES-16 and up reports C and all other wind reports). C 2020-08-20 S. MELCHIOR -- In subr. LISTSFC, accommodate BUFR format C buoy data. C 2021-06-24 S. MELCHIOR -- In subr. LISTSFC, accommodate BUFR format C ship and cman data. C C USAGE: C INPUT FILES: C UNIT 05 - INPUT DATA CARDS IN THE FORM OF A NAMELIST (SEE C - REMARKS) C UNIT 21 - BUFR DATA SET C C OUTPUT FILES: C UNIT 06 - STANDARD OUTPUT PRINT C C SUBPROGRAMS CALLED: C UNIQUE: - LISTUPA LISTSFC LISTPROFILER C - LISTVADWIND LISTGOESNDGS LISTERSCAT C - LISTQKSWND LISTGPSIPW LISTRASS C - LISTWNDSAT INDEXC IW3UNPBF C - W3UNPKB7 WORDLENGTH C LIBRARY: C W3NCO - W3TAGB W3TAGE ERREXIT C W3EMC - ORDERS C BUFR - UPFTBV SETBMISS GETBMISS iupvs01 readmg openbf C clospf C C EXIT STATES: C COND = 0 - SUCCESSFUL RUN C = 33 - A REPORT RETURNED FROM IW3UNPBF CONTAINS DATA IN C AN UNPACKED CATEGORY NOT RECOGNIZED BY THIS PROGRAM C = 44 - A REPORT RETURNED FROM IW3UNPBF CONTAINS MORE THAN C ONE LEVEL OF DATA (NOT POSSIBLE FOR SURFACE DATA) C = 55 - .GT. 20000 ADPUPA REPORTS, EXCEEDS SORT LIMIT C = 65 - .GT. 40000 ADPSFC REPORTS, EXCEEDS SORT LIMIT C = 88 - INPUT BUFR DATA DUMP DATA SET NAME NOT RECOGNIZED C = 99 - ERROR RETURNING A PARTICULAR REPORT FROM THE BUFR C FILE VIA IW3UNPBF C C REMARKS: C C C VARIABLES READ IN NAMELIST "RDATA": C C DSNAME_LC - CHARACTER*8 DATA SET NAME (E.G, "adpupa", "sfcshp") C C C VARIABLES READ IN NAMELIST "UDATA" (APPLIES ONLY FOR CALLS TO C LISTUPA): C C ITWINB - TIME WINDOW RELATIVE TO CYCLE TIME FOR ACCEPTING EARLIEST C REPORTS; UNITS ARE HUNDREDTHS OF AN HOUR (E.G., -150 C MEANS EARLIEST POSSIBLE TIME FOR ACCEPTING REPORTS IS C 1.5-HOURS PRIOR TO CYCLE TIME). (DEFAULT=-600) C ITWINA - TIME WINDOW RELATIVE TO CYCLE TIME FOR ACCEPTING LATEST C REPORTS; UNITS ARE HUNDREDTHS OF AN HOUR (E.G., +400 C MEANS LATEST POSSIBLE TIME FOR ACCEPTING REPORTS IS C 4.0-HOURS AFTER CYCLE TIME). (DEFAULT=+600) C NOTE: THE LIMITS FOR "ITWINB" AND "ITWINA" ARE -600 AND +600, C RESP. IF THESE VALUES ARE USED, THEN IT IS ASSUMED C THAT ALL REPORTS IN THE FILE ARE TO BE PROCESSED C REGARDLESS OF THEIR TIME. C LATS - SOUTHERNMOST LATITUDE FOR ACCEPTING REPORTS; UNITS ARE C HUNDREDTHS OF DEGREE SOUTH (E.G., -4578 MEANS C SOUTHERNMOST LATITUDE IS 45.78 DEG. S) (DEFAULT=-9001) C LATN - NORTHERNMOST LATITUDE FOR ACCEPTING REPORTS; UNITS ARE C HUNDREDTHS OF DEGREE NORTH (E.G., 5051 MEANS C NORTHERNMOST LATITUDE IS 50.51 DEG. N) (DEFAULT= 9001) C LONW - WESTERNMOST LONGITUDE FOR ACCEPTING REPORTS; UNITS ARE C HUNDREDTHS OF DEGREE EAST (E.G., 21534 MEANS C WESTERNMOST LONGITUDE IS 215.34 DEG. E) (DEFAULT= -0001) C LONE - EASTERNMOST LONGITUDE FOR ACCEPTING REPORTS; UNITS ARE C HUNDREDTHS OF DEGREE EAST (E.G., 33034 MEANS C EASTERNMOST LONGITUDE IS 330.34 DEG. E) (DEFAULT= 36001) C SUBSKP - LOGICAL (0:255,0:200) THAT IDENTIFIES THOSE BUFR TYPES/ C SUBTYPES FOR WHICH THE BUFR MESSAGES SHOULD BE SKIPPED C OVER (WITHOUT DECODING REPORTS) IF TRUE (DEFAULT=.FALSE.) C C C VARIABLES READ IN NAMELIST "SDATA" (APPLIES ONLY FOR CALLS TO C LISTSFC): C C LATS - SOUTHERNMOST LATITUDE FOR ACCEPTING REPORTS; UNITS ARE C HUNDREDTHS OF DEGREE SOUTH (E.G., -4578 MEANS C SOUTHERNMOST LATITUDE IS 45.78 DEG. S) (DEFAULT=-9001) C LATN - NORTHERNMOST LATITUDE FOR ACCEPTING REPORTS; UNITS ARE C HUNDREDTHS OF DEGREE NORTH (E.G., 5051 MEANS C NORTHERNMOST LATITUDE IS 50.51 DEG. N) (DEFAULT= 9001) C LONW - WESTERNMOST LONGITUDE FOR ACCEPTING REPORTS; UNITS ARE C HUNDREDTHS OF DEGREE EAST (E.G., 21534 MEANS C WESTERNMOST LONGITUDE IS 215.34 DEG. E) (DEFAULT= -0001) C LONE - EASTERNMOST LONGITUDE FOR ACCEPTING REPORTS; UNITS ARE C HUNDREDTHS OF DEGREE EAST (E.G., 33034 MEANS C EASTERNMOST LONGITUDE IS 330.34 DEG. E) (DEFAULT= 36001) C CHAR1 - ONLY REPORTS WITH STNID BEGINNING WITH THIS CHARACTER ARE C ACCEPTED (E.G., "K" MEANS ONLY U.S. METARS ARE ACCEPTED, C "C" MEANS ONLY CANADIAN METARS ARE EXCEPTED) (DEFAULT IS C "*" WHICH MEANS ALL METARS ARE ACCEPTED) C NOTE: THIS FILTER IS INVOKED AFTER LAT/LON FILTER C ABOVE C SUBSKP - LOGICAL (0:255,0:200) THAT IDENTIFIES THOSE BUFR TYPES/ C SUBTYPES FOR WHICH THE BUFR MESSAGES SHOULD BE SKIPPED C OVER (WITHOUT DECODING REPORTS) IF TRUE (DEFAULT=.FALSE.) C C C VARIABLES READ IN NAMELIST "PDATA" (APPLIES ONLY FOR CALLS TO C LISTPROFILER, LISTVADWIND, LISTGOESNDGS, LISTERSCAT, LISTQKSWND, C LISTGPSIPW, LISTRASS AND LISTWNDSAT): C C IDAT10 - "CENTRAL" DATE FOR PROCESSING BUFR MESSAGES IN FORM C YYYYMMDDHH (NOTE: IF FILE IS A DATA DUMP, THIS MUST C AGREE WITH CENTER DATE OF BUFR DUMP FILE) (FOR CALLS TO C W3UNPKB7 ONLY) C Note: Currently this does not include minutes for RTMA_RU C runs. It might be a good idea to update this C someday! C IWINDE - NUMBER OF WHOLE HOURS RELATIVE TO "IDAT10" FOR DATE OF C EARLIEST BUFR MESSAGE THAT IS TO BE DECODED; EARLIEST C DATE IS "IDAT10" + "IWINDE" HOURS (IF "IWINDE" IS C POSITIVE, EARLIEST MESSAGE DATE IS AFTER "IDAT10"; IF C "IWINDE" IS NEGATIVE, EARLIEST MESSAGE DATE IS PRIOR TO C "IDAT10") - EXAMPLE: IF IWINDE=1, THEN EARLIEST DATE IS C 1-HR AFTER IDAT10; IF IWINDE=-3, THEN EARLIEST DATE IS C 3-HR PRIOR TO IWINDE C IWINDL - NUMBER OF WHOLE HOURS RELATIVE TO "IDAT10" FOR DATE OF C LATEST BUFR MESSAGE THAT IS TO BE DECODED; LATEST C DATE IS "IDAT10" + ("IWINDL" HOURS PLUS 59 MIN) IF C "IWINDL" IS POSITIVE (LATEST MESSAGE DATE IS AFTER C "IDAT10"), AND "IDAT10" + ("IWINDL"+1 HOURS MINUS 1 MIN) C IF "IWINDL" IS NEGATIVE (LATEST MESSAGE DATE IS PRIOR C TO "IDAT10") - EXAMPLE: IF IWINDL=3, THEN LATEST DATE IS C 3-HR 59-MIN AFTER IDAT10; IF IWINDL=-2, THEN LATEST DATE C IS 1-HR 1-MIN PRIOR TO IDAT10 C NOTE: THE LIMITS FOR "IWINDE" AND "IWINDL" ARE -6 AND +6, RESP. C IF THESE VALUES ARE USED, THEN IT IS ASSUMED THAT ALL C BUFR MESSAGES IN THE FILE ARE TO BE PROCESSED REGARDLESS C OF THEIR TIME. C IPRINT - CONTROLS THE AMOUNT OF PRINTOUT ASSOCIATED WITH THE C LISTINGS C IPRINT = -2 - ALL POSSIBLE PRINTOUT C IPRINT = -1 - SOME ADDITIONAL PRINTOUT C IPRINT = 0 - NORMAL PRINTOUT C NOTE: NORMALLY IPRINT=0 IS USED; IF THERE ARE PROBLEMS C THAT NEED DIAGNOSING, THEN THE OTHER OPTIONS MAY C BE NEEDED C SUBSKP - LOGICAL (0:255,0:200) THAT IDENTIFIES THOSE BUFR TYPES/ C SUBTYPES FOR WHICH THE BUFR MESSAGES SHOULD BE SKIPPED C OVER (WITHOUT DECODING REPORTS) IF TRUE (DEFAULT=.FALSE.) C C THE FOLLOWING 3 SWITCHES APPLY ONLY TO CALLS TO LISTGOESNDGS: C (TRUE OR FALSE) C SNDG - PRINT VERTICAL SOUNDING DATA IN A GOES REPORT? C RETR - PRINT RETRIEVAL DATA IN A GOES REPORT? C RADN - PRINT RADIANCE DATA IN A GOES REPORT? C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ PROGRAM BUFR_LISTDUMPS CHARACTER*8 DSNAME_LC,DSNAMX,SUBSET INTEGER(8) IDSDMP_8 REAL(8) BMISS,GETBMISS NAMELIST/RDATA/DSNAME_LC COMMON/TYPE/DSNAME_LC COMMON/BUFRLIB_MISSING/BMISS DATA NUNIT/21/ CALL W3TAGB('BUFR_LISTDUMPS',2021,0175,0062,'NP22') PRINT 100 100 FORMAT(//36X,'***** PROGRAM BUFR_LISTDUMPS - WCOSS VERSION ', $ '06-24-2021 *****'//) C On WCOSS should always set BUFRLIB missing (BMISS) to 10E8 to avoid C overflow when either an INTEGER*4 variable is set to BMISS or a C REAL*8 (or REAL*4) variable that is missing is NINT'd C ------------------------------------------------------------------- ccccc CALL SETBMISS(10E10_8) CALL SETBMISS(10E8_8) BMISS=GETBMISS() print'(1X)' print'(" BUFRLIB value for missing is: ",G0)', bmiss print'(1X)' READ(5,RDATA) IF(DSNAME_LC.EQ.'adpupa '.OR.DSNAME_LC.EQ.'aircar '.OR. $ DSNAME_LC.EQ.'aircft '.OR.DSNAME_LC.EQ.'satwnd '.OR. $ DSNAME_LC.EQ.'spssmi ') THEN IOPENED = 0 KNTRPT = 0 DSNAMX = 'ZZZZZZZZ' IDSDAT = 0 IDSDMP_8 = 0 SUBSET = 'XXXXXXXX' CALL LISTUPA(IOPENED,KNTRPT,DSNAMX,IDSDAT,IDSDMP_8,SUBSET) GO TO 7000 ELSE IF(DSNAME_LC.EQ.'adpsfc '.OR.DSNAME_LC.EQ.'sfcshp '.OR. $ DSNAME_LC.EQ.'sfcbog '.OR.DSNAME_LC.EQ.'msonet ') THEN CALL LISTSFC GO TO 7000 ELSE IF(DSNAME_LC.EQ.'proflr ') THEN CALL LISTPROFILER GO TO 7000 ELSE IF(DSNAME_LC.EQ.'vadwnd ') THEN CALL LISTVADWIND GO TO 7000 ELSE IF(DSNAME_LC.EQ.'goesnd '.or. DSNAME_LC.EQ.'goesfv') THEN CALL LISTGOESNDGS GO TO 7000 ELSE IF(DSNAME_LC.EQ.'erscat ') THEN CALL LISTERSCAT GO TO 7000 ELSE IF(DSNAME_LC.EQ.'qkswnd ') THEN CALL LISTQKSWND(1) GO TO 7000 ELSE IF(DSNAME_LC.EQ.'ascatw ') THEN CALL LISTQKSWND(2) GO TO 7000 ELSE IF(DSNAME_LC.EQ.'gpsipw ') THEN CALL LISTGPSIPW GO TO 7000 ELSE IF(DSNAME_LC.EQ.'rassda ') THEN CALL LISTRASS GO TO 7000 ELSE IF(DSNAME_LC.EQ.'wdsatr ') THEN CALL LISTWNDSAT GO TO 7000 ELSE PRINT 567, DSNAME_LC 567 FORMAT('**BUFR_LISTDUMPS: INPUT BUFR DATA DUMP DATA SET ', $ 'NAME (',A8,') NOT RECOGNIZED!!') CALL W3TAGE('BUFR_LISTDUMPS') CALL ERREXIT(88) END IF 7000 CONTINUE CALL W3TAGE('BUFR_LISTDUMPS') STOP END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: LISTUPA C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2018-03-28 C C ABSTRACT: LISTS CONTENTS OF AN TIME-WINDOWED UPPER-AIR BUFR DATA C DUMP FILE. THE STANDARD OUTPUT IS IN AN EASY-TO-READ FORMAT. C NOTE: THIS SUBROUTINE CAN HANDLE THE FOLLOWING BUFR DATA DUMP C FILE TYPES: ADPUPA, AIRCAR, AIRCFT, SATWND, SPSSMI, PROFLR C {FOR "PROFLR" ONLY WIND PROFILERS ORIGINATING FROM PILOT C (PIBAL) FORMAT BULLETINS ARE PROCESSED HERE, REMAINDER OF C PROFILERS ARE PROCESSED BY SUBROUTINE "LISTPROFILER"}. THE C ADPUPA DUMP (ONLY) IS NOW SORTED IN ASCENDING ORDER OF STATION C ID. C C PROGRAM HISTORY LOG: C 2000-03-28 D.A. KEYSER -- ORIGINAL AUTHOR C 2000-06-07 D.A. KEYSER -- ADDED SORTING OF ADPUPA DATA IN ASCENDING C ORDER OF STATION ID; USER CAN NOW SPECIFY LAT/LON BOUNDARY FOR C LISTING "UPPER-AIR" (ADPUPA, AIRCAR, AIRCFT, SATWND, SPSSMI) C REPORTS; CAN NOW LIST SSM/I RAIN RATE REPORTS IN EASY-TO-READ C FORMAT; IMPROVED FORMAT FOR LISTING SATWND REPORTS C 2001-04-06 D.A. KEYSER -- CAN NOW LIST SSM/I SURFACE TEMPERATURE C REPORTS IN EASY-TO-READ FORMAT; UNITS FOR INPUT SSM/I RAIN C RATE CHANGED FROM MM/HR TO MM/SEC (PRECISE TO 10**6) TO ACCOUNT C FOR CHANGE IN IW3UNPBF (STILL LISTED IN UNITS OF MM/HR); UNITS C FOR INPUT SSM/I WIND SPEED, PWATER AND SFC. TEMP. CHANGED FROM C M/S*10, MM*10, K*100, RESP. TO M/S, MM, K WITH FLOATING POINT C PRECISON TO 10**1, 10**1, 10**2, RESP. TO ACCOUNT FOR CHANGE IN C IW3UNPBF; MEAN AND STD. DEV FOR SSM/I PRODUCTS NOW LISTED TO C NEAREST HUNDREDTH UNIT (WAS NEAREST TENTH); NEW INPUT ARGUMENT C IOPENED NOW INDICATES (WHEN = 1) THAT THE INPUT FILE HAS ALREADY C BEEN OPENED BY ANOTHER LISTER SUBR. IN THIS PROGRAM AND THIS C SUBR. WILL PICK UP WHERE THE OTHER SUBR. LEFT OFF (OTHER NEW C INPUT ARGS. "KOUNT", "DSNAME", "IDSDAT", "IDSDMP_8" AND "SUBSET" C ARE THEN NEEDED); ACCOUNTS FOR CHANGE IN IW3UNPBF WHICH RETURNS C SATELLITE ID IN HEADER WORD 6 (SATWINDS ONLY), INCLUDES SATELLITE C ID IN LISTING FOR SATWINDS; IMPROVED FORMAT FOR LISTING SSM/I C BRIGHTNESS TEMPS C 2004-09-09 KEYSER -- NOW PRINTS SST AND SINGLE-LEVEL SENSIBLE C WEATHER ELEMENTS FROM ADATA2 AND MULTIPLE-LEVEL SENSIBLE WEATHER C ELEMENTS FROM ADATA3 RETURNED FROM IW3UNPBF; INFORMATION THAT C HAD BEEN PRINTED FROM CATEGORIES 7 AND 8 RETURNED FROM IW3UNPBF C THAT IS NOW RETURNED IN ADATA2 AND ADATA3 IS NOW IGNORED; NO C ATTEMPT IS MADE TO PRINT DATA IN CATEGORY 7 SINCE IT IS NO C LONGER CONSIDERED IN IW3UNPBF C 2005-03-14 KEYSER -- NOW PRINTS QI W/ FCST AND QI W/O FCST FOR CAT 6 C SATELLITE WIND REPORTS (READ FROM CAT 8 C.F. 356 AND 357, RESP.) C (RFF FROM CAT 8 C.F. 355 STILL PRINTED AS WELL) C 2007-09-14 D. A. KEYSER -- BUMP UP ARRAY SIZE FOR UNPACKED REPORT C FROM IW3UNPBF FROM 3000 TO 3500; INCLUDES NESDIS PERCENT C CONFIDENCE BASED ON EXPECTED ERROR (Q.C.) (READ FROM CAT. 8 CODE C FIGURE 358) IN LISTING FOR CAT. 6 SATELLITE-DERIVED WIND REPORTS; C EXPANDED ARRAYS ADATA3 FROM (5,255,5) TO (5,255,7) AND NDATA3 C FROM (5) TO (7) (RETURNED OUT OF CALL TO IW3UNPBF) TO ACCOUNT FOR C PROCESSING/LISTING OF ADDITIONAL MULTIPLE-LEVEL SENSIBLE WEATHER C ELEMENTS CONTAINING SEQUENCES OF AIRFRAME ICING, HEIGHT OF BOTTOM C AND TOP OF ICING LAYER (IN RECCOS, PIREPS, E-AMDAR, CANADIAN C AMDAR, TAMDAR), AND DEGREE OF TURBULENCE, HEIGHT OF BOTTOM AND C TOP OF TURBULENCE LAYER (IN RECCOS AND ALL AIRCRAFT), THE C EXPANDED TURBULENCE INFORMATION REPLACES THE SINGLE DEGREE OF C TURBULENCE VALUE WHICH HAD BEEN RETURNED FROM IW3UNPBF IN CAT. 8, C CODE FIGURE 916; IMPROVED DOCUMENTATION AT TOP OF LISTINGS FOR C "ADPUPA", "AIRCFT", "AIRCAR" AND "SATWND" DUMPS C 2008-09-12 D. A. KEYSER -- MODIFIED TO RECOGNIZE THAT TAMDAR REPORTS C CAN NOW APPEAR IN "aircft" DUMP MESSAGE TYPES NC004012 (PENAIR) C AND NC004013 (CHAUTAUQUA) IN ADDITION TO MESSAGE TYPE NC004008 C (MESABA) C 2008-09-25 D. A. KEYSER -- ACARS MOISTURE QUALITY IS NOW LISTED C 2012-11-27 D. A. KEYSER -- ALLOW REPORT SEQUENCE NUMBER (CAT. 8, C CODE FIG. 21) TO NOW BE AS LARGE AS 999999 (ALL OTHER CODE FIGS. C UPPER LIMIT REMAINS 99999) (NEEDED BECAUSE THERE CAN NOW BE > C 99999 MDCRS REPORTS IN A MONOLITHIC "AIRCAR" DUMP FILE, PRIOR TO C THIS VALUE WAS LISTED AS LIMIT OF 99999 FOR ALL REPORTS WITH C SEQUENCE NUMBER > 99999) C 2014-04-22 D. A. KEYSER -- BUMPED UP ARRAY SIZE FOR "ADATA2", C RETURNED OUT OF CALL TO IW3UNPBF, FROM 42 TO 43, NEW WORD 43 C HOLDS SATELLITE ZENITH ANGLE (DEGREES, SATWND TYPES ONLY) WHICH C IS NOW LISTED. PRINTING FORMAT CHANGED FOR SOME TYPES TO SQUEEZE C MORE INFORMATION ON A LINE. C 2015-01-30 D. A. KEYSER -- The key of SATWND data listed updated to C include new instrument type 19 {IR (short-wave) imager automated C winds (high density)}. C 2015-03-09 D. A. KEYSER -- For aircraft report types (only), CBULL C (new variable returned from IW3UNPBF) is now listed (contains WMO C bulletin header and originator) in place of header character C reserve word 1 (which only contained WMO bulletin originator in C characters 1-4) (key for AIRCAR and AIRCFT data updated). C 2016-02-09 S. MELCHIOR -- Adjusted code to accommodate the processing C of three new aircraft data types: Korean AMDAR (BUFR), Catch-All C AMDAR (BUFR) and TAMDAR (Panasonic/AirDAT BUFR). Latitude, C longitude, and moisture are available in higher precision in new C version 7 BUFR format (for Catch-All AMDAR, MDCRS and E-AMDAR) so C print statements for dumps from "aircar", "aircft" and "adpupa" C (latter for future) were modified to account for increased C precision (only lat/lon for "adpupa") (lat/lon format changed to C list 5 significant digits instead of 2; moisture format changed to C list 6 significant digits instead of 3). C 2016-11-25 D. A. KEYSER -- Correct info in "KEY FOR DATA LISTED" C printout for AIRCFT types. For TAMDAR from Panasonic or AirDAT C only, lists "observer identification" (OBSVR, returned from C IW3UNPBF in bytes 1-4 of header reserve character word 1) (due to C change in both this code and in subr. IW3UNPBF), lists "type of C commercial aircraft" (ACTP, returned from IW3UNPBF in header C reserve character word 2) (due solely to change in subr. C IW3UNPBF), and lists instantaneous altitude rate (IALR, returned C from IW3UNPBF in cat.8 c.f. 932) (due solely to change in subr. C IW3UNPBF). For AMDAR types other than European, Canadian and C Korean originating from BUFR (referred to as "Catch-all" AMDAR) C lists "aircraft flight number" (ACID, returned from IW3UNPBF in C header reserve character word 2) (due solely to change in subr. C IW3UNPBF). C 2016-11-30 D. A. KEYSER -- Reads new output real, double-precision C argument array ADATA_8 of length 2 in call to IW3UNPBF. This C returns latitude and longitude for each report which is then C stored in R*8 variables ALAT_8 and ALON_8 prior to listing for the C following dump types: AIRCFT, AIRCAR and ADPUPA. C BENEFIT: Replaces lat/lon returned in ADATA(1:2) in call to C IW3UNPBF for these types which are just at machine C precison (normally R*4). Now that reports in these dumps C can store lat/lon at 0.00001 degree precision (e.g., C AIRCFT and AIRCAR dumps with switch to v7 BUFR), this C change will ensure that lat/lon is always accurate to C 0.00001 degrees in these listings. C 2017-10-13 D. A. KEYSER -- Added minutes to every print statement C that includes the central dump time. Central dump time minutes is C obtained from Section 1 of first (dummy) message of input dump C file via call to BUFRLIB routine IUPVS01. C BENEFIT: Until now, central dump time minutes was always zero. C However, with the implementation of the new RTMA_RU, C central dump time can now also have minutes = 15, 30 C or 45 (since the RTMA_RU runs 4 times per hour). This C change allows the print statements to reflect this new C center dump time format. C 2018-03-28 D. A. KEYSER -- For SATWND types, prints lat and lon to C nearest 0.00001 degree for GOES-16 and up reports since these have C high-res lat/lon in their tanks. All other SATWND types continue C to print lat and lon to nearest 0.01 degree since they still have C low-res lat/lon in their tanks (however the format statement is C modified to add three blanks after the lat and lon to keep the C alignment correct between GOES-16 and up reports and all other C satellite wind reports). C C USAGE: CALL LISTUPA(IOPENED,KOUNT,DSNAME,IDSDAT,IDSDMP_8,SUBSET) C INPUT ARGUMENT LIST: C IOPENED - INDICATOR AS TO WHETHER INPUT FILE HAS ALREADY C - BEEN OPENED BY ANOTHER LISTER SUBROUTINE IN THIS C - PROGRAM (=0 - HAS NOT ALREADY BEEN OPENED; =1 - C - HAS ALREADY BEEN OPENED) C KOUNT - IN THIS CASE ON IOPENED = 1, THE NUMBER OF REPORTS C - THAT HAVE ALREADY BEEN PROCESSED BY ANOTHER LISTER C - SUBROUTINE IN THIS PROGRAM (IF IOPENED IS INPUT AS C - 0, THEN KOUNT SHOULD ALSO BE INPUT AS 0) C DSNAME - CHARACTER*8 DATA SET NAME (IF IOPENED IS INPUT AS C - 0, THEN DSNAME IS NOT READ AND CAN BE INPUT AS C - 'ZZZZZZZZ') C IDSDAT - CENTER TIME FOR DUMP DATA SET IN FORM YYYYMMDDHH (IF C - IOPENED IS INPUT AS 0, THEN IDSDAT IS NOT READ AND C - CAN BE INPUT AS ZERO) C Note: Currently this does not include minutes for C RTMA_RU runs. It might be a good idea to update C this someday! C IDSDMP_8 - INTEGER*8 DUMP TIME FOR DUMP DATA SET IN FORM C - YYYYMMDDHHMM (IF IOPENED IS INPUT AS 0, THEN IDSDMP_8 C - IS NOT READ AND CAN BE INPUT AS ZERO) C SUBSET - CHARACTER*8 BUFR MESSAGE TYPE (IF IOPENED IS INPUT C - AS 0, THEN SUBSET IS NOT READ AND CAN BE INPUT AS C - 'XXXXXXXX') C C INPUT FILES: C UNIT 05 - INPUT DATA CARDS IN THE FORM OF A NAMELIST (SEE C - REMARKS IN MAIN PROGRAM DOCBLOCK) C UNIT 21 - BUFR DATA SET C C OUTPUT FILES: C UNIT 06 - STANDARD OUTPUT PRINT C C REMARKS: NONE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ SUBROUTINE LISTUPA(IOPENED,KOUNT,DSNAME,IDSDAT,IDSDMP_8,SUBSET) PARAMETER (MAXOBS = 3500) CHARACTER*1 C1,C2,c1_8,c2_8 CHARACTER*2 CIND1,CIND2,CIND3,CIND4,CQM(5,7) CHARACTER*4 CUNITS,CCAT1(8) CHARACTER*5 CCAT2(75),CCAT3(75),CCAT4(75) CHARACTER*6 CDATUM CHARACTER*8 STNID,CRES1,CRES2,DSNAME,STNID_S(20000), $ CRES1_S(20000),CRES2_S(20000),KEY_S(20000),SUBSET,SUBSET_S(20000) CHARACTER*9 CRES CHARACTER*10 CCAT5(60) CHARACTER*11 CCAT8(105),CBULL LOGICAL GLOBAL,SUBSKP(0:255,0:200),SORTID REAL ADATA(MAXOBS),ADATA_S(MAXOBS,20000),SRAD(7),ADATA2(43), $ ADATA2_S(43,20000),ADATA3(5,255,7),ADATA3_S(5,255,7,20000) REAL(8) BMISS,adata8_8(2),adata8_8_s(2,20000),alat_8,alon_8 INTEGER IDATA(MAXOBS),ICAT(9),INDX(20000),NDATA3(7), $ NDATA3_S(7,20000) INTEGER(8) IDSDMP_8 COMMON/BUFRLIB_MISSING/BMISS EQUIVALENCE (ADATA,IDATA) DATA NUNIT/21/ DATA CCAT1/'MAND',7*' '/ DATA CCAT2/'SIG-T',74*' '/ DATA CCAT3/'WND-P',74*' '/ DATA CCAT4/'WND-Z',74*' '/ DATA CCAT5/'TROPOPAUSE',59*' '/ DATA CCAT8/'ADDIT-DATA ',104*' '/ DATA ICAT/51,-99,-99,10,11,12,13,14,15/ DATA KTIMCH/0/,XMISS/99999./,IMISS/99999/ NAMELIST/UDATA/ITWINB,ITWINA,LATS,LATN,LONW,LONE,SUBSKP IADPUP = 0 KNTTIM = 0 KNTLAT = 0 KNTLON = 0 SORTID = .FALSE. ITWINB = -600 ITWINA = 600 LATS = -9001 LATN = 9001 LONW = -0001 LONE = 36001 SUBSKP = .FALSE. IER = 0 IF(IOPENED.EQ.1) THEN IER = -1 PRINT 892, NUNIT 892 FORMAT(/'##BUFR_LISTDUMPS/LISTUPA: ABOUT TO UNPACK REPORTS FROM ', $ 'A FILE (UNIT',I3,') WHICH HAS ALREADY BEEN OPENED BY ANOTHER ', $ 'LISTER'/26X,'SUBROUTINE IN THIS PROGRAM'/) END IF READ(5,UDATA,END=1905) 1905 CONTINUE GLOBAL = (LATS.LE.-09000.AND.LATN.GE.09000.AND. $ LONW.LE. 00000.AND.LONE.GE.36000) 905 CONTINUE IF(IW3UNPBF(NUNIT,ADATA,STNID,CRES1,CRES2,CBULL,ADATA2,ADATA3, $ NDATA3,adata8_8,DSNAME,IDSDAT,IDSDMP_8,SUBSET,SUBSKP,IER).EQ.0) $ GO TO 950 IF(IER.EQ.1) GO TO 910 IF(IER.EQ.2) GO TO 920 IF(IER.EQ.3) GO TO 920 IF(IER.EQ.999) GO TO 999 C----------------------------------------------------------------------- 910 CONTINUE IF(DSNAME.EQ.'ADPUPA ') THEN PRINT 101 101 FORMAT(//5X,'KEY FOR DATA LISTED IN EACH REPORT BELOW:'/ $/10X,'BUFR mnemonics:' $/15X,'RSRD ..... Restrictions on redistribution, Flag Table 0-35', $ '-200 (' $/32X,' 16 - can redistribute to any U.S. government agency ', $ 'within NOAA,' $/32X,'128 - can redistribute to any U.S. government agency,' $/32X,'160 - can redistribute to any U.S. government agency or ', $ 'educational institution,' $/32X,'192 - can redistribute to any U.S. government agency or ', $ 'research group,' $/32X,'224 - can redistribute to any U.S. government agency, ', $ 'research group or educational institution,' $/32X,'256 - no redistribution allowed,' $/28X,'Missing - no retrictions on redistribution)' $/15X,'EXPRSRD .. Expiration of restrictions on redistribution ', $ '(hours), 0-35-201' $/15X,'SST1 ..... Sea temperature (K), 0-22-043' $/15X,'SSTQM .... Sea temperature quality marker, Code Table 0-22', $ '-246' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'prepbufr.doc/table_7.htm)' $/15X,'HBLCS .... Height above surface of the base of the lowest ', $ 'cloud seen, Code Table 0-20-201' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_local_await-val.htm#0-20-201)' $/15X,'WDIR1..... Surface wind direction (degrees), 0-11-200' $/15X,'WSPD1..... Surface wind speed (m/sec), 0-11-201' $/15X,'PRWE ..... Present weather, Code Table 0-20-003' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_20.htm#0-20-003)' $/15X,'CLAM ..... Cloud amount, Code Table 0-20-011' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_20.htm#0-20-011)' $/15X,'CLTP ..... Cloud type, Code Table 0-20-012' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_20.htm#0-20-012)' $/15X,'HOCB ..... Height of base of cloud (meters), 0-20-013' $/15X,'HOCT ..... Height of top of cloud (meters), 0-20-014' $/15X,'AFIC ..... Airframe icing, Code Table 0-20-041' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_20.htm#0-20-041)' $/15X,'HBOI ..... Height of base of icing (meters), 0-24-194' $/15X,'HTOI ..... Height of top of icing (meters), 0-24-195' $/15X,'DGOT ..... Degree of turbulence, Code Table 0-11-031' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_9-19.htm#0-11-031)' $/15X,'HBOT ..... Height of base of turbulence (meters), 0-11-032' $/15X,'HTOT ..... Height of top of turbulence (meters), 0-11-033'/ $/10X,'ADDIT-DATA (Category 8) "Levels", each of form "wwwww xxx ', $ 'yyyyy zzzzz" where xxx is code figure defined as follows:' $/15X,'xxx = 104 - wwwww = release time (in 0.01 hours)' $/15X,'xxx = 105 - wwwww = receipt time (in 0.01 hours)' $/30x,'- yyyyy = radiosonde part (00004 - TTAA, 00005 - TTBB, ', $ '00006- TTCC, 00007 - TTDD, 00008 - PPAA,' $/40X,'00009 - PPBB, 00010 - PPCC, 00011 - PPDD)' $/15X,'xxx = 351 - wwwww = geopotential height (in meters)' $/30X,'- yyyyy = pressure level (mb)' $/30X,'- zzzzz = geopotential quality marker (00000 - monitor ', $ 'keep, 00001 - good, 00002 - neutral/not' $/40X,'checked, 00003 - suspect, 00012 - toss, on reject list, ', $'00013 - toss, failed automatic q.c.' $/40X,'tests, 00014 - toss, monitor purge)' $/15X,'xxx = 353 - wwwww = solar and infrared radiation ', $ 'correction indicator (BUFR Code Table 0-02-013,' $/35X,'see http://www.emc.ncep.noaa.gov/mmb/data_processingtable/', $ '_1-2.htm#0-02-013)' $/15X,'xxx = 354 - wwwww = tracking technique/status of system ', $ 'used indicator (BUFR Code Table 0-02-014,' $/35X,'see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'common_tbl_c6-c7.htm#c-7)'//) ELSE IF(DSNAME.EQ.'AIRCFT ') THEN PRINT 102 102 FORMAT(//5X,'KEY FOR DATA LISTED IN EACH REPORT BELOW:'/ $/10X,'Field 1 ....... AIREP, TAMDAR(MADIS): Flight number' $/10X,' PIREP: Constructed id' $/10X,' All AMDAR types, TAMDAR(Panasonic or ', $ 'AirDAT) : Tail number' $/10X,'Field 2 ....... Observation time (UTC)' $/10X,'Field 3 ....... Latitude (N,S)' $/10X,'Field 4 ....... Longitude (E,W)' $/10X,'Field 5 ....... Pressure (x 10 mb)' $/10X,'Field 6 ....... Pressure altitude (meters)' $/10X,'Field 7 ....... Temperature (x 10 degrees C)' $/10X,'Field 8 ....... Specific humidity (g/kg)' $/10X,'Field 9 ....... Wind direction (degrees) / wind speed (x ', $ '10 m/sec)' $/10X,'Field 10 ....... Quality markers in form AABBCCDDEE, where', $ ' AA = pressure, BB = pressure altitude, CC = temperature,' $/28X,'DD = specific humidity, EE = wind (00 - monitor keep, 01 -', $ ' good, 02 - neutral/not checked, 03 - suspect,' $/28X,'12 - toss, on reject list, 13 - toss, failed automatic ', $ 'q.c. tests, 14 - toss, monitor purge)' $/28X,'Note: If quality marker is default value of 02 then "--" ', $ 'is stamped out here rather than "02"' $/10X,'RCT ............ Receipt time (UTC)' $/10X,'Next field ..... 20 character string enclosed in quotes:', $/27x,' - Characters 1-6: WMO bulletin header (all types ', $ 'except TAMDAR from Panasonic or AirDAT)', $/27x,' - Characters 8-11: WMO bulletin originator (all types ', $ 'except TAMDAR from Panasonic or AirDAT)', $/27x,' - Characters 1-4: Observer identification (TAMDAR from', $ ' Panasonic or AirDAT only)', $/27x,' - Character 13: Indicator for bulletin source ', $ '{AIREP, PIREP, AMDAR (from AMDAR format) only}:', $/32x,' - "C" - AWFA', $/32x,' - " " - WMO', $/27x,' - Characters 13-20: Type of commercial aircraft (TAMDAR', $ ' from Panasonic or AirDAT only)', $/27x,' - Characters 13-20: Flight number (encrypted)', $ ' {AMDAR (from BUFR) only}', $/27x,' (all other characters are blanks)', $/10X,'RT ............. Dump report type / report subtype (report', $ ' type always 041 - aircraft; report subtype: 1 - AIREP,' $/28X,'2 - PIREP, 3 - AMDAR, 6 - E-AMDAR, 8 - TAMDAR-Mesaba, 9 - ', $ 'Canadian AMDAR, 11 - Korean AMDAR, ', $/28X,'12 - TAMDAR-PenAir, 13 - TAMDAR-Chautauqua, 103 - ', $ 'Catch-all AMDAR)' $/10X,'IT ............. Instrument type (97 - Inertial navigation', $ ' system, 98 - OMEGA)'/ $/10X,'BUFR mnemonics:' $/15X,'RSRD ..... Restrictions on redistribution, Flag Table 0-35', $ '-200 (' $/32X,' 16 - can redistribute to any U.S. government agency ', $ 'within NOAA,' $/32X,'128 - can redistribute to any U.S. government agency,' $/32X,'160 - can redistribute to any U.S. government agency or ', $ 'educational institution,' $/32X,'192 - can redistribute to any U.S. government agency or ', $ 'research group,' $/32X,'224 - can redistribute to any U.S. government agency, ', $ 'research group or educational institution,' $/32X,'256 - no redistribution allowed,' $/28X,'Missing - no retrictions on redistribution)' $/15X,'EXPRSRD .. Expiration of restrictions on redistribution ', $ '(hours), 0-35-201' $/15X,'PRWE ..... Present weather, Code Table 0-20-003' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_20.htm#0-20-003)' $/15X,'CLAM ..... Cloud amount, Code Table 0-20-011' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_20.htm#0-20-011)' $/15X,'CLTP ..... Cloud type, Code Table 0-20-012' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_20.htm#0-20-012)' $/15X,'HOCB ..... Height of base of cloud (meters), 0-20-013' $/15X,'HOCT ..... Height of top of cloud (meters), 0-20-014' $/15X,'AFIC ..... Airframe icing, Code Table 0-20-041' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_20.htm#0-20-041)' $/15X,'HBOI ..... Height of base of icing (meters), 0-24-194' $/15X,'HTOI ..... Height of top of icing (meters), 0-24-195' $/15X,'DGOT ..... Degree of turbulence, Code Table 0-11-031' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_9-19.htm#0-11-031)' $/15X,'HBOT ..... Height of base of turbulence (meters), 0-11-032' $/15X,'HTOT ..... Height of top of turbulence (meters), 0-11-033'/ $/10X,'ADDIT-DATA (Category 8) "Levels", each of form "Swwwww xxx', $ ' yyyyy zzzzz" where S is the sign (+/-) and ' $/11X,'xxx is code figure defined as follows:' $/15X,'xxx = 914 - wwwww = phase of aircraft flight {00002 - ', $ 'unsteady, 00003 - level flight (routine), 00004 - level flight' $/35X,'(highest wind encountered), 00005 - ascending, 00006 - ', $ 'descending, 00007 - missing}' $/15X,'xxx = 915 - wwwww = precision of temperature observation ', $ '(in 0.01 K)' $/15X,'xxx = 930 - wwwww = aircraft turbulence index (BUFR Code ', $ 'Table 0-11-235,' $/35X,'see http://www.emc.ncep.noaa.gov/mmb/data_processing/table', $ '_local_await-val.htm#0-11-235)' $/30X,'- zzzzz = turbulence index quality marker (00000 - monitor', $ ' keep, 00001 - good, 00002 - neutral/not' $/40X,'checked, 00003 - suspect, 00012 - toss, on reject list, ', $ '00013 - toss, failed automatic q.c.' $/40X,'tests, 00014 - toss, monitor purge)' $/15X,'xxx = 931 - wwwww = aircraft roll angle flag (00000 - roll', $ ' > 5 degrees, 00001 - roll DATA SET INFORMATION: NAME: ',A8,'; DATE: ', $ I10.10,i2.2,'; DUMP TIME: ',I12.12,' <--'//10X,'-- SELECTED ', $ 'DOMAIN FOR PROCESSING REPORTS: LATITUDE:',F7.2,' TO ',F7.2, $ ' N; LONGITUDE:',F8.2,' TO ',F8.2,' E --'//) ELSE PRINT 7997, DSNAME,IDSDAT,iminu,IDSDMP_8 7997 FORMAT(//22X,'--> DATA SET INFORMATION: NAME: ',A8,'; DATE: ', $ I10.10,i2.2,'; DUMP TIME: ',I12.12,' <--'//10X,'-- SELECTED ', $ 'DOMAIN FOR PROCESSING REPORTS: ALL REPORTS IN DATA SET ', $ 'REGARDLESS OF LOCATION'//) END IF SORTID = (DSNAME.EQ.'ADPUPA ') IF(ITWINB.LE.-600.AND.ITWINA.GE.600) THEN KTIMCH = 0 PRINT 6998 6998 FORMAT(34X,'-- NO TIME WINDOW CONSTRAINT FOR PROCESSING REPORTS'/) ELSE KTIMCH = 1 PRINT 6999, ITWINB,ITWINA 6999 FORMAT(34X,'-- SELECTED TIME WINDOW FOR PROCESSING REPORTS:',2I6, $ ' --'/) END IF IFIND = 0 DO I = 0,255 DO J = 0,200 IF(SUBSKP(I,J)) THEN IF(IFIND.EQ.0) PRINT 7000 7000 FORMAT(34X,'-- THE FOLLOWING BUFR MESSAGE TYPES/SUBTYPES WILL BE', $ ' SKIPPED:') PRINT 7001, I,J 7001 FORMAT(45X,'BUFR TYPE ',I3.3,', SUBTYPE ',I3.3) IFIND = 1 END IF ENDDO ENDDO IF(IFIND.EQ.0) PRINT 7002 7002 FORMAT(34X,'-- ALL BUFR MESSAGE TYPES/SUBTYPES IN DATA DUMP FILE', $ ' WILL BE PROCESSED') IF(SORTID) PRINT 8002 8002 FORMAT(/34X,'-- REPORTS WILL BE LISTED IN ORDER OF ASCENDING ', $ 'STATION ID,'/37X,'BUT FIRST A LISTING OF DIAGNOSTIC ', $ 'INFORMATION FROM BUFR DECODER (IW3UNPBF SUBROUTINE)'///130('+') $ //43X,'READING IN REPORTS AND STORING FOR LATER SORT'/) PRINT 7003 7003 FORMAT(//) IF(KTIMCH.EQ.1) THEN ICHR = MOD(IDSDAT,100) cpppppppppp cc print'(" the cycle hour here is ")', ICHR cpppppppppp ITMIN = (ICHR * 100) + ITWINB ITMAX = (ICHR * 100) + ITWINA cpppppppppp cc print'(" ITMIN = ",I0,"; ITMAX = ",I0)', itmin,itmax cpppppppppp END IF IF(IOPENED.EQ.1) THEN IOPENED = 0 GO TO 950 END IF GO TO 905 C----------------------------------------------------------------------- 920 CONTINUE PRINT 566, IER 566 FORMAT('RETURN CODE =',I3,'; PHYSICAL END-OF-FILE - DONE') IF(SORTID) THEN PRINT 8003 8003 FORMAT(//130('+')//23X,'ALL REPORTS HAVE BEEN READ IN AND STORED', $ ' - NEXT SORT BY STATION ID AND BEGIN LISTING'//) GO TO 7050 END IF GO TO 906 C----------------------------------------------------------------------- 950 CONTINUE IF(IOPENED.EQ.1) GO TO 910 IF(KTIMCH.EQ.1) THEN C DO A TIME CHECK IF TIME WINDOW CONSTRAINT INVOKED C ------------------------------------------------- IDATA4 = NINT(ADATA(4) * 100.) IF(ICHR.EQ.18.AND.IDATA4.LE.0600) THEN IDATA4 = IDATA4 + 2400 ELSE IF(ICHR.EQ.00.AND.IDATA4.GE.1800) THEN IDATA4 = IDATA4 - 2400 ENDIF cpppppppppp cc print'(" FOR THIS RPT, IDATA4 = ")', IDATA4 cpppppppppp IF(IDATA4.LT.ITMIN.OR.IDATA4.GT.ITMAX) THEN KNTTIM = KNTTIM + 1 PRINT 234, STNID,IDATA4,ITMIN,ITMAX 234 FORMAT(/'####> Report ',A8,' SKIPPED - obs time ',I4.4, $ ' UTC is outside time window of ',I4.4,' to ',I4.4,' UTC'/) GO TO 905 END IF END IF IDATA1 = NINT(ADATA(1) * 100.) IDATA2 = NINT(ADATA(2) * 100.) IF(.NOT.GLOBAL) THEN C DO A DOMAIN CHECK IF GLOBAL DOMAIN NOT SELECTED C ----------------------------------------------- cpppppppppp cc print'(" FOR THIS RPT, IDATA1 = ",I0,"; IDATA2 = ",I0)', cc $ IDATA1,IDATA2 cpppppppppp IF(IDATA1.LT.LATS.OR.IDATA1.GT.LATN) THEN KNTLAT = KNTLAT + 1 GO TO 905 END IF IF(IDATA2.LT.LONW.OR.IDATA2.GT.LONE) THEN KNTLON = KNTLON + 1 GO TO 905 END IF END IF JJ = 0 DO I = 29,45,2 JJ = JJ + 1 IF(IDATA(I).GT.0) THEN C----------------------------------------------------------------------- PRINT 998, ICAT(JJ) CALL W3TAGE('BUFR_LISTDUMPS') CALL ERREXIT(33) C----------------------------------------------------------------------- END IF END DO 998 FORMAT('**BUFR_LISTDUMPS/LISTUPA: CANNOT PROCESS DATA IN CAT.',I4, $ ' - STOP 33') KOUNT = KOUNT + 1 IF(.NOT.SORTID) GO TO 7060 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C ADPUPA REPORTS COME HERE FOR STORAGE BECAUSE THEY WILL BE SORTED C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ IF(KOUNT.GT.20000) THEN PRINT 8014 8014 FORMAT('**BUFR_LISTDUMPS/LISTUPA: THERE ARE MORE THAN 20000 ', $ 'ADPUPA REPORTS - THIS EXCEEDS THE SORT LIMIT - STOP 55'/) CALL W3TAGE('BUFR_LISTDUMPS') CALL ERREXIT(55) END IF ADATA_S(:,KOUNT) = ADATA ADATA2_S(:,KOUNT) = ADATA2 ADATA3_S(:,:,:,KOUNT) = ADATA3 NDATA3_S(:,KOUNT) = NDATA3 adata8_8_s(:,kount) = adata8_8 STNID_S(KOUNT) = STNID CRES1_S(KOUNT) = CRES1 CRES2_S(KOUNT) = CRES2 SUBSET_S(KOUNT) = SUBSET KEY_S(KOUNT) = STNID C IF THIS IS A RECCO/DROP REPORT, FOOL SORT INTO PUTTING AT END OF FILE IF(IDATA(9).EQ.31) $ KEY_S(KOUNT) = 'ZZ'//STNID(1:6) GO TO 905 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 7050 CONTINUE C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C ALL ADPUPA REPORTS HAVE BEEN STORED, TIME TO SORT BY STATION ID C AND THEN BEGIN PROCESS OF LISTING SORTED REPORTS C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ CALL INDEXC(KOUNT,KEY_S,INDX) KNTOUT = 0 8000 CONTINUE KNTOUT = KNTOUT + 1 IF(KNTOUT.GT.KOUNT) GO TO 906 ADATA = ADATA_S(:,INDX(KNTOUT)) ADATA2 = ADATA2_S(:,INDX(KNTOUT)) ADATA3 = ADATA3_S(:,:,:,INDX(KNTOUT)) NDATA3 = NDATA3_S(:,INDX(KNTOUT)) adata8_8 = adata8_8_s(:,INDX(KNTOUT)) STNID = STNID_S(INDX(KNTOUT)) CRES1 = CRES1_S(INDX(KNTOUT)) CRES2 = CRES2_S(INDX(KNTOUT)) SUBSET = SUBSET_S(INDX(KNTOUT)) C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 7060 CONTINUE C CHANGE MISSING TO "BMISS" (REAL) OR 99999999 (INTEGER) C {MISSING DEFINED AS VALUE OF XMISS (99999.) FOR ALL PARMAMETERS C EXCEPT SEQUENCE NUMBER IN CAT. 8, CODE FIG. 21 WHERE IT IS DEFINED C AS 999999} C --------------------------------------------------------------- C Determine index pointing to sequence number in cat. 8, code fig. 21 C if it is present (ISEQ_INDEX) C ------------------------------------------------------------------- ISEQ_INDEX = 2*MAXOBS !initialize it as an unrealistically large # IF(IDATA(27).GT.0) THEN L = IDATA(28) - 4 DO I = 1,IDATA(27) L = L + 4 IF(NINT(ADATA(L+1)).EQ.21) THEN ISEQ_INDEX = L EXIT END IF END DO END IF DO I = 1,MAXOBS IF(I.EQ.ISEQ_INDEX) THEN C Come here if index points to the sequence # in cat. 8, code fig. 21 C ------------------------------------------------------------------- IF(ADATA(I).EQ.999999.) ADATA(I) = BMISS IF(IDATA(I).EQ.999999) IDATA(I) = 99999999 ELSE C Otherwise come here C ------------------- IF(ADATA(I).EQ.XMISS) ADATA(I) = BMISS IF(IDATA(I).EQ.IMISS) IDATA(I) = 99999999 END IF END DO C1 = 'N' C2 = 'E' c1_8 = 'N' c2_8 = 'E' ALAT = ADATA(1) IF(NINT(ADATA(1)*100.).LT.0) THEN ALAT = -ALAT C1 = 'S' END IF ALON = ADATA(2) IF(NINT(ADATA(2)*100.).GT.18000) THEN ALON = 360.00 - ALON C2 = 'W' END IF alat_8 = adata8_8(1) if(adata8_8(1).lt.0.) then alat_8 = -alat_8 c1_8 = 'S' end if alon_8 = adata8_8(2) if(adata8_8(2).lt.0.) then alon_8 = -alon_8 c2_8 = 'W' end if IF(DSNAME.EQ.'SPSSMI ') THEN IF(IDATA(9).EQ.68) THEN IF(IDATA(27).GT.0) THEN C SSM/I 7-CHANNEL BRIGHTNESS TEMPERATURES IN CAT. 8 C ------------------------------------------------- IF(STNID(1:1).EQ.'S') THEN CRES = '# WRT AVG' ELSE CRES = ' ' END IF READ(CRES1(1:3),'(I3)') NUM N = IDATA(28) - 4 DO NLVL = 1,IDATA(27) N = N + 4 KNDX = -188 + NINT(ADATA(N+1)) IF(KNDX.GT.7) EXIT IF(ADATA(N).LT.99998.) SRAD(KNDX) = ADATA(N) ENDDO PRINT 9777, STNID,ADATA(4),ALAT,C1,ALON,C2, $ NINT(ADATA(7)),CRES,NUM,IDATA(9),IDATA(8) 9777 FORMAT(1X,A8,2X,F8.5,'Z',F7.2,A1,F8.2,A1,4X,'ELV',I4,3X,A9,1X,I3, $ 4X,'RPT TYP ',I3.3,3X,'INST TYPE ',I2.2) PRINT 961, SRAD 961 FORMAT(5X,'CHN. 1 -- BTEMP=',F8.2,'K; CHN. 2 -- BTEMP=',F8.2, $ 'K; CHN. 3 -- BTEMP=',F8.2,'K; CHN. 4 -- BTEMP=',F8.2,'K'/5X, $ 'CHN. 5 -- BTEMP=',F8.2,'K; CHN. 6 -- BTEMP=',F8.2,'K; CHN.', $ ' 7 -- BTEMP=',F8.2,'K') END IF ELSE IF(IDATA(27).GT.0) THEN C SSM/I WIND SPEED, PRECIP. WATER, RAIN RATE OR SFC TEMP DATA IN CAT. 8 C --------------------------------------------------------------------- CDATUM = '??????' CUNITS = '????' N = IDATA(28) - 4 SCALE = 1.0 DO NLVL = 1,IDATA(27) N = N + 4 IF(NINT(ADATA(N+1)).EQ.196) THEN CDATUM = 'WSPD ' CUNITS = 'M/S ' EXIT ELSE IF(NINT(ADATA(N+1)).EQ.197) THEN CDATUM = 'PWATER' CUNITS = 'MM ' EXIT ELSE IF(NINT(ADATA(N+1)).EQ.198) THEN CDATUM = 'RRATE ' CUNITS = 'MM/H' SCALE = 3600. EXIT ELSE IF(NINT(ADATA(N+1)).EQ.199) THEN CDATUM = 'SFTEMP' CUNITS = 'K ' EXIT END IF END DO IF(CDATUM.EQ.'??????') THEN GO TO 5689 ELSE IF(STNID(1:1).EQ.'S') THEN CRES = '# WRT AVG' ELSE CRES = 'RAIN FLAG' END IF IF(ADATA(N).LT.XMISS) ADATA(N) = ADATA(N)*SCALE IF(ADATA(N+2).LT.XMISS) ADATA(N+2) = ADATA(N+2)*SCALE READ(CRES1(1:3),'(I3)') NUM PRINT 777, STNID,ADATA(4),ALAT,C1,ALON,C2, $ NINT(ADATA(7)),CDATUM,ADATA(N),CUNITS,ADATA(N+2),CUNITS, $ CRES,NUM,IDATA(9),IDATA(8) 777 FORMAT(1X,A8,2X,F8.5,'Z',F7.2,A1,F8.2,A1,4X,'ELV',I4,3X,A6,1X, $ F6.2,A4,2X,'STDV ',F6.2,A4,3X,A9,1X,I3,4X,'RPT TYP ',I3.3,3X, $ 'INST TYPE ',I2.2) END IF END IF GO TO 905 END IF IF(DSNAME.EQ.'SATWND ') THEN IF(IDATA(23).GT.0) THEN C SATWND (CAT. 6) DATA WITH RFF, QI (W/ FCST), QI (W/O FCST) IN CAT. 8 C -------------------------------------------------------------------- IRFF = 99999999 IQI = 99999999 IQIN = 99999999 IEEF = 99999999 IF(IDATA(27).GT.0) THEN N = IDATA(28) - 4 DO NLVL = 1,IDATA(27) N = N + 4 IF(NINT(ADATA(N+1)).EQ.355) THEN IRFF = NINT(ADATA(N)) CYCLE ELSE IF(NINT(ADATA(N+1)).EQ.356) THEN IQI = NINT(ADATA(N)) CYCLE ELSE IF(NINT(ADATA(N+1)).EQ.357) THEN IQIN = NINT(ADATA(N)) CYCLE ELSE IF(NINT(ADATA(N+1)).EQ.358) THEN IEEF = NINT(ADATA(N)) CYCLE END IF ENDDO END IF IALT = 99999999 N = IDATA(24) CQM = '--' DO II=1,5 IF(NINT(ADATA(N+5+II)).NE.2) $ WRITE(CQM(II,1),'(I2.2)') NINT(ADATA(N+5+II)) ENDDO if(subset(6:7).eq.'03') then print 878, stnid,adata(4),alat,c1,alon,c2,nint(adata(n)), $ (nint(adata(n+ii)),ii=1,2),(nint(adata(n+ii)),ii=4,5), $ (cqm(ii,1),ii=1,3),cqm(5,1),adata(11),cres1(1:1), $ cres1(3:3),irff,iqi,iqin,ieef,adata2(43),idata(9),idata(8), $ idata(6) 878 FORMAT(A8,1X,F5.2,F9.5,A1,F10.5,A1,1X,I5.5,I6.5,1X,I4.3,1X, $ I3.3,'/',I4.4,1X,4A2,' RCT ',F5.2,' RES ',2A1,' RF',I3.2, $ ' QI',I3.2,' QIn',I3.2,' EE',I3.2,' ZA',F7.2,' RT',I3,' IT',I3.2, $ ' ',I3) else PRINT 877, STNID,ADATA(4),ALAT,C1,ALON,C2,NINT(ADATA(N)), $ (NINT(ADATA(N+II)),II=1,2),(NINT(ADATA(N+II)),II=4,5), $ (CQM(II,1),II=1,3),CQM(5,1),ADATA(11),CRES1(1:1), $ CRES1(3:3),IRFF,IQI,IQIN,IEEF,ADATA2(43),IDATA(9),IDATA(8), $ IDATA(6) 877 FORMAT(A8,1X,F5.2,F6.2,3x,A1,F7.2,3x,A1,1X,I5.5,I6.5,1X,I4.3,1X, $ I3.3,'/',I4.4,1X,4A2,' RCT ',F5.2,' RES ',2A1,' RF',I3.2, $ ' QI',I3.2,' QIn',I3.2,' EE',I3.2,' ZA',F7.2,' RT',I3,' IT',I3.2, $ ' ',I3) end if GO TO 905 END IF END IF 5689 CONTINUE IF(IDATA(23).GT.0) THEN C CATEGORY 6 C ---------- IALT = 99999999 N = IDATA(24) CQM = '--' DO II=1,5 IF(NINT(ADATA(N+5+II)).NE.2) $ WRITE(CQM(II,1),'(I2.2)') NINT(ADATA(N+5+II)) ENDDO C SPECIAL PROCESSING FOR CAT. 6 DATA IF(DSNAME.EQ.'AIRCFT '.OR.DSNAME.EQ.'AIRCAR ') THEN if(subset.eq.'NC004010') cbull = cres1//' ' PRINT 977, STNID,ADATA(4),alat_8,c1_8,alon_8,c2_8, $ NINT(ADATA(N)),(NINT(ADATA(N+II)),II=1,2),ADATA(N+3), $ (NINT(ADATA(N+II)),II=4,5),(CQM(II,1),II=1,5),ADATA(11), $ CBULL,CRES2,IDATA(9),IDATA(10),IDATA(8) 977 FORMAT(1X,A8,2X,F8.5,'Z',F10.5,A1,F11.5,A1,1X,I5.5,1X,I6.5,1X, $ I4.3,1X,F9.6,1X,I3.3,'/',I4.4,1X,5A2,' RCT ',F5.2,'Z',' "',A11, $ 1X,A8,'" RT',I3,'/',I3,' IT',I3.2) ELSE PRINT 77, STNID,ADATA(4),alat_8,c1_8,alon_8,c2_8, $ NINT(ADATA(N)),(NINT(ADATA(N+II)),II=1,2),ADATA(N+3), $ (NINT(ADATA(N+II)),II=4,5),(CQM(II,1),II=1,5),ADATA(11), $ CRES1,CRES2,IDATA(9),IDATA(10),IDATA(8) 77 FORMAT(1X,A8,2X,F8.5,'Z',F10.5,A1,F11.5,A1,1X,I5.5,1X,I6.5,1X, $ I4.3,1X,F9.6,1X,I3.3,'/',I4.4,1X,5A2,' RCT ',F5.2,'Z',' RES "', $ 2A8,'" RT',I3,'/',I3,' IT',I3.2) END IF ELSE PRINT 7, STNID,ADATA(4),alat_8,c1_8,alon_8,c2_8,NINT(ADATA(7)), $ IDATA(8),IDATA(9) 7 FORMAT(1X,A8,1X,F9.5,'Z',3X,F11.5,A1,2X,F11.5,A1,' ELEVATION', $3X,I6.5,'M',10X,'INST TYPE ',I5.3,12X,'RPT TYPE',I4.3) END IF IF(IDATA(13).GT.0) THEN C CATEGORY 1 C ---------- IADPUP = 1 N = IDATA(14) - 33 J = 0 DO NLVL = 1,IDATA(13),3 J = J + 1 N = N + 33 IF(NLVL+1.GT.IDATA(13)) THEN CQM = '--' DO II=1,5 IF(NINT(ADATA(N+5+II)).NE.2) $ WRITE(CQM(II,1),'(I2.2)') NINT(ADATA(N+5+II)) ENDDO PRINT 7051, CCAT1(J),NINT(ADATA(N)*.1), $ (NINT(ADATA(N+II)),II=1,5),(CQM(II,1),II=1,5) 7051 FORMAT(4X,A4,1X,2X,I4,1X,I5.4,1X,I4.3,1X,I3.3,1X,I3.3, $ '/',I4.4,1X,5A2) ELSE IF(NLVL+2.GT.IDATA(13)) THEN CQM = '--' DO II=1,5 IF(NINT(ADATA(N+5+II)).NE.2) $ WRITE(CQM(II,1),'(I2.2)') NINT(ADATA(N+5+II)) ENDDO DO II=1,5 IF(NINT(ADATA(N+11+5+II)).NE.2) $ WRITE(CQM(II,2),'(I2.2)') NINT(ADATA(N+11+5+II)) ENDDO PRINT 7052, CCAT1(J),NINT(ADATA(N)*.1), $ (NINT(ADATA(N+II)),II=1,5),(CQM(II,1),II=1,5), $ NINT(ADATA(N+11)*.1),(NINT(ADATA(N+11+II)),II=1,5), $ (CQM(II,2),II=1,5) 7052 FORMAT(4X,A4,1X,2(2X,I4,1X,I5.4,1X,I4.3,1X,I3.3,1X,I3.3, $ '/',I4.4,1X,5A2)) ELSE CQM = '--' DO II=1,5 IF(NINT(ADATA(N+5+II)).NE.2) $ WRITE(CQM(II,1),'(I2.2)') NINT(ADATA(N+5+II)) ENDDO DO II=1,5 IF(NINT(ADATA(N+11+5+II)).NE.2) $ WRITE(CQM(II,2),'(I2.2)') NINT(ADATA(N+11+5+II)) ENDDO DO II=1,5 IF(NINT(ADATA(N+22+5+II)).NE.2) $ WRITE(CQM(II,3),'(I2.2)') NINT(ADATA(N+22+5+II)) ENDDO PRINT 7053, CCAT1(J),NINT(ADATA(N)*.1), $ (NINT(ADATA(N+II)),II=1,5),(CQM(II,1),II=1,5), $ NINT(ADATA(N+11)*.1),(NINT(ADATA(N+11+II)),II=1,5), $ (CQM(II,2),II=1,5),NINT(ADATA(N+22)*.1), $ (NINT(ADATA(N+22+II)),II=1,5),(CQM(II,3),II=1,5) 7053 FORMAT(4X,A4,1X,3(2X,I4,1X,I5.4,1X,I4.3,1X,I3.3,1X,I3.3, $ '/',I4.4,1X,5A2)) END IF END DO END IF IF(IDATA(15).GT.0) THEN C CATEGORY 2 C ---------- IADPUP = 1 N = IDATA(16) - 28 J = 0 DO NLVL = 1,IDATA(15),4 J = J + 1 N = N + 28 IF(NLVL+1.GT.IDATA(15)) THEN WRITE(CIND1,'(I2.2)') NINT(ADATA(N+6)) IF(CIND1.EQ.'00') CIND1 = ' ' CQM = '--' DO II=1,3 IF(NINT(ADATA(N+2+II)).NE.2) $ WRITE(CQM(II,1),'(I2.2)') NINT(ADATA(N+2+II)) ENDDO PRINT 7061, CCAT2(J),CIND1,NINT(ADATA(N)), $ (NINT(ADATA(N+II)),II=1,2),(CQM(II,1),II=1,3) 7061 FORMAT(4X,A5,3X,A2,1X,I5.5,1X,I4.3,1X,I3.3,1X,3A2,1X) ELSE IF(NLVL+2.GT.IDATA(15)) THEN WRITE(CIND1,'(I2.2)') NINT(ADATA(N+6)) IF(CIND1.EQ.'00') CIND1 = ' ' WRITE(CIND2,'(I2.2)') NINT(ADATA(N+7+6)) IF(CIND2.EQ.'00') CIND2 = ' ' CQM = '--' DO II=1,3 IF(NINT(ADATA(N+2+II)).NE.2) $ WRITE(CQM(II,1),'(I2.2)') NINT(ADATA(N+2+II)) ENDDO DO II=1,3 IF(NINT(ADATA(N+2+7+II)).NE.2) $ WRITE(CQM(II,2),'(I2.2)') NINT(ADATA(N+2+7+II)) ENDDO PRINT 7062, CCAT2(J),CIND1,NINT(ADATA(N)), $ (NINT(ADATA(N+II)),II=1,2),(CQM(II,1),II=1,3),CIND2, $ NINT(ADATA(N+7)),(NINT(ADATA(N+7+II)),II=1,2), $ (CQM(II,2),II=1,3) 7062 FORMAT(4X,A5,2(3X,A2,1X,I5.5,1X,I4.3,1X,I3.3,1X,3A2, $ 1X)) ELSE IF(NLVL+3.GT.IDATA(15)) THEN WRITE(CIND1,'(I2.2)') NINT(ADATA(N+6)) IF(CIND1.EQ.'00') CIND1 = ' ' WRITE(CIND2,'(I2.2)') NINT(ADATA(N+7+6)) IF(CIND2.EQ.'00') CIND2 = ' ' WRITE(CIND3,'(I2.2)') NINT(ADATA(N+14+6)) IF(CIND3.EQ.'00') CIND3 = ' ' CQM = '--' DO II=1,3 IF(NINT(ADATA(N+2+II)).NE.2) $ WRITE(CQM(II,1),'(I2.2)') NINT(ADATA(N+2+II)) ENDDO DO II=1,3 IF(NINT(ADATA(N+2+7+II)).NE.2) $ WRITE(CQM(II,2),'(I2.2)') NINT(ADATA(N+2+7+II)) ENDDO DO II=1,3 IF(NINT(ADATA(N+2+14+II)).NE.2) $ WRITE(CQM(II,3),'(I2.2)') NINT(ADATA(N+2+14+II)) ENDDO PRINT 7063, CCAT2(J),CIND1,NINT(ADATA(N)), $ (NINT(ADATA(N+II)),II=1,2),(CQM(II,1),II=1,3),CIND2, $ NINT(ADATA(N+7)),(NINT(ADATA(N+7+II)),II=1,2), $ (CQM(II,2),II=1,3),CIND3,NINT(ADATA(N+14)), $ (NINT(ADATA(N+14+II)),II=1,2),(CQM(II,3),II=1,3) 7063 FORMAT(4X,A5,3(3X,A2,1X,I5.5,1X,I4.3,1X,I3.3,1X,3A2, $ 1X)) ELSE WRITE(CIND1,'(I2.2)') NINT(ADATA(N+6)) IF(CIND1.EQ.'00') CIND1 = ' ' WRITE(CIND2,'(I2.2)') NINT(ADATA(N+7+6)) IF(CIND2.EQ.'00') CIND2 = ' ' WRITE(CIND3,'(I2.2)') NINT(ADATA(N+14+6)) IF(CIND3.EQ.'00') CIND3 = ' ' WRITE(CIND4,'(I2.2)') NINT(ADATA(N+21+6)) IF(CIND4.EQ.'00') CIND4 = ' ' CQM = '--' DO II=1,3 IF(NINT(ADATA(N+2+II)).NE.2) $ WRITE(CQM(II,1),'(I2.2)') NINT(ADATA(N+2+II)) ENDDO DO II=1,3 IF(NINT(ADATA(N+2+7+II)).NE.2) $ WRITE(CQM(II,2),'(I2.2)') NINT(ADATA(N+2+7+II)) ENDDO DO II=1,3 IF(NINT(ADATA(N+2+14+II)).NE.2) $ WRITE(CQM(II,3),'(I2.2)') NINT(ADATA(N+2+14+II)) ENDDO DO II=1,3 IF(NINT(ADATA(N+2+21+II)).NE.2) $ WRITE(CQM(II,4),'(I2.2)') NINT(ADATA(N+2+21+II)) ENDDO PRINT 7064, CCAT2(J),CIND1,NINT(ADATA(N)), $ (NINT(ADATA(N+II)),II=1,2),(CQM(II,1),II=1,3),CIND2, $ NINT(ADATA(N+7)),(NINT(ADATA(N+7+II)),II=1,2), $ (CQM(II,2),II=1,3),CIND3,NINT(ADATA(N+14)), $ (NINT(ADATA(N+14+II)),II=1,2),(CQM(II,3),II=1,3),CIND4, $ NINT(ADATA(N+21)),(NINT(ADATA(N+21+II)),II=1,2), $ (CQM(II,4),II=1,3) 7064 FORMAT(4X,A5,4(3X,A2,1X,I5.5,1X,I4.3,1X,I3.3,1X,3A2, $ 1X)) END IF END DO END IF IF(IDATA(17).GT.0) THEN C CATEGORY 3 C ---------- IADPUP = 1 N = IDATA(18) - 24 J = 0 DO NLVL = 1,IDATA(17),4 J = J + 1 N = N + 24 IF(NLVL+1.GT.IDATA(17)) THEN WRITE(CIND1,'(I2.2)') NINT(ADATA(N+5)) IF(CIND1.EQ.'00') CIND1 = ' ' CQM = '--' DO II=1,2 IF(NINT(ADATA(N+2+II)).NE.2) $ WRITE(CQM(II,1),'(I2.2)') NINT(ADATA(N+2+II)) ENDDO PRINT 7071, CCAT3(J),CIND1,NINT(ADATA(N)), $ (NINT(ADATA(N+II)),II=1,2),(CQM(II,1),II=1,2) 7071 FORMAT(4X,A5,3X,A2,1X,I5.5,1X,I3.3,'/',I4.4,1X,2A2,3X) ELSE IF(NLVL+2.GT.IDATA(17)) THEN WRITE(CIND1,'(I2.2)') NINT(ADATA(N+5)) IF(CIND1.EQ.'00') CIND1 = ' ' WRITE(CIND2,'(I2.2)') NINT(ADATA(N+6+5)) IF(CIND2.EQ.'00') CIND2 = ' ' CQM = '--' DO II=1,2 IF(NINT(ADATA(N+2+II)).NE.2) $ WRITE(CQM(II,1),'(I2.2)') NINT(ADATA(N+2+II)) ENDDO DO II=1,2 IF(NINT(ADATA(N+2+6+II)).NE.2) $ WRITE(CQM(II,2),'(I2.2)') NINT(ADATA(N+2+6+II)) ENDDO PRINT 7072, CCAT3(J),CIND1,NINT(ADATA(N)), $ (NINT(ADATA(N+II)),II=1,2),(CQM(II,1),II=1,2),CIND2, $ NINT(ADATA(N+6)),(NINT(ADATA(N+6+II)),II=1,2), $ (CQM(II,2),II=1,2) 7072 FORMAT(4X,A5,2(3X,A2,1X,I5.5,1X,I3.3,'/',I4.4,1X, $ 2A2,3X)) ELSE IF(NLVL+3.GT.IDATA(17)) THEN WRITE(CIND1,'(I2.2)') NINT(ADATA(N+5)) IF(CIND1.EQ.'00') CIND1 = ' ' WRITE(CIND2,'(I2.2)') NINT(ADATA(N+6+5)) IF(CIND2.EQ.'00') CIND2 = ' ' WRITE(CIND3,'(I2.2)') NINT(ADATA(N+12+5)) IF(CIND3.EQ.'00') CIND3 = ' ' CQM = '--' DO II=1,2 IF(NINT(ADATA(N+2+II)).NE.2) $ WRITE(CQM(II,1),'(I2.2)') NINT(ADATA(N+2+II)) ENDDO DO II=1,2 IF(NINT(ADATA(N+2+6+II)).NE.2) $ WRITE(CQM(II,2),'(I2.2)') NINT(ADATA(N+2+6+II)) ENDDO DO II=1,2 IF(NINT(ADATA(N+2+12+II)).NE.2) $ WRITE(CQM(II,3),'(I2.2)') NINT(ADATA(N+2+12+II)) ENDDO PRINT 7073, CCAT3(J),CIND1,NINT(ADATA(N)), $ (NINT(ADATA(N+II)),II=1,2),(CQM(II,1),II=1,2),CIND2, $ NINT(ADATA(N+6)),(NINT(ADATA(N+6+II)),II=1,2), $ (CQM(II,2),II=1,2),CIND3,NINT(ADATA(N+12)), $ (NINT(ADATA(N+12+II)),II=1,2),(CQM(II,3),II=1,2) 7073 FORMAT(4X,A5,3(3X,A2,1X,I5.5,1X,I3.3,'/',I4.4,1X, $ 2A2,3X)) ELSE WRITE(CIND1,'(I2.2)') NINT(ADATA(N+5)) IF(CIND1.EQ.'00') CIND1 = ' ' WRITE(CIND2,'(I2.2)') NINT(ADATA(N+6+5)) IF(CIND2.EQ.'00') CIND2 = ' ' WRITE(CIND3,'(I2.2)') NINT(ADATA(N+12+5)) IF(CIND3.EQ.'00') CIND3 = ' ' WRITE(CIND4,'(I2.2)') NINT(ADATA(N+18+5)) IF(CIND4.EQ.'00') CIND4 = ' ' CQM = '--' DO II=1,2 IF(NINT(ADATA(N+2+II)).NE.2) $ WRITE(CQM(II,1),'(I2.2)') NINT(ADATA(N+2+II)) ENDDO DO II=1,2 IF(NINT(ADATA(N+2+6+II)).NE.2) $ WRITE(CQM(II,2),'(I2.2)') NINT(ADATA(N+2+6+II)) ENDDO DO II=1,2 IF(NINT(ADATA(N+2+12+II)).NE.2) $ WRITE(CQM(II,3),'(I2.2)') NINT(ADATA(N+2+12+II)) ENDDO DO II=1,2 IF(NINT(ADATA(N+2+18+II)).NE.2) $ WRITE(CQM(II,4),'(I2.2)') NINT(ADATA(N+2+18+II)) ENDDO PRINT 7074, CCAT3(J),CIND1,NINT(ADATA(N)), $ (NINT(ADATA(N+II)),II=1,2),(CQM(II,1),II=1,2),CIND2, $ NINT(ADATA(N+6)),(NINT(ADATA(N+6+II)),II=1,2), $ (CQM(II,2),II=1,2),CIND3,NINT(ADATA(N+12)), $ (NINT(ADATA(N+12+II)),II=1,2),(CQM(II,3),II=1,2),CIND4, $ NINT(ADATA(N+18)),(NINT(ADATA(N+18+II)),II=1,2), $ (CQM(II,4),II=1,2) 7074 FORMAT(4X,A5,4(3X,A2,1X,I5.5,1X,I3.3,'/',I4.4,1X, $ 2A2,3X)) END IF END DO END IF IF(IDATA(19).GT.0) THEN C CATEGORY 4 C ---------- IADPUP = 1 N = IDATA(20) - 20 J = 0 DO NLVL = 1,IDATA(19),4 J = J + 1 N = N + 20 IF(NLVL+1.GT.IDATA(19)) THEN CQM = '--' DO II=1,2 IF(NINT(ADATA(N+2+II)).NE.2) $ WRITE(CQM(II,1),'(I2.2)') NINT(ADATA(N+2+II)) ENDDO PRINT 7101, CCAT4(J),NINT(ADATA(N)), $ (NINT(ADATA(N+II)),II=1,2),(CQM(II,1),II=1,2) 7101 FORMAT(4X,A5,6X,I5.5,1X,I3.3,'/',I4.4,1X,2A2,3X) ELSE IF(NLVL+2.GT.IDATA(19)) THEN CQM = '--' DO II=1,2 IF(NINT(ADATA(N+2+II)).NE.2) $ WRITE(CQM(II,1),'(I2.2)') NINT(ADATA(N+2+II)) ENDDO DO II=1,2 IF(NINT(ADATA(N+2+5+II)).NE.2) $ WRITE(CQM(II,2),'(I2.2)') NINT(ADATA(N+2+5+II)) ENDDO PRINT 7102, CCAT4(J),NINT(ADATA(N)), $ (NINT(ADATA(N+II)),II=1,2),(CQM(II,1),II=1,2), $ NINT(ADATA(N+5)),(NINT(ADATA(N+5+II)),II=1,2), $ (CQM(II,2),II=1,2) 7102 FORMAT(4X,A5,2(6X,I5.5,1X,I3.3,'/',I4.4,1X,2A2,3X)) ELSE IF(NLVL+3.GT.IDATA(19)) THEN CQM = '--' DO II=1,2 IF(NINT(ADATA(N+2+II)).NE.2) $ WRITE(CQM(II,1),'(I2.2)') NINT(ADATA(N+2+II)) ENDDO DO II=1,2 IF(NINT(ADATA(N+2+5+II)).NE.2) $ WRITE(CQM(II,2),'(I2.2)') NINT(ADATA(N+2+5+II)) ENDDO DO II=1,2 IF(NINT(ADATA(N+2+10+II)).NE.2) $ WRITE(CQM(II,3),'(I2.2)') NINT(ADATA(N+2+10+II)) ENDDO PRINT 7103, CCAT4(J),NINT(ADATA(N)), $ (NINT(ADATA(N+II)),II=1,2),(CQM(II,1),II=1,2), $ NINT(ADATA(N+5)),(NINT(ADATA(N+5+II)),II=1,2), $ (CQM(II,2),II=1,2),NINT(ADATA(N+10)), $ (NINT(ADATA(N+10+II)),II=1,2),(CQM(II,3),II=1,2) 7103 FORMAT(4X,A5,3(6X,I5.5,1X,I3.3,'/',I4.4,1X,2A2,3X)) ELSE CQM = '--' DO II=1,2 IF(NINT(ADATA(N+2+II)).NE.2) $ WRITE(CQM(II,1),'(I2.2)') NINT(ADATA(N+2+II)) ENDDO DO II=1,2 IF(NINT(ADATA(N+2+5+II)).NE.2) $ WRITE(CQM(II,2),'(I2.2)') NINT(ADATA(N+2+5+II)) ENDDO DO II=1,2 IF(NINT(ADATA(N+2+10+II)).NE.2) $ WRITE(CQM(II,3),'(I2.2)') NINT(ADATA(N+2+10+II)) ENDDO DO II=1,2 IF(NINT(ADATA(N+2+15+II)).NE.2) $ WRITE(CQM(II,4),'(I2.2)') NINT(ADATA(N+2+15+II)) ENDDO PRINT 7104, CCAT4(J),NINT(ADATA(N)), $ (NINT(ADATA(N+II)),II=1,2),(CQM(II,1),II=1,2), $ NINT(ADATA(N+5)),(NINT(ADATA(N+5+II)),II=1,2), $ (CQM(II,2),II=1,2),NINT(ADATA(N+10)), $ (NINT(ADATA(N+10+II)),II=1,2),(CQM(II,3),II=1,2), $ NINT(ADATA(N+15)),(NINT(ADATA(N+15+II)),II=1,2), $ (CQM(II,4),II=1,2) 7104 FORMAT(4X,A5,4(6X,I5.5,1X,I3.3,'/',I4.4,1X,2A2,3X)) END IF END DO END IF IF(IDATA(21).GT.0) THEN C CATEGORY 5 C ---------- IADPUP = 1 N = IDATA(22) - 27 J = 0 DO NLVL = 1,IDATA(21),3 J = J + 1 N = N + 27 IF(NLVL+1.GT.IDATA(21)) THEN CQM = '--' DO II=1,4 IF(NINT(ADATA(N+4+II)).NE.2) $ WRITE(CQM(II,1),'(I2.2)') NINT(ADATA(N+4+II)) ENDDO PRINT 7081, CCAT5(J),NINT(ADATA(N)), $ (NINT(ADATA(N+II)),II=1,4),(CQM(II,1),II=1,4) 7081 FORMAT(4X,A10,1X,I5.5,1X,I4.3,1X,I3.3,1X,I3.3,'/',I4.4, $ 1X,4A2,3X) ELSE IF(NLVL+2.GT.IDATA(21)) THEN CQM = '--' DO II=1,4 IF(NINT(ADATA(N+4+II)).NE.2) $ WRITE(CQM(II,1),'(I2.2)') NINT(ADATA(N+4+II)) ENDDO DO II=1,4 IF(NINT(ADATA(N+4+9+II)).NE.2) $ WRITE(CQM(II,2),'(I2.2)') NINT(ADATA(N+4+9+II)) ENDDO PRINT 7082, CCAT5(J),NINT(ADATA(N)), $ (NINT(ADATA(N+II)),II=1,4),(CQM(II,1),II=1,4), $ NINT(ADATA(N+9)),(NINT(ADATA(N+9+II)),II=1,4), $ (CQM(II,2),II=1,4) 7082 FORMAT(4X,A10,1X,2(I5.5,1X,I4.3,1X,I3.3,1X,I3.3,'/',I4.4, $ 1X,4A2,3X)) ELSE CQM = '--' DO II=1,4 IF(NINT(ADATA(N+4+II)).NE.2) $ WRITE(CQM(II,1),'(I2.2)') NINT(ADATA(N+4+II)) ENDDO DO II=1,4 IF(NINT(ADATA(N+4+9+II)).NE.2) $ WRITE(CQM(II,2),'(I2.2)') NINT(ADATA(N+4+9+II)) ENDDO DO II=1,4 IF(NINT(ADATA(N+4+18+II)).NE.2) $ WRITE(CQM(II,3),'(I2.2)') NINT(ADATA(N+4+18+II)) ENDDO PRINT 7083, CCAT5(J),NINT(ADATA(N)), $ (NINT(ADATA(N+II)),II=1,4),(CQM(II,1),II=1,4), $ NINT(ADATA(N+9)),(NINT(ADATA(N+9+II)),II=1,4), $ (CQM(II,2),II=1,4),NINT(ADATA(N+18)), $ (NINT(ADATA(N+18+II)),II=1,4),(CQM(II,3),II=1,4) 7083 FORMAT(4X,A10,1X,3(I5.5,1X,I4.3,1X,I3.3,1X,I3.3,'/',I4.4, $ 1X,4A2,3X)) END IF END DO END IF IF(IDATA(27).GT.0) THEN C CATEGORY 8 C ---------- N = IDATA(28) - 16 J = 0 DO NLVL = 1,IDATA(27),4 J = J + 1 N = N + 16 IF(NLVL+1.GT.IDATA(27)) THEN IF(ADATA(N+1).EQ.21) THEN C Allow report sequence number (code fig. 21) to be as large as 999999 C -------------------------------------------------------------------- ADATA(N) = MIN(ADATA(N),999999.) ELSE C All other cat. 8 parameters can only be as large as XMISS (99999.) C ------------------------------------------------------------------ ADATA(N) = MIN(ADATA(N),XMISS) END IF PRINT 7091,CCAT8(J),NINT(ADATA(N)), $ (NINT(ADATA(N+II)),II=1,3) 7091 FORMAT(4X,A11,I6.5,1X,I3.3,2(1X,I5.5),3X) ELSE IF(NLVL+2.GT.IDATA(27)) THEN DO II = 4,8,4 IF(ADATA(N-4+II+1).EQ.21) THEN C Allow report sequence number (code fig. 21) to be as large as 999999 C -------------------------------------------------------------------- ADATA(N-4+II) = MIN(ADATA(N-4+II),999999.) ELSE C All other cat. 8 parameters can only be as large as XMISS (99999.) C ------------------------------------------------------------------ ADATA(N-4+II) = MIN(ADATA(N-4+II),XMISS) END IF ENDDO PRINT 7092,CCAT8(J),NINT(ADATA(N)), $ (NINT(ADATA(N+II)),II=1,3),NINT(ADATA(N+4)), $ (NINT(ADATA(N+4+II)),II=1,3) 7092 FORMAT(4X,A11,2(I6.5,1X,I3.3,2(1X,I5.5),3X)) ELSE IF(NLVL+3.GT.IDATA(27)) THEN DO II = 4,12,4 IF(ADATA(N-4+II+1).EQ.21) THEN C Allow report sequence number (code fig. 21) to be as large as 999999 C -------------------------------------------------------------------- ADATA(N-4+II) = MIN(ADATA(N-4+II),999999.) ELSE C All other cat. 8 parameters can only be as large as XMISS (99999.) C ------------------------------------------------------------------ ADATA(N-4+II) = MIN(ADATA(N-4+II),XMISS) END IF ENDDO PRINT 7093,CCAT8(J),NINT(ADATA(N)), $ (NINT(ADATA(N+II)),II=1,3),NINT(ADATA(N+4)), $ (NINT(ADATA(N+4+II)),II=1,3),NINT(ADATA(N+8)), $ (NINT(ADATA(N+8+II)),II=1,3) 7093 FORMAT(4X,A11,3(I6.5,1X,I3.3,2(1X,I5.5),3X)) ELSE DO II = 4,16,4 IF(ADATA(N-4+II+1).EQ.21) THEN C Allow report sequence number (code fig. 21) to be as large as 999999 C -------------------------------------------------------------------- ADATA(N-4+II) = MIN(ADATA(N-4+II),999999.) ELSE C All other cat. 8 parameters can only be as large as XMISS (99999.) C ------------------------------------------------------------------ ADATA(N-4+II) = MIN(ADATA(N-4+II),XMISS) END IF ENDDO PRINT 7094,CCAT8(J),NINT(ADATA(N)), $ (NINT(ADATA(N+II)),II=1,3),NINT(ADATA(N+4)), $ (NINT(ADATA(N+4+II)),II=1,3),NINT(ADATA(N+8)), $ (NINT(ADATA(N+8+II)),II=1,3),NINT(ADATA(N+12)), $ (NINT(ADATA(N+12+II)),II=1,3) 7094 FORMAT(4X,A11,4(I6.5,1X,I3.3,2(1X,I5.5),3X)) END IF END DO END IF C DATA RETURNED DIRECTLY FROM BUFR DUMP FILE (ADATA2 & ADATA3 ARRAYS) C {applies only to BUFR types 002 (all) & 004 (all) C ------------------------------------------------------------------- IF(SUBSET(1:5).EQ.'NC002'.OR.SUBSET(1:5).EQ.'NC004') THEN IF(MIN(ADATA2(1),ADATA2(2),ADATA2(4),ADATA2(41),ADATA2(24), $ ADATA2(42)).LT.BMISS) THEN IF(MIN(ADATA2(4),ADATA2(41),ADATA2(24)).LT.BMISS) THEN PRINT 1134, (NINT(ADATA2(I)),I=1,2),ADATA2(4), $ NINT(ADATA2(41)),NINT(ADATA2(24)) 1134 FORMAT(4X,'RSRD ',I3,', EXPRSRD ',I3,', SST1 ',F6.2,', SSTQM ',I2, $ ', HBLCS ',I2) ELSE IF(ADATA2(42).LT.BMISS.OR.SUBSET.EQ.'NC004004') THEN PRINT 1138, (NINT(ADATA2(I)),I=1,2),NINT(ADATA2(42)) 1138 FORMAT(4X,'RSRD ',I3,', EXPRSRD ',I3,', MSTQ ',I2) ELSE cc PRINT 1135, (NINT(ADATA2(I)),I=1,2) ! strange compiler ! error! (use below) i_ADATA2_1 = NINT(ADATA2(1)) i_ADATA2_2 = NINT(ADATA2(2)) PRINT 1135, i_ADATA2_1,i_ADATA2_2 1135 FORMAT(4X,'RSRD ',I3,', EXPRSRD ',I3) END IF END IF IF(MIN(ADATA2(27),ADATA2(28)).LT.BMISS) $ PRINT 1154, NINT(ADATA2(27)),ADATA2(28) 1154 FORMAT(4X,'WDIR1 ',I3,', WSPD1 ',F5.1) cpppppppppp cc print'(1X)' cc print'(" NDATA3 = ",7(I0,1X))', ndata3 cpppppppppp if(ndata3(2).gt.0) then if(ndata3(2).eq.1) then if(adata3(1,1,2).ge.bmiss) go to 402 end if cpppppppppp cc print'(1X)' cc print'(" ADATA3(*,*,2):")' cpppppppppp IF(NDATA3(2).EQ.1) THEN JNDX = 1 PRINT 1136, (J,NINT(ADATA3(1,J,2)),J=1,1) ELSE DO K = 1,NDATA3(2),8 DO L = 8,2,-1 IF(K+(L-1).LE.NDATA3(2)) THEN JNDX = L PRINT 1136, (J,NINT(ADATA3(1,J,2)),J=K,K+(L-1)) EXIT END IF ENDDO ENDDO END IF 1136 FORMAT(3X,(' L',I1,': PRWE ',I3,' |')) end if 402 continue if(ndata3(3).gt.0) then if(ndata3(3).eq.1) then if(min(adata3(2,1,3),adata3(3,1,3),adata3(4,1,3), $ adata3(5,1,3)).ge.bmiss) go to 403 end if cpppppppppp cc print'(1X)' cc print'(" ADATA3(*,*,3):")' cpppppppppp DO K = 1,NDATA3(3),2 IF(K+1.LE.NDATA3(3)) THEN JNDX = 2 PRINT 1137, (J,(NINT(ADATA3(I,J,3)),I=2,5),J=K,K+1) ELSE JNDX = 1 PRINT 1137, (J,(NINT(ADATA3(I,J,3)),I=2,5),J=K,K) END IF 1137 FORMAT(3X,(' L',I1,': CLAM ',I2,', CLTP ',I2,', HOCB ',I5, $ ', HOCT ',I5,' |')) ENDDO end if 403 continue if(ndata3(6).gt.0) then if(ndata3(6).eq.1) then if(min(adata3(1,1,6),adata3(2,1,6),adata3(3,1,6)).ge. $ bmiss) go to 405 end if cpppppppppp cc print'(1X)' cc print'(" ADATA3(*,*,6):")' cpppppppppp IF(NDATA3(6).EQ.1) THEN JNDX = 1 PRINT 4135, (J,NINT(ADATA3(1,J,6)),NINT(ADATA3(2,J,6)), $ NINT(ADATA3(3,J,6)),J=1,1) ELSE DO K = 1,NDATA3(6),3 DO L = 3,2,-1 IF(K+(L-1).LE.NDATA3(6)) THEN JNDX = L PRINT 4135, (J,NINT(ADATA3(1,J,6)), $ NINT(ADATA3(2,J,6)),NINT(ADATA3(3,J,6)), $ J=K,K+(L-1)) EXIT END IF ENDDO ENDDO END IF 4135 FORMAT(3X,(' L',I1,': AFIC=',I2,', HBOI=',I6,', HTOI=',I6, $ ' |')) end if 405 continue if(ndata3(7).gt.0) then if(ndata3(7).eq.1) then if(min(adata3(1,1,7),adata3(2,1,7),adata3(3,1,7)).ge. $ bmiss) go to 406 end if cpppppppppp cc print'(1X)' cc print'(" ADATA3(*,*,7):")' cpppppppppp IF(NDATA3(7).EQ.1) THEN JNDX = 1 PRINT 4136, (J,NINT(ADATA3(1,J,7)),NINT(ADATA3(2,J,7)), $ NINT(ADATA3(3,J,7)),J=1,1) ELSE DO K = 1,NDATA3(7),3 DO L = 3,2,-1 IF(K+(L-1).LE.NDATA3(7)) THEN JNDX = L PRINT 4136, (J,NINT(ADATA3(1,J,7)), $ NINT(ADATA3(2,J,7)),NINT(ADATA3(3,J,7)), $ J=K,K+(L-1)) EXIT END IF ENDDO ENDDO END IF 4136 FORMAT(3X,(' L',I1,': DGOT=',I2,', HBOT=',I6,', HTOT=',I6, $ ' |')) end if 406 continue IF(SUBSET(1:5).NE.'NC004') THEN print'(1X)' print'(1X)' END IF END IF IF(IADPUP.EQ.1) PRINT 993 993 FORMAT(' ') IF(SORTID) GO TO 8000 GO TO 905 C----------------------------------------------------------------------- 906 CONTINUE PRINT 9004, NUNIT,KOUNT 9004 FORMAT(//45X,'--> ALL REPORTS IN FILE',I3,' PROCESSED <--'//48X, $ '*** ',I6,' REPORTS LISTED HERE ***'/) IF(KNTTIM.GT.0) PRINT 9005, KNTTIM 9005 FORMAT(' --> ',I5,' REPORTS OUTSIDE OF SELECTED TIME WINDOW AND ', $ 'NOT LISTED HERE <--'/) IF(KNTLAT.GT.0) PRINT 9006, KNTLAT 9006 FORMAT(' --> ',I6,' REPORTS OUTSIDE OF SELECTED LATITUDE BAND ', $ 'AND NOT LISTED HERE <--'/) IF(KNTLON.GT.0) PRINT 9007, KNTLON 9007 FORMAT(' --> ',I6,' REMAINING REPORTS OUTSIDE OF SELECTED ', $ 'LONGITUDE BAND AND NOT LISTED HERE <--'/) PRINT 9008 9008 FORMAT(/38X,'>>> SUCCESSFUL COMPLETION OF PROGRAM ', $ 'BUFR_LISTDUMPS <<<'/) RETURN C----------------------------------------------------------------------- 999 CONTINUE PRINT 567, IER 567 FORMAT('**BUFR_LISTDUMPS/LISTUPA: RETURN CODE =',I3,'; SOME TYPE', $ ' OF ERROR IN DECODING REPORT FROM INPUT BUFR FILE - STOP 99') CALL W3TAGE('BUFR_LISTDUMPS') CALL ERREXIT(99) C----------------------------------------------------------------------- END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: LISTSFC C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2017-10-13 C C ABSTRACT: LISTS CONTENTS OF A TIME-WINDOWED SURFACE BUFR DATA DUMP C FILE. THE STANDARD OUTPUT IS IN AN EASY-TO-READ FORMAT. NOTE: C THIS SUBROUTINE CAN HANDLE THE FOLLOWING BUFR DATA DUMP FILE C TYPES: ADPSFC, SFCSHP, SFCBOG, MSONET. C C PROGRAM HISTORY LOG: C 2000-03-28 D.A. KEYSER -- ORIGINAL AUTHOR C 2002-05-22 D.A. KEYSER -- CAN NOW LIST MESONET REPORTS FROM THE C "MSONET" DATA DUMP FILE C 2004-02-02 D.A. KEYSER -- MODIFIED TO LIST ELEVATION Q.M. SINCE C SUBR. IW3UNPBF CAN NOW PROCESS MOBILE SURFACE LAND SYNOPTIC C REPORTS OUT OF ADPSFC DUMP FILE; MODIFIED LISTING OF CATEGORY 8 C MESONET DATA (MORE VARIABLES NOW RETURNED FROM SUBR. IW3UNPBF); C LAT/LON LISTING NOW CARRIES FOUR SIGNIFICANT DIGITS (WAS TWO) C 2004-09-09 KEYSER -- NOW PRINTS ALTIMETER SETTING, SST AND SINGLE- C LEVEL SENSIBLE WEATHER ELEMENTS FROM ADATA2 AND MULTIPLE-LEVEL C SENSIBLE WEATHER ELEMENTS FROM ADATA3 RETURNED FROM IW3UNPBF; C INFORMATION THAT HAD BEEN PRINTED FROM CATEGORIES 51, 52 AND 8 C RETURNED FROM IW3UNPBF THAT IS NOW RETURNED IN ADATA2 AND ADATA3 C IS NOW IGNORED; NO ATTEMPT IS MADE TO PRINT DATA IN CATEGORY 52 C SINCE IT IS LONGER CONSIDERED IN IW3UNPBF C 2007-09-14 D. A. KEYSER -- BUMP UP ARRAY SIZE FOR UNPACKED REPORT C FROM IW3UNPBF FROM 3000 TO 3500; IMPROVED DOCUMENTATION AT TOP OF C LISTINGS FOR "ADPSFC", "MSONET", "SFCSHP" AND "SFCBOG" DUMPS; C CORRECTED ERROR WHICH PREVENTED "SFCBOG" PMSL FROM BEING LISTED C 2010-06-07 D. A. KEYSER -- ADDED LISTING OF ALTIMETER Q.M. FOR C ADPSFC REPORTS SINCE THIS CAN NOW BE PRESENT IN SOME CASES FOR C METARS (CURRENTLY WHEN SDMEDIT PRESSURE Q.M. IS 12 OR 14 IN C WHICH CASE IW3UNPBF STORES THIS AS ALTIMETER Q.M.) C 2014-04-22 D. A. KEYSER -- BUMPED UP ARRAY SIZE FOR "ADATA2", C RETURNED OUT OF CALL TO IW3UNPBF, FROM 42 TO 43, NEW WORD 43 C HOLDS SATELLITE ZENITH ANGLE (DEGREES, SATWND TYPES ONLY); ADDED C OPTION TO SORT LISTING OF "ADPSFC" DUMP BY REPORT ID AND WITHIN C REQUESTED OBS TIME (HARDWIRED TO NOT DO SORTING). ABORTS WITH C RC=65 IF > 40000 ADPSFC REPORTS (EXCEEDS SORT LIMIT). C 2016-11-30 D. A. KEYSER -- Reads new output real, double-precision C argument array ADATA_8 of length 2 in call to IW3UNPBF. This C returns latitude and longitude for each report which is then C stored in R*8 variables ALAT_8 and ALON_8 prior to listing for the C following dump types: ADPSFC, SFCSHP and MSONET. C BENEFIT: Replaces lat/lon returned in ADATA(1:2) in call to C IW3UNPBF for these types which are just at machine C precison (normally R*4). Now that reports in these dumps C can store lat/lon at 0.00001 degree precision this change C will ensure that lat/lon is always accurate to 0.00001 C degrees in these listings. C 2017-10-13 D. A. KEYSER -- Added minutes to every print statement C that includes the central dump time. Central dump time minutes is C obtained from Section 1 of first (dummy) message of input dump C file via call to BUFRLIB routine IUPVS01. C BENEFIT: Until now, central dump time minutes was always zero. C However, with the implementation of the new RTMA_RU, C central dump time can now also have minutes = 15, 30 C or 45 (since the RTMA_RU runs 4 times per hour). This C change allows the print statements to reflect this new C center dump time format. C 2020-07-07 S. MELCHIOR -- Accommodate BUFR format buoy data. C 2021-06-24 S. MELCHIOR -- Accommodate BUFR format ship and cman data. C C USAGE: CALL LISTSFC C C INPUT FILES: C UNIT 05 - INPUT DATA CARDS IN THE FORM OF A NAMELIST (SEE C - REMARKS IN MAIN PROGRAM DOCBLOCK) C UNIT 21 - BUFR DATA SET C C OUTPUT FILES: C UNIT 06 - STANDARD OUTPUT PRINT C C REMARKS: NONE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ SUBROUTINE LISTSFC PARAMETER (MAXOBS = 3500) CHARACTER*1 C1,C2,CHAR1,c1_8,c2_8 CHARACTER*2 CQM(5) CHARACTER*8 STNID,CRES1,CRES2,DSNAME,SUBSET,DSNAME_LC, $ STNID_S(40000),CRES1_S(40000),CRES2_S(40000),SUBSET_S(40000) CHARACTER*10 CCAT8(60) CHARACTER*11 CBULL CHARACTER*15 CDATUM(3),CIND2(3) LOGICAL GLOBAL,SUBSKP(0:255,0:200),SORTID REAL ADATA(MAXOBS),ADATA_S(MAXOBS,40000),ADATA2(43), $ ADATA2_S(43,40000),ADATA3(5,255,7),ADATA3_S(5,255,7,40000), $ OB8(3),Q82(3) REAL(8) BMISS,adata8_8(2),alat_8,alon_8,adata8_8_s(2,40000) INTEGER IDATA(MAXOBS),ICAT(17),INDX(40000),NDATA3(7),IQM(255), $ NDATA3_S(7,40000) INTEGER(8) IDSDMP_8,IWORK_8(40000) COMMON/TYPE/DSNAME_LC COMMON/BUFRLIB_MISSING/BMISS EQUIVALENCE (ADATA,IDATA) DATA XMISS/99999./,IMISS/99999/ DATA NUNIT/21/ DATA CCAT8/'ADDIT-DATA',59*' '/ DATA ICAT/1,2,3,4,5,6,-99,8,51,-99,-99,10,11,12,13,14,15/ NAMELIST/SDATA/LATS,LATN,LONW,LONE,CHAR1,SUBSKP SORTID = .FALSE. IF(DSNAME_LC.EQ.'adpsfc') THEN PRINT 101 101 FORMAT(5X,'KEY FOR DATA LISTED IN EACH REPORT BELOW:'/ $/10X,'Field 1 ....... WMO Block/Station number' $/10X,'Field 2 ....... Observation time (UTC)' $/10X,'Field 3 ....... Latitude (N,S)' $/10X,'Field 4 ....... Longitude (E,W)' $/10X,'ELV/QM ......... Elevation (meters) / quality marker ', $ '(BUFR Code Table 0-33-024 -' $/28X,'see http://www.emc.ncep.noaa.gov/mmb/data_processing/table', $ '_25-35.htm#0-33-024)' $/10X,'ITP ............ Instrument type (always missing)' $/10X,'RCT ............ Receipt time (UTC)' $/10X,'RES ............ SYNOP: Reserve characters (16) {1 = ', $ 'Indicator for precipitation inclusion (BUFR Code Table 0-13-', $ '194,' $/28X,'see http://www.emc.ncep.noaa.gov/mmb/data_processing/table', $ '_local_await-val.htm#0-13-194), 2 = blank,' $/28X,'3 = Indicator for wind speed (source/units) ("0" - wind ', $ 'speed estimated in m/sec "uncertified' $/28X,'instrument", "1" - wind speed obtained from anemometer in ', $ 'm/sec "certified instrument", "3" - wind', $/28X,'speed estimated in knots "uncertified instrument", "4" - ', $ 'wind speed obtained from anemometer in knots' $/28X,'"certified instrument", "7" - Missing), 4 = blank, 5 = ', $ 'Indicator for station operation/past weather' $/28X,'data (BUFR Code Table 0-02-193,' $/28X,'see http://www.emc.ncep.noaa.gov/mmb/data_processing/table', $ '_local_await-val.htm#0-02-193), 6-16 = blank}' $/10X,' METAR: Reserve characters (16) {1-8 = ', $ 'blank, 9-13 = Type of hourly report ("METAR", "SPECI" OR ', $ '"LWIS ",' $/28X,'unknown is "?????"), 14-15 = blank, 16 = Corrected report ', $ 'indicator ("0" - not corrected, "1" - ' $/28X,'corrected by report originator, "2" - corrected by NCEP ', $ 'SDM, "7" - missing)}' $/10X,'RTP ............ Dump report type {511 - Fixed land ', $ 'surface by block and station number (synoptic, both ', $ 'unrestricted and' $/28X,'restricted WMO Res. 40), 512 - Fixed land surface by call ', $ 'letters (METAR), 514 - Mobile land surface ' $/28X,'(synoptic)}' $/10X,'MSL/STNP ....... Mean sea-level pressure / station ', $ 'pressure (both x 10 mb)' $/10X,'Next field ..... Wind direction (degrees) / wind speed ', $ '(x 10 m/sec)' $/10X,'Next field ..... Air temperature (x 10 degrees C)' $/10X,'Next field ..... Dewpoint depression (x 10 degrees C)' $/10X,'Next field ..... Quality markers in form AABBCCDDEE, where', $ ' AA = sea-level pressure, BB = station pressure, CC = wind,' $/28X,'DD = air temprature, EE = dewpoint depression (00 - ', $ 'monitor keep, 01 - good, 02 - neutral/not checked,' $/28X,'03 - suspect, 12 - toss, on reject list, 13 - toss, failed', $ ' automatic q.c. tests, 14 - toss, monitor' $/28X,'purge)' $/28X,'Note: If quality marker is default value of 02 then "--" ', $ 'is stamped out here rather than "02"' $//10X,'BUFR mnemonics:' $/15X,'RSRD ..... Restrictions on redistribution, Flag Table 0-35', $ '-200 (' $/32X,' 16 - can redistribute to any U.S. government agency ', $ 'within NOAA,' $/32X,'128 - can redistribute to any U.S. government agency,' $/32X,'160 - can redistribute to any U.S. government agency or ', $ 'educational institution,' $/32X,'192 - can redistribute to any U.S. government agency or ', $ 'research group,' $/32X,'224 - can redistribute to any U.S. government agency, ', $ 'research group or educational institution,' $/32X,'256 - no redistribution allowed,' $/28X,'Missing - no retrictions on redistribution)' $/15X,'EXPRSRD .. Expiration of restrictions on redistribution ', $ '(hours), 0-35-201' $/15X,'SST1 ..... Sea temperature (K), 0-22-043' $/15X,'SSTQM .... Sea temperature quality marker, Code Table 0-22', $ '-246' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'prepbufr.doc/table_7.htm)' $/15X,'MSST ..... Method of water temperature and/or salinity, ', $ 'Code Table 0-02-038' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_local_await-val.htm#0-02-038)' $/15X,'.REHOVI .. Relationship to horizontal visibility, Code ', $ 'Table 0-08-201' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_local_await-val.htm#0-08-201)' $/15X,'HOVI ..... Horizontal visibility (meters), 0-20-001' $/15X,'VTVI ..... Vertical visibility (meters), 0-20-002' $/15X,'PSW1 ..... Past weather (1), Code Table 0-20-004' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_20.htm#0-20-004)' $/15X,'PSW2 ..... Past weather (2), Code Table 0-20-005' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_20.htm#0-20-005)' $/15X,'PKWDSP ... Peak wind speed (m/sec), 0-11-203' $/15X,'PKWDDR ... Peak wind direction (degrees), 0-11-202' $/15X,'.DTMMXGS . Duration of time relating to maximum wind gust ', $ 'speed (minutes), 0-04-032' $/15X,'MXGS ..... Maximum wind gust speed (m/sec), 0-11-041' $/15X,'TP01 ..... Total precipitation past 1 hour (kg/m**2), ', $ '0-13-019' $/15X,'TP03 ..... Total precipitation past 3 hours (kg/m**2), ', $ '0-13-020' $/15X,'TP06 ..... Total precipitation past 6 hours (kg/m**2), ', $ '0-13-021' $/15X,'TP12 ..... Total precipitation past 12 hours (kg/m**2), ', $ '0-13-022' $/15X,'TP24 ..... Total precipitation past 24 hours (kg/m**2), ', $ '0-13-023' $/15X,'TOCC ..... Cloud cover (total) (%), 0-20-10' $/15X,'HBLCS .... Height above surface of the base of the lowest ', $ 'cloud seen, Code Table 0-20-201' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_local_await-val.htm#0-20-201)' $/15X,'ALSE ..... Altimeter setting (QNH) (Pa), 0-10-052 ', $ '{followed by quality marker (QM) (00 - monitor keep, 01 - ', $ 'good,' $/27X,'02 - neutral/not checked, 03 - suspect, 12 - toss, on ', $ 'reject list, 13 - toss, failed automatic q.c.' $/27X,'tests, 14 - toss, monitor purge)' $/15X,'.DTHTOPC . Duration of time relating to total ', $ 'precipitation/total water equivalent (hours), 0-04-031' $/15X,'TOPC ..... Total precipitation/total water equivalent ', $ '(kg/m**2), 0-13-011 {followed by quality marker (QM) (00 - ' $/27X,'monitor keep, 01 - good, 02 - neutral/not checked, 03 - ', $ 'suspect, 12 - toss, on reject list, 13 - toss,' $/27X,'failed automatic q.c. tests, 14 - toss, monitor purge)}' $/15X,'PRWE ..... Present weather, Code Table 0-20-003' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_20.htm#0-20-003)' $/15X,'.DTHMXTM . Duration of time relating to maximum ', $ 'temperature (hours), 0-04-031' $/15X,'MXTM ..... Maximum temperature (K), 0-12-111' $/15X,'.DTHMITM . Duration of time relating to minimum ', $ 'temperature (hours), 0-04-031' $/15X,'MITM ..... Minimum temperature (K), 0-12-112' $/15X,'VSSO ..... Vertical significance (surface observations), ', $ 'Code Table 0-08-002' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_3-8.htm#0-08-002)' $/15X,'CLAM ..... Cloud amount, Code Table 0-20-011' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_20.htm#0-20-011)' $/15X,'CLTP ..... Cloud type, Code Table 0-20-012' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_20.htm#0-20-012)' $/15X,'HOCB ..... Height of base of cloud (meters), 0-20-013' $/15X,'HOCT ..... Height of top of cloud (meters), 0-20-014' $/15X,'.DTHDOFS . Duration of time relating to depth of fresh ', $ 'snow (hours), 0-04-031' $/15X,'DOFS ..... Depth of fresh snow (meters), 0-13-012' $/15X,'TOSD ..... Total snow depth (meters), 0-13-013' $/15X,'HOWV ..... Height of waves (meters), 0-22-021' $/15X,'POWV ..... Period of waves (seconds), 0-22-011' $/15X,'HOWW ..... Height of wind waves (meters), 0-22-022' $/15X,'POWW ..... Period of wind waves (seconds), 0-22-012' $/15X,'DOSW ..... Direction of swell waves (degrees), 0-22-003' $/15X,'HOSW ..... Height of swell waves (meters), 0-22-023' $/15X,'POSW ..... Period of swell waves (seconds), 0-22-013' $/15X,'CHPT ..... Characteristic of pressure tendency, Code Table', $ ' 0-10-063' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_9-19.htm#0-10-063)' $/15X,'3HPC ..... 03-hour pressure change (Pa), 0-10-061' $/15X,'24PC ..... 24-hour pressure change (Pa), 0-10-062'//) ELSE IF(DSNAME_LC.EQ.'msonet') THEN PRINT 102 102 FORMAT(5X,'KEY FOR DATA LISTED IN EACH REPORT BELOW:'/ $/10X,'Field 1 ....... Report id' $/10X,'Field 2 ....... Observation time (UTC)' $/10X,'Field 3 ....... Latitude (N,S)' $/10X,'Field 4 ....... Longitude (E,W)' $/10X,'ELV/QM ......... Elevation (meters) / quality marker ', $ '(BUFR Code Table 0-33-024 -' $/28X,'see http://www.emc.ncep.noaa.gov/mmb/data_processing/table', $ '_25-35.htm#0-33-024)' $/10X,'ITP ............ Instrument type (always missing)' $/10X,'RCT ............ Receipt time (UTC)' $/10X,'RES ............ Reserve characters (16) {1-8 = First 8 ', $ 'characters of Mesonet Provider id, 9-16 = First 8 characters ', $ 'of' $/28X,'Mesonet Subprovider id (if present, otherwise blanks)}' $/10X,'RTP ............ Dump report type (540 - Mesonet surface)' $/10X,'MSL/STNP ....... Mean sea-level pressure / station ', $ 'pressure (both x 10 mb) ' $/10X,'Next field ..... Wind direction (degrees) / wind speed ', $ '(x 10 m/sec)' $/10X,'Next field ..... Air temperature (x 10 degrees C)' $/10X,'Next field ..... Dewpoint depression (x 10 degrees C)' $/10X,'Next field ..... Quality markers in form AABBCCDDEE, where', $ ' AA = sea-level pressure, BB = station pressure, CC = wind,' $/28X,'DD = air temprature, EE = dewpoint depression (00 - ', $ 'monitor keep, 01 - good, 02 - neutral/not checked,' $/28X,'03 - suspect, 12 - toss, on reject list, 13 - toss, failed', $ ' automatic q.c. tests, 14 - toss, monitor' $/28X,'purge)' $/28X,'Note: If quality marker is default value of 02 then "--" ', $ 'is stamped out here rather than "02"' $//10X,'BUFR mnemonics:' $/15X,'RSRD ..... Restrictions on redistribution, Flag Table 0-35', $ '-200 (' $/32X,' 16 - can redistribute to any U.S. government agency ', $ 'within NOAA,' $/32X,'128 - can redistribute to any U.S. government agency,' $/32X,'160 - can redistribute to any U.S. government agency or ', $ 'educational institution,' $/32X,'192 - can redistribute to any U.S. government agency or ', $ 'research group,' $/32X,'224 - can redistribute to any U.S. government agency, ', $ 'research group or educational institution,' $/32X,'256 - no redistribution allowed,' $/28X,'Missing - no retrictions on redistribution)' $/15X,'EXPRSRD .. Expiration of restrictions on redistribution ', $ '(hours), 0-35-201' $/15X,'MXGS ..... Maximum wind gust speed (m/sec), 0-11-041' $/15X,'MXGD ..... Maximum wind gust direction (degrees), 0-11-043' $/15X,'ALSE ..... Altimeter setting (QNH) (Pa), 0-10-052 ', $ '{followed by quality marker (QM) (00 - monitor keep, 01 - ', $ 'good,' $/27X,'02 - neutral/not checked, 03 - suspect, 12 - toss, on ', $ 'reject list, 13 - toss, failed automatic q.c.' $/27X,'tests, 14 - toss, monitor purge)' $/15X,'.DTHTOPC . Duration of time relating to total ', $ 'precipitation/total water equivalent (hours), 0-04-031' $/15X,'TOPC ..... Total precipitation/total water equivalent ', $ '(kg/m**2), 0-13-011 {followed by quality marker (QM) (00 - ' $/27X,'monitor keep, 01 - good, 02 - neutral/not checked, 03 - ', $ 'suspect, 12 - toss, on reject list, 13 - toss,' $/27X,'failed automatic q.c. tests, 14 - toss, monitor purge)}'//) ELSE IF(DSNAME_LC.EQ.'sfcshp') THEN PRINT 103 103 FORMAT(5X,'KEY FOR DATA LISTED IN EACH REPORT BELOW:'/ $/10X,'Field 1 ....... Report id (definition depends on report ', $ 'type)' $/10X,'Field 2 ....... Observation time (UTC)' $/10X,'Field 3 ....... Latitude (N,S)' $/10X,'Field 4 ....... Longitude (E,W)' $/10X,'ELV/QM ......... Elevation (meters) / quality marker ', $ '(BUFR Code Table 0-33-024 -' $/28X,'see http://www.emc.ncep.noaa.gov/mmb/data_processing/table', $ '_25-35.htm#0-33-024)' $/10X,'ITP ............ Instrument type (always missing)' $/10X,'RCT ............ Receipt time (UTC)' $/10X,'RES ............ SHIP, C-MAN, FIXED BUOY: Reserve ', $ 'characters (16) {1 = Indicator for precipitation inclusion ', $ '(BUFR Code' $/28X,'Table 0-13-194,' $/28X,'see http://www.emc.ncep.noaa.gov/mmb/data_processing/table', $ '_local_await-val.htm#0-13-194), 2 = blank,' $/28X,'3 = Indicator for wind speed (source/units) ("0" - wind', $ ' speed estimated in m/sec "uncertified' $/28X,'instrument", "1" - wind speed obtained from anemometer in ', $ 'm/sec "certified instrument", "3" - wind' $/28X,'speed estimated in knots "uncertified instrument", "4" - ', $ 'wind speed obtained from anemometer in knots' $/28X,'"certified instrument", "7" - Missing), 4 = blank, 5 = ', $ 'Indicator for station operation/past weather' $/28X,'data (BUFR Code Table 0-02-193,' $/28X,'see http://www.emc.ncep.noaa.gov/mmb/data_processing/table', $ '_local_await-val.htm#0-02-193), 6-16 = blank}' $/10X,' TIDE GAUGE, DRIFTING BUOY: Reserve ', $ 'characters (16) (1-16 = blank)' $/10X,'RTP ............ Dump report type {522 - Ship with name ', $ '(TAC), 523 - Ship without name (report id set to "SHIP") ', $ '(TAC),' $/28X,'524 - Ship with name (BUFR), 525 - Ship without name ', $ '(report id set to "SHIP") (BUFR),' $/28X,'530 - C-MAN platform (BUFR), 531 - C-MAN platform ', $ '(TAC),' $/28X,'532 - Tide gauge, 561 - Moored buoy (TAC), 562 - ', $ 'Drifting buoy (TAC),' $/28X,'563 - Moored buoy (BUFR), 564 - Drifting buoy (BUFR)}' $/10X,'MSL/STNP ....... Mean sea-level pressure / station ', $ 'pressure (both x 10 mb) ' $/10X,'Next field ..... Wind direction (degrees) / wind speed ', $ '(x 10 m/sec)' $/10X,'Next field ..... Air temperature (x 10 degrees C)' $/10X,'Next field ..... Dewpoint depression (x 10 degrees C)' $/10X,'Next field ..... Quality markers in form AABBCCDDEE, where', $ ' AA = sea-level pressure, BB = station pressure, CC = wind,' $/28X,'DD = air temprature, EE = dewpoint depression (00 - ', $ 'monitor keep, 01 - good, 02 - neutral/not checked,' $/28X,'03 - suspect, 04 - good - corrected by OPC, 12 - toss, on ', $ 'reject list, 13 - toss, failed automatic q.c.' $/28X,'tests, 14 - toss, monitor purge)' $//10X,'BUFR mnemonics:' $/15X,'RSRD ..... Restrictions on redistribution, Flag Table 0-35', $ '-200 (' $/32X,' 16 - can redistribute to any U.S. government agency ', $ 'within NOAA,' $/32X,'128 - can redistribute to any U.S. government agency,' $/32X,'160 - can redistribute to any U.S. government agency or ', $ 'educational institution,' $/32X,'192 - can redistribute to any U.S. government agency or ', $ 'research group,' $/32X,'224 - can redistribute to any U.S. government agency, ', $ 'research group or educational institution,' $/32X,'256 - no redistribution allowed,' $/28X,'Missing - no retrictions on redistribution)' $/15X,'EXPRSRD .. Expiration of restrictions on redistribution ', $ '(hours), 0-35-201' $/15X,'SST1 ..... Sea temperature (K), 0-22-043' $/15X,'SSTQM .... Sea temperature quality marker, Code Table 0-22', $ '-246' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'prepbufr.doc/table_7.htm)' $/15X,'DBSS ..... Depth below sea/water surface (meters), 0-07-062' $/15X,'MSST ..... Method of water temperature and/or salinity, ', $ 'Code Table 0-02-038' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_local_await-val.htm#0-02-038)' $/15X,'HOVI ..... Horizontal visibility (meters), 0-20-001' $/15X,'VTVI ..... Vertical visibility (meters), 0-20-002' $/15X,'PSW1 ..... Past weather (1), Code Table 0-20-004' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_20.htm#0-20-004)' $/15X,'PSW2 ..... Past weather (2), Code Table 0-20-005' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_20.htm#0-20-005)' $/15X,'PKWDSP ... Peak wind speed (m/sec), 0-11-203' $/15X,'PKWDDR ... Peak wind direction (degrees), 0-11-202' $/15X,'.DTMMXGS . Duration of time relating to maximum wind gust ', $ 'speed (minutes), 0-04-032' $/15X,'MXGS ..... Maximum wind gust speed (m/sec), 0-11-041' $/15X,'TOCC ..... Cloud cover (total) (%), 0-20-10' $/15X,'HBLCS .... Height above surface of the base of the lowest ', $ 'cloud seen, Code Table 0-20-201' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_local_await-val.htm#0-20-201)' $/15X,'XS10 ..... 10 meter extrapolated wind speed (m/sec), 0-11-', $ '223' $/15X,'XS20 ..... 20 meter extrapolated wind speed (m/sec), 0-11-', $ '224' $/15X,'PRWE ..... Present weather, Code Table 0-20-003' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_20.htm#0-20-003)' $/15X,'VSSO ..... Vertical significance (surface observations), ', $ 'Code Table 0-08-002' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_3-8.htm#0-08-002)' $/15X,'CLAM ..... Cloud amount, Code Table 0-20-011' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_20.htm#0-20-011)' $/15X,'CLTP ..... Cloud type, Code Table 0-20-012' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_20.htm#0-20-012)' $/15X,'HOCB ..... Height of base of cloud (meters), 0-20-013' $/15X,'HOCT ..... Height of top of cloud (meters), 0-20-014' $/15X,'HOWV ..... Height of waves (meters), 0-22-021' $/15X,'POWV ..... Period of waves (seconds), 0-22-011' $/15X,'HOWW ..... Height of wind waves (meters), 0-22-022' $/15X,'POWW ..... Period of wind waves (seconds), 0-22-012' $/15X,'DOSW ..... Direction of swell waves (degrees), 0-22-003' $/15X,'HOSW ..... Height of swell waves (meters), 0-22-023' $/15X,'POSW ..... Period of swell waves (seconds), 0-22-013' $/15X,'TDMP ..... Direction of motion of ship during last 3 ', $ 'hours, Code Table 0-01-193' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_local_await-val.htm#0-01-193)' $/15X,'ASMP ..... Average speed of motion of ship during last 3 ', $ 'hours, Code Table 0-01-200' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_local_await-val.htm#0-01-200)' $/15X,'CHPT ..... Characteristic of pressure tendency, Code Table', $ ' 0-10-063' $/27X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_9-19.htm#0-10-063)' $/15X,'3HPC ..... 03-hour pressure change (Pa), 0-10-061' $/15X,'24PC ..... 24-hour pressure change (Pa), 0-10-062'//) ELSE IF(DSNAME_LC.EQ.'sfcbog') THEN PRINT 104 104 FORMAT(5X,'KEY FOR DATA LISTED IN EACH REPORT BELOW:'/ $/10X,'Field 1 ....... Report id' $/10X,'Field 2 ....... Observation time (UTC)' $/10X,'Field 3 ....... Latitude (N,S)' $/10X,'Field 4 ....... Longitude (E,W)' $/10X,'ELV/QM ......... Elevation (meters) / quality marker ', $ '(BUFR Code Table 0-33-024 -' $/28X,'see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_25-35.htm#0-33-024)' $/10X,'ITP ............ Instrument type (always missing)' $/10X,'RCT ............ Receipt time (UTC)' $/10X,'RES ............ Reserve characters (16) (1-16 = blank)' $/10X,'RTP ............ Dump report type (551 - Sea-level ', $ 'pressure bogus)'//) END IF KOUNT = 0 KNTLAT = 0 KNTLON = 0 KNTCHR = 0 LATS = -9001 LATN = 9001 LONW = -0001 LONE = 36001 CHAR1= '*' SUBSKP = .FALSE. READ(5,SDATA,END=1905) 1905 CONTINUE GLOBAL = (LATS.LE.-09000.AND.LATN.GE.09000.AND. $ LONW.LE. 00000.AND.LONE.GE.36000) 905 CONTINUE IF(IW3UNPBF(NUNIT,ADATA,STNID,CRES1,CRES2,CBULL,ADATA2,ADATA3, $ NDATA3,adata8_8,DSNAME,IDSDAT,IDSDMP_8,SUBSET,SUBSKP,IER).EQ.0) $ GO TO 950 IF(IER.EQ.1) GO TO 910 IF(IER.EQ.2) GO TO 920 IF(IER.EQ.3) GO TO 920 IF(IER.EQ.999) GO TO 999 C----------------------------------------------------------------------- 910 CONTINUE cpppppppppp cc PRINT'(" RETURN CODE =",I0,"; DATA SET INFORMATION RETURNED")', cc $ IER cpppppppppp c 1st dummy message in file is open, call iupvs01 to get iminu iminu = iupvs01(nunit,'MINU') IF(.NOT.GLOBAL.OR.CHAR1.NE.'*') THEN IF(GLOBAL) THEN PRINT 6999, DSNAME,IDSDAT,iminu,IDSDMP_8,CHAR1 6999 FORMAT(//22X,'--> DATA SET INFORMATION: NAME: ',A8,'; DATE: ', $ I10.10,i2.2,'; DUMP TIME: ',I12.12,' <--'//39X,'-- ONLY REPORTS', $ ' BEGINNING WITH "',A1,'" ARE PROCESSED --'//) ELSE IF(CHAR1.EQ.'*') THEN PRINT 7000, DSNAME,IDSDAT,iminu,IDSDMP_8,LATS/100., $ LATN/100.,LONW/100.,LONE/100. 7000 FORMAT(//22X,'--> DATA SET INFORMATION: NAME: ',A8,'; DATE: ', $ I10.10,i2.2,'; DUMP TIME: ',I12.12,' <--'//10X,'-- SELECTED ', $ 'DOMAIN FOR PROCESSING REPORTS: LATITUDE:',F7.2,' TO ',F7.2, $ ' N; LONGITUDE:',F8.2,' TO ',F8.2,' E --'//) ELSE PRINT 6998, DSNAME,IDSDAT,iminu,IDSDMP_8,LATS/100., $ LATN/100.,LONW/100.,LONE/100.,CHAR1 6998 FORMAT(//22X,'--> DATA SET INFORMATION: NAME: ',A8,'; DATE: ', $ I10.10,i2.2,'; DUMP TIME: ',I12.12,' <--'//10X,'-- SELECTED ', $ 'DOMAIN FOR PROCESSING REPORTS: LATITUDE:',F7.2,' TO ',F7.2, $ ' N; LONGITUDE:',F8.2,' TO ',F8.2,' E --'//39X,'-- ONLY REPORTS', $ ' BEGINNING WITH "',A1,'" ARE PROCESSED --'//) END IF ELSE PRINT 8000, DSNAME,IDSDAT,iminu,IDSDMP_8 8000 FORMAT(//22X,'--> DATA SET INFORMATION: NAME: ',A8,'; DATE: ', $ I10.10,i2.2,'; DUMP TIME: ',I12.12,' <--'//10X,'-- SELECTED ', $ 'DOMAIN FOR PROCESSING REPORTS: ALL REPORTS IN DATA SET ', $ 'REGARDLESS OF LOCATION'//) END IF C Uncomment line below to sort ADPSFC reports first by stnid and C second by obs time CCCC SORTID = (DSNAME.EQ.'ADPSFC ') IFIND = 0 DO I = 0,255 DO J = 0,200 IF(SUBSKP(I,J)) THEN IF(IFIND.EQ.0) PRINT 7001 7001 FORMAT(34X,'-- THE FOLLOWING BUFR MESSAGE TYPES/SUBTYPES WILL ', $ 'BE SKIPPED:') PRINT 7002, I,J 7002 FORMAT(45X,'BUFR TYPE ',I3.3,', SUBTYPE ',I3.3) IFIND = 1 END IF ENDDO ENDDO IF(IFIND.EQ.0) PRINT 8003 8003 FORMAT(10X,'-- ALL BUFR MESSAGE TYPES/SUBTYPES IN DATA DUMP FILE', $ ' WILL BE PROCESSED') IF(SORTID) PRINT 8002 8002 FORMAT(/34X,'-- REPORTS WILL BE LISTED IN ORDER OF ASCENDING ', $ 'STATION ID AND WITHIN THAT ASCENDING OBS TIME'///130('+') $ //43X,'READING IN REPORTS AND STORING FOR LATER SORT'/) PRINT 7004 7004 FORMAT(//) GO TO 905 C----------------------------------------------------------------------- 920 CONTINUE PRINT 566, IER 566 FORMAT('RETURN CODE =',I3,'; PHYSICAL END-OF-FILE - DONE') IF(SORTID) THEN PRINT 8006 8006 FORMAT(//130('+')//23X,'ALL REPORTS HAVE BEEN READ IN AND STORED', $ ' - NEXT SORT BY STATION ID AND OBS TIME AND BEGIN LISTING'//) GO TO 7050 END IF GO TO 906 C----------------------------------------------------------------------- 950 CONTINUE IDATA1 = NINT(ADATA(1) * 100.) IDATA2 = NINT(ADATA(2) * 100.) IF(.NOT.GLOBAL) THEN C DO A DOMAIN CHECK IF GLOBAL DOMAIN NOT SELECTED C ----------------------------------------------- cpppppppppp cc print'(" FOR THIS RPT, IDATA1 = ",I0,"; IDATA2 = ",I0)', cc $ IDATA1,IDATA2 cpppppppppp IF(IDATA1.LT.LATS.OR.IDATA1.GT.LATN) THEN KNTLAT = KNTLAT + 1 GO TO 905 END IF IF(IDATA2.LT.LONW.OR.IDATA2.GT.LONE) THEN KNTLON = KNTLON + 1 GO TO 905 END IF END IF IF(CHAR1.NE.'*') THEN C DO A STNID CHECK IF NECESSARY C ----------------------------- cpppppppppp cc print'(" FOR THIS RPT, STNID = ",A)', STNID cpppppppppp IF(STNID(1:1).NE.CHAR1) THEN KNTCHR = KNTCHR + 1 GO TO 905 END IF END IF JJ = 0 DO I = 13,25,2 JJ = JJ + 1 IF(IDATA(I).GT.0) THEN PRINT 998, ICAT(JJ) CALL W3TAGE('BUFR_LISTDUMPS') CALL ERREXIT(33) END IF END DO JJ = JJ + 2 DO I = 31,45,2 JJ = JJ + 1 IF(IDATA(I).GT.0) THEN PRINT 998, ICAT(JJ) CALL W3TAGE('BUFR_LISTDUMPS') CALL ERREXIT(33) END IF END DO 998 FORMAT('**BUFR_LISTDUMPS/LISTSFC: CANNOT PROCESS DATA IN CAT.',I4, $ ' - STOP 33') KOUNT = KOUNT + 1 IF(.NOT.SORTID) GO TO 7060 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C ADPSFC REPORTS COME HERE FOR STORAGE BECAUSE THEY WILL BE SORTED C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ IF(KOUNT.GT.40000) THEN PRINT 8014 8014 FORMAT('**BUFR_LISTDUMPS/LISTSFC: THERE ARE MORE THAN 40000 ', $ 'ADPSFC REPORTS - THIS EXCEEDS THE SORT LIMIT - STOP 65'/) CALL W3TAGE('BUFR_LISTDUMPS') CALL ERREXIT(65) END IF ADATA_S(:,KOUNT) = ADATA ADATA2_S(:,KOUNT) = ADATA2 ADATA3_S(:,:,:,KOUNT) = ADATA3 NDATA3_S(:,KOUNT) = NDATA3 adata8_8_s(:,kount) = adata8_8 STNID_S(KOUNT) = STNID CRES1_S(KOUNT) = CRES1 CRES2_S(KOUNT) = CRES2 SUBSET_S(KOUNT) = SUBSET STNID_S(KOUNT) = STNID GO TO 905 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 7050 CONTINUE C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C ALL ADPSFC REPORTS HAVE BEEN STORED, TIME TO SORT BY STATION ID AND C WITHIN THAT OBS TIME AND THEN BEGIN PROCESS OF LISTING SORTED REPORTS C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ CALL ORDERS( 2,IWORK,ADATA_S(4,1),INDX,KOUNT,MAXOBS,4,2) CALL ORDERS(10,IWORK,STNID_S,INDX,KOUNT,1,8,2) KNTOUT = 0 8050 CONTINUE KNTOUT = KNTOUT + 1 IF(KNTOUT.GT.KOUNT) GO TO 906 ADATA = ADATA_S(:,INDX(KNTOUT)) ADATA2 = ADATA2_S(:,INDX(KNTOUT)) ADATA3 = ADATA3_S(:,:,:,INDX(KNTOUT)) NDATA3 = NDATA3_S(:,INDX(KNTOUT)) adata8_8 = adata8_8_s(:,INDX(KNTOUT)) STNID = STNID_S(INDX(KNTOUT)) CRES1 = CRES1_S(INDX(KNTOUT)) CRES2 = CRES2_S(INDX(KNTOUT)) SUBSET = SUBSET_S(INDX(KNTOUT)) C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 7060 CONTINUE C CHANGE MISSING TO 10E10 (REAL) OR 99999999 (INTEGER) C ---------------------------------------------------- DO I = 1,MAXOBS IF(ADATA(I).EQ.99999.) ADATA(I) = BMISS IF(IDATA(I).EQ.99999) IDATA(I) = 99999999 END DO C1 = 'N' C2 = 'E' c1_8 = 'N' c2_8 = 'E' ALAT = ADATA(1) IF(NINT(ADATA(1)*100.).LT.0) THEN ALAT = -ALAT C1 = 'S' END IF ALON = ADATA(2) IF(NINT(ADATA(2)*100.).GT.18000) THEN ALON = 360.00 - ALON C2 = 'W' END IF alat_8 = adata8_8(1) if(adata8_8(1).lt.0.) then alat_8 = -alat_8 c1_8 = 'S' end if alon_8 = adata8_8(2) if(adata8_8(2).lt.0.) then alon_8 = -alon_8 c2_8 = 'W' end if PRINT 7, STNID,ADATA(4),alat_8,c1_8,alon_8,c2_8,NINT(ADATA(7)), $ NINT(ADATA(12)),IDATA(8),ADATA(11),CRES1,CRES2,IDATA(9) 7 FORMAT(1X,A8,1X,F9.5,'Z',3X,2(F11.5,A1,2X),2X,'ELV/QM ',I5.5, $ 'M/',I1,4X,'ITP',I5.2,4X,'RCT',F6.2,'Z',4X,'RES "',A8,A8,'"',3X, $ 'RTP',I5.3) QAL = BMISS QTP01 = BMISS QTP24 = BMISS IQM = IMISS IF(IDATA(27).GT.0) THEN IF(DSNAME.EQ.'MSONET ') THEN C MESONET DATA IN CATEGORY 8 C (just store, will print all but alt. qm, TP01 qm & TP24 qm later) C ----------------------------------------------------------------- N = IDATA(28) - 4 M = IDATA(28) - 4 I = 0 DO NLVL = 1,IDATA(27) N = N + 4 IF(NINT(ADATA(N+1)).EQ.3) THEN I = I + 1 IF(I.GT.3) EXIT CDATUM(I) = 'DIF SR (J/M**2)' CIND2(I) = 'TIME PER (MIN) ' OB8(I) = MIN(XMISS,ADATA(N)*100.) Q82(I) = MIN(XMISS,ADATA(N+3)) ELSE IF(NINT(ADATA(N+1)).EQ.4) THEN I = I + 1 IF(I.GT.3) EXIT CDATUM(I) = 'DIR SR (J/M**2)' CIND2(I) = 'TIME PER (MIN) ' OB8(I) = MIN(XMISS,ADATA(N)*100.) Q82(I) = MIN(XMISS,ADATA(N+3)) ELSE IF(NINT(ADATA(N+1)).EQ.5) THEN QTP01 = MIN(XMISS,ADATA(N)) ELSE IF(NINT(ADATA(N+1)).EQ.6) THEN QTP24 = MIN(XMISS,ADATA(N)) ELSE IF(NINT(ADATA(N+1)).EQ.20) THEN QAL = MIN(XMISS,ADATA(N)) ELSE IF(NINT(ADATA(N+1)).EQ.198) THEN I = I + 1 IF(I.GT.3) EXIT CDATUM(I) = 'RAIN RTE (MM/H)' CIND2(I) = 'QUALITY MARKER ' OB8(I) = MIN(XMISS,ADATA(N)*3600.) Q82(I) = MIN(XMISS,ADATA(N+3)) END IF END DO ELSE IF(DSNAME.EQ.'ADPSFC ') THEN C SURFACE LAND DATA IN CATEGORY 8 (currently only alt. q.m) C --------------------------------------------------------- N = IDATA(28) - 4 M = IDATA(28) - 4 I = 0 DO NLVL = 1,IDATA(27) N = N + 4 IF(NINT(ADATA(N+1)).EQ.20) THEN QAL = MIN(XMISS,ADATA(N)) END IF END DO END IF END IF IF(IDATA(29).GT.0) THEN C CAT. 51 & DATA RETURNED DIRECTLY FROM BUFR DUMP FILE (ADATA2 ARRAY) C ------------------------------------------------------------------- IF(IDATA(29).NE.1) THEN PRINT 991, ICAT(9) 991 FORMAT('**BUFR_LISTDUMPS/LISTSFC: MORE THAN 1 LEVEL IN CAT. ',I3, $ '- STOP 44') CALL W3TAGE('BUFR_LISTDUMPS') CALL ERREXIT(44) END IF N51 = IDATA(30) - 1 cpppppppppp cc DO NN=1,13 cc IF(NINT(ADATA(N51+NN)).LT.0) print'(" Cat. 51 Word ",I0, cc $ " < 0")', NN cc END DO cpppppppppp CQM = '--' DO II=1,5 IF(NINT(ADATA(N51+8+II)).NE.2) $ WRITE(CQM(II),'(I2.2)') NINT(ADATA(N51+8+II)) ENDDO IF(DSNAME.EQ.'ADPSFC') THEN IF(IDATA(9).EQ.512) THEN ! Land METARs PRINT 7012, (NINT(ADATA(N51+NN)),NN=1,6), $ (CQM(II),II=1,5),(NINT(ADATA2(I)),I=38,39), $ NINT(ADATA2(3)),NINT(QAL),ADATA2(17),ADATA2(18), $ ADATA2(19),ADATA2(21) 7012 FORMAT('MSL/STNP:',I5.5,'/',I5.5,1X,I3.3,'/',I4.4,1X,I5.3,1X, $ I3.3,1X,5A2,1X,', CHPT ',I2,', 3HPC ',I5,', ALSE/QM ',I6,'/',I2, $ ', TP01 ',F6.1,', TP03 ',F6.1,', TP06 ',F6.1,', TP24 ',F6.1) IF(MIN(ADATA2(1),ADATA2(2)).LT.BMISS) PRINT 1144, $ (NINT(ADATA2(I)),I=1,2) 1144 FORMAT('RSRD ',I3,', EXPRSRD ',I3) IF(ADATA2(22).LT.BMISS) PRINT 1114, NINT(ADATA2(22)) 1114 FORMAT(' TOSS ',I4) ELSE ! Land SYNOPs PRINT 7063, (NINT(ADATA(N51+NN)),NN=1,6), $ (CQM(II),II=1,5),(NINT(ADATA2(I)),I=38,40), $ (ADATA2(I),NINT(ADATA2(I+1)),I=32,34,2) 7063 FORMAT('MSL/STNP:',I5.5,'/',I5.5,1X,I3.3,'/',I4.4,1X,I5.3,1X,I3.3, $ 1X,5A2,1X,', CHPT ',I2,', 3HPC ',I5,', 24PC ',I6,', HOWV ',F5.1, $ ', POWV ',I2,', HOWW ',F5.1,', POWW ',I2) IF(MIN(ADATA2(1),ADATA2(2),ADATA2(17),ADATA2(18), $ ADATA2(19),ADATA2(20),ADATA2(21),ADATA2(23),ADATA2(24)) $ .LT.BMISS) PRINT 7164, (NINT(ADATA2(I)),I=1,2), $ (ADATA2(I),I=17,21),(NINT(ADATA2(I)),I=23,24) 7164 FORMAT('RSRD ',I3,', EXPRSRD ',I3,', TP01 ',F6.1,', TP03 ',F6.1, $ ', TP06 ',F6.1,', TP12 ',F6.1,', TP24 ',F6.1,', TOCC ',I3, $ ', HBLCS ',I2) END IF ! Land METARs and SYNOPs IF(MIN(ADATA2(29),ADATA2(30),ADATA2(31)).LT.BMISS) $ PRINT 8144, NINT(ADATA2(29)),(ADATA2(I),I=30,31) 8144 FORMAT('.DTHDOFS ',I3,', DOFS ',F5.2,', TOSD ',F6.2) IF(MIN(ADATA2(4),ADATA2(41),ADATA2(6),ADATA2(7),ADATA2(8), $ ADATA2(9),ADATA2(10),ADATA2(11),ADATA2(12),ADATA2(13), $ ADATA2(14),ADATA2(15)).LT.BMISS) PRINT 7154, ADATA2(4), $ NINT(ADATA2(41)),(NINT(ADATA2(I)),I=6,11),ADATA2(12), $ (NINT(ADATA2(I)),I=13,14),ADATA2(15) 7154 FORMAT('SST1 ',F6.2,', SSTQM ',I2,', MSST ',I1,', .REHOVI ',I1, $ ', HOVI ',I5,', VTVI ',I4,', PSW1 ',I2,', PSW2 ',I2,', PKWDSP ', $ F5.1,', PKWDDR ',I3,', .DTMMXGS ',I2,', MXGS ',F5.1) ELSE IF(DSNAME.EQ.'MSONET ') THEN ! mesonets PRINT 8062, (NINT(ADATA(N51+NN)),NN=1,6),(CQM(II),II=1,5), $ (NINT(ADATA2(I)),I=1,2),ADATA2(15),NINT(ADATA2(16)), $ NINT(ADATA2(3)),NINT(QAL) 8062 FORMAT('MSL/STNP:',I5.5,'/',I5.5,1X,I3.3,'/',I4.4,1X,I5.3,1X, $ I3.3,1X,5A2,1X,', RSRD ',I3,', EXPRSRD ',I3,', MXGS ',F5.1, $ ', MXGD ',I3,', ALSE/QM ',I6,'/',I2) ELSE IF(DSNAME.EQ.'SFCSHP') THEN IF(IDATA(9).EQ.562.OR.IDATA(9).EQ.564) THEN ! drifting buoys PRINT 9063, (NINT(ADATA(N51+NN)),NN=1,6), $ (CQM(II),II=1,5),ADATA2(4),NINT(ADATA2(41)),ADATA2(5), $ (NINT(ADATA2(I)),I=38,39),ADATA2(32),NINT(ADATA2(33)) 9063 FORMAT('MSL/STNP:',I5.5,'/',I5.5,1X,I3.3,'/',I4.4,1X,I5.3,1X,I3.3, $ 1X,5A2,', SST1 ',F6.2,', SSTQM ',I2,', DBSS ',F4.1,', CHPT ',I2, $ ', 3HPC ',I5,', HOWV ',F5.1,', POWV ',I2) IF(MIN(ADATA2(1),ADATA2(2)).LT.BMISS) PRINT 1144, $ (NINT(ADATA2(I)),I=1,2) ELSE IF(IDATA(9).EQ.522.OR.IDATA(9).EQ.523) THEN ! ships PRINT 8063, (NINT(ADATA(N51+NN)),NN=1,6), $ (CQM(II),II=1,5),ADATA2(4),NINT(ADATA2(41)), $ NINT(ADATA2(6)),(NINT(ADATA2(I)),I=38,39), $ NINT(ADATA2(24)),(NINT(ADATA2(I)),I=36,37) 8063 FORMAT('MSL/STNP:',I5.5,'/',I5.5,1X,I3.3,'/',I4.4,1X,I5.3,1X,I3.3, $ 1X,5A2,', SST1 ',F6.2,', SSTQM ',I2,', MSST ',I1,', CHPT ',I2, $ ', 3HPC ',I5,', HBLCS ',I2,', TDMP ',I2,', ASMP ',I2) IF(MIN(ADATA2(1),ADATA2(2)).LT.BMISS) PRINT 1144, $ (NINT(ADATA2(I)),I=1,2) IF(MIN(ADATA2(32),ADATA2(33),ADATA2(34),ADATA2(35), $ ADATA2(9),ADATA2(10),ADATA2(11),ADATA2(23),ADATA2(8), $ ADATA2(14),ADATA2(15),ADATA2(40)).LT.BMISS) $ PRINT 56, (ADATA2(I),NINT(ADATA2(I+1)),I=32,34,2), $ (NINT(ADATA2(I)),I=9,11),NINT(ADATA2(23)), $ NINT(ADATA2(8)),NINT(ADATA2(14)),ADATA2(15), $ NINT(ADATA2(40)) 56 FORMAT('HOWV ',F5.1,', POWV ',I2,', HOWW ',F5.1,', POWW ',I2, $ ', VTVI ',I4,', PSW1 ',I2,', PSW2 ',I2,', TOCC ',I3,', HOVI ',I5, $ ', .DTMMXGS ',I2,', MXGS ',F5.1,', 24PC ',I6) ELSE ! all other marine PRINT 8093, (NINT(ADATA(N51+NN)),NN=1,6), $ (CQM(II),II=1,5),ADATA2(4),NINT(ADATA2(41)), $ NINT(ADATA2(6)),(NINT(ADATA2(I)),I=38,39), $ NINT(ADATA2(8)),NINT(ADATA2(14)) 8093 FORMAT('MSL/STNP:',I5.5,'/',I5.5,1X,I3.3,'/',I4.4,1X,I5.3,1X,I3.3, $ 1X,5A2,', SST1 ',F6.2,', SSTQM ',I2,', MSST ',I1,', CHPT ',I2, $ ', 3HPC ',I5,', HOVI ',I5,', .DTMMXGS ',I2) IF(MIN(ADATA2(1),ADATA2(2)).LT.BMISS) PRINT 1144, $ (NINT(ADATA2(I)),I=1,2) IF(MIN(ADATA2(15),ADATA2(32),ADATA2(33),ADATA2(34), $ ADATA2(35),ADATA2(10),ADATA2(11),ADATA2(12),ADATA2(13), $ ADATA2(25),ADATA2(26)).LT.BMISS) $ PRINT 58, ADATA2(15),(ADATA2(I), $ NINT(ADATA2(I+1)),I=32,34,2),(NINT(ADATA2(I)),I=10,11), $ ADATA2(12),NINT(ADATA2(13)),ADATA2(25),ADATA2(26) 58 FORMAT('MXGS ',F5.1,', HOWV ',F5.1,', POWV ',I2,', HOWW ',F5.1, $ ', POWW ',I2,', PSW1 ',I2,', PSW2 ',I2,', PKWDSP ',F5.1, $ ', PKWDDR ',I3,', XS10 ',F5.1,', XS20 ',F5.1) END IF ELSE IF(DSNAME.EQ.'SFCBOG') THEN PRINT 8069, (NINT(ADATA(N51+1))) 8069 FORMAT('MEAN SEA-LEVEL PRESSURE (x 10 mb): ',I5.5) END IF END IF IF(IDATA(27).GT.0) THEN IF(DSNAME.EQ.'MSONET ') THEN C MESONET DATA IN CATEGORY 8 (already stored & ready to print) C ------------------------------------------------------------ ILV = MIN(IDATA(27)-3,3) IF(ILV.GT.0) PRINT 777, (CDATUM(I),OB8(I),CIND2(I),Q82(I), $ I=1,ILV) 777 FORMAT(2(1X,'|| ',A15,F9.1,2X,A15,F9.1),' ||') ELSE C ALL OTHER CATEGORY 8 SURFACE DATA (store and then print) C -------------------------------------------------------- N = IDATA(28) - 20 J = 0 DO NLVL = 1,IDATA(27),5 J = J + 1 N = N + 20 IF(NLVL+1.GT.IDATA(27)) THEN ADATA(N) = MIN(ADATA(N),XMISS) PRINT 7091,CCAT8(J),NINT(ADATA(N)), $ (NINT(ADATA(N+II)),II=1,3) 7091 FORMAT(1X,A10,I6.5,1X,I3.3,2(1X,I5.5),2X) ELSE IF(NLVL+2.GT.IDATA(27)) THEN DO II = 4,8,4 ADATA(N-4+II) = MIN(ADATA(N-4+II),XMISS) ENDDO PRINT 7092,CCAT8(J),NINT(ADATA(N)), $ (NINT(ADATA(N+II)),II=1,3),NINT(ADATA(N+4)), $ (NINT(ADATA(N+4+II)),II=1,3) 7092 FORMAT(1X,A10,2(I6.5,1X,I3.3,2(1X,I5.5),2X)) ELSE IF(NLVL+3.GT.IDATA(27)) THEN DO II = 4,12,4 ADATA(N-4+II) = MIN(ADATA(N-4+II),XMISS) ENDDO PRINT 7093,CCAT8(J),NINT(ADATA(N)), $ (NINT(ADATA(N+II)),II=1,3),NINT(ADATA(N+4)), $ (NINT(ADATA(N+4+II)),II=1,3),NINT(ADATA(N+8)), $ (NINT(ADATA(N+8+II)),II=1,3) 7093 FORMAT(1X,A10,3(I6.5,1X,I3.3,2(1X,I5.5),2X)) ELSE IF(NLVL+4.GT.IDATA(27)) THEN DO II = 4,16,4 ADATA(N-4+II) = MIN(ADATA(N-4+II),XMISS) ENDDO PRINT 7094,CCAT8(J),NINT(ADATA(N)), $ (NINT(ADATA(N+II)),II=1,3),NINT(ADATA(N+4)), $ (NINT(ADATA(N+4+II)),II=1,3),NINT(ADATA(N+8)), $ (NINT(ADATA(N+8+II)),II=1,3),NINT(ADATA(N+12)), $ (NINT(ADATA(N+12+II)),II=1,3) 7094 FORMAT(1X,A10,4(I6.5,1X,I3.3,2(1X,I5.5),2X)) ELSE DO II = 4,20,4 ADATA(N-4+II) = MIN(ADATA(N-4+II),XMISS) ENDDO PRINT 7095,CCAT8(J),NINT(ADATA(N)), $ (NINT(ADATA(N+II)),II=1,3),NINT(ADATA(N+4)), $ (NINT(ADATA(N+4+II)),II=1,3),NINT(ADATA(N+8)), $ (NINT(ADATA(N+8+II)),II=1,3),NINT(ADATA(N+12)), $ (NINT(ADATA(N+12+II)),II=1,3),NINT(ADATA(N+16)), $ (NINT(ADATA(N+16+II)),II=1,3) 7095 FORMAT(1X,A10,5(I6.5,1X,I3.3,2(1X,I5.5),2X)) END IF END DO END IF END IF C DATA RETURNED DIRECTLY FROM BUFR DUMP FILE (ADATA3 ARRAY) C --------------------------------------------------------- cpppppppppp cc print'(1X)' cc print'(" NDATA3 = ",7(I0,1X))', ndata3 cpppppppppp if(ndata3(1).gt.0) then if(ndata3(1).eq.1) then if(min(adata3(1,1,1),adata3(2,1,1)).ge.bmiss) go to 401 end if cpppppppppp cc print'(1X)' cc print'(" ADATA3(*,*,1):")' cpppppppppp IF(NDATA3(1).EQ.1) THEN JNDX = 1 IF(NINT(ADATA3(1,1,1)).EQ.1.AND.QTP01.LT.BMISS) THEN IQM(1)=NINT(QTP01) ELSE IF(NINT(ADATA3(1,1,1)).EQ.24.AND.QTP24.LT.BMISS) THEN IQM(1)=NINT(QTP24) END IF PRINT 1135, (J,NINT(ADATA3(1,J,1)),ADATA3(2,J,1),IQM(J), $ J=1,1) ELSE DO K = 1,NDATA3(1),3 DO L = 3,2,-1 IF(K+(L-1).LE.NDATA3(1)) THEN JNDX = L DO J = K,K+(L-1) IF(NINT(ADATA3(1,J,1)).EQ.1.AND. $ QTP01.LT.BMISS) THEN IQM(J)=NINT(QTP01) ELSE IF(NINT(ADATA3(1,J,1)).EQ.24 $ .AND.QTP24.LT.BMISS) THEN IQM(J)=NINT(QTP24) END IF ENDDO PRINT 1135, (J,NINT(ADATA3(1,J,1)), $ ADATA3(2,J,1),IQM(J),J=K,K+(L-1)) EXIT END IF ENDDO ENDDO END IF 1135 FORMAT((' L',I1,': .DTHTOPC ',I3,', TOPC/QM ',F6.1,'/',I2, $ ' |')) end if 401 continue if(ndata3(2).gt.0) then if(ndata3(2).eq.1) then if(adata3(1,1,2).ge.bmiss) go to 402 end if cpppppppppp cc print'(1X)' cc print'(" ADATA3(*,*,2):")' cpppppppppp IF(NDATA3(2).EQ.1) THEN JNDX = 1 PRINT 1136, (J,NINT(ADATA3(1,J,2)),J=1,1) ELSE DO K = 1,NDATA3(2),8 DO L = 8,2,-1 IF(K+(L-1).LE.NDATA3(2)) THEN JNDX = L PRINT 1136, (J,NINT(ADATA3(1,J,2)),J=K,K+(L-1)) EXIT END IF ENDDO ENDDO END IF 1136 FORMAT((' L',I1,': PRWE ',I3,' |')) end if 402 continue if(ndata3(3).gt.0) then if(ndata3(3).eq.1) then if(min(adata3(1,1,3),adata3(2,1,3),adata3(3,1,3), $ adata3(4,1,3),adata3(5,1,3)).ge.bmiss) go to 403 end if cpppppppppp cc print'(1X)' cc print'(" ADATA3(*,*,3):")' cpppppppppp DO K = 1,NDATA3(3),2 IF(K+1.LE.NDATA3(3)) THEN JNDX = 2 PRINT 1137, (J,(NINT(ADATA3(I,J,3)),I=1,5),J=K,K+1) ELSE JNDX = 1 PRINT 1137, (J,(NINT(ADATA3(I,J,3)),I=1,5),J=K,K) END IF 1137 FORMAT((' L',I1,': VSSO ',I2,', CLAM ',I2,', CLTP ',I2, $ ', HOCB ',I5,', HOCT ',I5,' |')) ENDDO end if 403 continue if(ndata3(4).gt.0) then if(ndata3(4).eq.1) then if(min(adata3(1,1,4),adata3(2,1,4),adata3(3,1,4), $ adata3(4,1,4)).ge.bmiss) go to 404 end if cpppppppppp cc print'(1X)' cc print'(" ADATA3(*,*,4):")' cpppppppppp DO K = 1,NDATA3(4),2 IF(K+1.LE.NDATA3(4)) THEN JNDX = 2 PRINT 1138, (J,(NINT(ADATA3(I,J,4)), $ ADATA3(I+1,J,4),I=1,3,2),J=K,K+1) ELSE JNDX = 1 PRINT 1138, (J,(NINT(ADATA3(I,J,4)), $ ADATA3(I+1,J,4),I=1,3,2),J=K,K) END IF 1138 FORMAT((' L',I1,': .DTHMXTM ',I3,', MXTM ',F6.2, $ ', .DTHMITM ',I3,', MITM ',F6.2,' |')) ENDDO end if 404 continue if(ndata3(5).gt.0) then if(ndata3(5).eq.1) then if(min(adata3(1,1,5),adata3(2,1,5)).ge.bmiss) go to 405 end if cpppppppppp cc print'(1X)' cc print'(" ADATA3(*,*,5):")' cpppppppppp IF(NDATA3(5).EQ.1) THEN JNDX = 1 PRINT 4135, (J,NINT(ADATA3(1,J,5)),ADATA3(2,J,5), $ NINT(ADATA3(3,J,5)),J=1,1) ELSE DO K = 1,NDATA3(5),3 DO L = 3,2,-1 IF(K+(L-1).LE.NDATA3(5)) THEN JNDX = L PRINT 4135, (J,NINT(ADATA3(1,J,5)),ADATA3(2,J,5), $ NINT(ADATA3(3,J,5)),J=K,K+(L-1)) EXIT END IF ENDDO ENDDO END IF 4135 FORMAT((' L',I1,': DOSW ',I3,', HOSW ',F5.1,', POSW ',I2, $ ' |')) end if 405 continue PRINT 993 993 FORMAT(' ') IF(SORTID) GO TO 8050 GO TO 905 C----------------------------------------------------------------------- 906 CONTINUE PRINT 9004, NUNIT,KOUNT 9004 FORMAT(//45X,'--> ALL REPORTS IN FILE',I3,' PROCESSED <--'//48X, $ '*** ',I5,' REPORTS LISTED HERE ***'/) IF(KNTLAT.GT.0) PRINT 9005, KNTLAT 9005 FORMAT(' --> ',I6,' REPORTS OUTSIDE OF SELECTED LATITUDE BAND ', $ 'AND NOT LISTED HERE <--'/) IF(KNTLON.GT.0) PRINT 9006, KNTLON 9006 FORMAT(' --> ',I6,' REMAINING REPORTS OUTSIDE OF SELECTED ', $ 'LONGITUDE BAND AND NOT LISTED HERE <--'/) IF(KNTCHR.GT.0) PRINT 9007, KNTCHR 9007 FORMAT(' --> ',I6,' REMAINING REPORTS NOT OF REQUESTED STNID ', $ 'NOT LISTED HERE <--'/) PRINT 9008 9008 FORMAT(/40X,'>>> SUCCESSFUL COMPLETION OF PROGRAM ', $ 'BUFR_LISTDUMPS <<<'/) RETURN C----------------------------------------------------------------------- 999 CONTINUE PRINT 567, IER 567 FORMAT('**BUFR_LISTDUMPS/LISTSFC: RETURN CODE =',I3,'; SOME TYPE', $ ' OF ERROR IN DECODING REPORT FROM INPUT BUFR FILE - STOP 99') CALL W3TAGE('BUFR_LISTDUMPS') CALL ERREXIT(99) C----------------------------------------------------------------------- END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: LISTPROFILER C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2017-10-13 C C ABSTRACT: LISTS CONTENTS OF A TIME-WINDOWED WIND PROFILER BUFR DATA C DUMP FILE. THE STANDARD OUTPUT IS IN AN EASY-TO-READ FORMAT. C NOTE: THIS SUBROUTINE CAN HANDLE THE FOLLOWING BUFR DATA DUMP C FILE TYPE: PROFLR {ALL TYPES EXCEPT FOR THOSE ORIGINATING FROM C PILOT (PIBAL) FORMAT BULLETINS WHICH ARE PROCESSED BY SUBROUTINE C "LISTUPA"}. C C PROGRAM HISTORY LOG: C 2000-03-28 D.A. KEYSER -- ORIGINAL AUTHOR C 2001-04-06 D.A. KEYSER -- TESTS FOR IRET = 8 FROM W3UNPKB7 - IF C FOUND MEANS A NEW BUFR MESSAGE WAS READ WITH SUBSET "NC002009", C AND CALLS SUBR. "LISTUPA" TO PROCESS THE REPORTS; ACCOUNTS FOR C CHANGE IN W3UNPKB7 WHICH RETURNS FULL DATE (YYYYMMDDHH) IN C HEADER WORD 5 C 2002-03-05 D.A. KEYSER -- SUBR. W3UNPKB7 ARGUMENT RDATA MUST BE C DIMENSIONED AT LEAST 1200 NOW TO ACCOUNT FOR 64 POSSIBLE WIND C PROFILER LEVELS FROM NOAA/FSL, RDATA INCREASED FROM 800 TO 1200 C IN THIS PROGRAM C 2004-02-02 KEYSER -- ARRAY SUBSKP BUMPED UP FROM (0:12,200) TO C (0:255,0:200) AND NOW IT CAN ALSO BE READ IN FOR NON-UPA AND C NON-SFC TYPES IN NAMELIST PDATA C 2016-11-30 D. A. KEYSER -- Reads new output real, double-precision C argument array RDATA8_8 of length 2 in call to W3UNPKB7. This C new array, which returns latitude and longitude for each report, C is currently not referenced by this subroutine. C 2017-10-13 D. A. KEYSER -- Added minutes to every print statement C that includes the central dump time. Central dump time minutes is C obtained from Section 1 of first (dummy) message of input dump C file via call to BUFRLIB routine IUPVS01. C BENEFIT: Until now, central dump time minutes was always zero. C However, with the implementation of the new RTMA_RU, C central dump time can now also have minutes = 15, 30 C or 45 (since the RTMA_RU runs 4 times per hour). This C change allows the print statements to reflect this new C center dump time format. C C USAGE: CALL LISTPROFILER C C INPUT FILES: C UNIT 05 - INPUT DATA CARDS IN THE FORM OF A NAMELIST (SEE C - REMARKS IN MAIN PROGRAM DOCBLOCK) C UNIT 21 - BUFR DATA SET C C OUTPUT FILES: C UNIT 06 - STANDARD OUTPUT PRINT C C REMARKS: NONE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ SUBROUTINE LISTPROFILER LOGICAL SNDG,RETR,RADN,SUBSKP(0:255,0:200) INTEGER NWINDO(2),IDATE(4),MDATE(4),IDATA(2500) INTEGER(8) IDSDMP_8 REAL RDATA(2500),RDATA2(25) REAL(8) BMISS,rdata8_8(2) CHARACTER*1 C1,C2 CHARACTER*8 STNID,DSNAME,SUBSET CHARACTER*9 TEXT1 COMMON/BUFRLIB_MISSING/BMISS EQUIVALENCE (RDATA,IDATA) DATA XMISS/99999./ NAMELIST/PDATA/IDAT10,IWINDE,IWINDL,IPRINT,SNDG,RETR,RADN,SUBSKP SUBSKP = .FALSE. READ(5,PDATA) IDATE(1) = IDAT10/1000000 IDATE(2) = MOD((IDAT10/10000),100) IDATE(3) = MOD((IDAT10/100),100) IDATE(4) = MOD(IDAT10,100) IUNIT = 21 NWINDO(1) = IWINDE NWINDO(2) = IWINDL KNTRPT = 0 2090 CONTINUE C CALL W3UNPKB7 TO UNPACK THE NEXT WIND PROFILER REPORT IRET = IPRINT PRINT'(1X)' CALL W3UNPKB7(IDATE,NWINDO(1),NWINDO(2),IUNIT,RDATA,STNID,DSNAME, $ RDATA2,rdata8_8,IDSDAT,IDSDMP_8,SUBSET,SUBSKP,IRET) C----------------------------------------------------------------------- IF(IRET.EQ.1) THEN C IRET = 1 RETURNS DATA SET INFO (ONLY) AFTER FIRST CALL IF(IPRINT.LT.0) PRINT'(" RETURN CODE =",I0,"; DATA SET ", $ "INFORMATION RETURNED")', IRET PRINT 102, DSNAME,IUNIT 102 FORMAT(//46X,'***** ',A8,' -- UNIT =',I3,' *****') C SPLIT DATE INTO COMPONENTS (MDATE) MDATE(1) = IDSDAT/1000000 MDATE(2) = MOD((IDSDAT/10000),100) MDATE(3) = MOD((IDSDAT/100),100) MDATE(4) = MOD(IDSDAT,100) c----------------------------------------------------------------------- c Read 1st dummy message in file so can then call iupvs01 to get iminu call readmg(iunit,subset,ibdate,kret) iminu = iupvs01(iunit,'MINU') c Close file and reopen so W3UNPKB7 will handle things as though this c block of code never exited call closbf(iunit) call openbf(iunit,'IN',iunit) c----------------------------------------------------------------------- PRINT 1101, DSNAME,MDATE,iminu,IDSDMP_8 1101 FORMAT(20X,'DATASET NAME: ',A8,' -- DATE: ',I4.4,2('-',I2.2), $ 1X,I2.2,i2.2,'Z -- DUMP DATE (I12 FORMAT): ',I12.12/) C DOES DATE FROM DATA SET MATCH EXPECTED CENTER DATE? IF(IDSDAT.NE.IDAT10) THEN PRINT 324 324 FORMAT(/13X,'>>>>> P R O B L E M : B U F R F I L E ', $ 'D A T E D O E S N O T M A T C H E X P E C T E D ', $ 'D A T E <<<<<'/) GO TO 7003 END IF IFIND = 0 DO I = 0,255 DO J = 0,200 IF(SUBSKP(I,J)) THEN IF(IFIND.EQ.0) PRINT 7000 7000 FORMAT(34X,'-- THE FOLLOWING BUFR MESSAGE TYPES/SUBTYPES WILL BE', $ ' SKIPPED:') PRINT 7001, I,J 7001 FORMAT(45X,'BUFR TYPE ',I3.3,', SUBTYPE ',I3.3) IFIND = 1 END IF ENDDO ENDDO IF(IFIND.EQ.0) PRINT 7002 7002 FORMAT(34X,'-- ALL BUFR MESSAGE TYPES/SUBTYPES IN DATA DUMP FILE', $ ' WILL BE PROCESSED') PRINT 7004 7004 FORMAT(//) GO TO 2090 C---------------------------------------------------------------------- ELSE IF(IRET.EQ.8) THEN C A NEW BUFR MESSAGE WAS READ WITH TYPE 002, SUBTYPE 009 - THIS MESSAGE C CONTAINS WIND PROFILER REPORTS ORIGINATING FROM PILOT (PIBAL) C BULLETINS - USE SUBROUTINE LISTUPA TO UNPACK AND LIST PRINT 892, IUNIT,SUBSET 892 FORMAT(/'##BUFR_LISTDUMPS/LISTPROFILER: BUFR MESSAGE IN UNIT',I3, $ ' CONTAINS WIND PROFILER REPORTS ORIG. FROM PILOT (PIBAL) ', $ ' BULLETINS (SUBSET=',A8,')'/31X,'USE SUBROUTINE LISTUPA TO ', $ 'UNPACK AND LIST THESE REPORTS'/) IOPENED = 1 CALL LISTUPA(IOPENED,KNTRPT,DSNAME,IDSDAT,IDSDMP_8,SUBSET) RETURN C---------------------------------------------------------------------- ELSE IF(IRET.GT.2) THEN C PROBLEM READING WIND PROFILER REPORT, GO ON TO NEXT REPORT PRINT 912 912 FORMAT(' * * ERROR READING WIND PROFILER REPORT, TRY NEXT ONE') GO TO 2090 C---------------------------------------------------------------------- C ALL DONE ELSE IF(IRET.EQ.2) THEN GO TO 7003 END IF C---------------------------------------------------------------------- KNTRPT = KNTRPT + 1 C PRINT OUT REPORT AS FOUND IN OUTPUT ARRAY 'IDATA' IF(IPRINT.LT.0) PRINT 8890,(IDATA(K),K=35,38) 8890 FORMAT(1X,'>> PRINTOUT OF OUTPUT IDATA ARRAY:'//1X,'NO. CAT. 10 ', $ 'LVLS=',I1,'; CAT. 10 DATA SUBSCRIPT=',I2,'; NO. CAT. 11 LVLS=' $ ,I2,'; CAT. 11 DATA SUBSCRIPT=',I3/) C1 = 'N' C2 = 'E' ALAT = RDATA(1) IF(RDATA(1).LT.0.0) THEN ALAT = -ALAT C1 = 'S' END IF ALON = RDATA(2) IF(RDATA(2).GT.180.00) THEN ALON = 360.00 - ALON C2 = 'W' END IF IF(RDATA2(5).LT.BMISS) THEN ISBMD = NINT(RDATA2(5)) ELSE ISBMD = 3 END IF PRINT 9890, STNID(1:5),RDATA(4),ALAT,C1,ALON,C2,NINT(RDATA(7)), $ IDATA(9),NINT(RDATA2(1)),ISBMD,NINT(RDATA2(6)),IDATA(5) 9890 FORMAT(1X,A5,3X,F8.5,'Z',3X,F5.2,A1,3X,F6.2,A1,3X,'ELEV ',I5, $ 'M',3X,'RPT TYPE ',I3.3,3X,'TSIG ',I2,3X,'SUBMODE ',I2,3X, $ 'TAVG ',I4,'MIN',3X,'DATE ',I10.10) IF(IDATA(35).GT.0) THEN PMSL = XMISS PSTN = XMISS WSPD = XMISS TEMP = XMISS IF(RDATA(IDATA(36)).LT.XMISS) PMSL = RDATA(IDATA(36))*0.1 IF(RDATA(IDATA(36)+1).LT.XMISS) PSTN = RDATA(IDATA(36)+1)*0.1 IF(RDATA(IDATA(36)+3).LT.XMISS) WSPD = RDATA(IDATA(36)+3)*0.1 IF(RDATA(IDATA(36)+4).LT.XMISS) TEMP = RDATA(IDATA(36)+4)*0.1 PRINT 9891, PMSL,PSTN,NINT(RDATA(IDATA(36)+2)),WSPD,TEMP, $ NINT(RDATA(IDATA(36)+5)),RDATA(IDATA(36)+6)*3600. 9891 FORMAT('SURFACE: PMSL ',F6.1,'MB PSTN ',F6.1,'MB WDIR ', $ I3,'DEG WSPD ',F5.1,'M/S TEMP ',F5.1,'K RH ',I3, $ '% RAINFALL RATE ',F6.1,'MM/HR') END IF IF(IDATA(37).GT.0) THEN J = IDATA(38) - 11 TEXT1 = ' PEAK PWR' IF(SUBSET.EQ.'NC002013') TEXT1 = 'S2N RATIO' PRINT 8892, TEXT1 8892 FORMAT('UPPER AIR: LVL HGT(M) WDIR(DEG) WSPD(M/S) Q.CODE ', $ ' VVEL(M/S) H.C. V.C. ',A9,'(DB) H. VAR(M/S) V. ', $ 'VAR(M/S) MODE') DO I = 1,IDATA(37) J = J + 11 IHGHT = 999999 IF(RDATA(J).LT.XMISS) IHGHT = NINT(RDATA(J)) WSPD = XMISS IF(RDATA(J+2).LT.XMISS) WSPD = RDATA(J+2)*0.1 VVEL = XMISS IF(RDATA(J+4).LT.XMISS) VVEL = RDATA(J+4)*0.01 HVAR = XMISS IF(RDATA(J+8).LT.XMISS) HVAR = RDATA(J+8)*0.1 VVAR = XMISS IF(RDATA(J+9).LT.XMISS) VVAR = RDATA(J+9)*0.1 PRINT 8893, I,IHGHT,NINT(RDATA(J+1)),WSPD,IDATA(J+3),VVEL, $ (IDATA(J+K),K=5,6),NINT(RDATA(J+7)),HVAR,VVAR,IDATA(J+10) 8893 FORMAT(11X,I3,4X,I5,6X,I3,6X,F5.1,7X,I3,5X,F6.2,7X,I2,5X,I2,6X,I4, $ 12X,F5.1,9X,F5.1,7X,I2) ENDDO END IF C GO UP AND UNPACK THE NEXT REPORT GO TO 2090 7003 CONTINUE C----------------------------------------------------------------------- C ALL REPORTS HAVE BEEN UNPACKED -- ALL DONE PRINT 9004, IUNIT,KNTRPT 9004 FORMAT(//45X,'--> ALL REPORTS IN FILE',I3,' PROCESSED <--'//47X, $ '*** ',I6,' REPORTS LISTED HERE ***'/) PRINT 9006 9006 FORMAT(/38X,'>>> SUCCESSFUL COMPLETION OF PROGRAM ', $ 'BUFR_LISTDUMPS <<<'/) RETURN C----------------------------------------------------------------------- END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: LISTVADWIND C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2017-10-13 C C ABSTRACT: LISTS CONTENTS OF A TIME-WINDOWED VAD WIND BUFR DATA C DUMP FILE. THE STANDARD OUTPUT IS IN AN EASY-TO-READ FORMAT. C NOTE: THIS SUBROUTINE CAN HANDLE THE FOLLOWING BUFR DATA DUMP C FILE TYPE: VADWND. C C PROGRAM HISTORY LOG: C 2000-03-28 D.A. KEYSER -- ORIGINAL AUTHOR C 2001-04-06 D.A. KEYSER -- ACCOUNTS FOR CHANGE IN W3UNPKB7 WHICH C RETURNS FULL DATE (YYYYMMDDHH) IN HEADER WORD 5 C 2002-03-05 D.A. KEYSER -- SUBR. W3UNPKB7 ARGUMENT RDATA MUST BE C DIMENSIONED AT LEAST 1200 NOW TO ACCOUNT FOR 64 POSSIBLE WIND C PROFILER LEVELS FROM NOAA/FSL, RDATA INCREASED FROM 800 TO 1200 C IN THIS PROGRAM C 2004-02-02 KEYSER -- ARRAY SUBSKP BUMPED UP FROM (0:12,200) TO C (0:255,0:200) AND NOW IT CAN ALSO BE READ IN FOR NON-UPA AND C NON-SFC TYPES IN NAMELIST PDATA C 2014-04-22 D. A. KEYSER -- CHANGES TO ALLOW FOR LISTING OF NEW VAD C WIND REPORTS FROM LEVEL 2 DECODER. C 2016-11-30 D. A. KEYSER -- Reads new output real, double-precision C argument array RDATA8_8 of length 2 in call to W3UNPKB7. This C new array, which returns latitude and longitude for each report, C is currently not referenced by this subroutine. C 2017-10-13 D. A. KEYSER -- Added minutes to every print statement C that includes the central dump time. Central dump time minutes is C obtained from Section 1 of first (dummy) message of input dump C file via call to BUFRLIB routine IUPVS01. C BENEFIT: Until now, central dump time minutes was always zero. C However, with the implementation of the new RTMA_RU, C central dump time can now also have minutes = 15, 30 C or 45 (since the RTMA_RU runs 4 times per hour). This C change allows the print statements to reflect this new C center dump time format. C C USAGE: CALL LISTVADWND C C INPUT FILES: C UNIT 05 - INPUT DATA CARDS IN THE FORM OF A NAMELIST (SEE C - REMARKS IN MAIN PROGRAM DOCBLOCK) C UNIT 21 - BUFR DATA SET C C OUTPUT FILES: C UNIT 06 - STANDARD OUTPUT PRINT C C REMARKS: NONE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ SUBROUTINE LISTVADWIND LOGICAL SNDG,RETR,RADN,SUBSKP(0:255,0:200) INTEGER NWINDO(2),IDATE(4),MDATE(4),IDATA(2500) INTEGER(8) IDSDMP_8 REAL RDATA(2500),RDATA2(25) real(8) rdata8_8(2) CHARACTER*1 C1,C2 CHARACTER*8 STNID,DSNAME,SUBSET EQUIVALENCE (RDATA,IDATA) DATA XMISS/99999./ NAMELIST/PDATA/IDAT10,IWINDE,IWINDL,IPRINT,SNDG,RETR,RADN,SUBSKP SUBSKP = .FALSE. READ(5,PDATA) IDATE(1) = IDAT10/1000000 IDATE(2) = MOD((IDAT10/10000),100) IDATE(3) = MOD((IDAT10/100),100) IDATE(4) = MOD(IDAT10,100) IUNIT = 21 NWINDO(1) = IWINDE NWINDO(2) = IWINDL KNTRPT = 0 2090 CONTINUE C CALL W3UNPKB7 TO UNPACK THE NEXT VAD WIND REPORT IRET = IPRINT PRINT'(1X)' CALL W3UNPKB7(IDATE,NWINDO(1),NWINDO(2),IUNIT,RDATA,STNID,DSNAME, $ RDATA2,rdata8_8,IDSDAT,IDSDMP_8,SUBSET,SUBSKP,IRET) C----------------------------------------------------------------------- IF(IRET.EQ.1) THEN C IRET = 1 RETURNS DATA SET INFO (ONLY) AFTER FIRST CALL IF(IPRINT.LT.0) PRINT'(" RETURN CODE =",I0,"; DATA SET ", $ "INFORMATION RETURNED")', IRET PRINT 102, DSNAME,IUNIT 102 FORMAT(//46X,'***** ',A8,' -- UNIT =',I3,' *****') C SPLIT DATE INTO COMPONENTS (MDATE) MDATE(1) = IDSDAT/1000000 MDATE(2) = MOD((IDSDAT/10000),100) MDATE(3) = MOD((IDSDAT/100),100) MDATE(4) = MOD(IDSDAT,100) c----------------------------------------------------------------------- c Read 1st dummy message in file so can then call iupvs01 to get iminu call readmg(iunit,subset,ibdate,kret) iminu = iupvs01(iunit,'MINU') c Close file and reopen so W3UNPKB7 will handle things as though this c block of code never exited call closbf(iunit) call openbf(iunit,'IN',iunit) c----------------------------------------------------------------------- PRINT 1101, DSNAME,MDATE,iminu,IDSDMP_8 1101 FORMAT(20X,'DATASET NAME: ',A8,' -- DATE: ',I4.4,2('-',I2.2), $ 1X,I2.2,i2.2,'Z -- DUMP DATE (I12 FORMAT): ',I12.12/) C DOES DATE FROM DATA SET MATCH EXPECTED CENTER DATE? IF(IDSDAT.NE.IDAT10) THEN PRINT 324 324 FORMAT(/13X,'>>>>> P R O B L E M : B U F R F I L E ', $ 'D A T E D O E S N O T M A T C H E X P E C T E D ', $ 'D A T E <<<<<'/) GO TO 7003 END IF IFIND = 0 DO I = 0,255 DO J = 0,200 IF(SUBSKP(I,J)) THEN IF(IFIND.EQ.0) PRINT 7001 7001 FORMAT(34X,'-- THE FOLLOWING BUFR MESSAGE TYPES/SUBTYPES WILL ', $ 'BE SKIPPED:') PRINT 7002, I,J 7002 FORMAT(45X,'BUFR TYPE ',I3.3,', SUBTYPE ',I3.3) IFIND = 1 END IF ENDDO ENDDO IF(IFIND.EQ.0) PRINT 8003 8003 FORMAT(10X,'-- ALL BUFR MESSAGE TYPES/SUBTYPES IN DATA DUMP FILE', $ ' WILL BE PROCESSED') PRINT 7004 7004 FORMAT(//) GO TO 2090 C---------------------------------------------------------------------- ELSE IF(IRET.GT.2) THEN C PROBLEM READING VAD WIND REPORT, GO ON TO NEXT REPORT PRINT 912 912 FORMAT(' * * ERROR READING VAD WIND REPORT, TRY NEXT ONE') GO TO 2090 C---------------------------------------------------------------------- ELSE IF(IRET.EQ.2) THEN C ALL DONE GO TO 7003 END IF C---------------------------------------------------------------------- KNTRPT = KNTRPT + 1 C PRINT OUT REPORT AS FOUND IN OUTPUT ARRAY 'IDATA' IF(IPRINT.LT.0) PRINT 8890,(IDATA(K),K=19,20) 8890 FORMAT(//1X,'>> PRINTOUT OF OUTPUT IDATA ARRAY:'//' NO.', $ ' CAT. 04 LVLS=',I3,'; CAT. 04 DATA SUBSCRIPT=',I3/) C1 = 'N' C2 = 'E' ALAT = RDATA(1) IF(RDATA(1).LT.0.0) THEN ALAT = -ALAT C1 = 'S' END IF ALON = RDATA(2) IF(RDATA(2).GT.180.00) THEN ALON = 360.00 - ALON C2 = 'W' END IF PRINT 9890, STNID,RDATA(4),ALAT,C1,ALON,C2,NINT(RDATA(7)), $ IDATA(9),IDATA(5) 9890 FORMAT(1X,A8,4X,F8.5,'Z',4X,F5.2,A1,4X,F6.2,A1,4X,'ELEV ',I5, $ 'M',4X,'RPT TYPE ',I3.3,4X,'DATE ',I10.10) IF(IDATA(19).GT.0) THEN J = IDATA(20) - 5 IF(SUBSET.EQ.'NC002008') THEN PRINT 9892 9892 FORMAT(12X,'LVL HGT(M) WDIR(DEG) WSPD(M/S) Q.MARK') DO I = 1,IDATA(19) J = J + 5 IHGHT = 999999 IF(RDATA(J).LT.XMISS) IHGHT = NINT(RDATA(J)) WSPD = XMISS IF(RDATA(J+2).LT.XMISS) WSPD = RDATA(J+2)*0.1 PRINT 9893,I,IHGHT,NINT(RDATA(J+1)),WSPD,NINT(RDATA(J+4)) 9893 FORMAT(12X,I2,4X,I5,6X,I3,7X,F5.1,9X,I2.2) ENDDO ELSE IF(SUBSET.EQ.'NC002017') THEN PRINT 9894 9894 FORMAT(12X,'LVL HGT(M) UCMP(M/S) VCMP(M/S) Q.MARK') DO I = 1,IDATA(19) J = J + 5 IHGHT = 999999 IF(RDATA(J).LT.XMISS) IHGHT = NINT(RDATA(J)) PRINT 9895,I,IHGHT,RDATA(J+1),RDATA(J+2),NINT(RDATA(J+4)) 9895 FORMAT(10X,I4,4X,I5,4X,F5.1,7X,F5.1,9X,I2.2) ENDDO END IF END IF C GO UP AND UNPACK THE NEXT REPORT GO TO 2090 7003 CONTINUE C----------------------------------------------------------------------- C ALL REPORTS HAVE BEEN UNPACKED -- ALL DONE PRINT 9004, IUNIT,KNTRPT 9004 FORMAT(//45X,'--> ALL REPORTS IN FILE',I3,' PROCESSED <--'//47X, $ '*** ',I6,' REPORTS LISTED HERE ***'/) PRINT 9006 9006 FORMAT(/38X,'>>> SUCCESSFUL COMPLETION OF PROGRAM ', $ 'BUFR_LISTDUMPS <<<'/) RETURN C----------------------------------------------------------------------- END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: LISTGOESNDGS C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2017-10-13 C C ABSTRACT: LISTS CONTENTS OF A TIME-WINDOWED GOES SOUNDING/RETRIEVAL/ C RADIANCE BUFR DATA DUMP FILE. THE STANDARD OUTPUT IS IN AN EASY- C TO-READ FORMAT. NOTE: THIS SUBROUTINE CAN HANDLE THE FOLLOWING C BUFR DATA DUMP FILE TYPES: GOESND AND GOESFV. C C PROGRAM HISTORY LOG: C 2000-03-28 D.A. KEYSER -- ORIGINAL AUTHOR C 2001-04-06 D.A. KEYSER -- UNITS FOR INPUT GOES BRIGHT. TEMPS, LI, C PWATER (TOTAL AND LAYERS), SKIN TEMP, ZENITH ANGLE (SOLAR AND C SATELLITE), CLOUD TOP TEMP AND CLOUD TOP PRESSURE CHANGED FROM C K*100, K*100, MM*100, K*100, DEG*100, K*100, MB*10, RESP. TO K, C K, MM, K, DEG, K, MB WITH FLOATING POINT PRECISION TO 10**2, C 10**2, 10**2, 10**2, 10**2, 10**2, 10**1, RESP. TO ACCOUNT FOR C CHANGE IN W3UNPKB7; ACCOUNTS FOR CHANGE IN W3UNPKB7 WHICH RETURNS C FULL DATE (YYYYMMDDHH) IN HEADER WORD 5 AND SATELLITE ID IN C HEADER WORD 6, INCLUDES SATELLITE ID IN LISTING C 2001-06-19 D.A. KEYSER -- CAN NOW LIST GOES CLOUD TOP REPORTS C CONTAINING CLOUD TOP PRESSURE, CLOUD COVER AND CLOUD TOP C TEMPERATURE WHICH CAN NOW BE PART OF THE "GOESND" DATA DUMP FILE C 2002-03-05 D.A. KEYSER -- SUBR. W3UNPKB7 ARGUMENT RDATA MUST BE C DIMENSIONED AT LEAST 1200 NOW TO ACCOUNT FOR 64 POSSIBLE WIND C PROFILER LEVELS FROM NOAA/FSL, RDATA INCREASED FROM 800 TO 1200 C IN THIS PROGRAM C 2004-02-02 KEYSER -- ARRAY SUBSKP BUMPED UP FROM (0:12,200) TO C (0:255,0:200) AND NOW IT CAN ALSO BE READ IN FOR NON-UPA AND C NON-SFC TYPES IN NAMELIST PDATA C 2004-09-09 KEYSER -- NO LONGER SELECTS WHAT TO PRINT SIMPLY BY C WHETHER REPORT IS A 1x1 ("H" IN 1ST CHAR. OF STNID) OR 5x5 C REPORT, THIS IS BECAUSE 1x1 REPORTS COULD NOW CONTAIN BOTH CLOUD C REPORTS (AS BEFORE) AND SOUNDING/RADIANCE REPORTS - SUBR. NOW C TESTS FOR MISSING CLOUD DATA TO NOT PRINT CLOUD INFO, MISSING C PSFC AND TPW TO NOT PRINT RETRIEVAL INFO AND ZERO BRIGHTNESS TEMP C LEVELS TO NOT PRINT RADIANCE INFO C 2007-09-14 D. A. KEYSER -- IMPROVED DOCUMENTATION AT TOP OF LISTINGS. C 2015-04-16 D. A. KEYSER -- Now correctly lists total cloud cover from C GOES cloud reports in dump file "goesnd" as the value of TOCC C from RDATA2(25) passed from W3UNPKB7 (had looked for it in cat 8 C c.f. 258 passed in from W3UNPKB7 in RDATA array but this was C changed long ago to hold cloud amount and not total cloud cover, C and the former is missing in GOES cloud reports). C 2016-11-30 D. A. KEYSER -- Reads new output real, double-precision C argument array RDATA8_8 of length 2 in call to W3UNPKB7. This C new array, which returns latitude and longitude for each report, C is currently not referenced by this subroutine. C 2017-10-13 D. A. KEYSER -- Added minutes to every print statement C that includes the central dump time. Central dump time minutes is C obtained from Section 1 of first (dummy) message of input dump C file via call to BUFRLIB routine IUPVS01. C BENEFIT: Until now, central dump time minutes was always zero. C However, with the implementation of the new RTMA_RU, C central dump time can now also have minutes = 15, 30 C or 45 (since the RTMA_RU runs 4 times per hour). This C change allows the print statements to reflect this new C center dump time format. C C USAGE: CALL LISTGOESNDGS C C INPUT FILES: C UNIT 05 - INPUT DATA CARDS IN THE FORM OF A NAMELIST (SEE C - REMARKS IN MAIN PROGRAM DOCBLOCK) C UNIT 21 - BUFR DATA SET C C OUTPUT FILES: C UNIT 06 - STANDARD OUTPUT PRINT C C REMARKS: NONE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ SUBROUTINE LISTGOESNDGS LOGICAL SNDG,RETR,RADN,SUBSKP(0:255,0:200) INTEGER NWINDO(2),IDATE(4),IDATA(2500),IQM(250:262),JQM(18) INTEGER(8) IDSDMP_8 REAL RDATA(2500),DAT(250:262),RAD(18),RDATA2(25) real(8) rdata8_8(2) CHARACTER*1 C1,C2 CHARACTER*8 STNID,DSNAME,SUBSET EQUIVALENCE (RDATA,IDATA) DATA ZMISS/999999./ NAMELIST/PDATA/IDAT10,IWINDE,IWINDL,IPRINT,SNDG,RETR,RADN,SUBSKP SUBSKP = .FALSE. READ(5,PDATA) IUNIT = 21 NWINDO(1) = IWINDE NWINDO(2) = IWINDL PRINT 9003, IUNIT 9003 FORMAT(//32X,' ***** GOES SATELLITE SOUNDING/RETRIEVAL/RADIANCE', $ ' FILE UNIT =',I4,' *****') C SPLIT PRODUCTION DATE INTO COMPONENTS (IDATE) IDATE(1) = IDAT10/1000000 IDATE(2) = MOD((IDAT10/10000),100) IDATE(3) = MOD((IDAT10/100),100) IDATE(4) = MOD(IDAT10,100) PRINT 550, IDATE 550 FORMAT(25X,'LOOKING FOR FILE WITH CENTER DATE: ',2X,I4.4, $ 2('-',I2.2),1X,I2.2,'Z BASED ON PRODUCTION DATE') PRINT 101 101 FORMAT(//5X,'KEY FOR DATA LISTED IN EACH REPORT BELOW:'/ $/10X,'Field 1 ....... Report id' $/10X,'Field 2 ....... Observation time (UTC)' $/10X,'Field 3 ....... Latitude (N,S)' $/10X,'Field 4 ....... Longitude (E,W)' $/10X,'ELV ............ Elevation (meters)' $/10X,'SATID .......... Satellite id, BUFR Code Table 0-01-007' $/28X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'common_tbl_c1-c5.htm#c-5)' $/10X,'RTYPE .......... Dump report type (always 061 - GOES ', $ 'sounding/radiance)' $/10X,'#FOV ........... Number of fields-of-view (numeric)' $/10X,'QM ............. Quality information, BUFR Code Table 0-33', $ '-002' $/28X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/table' $,'_25-35.htm#0-33-002)' $/10X,'TECH ........... Retrieval type (21 - Clear, 23 - Cloudy)' $/10X,'DATE ........... YYYYMMDDHH of observation'/) IF(RETR) PRINT 551 551 FORMAT(7X,'RETRIEVALS --' $/10X,'xxx/QM , where xxx is:' $/16X,'PS = Surface pressure (mb)' $/16X,'LI = Lifted index (K)' $/16X,'PW = Total column precipitable water (mm)' $/16X,'P1 = 1.0 to 0.9 sigma layer precipitable water (mm)' $/16X,'P2 = 0.9 to 0.7 sigma layer precipitable water (mm)' $/16X,'P3 = 0.7 to 0.3 sigma layer precipitable water (mm)' $/16X,'TS = Skin temperature (K)' $/16X,'CL = Cloud amount, BUFR Code Table 0-20-011' $/23X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_20.htm#0-20-011)' $/16X,'CC = Total cloud cover (%) (note: there is no QM, stamped', $ ' out as "--")' $/16X,'IN = Instrument data used, BUFR Code Table 0-02-021' $/23X,'(see http://www.emc.ncep.noaa.gov/mmb/data_processing/', $ 'table_1-2.htm#0-02-021)' $/16X,'OZ = Solar zenith angle (degrees)' $/16X,'AZ = Satellite zenith angle (degrees)' $/16X,'CTT = Cloud top temperature (K)' $/16X,'CTP = Cloud top pressure (mb)' $//20X,'and QM is Quality marker (00 - monitor keep, 01 - good, ', $ '02 - neutral/not checked, 03 - suspect, 12 - toss, on' $/30X,'reject list, 13 - toss, failed automatic q.c. tests, 14 - ', $ 'toss, monitor purge)'//) IF(RADN) PRINT 552 552 FORMAT(7X,'RADIANCES --' $/10X,'RADN: For each channel: xx yyy.yy/zz where:' $/20X,'xx = Channel number (1-18)' $/20X,'yyy.yy = Brightness temperature (K)' $/20X,'zz = Quality marker (00 - monitor keep, 01 - good, 02', $ ' - neutral/not checked, 03 - suspect, 12 - toss, on' $/30X,'reject list, 13 - toss, failed automatic q.c. tests, 14 - ', $ 'toss, monitor purge)'//) PRINT'(1X)' KNTRPT = 0 C*********************************************************************** 1400 CONTINUE C ATTEMPT TO DECODE THE NEXT GOES REPORT IRET = IPRINT PRINT'(1X)' CALL W3UNPKB7(IDATE,NWINDO(1),NWINDO(2),IUNIT,RDATA,STNID,DSNAME, $ RDATA2,rdata8_8,IDSDAT,IDSDMP_8,SUBSET,SUBSKP,IRET) C----------------------------------------------------------------------- IF(IRET.EQ.1) THEN C IRET = 1 RETURNS DATA SET INFO (ONLY) AFTER FIRST CALL IF(IPRINT.LT.0) PRINT'(" RETURN CODE =",I0,"; DATA SET ", $ "INFORMATION RETURNED")', IRET c----------------------------------------------------------------------- c Read 1st dummy message in file so can then call iupvs01 to get iminu call readmg(iunit,subset,ibdate,kret) iminu = iupvs01(iunit,'MINU') c Close file and reopen so W3UNPKB7 will handle things as though this c block of code never exited call closbf(iunit) call openbf(iunit,'IN',iunit) c----------------------------------------------------------------------- PRINT 7000, DSNAME,IDSDAT,iminu,IDSDMP_8 7000 FORMAT(//22X,'--> DATA SET INFORMATION: NAME: ',A8,'; DATE: ', $ I10.10,i2.2,'; DUMP TIME: ',I12.12,' <--') C DOES DATE FROM DATA SET MATCH EXPECTED CENTER DATE? IF(IDSDAT.NE.IDAT10) THEN PRINT 324 324 FORMAT(/13X,'>>>>> P R O B L E M : B U F R F I L E ', $ 'D A T E D O E S N O T M A T C H E X P E C T E D ', $ 'D A T E <<<<<'/) GO TO 9999 END IF IFIND = 0 DO I = 0,255 DO J = 0,200 IF(SUBSKP(I,J)) THEN IF(IFIND.EQ.0) PRINT 7001 7001 FORMAT(34X,'-- THE FOLLOWING BUFR MESSAGE TYPES/SUBTYPES WILL ', $ 'BE SKIPPED:') PRINT 7002, I,J 7002 FORMAT(45X,'BUFR TYPE ',I3.3,', SUBTYPE ',I3.3) IFIND = 1 END IF ENDDO ENDDO IF(IFIND.EQ.0) PRINT 8003 8003 FORMAT(10X,'-- ALL BUFR MESSAGE TYPES/SUBTYPES IN DATA DUMP FILE', $ ' WILL BE PROCESSED') PRINT 7004 7004 FORMAT(//) GO TO 1400 C---------------------------------------------------------------------- ELSE IF(IRET.GT.2) THEN C ERROR DECODING THIS REPORT, GO ON TO NEXT REPORT PRINT 572, IUNIT,KNTRPT+1,IRET 572 FORMAT(' * * ERROR DECODING GOES REPORT ON UNIT',I3,' -- ', $ 'REPORT CNT. ',I5,' -- IRET ',I5,' --> GO ON TO NEXT RPT') GO TO 1400 C---------------------------------------------------------------------- ELSE IF(IRET.EQ.2) THEN C IF IER = 2, HAVE HIT END-OF-FILE, ALL REPORTS PROCESSED GO TO 9999 C---------------------------------------------------------------------- END IF C A REPORT WAS SUCCESSFULLY DECODED KNTRPT = KNTRPT + 1 C PRINT OUT REPORT AS FOUND IN OUTPUT ARRAY 'IDATA' IF(IPRINT.LT.0) PRINT 8890, IDATA(39),IDATA(40),IDATA(27), $ IDATA(28),IDATA(41),IDATA(42) 8890 FORMAT(//1X,'>> PRINTOUT OF OUTPUT IDATA ARRAY:'//' NO. CAT. 12 ', $ 'LVLS=',I3,'; CAT. 12 SUBS.=',I3,'; NO. CAT. 08 LVLS=',I3, $ '; CAT. 08 SUBS.=',I3,'; NO. CAT. 13 LVLS=',I3, $ '; CAT. 13 SUBS.=',I3/) C1 = 'N' C2 = 'E' ALAT = RDATA(1) IF(RDATA(1).LT.0.0) THEN ALAT = -ALAT C1 = 'S' END IF ALON = RDATA(2) IF(RDATA(2).GT.180.00) THEN ALON = 360.00 - ALON C2 = 'W' END IF PRINT 9890, STNID,RDATA(4),ALAT,C1,ALON,C2,NINT(RDATA(7)), $ IDATA(6),IDATA(9),NINT(RDATA2(2)),NINT(RDATA2(7)),IDATA(8), $ IDATA(5) 9890 FORMAT(1X,A8,1X,F9.5,'Z', 3X,F8.2,A1,2X,F8.2,A1,4X,'ELV ',I5, $ 4X,'SATID',I4,3X,'RTYPE',I5.3,4X,'#FOV ',I3.2,3X,'QM ',I2.2, $ 3X,'TECH',I3.2,3X,'DATE ',I10.10) IF(SNDG) THEN IF(IDATA(39).GT.0) THEN ! will not print sndg data if zero lvls J = IDATA(40) - 9 PRINT 8892 8892 FORMAT('SOUNDING: LVL PRESS(MB) HGHT(M) TEMP(C) DWPT(C)', $ ' *RESV* *RESV* QM ') DO I = 1,IDATA(39) J = J + 9 PRESS = ZMISS IHGHT = 999999 IF(RDATA(J+1).LT.ZMISS) IHGHT = NINT(RDATA(J+1)) TEMP = ZMISS DWPT = ZMISS IF(RDATA(J).LT.ZMISS) PRESS = RDATA(J)/10. IF(RDATA(J+2).LT.ZMISS) TEMP = RDATA(J+2)/10. IF(RDATA(J+3).LT.ZMISS) DWPT = RDATA(J+3)/10. PRINT 8893, I,PRESS,IHGHT,TEMP,DWPT,RDATA(J+4), $ RDATA(J+5),(NINT(RDATA(J+II)),II=6,8) 8893 FORMAT(10X,I3,6X,F7.1,4X,I5,3X,F7.1,2X,F7.1,1X,2(3X,F7.1),2X,3(1X, $ I2.2)) END DO END IF END IF IF(RETR) THEN DAT = ZMISS IQM = 999999 J = IDATA(28) - 4 IF(IDATA(27).GT.0) THEN DO I = 1,IDATA(27) J = J + 4 IF(NINT(RDATA(J+1)).GT.249.AND.NINT(RDATA(J+1)).LT.263) $ THEN DAT(NINT(RDATA(J+1))) = RDATA(J) IF(RDATA(J+2).LT.ZMISS) IQM(NINT(RDATA(J+1))) = $ NINT(RDATA(J+2)) END IF END DO END IF IF(MIN(DAT(256),DAT(257)).LT.ZMISS) PRINT 9897, ! will not print cld data if c-top temp & press are missing $ (DAT(II),IQM(II),II=256,257),NINT(RDATA2(25)),NINT(DAT(259)), $ IQM(259) 9897 FORMAT('CTT',F7.2,'/',I2.2,5X,'CTP ',F6.1,'/',I2.2,5X,'CC',I4, $ '/--',5X,'IN',I2,'/',I2.2) IF(MIN(DAT(262),DAT(251)).LT.ZMISS) PRINT 9891, DAT(262), $ IQM(262),(DAT(II),IQM(II),II=250,255),(NINT(DAT(II)),IQM(II), $ II=258,259),(DAT(II),IQM(II),II=260,261) ! will not print retr data if psfc & tpw are missing 9891 FORMAT('PS',F7.1,'/',I2.2,2X,'LI',F6.2,'/',I2.2,2X,'PW',F5.1,'/', $ I2.2,2X,'P1',F5.1,'/',I2.2,2X,'P2',F5.1,'/',I2.2,2X,'P3',F5.1, $ '/',I2.2,2X,'TS',F7.2,'/',I2.2,2X,'CL',I2,'/',I2.2,2X,'IN',I2, $ '/',I2.2,2X,'OZ',F6.2,'/',I2.2,2X,'AZ',F6.2,'/',I2.2) END IF IF(RADN) THEN RAD = ZMISS JQM = 999999 J = IDATA(42) - 3 IF(IDATA(41).GT.0) THEN DO I = 1,IDATA(41) J = J + 3 IF(IDATA(J).GT.0.AND.IDATA(J).LT.19) THEN RAD(IDATA(J)) = RDATA(J+1) IF(RDATA(J+2).LT.ZMISS)JQM(IDATA(J)) =NINT(RDATA(J+2)) END IF END DO END IF IF(IDATA(41).GT.0) THEN ! will not print radiance data if all channels missing PRINT 9895, (RAD(II),JQM(II),II=1,18) 9895 FORMAT('RADN: 1',F7.2,'/',I2.2,' 2',F7.2,'/',I2.2,' 3',F7.2, $ '/',I2.2,' 4',F7.2,'/',I2.2,' 5',F7.2,'/',I2.2,' 6',F7.2, $ '/',I2.2,' 7',F7.2,'/',I2.2,' 8',F7.2,'/',I2.2,' 9',F7.2, $ '/',I2.2 $ /' 10',F7.2,'/',I2.2,' 11',F7.2,'/',I2.2,' 12',F7.2, $ '/',I2.2,' 13',F7.2,'/',I2.2,' 14',F7.2,'/',I2.2,' 15',F7.2, $ '/',I2.2,' 16',F7.2,'/',I2.2,' 17',F7.2,'/',I2.2,' 18',F7.2, $ '/',I2.2) END IF END IF C GO UP AND UNPACK THE NEXT REPORT GO TO 1400 9999 CONTINUE C----------------------------------------------------------------------- C ALL REPORTS HAVE BEEN UNPACKED -- ALL DONE PRINT 9004, IUNIT,KNTRPT 9004 FORMAT(//45X,'--> ALL REPORTS IN FILE',I3,' PROCESSED <--'//47X, $ '*** ',I6,' REPORTS LISTED HERE ***'/) PRINT 9006 9006 FORMAT(/38X,'>>> SUCCESSFUL COMPLETION OF PROGRAM ', $ 'BUFR_LISTDUMPS <<<'/) RETURN C----------------------------------------------------------------------- END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: LISTERSCAT C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2017-10-13 C C ABSTRACT: LISTS CONTENTS OF A TIME-WINDOWED REPROCESSED ERS C SCATTEROMETER BUFR DATA DUMP FILE. THE STANDARD OUTPUT IS IN C AN EASY-TO-READ FORMAT. NOTE: THIS SUBROUTINE CAN C HANDLE THE FOLLOWING BUFR DATA DUMP FILE TYPE: ERS1DA. C C PROGRAM HISTORY LOG: C 2000-03-28 D.A. KEYSER -- ORIGINAL AUTHOR C 2001-04-06 D.A. KEYSER -- ACCOUNTS FOR CHANGE IN W3UNPKB7 WHICH C RETURNS SATELLITE ID IN HEADER WORD 6, INCLUDES SATELLITE ID IN C LISTING C 2002-03-05 D.A. KEYSER -- SUBR. W3UNPKB7 ARGUMENT RDATA MUST BE C DIMENSIONED AT LEAST 1200 NOW TO ACCOUNT FOR 64 POSSIBLE WIND C PROFILER LEVELS FROM NOAA/FSL, RDATA INCREASED FROM 800 TO 1200 C IN THIS PROGRAM C 2004-02-02 KEYSER -- ARRAY SUBSKP BUMPED UP FROM (0:12,200) TO C (0:255,0:200) AND NOW IT CAN ALSO BE READ IN FOR NON-UPA AND C NON-SFC TYPES IN NAMELIST PDATA C 2016-11-30 D. A. KEYSER -- Reads new output real, double-precision C argument array RDATA8_8 of length 2 in call to W3UNPKB7. This C new array, which returns latitude and longitude for each report, C is currently not referenced by this subroutine. C 2017-10-13 D. A. KEYSER -- Added minutes to every print statement C that includes the central dump time. Central dump time minutes is C obtained from Section 1 of first (dummy) message of input dump C file via call to BUFRLIB routine IUPVS01. C BENEFIT: Until now, central dump time minutes was always zero. C However, with the implementation of the new RTMA_RU, C central dump time can now also have minutes = 15, 30 C or 45 (since the RTMA_RU runs 4 times per hour). This C change allows the print statements to reflect this new C center dump time format. C C USAGE: CALL LISTERSCAT C C INPUT FILES: C UNIT 05 - INPUT DATA CARDS IN THE FORM OF A NAMELIST (SEE C - REMARKS IN MAIN PROGRAM DOCBLOCK) C UNIT 21 - BUFR DATA SET C C OUTPUT FILES: C UNIT 06 - STANDARD OUTPUT PRINT C C REMARKS: NONE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ SUBROUTINE LISTERSCAT LOGICAL SNDG,RETR,RADN,SUBSKP(0:255,0:200) INTEGER NWINDO(2),IDATE(4),MDATE(4),IDATA(2500) INTEGER(8) IDSDMP_8 REAL RDATA(2500),RDATA2(25) real(8) rdata8_8(2) CHARACTER*1 C1,C2 CHARACTER*8 STNID,DSNAME,SUBSET EQUIVALENCE (RDATA,IDATA) DATA XMISS/99999./ NAMELIST/PDATA/IDAT10,IWINDE,IWINDL,IPRINT,SNDG,RETR,RADN,SUBSKP SUBSKP = .FALSE. READ(5,PDATA) IDATE(1) = IDAT10/1000000 IDATE(2) = MOD((IDAT10/10000),100) IDATE(3) = MOD((IDAT10/100),100) IDATE(4) = MOD(IDAT10,100) IUNIT = 21 NWINDO(1) = IWINDE NWINDO(2) = IWINDL KNTRPT = 0 2090 CONTINUE C CALL W3UNPKB7 TO UNPACK THE NEXT ERS SCATTEROMETER WIND REPORT IRET = IPRINT CALL W3UNPKB7(IDATE,NWINDO(1),NWINDO(2),IUNIT,RDATA,STNID,DSNAME, $ RDATA2,rdata8_8,IDSDAT,IDSDMP_8,SUBSET,SUBSKP,IRET) C----------------------------------------------------------------------- IF(IRET.EQ.1) THEN C IRET = 1 RETURNS DATA SET INFO (ONLY) AFTER FIRST CALL IF(IPRINT.LT.0) PRINT'(" RETURN CODE =",I0,"; DATA SET ", $ "INFORMATION RETURNED")', IRET PRINT 102, DSNAME,IUNIT 102 FORMAT(//46X,'***** ',A8,' -- UNIT =',I3,' *****') C SPLIT DATE INTO COMPONENTS (MDATE) MDATE(1) = IDSDAT/1000000 MDATE(2) = MOD((IDSDAT/10000),100) MDATE(3) = MOD((IDSDAT/100),100) MDATE(4) = MOD(IDSDAT,100) c----------------------------------------------------------------------- c Read 1st dummy message in file so can then call iupvs01 to get iminu call readmg(iunit,subset,ibdate,kret) iminu = iupvs01(iunit,'MINU') c Close file and reopen so W3UNPKB7 will handle things as though this c block of code never exited call closbf(iunit) call openbf(iunit,'IN',iunit) c----------------------------------------------------------------------- PRINT 1101, DSNAME,MDATE,iminu,IDSDMP_8 1101 FORMAT(20X,'DATASET NAME: ',A8,' -- DATE: ',I4.4,2('-',I2.2), $ 1X,I2.2,i2.2,'Z -- DUMP DATE (I12 FORMAT): ',I12.12/) C DOES DATE FROM DATA SET MATCH EXPECTED CENTER DATE? IF(IDSDAT.NE.IDAT10) THEN PRINT 324 324 FORMAT(/13X,'>>>>> P R O B L E M : B U F R F I L E ', $ 'D A T E D O E S N O T M A T C H E X P E C T E D ', $ 'D A T E <<<<<'/) GO TO 7003 END IF IFIND = 0 DO I = 0,255 DO J = 0,200 IF(SUBSKP(I,J)) THEN IF(IFIND.EQ.0) PRINT 7001 7001 FORMAT(34X,'-- THE FOLLOWING BUFR MESSAGE TYPES/SUBTYPES WILL ', $ 'BE SKIPPED:') PRINT 7002, I,J 7002 FORMAT(45X,'BUFR TYPE ',I3.3,', SUBTYPE ',I3.3) IFIND = 1 END IF ENDDO ENDDO IF(IFIND.EQ.0) PRINT 8003 8003 FORMAT(10X,'-- ALL BUFR MESSAGE TYPES/SUBTYPES IN DATA DUMP FILE', $ ' WILL BE PROCESSED') PRINT 7004 7004 FORMAT(//) GO TO 2090 C---------------------------------------------------------------------- ELSE IF(IRET.GT.2) THEN C PROBLEM READING ERS SCATTEROMETER WIND REPORT, GO ON TO NEXT REPORT PRINT 912 912 FORMAT(' * * ERROR READING ERS SCATTEROMETER WIND REPORT, TRY', $ ' NEXT ONE') GO TO 2090 C---------------------------------------------------------------------- ELSE IF(IRET.EQ.2) THEN C ALL DONE GO TO 7003 END IF C---------------------------------------------------------------------- KNTRPT = KNTRPT + 1 C PRINT OUT REPORT AS FOUND IN OUTPUT ARRAYS 'RDATA' AND 'IDATA' IF(IPRINT.LT.0) PRINT 8890, (IDATA(K),K=35,36) 8890 FORMAT(1X,'>> PRINTOUT OF OUTPUT RDATA/IDATA ARRAY:'//1X,'NO. ', $ 'CAT. 10 LVLS=',I1,'; CAT. 10 DATA SUBSCRIPT=',I2/) C1 = 'N' C2 = 'E' ALAT = RDATA(1) IF(RDATA(1).LT.0.0) THEN ALAT = -ALAT C1 = 'S' END IF ALON = RDATA(2) IF(RDATA(2).GT.180.00) THEN ALON = 360.00 - ALON C2 = 'W' END IF IHGHT = 999999 IF(RDATA(7).LT.XMISS) IHGHT = NINT(RDATA(7)) WSPD = XMISS IF(RDATA(IDATA(36)+3).LT.XMISS) WSPD = RDATA(IDATA(36)+3)*0.1 PRINT 9890, STNID,RDATA(4),ALAT,C1,ALON,C2,IHGHT,IDATA(6), $ IDATA(9),NINT(RDATA(IDATA(36)+2)),WSPD 9890 FORMAT(1X,A8,2X,F8.5,'Z',4X,F5.2,A1,4X,F6.2,A1,4X,'ELEV ',I5, $ 'M',4X,'SATID',I4,4X,'RPT TYPE ',I3.3,4X,'WDIR ',I3,4X,'WSPD ', $ F5.1,'M/S') C GO UP AND UNPACK THE NEXT REPORT GO TO 2090 7003 CONTINUE C----------------------------------------------------------------------- C ALL REPORTS HAVE BEEN UNPACKED -- ALL DONE PRINT 9004, IUNIT,KNTRPT 9004 FORMAT(//45X,'--> ALL REPORTS IN FILE',I3,' PROCESSED <--'//47X, $ '*** ',I6,' REPORTS LISTED HERE ***'/) PRINT 9006 9006 FORMAT(/38X,'>>> SUCCESSFUL COMPLETION OF PROGRAM ', $ 'BUFR_LISTDUMPS <<<'/) RETURN C----------------------------------------------------------------------- END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: LISTQKSWND C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2017-10-13 C C ABSTRACT: LISTS CONTENTS OF A TIME-WINDOWED REPROCESSED QUIKSCAT C OR ASCAT SCATTEROMETER BUFR DATA DUMP FILE. THE STANDARD OUTPUT IS C IN AN EASY-TO-READ FORMAT. NOTE: THIS SUBROUTINE CAN HANDLE THE C FOLLOWING BUFR DATA DUMP FILE TYPES: QKSWND, ASCATW. C C PROGRAM HISTORY LOG: C 2000-09-22 D.A. KEYSER -- ORIGINAL AUTHOR C 2001-04-06 D.A. KEYSER -- ACCOUNTS FOR CHANGE IN W3UNPKB7 WHICH C RETURNS SATELLITE ID IN HEADER WORD 6, INCLUDES SATELLITE ID IN C LISTING C 2001-08-20 D.A. KEYSER -- ACCOUNTS FOR CHANGE IN W3UNPKB7 WHICH C RETURNS NUMBER OF ORIGINAL REPORTS USED TO GENERATE SUPEROB C (ACAV) IN HEADER WORD 10, INCLUDES THIS IN LISTING C 2002-03-05 D.A. KEYSER -- SUBR. W3UNPKB7 ARGUMENT RDATA MUST BE C DIMENSIONED AT LEAST 1200 NOW TO ACCOUNT FOR 64 POSSIBLE WIND C PROFILER LEVELS FROM NOAA/FSL, RDATA INCREASED FROM 800 TO 1200 C IN THIS PROGRAM C 2004-02-02 KEYSER -- ARRAY SUBSKP BUMPED UP FROM (0:12,200) TO C (0:255,0:200) AND NOW IT CAN ALSO BE READ IN FOR NON-UPA AND C NON-SFC TYPES IN NAMELIST PDATA C 2008-09-25 KEYSER -- HANDLES "REPROCESSED" ASCAT WINDS IN "ascatw" C DUMP FILE C 2016-11-30 D. A. KEYSER -- Reads new output real, double-precision C argument array RDATA8_8 of length 2 in call to W3UNPKB7. This C returns latitude and longitude for each report which is then C stored in R*8 variables ALAT_8 and ALON_8 prior to listing for C dump type ASCATW (also here format changed to list 5 significant C digits instead of 2). C BENEFIT: Replaces lat/lon returned in RDATA(1:2) in call to C W3UNPKB7 for this type, which is just at machine precison C (normally R*4). Since reports in these dumps can store C lat/lon at 0.00001 degree precision, this change will C ensure that lat/lon is always accurate to 0.00001 degrees C in these listings. C 2017-10-13 D. A. KEYSER -- Added minutes to every print statement C that includes the central dump time. Central dump time minutes is C obtained from Section 1 of first (dummy) message of input dump C file via call to BUFRLIB routine IUPVS01. C BENEFIT: Until now, central dump time minutes was always zero. C However, with the implementation of the new RTMA_RU, C central dump time can now also have minutes = 15, 30 C or 45 (since the RTMA_RU runs 4 times per hour). This C change allows the print statements to reflect this new C center dump time format. C C USAGE: CALL LISTQKSWND(ITYPE) C INPUT ARGUMENT LIST: C ITYPE - TYPE OF SCATTEROMETER DATA BEING PROCESSED (=1 - C QUIKSCAT, =2 - ASCAT) C C INPUT FILES: C UNIT 05 - INPUT DATA CARDS IN THE FORM OF A NAMELIST (SEE C - REMARKS IN MAIN PROGRAM DOCBLOCK) C UNIT 21 - BUFR DATA SET C C OUTPUT FILES: C UNIT 06 - STANDARD OUTPUT PRINT C C REMARKS: NONE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ SUBROUTINE LISTQKSWND(ITYPE) LOGICAL SNDG,RETR,RADN,SUBSKP(0:255,0:200) INTEGER NWINDO(2),IDATE(4),MDATE(4),IDATA(2500),IBIT(31) INTEGER(8) IDSDMP_8 REAL RDATA(2500),RDATA2(25) REAL(8) WVCQ_8,BMISS,rdata8_8(2),alat_8,alon_8 CHARACTER*1 C1,C2,c1_8,c2_8 CHARACTER*8 STNID,DSNAME,SUBSET,CTYPE(2) COMMON/BUFRLIB_MISSING/BMISS EQUIVALENCE (RDATA,IDATA) DATA XMISS/99999./ DATA CTYPE/'QUIKSCAT',' ASCAT '/ NAMELIST/PDATA/IDAT10,IWINDE,IWINDL,IPRINT,SNDG,RETR,RADN,SUBSKP SUBSKP = .FALSE. READ(5,PDATA) IDATE(1) = IDAT10/1000000 IDATE(2) = MOD((IDAT10/10000),100) IDATE(3) = MOD((IDAT10/100),100) IDATE(4) = MOD(IDAT10,100) IUNIT = 21 NWINDO(1) = IWINDE NWINDO(2) = IWINDL KNTRPT = 0 2090 CONTINUE C CALL W3UNPKB7 TO UNPACK THE NEXT QUIKSCAT OR ASCAT SCATTEROMETER WIND C REPORT IRET = IPRINT CALL W3UNPKB7(IDATE,NWINDO(1),NWINDO(2),IUNIT,RDATA,STNID,DSNAME, $ RDATA2,rdata8_8,IDSDAT,IDSDMP_8,SUBSET,SUBSKP,IRET) C----------------------------------------------------------------------- IF(IRET.EQ.1) THEN C IRET = 1 RETURNS DATA SET INFO (ONLY) AFTER FIRST CALL IF(IPRINT.LT.0) PRINT'(" RETURN CODE =",I0,"; DATA SET ", $ "INFORMATION RETURNED")', IRET PRINT 102, DSNAME,IUNIT 102 FORMAT(//46X,'***** ',A8,' -- UNIT =',I3,' *****') C SPLIT DATE INTO COMPONENTS (MDATE) MDATE(1) = IDSDAT/1000000 MDATE(2) = MOD((IDSDAT/10000),100) MDATE(3) = MOD((IDSDAT/100),100) MDATE(4) = MOD(IDSDAT,100) c----------------------------------------------------------------------- c Read 1st dummy message in file so can then call iupvs01 to get iminu call readmg(iunit,subset,ibdate,kret) iminu = iupvs01(iunit,'MINU') c Close file and reopen so W3UNPKB7 will handle things as though this c block of code never exited call closbf(iunit) call openbf(iunit,'IN',iunit) c----------------------------------------------------------------------- PRINT 1101, DSNAME,MDATE,iminu,IDSDMP_8 1101 FORMAT(20X,'DATASET NAME: ',A8,' -- DATE: ',I4.4,2('-',I2.2), $ 1X,I2.2,i2.2,'Z -- DUMP DATE (I12 FORMAT): ',I12.12/) C DOES DATE FROM DATA SET MATCH EXPECTED CENTER DATE? IF(IDSDAT.NE.IDAT10) THEN PRINT 324 324 FORMAT(/13X,'>>>>> P R O B L E M : B U F R F I L E ', $ 'D A T E D O E S N O T M A T C H E X P E C T E D ', $ 'D A T E <<<<<'/) GO TO 7003 END IF IFIND = 0 DO I = 0,255 DO J = 0,200 IF(SUBSKP(I,J)) THEN IF(IFIND.EQ.0) PRINT 7001 7001 FORMAT(34X,'-- THE FOLLOWING BUFR MESSAGE TYPES/SUBTYPES WILL ', $ 'BE SKIPPED:') PRINT 7002, I,J 7002 FORMAT(45X,'BUFR TYPE ',I3.3,', SUBTYPE ',I3.3) IFIND = 1 END IF ENDDO ENDDO IF(IFIND.EQ.0) PRINT 8003 8003 FORMAT(10X,'-- ALL BUFR MESSAGE TYPES/SUBTYPES IN DATA DUMP FILE', $ ' WILL BE PROCESSED') PRINT 7004 7004 FORMAT(//) GO TO 2090 C---------------------------------------------------------------------- ELSE IF(IRET.GT.2) THEN C PROBLEM READING QUIKSCAT OR ASCAT SCATTEROMETER WIND REPORT, GO ON TO C NEXT RPT PRINT 912, CTYPE(ITYPE) 912 FORMAT(' * * ERROR READING ',A,' SCATTEROMETER WIND REPORT, ', $ 'TRY NEXT ONE') GO TO 2090 C---------------------------------------------------------------------- ELSE IF(IRET.EQ.2) THEN C ALL DONE GO TO 7003 END IF C---------------------------------------------------------------------- KNTRPT = KNTRPT + 1 C PRINT OUT REPORT AS FOUND IN OUTPUT ARRAYS 'RDATA' AND 'IDATA' IF(IPRINT.LT.0) PRINT 8890, (IDATA(K),K=35,36) 8890 FORMAT(1X,'>> PRINTOUT OF OUTPUT RDATA/IDATA ARRAY:'//1X,'NO. ', $ 'CAT. 10 LVLS=',I1,'; CAT. 10 DATA SUBSCRIPT=',I2/) C1 = 'N' C2 = 'E' c1_8 = 'N' c2_8 = 'E' ALAT = RDATA(1) IF(RDATA(1).LT.0.0) THEN ALAT = -ALAT C1 = 'S' END IF ALON = RDATA(2) IF(RDATA(2).GT.180.00) THEN ALON = 360.00 - ALON C2 = 'W' END IF alat_8 = rdata8_8(1) if(rdata8_8(1).lt.0.) then alat_8 = -alat_8 c1_8 = 'S' end if alon_8 = rdata8_8(2) if(rdata8_8(2).lt.0.) then alon_8 = -alon_8 c2_8 = 'W' end if IHGHT = 999999 IF(RDATA(7).LT.XMISS) IHGHT = NINT(RDATA(7)) WSPD = XMISS SPRR = XMISS IF(RDATA(IDATA(36)+3).LT.XMISS) WSPD = RDATA(IDATA(36)+3)*0.1 IF(RDATA2(8).LT.BMISS) SPRR = RDATA2(8) * 100.0 IF(ITYPE.EQ.1) THEN PRINT 9890, STNID,RDATA(4),ALAT,C1,ALON,C2,IHGHT,IDATA(6), $ IDATA(9),NINT(RDATA(IDATA(36)+2)),WSPD,NINT(RDATA2(3)), $ NINT(RDATA2(4)),SPRR,NINT(RDATA2(2)) 9890 FORMAT(A8,1X,F8.5,'Z',3X,F5.2,A1,2X,F6.2,A1,3X,'ELV',I3,'M', $ 3X,'SAID',I4,3X,'RT ',I3.3,3X,'DIR ',I3,2X,'SPD',F5.1, $ 'M/S',3X,'CELL',I3,2X,'ROW',I4,3X,'SPRR',F6.1,'%',3X,'ACAV',I3) ELSE PRINT 9891, STNID,RDATA(4),alat_8,c1_8,alon_8,c2_8,IHGHT, $ IDATA(6),IDATA(9),NINT(RDATA(IDATA(36)+2)),WSPD, $ NINT(RDATA2(3)),NINT(RDATA2(2)),RDATA2(23),RDATA2(24) 9891 FORMAT(A8,1X,F8.5,'Z',3X,F8.5,A1,2X,F9.5,A1,3X,'ELV',I3,'M', $ 3X,'SAID',I4,3X,'RT ',I3.3,3X,'DIR ',I3,2X,'SPD',F5.1, $ 'M/S',3X,'CELL',I3,3X,'ACAV',I3,3X,'BSCD ',F6.1,3X,'LKCS ',F7.3) IF(RDATA2(22).LT.BMISS ) THEN WVCQ_8 = RDATA2(22) CALL UPFTBV(21,'WVCQ',WVCQ_8,31,IBIT,NIB) IF(NIB.GT.0) THEN PRINT 1245, NINT(RDATA2(22)),(IBIT(II)-1,II=1,NIB) 1245 FORMAT(5X,'WVCQ ',I8,' (',I3,')') ELSE PRINT 9892, NINT(RDATA2(22)) 9892 FORMAT(5X,'WVCQ ',I8) END IF END IF END IF C GO UP AND UNPACK THE NEXT REPORT GO TO 2090 7003 CONTINUE C----------------------------------------------------------------------- C ALL REPORTS HAVE BEEN UNPACKED -- ALL DONE PRINT 9004, IUNIT,KNTRPT 9004 FORMAT(//45X,'--> ALL REPORTS IN FILE',I3,' PROCESSED <--'//47X, $ '*** ',I6,' REPORTS LISTED HERE ***'/) PRINT 9006 9006 FORMAT(/38X,'>>> SUCCESSFUL COMPLETION OF PROGRAM ', $ 'BUFR_LISTDUMPS <<<'/) RETURN C----------------------------------------------------------------------- END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: LISTGPSIPW C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2017-10-13 C C ABSTRACT: LISTS CONTENTS OF A TIME-WINDOWED GPS INTEGRATED C PRECIPITABLE BUFR DATA DUMP FILE. THE STANDARD OUTPUT IS IN C AN EASY-TO-READ FORMAT. NOTE: THIS SUBROUTINE CAN C HANDLE THE FOLLOWING BUFR DATA DUMP FILE TYPE: GPSIPW. C C PROGRAM HISTORY LOG: C 2002-07-05 D.A. KEYSER -- ORIGINAL AUTHOR C 2004-02-02 KEYSER -- ARRAY SUBSKP BUMPED UP FROM (0:12,200) TO C (0:255,0:200) AND NOW IT CAN ALSO BE READ IN FOR NON-UPA AND C NON-SFC TYPES IN NAMELIST PDATA C 2016-08-28 D. A. Keyser -- Now lists lat and lon to nearest 0.00001 C degree rather than to nearest 0.01 degree. New WMO format GNSS C ground-based data (in dump file "gpsipw" under subset 'NC012004) C stores CLATH/CLONH rather than CLAT/CLON as with previous C production non-standard BUFR format GPS ground-based data from GSD C (had been in dump file "gpsipw" under subset 'NC012003). C 2016-11-30 D. A. KEYSER -- Reads new output real, double-precision C argument array RDATA8_8 of length 2 in call to W3UNPKB7. This C returns latitude and longitude for each report which is then C stored in R*8 variables ALAT_8 and ALON_8 prior to listing for C dump type GPSIPW (already lists to 5 significant digits). C BENEFIT: Replaces lat/lon returned in RDATA(1:2) in call to C W3UNPKB7 for this type, which is just at machine precison C (normally R*4). Since reports in these dumps can store C lat/lon at 0.00001 degree precision, this change will C ensure that lat/lon is always accurate to 0.00001 degrees C in these listings. C 2017-10-13 D. A. KEYSER -- Added minutes to every print statement C that includes the central dump time. Central dump time minutes is C obtained from Section 1 of first (dummy) message of input dump C file via call to BUFRLIB routine IUPVS01. C BENEFIT: Until now, central dump time minutes was always zero. C However, with the implementation of the new RTMA_RU, C central dump time can now also have minutes = 15, 30 C or 45 (since the RTMA_RU runs 4 times per hour). This C change allows the print statements to reflect this new C center dump time format. C C USAGE: CALL LISTGPSIPW C C INPUT FILES: C UNIT 05 - INPUT DATA CARDS IN THE FORM OF A NAMELIST (SEE C - REMARKS IN MAIN PROGRAM DOCBLOCK) C UNIT 21 - BUFR DATA SET C C OUTPUT FILES: C UNIT 06 - STANDARD OUTPUT PRINT C C REMARKS: NONE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ SUBROUTINE LISTGPSIPW LOGICAL SNDG,RETR,RADN,SUBSKP(0:255,0:200) INTEGER NWINDO(2),IDATE(4),MDATE(4),IDATA(2500) INTEGER(8) IDSDMP_8 REAL RDATA(2500),RDATA2(25) real(8) rdata8_8(2),alat_8,alon_8 CHARACTER*1 C1,C2,c1_8,c2_8 CHARACTER*8 STNID,DSNAME,SUBSET EQUIVALENCE (RDATA,IDATA) DATA XMISS/99999./ NAMELIST/PDATA/IDAT10,IWINDE,IWINDL,IPRINT,SNDG,RETR,RADN,SUBSKP SUBSKP = .FALSE. READ(5,PDATA) IDATE(1) = IDAT10/1000000 IDATE(2) = MOD((IDAT10/10000),100) IDATE(3) = MOD((IDAT10/100),100) IDATE(4) = MOD(IDAT10,100) IUNIT = 21 NWINDO(1) = IWINDE NWINDO(2) = IWINDL KNTRPT = 0 2090 CONTINUE C CALL W3UNPKB7 TO UNPACK THE NEXT GPS-IPW REPORT IRET = IPRINT CALL W3UNPKB7(IDATE,NWINDO(1),NWINDO(2),IUNIT,RDATA,STNID,DSNAME, $ RDATA2,rdata8_8,IDSDAT,IDSDMP_8,SUBSET,SUBSKP,IRET) C----------------------------------------------------------------------- IF(IRET.EQ.1) THEN C IRET = 1 RETURNS DATA SET INFO (ONLY) AFTER FIRST CALL IF(IPRINT.LT.0) PRINT'(" RETURN CODE =",I0,"; DATA SET ", $ "INFORMATION RETURNED")', IRET PRINT 102, DSNAME,IUNIT 102 FORMAT(//46X,'***** ',A8,' -- UNIT =',I3,' *****') C SPLIT DATE INTO COMPONENTS (MDATE) MDATE(1) = IDSDAT/1000000 MDATE(2) = MOD((IDSDAT/10000),100) MDATE(3) = MOD((IDSDAT/100),100) MDATE(4) = MOD(IDSDAT,100) c----------------------------------------------------------------------- c Read 1st dummy message in file so can then call iupvs01 to get iminu call readmg(iunit,subset,ibdate,kret) iminu = iupvs01(iunit,'MINU') c Close file and reopen so W3UNPKB7 will handle things as though this c block of code never exited call closbf(iunit) call openbf(iunit,'IN',iunit) c----------------------------------------------------------------------- PRINT 1101, DSNAME,MDATE,iminu,IDSDMP_8 1101 FORMAT(20X,'DATASET NAME: ',A8,' -- DATE: ',I4.4,2('-',I2.2), $ 1X,I2.2,i2.2,'Z -- DUMP DATE (I12 FORMAT): ',I12.12/) C DOES DATE FROM DATA SET MATCH EXPECTED CENTER DATE? IF(IDSDAT.NE.IDAT10) THEN PRINT 324 324 FORMAT(/13X,'>>>>> P R O B L E M : B U F R F I L E ', $ 'D A T E D O E S N O T M A T C H E X P E C T E D ', $ 'D A T E <<<<<'/) GO TO 7003 END IF IFIND = 0 DO I = 0,255 DO J = 0,200 IF(SUBSKP(I,J)) THEN IF(IFIND.EQ.0) PRINT 7001 7001 FORMAT(34X,'-- THE FOLLOWING BUFR MESSAGE TYPES/SUBTYPES WILL ', $ 'BE SKIPPED:') PRINT 7002, I,J 7002 FORMAT(45X,'BUFR TYPE ',I3.3,', SUBTYPE ',I3.3) IFIND = 1 END IF ENDDO ENDDO IF(IFIND.EQ.0) PRINT 8003 8003 FORMAT(10X,'-- ALL BUFR MESSAGE TYPES/SUBTYPES IN DATA DUMP FILE', $ ' WILL BE PROCESSED') PRINT 7004 7004 FORMAT(//) GO TO 2090 C---------------------------------------------------------------------- ELSE IF(IRET.GT.2) THEN C PROBLEM READING GPS-IPW REPORT, GO ON TO NEXT REPORT PRINT 912 912 FORMAT(' * * ERROR READING GPS-IPW REPORT, TRY NEXT ONE') GO TO 2090 C---------------------------------------------------------------------- ELSE IF(IRET.EQ.2) THEN C ALL DONE GO TO 7003 END IF C---------------------------------------------------------------------- KNTRPT = KNTRPT + 1 C PRINT OUT REPORT AS FOUND IN OUTPUT ARRAYS 'RDATA' AND 'IDATA' IF(IPRINT.LT.0) PRINT 8890, (IDATA(K),K=43,44) 8890 FORMAT(1X,'>> PRINTOUT OF OUTPUT RDATA/IDATA ARRAY:'//1X,'NO. ', $ 'CAT. 14 LVLS=',I1,'; CAT. 14 DATA SUBSCRIPT=',I2/) C1 = 'N' C2 = 'E' c1_8 = 'N' c2_8 = 'E' ALAT = RDATA(1) IF(RDATA(1).LT.0.0) THEN ALAT = -ALAT C1 = 'S' END IF ALON = RDATA(2) IF(RDATA(2).GT.180.00) THEN ALON = 360.00 - ALON C2 = 'W' END IF alat_8 = rdata8_8(1) if(rdata8_8(1).lt.0.) then alat_8 = -alat_8 c1_8 = 'S' end if alon_8 = rdata8_8(2) if(rdata8_8(2).lt.0.) then alon_8 = -alon_8 c2_8 = 'W' end if IHGHT = 999999 IF(RDATA(7).LT.XMISS) IHGHT = NINT(RDATA(7)) ITDEL = 999999 IF(RDATA(IDATA(44)+4).LT.XMISS) ITDEL = $ NINT(RDATA(IDATA(44)+4) * 100.) IF(RDATA(IDATA(44)+5).LT.XMISS) RDATA(IDATA(44)+5) = $ RDATA(IDATA(44)+5) * 1000. IHSDL = 999999 IF(RDATA(IDATA(44)+6).LT.XMISS) IHSDL = $ NINT(RDATA(IDATA(44)+6) * 100.) IF(RDATA(IDATA(44)+7).LT.XMISS) RDATA(IDATA(44)+7) = $ RDATA(IDATA(44)+7) * 1000. PRINT 9890, STNID,RDATA(4),alat_8,c1_8,alon_8,c2_8,IHGHT, $ IDATA(9),RDATA(11),(RDATA(IDATA(44)+II),II=0,1), $ NINT(RDATA(IDATA(44)+2)),RDATA(IDATA(44)+3),ITDEL, $ RDATA(IDATA(44)+5),IHSDL,(RDATA(IDATA(44)+II),II=7,9) 9890 FORMAT(A8,2X,F8.5,'Z',3X,F8.5,A1,2X,F9.5,A1,3X,'ELV ',I4,'M', $ 3X,'RTP ',I3.3,3X,'RCPT ',F6.2,'Z'/' PSTN ',F6.1,'MB', $ 3X,'TEMP ',F5.1,'K',3X,'RELH ',I3,'%',3X,'TPW',F5.1,'MM',3X, $ 'ZTD ',I4,'CM',2X,'eZTD ',F4.1,'MM',3X,'HSDL',I3,'CM',2X, $ 'EHSD',F4.1,'MM',3X,'WMTM ',F6.2,'K',3X,'WDMF',F5.2/) C GO UP AND UNPACK THE NEXT REPORT GO TO 2090 7003 CONTINUE C----------------------------------------------------------------------- C ALL REPORTS HAVE BEEN UNPACKED -- ALL DONE PRINT 9004, IUNIT,KNTRPT 9004 FORMAT(//45X,'--> ALL REPORTS IN FILE',I3,' PROCESSED <--'//47X, $ '*** ',I6,' REPORTS LISTED HERE ***'/) PRINT 9006 9006 FORMAT(/38X,'>>> SUCCESSFUL COMPLETION OF PROGRAM ', $ 'BUFR_LISTDUMPS <<<'/) RETURN C----------------------------------------------------------------------- END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: LISTRASS C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2017-10-13 C C ABSTRACT: LISTS CONTENTS OF A TIME-WINDOWED RASS BUFR DATA DUMP C FILE. THE STANDARD OUTPUT IS IN AN EASY-TO-READ FORMAT. NOTE: C THIS SUBROUTINE CAN HANDLE THE FOLLOWING BUFR DATA DUMP FILE C TYPE: RASSDA. C C PROGRAM HISTORY LOG: C 2004-02-02 D.A. KEYSER -- ORIGINAL AUTHOR C 2016-11-30 D. A. KEYSER -- Reads new output real, double-precision C argument array RDATA8_8 of length 2 in call to W3UNPKB7. This C new array, which returns latitude and longitude for each report, C is currently not referenced by this subroutine. C 2017-10-13 D. A. KEYSER -- Added minutes to every print statement C that includes the central dump time. Central dump time minutes is C obtained from Section 1 of first (dummy) message of input dump C file via call to BUFRLIB routine IUPVS01. C BENEFIT: Until now, central dump time minutes was always zero. C However, with the implementation of the new RTMA_RU, C central dump time can now also have minutes = 15, 30 C or 45 (since the RTMA_RU runs 4 times per hour). This C change allows the print statements to reflect this new C center dump time format. C C USAGE: CALL LISTRASS C C INPUT FILES: C UNIT 05 - INPUT DATA CARDS IN THE FORM OF A NAMELIST (SEE C - REMARKS IN MAIN PROGRAM DOCBLOCK) C UNIT 21 - BUFR DATA SET C C OUTPUT FILES: C UNIT 06 - STANDARD OUTPUT PRINT C C REMARKS: NONE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ SUBROUTINE LISTRASS LOGICAL SNDG,RETR,RADN,SUBSKP(0:255,0:200) INTEGER NWINDO(2),IDATE(4),MDATE(4),IDATA(2500) INTEGER(8) IDSDMP_8 REAL RDATA(2500),RDATA2(25) real(8) rdata8_8(2) CHARACTER*1 C1,C2 CHARACTER*8 STNID,DSNAME,SUBSET EQUIVALENCE (RDATA,IDATA) DATA XMISS/99999./ NAMELIST/PDATA/IDAT10,IWINDE,IWINDL,IPRINT,SNDG,RETR,RADN,SUBSKP SUBSKP = .FALSE. READ(5,PDATA) IDATE(1) = IDAT10/1000000 IDATE(2) = MOD((IDAT10/10000),100) IDATE(3) = MOD((IDAT10/100),100) IDATE(4) = MOD(IDAT10,100) IUNIT = 21 NWINDO(1) = IWINDE NWINDO(2) = IWINDL KNTRPT = 0 2090 CONTINUE C CALL W3UNPKB7 TO UNPACK THE NEXT RASS REPORT IRET = IPRINT PRINT'(1X)' CALL W3UNPKB7(IDATE,NWINDO(1),NWINDO(2),IUNIT,RDATA,STNID,DSNAME, $ RDATA2,rdata8_8,IDSDAT,IDSDMP_8,SUBSET,SUBSKP,IRET) C----------------------------------------------------------------------- IF(IRET.EQ.1) THEN C IRET = 1 RETURNS DATA SET INFO (ONLY) AFTER FIRST CALL IF(IPRINT.LT.0) PRINT'(" RETURN CODE =",I0,"; DATA SET ", $ "INFORMATION RETURNED")', IRET PRINT 102, DSNAME,IUNIT 102 FORMAT(//46X,'***** ',A8,' -- UNIT =',I3,' *****') C SPLIT DATE INTO COMPONENTS (MDATE) MDATE(1) = IDSDAT/1000000 MDATE(2) = MOD((IDSDAT/10000),100) MDATE(3) = MOD((IDSDAT/100),100) MDATE(4) = MOD(IDSDAT,100) c----------------------------------------------------------------------- c Read 1st dummy message in file so can then call iupvs01 to get iminu call readmg(iunit,subset,ibdate,kret) iminu = iupvs01(iunit,'MINU') c Close file and reopen so W3UNPKB7 will handle things as though this c block of code never exited call closbf(iunit) call openbf(iunit,'IN',iunit) c----------------------------------------------------------------------- PRINT 1101, DSNAME,MDATE,iminu,IDSDMP_8 1101 FORMAT(20X,'DATASET NAME: ',A8,' -- DATE: ',I4.4,2('-',I2.2), $ 1X,I2.2,i2.2,'Z -- DUMP DATE (I12 FORMAT): ',I12.12/) C DOES DATE FROM DATA SET MATCH EXPECTED CENTER DATE? IF(IDSDAT.NE.IDAT10) THEN PRINT 324 324 FORMAT(/13X,'>>>>> P R O B L E M : B U F R F I L E ', $ 'D A T E D O E S N O T M A T C H E X P E C T E D ', $ 'D A T E <<<<<'/) GO TO 7003 END IF IFIND = 0 DO I = 0,255 DO J = 0,200 IF(SUBSKP(I,J)) THEN IF(IFIND.EQ.0) PRINT 7001 7001 FORMAT(34X,'-- THE FOLLOWING BUFR MESSAGE TYPES/SUBTYPES WILL ', $ 'BE SKIPPED:') PRINT 7002, I,J 7002 FORMAT(45X,'BUFR TYPE ',I3.3,', SUBTYPE ',I3.3) IFIND = 1 END IF ENDDO ENDDO IF(IFIND.EQ.0) PRINT 8003 8003 FORMAT(10X,'-- ALL BUFR MESSAGE TYPES/SUBTYPES IN DATA DUMP FILE', $ ' WILL BE PROCESSED') PRINT 7004 7004 FORMAT(//) GO TO 2090 C---------------------------------------------------------------------- ELSE IF(IRET.GT.2) THEN C PROBLEM READING RASS REPORT, GO ON TO NEXT REPORT PRINT 912 912 FORMAT(' * * ERROR READING RASS REPORT, TRY NEXT ONE') GO TO 2090 C---------------------------------------------------------------------- C ALL DONE ELSE IF(IRET.EQ.2) THEN GO TO 7003 END IF C---------------------------------------------------------------------- KNTRPT = KNTRPT + 1 C PRINT OUT REPORT AS FOUND IN OUTPUT ARRAY 'IDATA' IF(IPRINT.LT.0) PRINT 8890,(IDATA(K),K=45,46) 8890 FORMAT(//1X,'>> PRINTOUT OF OUTPUT IDATA ARRAY:'//' NO. CAT. 15', $ ' LVLS=',I3,'; CAT. 15 DATA SUBSCRIPT=',I3/) C1 = 'N' C2 = 'E' ALAT = RDATA(1) IF(RDATA(1).LT.0.0) THEN ALAT = -ALAT C1 = 'S' END IF ALON = RDATA(2) IF(RDATA(2).GT.180.00) THEN ALON = 360.00 - ALON C2 = 'W' END IF PRINT 9890, STNID,RDATA(4),ALAT,C1,ALON,C2,NINT(RDATA(7)), $ IDATA(9),NINT(RDATA2(1)),NINT(RDATA2(6)),IDATA(5) 9890 FORMAT(1X,A8,4X,F8.5,'Z',4X,F5.2,A1,4X,F6.2,A1,4X,'ELEV ',I5, $ 'M',4X,'RPT TYPE ',I3.3,4X,'TSIG ',I2,4X,'TAVG ',I4,'MIN',4X, $ 'DATE ',I10.10) IF(IDATA(45).GT.0) THEN J = IDATA(46) - 3 PRINT 8892 8892 FORMAT('UPPER AIR: LVL HGT(M) VTMP(K) Q.CODE ') DO I = 1,IDATA(45) J = J + 3 IHGHT = 999999 IF(RDATA(J).LT.XMISS) IHGHT = NINT(RDATA(J)) VTMP = XMISS IF(RDATA(J+2).LT.XMISS) VTMP = RDATA(J+1) PRINT 8893, I,IHGHT,VTMP,IDATA(J+2) 8893 FORMAT(12X,I2,4X,I5,6X,F6.2,7X,I3) ENDDO END IF C GO UP AND UNPACK THE NEXT REPORT GO TO 2090 7003 CONTINUE C----------------------------------------------------------------------- C ALL REPORTS HAVE BEEN UNPACKED -- ALL DONE PRINT 9004, IUNIT,KNTRPT 9004 FORMAT(//45X,'--> ALL REPORTS IN FILE',I3,' PROCESSED <--'//47X, $ '*** ',I6,' REPORTS LISTED HERE ***'/) PRINT 9006 9006 FORMAT(/38X,'>>> SUCCESSFUL COMPLETION OF PROGRAM ', $ 'BUFR_LISTDUMPS <<<'/) RETURN C----------------------------------------------------------------------- END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: INDEXC GENERAL SORT ROUTINE FOR CHARACTER ARRAY C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2000-06-07 C C ABSTRACT: USES EFFICIENT SORT ALGORITHM TO PRODUCE INDEX SORT LIST C FOR A 8-CHARACTER ARRAY. DOES NOT REARRANGE THE FILE. C C PROGRAM HISTORY LOG: C 1993-06-05 R KISTLER --- FORTRAN VERSION OF C-PROGRAM C 1993-07-15 P. JULIAN ---- MODIFIED TO SORT 12-CHARACTER ARRAY C 1994-08-25 D. A. KEYSER - MODIFIED TO SORT 8-CHARACTER ARRAY C 1995-05-30 D. A. KEYSER - TESTS FOR < 2 ELEMENTS IN SORT LIST, C IF SO RETURNS WITHOUT SORTING (BUT FILLS INDX ARRAY) C 2000-06-07 D. A. KEYSER - CONVERTED TO IBM-SP C C USAGE: CALL INDEXC(N,CARRIN,INDX) C INPUT ARGUMENT LIST: C N - SIZE OF ARRAY TO BE SORTED C CARRIN - 8-CHARACTER ARRAY TO BE SORTED C C OUTPUT ARGUMENT LIST: C INDX - ARRAY OF POINTERS GIVING SORT ORDER OF CARRIN IN C - ASCENDING ORDER {E.G., CARRIN(INDX(I)) IS SORTED IN C - ASCENDING ORDER FOR ORIGINAL I = 1, ... ,N} C C REMARKS: NONE C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ SUBROUTINE INDEXC(N,CARRIN,INDX) CHARACTER*8 CARRIN(N),CC INTEGER INDX(N) DO J = 1,N INDX(J) = J ENDDO C MUST BE > 1 ELEMENT IN SORT LIST, ELSE RETURN IF(N.LE.1) RETURN L = N/2 + 1 IR = N 33 CONTINUE IF(L.GT.1) THEN L = L - 1 INDXT = INDX(L) CC = CARRIN(INDXT) ELSE INDXT = INDX(IR) CC = CARRIN(INDXT) INDX(IR) = INDX(1) IR = IR - 1 IF(IR.EQ.1) THEN INDX(1) = INDXT RETURN END IF END IF I = L J = L * 2 30 CONTINUE IF(J.LE.IR) THEN IF(J.LT.IR) THEN IF(CARRIN(INDX(J)).LT.CARRIN(INDX(J+1))) J = J + 1 END IF IF(CC.LT.CARRIN(INDX(J))) THEN INDX(I) = INDX(J) I = J J = J + I ELSE J = IR + 1 ENDIF END IF IF(J.LE.IR) GO TO 30 INDX(I) = INDXT GO TO 33 END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: LISTWNDSAT C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2017-10-13 C C ABSTRACT: LISTS CONTENTS OF A TIME-WINDOWED REPROCESSED WINDSAT C SCATTEROMETER BUFR DATA DUMP FILE. THE STANDARD OUTPUT IS IN C AN EASY-TO-READ FORMAT. NOTE: THIS SUBROUTINE CAN C HANDLE THE FOLLOWING BUFR DATA DUMP FILE TYPE: WDSATR. C C PROGRAM HISTORY LOG: C 2006-07-14 D.A. KEYSER -- ORIGINAL AUTHOR C 2016-11-30 D. A. KEYSER -- Reads new output real, double-precision C argument array RDATA8_8 of length 2 in call to W3UNPKB7. This C new array, which returns latitude and longitude for each report, C is currently not referenced by this subroutine. C 2017-10-13 D. A. KEYSER -- Added minutes to every print statement C that includes the central dump time. Central dump time minutes is C obtained from Section 1 of first (dummy) message of input dump C file via call to BUFRLIB routine IUPVS01. C BENEFIT: Until now, central dump time minutes was always zero. C However, with the implementation of the new RTMA_RU, C central dump time can now also have minutes = 15, 30 C or 45 (since the RTMA_RU runs 4 times per hour). This C change allows the print statements to reflect this new C center dump time format. C C USAGE: CALL LISTWNDSAT C C INPUT FILES: C UNIT 05 - INPUT DATA CARDS IN THE FORM OF A NAMELIST (SEE C - REMARKS IN MAIN PROGRAM DOCBLOCK) C UNIT 21 - BUFR DATA SET C C OUTPUT FILES: C UNIT 06 - STANDARD OUTPUT PRINT C C REMARKS: NONE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ SUBROUTINE LISTWNDSAT LOGICAL SNDG,RETR,RADN,SUBSKP(0:255,0:200),short INTEGER NWINDO(2),IDATE(4),MDATE(4),IDATA(2500) INTEGER(8) IDSDMP_8 REAL RDATA(2500),RDATA2(25) real(8) rdata8_8(2) CHARACTER*1 C1,C2 CHARACTER*8 STNID,DSNAME,SUBSET EQUIVALENCE (RDATA,IDATA) DATA XMISS/99999./ NAMELIST/PDATA/IDAT10,IWINDE,IWINDL,IPRINT,SNDG,RETR,RADN,SUBSKP SUBSKP = .FALSE. READ(5,PDATA) IDATE(1) = IDAT10/1000000 IDATE(2) = MOD((IDAT10/10000),100) IDATE(3) = MOD((IDAT10/100),100) IDATE(4) = MOD(IDAT10,100) IUNIT = 21 NWINDO(1) = IWINDE NWINDO(2) = IWINDL KNTRPT = 0 2090 CONTINUE C CALL W3UNPKB7 TO UNPACK THE NEXT WINDSAT SCATTEROMETER WIND REPORT IRET = IPRINT CALL W3UNPKB7(IDATE,NWINDO(1),NWINDO(2),IUNIT,RDATA,STNID,DSNAME, $ RDATA2,rdata8_8,IDSDAT,IDSDMP_8,SUBSET,SUBSKP,IRET) C----------------------------------------------------------------------- IF(IRET.EQ.1) THEN C IRET = 1 RETURNS DATA SET INFO (ONLY) AFTER FIRST CALL IF(IPRINT.LT.0) PRINT'(" RETURN CODE =",I0,"; DATA SET ", $ "INFORMATION RETURNED")', IRET PRINT 102, DSNAME,IUNIT 102 FORMAT(//46X,'***** ',A8,' -- UNIT =',I3,' *****') C SPLIT DATE INTO COMPONENTS (MDATE) MDATE(1) = IDSDAT/1000000 MDATE(2) = MOD((IDSDAT/10000),100) MDATE(3) = MOD((IDSDAT/100),100) MDATE(4) = MOD(IDSDAT,100) c----------------------------------------------------------------------- c Read 1st dummy message in file so can then call iupvs01 to get iminu call readmg(iunit,subset,ibdate,kret) iminu = iupvs01(iunit,'MINU') c Close file and reopen so W3UNPKB7 will handle things as though this c block of code never exited call closbf(iunit) call openbf(iunit,'IN',iunit) c----------------------------------------------------------------------- PRINT 1101, DSNAME,MDATE,iminu,IDSDMP_8 1101 FORMAT(20X,'DATASET NAME: ',A8,' -- DATE: ',I4.4,2('-',I2.2), $ 1X,I2.2,i2.2,'Z -- DUMP DATE (I12 FORMAT): ',I12.12/) C DOES DATE FROM DATA SET MATCH EXPECTED CENTER DATE? IF(IDSDAT.NE.IDAT10) THEN PRINT 324 324 FORMAT(/13X,'>>>>> P R O B L E M : B U F R F I L E ', $ 'D A T E D O E S N O T M A T C H E X P E C T E D ', $ 'D A T E <<<<<'/) GO TO 7003 END IF IFIND = 0 DO I = 0,255 DO J = 0,200 IF(SUBSKP(I,J)) THEN IF(IFIND.EQ.0) PRINT 7001 7001 FORMAT(34X,'-- THE FOLLOWING BUFR MESSAGE TYPES/SUBTYPES WILL ', $ 'BE SKIPPED:') PRINT 7002, I,J 7002 FORMAT(45X,'BUFR TYPE ',I3.3,', SUBTYPE ',I3.3) IFIND = 1 END IF ENDDO ENDDO IF(IFIND.EQ.0) PRINT 8003 8003 FORMAT(10X,'-- ALL BUFR MESSAGE TYPES/SUBTYPES IN DATA DUMP FILE', $ ' WILL BE PROCESSED') PRINT 7004 7004 FORMAT(//) GO TO 2090 C---------------------------------------------------------------------- ELSE IF(IRET.GT.2) THEN C PROBLEM READING WINDSAT SCATTEROMETER WIND REPORT, GO ON TO NEXT RPT PRINT 912 912 FORMAT(' * * ERROR READING WINDSAT SCATTEROMETER WIND REPORT,', $ ' TRY NEXT ONE') GO TO 2090 C---------------------------------------------------------------------- ELSE IF(IRET.EQ.2) THEN C ALL DONE GO TO 7003 END IF C---------------------------------------------------------------------- KNTRPT = KNTRPT + 1 C PRINT OUT REPORT AS FOUND IN OUTPUT ARRAYS 'RDATA' AND 'IDATA' IF(IPRINT.LT.0) PRINT 8890, (IDATA(K),K=35,36) 8890 FORMAT(1X,'>> PRINTOUT OF OUTPUT RDATA/IDATA ARRAY:'//1X,'NO. ', $ 'CAT. 10 LVLS=',I1,'; CAT. 10 DATA SUBSCRIPT=',I2/) C1 = 'N' C2 = 'E' ALAT = RDATA(1) IF(RDATA(1).LT.0.0) THEN ALAT = -ALAT C1 = 'S' END IF ALON = RDATA(2) IF(RDATA(2).GT.180.00) THEN ALON = 360.00 - ALON C2 = 'W' END IF IHGHT = 999999 IF(RDATA(7).LT.XMISS) IHGHT = NINT(RDATA(7)) WSPD = XMISS short = .true. IF(RDATA(IDATA(36)+3).LT.XMISS) WSPD = RDATA(IDATA(36)+3)*0.1 if(.not.short) then PRINT 9890, STNID,RDATA(4),ALAT,C1,ALON,C2,IHGHT,IDATA(6), $ IDATA(9),NINT(RDATA(IDATA(36)+2)),WSPD, $ RDATA(IDATA(36)+6)*3600.,RDATA2(9),RDATA2(10),RDATA2(11), $ NINT(RDATA2(12)),RDATA2(19),RDATA2(17),RDATA2(18),RDATA2(21), $ RDATA2(20),RDATA2(16),NINT(RDATA2(15)),RDATA2(13),RDATA2(14), $ NINT(RDATA2(2)) 9890 FORMAT(A8,2X,F8.5,'Z',2X,F5.2,A1,1X,F6.2,A1,2X,'ELV',I3,'M',2X, $ 'SAID',I4,2X,'RTP ',I3.3,2X,'DIR ',I3,1X,'SPD',F5.1,'M/S',2X, $ 'REQV ',F4.1,'MM/HR',2X,'SST1 ',F6.2,'K',2X,'PW ',F6.2,'MM',2X, $ 'CLW ',F5.2,'MM'/5X,'WSST',I2,2X,'SSTE ',F6.2,2X,'PHER ',F5.1, $ 2X,'SPDE ',F5.2,2X,'VPRE ',F5.2,2X,'CLDE ',F6.3,2X,'CHSQ ',F5.2, $ 2X,'WSEQC1 ',I10,2X,'MWD10 ',F6.2,2X,'MWS10 ',F6.2,2X,'ACAV ',I2) else PRINT 9891, STNID,RDATA(4),ALAT,C1,ALON,C2,IHGHT,IDATA(6), $ IDATA(9),NINT(RDATA(IDATA(36)+2)),WSPD, $ RDATA(IDATA(36)+6)*3600.,RDATA2(9),RDATA2(10),RDATA2(11) 9891 FORMAT(A8,2X,F8.5,'Z',2X,F5.2,A1,1X,F6.2,A1,2X,'ELV',I3,'M',2X, $ 'SAID',I4,2X,'RTP ',I3.3,2X,'DIR ',I3,1X,'SPD',F5.1,'M/S',2X, $ 'REQV ',F4.1,'MM/HR',2X,'SST1 ',F6.2,'K',2X,'PW ',F6.2,'MM',2X, $ 'CLW ',F5.2,'MM') end if C GO UP AND UNPACK THE NEXT REPORT GO TO 2090 7003 CONTINUE C----------------------------------------------------------------------- C ALL REPORTS HAVE BEEN UNPACKED -- ALL DONE PRINT 9004, IUNIT,KNTRPT 9004 FORMAT(//45X,'--> ALL REPORTS IN FILE',I3,' PROCESSED <--'//47X, $ '*** ',I6,' REPORTS LISTED HERE ***'/) PRINT 9006 9006 FORMAT(/38X,'>>> SUCCESSFUL COMPLETION OF PROGRAM ', $ 'BUFR_LISTDUMPS <<<'/) RETURN C----------------------------------------------------------------------- END