C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: IW3UNPBF C PRGMMR: DONG/WHITING ORG: NP22 DATE: 2020-08-20 C C ABSTRACT: READS AND UNPACKS ONE REPORT FROM INPUT NCEP BUFR DUMP C FILE INTO SPECIFIED FORMAT. FUNCTION RETURNS THE UNPACKED REPORT C TO THE CALLING PROGRAM IN THE ARRAY 'OBS' AS WELL AS IN VARIABLES C 'STNID', 'CRES1', 'CRES2', 'OBS2', 'OBS3' AND 'OBS8_8'. IT ALSO C RETURNS INFORMATION ABOUT THE INPUT DATA SET ITSELF (NAME, CENTER C DATE, DUMP TIME) AND THE BUFR MESSAGE TYPE. VARIOUS CONTINGENCIES C ARE COVERED BY RETURN VALUE OF THE FUNCTION AND PARAMETER 'IER' - C FUNCTION AND IER HAVE SAME VALUE. REPEATED CALLS OF FUNCTION WILL C RETURN A SEQUENCE OF UNPACKED REPORTS. THE CALLING PROGRAM MAY C SWITCH TO A NEW 'NUNIT' AT ANY TIME, THAT DATASET WILL THEN BE READ C IN SEQUENCE. IF USER SWITCHES BACK TO A PREVIOUS 'NUNIT', THAT C DATA SET WILL BE READ FROM THE BEGINNING, NOT FROM WHERE THE USER C LEFT OFF (THIS IS A 'SOFTWARE TOOL', NOT AN ENTIRE I/O SYSTEM). C ARGUMENT 'IER' IS ALSO CHECKED UPON INPUT THE FIRST TIME A NEW C 'NUNIT' IS PASSED IN. C IF 'IER' IS -1 IN THIS CASE, THIS C INDICATES THAT THE FILE ASSOCIATED WITH "NUNIT" HAS ALREADY BEEN C OPENED BY THE CORRESPONDING INTERFACE SUBROUTINE W3UNPKB7 AND SOME C REPORTS HAVE BEEN PROCESSED. IN THIS CASE, THIS ROUTINE WILL C CONTINUE READING AND PROCESSING REPORTS FROM 'NUNIT' (OTHERWISE IER C SHOULD BE INPUT AS ZERO THE FIRST TIME A NEW 'NUNIT' IS PASSED IN). C C PROGRAM HISTORY LOG: C 1998-02-17 D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM W3LIB C ROUTINE IW3GAD) C 1998-03-16 D. A. KEYSER -- BUMPED UP ARRAY SIZE FOR UNPACKED C REPORT IN "OBS" FROM 1608 TO 2500; SUBROUTINE NO LONGER RETURNS C WITH IER=999 IF UNPACKED ARRAY SIZE IS EXCEEDED - RATHER IT SKIPS C PROCESSING OF OFFENDING REPORT AND PRINTS A DIAGNOSTIC; BUMP UP C MAXIMUM NUMBER OF LEVELS THAT CAN BE PROCESSED FOR A CATEGORY C FROM 150 TO 160 C 1998-06-15 D. A. KEYSER -- STREAMLINED THE PROCESSING OF FLIGHT- C LEVEL RECONNAISSANCE REPORTS; REDEFINED UNITS FOR UNPACKED WORDS C 1 (LATITUDE), 2 (LONGITUDE), 4 (OBS. TIME) AND 11 (RECEIPT TIME) C - ALL TO STREAMLINE PROCESSING IN PREPDATA PROGRAM; IN ADPUPA C PROCESSING, REMOVED WRITING OF CAT. 8 C.F. 106, ADDED WRITING OF C NEW CAT. 8 C.F. 353 (SOLAR AND INFRARED RADIATION CORRECTION C INDICATOR) AND 354 (TRACKING TECHNIQUE/STATUS OF SYSTEM USED C INDICATOR) C 1998-09-21 D. A. KEYSER -- SUBROUTINE NOW Y2K AND FORTRAN 90 C COMPLIANT C 1999-01-20 D. A. KEYSER -- INCORPORATED BOB KISTLER'S CHANGES NEEDED C TO PORT THE CODE TO THE IBM SP; ADDED REPORT SUBTYPE 1 FOR RECCOS C UNDER REPORT TYPE 31 AND SUBTYPE 2 FOR DROPS UNDER REPORT TYPE 31 C 1999-02-25 D. A. KEYSER -- ADDED ABILITY TO READ REPROCESSED SSM/I C NCEP BUFR DUMP FILE (SPSSMI); ADDED ABILITY TO READ MEAN SEA- C LEVEL PRESSURE BOGUS (PAOBS) DATA SET (SFCBOG); ADDED PROCESSING C OF MDCRS ACARS MOISTURE DATA (READ IN AS MIXING RATIO AND C CONVERTED TO DEWPOINT DEPRESSION); MAND. LVLS WITH ONLY WIND NOW C STORED AS CAT. 1 (USED TO STORE AS CAT. 3 LIKE OLD ON29); TROP. C LVLS NOW STORED AS ONLY CAT. 5 (USED TO STORE AS BOTH CAT. 3 AND C 5); U.S. RAOBS NO LONGER TRUNCATE WIND-BY-HGT HGTS ABOVE 100 MB C DOWN TO NEXT 10 METER LVL (THIS WAS AN OLD ON29 CONVENTION) C 1999-05-14 D. A. KEYSER -- MADE FURTHER CHANGES NECESSARY TO PORT C THIS ROUTINE TO THE IBM SP C 1999-06-18 D. A. KEYSER -- CAN NOW PROCESS WATER VAPOR SATWNDS FROM C FOREIGN PRODUCERS; STN. ID FOR FOREIGN SATWNDS NOW REPROCESSED IN C SAME WAY AS FOR NESDIS/GOES SATWNDS, CHARACTER 1 OF STN. ID NOW C DEFINES EVEN VS. ODD SATELLITE WHILE CHARACTER 6 OF STN. ID NOW C DEFINES IR CLOUD-DRFT VS. VISIBLE CLOUD DRFT VS. WATER VAPOR C 1999-08-04 D. A. KEYSER -- UPDATED CALL TO ORDERS TO CORRECT ERROR C SINCE ORDERS WAS RECENTLY UPDATED IN W3LIB (4-BYTE REAL MACHINE C VERSION WAS PASSING 8-BYTE SORT KEYS WHICH CAUSED CAT. 2,3,4 C PRESSURE SORT AND CAT. 8 CODE FIG. SORT TO NO LONGER WORK C PROPERLY); ADDED CALL TO SUBR. WORDLENGTH TO DETERMINE REAL AND C INTEGER MACHINE WORDLENGTH SO PROPER SORT KEY WORD LENGTH IS C ALWAYS PASSED INTO ORDERS; NOW FLAGS ALL VARIABLES (Q.M.=14) ON C DUPLICATE PRESSURE LEVELS WHERE OTHER DATA DISAGREE C 1999-11-02 D. A. KEYSER -- CHANGES TO MAKE CODE MORE PORTABLE C 1999-11-04 D. A. KEYSER -- ADDED NEW INPUT ARGUMENT "SUBSKP" - SEE C DESCRIPTION BELOW C 2000-01-24 D. A. KEYSER -- ADDED WRITING OF NEW CAT. 8 C.F. 355 C (NESDIS RECURSIVE FILTER FUNCTION) IN SATWND PROCESSING; MOVED C GOES SATWND Q.M. ASSIGNMENT BASED ON RFFL FROM SATWND PROCESSING C IN THIS SUBROUTINE TO SUBROUTINE GETC06 INLINE IN PREPDATA; THIS C SUBROUTINE NOW ASSIGNS CHAR. 1 AND CHAR. 6 OF NESDIS SATWND C REPORTS IN SATWND PROCESSING (HAD USED VALUES ASSIGNED BY INGEST C PROGRAM); SATWND PROCESSING MODIFIED TO HANDLE FUTURE EXPANDED C NESDIS SATWND FORMAT READ IN FROM NESDIS BUFR FILE C 2000-06-07 D. A. KEYSER -- SATWND PROCESSING FURTHER MODIFIED TO C HANDLE NEW EXPANDED NESDIS SATWND FORMAT READ IN FROM NESDIS BUFR C FILES C 2000-09-22 D. A. KEYSER -- ADDED NEW REPORT TYPE (RTP) OF 533 FOR C SURFACE MARINE AUTOMATED TIDE GAUGE REPORTS; FURTHER C MODIFICATIONS TO SATWND PROCESSING TO HANDLE NEW EXPANDED NESDIS C SATWND FORMAT, IN PARTICULAR NESDIS WINDS GENERATED FROM THE GMS C SATELLITE C 2000-12-05 D. A. KEYSER -- CHANGED REPORT TYPE (RTP) FOR SURFACE C MARINE AUTOMATED TIDE GAUGE REPORTS FROM 533 TO 532 SO THEY AGREE C WITH REPORT TYPE IN QUIPS PROCESSING; SATWND PROCESSING MODIFIED C TO HANDLE OLD LO-DENSITY NESDIS FORMAT IN NC005001-NC005004 (FOR C HISTORICAL RERUNS); SATWND PROCESSING MODIFIED TO NOT CREATE STN. C ID IF IT HAS ALREADY BEEN CREATED BY BUFR_DUPSAT (OTHERWISE, C MODIFIED TO CREATE AN 8-CHARACTER STN. ID); ALL CAT. 6 TYPES NOW C STORE SPEC. HUMIDITY AS MOISTURE VARIABLE RATHER THAN DEWPOINT C DEPR.; MDCRS ACARS AIRCRAFT NOW PROCESSES MOISTURE ONLY IF C MOISTURE QUALITY IS "GOOD", IN THIS CASE IF MIXING RATIO IS FOUND C IT IS USED OTHERWISE LOOKS FOR RELATIVE HUM. (BEFORE, MOISTURE C QUALITY IND. WAS NOT EXAMINED AND ONLY MIXING RATIO WAS DECODED) C 2001-04-06 D. A. KEYSER -- MODIFIED TO HANDLE NEW BUFR EUMETSAT C WINDS IN SUBSETS "NC005064", "NC005065" AND "NC005066"; NOW C STORES SSM/I RAINFALL RATE (CAT. 8, C.F. 198) IN UNITS OF MM/SEC C (STORED TO 10**6 PRECISION) (RATHER THAN WHOLE MM/HR), SSM/I C SURFACE TEMP (CAT. 8, C.F. 199) IN UNITS OF K (STORED TO 10**2 C PRECISION) (RATHER THAN WHOLE K), SSM/I TPW (CAT. 8, C.F. 197) IN C UNITS OF MM (STORED TO 10**1 PRECISION) (RATHER THAN MM*100), AND C SSM/I WSPD (CAT. 8, C.F. 196) IN UNITS OF M/SEC (STORED TO 10**1 C PRECISION) (RATHER THAN M/SEC*10); NOW LOOKS FOR SSM/I RAINFALL C RATE IN MNEMONIC "REQ6" FIRST, IF NOT FOUND LOOKS IN "REQV" C (LATTER FOR HISTORICAL RERUNS); CAN NOW UNPACK SSM/I SEA-SURFACE C TEMPERATURE PRODUCT (RTYP=577), STORES AS CAT. 8, C.F. 203; NOW C READS INPUT VALUE FOR IER ON FIRST CALL FOR A "NUNIT", IF IER=-1 C ASSUMES THAT THE FILE ASSOCIATED WITH "NUNIT" HAS ALREADY BEEN C OPENED BY SUBR. "W3UNPKB7" AND REPORTS HAVE BEEN PROCESSED, IN C THIS CASE THIS ROUTINE WILL CONTINUE READING AND PROCESSING C REPORTS FROM "NUNIT" (THE OUTPUT ARGUMENTS DSNAME, IDSDAT AND C IDSDMP_8 ALSO BECOME INPUT ARGUMENTS IN THIS CASE) (CALLING C PROGRAM SHOULD OTHERWISE SET IER=0 ON FIRST CALL FOR A NEW C "NUNIT"); CAN NOW PROCESS WIND PROFILERS THAT ORIGINATE FROM C PILOT (PIBAL) FORMAT BULLETINS, GET R. TYPE 073; CORRECTED A BUG C WHICH MIGHT HAVE PREVENTED A DIAGNOSTIC PRINT FOR CASES WHEN C 'SUBSKP' IS PASSED IN AS TRUE FOR SOME BUFR TYPE/SUBTYPE; ADDED C "SUBSET_r" (BUFR MESSAGE TYPE) AS AN INPUT/OUTPUT ARGUMENT (INPUT C ONLY WHEN IER IS PASSED IN AS -1; HEADER WORD 6 (WAS MISSING) C NOW RETURNS SATELLITE ID FOR SATWIND AND SSM/I NON-SUPEROB C REPORTS (FOR OTHERS IT'S STILL MISSING); NOW STORES SSM/I C BRIGHTNESS TEMPS (CAT. 8, C.F. 189-195) IN UNITS OF K (STORED TO C 10**2 PRECISION) (RATHER THAN K*100); CAN NOW UNPACK 4 MDCRS C ACARS TURBULENCE INDECES AND STORE AS CAT. 8, C.F. 926-929 C 2001-06-03 D. A. KEYSER -- MODIFIED TO HANDLE EXPANDED Q.C. INFO C FOR BUFR EUMETSAT WINDS IN SUBSETS "NC005064", "NC005065" AND C "NC005066" IMPLEMENTED ON 6-4-2001 (NOW HAS Q.C. NOT BASED ON C FIRST GUESS, ALONG WITH Q.C. BASED ON FIRST GUESS AS BEFORE, WE C ONLY WANT THE LATTER FOR NOW) C 2001-06-19 D. A. KEYSER -- REMOVED A TEMPORARY FIX TO FORCE A C "VSIG" OF 2 OR 64 FOR WIND PROFILERS THAT ORIGNATE FROM PILOT C (PIBAL) FORMAT BULLETINS IN 002/009 - THIS HAS BEEN FIXED IN THE C DECODER C 2002-01-28 D. A. KEYSER -- PRECISION OF TEMPERATURE OBS (AMDAR C FORMAT AND MDCRS ACARS) NOW STORED AS DEG. K * 100 IN CAT. 8 C.F. C 915 SINCE IT IS STORED WITH 10**2 PRECISION IN DUMPS (WAS STORED C AS DEG. K * 1 WITH INCORRECT COMMENTS THAT IT WAS A BUFR CODE C TABLE 0-08-005, ACTUAL DESC. IS 0-02-005) C 2002-03-05 D. A. KEYSER -- ACCOUNTS FOR CHANGES IN INPUT ADPUPA, C ADPSFC, AIRCFT AND AIRCAR BUFR DUMP FILES AFTER 5/2002: CAT. 7 C AND CAT. 51 USE MNEMONIC "HBLCS" TO GET HEIGHT OF CLOUD BASE IF C MNEMONIC "HOCB" NOT AVAILABLE (AND IT WILL NOT BE FOR ALL CAT. 7 C AND SOME CAT. 51 REPORTS); MNEMONIC "TIWM" REPLACES "SUWS" IN C HEADER FOR SURFACE DATA; MNEMONIC "BORG" REPLACES "ICLI" IN CAT. C 8 FOR AIRCRAFT DATA (WILL STILL WORK PROPERLY FOR INPUT ADPUPA, C ADPSFC, AIRCFT AND AIRCAR DUMP FILES PRIOR TO 5/2002) C 2002-07-03 D. A. KEYSER -- ADDED ABILITY TO READ MESONET NCEP BUFR C DUMP FILE (MSONET) C 2003-05-23 D. A. KEYSER -- GOES-9 (SAT. ID 253) WINDS WITH BUFR C MESSAGE SUBTYPE 41-43 ALWAYS GET "P" IN 1ST CHAR. OF STN. ID AND C "D" (PROCUCER = JMA) IN 2ND CHAR. OF STN. ID. (JMA BEGAN C PRODUCING WINDS FROM GOES-9 IN PLACE OF FAILING GMS-5 ON 23 MAY C 2003), WHEN NESDIS PRODUCES WINDS FROM GOES-9 THE FIRST CHAR. IN C THE STN. ID IS "C" (AS BEFORE) C 2003-07-10 D. A. KEYSER -- ADDED NEW ARRAY OBS2 WHICH RETURNS C SINGLE-LEVEL REPORT DATA DIRECTLY FROM BUFR DUMP, INITALLY ONLY C 2-WORDS, FIRST WORD RETURNS BUFR FLAG TABLE FOR "RESTRICTIONS ON C REDISTRIBUTION" (0-35-200) AND SECOND WORD RETURNS "EXPIRATION OF C RESTRICTIONS ON REDISTRIBUTION" (HOURS) C 2004-01-09 D. A. KEYSER -- INPUT ARGUMENT SUBSKP SECOND DIMENSION C CHANGED FROM 1:200 TO 0:200 TO ACCOUNT FOR REPORTS WITH BUFR C SUBTYPE 000 (CURRENTLY ONLY WMO RES. 40 SYNOPS), DONE IN RESPONSE C TO CHANGE IN CORRESPONDING CALLING PROGRAM(S) C 2004-02-02 D. A. KEYSER -- ADDED ABILITY TO PROCESS MOBILE SURFACE C LAND SYNOPTIC REPORTS OUT OF ADPSFC DUMP FILE [INCL. STN. ELEV C Q.M. WHICH IS STORED IN OUTPUT HEADER WORD 12 (PREV. MISSING AND C IS STILL MISSING FOR ALL OTHER DATA TYPES)]; ADDED ABILITY TO C PROCESS E-AMDAR AIRCRAFT REPORTS OUT OF THE AIRCFT DUMP FILE; C ADDED INFO. NOT PREVIOUSLY DECODED FOR MESONET DATA FROM MSONET C DUMP FILE {INCL. ID STRINGS FOR PROVIDER AND SUB-PROVIDER STORED C IN RESERVE WORDS 1 AND 2, RESP. (CHARACTER)}; ACCOUNTS FOR C TRANSITION OF MESONET REPORTS FROM LOW- TO HIGH-RESOLUTION LAT/ C LON IN EARLY 2004; ARRAY SUBSKP BUMPED UP FROM (0:12,0:200) TO C (0:255,0:200); ACARS FLIGHT NUMBER NOW STORED IN RESERVE WORD 2 C (CHARACTER); LOGIC ADDED TO SELECT WHICH PRESSURE (HEIGHT C ASSIGN.) AND WIND TO USE FOR GOES SATWND REPORTS (STILL HARDWIRED C TO "FINAL" VALUE); ADDED LOGIC TO HANDLE FUTURE NASA/MODIS (AQUA/ C TERRA) POES WINDS C 2004-09-09 D. A. KEYSER -- CORRECTED THE DEFINITION OF "INSTRUMENT C TYPE" (IT IS NOT BUFR CODE TBL 0-02-011 FOR NON-ADPUPA TYPE C REPORTS) AND INITIALIZES IT AS MISSING INSTEAD OF "99"; SURFACE C TYPES NOW ALWAYS STORE INSTRUMENT TYPE AS MISSING RATHER THAN C PACKING IN SYNOPTIC FORMAT FLAG, AUTOMATED STATION TYPE, AND SHIP C LOCATION FLAG; EXPANDED OBS2 FROM 2 TO 41-WORDS, ADDING RETURN OF C ALTIMETER SETTING, SEA-SURFACE TEMPERATURE AND SINGLE-LEVEL C SENSIBLE WEATHER ELEMENTS DIRECTLY FROM BUFR DUMP AND HARDWIRING C OBS2(41) (SST Q.M.) TO 2 WHEN SST IS PRESENT (ELSE MISSING) (SEE C REMARKS FOR CONTENT OF OBS2); ADDED NEW OUTPUT ARGUMENT OBS3 C {CURRENTLY 5,255,5)} WHICH RETURNS MULTIPLE-LEVEL SENSIBLE C WEATHER ELEMENTS DIRECTLY FROM BUFR DUMP (SEE REMARKS FOR CONTENT C OF OBS3); ADDED NEW OUTPUT ARGUMENT NOBS3 {CURRENTLY (5)} WHICH C INDICATES THE NUMBER OF LEVELS OF DATA IN THE OBS3(X,Y,1), C OBS3(X,Y,2), OBS3(X,Y,3), OBS3(X,Y,4) AND OBS3(X,Y,5) ARRAYS (SEE C REMARKS); REMOVED ALL REFERENCES TO CAT. 7, 9 & 52 SINCE NO DATA C IN THESE NOW (RETURNED IN OBS2 OR OBS3); REMOVED (SET TO MISSING) C SOME INFO. THAT HAD BEEN RETURNED IN CAT. 51 & REDUCED NUMBER OF C VALUES IN IT FROM 25 TO 13 (RETURNED IN OBS2 OR OBS3); REMOVED C CAT. 8 CODE FIG. 001 (MAX. WIND SPD), 002 (MAX. WIND GUST DIR.), C 081 (CALENDAR DAY MAX. TEMP.), 082 (CALENDAR DAY MIN. TEMP.), 083 C (6-HR MAX. TEMP.), 084 (6-HR MIN. TEMP.), 085 (1-HR PRECIP.) AND C 098 (TOTAL SUNSHINE FOR CALENDAR DAY) (RETURNED IN OBS2 OR OBS3); C CHANGED MEANING OF CAT. 8 CODE FIG. 005 FROM 1-HR PRECIP. (W/ C IND. 2 ITS Q.M.) TO Q.M. FOR 1-HR PRECIP. (IND. 2 NOW MISSING), C 006 FROM 24-HR PRECIP. (W/ IND. 2 ITS Q.M.) TO Q.M. FOR 24-HR C PRECIP. (IND. 2 NOW MISSING) AND 020 FROM ALTIMETER SETTING (W/ C IND. 2 ITS Q.M.) TO Q.M. FOR ALTIMETER SETTING (IND. 2 NOW C MISSING); TYPE OF HOURLY REPORT ("METAR", "SPECI" OR "LWIS"), C DETERMINED FROM BUFR MNEMONIC THRPT, STORED IN BYTES 1-5 OF C HEADER RESERVE CHARACTER WORD 2 (METAR REPORTS ONLY), CORRECTED C REPORT INDICATOR ("CORN") STORED IN BYTE 8 OF HEADER RESERVE C CHARACTER WORD 2 (METAR REPORTS ONLY); LOGIC MODIFIED TO C TRANSITION FROM LOCAL TO WMO MNEMONICS FOR INPUT SSM/I DATA - NOW C LOOKS FOR TOTAL PRECIP. WATER IN MNEMONIC "TPWT" FIRST, IF NOT C FOUND LOOKS IN "PH2O", LOOKS FOR TOTAL SNOW DEPTH IN MNEMONIC C "TOSD" FIRST, IF NOT FOUND LOOKS IN "SNDP", LOOKS FOR OCEAN C SURFACE WIND SPEED IN MNEMONIC "WSPD" (WIND SPEED) FIRST, IF NOT C FOUND LOOKS IN "WSOS" (THIS ALSO ALLOWS FOR HISTORICAL RERUNS); C NON-MDCRS ACARS AIRFRAFT REPORTS NO LONGER GIVE ALL VARIABLES A C KEEP OR PURGE FLAG IF EITHER TEMP OR WIND HAS KEEP OR PURGE FLAG C - Q.M. REMAINS AS READ IN EXCEPT IF WIND Q.M. HAS PURGE FLAG, C THEN TEMP Q.M. ALSO GETS PURGE FLAG C 2005-03-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM BUFR_LISTDUMPS): C 2006-11-29 D. A. KEYSER (THIS FUNCTION IN PROGRAM PREPOBS_PREPDATA): C MODIFIED TO HANDLE PREVIOUS CHANGE IN BUFR SUBSET STRUCTURE FOR C MODIS WINDS IN NC005070-071 ("SWCM" INSTEAD OF "SWDL" USED TO C DETERMINE CLOUD-TOP VS. DEEP-LAYER - BUG HAD LED TO ALL WV WINDS C TAGGED AS CLOUD-TOP); MODIFIED TO HANDLE PREVIOUS CHANGE IN BUFR C SUBSET STRUCTURE FOR EUMETSAT WINDS IN NC005064-066 (WILL STILL C WORK WITH OLD BUFR SUBSET STRUCTURE); MODIFIED TO HANDLE FUTURE C GTS GOES WINDS IN NC005015-018 AND FUTURE HI-DENSITY (FROM BUFR) C JMA WINDS IN NC005044-046; STORES PERCENT CONFIDENCE BASED ON C EUMETSAT QUALITY INDEX WITH FORECAST CONSISTENCY TEST (FOR C SATELLITE WINDS) (BUFR CODE TABLE 0-33-197) IN CAT. 8 CODE FIGURE C 356; STORES PERCENT CONFIDENCE BASED ON EUMETSAT QUALITY INDEX C WITHOUT FORECAST CONSISTENCY TEST (FOR SATELLITE WINDS) (BUFR C CODE TABLE 0-33-198) IN CAT. 8 CODE FIGURE 357 C 2005-03-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM BUFR_LISTDUMPS): C 2007-09-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM PREPOBS_PREPDATA): C CHANGES IN SATWND PROCESSING IN RESPONSE TO NESDIS' CORRECTION OF C AN ERROR (EFF. 3/10/2005) WHICH HAD STORED SIDP (SATELLITE C INSTRUMENT USED IN DATA PROCESSING) AS A CODE TABLE VALUE RATHER C THAN CORRECTLY AS A FLAG TABLE VALUE (THE CHANGE BY NESDIS C RESULTED IN INSTRUMENT TYPE BEING STORED AS MISSING AND THE C REPORT ID NOT BEING INDEXED) (WILL STILL WORK OK FOR HISTORICAL C RUNS PRIOR TO NESDIS FIX) {NOTE: THE LOGIC CHANGED HERE IS C ACTUALLY NEVER USED ANY MORE SINCE THE DUMP PROGRAM BUFR_DUPSAT C NOW (SINCE 12/2000) CREATES THE STATION ID PRIOR TO THIS ROUTINE C RUNNING AND THE INSTRUMENT TYPE IS NOW OBTAINED FROM THE STATION C ID} C 2006-07-14 D. A. KEYSER -- BUMPED UP ARRAY SIZE FOR UNPACKED REPORT C IN "OBS" FROM 2500 TO 3000; BUMPED UP MAXIMUM NUMBER OF LEVELS C THAT CAN BE PROCESSED FOR A CATEGORY FROM 160 TO 200 C 2006-07-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM BUFR_LISTDUMPS): C 2007-09-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM PREPOBS_PREPDATA): C CHANGES TO HANDLE JMA'S SWITCH FROM GOES-9 (SAT. ID 253) TO NEW C MTSAT-1R (SAT. ID 171, FIRST CHARACTER OF RPID IS "Q") FOR C SATWINDS ON 7/15/2005; ADDED NEW CODE FIGURES 930 {TAMDAR C TURBULENCE INDEX (BUFR CODE TABLE 0-11-235), INDICATOR 2 CONTAINS C TURBULENCE INDEX QUALITY MARKER (0-15)}; AND 931 {TAMDAR ROLL C ANGLE FLAG (BUFR CODE TABLE 0-02-199)}; FIXED BUG WHICH PREVENTED C "PART" RECEIPT TIMES FROM BEING STORED PROPERLY FOR ADPUPA TYPES; C MODIFIED TO PROCESS TAMDAR AND CANADIAN AMDAR AIRCRAFT DATA, C LATTER PROCESSES MOISTURE; THE HIGHEST FSL QUALITY FLAGS FOR C MESONET AND TAMDAR DATA NOW RESULT IN A PREPBUFR Q.M. OF 2 C (NEUTRAL) RATHER THAN 1 (GOOD); CHANGES TO HANDLE INDIAN SATWINDS C FROM INSAT-3A (SAT. ID 470, FIRST CHARACTER OF RPID IS "V") AND C KALPANA-1 (SAT. ID 440, FIRST CHARACTER OF RPID IS "K") C 2006-11-29 D. A. KEYSER (THIS FUNCTION IN PROGRAM PREPOBS_PREPDATA): C 2007-09-14 D. A. KEYSER (THIS FUNCTION IN PROGRAM BUFR_LISTDUMPS): C FUNCTION R06UBF ACCOUNTS FOR EUMETSAT CLOUD WINDS NOW SENDING A C THIRD REPLICATION OF QUALITY INFORMATION (NESDIS RFF, IN C METEOSAT-MSG ONLY, BUT TESTED FOR ALL EUMETSAT SATELLITES) C 2007-09-14 D. A. KEYSER -- BUMPED UP ARRAY SIZE FOR UNPACKED REPORT C IN "OBS" FROM 3000 TO 3500; BUMPED UP MAXIMUM NUMBER OF LEVELS C THAT CAN BE PROCESSED FOR A CATEGORY FROM 200 TO 300; STORES C PERCENT CONFIDENCE BASED ON NESDIS EXPECTED ERROR (FOR SATELLITE C WINDS) (BUFR CODE TABLE 0-33-203) IN CAT. 8 CODE FIGURE 358; C EXPANDED ARRAYS OBS3 FROM (5,255,5) TO (5,255,7) AND NOBS3 FROM C (5) TO (7) TO ACCOUNT FOR PROCESSING OF ADDITIONAL MULTIPLE-LEVEL C SENSIBLE WEATHER ELEMENTS CONTAINING AIRFRAME ICING (RECCOS, C PIREPS, E-AMDAR, CANADIAN AMDAR, TAMDAR) AND DEGREE OF TURBULENCE C (RECCOS AND ALL AIRCRAFT) INFORMATION (SEE REMARKS), THE LATTER C REPLACES STORAGE OF SINGLE DEGREE OF TURBULENCE VALUE WHICH HAD C BEEN IN CAT. 8, CODE FIGURE 916; ALL CALLS TO UFBINT TO RETURN C OBS3 DATA NOW CHECK FOR ALL MISSING VALUES WHEN NUMBER OF C "LEVELS" RETURNED IS 1 - IN SUCH CASES, THE NUMBER OF "LEVELS" C RETURNED IS CHANGED TO 0 (UFBINT CAN RETURN 1 LEVEL EVEN IF ALL C DATA ARE MISSING); ACCOUNTS FOR ARINC SCALING MIXR INCORRECTLY IN C MDCRS ACARS REPORTS (10 TIMES TOO LARGE) BETWEEN 11/1/2006 AND C 10/1/2007 (COMPENSATES BY DIVIDING MIXR BY 10) - ON 10/2/2007 C ARINC MADE FIX, MIXR SET TO MISSING SINCE UNCERTAIN OF EXACT TIME C OF FIX - FROM 10/1/2006 THROUGH 10/31/2006 MIXR ALSO SET TO C MISSING SINCE THERE IS UNCERTAINTY AS TO WHEN SCALING ERROR WAS C INTRODUCED DURING 10/2006 (NOTE: THIS CHANGE BENEFITS ONLY C HISTORICAL RERUNS AND REANALYSIS RUNS SINCE CHANGE WILL NOT BE C IMPLEMENTED UNTIL WELL AFTER 10/2/2007) C 2008-04-10 D. A. KEYSER -- CAN HANDLE RADIOSONDE TYPES > 99 WHICH C WILL SOON BE INTRODUCED INTO THE BUFR DATABASE (BASED ON NOVEMBER C 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 -- ADDED FUNCTION TO CORRECTLY CALC. C PRESSURE ALTITUDE FROM PRESSURE (VIA U.S. STD. ATMOS) FOR C AIRCRAFT ABOVE 226 MB (BEFORE USED FUNCTION TO CALC. PRESSURE C ALTITUDE FROM PRSSSURE BELOW 226 MB AT ALL LEVELS), THIS APPLIES C ONLY TO MDCRS ACARS AND TAMDAR AIRCRAFT; THE Q.M. FOR MDCRS ACARS C WIND IS NO LONGER SET TO 1 (GOOD) IF NOT PREVIOUSLY SET, INSTEAD C IT IS SET TO 2 (NEUTRAL) (NEW NRL QC MODULE WILL DECIDE ON FINAL C Q.M.); OUTPUT ARRAY OBS2 INCR. FROM 41 TO 42 WORDS, WORD 42 C CONTAINS MOISTURE QUALITY (CODE TABLE, ACARS REPORTS); EUMETSAT C WIND REPORTS ARE NO LONGER FLAGGED WITH QM=13 BASED ON LOW "QI C WITH FORECAST" VALUE OR HIGH MANUAL/AUTOMATIC Q.C. INDICATOR C 2010-06-07 D. A. KEYSER -- NOW STORES Q.M. FOR ALTIMETER SETTING FOR C METARS (JUST AS ALWAYS FOR MESONETS) IN CODE FIG. 20 OF CAT. 8, C BUT ONLY IF METAR PRESSURE Q.M. WAS GIVEN A PURGE OR REJECT FLAG C IN THE SDMEDIT FILE - IN THIS CASE ALTIMETER Q.M. IS SET TO SAME C VALUE AS PRESSURE Q.M. (EITHER 12 OR 14) (THIS WILL ALLOW C REJECTED OR PURGED PRESSURE Q.M. TO BE HONORED WHEN PSTN IS C CALCULATED FROM ALTIMETER SETTING DOWNSTREAM in PREPDATA); IF C PSTN OR PMSL ARE MISSING, WILL STILL STORE Q.M. READ IN FROM C SDMEDIT FOR THEM; RECOGNIZES NEW OR SOON-TO-BE NEW UNRESTRICTED C SHIP TANK NC001013; RECOGNIZES NEW AVHRR WIND TANK NC005080; C CHANGES 1ST CHARACTER OF REPORT ID FROM "?" (IF FOUND) TO "R" FOR C MTSAT-2 (SATELLITE ID 172) SAT-WIND REPORTS SO THAT THEY WILL BE C PROPERLY RECOGNIZED FOR HISTORICAL RERUNS, ETC. (FROM ~ 11 AUG TO C 30 SEP 2010, BUFR_DUPSAT INCORRECTLY PLACED "?" IN 1ST CHARACTER C OF THESE IDS) C 2012-11-27 D. A. KEYSER -- ALLOW REPORT SEQUENCE NUMBER (CAT. 8, C CODE FIG. 21) TO NOW BE AS LARGE AS 999990 (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) C 2012-11-30 J. WOOLLEN -- INITIAL PORT TO WCOSS; RESET BMISS TO C A VALUE (10E08) WHICH WILL NOT CAUSE INTEGER OVERFLOW WHICH CAN C BE UNPREDICTABLE (PRIOR BMISS VALUE WAS 10E10) C 2013-02-14 D. A. KEYSER -- FINAL CHANGES TO RUN ON WCOSS; OBTAIN C VALUE OF BMISS SET IN CALLING PROGRAM VIA CALL TO BUFRLIB ROUTINE C GETBMISS RATHER THAN HARDWIRING IT TO 10E08 (OR 10E10); USE C BUFRLIB FUNCTION IBFMS TO DETERMINE IF A VARIABLE READ FROM BUFR C FILE IS MISSING (I.E. RETURNED AS BMISS); USE FORMATTED PRINT C STATEMENTS WHERE PREVIOUSLY UNFORMATTED PRINT WAS USED (WCOSS C SPLITS UNFORMATTED PRINT AT 80 CHARACTERS) C 2013-06-30 D. A. KEYSER -- ADDED ABILITY TO READ IN AND PROCESS C PERCENT CONFIDENCE BASED ON EUMETSAT QUALITY INDICATOR WITH AND C WITHOUT FORECAST FOR NESDIS GOES WINDS PULLED FROM NESDIS SERVER C (WHICH ORIGINALLY STORED THEM IN DUMP FILE EXPLICITLY AS "QIFY" C AND "QIFN" BUT LATER STORED THEM BOTH AS BEFORE AND AS REPLICATED C "PCCF" VALUES AS WITH V10 BUFR, AND EVEN LATER STORED THEM ONLY C AS REPLICATED "PCCF" VALUES AS WITH V10 BUFR) IF THEY ARE PRESENT C (NOTE: AS NOTED, WILL ALSO WORK IF THESE ARE STORED IN REPLICATED C "PCCF" VALUES AS WITH V10 BUFR, E.G., MODIS WINDS, AVHRR WINDS, C JMA WINDS, EUMETSAT WINDS); ADDED ABILITY TO READ IN AND PROCESS C PERCENT CONFIDENCE BASED ON NESDIS RECURSVE FILTER FUNCTION FOR C TYPES WHICH MIGHT STORE IT IN DUMP FILE IN REPLICATED "PCCF" C VALUES AS WITH V10 BUFR (IN THIS CASE NESDIS GOES WINDS, MODIS C WINDS, AVHRR WINDS, JMA WINDS - ALREADY IN PLACE FOR EUMETSAT C WINDS) IF IT IS PRESENT (NOTE: WILL STILL WORK IF THIS IS STORED C EXPLICITLY AS "RFFL" AS ORIGINALLY WITH GOES WINDS PULLED FROM C NESDIS SERVER); ADDED ABILITY TO READ IN AND PROCESS PERCENT C CONFIDENCE BASED ON NESDIS EXPECTED ERROR FOR TYPES WHICH MIGHT C STORE IT IN DUMP FILE IN REPLICATED "PCCF" VALUES AS WITH C V10 BUFR (IN THIS CASE MODIS OR AVHRR WINDS) IF IT IS PRESENT C (NOTE: WILL STILL WORK IF THIS IS STORED EXPLICITLY AS "EEQF" AS C ORIGINALLY WITH GOES WINDS PULLED FROM NESDIS SERVER); NOW STORES C CLOUD-TOP/DEEP-LAYER INDICATOR IN BYTE 3 OF HEADER RESERVE C CHARACTER WORD 1 FOR FOREIGN-PRODUCED SATELLITE WINDS (AS ALREADY C DONE FOR NESDIS-PRODUCED SATELLITE WINDS) - JMA AND EUMETSAT C IMAGER WATER VAPOR WINDS CAN NOW BE OF BOTH TYPES, BEFORE THEY C WERE ONLY CLOUD-TOP; OUTPUT ARRAY OBS2 INCR. FROM 42 TO 43 WORDS, C WORD 43 CONTAINS SATELLITE ZENITH ANGLE (DEGREES, SATWND TYPES C ONLY) C 2014-02-01 S. MELCHIOR -- ADDED NEW REPORT TYPE (RTP) OF 534 FOR C SURFACE MARINE COAST GUARD TIDE GAUGE REPORTS C 2015-01-30 D. A. KEYSER -- Added logic to handle new NASA/VIIRS C (NPP) POES winds in tank NC005090 (e.g., recognizes that they now C exist, counts of reports with flagged QI values, counts of C reports by satellite number). Added logic to properly handle C GOES IR short-wave winds in tank NC005019 (e.g., new instrument C type 19, process the quality information correctly). Added some C missing logic which summarizes processing of NESDIS/AVHRR POES C winds in tank NC005080 (e.g., counts of reports by satellite C number). C 2015-03-09 D. A. KEYSER -- Now stores WMO bulletin header and C originator in new output character*11 argument CBULL for aircraft C data (only) (all blanks for all other data types for now). (Note: C Previously, WMO bulletin originator had been stored in characters C 1-4 of header reserve character word 1 and bulletin header was C not stored.) C 2016-02-09 S. MELCHIOR -- Adjusted code to accommodate the C processing of two new aircraft data types: Korean AMDAR (BUFR) C and Catch-All AMDAR (BUFR). Either pre-version 7 BUFR or new C version 7 BUFR for Catch-All AMDAR, MDCRS and E-AMDAR can be C handled. Adjustments are primarily in function R05UBF. Added two C functions to estimate pressure using indicated altitude and U.S. C Standard Atmosphere. The pressure is used to estimate dew point C temperature to perform a gross check on moisture data. The C estimated pressures are not considered reported pressure and C remain missing in the encoded report. Details and clarification C were added explaining how height information is obtained for C different aircraft data types. Adjusted setting of report subtype C (ISTP) to read the last three integers of the subset rather than C the last two integers. This preserves the difference between C legacy TAC format AMDAR tank and new BUFR format "Catch-All" tank C (e.g. 004003 and 004103). Phase of flight information for version C 7 BUFR data is stored in a different mnemonic (DPOF) than C pre-version 7 BUFR version (POAF). The values do not exactly C correlate. Logic was added to translate DPOF values into POAF C values since downstream codes still expect POAF. All references C to E-ADAS have been changed to E-AMDAR. C {Note: Some modifications made to handle new Panasonic (AirDAT) C TAMDAR. This needs further testing.} C 2016-07-28 C. Hill -- C Added capability to process BUFR(v4) TAMDAR data, as provided by C Panasonic/AirDat since November 2015. HMSL (pressure altitude) is C given precedence over FLVLST (GPS altitude) in defining flight C level height (ELEV) and in calcuating pressure values, consistent C with other aircraft data types and performed without adversely C affecting ELEV assignment of the other aircraft data types. C Quality marks for temperature and wind are derived from quality C information provided by QMRKH fields in the reports. The quality C mark for moisture is derived from the "percent confidence" (PCCF) C field provided in the reports. {Additional fields of FLVLST and C IALR (instantaneous altitude rate) are available and may be C considered for future inclusion in PREPBUFR files.} C 2016-11-25 D. A. KEYSER -- C Changes in processing of TAMDAR data provided by Panasonic/AirDat C (TAMDARB): C - Stores instantaneous altitude rate (read from IALR) in cat.8 C c.f. 932 (.001 x m/sec). C - Stores type of commercial aircraft (read from ACTP) in header C reserve character (*8) word 2. C - Stores observer identification (read from OBSVR) in bytes 1-4 C of header reserve character (*8) word 1. C - Cleaned up logic which reads in BORG and BUHD (sets to all C blanks since these are missing for TAMDARB data). Also store C all blanks in output character (*11) CBULLX in this case. C - Bug fixes, mostly minor. Most serious one was logic not C honoring incoming TQM/WQM/QQM other than 2 in transformation C of TAMDAR QMRKH/PCCF into updated TQM/WQM/QQM (from 2016-07-28 C update). C - Treat these like MDCRS in that an SDM purge on wind QM does C NOT force a purge also on temperature QM (this is still done C for all other aircraft types). C Changes in processing of Catch-All AMDAR (BUFR) data: C - Stores flight number (read from ACID) in header reserve C character (*8) word 2 (if ACID is missing, stores all blanks C here). C 2016-11-30 D. A. KEYSER -- C Added new output real, double-precision argument array OBS8_8 of C length 2 to return full-precision latitude and longitude for a C report. C BENEFIT: Although lat and lon are returned in OBS(1:2) these are C at machine precison, which is normally R*4. Now that C many reports in the dumps store lat/lon at 0.001 or even C 0.00001 degree precision, and now that PREPBUFR encodes C YOB (lat) and XOB (lon) at 0.00001 degree precision, this C change will ensure that lat/lon is always accurate to C 0.00001 degrees in all downstream processing. C 2017-01-11 C. Hill -- C For TAMDARB reports, always set moisture quality mark (QQM) to 13 C if temperature quality mark (TQM) was set to 13 earlier in subr. C R05UBF . C 2017-07-03 D. A. KEYSER -- (changes are in function R04UBF) C Mesonet reports now look for SDMEDIT quality marks in dump and C store that information. If missing then, as before, interpret C MADIS quality mark and use that. C BENFEFIT: Corrects a bug in code. SDMEDIT quality marks on C mesonet reports will now be honored (and will not be C overwritten by interpreted MADIS quality marks). C 2018-07-02 S.Melchior-- In function R04UBF, added call to UFBINT C routine to pull in HOVI (horizontal visibility) value for mesonet C message types (NC255). C 2018-10-22 D. A. KEYSER -- (changes are in function R06UBF) C Changes to handle new GOES-16 & up satellite winds which do not C contain a report id (STNID) and have high-res lat/lon (amongst C other differences vs. GOES-15 & down). C 2020-08-20 J. Whiting -- C - Assigned input report type values of 563-4 to fixed and drifting C BUFR-feed buoy data, respectively. C - Set SST values for BUFR-feed fixed & drifting buoy data streams C to be taken from SST0 field. C 2020-08-20 J. DONG -- C - In function I02UBF: C - Changed the windowing decade from 20 to 40 for cases when the C year is represented by 2 digits instead of 4. C - IN FUNCTION R04UBF: C - ADDED ABILITY TO ENCODE ELEVATION (HSMSL) IN BUFR FORMAT FROM C ADPSFC DUMP FILE IN HEADER. C - ADDED ABILITY TO ENCODE THE CLOUD HEIGHT IN BUFR FORMAT FROM C THE ADPSFC DUMP FILE AND HANDLED HOCB AND HOCT WITH DIFFERENT C ATTRIBUTES. C - ADDED ABILITY TO ENCODE PRECIPTATION REPORTS IN BUFR FORMAT C FROM THE ADPSFC DUMP FILE. CONVERTED THE PRECIPITATION (TOPC) C INTO THE TAC FORMAT INCLUDING TP01, TP03, TP06, TP12, TP24 C AND DTHTOPC. C - ADDED ABILITY TO ENCODE MAX/MIN TEMPERATURE IN BUFR FORMAT C REPORTS FROM THE ADPSFC DUMP FILE. CONVERTED THE ATTRIBUTE C (TPHR) INTO .DTHMXTM/.DTHMITM IN TAC FORMAT. C - ADDED ABILITY TO ENCODE MAXIMUM GUST WIND SPD (MXGS) AND TPMI C IN BUFR FORMAT FROM THE ADPSFC DUMP FILE, AND CONVERTED TPMI C TO .DTMMXGS IN TAC FORMAT. C - ADDED ABILITY TO ENCODE HOVI REPORTS IN BUFR FORMAT FROM THE C ADPSFC DUMP FILE. CONVERT THE ATTRIBUTE (AOFV) OF HOVI TO THE C RELATIONSHIP (.REHOVI) IN VISBSEQN SEQUENCE. C - ADDED ABILITY TO ENCODE PAST WEATHER IN BUFR FORMAT FROM THE C ADPSFC DUMP FILE. ADDED TO READ THE TIME PERIOD OR DISPLACEMENT C (TPHR) FOR THE PAST WEATHER MEASUREMENTS. C 2020-09-14 S. Melchior -- In function R06UBF, added code to process C new WMO BUFR format Meteosat AMV data from subsets: 005067, C 005068, 005069. c 2020-10-15 JWhiting -- added trap to pull dump mnemonics specific to c BUFR feed buoy data streams so as to properly encode prepbufr c wave height & frequecy mnemonics (HOWV POWV). c 2021-03-30 JWhiting - C - Fixed ambiguity in trap for buoy SST values (msg types 102-3) C - Assigned input report type values of 524-5 to BUFR-feed ships c data, for named and unnamed obs, respectively (TAC-feeds remain c as 522-3). C - Assigned input report type value of 530 to BUFR-feed C-MAN C reports. C 2021-07-14 J. Dong -- In function R04UBF, added code to encode the C cloud data for the BUFR-feed ships data. C C C USAGE: II = IW3UNPBF(NUNIT, OBS, STNID, CRES1, CRES2, CBULL, OBS2, C OBS3, NOBS3, OBS8_8, DSNAME, IDSDAT, IDSDMP_8, C SUBSET_r, SUBSKP, IER) C INPUT ARGUMENT LIST: C NUNIT - FORTRAN UNIT NUMBER FOR SEQUENTIAL DATA SET CONTAINING C PACKED NCEP BUFR REPORTS (DUMP FILE) C DSNAME - CHARACTER*8 DATA SET NAME (ONLY READ WHEN INPUT ARG. C IER = -1, SEE BELOW) C IDSDAT - INTEGER DATA SET CENTER DATE IN FORM YYYYMMDDHH (ONLY C READ WHEN INPUT ARG. IER = -1, SEE BELOW) C IDSDMP_8 - INTEGER DATA SET DUMP TIME IN FORM YYYYMMDDHHMM (ONLY C READ WHEN INPUT ARG. IER = -1, SEE BELOW) C SUBSKP - TWO-DIMENSIONAL LOGICAL ARRAY WHERE ELEMENT 1 REFERS C TO A PARTICULAR BUFR TYPE (RANGE 0-255) AND ELEMENT 2 C REFERS TO A PARTICULAR BUFR SUBTYPE (RANGE 0-200). IF C SUBSKP IS SET TO TRUE FOR A PARTICULAR BUFR TYPE AND C SUBTYPE, THEN ANY BUFR MESSAGE OF THIS TYPE READ IN C WILL BE SKIPPED OVER {NO SUBSETS (REPORTS) WILL BE C DECODED OUT OF IT AND RETURNED TO THE CALLING PROGRAM, C INSTEAD THIS FUNCTION WILL MOVE ON TO READ THE NEXT C BUFR MESSAGE IN THE FILE AND AGAIN USE SUBSKP TO SEE C IF ANY SUBSETS SHOULD BE DECODED OUT OF IT}. THIS C ALLOWS THIS FUNCTION TO QUICKLY PASS BY ANY BUFR C MESSAGES WITH A TYPE/SUBTYPE THAT THE CALLING PROGRAM C DOES NOT WANT DECODED. THE LENGTH OF THIS ARRAY C SHOULD ALWAYS BE HARDWIRED TO (0:255,0:200). C SUBSET_r - CHARACTER*8 BUFR MESSAGE TYPE (ONLY READ WHEN INPUT C ARG. IER = -1, SEE BELOW) C IER - PRIOR TO INITIAL CALL TO THIS SUBROUTINE WITH A NEW C "NUNIT": IF =-1, INDICATES THAT THE FILE ASSOCIATED C WITH "NUNIT" HAS ALREADY BEEN OPENED BY THE C CORRESPONDING INTERFACE SUBROUTINE W3UNPKB7 AND C REPORTS HAVE BEEN PROCESSED, THIS ROUTINE WILL C CONTINUE READING AND PROCESSING REPORTS FROM "NUNIT"; C OTHERWISE IER SHOULD BE INPUT AS ZERO C C OUTPUT ARGUMENT LIST: C OBS - ARRAY CONTAINING ONE REPORT IN SPECIFIED UNPACKED C FORMAT. FORMAT IS MIXED, USER MUST EQUIVALENCE C INTEGER ARRAY TO THIS ARRAY (SEE REMARKS FOR UNPACKED C FORMAT) THE LENGTH OF THE ARRAY SHOULD BE AT LEAST C 3500 (NOTE: DOES NOT INCLUDE STATION ID, CHARACTER C RESERVE WORD 1, CHARACTER RESERVE WORD 2 AND CBULL) C STNID - CHARACTER*8 SINGLE REPORT STATION IDENTIFICATION (UP C TO 8 CHARACTERS, LEFT-JUSTIFIED) C (Note: For GOES-16 & up satellite winds, there is no C report id; this is hardwired as 8 dashes: C "--------". C CRES1 - CHARACTER*8 SINGLE REPORT CHARACTER RESERVE WORD 1 C (SEE DOCUMENTATION/COMMENTS IN THIS PROGRAM (VARIES BY C TYPE OF DATA) C CRES2 - CHARACTER*8 SINGLE REPORT CHARACTER RESERVE WORD 2 C (SEE DOCUMENTATION/COMMENTS IN THIS PROGRAM (VARIES BY C TYPE OF DATA) C CBULL - CHARACTER*11 STRING HOLDING WMO BULLETIN HEADER (CHAR. C 1-6) AND ORIGINATOR (CHAR. 8-11) (CHAR. 7 IS BLANK) C (Note: Currently only applies to aircraft reports, C this string is all blanks for all other types.) C OBS2 - 43-WORD ARRAY CONTAINING ADDITIONAL REPORT DATA NOT C PRESENT IN OBS ARRAY (DATA RESTRICTION INFO, C ALTIMETER SETTING, SST, SINGLE-LEVEL SENSIBLE WEATHER C ELEMENTS - STORED DIRECTLY FROM BUFR) (SEE REMARKS FOR C CONTENT) C OBS3 - (5,255,7)-WORD ARRAY CONTAINING ADDITIONAL REPORT DATA C NOT PRESENT IN OBS ARRAY (MULTIPLE-LEVEL SENSIBLE C WEATHER ELEMENTS STORED DIRECTLY FROM BUFR) (SEE C REMARKS FOR CONTENT) C NOBS3 - 7-WORD ARRAY CONTAINING NUMBER OF LEVELS OF DATA C IN THE OBS3(X,Y,1), OBS3(X,Y,2), OBS3(X,Y,3), C OBS3(X,Y,4), OBS3(X,Y,5), OBS3(X,Y,6) AND OBS3(X,Y,7) C ARRAYS (SEE REMARKS) C OBS8_8 - 2-WORD REAL*8 ARRAY CONTAINING ADDITIONAL REPORT DATA C (LATITUDE AND LONGITUDE) (SEE REMARKS FOR CONTENT) C DSNAME - CHARACTER*8 DATA SET NAME (SAME FOR ALL REPORTS IN C A COMMON INPUT DATA SET - SEE REMARKS FOR IER=1) C IDSDAT - INTEGER DATA SET CENTER DATE IN FORM YYYYMMDDHH (SAME C FOR ALL REPORTS IN A COMMON INPUT DATA SET - SEE C REMARKS FOR IER=1) C IDSDMP_8 - INTEGER DATA SET DUMP TIME IN FORM YYYYMMDDHHMM (SAME C FOR ALL REPORTS IN A COMMON INPUT DATA SET - SEE C REMARKS FOR IER=1) C SUBSET_r - CHARACTER*8 BUFR MESSAGE TYPE (SAME FOR ALL REPORTS C IN A COMMON BUFR MESSAGE) C IER - RETURN FLAG (EQUAL TO FUNCTION VALUE) - SEE REMARKS C C INPUT FILES: C UNIT AA - SEQUENTIAL NCEP BUFR DUMP FILE ("AA" IS UNIT NUMBER C SPECIFIED BY INPUT ARGUMENT "NUNIT") C C OUTPUT FILES: C UNIT 06 - PRINTOUT C C SUBPROGRAMS CALLED: C UNIQUE: - R01UBF R02UBF R03UBF R04UBF R05UBF C R06UBF R07UBF I02UBF I04UBF I05UBF C L01UBF L02UBF L03UBF S01UBF S02UBF C S03UBF S04UBF S05UBF SE01UBF MQMUBF C EQSUBF EQMUBF ERTUBF C01UBF WORDLENGTH C LIBRARY: C W3EMC - ORDERS C BUFRLIB - OPENBF CLOSBF DATELEN STATUS DUMPBF C READMG READSB UFBINT UFBREP NMSUB C UFBSEQ GETBMISS IBFMS CBFMS READLC C C REMARKS: C THE RETURN FLAGS IN IER (AND FUNCTION IW3UNPBF ITSELF) ARE: C = 0 OBSERVATION READ AND UNPACKED INTO LOCATIONS 'OBS', C 'STNID', 'CRES1', 'CRES2', 'CBULL', 'OBS2', 'OBS3', C 'OBS8_8', 'DSNAME', 'IDSDAT', AND 'IDSDMP_8'. SEE C REMARKS BELOW FOR CONTENTS. NEXT CALL TO IW3UNPBF C WILL RETURN NEXT OBSERVATION IN DATA SET. C = 1 INFORMATION ABOUT THE BUFR DATASET IS RETURNED IN C THE OUTPUT ARGUMENTS DSNAME, IDSDAT, IDSDMP_8 (SEE C OUTPUT ARGUMENT LIST ABOVE) C C THIS SHOULD ALWAYS OCCUR AFTER THE FIRST CALL TO C THIS SUBROUTINE. NO REPORT IS UNPACKED AT THIS C POINT, AND ONLY DSNAME, IDSDAT, AND IDSDMP_8 C CONTAIN INFORMATION. ALL SUBSEQUENT CALLS TO C IW3UNPBF SHOULD RETURN THE OBSERVATIONS IN THIS C DATA SET, SEQUENTIALLY, (IER=0) UNTIL THE END OF C FILE IS ENCOUNTERED (IER=2 OR 3). THE VALUES C STORED IN DSNAME, IDSDAT, AND IDSDMP_8 WILL C CONTINUE TO BE RETURNED ALONG WITH EACH REPORT C WHEN IER = 0. C = 2 THE PHYSICAL END OF FILE IS ENCOUNTERED (THIS IS C FOR A VALID NCEP BUFR DUMP FILE CONTAINING C REPORTS). ALL DONE. C = 3 THIS IS AN EMPTY (NULL) FILE. ALL DONE. C = 999 ERROR: EITHER FILE IS NOT NCEP BUFR, ERROR READING C FILE, CENTER DATE DUMMY MESSAGE NOT FOUND AT C TOP OF NCEP BUFR DUMP FILE, OR SOME OTHER C PROBLEM IN DECODING ONE OR MORE REPORTS IN AN C NCEP BUFR DUMP FILE. C NO USEFUL INFORMATION IN 'OBS', 'STNID', 'CRES1', C 'CRES2', 'CBULL', 'OBS2', 'OBS3', 'OBS8_8', 'DSNAME', C 'IDSDAT', AND 'IDSDMP_8' ARRAYS. CALLING PROGRAM C CAN CHOOSE TO STOP WITH NON-ZERO CONDITION CODE OR C RESET 'NUNIT' TO POINT TO A NEW DATA SET (IN WHICH C CASE NEXT CALL TO IW3UNPBF SHOULD RETURN WITH C IER=1). C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C CONTENTS OF AN UNPACKED REPORT IN THE "OBS" ARRAY C {MISSING INTEGER DATA ARE SET TO IMISS (99999); C MISSING REAL DATA ARE SET TO XMISS (99999.)} C C (NOTE: DOES NOT INCLUDE STATION IDENTIFICATION, CHARACTER RESERVE C WORD 1, CHARACTER RESERVE WORD 2, "CBULL", "OBS2" AND C "OBS3" ARRAY OUTPUT; LATITUDE AND LONGITUDE IN OBS(1:2) ARE C ALSO OUTPUT IN REAL*8 IN "OBS8_8" - SEE OUTPUT ARGUMENTS C "STNID", "CRES1", "CRES2" AND "CBULL" ABOVE AND "OBS2", C "OBS3" AND "OBS8_8" CONTENTS BELOW) C C *************************************************************** C WORD CONTENT UNIT FORMAT C ---- ---------------------- ------------------- --------- C 1 LATITUDE DEGREES (N+,S-) REAL C 2 LONGITUDE DEGREES EAST REAL C 3 NOT USED MISSING REAL C 4 OBSERVATION TIME HOURS (UTC) REAL C 5 NOT USED MISSING REAL C 6 SATELLITE ID (BUFR CODE TABLE 0-01-007) INTEGER C (SEE @) C 7 STATION ELEVATION METERS REAL C 8 INSTRUMENT TYPE (SEE $) INTEGER C 9 DUMP REPORT TYPE (SEE &) INTEGER C 10 DUMP REPORT SUBTYPE (SEE %) INTEGER C 11 RECEIPT TIME HOURS (UTC) REAL C 12 STATION ELEVATION (BUFR CODE TABLE 0-33-024) REAL C QUALITY MARK (SEE #) C C 13 CATEGORY 1, NO. LEVELS COUNT INTEGER C 14 CATEGORY 1, DATA INDEX COUNT INTEGER C 15 CATEGORY 2, NO. LEVELS COUNT INTEGER C 16 CATEGORY 2, DATA INDEX COUNT INTEGER C 17 CATEGORY 3, NO. LEVELS COUNT INTEGER C 18 CATEGORY 3, DATA INDEX COUNT INTEGER C 19 CATEGORY 4, NO. LEVELS COUNT INTEGER C 20 CATEGORY 4, DATA INDEX COUNT INTEGER C 21 CATEGORY 5, NO. LEVELS COUNT INTEGER C 22 CATEGORY 5, DATA INDEX COUNT INTEGER C 23 CATEGORY 6, NO. LEVELS COUNT INTEGER C 24 CATEGORY 6, DATA INDEX COUNT INTEGER C 25 reserved 0 INTEGER C 26 reserved 0 INTEGER C 27 CATEGORY 8, NO. LEVELS COUNT INTEGER C 28 CATEGORY 8, DATA INDEX COUNT INTEGER C 29 CATEGORY 51, NO. LEVELS COUNT INTEGER C 30 CATEGORY 51, DATA INDEX COUNT INTEGER C 31-52 ZEROED OUT - NOT USED INTEGER C C 53-END UNPACKED DATA GROUPS (SEE BELOW) MIXED C C @ - WORD 6, SATELLITE ID, IS CURRENTLY SET TO MISSING FOR C ALL TYPES EXCEPT: C SATELLITE WIND (DUMP REPORT TYPE 63) C SSM/I (NON-SUPEROBED ONLY: ALL TYPES, DUMP REPORT C TYPES 65,66,68,69,571,573-577) C $ - WORD 8, INSTRUMENT TYPE, IS CURRENTLY SET TO MISSING FOR C ALL TYPES EXCEPT: C UPPER-AIR (ADPUPA) (DUMP REPORT TYPES 11-13, 22, 23, C 31): C Radiosonde type - see BUFR CODE TABLE 0-02-011 C SATELLITE-DERIVED WIND (SATWND) (DUMP REPORT TYPE 63): C NESDIS satellite wind type C 0 Reserved C 1 IR (long-wave) automated winds (low density) C 2 IR (long-wave) manual winds C 3 Picture triplet (low density) C 4 Water vapor automated (low density) C 5 Visible manual C 6 Visible automated (low density) C 7 Gradient winds C 8 Picture pair C 9 Reserved C 10 AMSU/SSMI microwave winds C 11 Scatterometer C 12 Altimeter C 13 LAWS C 14 High-density water vapor sounder, channel 10 C 15 High-density water vapor sounder, channel 11 C 16 High-density IR (long-wave) imager automated winds C 17 High-density visible imager automated winds C 18 High-density water vapor imager C 19 High-density IR (short-wave) imager automated winds C 20-254 Reserved for future use C 255 Missing value C AIRCRAFT (AIRCFT) (DUMP REPORT TYPE 41): C 0-96 Reserved C 97 Inertial navigation system C 98 OMEGA C 99-254 Reserved C 255 Missing value C % - WORD 10, REPORT SUBTYPE, IS CURRENTLY SET TO MISSING FOR C ALL TYPES EXCEPT: C AIRCRAFT (DUMP REPORT TYPE 41), WHERE: C = 1 - AIREP FORMAT AIRCRAFT C = 2 - PIREP FORMAT AIRCRAFT C = 3 - AMDAR FORMAT ASDAR/ACARS AIRCRAFT C = 4 - MDCRS ACARS AIRCRAFT (ARINC -> NCEP) C = 6 - E-AMDAR AIRCRAFT {EUROPEAN AMDAR (ASDAR/ACARS) C DATA ORIGINALLY IN BUFR} C = 7 - MDCRS ACARS AIRCRAFT (ARINC -> AFWA -> NCEP) C = 8 - MADIS/TAMDAR-Mesaba AIRCRAFT C = 9 - CANADIAN AMDAR AIRCRAFT (ASDAR/ACARS DATA C ORIGINALLY IN BUFR) C = 10 - TAMDAR {FROM PANASONIC(AirDAT), DATA ORIGINALLY C IN BUFR}, HEREAFTER REFERRED TO AS TAMDARB C = 11 - KOREAN AMDAR AIRCRAFT (DATA ORIGINALLY IN BUFR) C = 12 - MADIS/TAMDAR-PenAir AIRCRAFT C = 13 - MADIS/TAMDAR-Chautauqua AIRCRAFT C = 103 - CATCH-ALL AMDAR AIRCRAFT (DATA ORIGINALLY IN C BUFR) C RECONNAISSANCE/DROPWINSONDE (DUMP REPORT TYPE 31), WHERE: C = 1 - RECONNAISSANCE AIRCRAFT C = 2 - DROPWINSONDE C # - WORD 12, STATION ELEVATION QUALITY MARK, IS CURRENTLY SET TO C MISSING FOR ALL TYPES EXCEPT MOBILE LAND SURFACE (SYNOPTIC) C (DUMP REPORT TYPE 514) C C & - DUMP REPORT TYPES: C 011 - Fixed land RAOB and PIBAL by block and station C number C 012 - Fixed land RAOB and PIBAL by call letters C 013 - Mobile land RAOB, including CLAS soundings C 022 - Ship RAOB with name C 023 - Ship RAOB without name (report id set to "SHIP") C 031 - Reconnaissance aircraft or dropwinsonde C 041 - Aircraft flight-level (all types) C 063 - Satellite-derived winds C 065 - SSM/I total precipitable water (ocean) C 066 - SSM/I rain rate C 068 - SSM/I brightness temperatures C 069 - SSM/I cloud water (ocean) C 073 - Wind profiler originating from PILOT (PIBAL) format C bulletins (mainly tropical and European) C 511 - Fixed land surface by block and station number C (synoptic, both unrestricted & restricted WMO Res. 40) C 512 - Fixed land surface by call letters (METAR) C 514 - Mobile land surface (synoptic) C 522 - TAC format Ship with name C 523 - TAC format Ship w/o name (report id set to "SHIP") C 524 - FM94/BUFR format Ship with name C 525 - FM94/BUFR format Ship w/o name (rpt id set to "SHIP") C 530 - C-MAN platform (BUFR-feed data stream) C 531 - C-MAN platform (TAC-feed data stream) C 532 - Tide gauge C 534 - Coast Guard Tide gauge C 540 - Mesonet surface C 551 - Sea-level pressure bogus C 561 - Buoy data arriving in WMO FM13 format (fixed); C 562 - Buoy data arriving in WMO FM18 format (fixed or drifting); C 563 - Buoy data arriving in WMO FM94 format (fixed); C 564 - Buoy data arriving in WMO FM94 format (fixed? or drifting); C 571 - SSM/I wind speed (ocean) C 573 - SSM/I soil moisture C 574 - SSM/I snow depth C 575 - SSM/I additional products (surface tag, ice C concentration, ice age, ice edge, calculated C surface type) C 576 - SSM/I surface (skin) temperature C 577 - SSM/I sea surface temperature C C C C C *************************************************************** C C C DATA ARE UNPACKED INTO FIXED LOCATIONS IN WORDS 1-12 AND INTO C INDEXED LOCATIONS IN WORD 53 AND FOLLOWING. THE VERTICAL C SIGNIFICANCE DESCRIPTOR FOR EACH LEVEL IN THE BUFR REPORT IS C USED TO UNPACK THE LEVEL INTO THE "DATA LEVEL CATEGORIES" C DESCRIBED BELOW. EACH DATA LEVEL CATEGORY HAS A LAYOUT IN C LOCATIONS IN ARRAY OBS THAT MAY BE FOUND BY USING THE C CORRESPONDING INDEX AMOUNT FROM WORDS 14, 16, ..., 34, IN C ARRAY OBS. FOR INSTANCE, IF A REPORT IS UNPACKED INTO ONE OR C MORE CATEGORY 3 DATA LEVEL GROUPS (WIND DATA AT VARIABLE C PRESSURE LEVELS) THAT DATA WILL BE SPECIFIED IN THE UNPACKED C BINARY FORMAT AS DESCRIBED BELOW UNDER DATA LEVEL CATEGORY 3. C THE NUMBER OF LEVELS WILL BE STORED IN WORD 17 OF OBS AND THE C INDEX OF THE FIRST LEVEL OF UNPACKED DATA IN THE OUTPUT ARRAY C WILL BE STORED IN WORD 18. THE SECOND LEVEL, IF ANY, WILL BE C STORED BEGINNING SIX WORDS FURTHER ON, AND SO FORTH UNTIL THE C COUNT IN WORD 17 IS EXHAUSTED. THE FIELD LAYOUT IN EACH DATA C LEVEL CATEGORY IS GIVEN BELOW... C C DATA LEVEL CATEGORY 1 - MANDATORY LEVEL DATA C WORD PARAMETER UNITS FORMAT C ---- --------- ----------------- ------------- C 1 PRESSURE 0.1 MILLIBARS REAL C 2 GEOPOTENTIAL METERS REAL C 3 TEMPERATURE 0.1 DEGREES C REAL C 4 DEWPOINT DEPRESSION 0.1 DEGREES C REAL C 5 WIND DIRECTION DEGREES REAL C 6 WIND SPEED 0.1 METERS/SEC REAL C 7 PRES. QUALITY MARKER (SEE $) REAL C 8 GEOP. QUALITY MARKER (SEE $) REAL C 9 TEMP. QUALITY MARKER (SEE $) REAL C 10 DDPR. QUALITY MARKER (SEE $) REAL C 11 WIND QUALITY MARKER (SEE $) REAL C C DATA LEVEL CATEGORY 2 - TEMPERATURE AT VARIABLE PRESSURE C WORD PARAMETER UNITS FORMAT C ---- --------- ----------------- ------------- C 1 PRESSURE 0.1 MILLIBARS REAL C 2 TEMPERATURE 0.1 DEGREES C REAL C 3 DEWPOINT DEPRESSION 0.1 DEGREES C REAL C 4 PRES. QUALITY MARKER (SEE $) REAL C 5 TEMP. QUALITY MARKER (SEE $) REAL C 6 DDPR. QUALITY MARKER (SEE $) REAL C 7 SPECIAL INDICATOR (SEE $$) REAL C C DATA LEVEL CATEGORY 3 - WINDS AT VARIABLE PRESSURE C WORD PARAMETER UNITS FORMAT C ---- --------- ----------------- ------------- C 1 PRESSURE 0.1 MILLIBARS REAL C 2 WIND DIRECTION DEGREES REAL C 3 WIND SPEED 0.1 METERS/SEC REAL C 4 PRES. QUALITY MARKER (SEE $) REAL C 5 WIND QUALITY MARKER (SEE $) REAL C 6 SPECIAL INDICATOR (SEE $$$) REAL C C DATA LEVEL CATEGORY 4 - WINDS AT VARIABLE HEIGHTS C WORD PARAMETER UNITS FORMAT C ---- --------- ----------------- ------------- C 1 GEOPOTENTIAL METERS REAL C 2 WIND DIRECTION DEGREES REAL C 3 WIND SPEED 0.1 METERS/SEC REAL C 4 GEOP. QUALITY MARKER (SEE $) REAL C 5 WIND QUALITY MARKER (SEE $) REAL C C DATA LEVEL CATEGORY 5 - TROPOPAUSE DATA C WORD PARAMETER UNITS FORMAT C ---- --------- ----------------- ------------- C 1 PRESSURE 0.1 MILLIBARS REAL C 2 TEMPERATURE 0.1 DEGREES C REAL C 3 DEWPOINT DEPRESSION 0.1 DEGREES C REAL C 4 WIND DIRECTION DEGREES REAL C 5 WIND SPEED 0.1 METERS/SEC REAL C 6 PRES. QUALITY MARKER (SEE $) REAL C 7 TEMP. QUALITY MARKER (SEE $) REAL C 8 DDPR. QUALITY MARKER (SEE $) REAL C 9 WIND QUALITY MARKER (SEE $) REAL C C DATA LEVEL CATEGORY 6 - CONSTANT-LEVEL DATA (AIRCRAFT, C SATELLITE-DERIVED WIND) C WORD PARAMETER UNITS FORMAT C ---- --------- ----------------- ------------- C 1 PRESSURE 0.1 MILLIBARS REAL C 2 PRESSURE ALTITUDE METERS REAL C 3 TEMPERATURE 0.1 DEGREES C REAL C 4 SPECIFIC HUMIDITY G/KG REAL C 5 WIND DIRECTION DEGREES REAL C 6 WIND SPEED 0.1 METERS/SEC REAL C 7 PRES. QUALITY MARKER (SEE $) REAL C 8 P-ALT QUALITY MARKER (SEE $) REAL C 9 TEMP. QUALITY MARKER (SEE $) REAL C 10 S-HUM QUALITY MARKER (SEE $) REAL C 11 WIND QUALITY MARKER (SEE $) REAL C C DATA LEVEL CATEGORY 8 - ADDITIONAL DATA C WORD PARAMETER UNITS FORMAT C ---- --------- ----------------- ------------- C 1 VARIABLE SPEPIFIED (SEE &) REAL C BY CODE FIGURE C 2 CODE FIGURE (SEE &) REAL C 3 INDICATOR 1 (SEE &) REAL C 4 INDICATOR 2 (SEE &) REAL C C DATA LEVEL CATEGORY 51 - SURFACE DATA C WORD PARAMETER UNITS FORMAT C ---- --------- ----------------- ------------- C 1 SEA-LEVEL PRESSURE 0.1 MILLIBARS REAL C 2 STATION PRESSURE 0.1 MILLIBARS REAL C 3 WIND DIRECTION DEGREES REAL C 4 WIND SPEED 0.1 METERS/SEC REAL C 5 AIR TEMPERATURE 0.1 DEGREES C REAL C 6 DEWPOINT DEPRESSION 0.1 DEGREES C REAL C 7 reserved XMISS REAL C 8 reserved XMISS REAL C 9 MSL-P QUALITY MARKER (SEE $) REAL C 10 STN-P QUALITY MARKER (SEE $) REAL C 11 WIND QUALITY MARKER (SEE $) REAL C 12 ATEMP QUALITY MARKER (SEE $) REAL C 13 DDPR. QUALITY MARKER (SEE $) REAL C C $ - QUALITY MARKER CODE TABLE: C 0. - MONITOR KEEP C 1. - GOOD C 2. - NEUTRAL OR NOT CHECKED (DEFAULT) C 3. - SUSPECT C 4. - GOOD - CORRECTED BY O.P.C. (SURFACE MARINE ONLY) C 12. - REJECT LIST, DO NOT USE C 13. - FAILED AUTOMATIC Q.C. TESTS, DO NOT USE C 14. - MONITOR PURGE, DO NOT USE C C $$ - DATA LEVEL CATEGORY 2 SPECIAL INDICATOR: C 0. - NOTHING INDICATED (DEFAULT) C 4. - LEVEL PRESSURE ESTIMATED C C $$$ - DATA LEVEL CATEGORY 3 SPECIAL INDICATOR: C 0. - NOTHING INDICATED (DEFAULT) C 1. - TROPOPAUSE LEVEL C 2. - MAXIMUM WIND LEVEL C 3. - MAXIMUM WIND LEVEL AT TERMINATING LEVEL C 4. - LEVEL PRESSURE ESTIMATED C C & - DATA LEVEL CATEGORY 8 CODE FIGURE: C 003 - DIFFUSE SOLAR RADIATION IN 100.*JOULE/M**2 C INDICATOR 2 CONTAINS TIME PERIOD OVER WHICH C RADIATION WAS INTEGRATED (MINUTES) C 004 - DIRECT SOLAR RADIATION IN 100.*JOULE/M**2 C INDICATOR 2 CONTAINS TIME PERIOD OVER WHICH C RADIATION WAS INTEGRATED (MINUTES) C 005 - QUALITY MARKER FOR TOTAL PRECIP. OVER 1-HR C (see $ above) C 006 - QUALITY MARKER FOR TOTAL PRECIP. OVER 24-HR C (see $ above) C 020 - QUALITY MARKER FOR ALTIMETER SETTING C (see $ above) C 021 - REPORT SEQUENCE NUMBER C 104 - RELEASE TIME IN .01*HR C 105 - RECEIPT TIME IN .01*HR C INDICATOR 1 CONTAINS RECEIPT TIME SIGNIFICANCE C (BUFR CODE TABLE 0-08-202, DEFINED IN THIS CODE) C 189 - SSM/I 19 GHZ V BRIGHT. TEMP (DEG K TO 10**2 PRECISION) C (FOR SUPEROBS THIS IS MEAN AND INDICATOR 1 IS C STANDARD DEVIATION IN SAME UNITS) C 190 - SSM/I 19 GHZ H BRIGHT. TEMP (DEG K TO 10**2 PRECISION) C (FOR SUPEROBS THIS IS MEAN AND INDICATOR 1 IS C STANDARD DEVIATION IN SAME UNITS) C 191 - SSM/I 22 GHZ V BRIGHT. TEMP (DEG K TO 10**2 PRECISION) C (FOR SUPEROBS THIS IS MEAN AND INDICATOR 1 IS C STANDARD DEVIATION IN SAME UNITS) C 192 - SSM/I 37 GHZ V BRIGHT. TEMP (DEG K TO 10**2 PRECISION) C (FOR SUPEROBS THIS IS MEAN AND INDICATOR 1 IS C STANDARD DEVIATION IN SAME UNITS) C 193 - SSM/I 37 GHZ H BRIGHT. TEMP (DEG K TO 10**2 PRECISION) C (FOR SUPEROBS THIS IS MEAN AND INDICATOR 1 IS C STANDARD DEVIATION IN SAME UNITS) C 194 - SSM/I 85 GHZ V BRIGHT. TEMP (DEG K TO 10**2 PRECISION) C (FOR SUPEROBS THIS IS MEAN AND INDICATOR 1 IS C STANDARD DEVIATION IN SAME UNITS) C 195 - SSM/I 85 GHZ H BRIGHT. TEMP (DEG K TO 10**2 PRECISION) C (FOR SUPEROBS THIS IS MEAN AND INDICATOR 1 IS C STANDARD DEVIATION IN SAME UNITS) C 196 - SSM/I OCEANIC WIND SPEED (M/SEC TO 10**1 PRECISION) C (FOR SUPEROBS THIS IS MEAN AND INDICATOR 1 IS C STANDARD DEVIATION IN SAME UNITS) C INDICATOR 2 IS RAIN FLAG (BUFR CODE TABLE 0-33-217) C 197 - SSM/I TOTAL PRECIPITABLE WATER (MM TO 10**1 PRECISION) C (FOR SUPEROBS THIS IS MEAN AND INDICATOR 1 IS C STANDARD DEVIATION IN SAME UNITS) C INDICATOR 2 IS RAIN FLAG (BUFR CODE TABLE 0-33-217) C 198 - RAINFALL RATE (MM/SEC, TO 10**6 PRECISION FOR SSM/I C AND TO 10**4 PRECISION FOR ALL OTHER DATA TYPES) C (FOR SSM/I SUPEROBS THIS IS MEAN AND INDICATOR 1 IS C STANDARD DEVIATION IN SAME UNITS) C INDICATOR 2 CONTAINS RAINFALL RATE QUALITY MARKER C 199 - SSM/I SURFACE TEMP. (DEG. KELVIN TO 10**2 PRECISION) C (FOR SUPEROBS THIS IS MEAN AND INDICATOR 1 IS C STANDARD DEVIATION IN SAME UNITS) C 200 - SSM/I CLOUD WATER (MM * 100) C (FOR SUPEROBS THIS IS MEAN AND INDICATOR 1 IS C STANDARD DEVIATION IN SAME UNITS) C 201 - SSM/I SOIL MOISTURE (MM) C (FOR SUPEROBS THIS IS MEAN AND INDICATOR 1 IS C STANDARD DEVIATION IN SAME UNITS) C 202 - SSM/I SNOW DEPTH (MM) C (FOR SUPEROBS THIS IS MEAN AND INDICATOR 1 IS C STANDARD DEVIATION IN SAME UNITS) C 203 - SSM/I SEA-SURFACE TEMP. (DEG. K TO 10**2 PRECISION) C (FOR SUPEROBS THIS IS MEAN AND INDICATOR 1 IS C STANDARD DEVIATION IN SAME UNITS) C 210 - SSM/I SURFACE TAG -- C 0 - land C 1 - vegitation covered land C 2 - near coast C 3 - multiyear ice C 4 - possible ice C 5 - ocean C 6 - coast C 211 - SSM/I ICE CONCENTRATION (PERCENT) C 212 - SSM/I ICE AGE -- C 0 - first year ice C 1 - multiyear ice C 213 - SSM/I ICE EDGE -- C 0 - no edge present C 1 - edge present C 214 - SSM/I CALCULATED SURFACE TYPE -- C 1 - vegetation C 2 - RESERVED C 3 - ice C 4 - RESERVED C 5 - ocean C 6 - coast C 7 - flooded condition C 8 - dense vegetation C 9 - dense agriculture crops C 10 - dry arable soil C 11 - moist soil C 12 - semi-arid surface C 13 - desert C 14 - precipitation over vegetation C 15 - precipitation over soil C 16 - composite vegetation-water C 17 - compostite soil-water-wet soil C 18 - dry snow C 19 - wet snow C 20 - refrozen snow C 250-262 - RESERVED FOR W3UNPKB7 C 351 - GEOPOTENTIAL HEIGHT (METERS) C INDICATOR 1 IS PRESSURE LEVEL (MB) C INDICATOR 2 CONTAINS GEOPOTENTIAL QUALITY MARKER C 352 - MEAN-SEA LEVEL PRESSURE IN 0.1*MB C 353 - SOLAR AND INFRARED RADIATION CORRECTION INDICATOR C (BUFR CODE TABLE 0-02-013) C 354 - TRACKING TECHNIQUE/STATUS OF SYSTEM USED INDICATOR C (BUFR CODE TABLE 0-02-014) C 355 - PERCENT CONFIDENCE BASED ON NESDIS RECURSIVE FILTER C FUNCTION (SATELLITE WINDS) (%) C (BUFR CODE TABLE 0-33-196) C 356 - PERCENT CONFIDENCE BASED ON EUMETSAT QUALITY INDEX C WITH FORECAST CONSISTENCY TEST (SATELLITE WINDS) C (%) (BUFR CODE TABLE 0-33-197) C 357 - PERCENT CONFIDENCE BASED ON EUMETSAT QUALITY INDEX C WITHOUT FORECAST CONSISTENCY TEST (SATELLITE WINDS) C (%) (BUFR CODE TABLE 0-33-198) C 358 - PERCENT CONFIDENCE BASED ON NESDIS EXPECTED ERROR C (SATELLITE WINDS) (%) (BUFR CODE TABLE 0-33-203) C 914 - AMDAR FORMAT, MDCRS ACARS, E-AMDAR OR CANADIAN AMDAR C AIRCRAFT PHASE OF FLIGHT (BUFR CODE TABLE 0-08-004) C 915 - AMDAR FORMAT, MDCRS ACARS. E-AMDAR OR CANADIAN AMDAR C AIRCRAFT PRECISION OF TEMPERATURE OBSERVATION IN C 0.01*DEG. K C 926 - MDCRS ACARS TURBULENCE INDEX FOR PERIOD T-1 MINUTE TO C T-0 MINUTES (BUFR CODE TABLE 0-11-236) C 927 - MDCRS ACARS TURBULENCE INDEX FOR PERIOD T-2 MINUTE TO C T-1 MINUTES (BUFR CODE TABLE 0-11-237) C 928 - MDCRS ACARS TURBULENCE INDEX FOR PERIOD T-3 MINUTE TO C T-2 MINUTES (BUFR CODE TABLE 0-11-238) C 929 - MDCRS ACARS TURBULENCE INDEX FOR PERIOD T-4 MINUTE TO C T-3 MINUTES (BUFR CODE TABLE 0-11-239) C 930 - TAMDAR TURBULENCE INDEX (BUFR CODE TABLE 0-11-235) C INDICATOR 2 CONTAINS TURBULENCE INDEX QUALITY MARKER C (0-15) C 931 - TAMDAR ROLL ANGLE FLAG (BUFR CODE TABLE 0-02-199) C 932 - INSTANTANEOUS ALTITUDE RATE IN .001*METERS/SECOND C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C CONTENTS OF UNPACKED REPORT DATA IN THE "OBS2" ARRAY C (ALL VALUES IN REAL FORMAT) C (MISSING DATA ARE SET TO "BMISS") C C *************************************************************** C WORD CONTENT UNIT C ---- -------------------------------- ------------------- C 1 RESTRICTIONS ON REDISTRIBUTION BUFR FLAG TBL "0 35 200" C 2 EXPIRATION OF RESTRICTIONS ON HOURS C REDISTRIBUTION C 3 ALTIMETER SETTING PASCALS C 4 SEA-SURFACE TEMPERATURE KELVIN C 5 DEPTH AT WHICH SEA-SURFACE METERS C TEMPERATURE MEASURED C 6 METHOD OF SEA SURFACE TEMPERATURE BUFR CODE TBL "0 02 038" C MEASUREMENT C 7 RELATIONSHIP TO HORIZONTAL BUFR CODE TBL "0 08 201" C VISIBILITY C 8 HORIZONTAL VISIBILITY METERS C 9 VERTICAL VISIBILITY METERS C 10 PAST WEATHER - 1 BUFR CODE TBL "0 20 004" C 11 PAST WEATHER - 2 BUFR CODE TBL "0 20 005" C 12 PEAK WIND SPEED METERS/SEC C 13 PEAK WIND DIRECTION DEGREES C 14 DURATION OF TIME FOR MAXIMUM MINUTES C WIND SPEED (GUST) C 15 MAXIMUM WIND SPEED (GUST) METERS/SEC C 16 MAXIMUM WIND GUST DIRECTION DEGREES C 17 TOTAL PRECIPITATION PAST 1-HR KG/METERS**2 C 18 TOTAL PRECIPITATION PAST 3-HR KG/METERS**2 C 19 TOTAL PRECIPITATION PAST 6-HR KG/METERS**2 C 20 TOTAL PRECIPITATION PAST 12-HR KG/METERS**2 C 21 TOTAL PRECIPITATION PAST 24-HR KG/METERS**2 C 22 TOTAL SUNSHINE MINUTES C 23 TOTAL CLOUD COVER PERCENT C 24 HEIGHT ABOVE SURFACE OF BASE OF BUFR CODE TBL "0 20 201" C LOWEST CLOUD SEEN C 25 10 METER EXTRAPOLATED WIND SPEED METERS/SEC C 26 20 METER EXTRAPOLATED WIND SPEED METERS/SEC C 27 SURFACE WIND DIRECTION DEGREES C 28 SURFACE WIND SPEED METERS/SEC C 29 DURATION OF TIME FOR DEPTH OF HOURS C FRESH SNOW C 30 DEPTH OF FRESH SNOW METERS C 31 TOTAL SNOW DEPTH METERS C 32 HEIGHT OF WAVES METERS C 33 PERIOD OF WAVES SECONDS C 34 HEIGHT OF WIND WAVES METERS C 35 PERIOD OF WIND WAVES SECONDS C 36 TRUE DIRECTION OF SHIP PAST 3-HRS BUFR CODE TBL "0 01 193" C 37 AVERAGE SPEED OF SHIP PAST 3-HRS BUFR CODE TBL "0 01 200" C 38 CHARACTERISTIC OF PRESSURE BUFR CODE TBL "0 10 063" C TENDENCY C 39 03-HOUR PRESSURE CHANGE PASCALS C 40 24-HOUR PRESSURE CHANGE PASCALS C 41 SEA-SURFACE TEMPERATURE Q. MARK BUFR CODE TBL "0 22 246" C (HARDWIRED TO 2 IF SST C NON-MISSING, ELSE TO C MISSING IF SST MISSING) C 42 MOISTURE QUALITY BUFR CODE TBL "0 33 026" C 43 SATELLITE ZENITH ANGLE DEGREES C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C CONTENTS OF UNPACKED REPORT DATA IN THE "OBS3" ARRAY C (ALL VALUES IN REAL FORMAT) C (MISSING DATA OR UNUSED VALUES ARE SET TO "BMISS") C C *************************************************************** C C OBS3(X,Y,1) ON LEVELS ("Y") 1 THROUGH NOBS3(1) C C WORD CONTENT UNIT C (X) C ---- -------------------------------- ------------------- C 1 DURATION OF TIME FOR TOTAL HOURS C PRECIPITATION MEASURMENT C 2 TOTAL PRECIPITATION MEASUREMENT KG/METERS**2 C C C OBS3(X,Y,2) ON LEVELS ("Y") 1 THROUGH NOBS3(2) C C WORD CONTENT UNIT C (X) C ---- -------------------------------- ------------------- C 1 PRESENT WEATHER BUFR CODE TBL "0 20 003" C C C OBS3(X,Y,3) ON LEVELS ("Y") 1 THROUGH NOBS3(3) C C WORD CONTENT UNIT C (X) C ---- -------------------------------- ------------------- C 1 VERTICAL SIGNIFICANCE (SURFACE BUFR CODE TBL "0 08 002" C OBSERVATION) C 2 CLOUD AMOUNT BUFR CODE TBL "0 20 011" C 3 CLOUD TYPE BUFR CODE TBL "0 20 012" C 4 HEIGHT OF BASE OF CLOUD METERS C 5 HEIGHT OF TOP OF CLOUD METERS C C C OBS3(X,Y,4) ON LEVELS ("Y") 1 THROUGH NOBS3(4) C C WORD CONTENT UNIT C (X) C ---- -------------------------------- ------------------- C 1 DURATION OF TIME FOR MAXIMUM HOURS C TEMPERATURE C 2 MAXIMUM TEMPERATURE KELVIN C 3 DURATION OF TIME FOR MINIMUM HOURS C TEMPERATURE C 4 MINIMUM TEMPERATURE KELVIN C C C OBS3(X,Y,5) ON LEVELS ("Y") 1 THROUGH NOBS3(5) C C WORD CONTENT UNIT C (X) C ---- -------------------------------- ------------------- C 1 DIRECTION OF SWELL WAVES DEGREES C 2 HEIGHT OF SWELL WAVES METERS C 3 PERIOD OF SWELL WAVES SECONDS C C C OBS3(X,Y,6) ON LEVELS ("Y") 1 THROUGH NOBS3(6) C C WORD CONTENT UNIT C (X) C ---- -------------------------------- ------------------- C 1 AIRFRAME ICING BUFR CODE TBL "0 20 041" C 2 HEIGHT OF BASE OF ICING METERS C 3 HEIGHT OF TOP OF ICING METERS C C C OBS3(X,Y,7) ON LEVELS ("Y") 1 THROUGH NOBS3(7) C C WORD CONTENT UNIT C (X) C ---- -------------------------------- ------------------- C 1 DEGREE OF TURBULENCE BUFR CODE TBL "0 11 031" C 2 HEIGHT OF BASE OF TURBULENCE METERS C 3 HEIGHT OF TOP OF TURBULENCE METERS C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C CONTENTS OF UNPACKED REPORT DATA IN THE "OBS8_8" ARRAY C (ALL VALUES IN REAL*8 FORMAT) C (MISSING DATA ARE SET TO "BMISS") C C *************************************************************** C WORD CONTENT UNIT C ---- -------------------------------- ------------------- C 1 LATITUDE DEGREES (N+,S-) C 2 LONGITUDE DEGREES (E+,W-) C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ FUNCTION IW3UNPBF(LUNIT,OBS,STNID,CRES1,CRES2,CBULL,OBS2,OBS3, $ NOBS3,obs8_8,DSNAME,IDSDAT,IDSDMP_8,SUBSET_r,SUBSKP,IER) PARAMETER (NUMCAT=8, LEVLIM=300) COMMON/IUBFAA/BMISS COMMON/IUBFBB/KNDX,KSKACF(8),KSKUPA,KSKSFC,KSKSAT,KFLSAT(12), $ KSKSMI COMMON/IUBFCC/SUBSET COMMON/IUBFDD/HDR(12),RCATS(50,LEVLIM,NUMCAT),IKAT(NUMCAT), $ MCAT(NUMCAT),NCAT(NUMCAT),LVDX(NUMCAT) COMMON/IUBFEE/ROBS(255,9) COMMON/IUBFFF/QMS(255,5) COMMON/IUBFGG/SFO(6) COMMON/IUBFHH/SFQ(5) COMMON/IUBFII/PWMIN COMMON/IUBFJJ/ISET,MANLIN(1001) COMMON/IUBFKK/KOUNT(499,18,2),KNTSAT(250:260),KNTMODIS(783:785), $ KNTavhrr(3:224),KNTviirs(224:225),IFLSAT,knts16(270:274) COMMON/IUBFLL/Q8(255,2) COMMON/IUBFMM/XIND(255) COMMON/IUBFNN/STNIDX,CRES1X,CRES2X COMMON/IUBFOO/DSNAMX,IDSDAX_8,IDSDMX_8 COMMON/IUBFPP/LWI,LWR COMMON/IUBFQQ/NPRINT(0:255,0:200) COMMON/IUBFRR/IDATEB COMMON/IUBFSS/CBULLX DIMENSION OBS(*),OBS2(43),OBS3(5,255,7),NOBS3(7),JWFILE(100) dimension istart(3),iend(3) CHARACTER*8 STNID,STNIDX,CRES1,CRES1X,CRES2,CRES2X,DSNAME,DSNAMX, $ SUBSET_r,SUBSET CHARACTER*11 CBULL,CBULLX INTEGER(8) IDSDMP_8,IDSDAX_8,IDSDMX_8 REAL(8) BMISS,GETBMISS,obs8_8(2) LOGICAL SUBSKP(0:255,0:200) SAVE DATA JWFILE/100*0/,LASTF/0/,ITIMES/0/ data istart/3,200,223/,iend/5,209,223/ IF(ITIMES.EQ.0) THEN PRINT'(" ===> IW3UNPBF - WCOSS VERSION: 06-24-2021")' C THE FIRST TIME IN, INITIALIZE SOME DATA C (NOTE: FORTRAN 77/90 STANDARD DOES NOT ALLOW COMMON BLOCK VARIABLES C TO BE INITIALIZED VIA DATA STATEMENTS, AND, FOR SOME REASON, C THE BLOCK DATA MAY NOT INITIALIZE DATA IN THE W3EMC/W3NCO C LIBRARIES C A V O I D B L O C K D A T A I N W 3 L I B ) C -------------------------------------------------------------------- ITIMES = 1 KNDX = 0 KSKACF = 0 KSKUPA = 0 KSKSFC = 0 KSKSAT = 0 KFLSAT = 0 KSKSMI = 0 KOUNT = 0 KNTSAT = 0 knts16 = 0 KNTMODIS = 0 KNTavhrr = 0 KNTviirs = 0 IFLSAT = 0 C IKAT defines the category number IKAT(1) = 1 IKAT(2) = 2 IKAT(3) = 3 IKAT(4) = 4 IKAT(5) = 5 IKAT(6) = 6 IKAT(7) = 51 IKAT(8) = 8 C MCAT defines the number of parameters in a level for each category C --> THIS NEEDS TO BE UPDATED WHEN ADDING MORE WORDS PER CAT LEVEL MCAT(1) = 11 ! Cat. 1 MCAT(2) = 7 ! Cat. 2 MCAT(3) = 6 ! Cat. 3 MCAT(4) = 5 ! Cat. 4 MCAT(5) = 9 ! Cat. 5 MCAT(6) = 11 ! Cat. 6 MCAT(7) = 13 ! Cat. 51 MCAT(8) = 4 ! Cat. 8 C LVDX defines location in UNP holding the no. of levels for each cat. LVDX(1) = 13 ! Cat. 1 LVDX(2) = 15 ! Cat. 2 LVDX(3) = 17 ! Cat. 3 LVDX(4) = 19 ! Cat. 4 LVDX(5) = 21 ! Cat. 5 LVDX(6) = 23 ! Cat. 6 LVDX(7) = 29 ! Cat. 51 LVDX(8) = 27 ! Cat. 8 ISET = 0 END IF C UNIT NUMBER OUT OF RANGE RETURNS A 999 C -------------------------------------- IF(LUNIT.LT.1 .OR. LUNIT.GT.100) THEN PRINT'(" ##IW3UNPBF - UNIT NUMBER ",I0," OUT OF RANGE -- ", $ "IER = 999")', LUNIT GO TO 9999 END IF IF(LASTF.NE.LUNIT .AND. LASTF.GT.0) THEN CALL CLOSBF(LASTF) JWFILE(LASTF) = 0 END IF LASTF = LUNIT 60 CONTINUE C THE JWFILE INDICATOR: =0 IF UNOPENED; =2 IF OPENED AND NCEP BUFR C ---------------------------------------------------------------- IF(JWFILE(LUNIT).EQ.0) THEN PRINT'(" ===> IW3UNPBF - WCOSS VERSION: 01-06-2020")' C DETERMINE MACHINE WORD LENGTH (BYTES) FOR BOTH INTEGERS AND REALS C ----------------------------------------------------------------- CALL WORDLENGTH(LWI,LWR) PRINT 2213, LWI,LWR 2213 FORMAT(/' ---> IW3UNPBF - MACHINE WORD LENGTH (BYTES) FOR ', $ 'INTEGER WORDS IS ',I3/' ---> IW3UNPBF - MACHINE WORD LENGTH ', $ '(BYTES) FOR REAL WORDS IS ',I3/) NPRINT = 0 BMISS = GETBMISS() print'(1X)' print'(" BUFRLIB value for missing passed into IW3UNPBF is: ", $ G0)', bmiss print'(1X)' IF(IER.EQ.-1) THEN IER = 0 PRINT 4567, LUNIT 4567 FORMAT(/'##IW3UNPBF: UNIT NUMBER',I3,' HAS ALREADY BEEN OPENED ', $ 'BY CORRESPONDING INTERFACE SUBROUTINE W3UNPKB7 AND REPORTS ', $ 'HAVE BEEN'/12X,'PROCESSED - CONTINUE PROCESSING REPORTS HERE'/) JWFILE(LUNIT) = 2 DSNAMX = DSNAME IDSDAX_8 = IDSDAT IDSDMX_8 = IDSDMP_8 SUBSET = SUBSET_r 867 CONTINUE ISUB = NMSUB(LUNIT) READ(SUBSET(3:5),'(I3)') IINDEX READ(SUBSET(6:8),'(I3)') JINDEX IF(IINDEX.LE.255 .AND. JINDEX.LE.200) THEN IF(SUBSKP(IINDEX,JINDEX)) THEN IF(ISUB.GT.0.AND.NPRINT(IINDEX,JINDEX).EQ.0) THEN C There may be messages with no reports present (e.g., the center time C and dump time messages which may be present even if no reports are C present in subsequent messages), so key on the FIRST message of C this type/subtype with reports present for the diagnostic print PRINT 1234, SUBSET 1234 FORMAT(/'IW3UNPBF/I02UBF - BUFR MESSAGE WITH TABLE ENTRY "',A8, $ '" (AND CONTAINING SUBSETS) READ - ALL MESSAGES WITH THIS BUFR ', $ 'TYPE/SUBTYPE'/20X,'ARE SKIPPED AS DIRECTED BY CALLING PROGRAM'/) NPRINT(IINDEX,JINDEX) = 1 END IF CALL READMG(LUNIT,SUBSET,idateb,IRET) IF(IRET.NE.0) THEN IER = 2 IW3UNPBF = 2 RETURN END IF GO TO 867 END IF END IF GO TO 60 END IF IERR = I02UBF(LUNIT,OBS,OBS2,OBS3,NOBS3,obs8_8,SUBSKP,IER) IF(IERR.EQ.1) THEN PRINT'(" IW3UNPBF - OPENED AN NCEP BUFR FILE IN UNIT ",I0)', $ LUNIT JWFILE(LUNIT) = 2 KNDX = 0 KSKACF = 0 KSKUPA = 0 KSKSFC = 0 KSKSAT = 0 KFLSAT = 0 KSKSMI = 0 IFLSAT = 0 IER = 1 IW3UNPBF = 1 ELSE IF(IERR.NE.999) THEN IER = 3 IW3UNPBF = 3 ELSE IER = 999 IW3UNPBF = 999 END IF ELSE IF(JWFILE(LUNIT).EQ.2) THEN IF(I02UBF(LUNIT,OBS,OBS2,OBS3,NOBS3,obs8_8,SUBSKP,IER).NE.0) $ JWFILE(LUNIT) = 0 IF(IER.GT.0) CALL CLOSBF(LUNIT) IF(IER.EQ.2.OR.IER.EQ.3) THEN PRINT'(1X)' IF(KSKACF(1).GT.0) PRINT'(" IW3UNPBF - NO. OF AIRCFT/", $ "AIRCAR REPORTS TOSSED DUE TO ZERO CAT. 6 LVLS = ",I0)', $ KSKACF(1) IF(KSKACF(8).GT.0) PRINT'(" IW3UNPBF - NO. OF AIRCFT ", $ "REPORTS TOSSED DUE TO BEING ""PHWR"" AIREP FORMAT = ", $ I0)', KSKACF(8) IF(KSKACF(3).GT.0) PRINT'(" IW3UNPBF - NO. OF AMDAR ", $ "FORMAT ASDAR/ACARS AIRCFT REPORTS TOSSED DUE TO BEING ", $ "DISGUISED AS AIREP FORMAT REPORTS BY AFWA = ",I0)', $ KSKACF(3) IF(KSKACF(4).GT.0) PRINT'(" IW3UNPBF - NO. OF MDCRS ACARS", $ " AIRCFT REPORTS TOSSED DUE TO BEING DISGUISED AS ", $ "AIREP FORMAT REPORTS BY AFWA = ",I0)', KSKACF(4) IF(KSKACF(5).GT.0) PRINT'(" IW3UNPBF - NO. OF AIRCFT/", $ "AIRCAR REPORTS TOSSED DUE TO HAVING MISSING WIND = ",I0)', $ KSKACF(5) IF(KSKACF(1)+KSKACF(3)+KSKACF(4)+KSKACF(5)+KSKACF(8).GT.0) $ PRINT'(" IW3UNPBF - TOTAL NO. OF AIRCFT/AIRCAR REPORTS ", $ "TOSSED = ",I0)', $ KSKACF(1)+KSKACF(3)+KSKACF(4)+KSKACF(5)+KSKACF(8) IF(KSKUPA.GT.0) PRINT'(" IW3UNPBF - TOTAL NO. OF ADPUPA ", $ "REPORTS TOSSED = ",I0)', KSKUPA IF(KSKSFC.GT.0) PRINT'(" IW3UNPBF - TOTAL NO. OF ADPSFC/", $ "SFCSHP/SFCBOG/MSONET REPORTS TOSSED = ",I0)', KSKSFC IF(KSKSAT.GT.0) PRINT'(" IW3UNPBF - TOTAL NO. OF SATWND ", $ "REPORTS TOSSED = ",I0)', KSKSAT IF(KFLSAT(1).GT.0) PRINT'(" IW3UNPBF - TOTAL NO. OF ", $ "EUMETSAT SATWND REPORTS FLAGGED WITH WQM=13 DUE TO QI ", $ "CONFIDENCE FACTOR /= LIMqc = ",I0)', $ KFLSAT(2) IF(KFLSAT(3).GT.0) PRINT'(" IW3UNPBF - TOTAL NO. OF JMA ", $ "SATWND REPORTS FLAGGED WITH WQM=13 DUE TO QI CONFIDENCE ", $ "FACTOR /= LIMqc = ",I0)', KFLSAT(4) IF(KFLSAT(5).GT.0) PRINT'(" IW3UNPBF - TOTAL NO. OF GOES ", $ "SATWND REPORTS FLAGGED WITH WQM=13 DUE TO QI CONFIDENCE ", $ "FACTOR /= LIMqc = ",I0)', KFLSAT(6) IF(KFLSAT(7).GT.0) PRINT'(" IW3UNPBF - TOTAL NO. OF MODIS", $ " POES SATWND REPORTS FLAGGED WITH WQM=13 DUE TO QI ", $ "CONFIDENCE FACTOR /= LIMqc = ",I0)', $ KFLSAT(8) IF(KFLSAT(9).GT.0) PRINT *, 'IW3UNPBF - TOTAL NO. OF ', $ 'AVHRR POES SATWND REPORTS FLAGGED WITH WQM=13 DUE TO QI ', $ 'CONFIDENCE FACTOR /= LIMqc = ',KFLSAT(10) IF(KFLSAT(11).GT.0) PRINT *, 'IW3UNPBF - TOTAL NO. OF ', $ 'VIIRS POES SATWND REPORTS FLAGGED WITH WQM=13 DUE TO QI ', $ 'CONFIDENCE FACTOR /= LIMqc = ',KFLSAT(12) IF(KSKSMI.GT.0) PRINT'(" IW3UNPBF - TOTAL NO. OF SPSSMI ", $ "REPORTS TOSSED = ",I0)', KSKSMI IF(IFLSAT.EQ.1) THEN MFLAG = 0 PRINT 8102 8102 FORMAT(/' ---> IW3UNPBF: SUMMARY OF NESDIS GOES REPORT COUNTS ', $ 'GROUPED BY SATELLITE ID (PRIOR TO ANY FILTERING BY CALLING ', $ 'PROGRAM)'/) DO IDSAT = 250,259 IF(KNTSAT(IDSAT).GT.0) THEN PRINT 8103, IDSAT,KNTSAT(IDSAT) MFLAG = 1 ENDIF ENDDO do idsat = 270,273 if(knts16(idsat).gt.0) then print 8103, idsat,knts16(idsat) mflag = 1 endif enddo 8103 FORMAT(15X,'NUMBER FROM SAT. ID',I4,4X,':',I6) IF(KNTSAT(260).GT.0.or.knts16(274).gt.0) THEN PRINT 8104, KNTSAT(260)+knts16(274) MFLAG = 1 ENDIF 8104 FORMAT(15X,'TOTAL NUMBER FROM UNKNOWN SAT. IDs:',I6) IF(MFLAG.EQ.0) PRINT 8110 8110 FORMAT(15X,'NO REPORTS OF THIS TYPE WERE READ') PRINT 8105 8105 FORMAT(/) MFLAG = 0 PRINT 8202 8202 FORMAT(/' ---> IW3UNPBF: SUMMARY OF NASA/MODIS POES REPORT ', $ 'COUNTS GROUPED BY SATELLITE ID (PRIOR TO ANY FILTERING BY ', $ 'CALLING PROGRAM)'/) DO IDSAT = 783,784 IF(KNTMODIS(IDSAT).GT.0) THEN PRINT 8103, IDSAT,KNTMODIS(IDSAT) MFLAG = 1 ENDIF ENDDO IF(KNTMODIS(785).GT.0) THEN PRINT 8104, KNTMODIS(785) MFLAG = 1 ENDIF IF(MFLAG.EQ.0) PRINT 8110 PRINT 8105 MFLAG = 0 PRINT 8203 8203 FORMAT(/' ---> IW3UNPBF: SUMMARY OF NESDIS/AVHRR POES REPORT ', $ 'COUNTS GROUPED BY SATELLITE ID (PRIOR TO ANY FILTERING BY ', $ 'CALLING PROGRAM)'/) do ii = 1,3 DO IDSAT = istart(ii),iend(ii) IF(KNTavhrr(IDSAT).GT.0) THEN PRINT 8103, IDSAT,KNTavhrr(IDSAT) MFLAG = 1 ENDIF ENDDO enddo IF(KNTavhrr(224).GT.0) THEN PRINT 8104, KNTavhrr(224) MFLAG = 1 ENDIF IF(MFLAG.EQ.0) PRINT 8110 PRINT 8105 MFLAG = 0 PRINT 8204 8204 FORMAT(/' ---> IW3UNPBF: SUMMARY OF NASA/VIIRS POES REPORT ', $ 'COUNTS GROUPED BY SATELLITE ID (PRIOR TO ANY FILTERING BY ', $ 'CALLING PROGRAM)'/) DO IDSAT = 224,224 IF(KNTviirs(IDSAT).GT.0) THEN PRINT 8103, IDSAT,KNTviirs(IDSAT) MFLAG = 1 ENDIF ENDDO IF(KNTviirs(225).GT.0) THEN PRINT 8104, KNTviirs(225) MFLAG = 1 ENDIF IF(MFLAG.EQ.0) PRINT 8110 PRINT 8105 END IF KNDX = 0 KSKACF = 0 KSKUPA = 0 KSKSFC = 0 KSKSAT = 0 KFLSAT = 0 KSKSMI = 0 IFLSAT = 0 END IF IW3UNPBF = IER END IF STNID = STNIDX CRES1 = CRES1X CRES2 = CRES2X CBULL = CBULLX DSNAME = DSNAMX IDSDAT = IDSDAX_8 IDSDMP_8 = IDSDMX_8 SUBSET_r = SUBSET RETURN 9999 CONTINUE IER = 999 IW3UNPBF = 999 RETURN END C*********************************************************************** C*********************************************************************** C*********************************************************************** FUNCTION I02UBF(LUNIT,OBS,OBS2,OBS3,NOBS3,obs8_8,SUBSKP,IER) PARAMETER (MAXOBS=3500) COMMON/IUBFCC/SUBSET COMMON/IUBFOO/DSNAMX,IDSDAX_8,IDSDMX_8 COMMON/IUBFQQ/NPRINT(0:255,0:200) COMMON/IUBFRR/IDATEB CHARACTER*8 SUBSET,DSNAMX,CBUFR CHARACTER*6 C01UBF DIMENSION OBS(MAXOBS),OBS2(43),OBS3(5,255,7),NOBS3(7),JDATE(5), $ JDUMP(5) real(8) obs8_8(2) INTEGER(8) IDSDAX_8,IDSDMX_8,JDUMP_8(5) LOGICAL SUBSKP(0:255,0:200) SAVE JDATE = -1 JDUMP = -1 CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) THEN C IF FILE IS CLOSED TRY TO OPEN IT AND RETURN INFORMATION ABOUT IT C IN DSNAMX, IDSDAX_8 AND IDSDMX_8 C ---------------------------------------------------------------- IRET = -1 I02UBF = 2 REWIND LUNIT READ(LUNIT,END=11,ERR=12,FMT='(A8)') CBUFR IF(CBUFR(1:4).EQ.'BUFR') THEN PRINT'(" IW3UNPBF - INPUT FILE ON UNIT ",I0, " IS", $ " UNBLOCKED NCEP BUFR"/)', LUNIT ELSE IF(CBUFR(5:8).EQ.'BUFR') THEN PRINT'(" IW3UNPBF - INPUT FILE ON UNIT ",I0, " IS", $ " BLOCKED NCEP BUFR"/)', LUNIT ELSE PRINT'(" ##IW3UNPBF/I02UBF - INPUT FILE ON UNIT ",I0, " IS", $ " NOT NCEP BUFR -- IER = 999")', LUNIT I02UBF = 999 GOTO 10 END IF CALL DATELEN(10) CALL DUMPBF(LUNIT,JDATE,JDUMP) print'(" CENTER DATE (JDATE) = ",5(I0,1X))', jdate print'(" DUMP DATE (JDUMP) = ",5(I0,1X))', jdump IF(JDATE(1).LE.0) then PRINT'(" ##IW3UNPBF/I02UBF - CENTER DATE COULD NOT BE ", $ "OBTAINED FROM INPUT FILE ON UNIT ",I0," -- IER = 999")', $ LUNIT I02UBF = 999 GO TO 10 END IF IF(JDATE(1).LT.100) THEN C IF 2-DIGIT YEAR RETURNED IN JDATE(1), MUST USE "WINDOWING" TECHNIQUE C TO CREATE A 4-DIGIT YEAR C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE) PRINT'(" ##IW3UNPBF/I02UBF - THE FOLLOWING SHOULD NEVER ", $ "HAPPEN!!!!!")' PRINT'(" ##IW3UNPBF/I02UBF - 2-DIGIT YEAR IN JDATE(1) ", $ "RETURNED FROM DUMPBF (JDATE IS: ",I0,") - USE WINDOWING ", $ "TECHNIQUE TO OBTAIN 4-DIGIT YEAR")', JDATE C IF JDATE=41~99 THEN JDATE=1941~1999 C IF JDATE=00~40 THEN JDATE=2000~2040 IF(JDATE(1).GT.40) THEN JDATE(1) = 1900 + JDATE(1) ELSE JDATE(1) = 2000 + JDATE(1) ENDIF PRINT'(" ##IW3UNPBF/I02UBF - CORRECTED JDATE(1) WITH 4-", $ "DIGIT YEAR, JDATE NOW IS: ",I0)', JDATE ENDIF IDSDAX_8 =JDATE(1)*1000000+JDATE(2)*10000+JDATE(3)*100+JDATE(4) IF(JDUMP(1).LE.0) THEN IDSDMX_8 = 999999999999_8 ELSE IF(JDUMP(1).LT.100) THEN C IF 2-DIGIT YEAR RETURNED IN JDUMP(1), MUST USE "WINDOWING" TECHNIQUE C TO CREATE A 4-DIGIT YEAR C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE) PRINT'(" ##IW3UNPBF/I02UBF - THE FOLLOWING SHOULD NEVER", $ " HAPPEN!!!!!")' PRINT'(" ##IW3UNPBF/I02UBF - 2-DIGIT YEAR IN JDUMP(1) ", $ "RETURNED FROM DUMPBF (JDUMP IS: ",I0,") - USE ", $ "WINDOWING TECHNIQUE TO OBTAIN 4-DIGIT YEAR")', JDUMP C IF JDUMP=41~99 THEN JDUMP=1941~1999 C IF JDUMP=00~40 THEN JDUMP=2000~2040 IF(JDUMP(1).GT.40) THEN JDUMP(1) = 1900 + JDUMP(1) ELSE JDUMP(1) = 2000 + JDUMP(1) ENDIF PRINT'(" ##IW3UNPBF/I02UBF - CORRECTED JDUMP(1) WITH 4-", $ "DIGIT YEAR, JDUMP NOW IS: ",I0)', JDUMP END IF JDUMP_8 = JDUMP IDSDMX_8 = JDUMP_8(1)*100000000+JDUMP_8(2)*1000000+ $ JDUMP_8(3)*10000+JDUMP_8(4)*100+JDUMP_8(5) ENDIF CALL OPENBF(LUNIT,'IN',LUNIT) ccccccc CALL OPENBF(0,'QUIET',1) ! will generate diagnostic print if ccccccc ! an embedded BUFR table is read C This next call, I believe, is needed only because SUBSET is not C returned in DUMPBF ... call readmg(lunit,subset,idateb,iret) DSNAMX = C01UBF(SUBSET)//' ' I02UBF = 1 GO TO 10 11 CONTINUE PRINT'(" ##IW3UNPBF/I02UBF - INPUT FILE ON UNIT ",I0," IS ", $ "EMPTY (NULL) -- ALL DONE WITH THIS FILE (IER = 3)")', LUNIT GO TO 10 12 CONTINUE PRINT'(" ##IW3UNPBF/I02UBF - ERROR READING INPUT FILE ON UNIT", $ 1X,I0," -- IER = 999")', LUNIT I02UBF = 999 10 CONTINUE IER = I02UBF RETURN ELSE IF(IL.LT.0) THEN C IF THE FILE IS ALREADY OPENED FOR INPUT TRY TO READ THE NEXT SUBSET C ------------------------------------------------------------------- 7822 CONTINUE C READ THE NEXT SUBSET IN THE BUFR FILE C ------------------------------------- 1 CONTINUE CALL READSB(LUNIT,IRET) IF(IRET.NE.0) THEN 30 CONTINUE CALL READMG(LUNIT,SUBSET,idateb,IRET) IF(IRET.NE.0) GO TO 20 ISUB = NMSUB(LUNIT) READ(SUBSET(3:5),'(I3)') IINDEX READ(SUBSET(6:8),'(I3)') JINDEX IF(IINDEX.LE.255 .AND. JINDEX.LE.200) THEN IF(SUBSKP(IINDEX,JINDEX)) THEN IF(ISUB.GT.0.AND.NPRINT(IINDEX,JINDEX).EQ.0) THEN C There may be messages with no reports present (e.g., the center time C and dump time messages which may be present even if no reports are C present in subsequent messages), so key on the FIRST message of C this type/subtype with reports present for the diagnostic print PRINT 1234, SUBSET 1234 FORMAT(/'IW3UNPBF/I02UBF - BUFR MESSAGE WITH TABLE ENTRY "',A8, $ '" (AND CONTAINING SUBSETS) READ - ALL MESSAGES WITH THIS BUFR ', $ 'TYPE/SUBTYPE'/20X,'ARE SKIPPED AS DIRECTED BY CALLING PROGRAM'/) NPRINT(IINDEX,JINDEX) = 1 END IF GO TO 30 END IF END IF GO TO 1 END IF 20 CONTINUE IF(IRET.EQ.0) I02UBF = R01UBF(SUBSET,LUNIT,OBS,OBS2,OBS3,NOBS3, $ obs8_8) IF(IRET.NE.0) I02UBF = 2 IF(I02UBF.EQ.-9999) GO TO 7822 IER = I02UBF RETURN END IF C FILE MUST BE OPEN FOR INPUT! C ---------------------------- PRINT'(" ##IW3UNPBF/I02UBF - FILE ON UNIT ",I0," IS OPENED FOR ", 4 "OUTPUT -- IER = 999")', LUNIT I02UBF = 999 IER = 999 RETURN END C*********************************************************************** C*********************************************************************** C*********************************************************************** FUNCTION C01UBF(SUBSET) CHARACTER*(*) SUBSET CHARACTER*6 C01UBF SAVE C01UBF = 'NONE' IF(SUBSET(1:5).EQ.'NC000') THEN C01UBF = 'ADPSFC' ELSE IF(SUBSET(1:5).EQ.'NC001') THEN IF(SUBSET(6:8).NE.'006') THEN C01UBF = 'SFCSHP' ELSE C01UBF = 'SFCBOG' END IF ELSE IF(SUBSET(1:5).EQ.'NC002') THEN C01UBF = 'ADPUPA' ELSE IF(SUBSET(1:5).EQ.'NC004') THEN IF(SUBSET(6:8).EQ.'004' .OR. SUBSET(6:8).EQ.'007') THEN C01UBF = 'AIRCAR' ELSE IF(SUBSET(6:8).EQ.'005') THEN C01UBF = 'ADPUPA' ELSE C01UBF = 'AIRCFT' END IF ELSE IF(SUBSET(1:5).EQ.'NC005') THEN C01UBF = 'SATWND' ELSE IF(SUBSET(1:5).EQ.'NC012') THEN C01UBF = 'SPSSMI' ELSE IF(SUBSET(1:5).EQ.'NC255') THEN C01UBF = 'MSONET' END IF IF(C01UBF.EQ.'NONE') PRINT'(" ##IW3UNPBF/C01UBF - UNKNOWN SUBSET", $ "(=",A,") -- CONTINUE~~")', SUBSET RETURN END C*********************************************************************** C*********************************************************************** C*********************************************************************** FUNCTION R01UBF(SUBSET,LUNIT,OBS,OBS2,OBS3,NOBS3,obs8_8) CHARACTER*(*) SUBSET CHARACTER*6 C01UBF,ADPSUB DIMENSION OBS(*),OBS2(43),OBS3(5,255,7),NOBS3(7) real*8 obs8_8(2) SAVE C FIND SPECIFIED UNPACKED DATA TYPE AND CALL A TRANSLATOR C ------------------------------------------------------- R01UBF = 4 ADPSUB = C01UBF(SUBSET) IF(ADPSUB .EQ. 'ADPUPA') THEN R01UBF = R03UBF(LUNIT,OBS,OBS2,OBS3,NOBS3,obs8_8) ELSE IF(ADPSUB(1:3).EQ.'AIR') THEN R01UBF = R05UBF(LUNIT,OBS,OBS2,OBS3,NOBS3,obs8_8) ELSE IF(ADPSUB .EQ. 'SATWND') THEN R01UBF = R06UBF(LUNIT,OBS,OBS2,OBS3,NOBS3,obs8_8) ELSE IF(ADPSUB .EQ. 'SPSSMI') THEN R01UBF = R07UBF(LUNIT,OBS,OBS2,OBS3,NOBS3,obs8_8) ELSE R01UBF = R04UBF(LUNIT,OBS,OBS2,OBS3,NOBS3,obs8_8) END IF RETURN END C*********************************************************************** C*********************************************************************** C*********************************************************************** SUBROUTINE S01UBF(SID,XOB,YOB,RHR,RCTIM,RSV1,RSV2,ELV,QMELV,ITP, $ RTP,RSTP,IDS) C ---> PROCESSES HEADER PARAMETER (NUMCAT=8, LEVLIM=300) COMMON/IUBFAA/BMISS COMMON/IUBFDD/HDR(12),RCATS(50,LEVLIM,NUMCAT),IKAT(NUMCAT), $ MCAT(NUMCAT),NCAT(NUMCAT),LVDX(NUMCAT) COMMON/IUBFNN/STNIDX,CRES1X,CRES2X CHARACTER*(*) RSV1,RSV2 CHARACTER*8 SID,STNIDX,CRES1X,CRES2X REAL(8) BMISS DIMENSION IHDR(12),RHDR(12) EQUIVALENCE (IHDR(1),RHDR(1)) SAVE DATA XMISS/99999./,IMISS/99999/ C INITIALIZE THE UNPACK ARRAY TO MISSINGS C --------------------------------------- C NCAT will hold the number of unpacked levels in each category NCAT = 0 RCATS = IMISS C STORE THE UNPACKED HEADER INFORMATION INTO UNP FORMAT C ----------------------------------------------------- RHDR( 1) = MIN(YOB,XMISS) IF(YOB.GE.BMISS) print'(" ~~IW3UNPBF/S01UBF: ID ",A," has a ", $ "missing LATITUDE - unpked hdr, word 1 is set to ",G0)', $ sid,RHDR(1) C Important: According to BUFR Manual, CLON (0-06-002) - represented C here by "XOB" - should be in units of Degrees West - and East + C (-180.0 to +180.0); however some BUFR data sets (e.g., PREPBUFR) are C known to encode CLON in units of Degree East (0.0 to 359.99) -- So C we use the following conversion to work in either case ... RHDR( 2) = XMISS IF(XOB.LT.BMISS) RHDR( 2) = 360. - MOD(720.-XOB,360.) IF(RHDR(2).EQ.360.0) RHDR(2) = 0.0 IF(XOB.GE.BMISS) print'(" ~~IW3UNPBF/S01UBF: ID ",A," has a ", $ "missing LONGITUDE - unpked hdr, word 2 is set to ",G0)', $ sid,RHDR(2) RHDR( 3) = XMISS RHDR( 4) = MIN(RHR,XMISS) IF(RHR.GE.BMISS) print'(" ~~IW3UNPBF/S01UBF: ID ",A," has a ", $ "missing OB TIME - unpked hdr, word 4 is set to ",G0)', $ sid,RHDR(4) RHDR( 5) = XMISS IHDR( 6) = IDS cdak RHDR( 7) = NINT(ELV) RHDR( 7) = MIN(NINT(ELV),IMISS) IHDR( 8) = ITP IHDR( 9) = RTP IHDR(10) = RSTP RHDR(11) = XMISS IF(RCTIM.LT.24.01.AND.RCTIM.GT.-.01) RHDR(11) = RCTIM RHDR(12) = QMELV STNIDX = SID CRES1X = RSV1 CRES2X = RSV2 C STORE THE HEADER INTO A HOLDING ARRAY C ------------------------------------- HDR = RHDR RETURN END C*********************************************************************** C*********************************************************************** C*********************************************************************** SUBROUTINE S02UBF(ICAT,N,*) C ---> PROCESSES DATA LEVEL CATEGORIES PARAMETER (NUMCAT=8, LEVLIM=300) C Input argument ICAT - the category number (1,2,3,4,5,6,8,51) C Input argument N - level indicator (unless = 0, then signals C subr. to write an empty cat. 2,3, or 4 level COMMON/IUBFDD/HDR(12),RCATS(50,LEVLIM,NUMCAT),IKAT(NUMCAT), $ MCAT(NUMCAT),NCAT(NUMCAT),LVDX(NUMCAT) COMMON/IUBFEE/POB(255),QOB(255),TOB(255),ZOB(255),DOB(255), $ SOB(255),VSG(255),OB8(255),CF8(255) COMMON/IUBFFF/PQM(255),QQM(255),TQM(255),ZQM(255),WQM(255) COMMON/IUBFGG/PSL,STP,SDR,SSP,STM,DPD COMMON/IUBFHH/PSQ,SPQ,SWQ,STQ,DDQ COMMON/IUBFII/PWMIN COMMON/IUBFLL/Q81(255),Q82(255) COMMON/IUBFMM/XIND(255) COMMON/IUBFNN/STNIDX,CRES1X,CRES2X CHARACTER*8 STNIDX,CRES1X,CRES2X DIMENSION RCAT(50),JCAT(50) EQUIVALENCE (RCAT(1),JCAT(1)) LOGICAL SURF SAVE DATA XMISS/99999./,IMISS/99999/ cppppp-ID iprint = 0 cc iprint = 1 c if(stnidx.eq.'89571 ') iprint = 1 c if(stnidx.eq.'68906 ') iprint = 1 c if(stnidx.eq.'68842 ') iprint = 1 c if(stnidx.eq.'74794 ') iprint = 1 c if(stnidx.eq.'74389 ') iprint = 1 c if(stnidx.eq.'96801A ') iprint = 1 cppppp-ID SURF = .FALSE. GOTO 1 C ENTRY POINT SE01UBF FORCES DATA INTO THE SURFACE (FIRST) LEVEL C -------------------------------------------------------------- ENTRY SE01UBF(ICAT,N) C ---> PROCESSES DATA INTO SURFACE LEVEL SURF = .TRUE. C CHECK THE PARAMETERS COMING IN (KCAT IS INDEX IN IKAT, MCAT, NCAT C FOR A PARTICULAR CATEGORY) C ----------------------------------------------------------------- 1 KCAT = 0 DO I = 1,NUMCAT IF(ICAT.EQ.IKAT(I)) THEN KCAT = I EXIT END IF ENDDO C PARAMETER ICAT (UNPACKED DATA LEVEL CATEGORY) OUT OF BOUNDS C RETURNS A 999 C -------------------------------------------------------------- IF(KCAT.EQ.0) THEN PRINT'(" ##IW3UNPBF/S02UBF - UNPACKED CATEGORY ",I0," OUT OF ", $ "BOUNDS -- IER = 999")', ICAT RETURN 1 END IF C PARAMETER N (LEVEL INDEX) OUT OF BOUNDS RETURNS A 999 C ----------------------------------------------------- IF(N.GT.255) THEN PRINT'(" ##IW3UNPBF/S02UBF - LEVEL INDEX ",I0," EXCEEDS 255 ", $ "-- IER = 999")', N RETURN 1 END IF C MAKE A MISSING LEVEL AND RETURN WHEN N=0 (NOT ALLOWED FOR CAT 01) C (NOTE: QUALITY MARKERS ARE SET TO 2 AND SPECIAL LEVEL INDICATORS C ARE SET TO 0) C ----------------------------------------------------------------- IF(N.EQ.0) THEN IF(ICAT.EQ.1) RETURN NCAT(KCAT) = MIN(LEVLIM-1,NCAT(KCAT)+1) if(iprint.eq.1) then print'(" To prepare for sfc. data, write all missings on ", $ "lvl ",I0," for cat ",i0)', ncat(kcat),icat print'(" also write default =2 for all q. markers")' print'(" also write default =0 for special lvl ", $ "indicators")' end if IF(ICAT.EQ.2) THEN RCATS(4:6,NCAT(KCAT),KCAT) = 2. RCATS(7,NCAT(KCAT),KCAT) = 0 ELSE IF(ICAT.EQ.3) THEN RCATS(4:5,NCAT(KCAT),KCAT) = 2. RCATS(6,NCAT(KCAT),KCAT) = 0 ELSE IF(ICAT.EQ.4) THEN RCATS(4:5,NCAT(KCAT),KCAT) = 2. END IF RETURN END IF C FIGURE OUT WHICH LEVEL TO UPDATE AND RESET THE LEVEL COUNTER C ------------------------------------------------------------ IF(ICAT.EQ.1) THEN L = I04UBF(POB(N)*.1) C MANDATORY LEVEL WITH NON-MANDATORY PRESSURE RETURNS A 999 C --------------------------------------------------------- IF(L.LE.0) THEN PRINT'(" ##IW3UNPBF/S02UBF - MANDATORY LEVEL WITH NON-", $ "MANDATORY PRESSURE (P = ",G0,"mb) -- IER = 999")', $ POB(N)*.1 RETURN 1 END IF NCAT(KCAT) = MAX(NCAT(KCAT),L) if(iprint.eq.1) $ print'(" Will write cat. 1 data on lvl ",I0," for cat ",I0, $ ", - total no. cat. 1 lvls processed so far = ",I0)', $ L,icat,ncat(kcat) ELSEIF(SURF) THEN L = 1 NCAT(KCAT) = MAX(NCAT(KCAT),1) if(iprint.eq.1) $ print'(" Will write cat. ",I0," SURFACE data on lvl ",I0, $ ", - total no. cat. ",I0," lvls processed so far = ",I0)', $ icat,L,icat,ncat(kcat) ELSE L = MIN(LEVLIM-1,NCAT(KCAT)+1) IF(L.EQ.LEVLIM-1) THEN print'(" ~~IW3UNPBF/S02UBF: ID ",A," - This cat. ",I0, $ ", level cannot be processed because the limit of ",I0, $ " has already been reached")', stnidx,icat,LEVLIM RETURN END IF NCAT(KCAT) = L if(iprint.eq.1) $ print'(" Will write cat. ",I0," NON-SFC data on lvl ",I0, $ ", - total no. cat. ",I0," lvls processed so far = ",I0)', $ icat,L,icat,ncat(kcat) END IF C EACH DATA LEVEL CATEGORY NEEDS A SPECIFIC DATA ARRANGEMENT C ---------------------------------------------------------- IF(ICAT.EQ.1) THEN RCAT(1) = MIN(NINT(POB(N)),NINT(RCATS( 1,L,KCAT))) RCAT(2) = MIN(NINT(ZOB(N)),NINT(RCATS( 2,L,KCAT))) RCAT(3) = MIN(NINT(TOB(N)),NINT(RCATS( 3,L,KCAT))) RCAT(4) = MIN(NINT(QOB(N)),NINT(RCATS( 4,L,KCAT))) RCAT(5) = MIN(NINT(DOB(N)),NINT(RCATS( 5,L,KCAT))) RCAT(6) = MIN(NINT(SOB(N)),NINT(RCATS( 6,L,KCAT))) IF(RCATS(7,L,KCAT).LT.IMISS) THEN RCAT(7) = MAX(NINT(PQM(N)),NINT(RCATS( 7,L,KCAT))) ELSE RCAT(7) = NINT(PQM(N)) END IF IF(RCATS(8,L,KCAT).LT.IMISS) THEN RCAT(8) = MAX(NINT(ZQM(N)),NINT(RCATS( 8,L,KCAT))) ELSE RCAT(8) = NINT(ZQM(N)) END IF IF(RCATS(9,L,KCAT).LT.IMISS) THEN RCAT(9) = MAX(NINT(TQM(N)),NINT(RCATS( 9,L,KCAT))) ELSE RCAT(9) = NINT(TQM(N)) END IF IF(RCATS(10,L,KCAT).LT.IMISS) THEN RCAT(10) = MAX(NINT(QQM(N)),NINT(RCATS(10,L,KCAT))) ELSE RCAT(10) = NINT(QQM(N)) END IF IF(RCATS(11,L,KCAT).LT.IMISS) THEN RCAT(11) = MAX(NINT(WQM(N)),NINT(RCATS(11,L,KCAT))) ELSE RCAT(11) = NINT(WQM(N)) END IF ELSEIF(ICAT.EQ.2) THEN RCAT(1) = MIN(NINT(POB(N)),IMISS) RCAT(2) = MIN(NINT(TOB(N)),IMISS) RCAT(3) = MIN(NINT(QOB(N)),IMISS) RCAT(4) = NINT(PQM(N)) RCAT(5) = NINT(TQM(N)) RCAT(6) = NINT(QQM(N)) RCAT(7) = NINT(XIND(N)) ELSEIF(ICAT.EQ.3) THEN RCAT(1) = MIN(NINT(POB(N)),IMISS) RCAT(2) = MIN(NINT(DOB(N)),IMISS) RCAT(3) = MIN(NINT(SOB(N)),IMISS) RCAT(4) = NINT(PQM(N)) RCAT(5) = NINT(WQM(N)) IF(NINT(VSG(N)).EQ. 8) THEN C MARK THE MAXIMUM WIND LEVEL IN DATA LEVEL CATEGORY 3 XIND(N) = 2 IF(NINT(POB(N)).EQ.NINT(PWMIN)) XIND(N) = 3 END IF RCAT(6) = NINT(XIND(N)) ELSEIF(ICAT.EQ.4) THEN RCAT(1) = MIN(NINT(ZOB(N)),IMISS) RCAT(2) = MIN(NINT(DOB(N)),IMISS) RCAT(3) = MIN(NINT(SOB(N)),IMISS) RCAT(4) = NINT(ZQM(N)) RCAT(5) = NINT(WQM(N)) ELSEIF(ICAT.EQ.5) THEN RCAT(1) = MIN(NINT(POB(N)),IMISS) RCAT(2) = MIN(NINT(TOB(N)),IMISS) RCAT(3) = MIN(NINT(QOB(N)),IMISS) RCAT(4) = MIN(NINT(DOB(N)),IMISS) RCAT(5) = MIN(NINT(SOB(N)),IMISS) RCAT(6) = NINT(PQM(N)) RCAT(7) = NINT(TQM(N)) RCAT(8) = NINT(QQM(N)) RCAT(9) = NINT(WQM(N)) ELSEIF(ICAT.EQ.6) THEN RCAT(1) = MIN(NINT(POB(N)),IMISS) RCAT(2) = MIN(NINT(ZOB(N)),IMISS) RCAT(3) = MIN(NINT(TOB(N)),IMISS) RCAT(4) = MIN(QOB(N),XMISS) RCAT(5) = MIN(NINT(DOB(N)),IMISS) RCAT(6) = MIN(NINT(SOB(N)),IMISS) RCAT(7) = NINT(PQM(N)) RCAT(8) = NINT(ZQM(N)) RCAT(9) = NINT(TQM(N)) RCAT(10) = NINT(QQM(N)) RCAT(11) = NINT(WQM(N)) ELSEIF(ICAT.EQ.8) THEN RCAT(1) = MIN(OB8(N),XMISS) C Allow report sequence number (code fig. 21) to be as large as 999990 IF(NINT(CF8(N)).EQ.21) RCAT(1) = MIN(OB8(N),XMISS*10.) RCAT(2) = MIN(NINT(CF8(N)),IMISS) RCAT(3) = MIN(Q81(N),XMISS) RCAT(4) = NINT(Q82(N)) ELSEIF(ICAT.EQ.51) THEN RCAT( 1) = MIN(NINT(PSL),IMISS) RCAT( 2) = MIN(NINT(STP),IMISS) RCAT( 3) = MIN(NINT(SDR),IMISS) RCAT( 4) = MIN(NINT(SSP),IMISS) RCAT( 5) = MIN(NINT(STM),IMISS) RCAT( 6) = MIN(NINT(DPD),IMISS) RCAT( 7) = IMISS ! Reserved RCAT( 8) = IMISS ! Reserved RCAT( 9) = NINT(PSQ) RCAT(10) = NINT(SPQ) RCAT(11) = NINT(SWQ) RCAT(12) = NINT(STQ) RCAT(13) = NINT(DDQ) ELSE C UNSUPPORTED DATA LEVEL CATEGORY RETURNS A 999 C --------------------------------------------- PRINT'(" ##IW3UNPBF/S02UBF - CATEGORY ",I0," NOT SUPPORTED ", $ "-- IER = 999")', ICAT RETURN 1 END IF C TRANSFER THE LEVEL DATA INTO THE HOLDING ARRAY AND EXIT C ------------------------------------------------------- RCATS(1:MCAT(KCAT),L,KCAT) = RCAT(1:MCAT(KCAT)) RETURN END C*********************************************************************** C*********************************************************************** C*********************************************************************** SUBROUTINE S03UBF(UNP,SUBSET,*,*,*) C ---> PACKS DATA INTO UNP ARRAY PARAMETER (NUMCAT=8, LEVLIM=300, MAXOBS=3500) COMMON/IUBFDD/HDR(12),RCATS(50,LEVLIM,NUMCAT),IKAT(NUMCAT), $ MCAT(NUMCAT),NCAT(NUMCAT),LVDX(NUMCAT) COMMON/IUBFNN/STNIDX,CRES1X,CRES2X CHARACTER*8 STNIDX,CRES1X,CRES2X,SUBSET DIMENSION RCAT(60),JCAT(60),UNP(*) EQUIVALENCE (RCAT(1),JCAT(1)) SAVE C CALL TO SORT DATA LEVEL CATEGORIES 02, 03, 04, AND 08 LEVELS C ------------------------------------------------------------ CALL S04UBF C TRANSFER DATA FROM ALL DATA LEVEL CATEGORIES INTO UNP ARRAY C AND SET POINTERS C ----------------------------------------------------------- INDX = 53 JCAT = 0 NLEVTO = 0 NLEVC8 = 0 DO K = 1,NUMCAT JCAT(LVDX(K)) = NCAT(K) IF(IKAT(K).NE.8) THEN NLEVTO = NLEVTO + NCAT(K) ELSE NLEVC8 = NLEVC8 + NCAT(K) END IF IF(NCAT(K).GT.0) THEN JCAT(LVDX(K)+1) = INDX ELSE JCAT(LVDX(K)+1) = 0 END IF DO J = 1,NCAT(K) DO I = 1,MCAT(K) C UNPACKED REPORT CONTAINS MORE THAN MAXOBS WORDS - RETURNS A 999 C ------------------------------------------------------------- IF(INDX.GT.MAXOBS) THEN PRINT'(" ~~IW3UNPBF/S03UBF: RPT with ID= ",A, $ " TOSSED - CONTAINS ",I0," WORDS, > LIMIT OF ",I0)', $ STNIDX,INDX,MAXOBS RETURN 3 END IF UNP(INDX) = RCATS(I,J,K) INDX = INDX+1 ENDDO ENDDO ENDDO C RETURN WITHOUT PROCESSING THIS REPORT IF NO DATA IN CAT. 1-6, 51 C (UNLESS SSM/I REPORT, THEN DO NOT RETURN UNLESS ALSO NO CAT. 8 DATA) C --------------------------------------------------------------------- IF(NLEVTO.EQ.0) THEN IF(SUBSET(1:5).NE.'NC012') THEN RETURN 2 ELSE IF(NLEVC8.EQ.0) RETURN 2 END IF END IF C TRANSFER THE HEADER AND POINTER ARRAYS INTO UNP C ----------------------------------------------- UNP(1:12) = HDR UNP(13:52) = RCAT(13:52) RETURN END C*********************************************************************** C*********************************************************************** C*********************************************************************** SUBROUTINE S04UBF C ---> SORTS DATA LEVEL CATEGORIES PARAMETER (NUMCAT=8, LEVLIM=300) COMMON/IUBFAA/BMISS COMMON/IUBFDD/HDR(12),RCATS(50,LEVLIM,NUMCAT),IKAT(NUMCAT), $ MCAT(NUMCAT),NCAT(NUMCAT),LVDX(NUMCAT) COMMON/IUBFNN/STNIDX,CRES1X,CRES2X COMMON/IUBFPP/LWI,LWR CHARACTER*8 STNIDX,CRES1X,CRES2X REAL(8) BMISS DIMENSION RCAT(50,LEVLIM),SCAT(50,LEVLIM),IORD(LEVLIM), $ IWORK(65536),RCTL(3) DIMENSION PMAND(21) SAVE DATA XMISS/99999./,PMAND/10000.,9250.,8500.,7000.,5000.,4000., $ 3000.,2500.,2000.,1500.,1000.,700.,500.,300.,200.,100.,70.,50., $ 30.,20.,10./ C INSERT DATA LEVEL CATEGORY 1 PRESSURE & DEF. Q.M.'S INTO THOSE LEVELS C WHERE MSSING C --------------------------------------------------------------------- DO I=1,NCAT(1) IF(RCATS(1,I,1).GE.XMISS) THEN RCATS(1,I,1) = PMAND(I) RCATS(7:11,I,1) = 2.0 END IF ENDDO C SORT DATA LEVEL CATEGORIES 2, 3, AND 4 - LEAVE THE FIRST LEVEL IN C EACH INTACT C ------------------------------------------------------------------ DO K=2,4 IF(NCAT(K).GT.1) THEN DO J=1,NCAT(K)-1 DO I=1,MCAT(K) SCAT(I,J) = RCATS(I,J+1,K) ENDDO ENDDO CALL ORDERS(2,IWORK,SCAT(1,1),IORD,NCAT(K)-1,50,LWR,2) RCTL = BMISS DO J=1,NCAT(K)-1 IF(K.LT.4) JJ = IORD((NCAT(K)-1)-J+1) IF(K.EQ.4) JJ = IORD(J) DO I=1,MCAT(K) RCAT(I,J) = SCAT(I,JJ) ENDDO IDUP = 0 IFLAG = 0 IF(NINT(RCAT(1,J)).EQ.NINT(RCTL(1))) THEN IF(NINT(RCAT(2,J)).EQ.NINT(RCTL(2)).AND. $ NINT(RCAT(3,J)).EQ.NINT(RCTL(3))) THEN if(k.ne.4) then print'(" ~~@@IW3UNPBF/S04UBF: ID ",A," has a ", $ "dupl. cat. ",I0," lvl (all data) at ",G0," ", $ "mb -- lvl will be excluded from processing")', $ stnidx,k,rcat(1,j)*.1 else print'(" ~~@@IW3UNPBF/S04UBF: ID ",A," has a ", $ "dupl. cat. ",I0," lvl (all data) at ",G0," m", $ " -- lvl will be excluded from processing")', $ stnidx,k,rcat(1,j) end if IDUP = 1 ELSE if(k.ne.4) then print'(" ~~@@#IW3UNPBF/S04UBF: ID ",A," has a ", $ "dupl. cat. ",I0," press. lvl (data differ) ", $ "at ",G0," mb -- all q.m. will be FLAGGED")', $ stnidx,k,rcat(1,j)*.1 else print'(" ~~@@#IW3UNPBF/S04UBF: ID ",A," has a ", $ "dupl. cat. ",I0," height lvl (data differ) ", $ "at ",G0," m -- all q.m. will be FLAGGED")', $ stnidx,k,rcat(1,j) end if IFLAG = 1 END IF END IF RCTL = RCAT(1:3,J) IF(IDUP.EQ.1) THEN RCAT(1,J) = BMISS ELSE IF(IFLAG.EQ.1) THEN RCAT(4,J) = 14 RCAT(5,J) = 14 RCAT(4,J-1) = 14 RCAT(5,J-1) = 14 END IF ENDDO JJJ = 1 LOOP1: DO J=2,NCAT(K) IF(RCAT(1,J-1).GE.BMISS) CYCLE LOOP1 JJJ = JJJ + 1 LOOP1n1: DO I=1,MCAT(K) RCATS(I,JJJ,K) = RCAT(I,J-1) ENDDO LOOP1n1 ENDDO LOOP1 if(jjj.ne.NCAT(K)) $ print'(" ~~@@IW3UNPBF/S04UBF: ID ",A," has had ",I0, $ " lvls removed due to their being duplicates")', $ stnidx,NCAT(K)-jjj ncat(k) = jjj end if IF(NCAT(K).EQ.1) THEN IF(MIN(RCATS(1,1,K),RCATS(2,1,K),RCATS(3,1,K)).GT.99998.8) $ NCAT(K) = 0 END IF ENDDO C SORT DATA LEVEL CATEGORY 08 BY CODE FIGURE C ------------------------------------------ DO K=8,8 IF(NCAT(K).GT.1) THEN CALL ORDERS(2,IWORK,RCATS(2,1,K),IORD,NCAT(K),50,LWR,2) DO J=1,NCAT(K) DO I=1,MCAT(K) RCAT(I,J) = RCATS(I,IORD(J),K) ENDDO ENDDO DO J=1,NCAT(K) DO I=1,MCAT(K) RCATS(I,J,K) = RCAT(I,J) ENDDO ENDDO END IF ENDDO C NORMAL EXIT C ----------- RETURN END C*********************************************************************** C*********************************************************************** C*********************************************************************** SUBROUTINE S05UBF C ---> INITIALIZES INPUT ARRAYS CHARACTER*8 STNIDX,CRES1X,CRES2X CHARACTER*11 CBULLX REAL(8) BMISS COMMON/IUBFAA/BMISS COMMON/IUBFEE/OBS(255,9) COMMON/IUBFFF/QMS(255,5) COMMON/IUBFGG/SFO(6) COMMON/IUBFHH/SFQ(5) COMMON/IUBFLL/Q8(255,2) COMMON/IUBFMM/XIND(255) COMMON/IUBFNN/STNIDX,CRES1X,CRES2X COMMON/IUBFSS/CBULLX SAVE DATA IMISS/99999/ C SET THE INPUT OBS DATA ARRAYS TO MISSING, INPUT Q.M. DATA ARRAYS C TO 2, INPUT CAT. 8 INDICATORS TO IMISS AND INPUT SPECIAL LEVEL C INDICATORS TO 0 C ---------------------------------------------------------------- OBS = BMISS QMS = 2 SFO = BMISS SFQ = 2 XIND = 0 Q8 = IMISS STNIDX = ' ' CRES1X = ' ' CRES2X = ' ' CBULLX = ' ' RETURN END C*********************************************************************** C*********************************************************************** C*********************************************************************** FUNCTION I04UBF(P) C ---> ASSIGNS NUMBER TO MANDATORY PRESSURE LEVEL COMMON/IUBFJJ/ISET,MANLIN(1001) SAVE IF(ISET.EQ.0) THEN MANLIN = 0 MANLIN(1000) = 1 MANLIN(925) = 2 MANLIN(850) = 3 MANLIN(700) = 4 MANLIN(500) = 5 MANLIN(400) = 6 MANLIN(300) = 7 MANLIN(250) = 8 MANLIN(200) = 9 MANLIN(150) = 10 MANLIN(100) = 11 MANLIN(70) = 12 MANLIN(50) = 13 MANLIN(30) = 14 MANLIN(20) = 15 MANLIN(10) = 16 MANLIN(7) = 17 MANLIN(5) = 18 MANLIN(3) = 19 MANLIN(2) = 20 MANLIN(1) = 21 ISET = 1 END IF IP = NINT(P*10.) IF(IP.GT.10000 .OR. IP.LT.10 .OR. MOD(IP,10).NE.0) THEN I04UBF = 0 ELSE I04UBF = MANLIN(IP/10) END IF RETURN END C*********************************************************************** C*********************************************************************** C*********************************************************************** FUNCTION R02UBF() CHARACTER*8 QMARK,SUBSET,RPID LOGICAL L02UBF,L03UBF REAL(8) BMISS COMMON/IUBFAA/BMISS SAVE R02UBF = 0 RETURN C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ENTRY ERTUBF(SUBSET,RPID) ERTUBF = BMISS IF(SUBSET(1:5).EQ.'NC000') THEN IF(SUBSET(6:8).EQ.'002') THEN C LAND SYNOPTIC SURFACE - MOBILE C ------------------------------ ERTUBF = 514 ELSE C LAND SYNOPTIC SURFACE - FIXED (RESTRICTED WMO RES. 40 & UNRESTRICTED) C --------------------------------------------------------------------- IF(L02UBF(RPID)) ERTUBF = 511 C METAR SURFACE - FIXED C --------------------- IF(L03UBF(RPID)) ERTUBF = 512 END IF ELSE IF(SUBSET(1:5).EQ.'NC255') THEN C MESONET SURFACE C --------------- ERTUBF = 540 ELSE IF(SUBSET(1:5).EQ.'NC001') THEN !_ships nem 001001 #> Ship - manual and automatic, restricted | !_shipsu nem 001013 #> Ship - manual and automatic, unrestricted | !_shipsb nem 001101 #> Ship - manual and automatic, restricted (BUFR) | !_shipub nem 001113 #> Ship - manual and automatic, unrestricted (BUFR) | IF(SUBSET(7:8).EQ.'01'.OR.SUBSET(7:8).EQ.'13') THEN IF(RPID.NE.'SHIP') THEN C SHIP WITH NAME C -------------- if(subset(6:8).eq.'001'.or.subset(6:8).eq.'013')then ERTUBF = 522 ! TAC-feed -- ID not 'SHIP' else ERTUBF = 524 ! FM94/BUFR-feed -- ID not 'SHIP' endif ELSE C SHIP WITHOUT NAME C ----------------- if(subset(6:8).eq.'101'.or.subset(6:8).eq.'113')then ERTUBF = 523 ! TAC-feed -- ID = 'SHIP' else ERTUBF = 525 ! FM94/BUFR-feed -- ID = 'SHIP' endif END IF ELSE IF(SUBSET(6:8).EQ.'002') THEN C BUOYS ARRIVING IN WMO FM18 FORMAT (FIXED OR DRIFTING) C ----------------------------------------------------- ERTUBF = 562 ELSE IF(SUBSET(6:8).EQ.'003') THEN C BUOYS ARRIVING IN WMO FM13 FORMAT (FIXED) C ----------------------------------------- ERTUBF = 561 ELSE IF(SUBSET(6:8).EQ.'102') THEN C BUOYS ARRIVING IN WMO FM94/BUFR FORMAT (FIXED OR DRIFTING) C ---------------------------------------------------------- ERTUBF = 564 ELSE IF(SUBSET(6:8).EQ.'103') THEN C BUOYS ARRIVING IN WMO FM94/BUFR FORMAT (FIXED) C ---------------------------------------------- ERTUBF = 563 ELSE IF(SUBSET(6:8).EQ.'004' ) THEN C C-MAN PLATFORM (TAC-feed) C ------------------------- ERTUBF = 531 ELSE IF(SUBSET(6:8).EQ.'104' ) THEN C C-MAN PLATFORM (BUFR-feed) C ------------------------- ERTUBF = 530 ELSE IF(SUBSET(6:8).EQ.'005') THEN C TIDE GAUGE C ---------- ERTUBF = 532 ELSE IF(SUBSET(6:8).EQ.'006') THEN C SEA-LEVEL PRESSURE BOGUS C ------------------------ ERTUBF = 551 ELSE IF(SUBSET(6:8).EQ.'007') THEN C COAST GUARD TIDE GAUGE C ---------------------- ERTUBF = 534 END IF ELSE IF(SUBSET(1:5).EQ.'NC002') THEN IF(SUBSET(6:8).EQ.'001') THEN C LAND RADIOSONDE - FIXED C ----------------------- ERTUBF = 011 IF(L03UBF(RPID)) ERTUBF = 012 IF(RPID(1:4).EQ.'CLAS') ERTUBF = 013 ELSE IF(SUBSET(6:8).EQ.'002') THEN C LAND RADIOSONDE - MOBILE C ------------------------ ERTUBF = 013 ELSE IF(SUBSET(6:8).EQ.'003') THEN C SHIP RADIOSONDE C --------------- ERTUBF = 022 IF(RPID(1:4).EQ.'SHIP') ERTUBF = 023 ELSE IF(SUBSET(6:8).EQ.'004') THEN C DROPWINSONDE C ------------- ERTUBF = 031 ELSE IF(SUBSET(6:8).EQ.'005') THEN C PIBAL C ----- ERTUBF = 011 IF(L03UBF(RPID)) ERTUBF = 012 ELSE IF(SUBSET(6:8).EQ.'009') THEN C WIND PROFILERS ORIGINATING FROM PILOT (PIBAL) FORMAT BULLETINS C -------------------------------------------------------------- ERTUBF = 073 END IF ELSE IF(SUBSET.EQ.'NC004005') THEN C RECCOS/DROPS C ------------ ERTUBF = 031 END IF RETURN C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ENTRY MQMUBF(QMARK) IF(QMARK(1:1).EQ.'S'.OR.QMARK(1:1).EQ.'V') THEN CCCCCCCCCCC MQMUBF = 1 ! good MQMUBF = 2 ! good ELSE IF(QMARK(1:1).EQ.'Q') THEN MQMUBF = 3 ! suspect ELSE IF(QMARK(1:1).EQ.'X') THEN MQMUBF = 13 ! failed ELSE IF(QMARK(1:1).EQ.'Z'.OR.QMARK(1:1).EQ.'C') THEN MQMUBF = 2 ! neutral ELSE MQMUBF = 15 ! missing or unknown (make 15 for now ! for diag. checks, later change to 13) ! DAK: 7/2017: believe this ends up as a 2 (?) END IF RETURN C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ENTRY EQMUBF(QMK) IF((NINT(QMK).GE.0 .AND. NINT(QMK).LT.4) .OR. $ (NINT(QMK).GT.9 .AND. NINT(QMK).LT.15)) THEN EQMUBF = NINT(QMK) ELSE IF(NINT(QMK).EQ.6) THEN C To get around the 3-bit limit to SDMEDIT/QUIPS pressure q.m. mnemonic C "QMPR", purge or reject flag on pressure is changed from 12 or 14 to C 6 to fit in 3-bits) EQMUBF = 14 ELSE EQMUBF = 2 END IF RETURN C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ENTRY EQSUBF(QMK) IF(NINT(QMK).GE.0 .AND. NINT(QMK).LT.15) THEN EQSUBF = NINT(QMK) ELSE EQSUBF = 2 END IF IF(NINT(QMK).EQ.6) THEN C (NOTE: Prior to mid-March 1999, a purge or reject flag on pressure C was set to 6 (instead of 14 or 12, resp.) to get around the C 3-bit limit to SDMEDIT/QUIPS pressure q.m. mnemonic "QMPR". C The 3-bit limit on "QMPR" was changed to 4-bits with a decoder C change in February 1999. However, the codes that write the C q.m.'s out (EDTBUFR and QUIPC) weren't changed to write out 14 C or 12 for purge or reject until mid-March 1999. In order to C allow old runs to work properly, a q.m. of 6 will be reset to C 14. This would have to change if q.m.=6 ever has a defined C meaning.) EQSUBF = 14 END IF RETURN END C*********************************************************************** C*********************************************************************** C*********************************************************************** FUNCTION L01UBF() CHARACTER*8 RPID LOGICAL L01UBF,L02UBF,L03UBF SAVE L01UBF = .TRUE. RETURN C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ENTRY L02UBF(RPID) L02UBF = .FALSE. READ(RPID,'(I5)',ERR=1) IBKS L02UBF = .TRUE. 1 RETURN C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ENTRY L03UBF(RPID) L03UBF = .TRUE. READ(RPID,'(I5)',ERR=2) IBKS L03UBF = .FALSE. 2 RETURN END C*********************************************************************** C*********************************************************************** C*********************************************************************** FUNCTION R03UBF(LUNIT,OBS,OBS2,OBS3,NOBS3,obs8_8) C ---> PROCESSES ADPUPA DATA (002/*, 004/005) PARAMETER (NUMCAT=8, LEVLIM=300) COMMON/IUBFAA/BMISS COMMON/IUBFBB/KNDX,KSKACF(8),KSKUPA,KSKSFC,KSKSAT,KFLSAT(12), $ KSKSMI COMMON/IUBFCC/SUBSET COMMON/IUBFDD/HDR(12),RCATS(50,LEVLIM,NUMCAT),IKAT(NUMCAT), $ MCAT(NUMCAT),NCAT(NUMCAT),LVDX(NUMCAT) COMMON/IUBFEE/POB(255),QOB(255),TOB(255),ZOB(255),DOB(255), $ SOB(255),VSG(255),OB8(255),CF8(255) COMMON/IUBFFF/PQM(255),QQM(255),TQM(255),ZQM(255),WQM(255) COMMON/IUBFII/PWMIN COMMON/IUBFLL/Q81(255),Q82(255) COMMON/IUBFMM/XIND(255) CHARACTER*80 HDSTR,LVSTR,QMSTR,RCSTR CHARACTER*8 SUBSET,SID,RSV1,RSV2 REAL(8) RID_8,HDR_8(12),VSG_8(255),OBS2_8(43),OBS3_8(5,255,7), $ RCT_8(5,255),ARR_8(10,255),RAT_8(255),RMORE_8(4),RGP10_8(255), $ PRGP10_8(255),RPMSL_8,RPSAL_8,BMISS,AMINIMUM_8,obs8_8(2) DIMENSION OBS(*),OBS2(43),OBS3(5,255,7),NOBS3(7),RCT(5,255), $ ARR(10,255), RAT(255),RMORE(4),RGP10(255),PRGP10(255),P2(255), $ P8(255),P16(255) EQUIVALENCE (RID_8,SID) LOGICAL L02UBF SAVE DATA HDSTR/'NUL CLON CLAT HOUR MINU SELV '/ DATA LVSTR/'PRLC TMDP TMDB GP07 GP10 WDIR WSPD '/ DATA QMSTR/'QMPR QMAT QMDD QMGP QMWN '/ DATA RCSTR/'RCHR RCMI RCTS '/ DATA XMISS/99999./, IMISS/99999/, GRAV/9.8/ PRS1(Z) = 1013.25 * (((288.15 - (.0065 * Z))/288.15)**5.256) PRS2(Z) = 226.3 * EXP(1.576106E-4 * (11000. - Z)) C FCNS BELOW CONVERT TEMP/TD(K) & PRESS(MB) INTO SAT./SPEC. HUM.(KG/KG) C --------------------------------------------------------------------- ES(T) = 6.1078 * EXP((17.269 * (T - 273.16))/((T - 273.16)+237.3)) QFRMTP(T,P) = (0.622 * ES(T))/(P - (0.378 * ES(T))) R03UBF = 0 C STORE SINGLE LEVEL REPORT DATA DIRECTLY INTO OBS2 ARRAY AND C MULTIPLE LEVEL REPORT DATA DIRECTLY INTO OBS3, C DOUBLE-PRECISION SINGLE LEVEL REPORT DATA DIRECTLY INTO OBS8_8 ARRAY C --------------------------------------------------------------------- OBS2_8 = BMISS OBS3_8 = BMISS NOBS3 = 0 obs8_8 = bmiss CALL UFBINT(LUNIT,OBS2_8( 1),2,1,IRET,'RSRD EXPRSRD') CALL UFBINT(LUNIT,OBS2_8( 4),1,1,IRET,'SST1') IF(IBFMS(OBS2_8(4)).EQ.0) OBS2_8(41) = 2.0 CALL UFBINT(LUNIT,OBS3_8(1,1,3),5,255,IRET, $ 'NUL CLAM CLTP HOCB HOCT') IF(IRET.EQ.1) THEN ! reset iret from 1 to 0 if all obs missing ! (iret can be 1 even if all obs missing) AMINIMUM_8 = MIN(OBS3_8(2,1,3),OBS3_8(3,1,3),OBS3_8(4,1,3), $ OBS3_8(5,1,3)) IF(IBFMS(AMINIMUM_8).NE.0) IRET = 0 END IF NOBS3(3) = IRET IF(SUBSET.EQ.'NC004005') THEN ! RECCOs CALL UFBINT(LUNIT,OBS3_8(1,1,2),5,255,IRET,'PRWE') IF(IRET.EQ.1) THEN ! reset iret from 1 to 0 if all obs missing ! (iret can be 1 even if all obs missing) IF(IBFMS(OBS3_8(1,1,2)).NE.0) IRET = 0 END IF NOBS3(2) = IRET CALL UFBINT(LUNIT,OBS3_8(1,1,6),5,255,IRET,'AFIC HBOI HTOI') IF(IRET.EQ.1) THEN ! reset iret from 1 to 0 if all obs missing ! (iret can be 1 even if all obs missing) AMINIMUM_8 = MIN(OBS3_8(1,1,6),OBS3_8(2,1,6),OBS3_8(3,1,6)) IF(IBFMS(AMINIMUM_8).NE.0) IRET = 0 END IF NOBS3(6) = IRET CALL UFBINT(LUNIT,OBS3_8(1,1,7),5,255,IRET,'DGOT HBOT HTOT') IF(IRET.EQ.1) THEN ! reset iret from 1 to 0 if all obs missing ! (iret can be 1 even if all obs missing) AMINIMUM_8 = MIN(OBS3_8(1,1,7),OBS3_8(2,1,7),OBS3_8(3,1,7)) IF(IBFMS(AMINIMUM_8).NE.0) IRET = 0 END IF NOBS3(7) = IRET CALL UFBINT(LUNIT,OBS2_8(27),2,1,IRET,'WDIR1 WSPD1') ELSE ! RAOBs, PIBALs c HBLCS is replicated for NC002* but is always missng on all but 1st lvl CALL UFBINT(LUNIT,OBS2_8(24),1,1,IRET,'HBLCS') END IF OBS2 = OBS2_8 OBS3 = OBS3_8 CALL S05UBF C VERTICAL SIGNIFICANCE DESCRIPTOR TO ASSIGN UNPACKED DATA LEVEL C CATEGORY C -------------------------------------------------------------- C NOTE: MNEMONIC "VSIG" 008001 IS DEFINED AS VERTICAL SOUNDING C SIGNIFICANCE -- CODE TABLE FOLLOWS: C 64 Surface C processed as unpacked category 2 and/or 3 and/or 4 C 32 Standard (mandatory) level C processed as unpacked category 1 C 16 Tropopause level C processed as unpacked category 5 C 8 Maximum wind level C processed as unpacked category 3 or 4 C 4 Significant level, temperature C processed as unpacked category 2 C 2 Significant level, wind C processed as unpacked category 3 or 4 C C NOTE: THIS SUBR. ASSIGNS VSIG=1 TO LEVELS THAT SHOULD BE C PROCESSED AS UNPACKED CATEGORY 6 (ONLY APPLIES TO C RECCOS) C C anything else - the level is not processed CALL UFBINT(LUNIT,VSG_8,1,255,NLEV,'VSIG');VSG=VSG_8 C PUT THE HEADER INFORMATION INTO UNPACKED FORMAT C ----------------------------------------------- CALL UFBINT(LUNIT,HDR_8,12, 1,IRET,HDSTR);HDR=HDR_8 IF(HDR(5).GE.BMISS) HDR(5) = 0 CALL UFBINT(LUNIT,RID_8,1,1,IRET,'RPID') cccc IF(IRET.NE.1.OR.(RID_8.GT.BMISS-5000..AND.RID_8.LT.BMISS+5000.)) cccc $ SID = 'MISSING ' cxxxx cpppppppppp cc print'(" rid_8,icbfms(sid,8): ",G0,1X,I0)', rid_8,icbfms(sid,8) cpppppppppp ccccc IF(ICBFMS(SID,8).NE.0) SID = 'MISSING ' C above line not working right - may return 0 when missing, so use next C two lines below temporarily until this is fixed (readlc will return C all blanks for sid when mnemonic "RPID" not found) - dak 2/19/13 call readlc(lunit,sid,'RPID') cpppppppppp cc print'(" sid = """,A,"""")', sid cpppppppppp if(sid.eq.' ') sid = 'MISSING ' cxxxx cppppp-ID iprint = 0 cc iprint = 1 c if(sid.eq.'89571 ') iprint = 1 c if(sid.eq.'68906 ') iprint = 1 c if(sid.eq.'68842 ') iprint = 1 c if(sid.eq.'59362 ') iprint = 1 c if(sid.eq.'57957 ') iprint = 1 c if(sid.eq.'74794 ') iprint = 1 c if(sid.eq.'74389 ') iprint = 1 c if(sid.eq.'96801A ') iprint = 1 if(iprint.eq.1) $ print'(" @@@ START DIAGNOSTIC PRINTOUT FOR ID ",A)', sid cppppp-ID RGP10 = BMISS PRGP10 = BMISS CALL UFBINT(LUNIT,RPMSL_8,1, 1,IRET,'PMSL');RPMSL=RPMSL_8 IF(SUBSET.EQ.'NC004005') THEN CALL UFBINT(LUNIT,RGP10_8,1,255,NLEV,'GP10');RGP10=RGP10_8 CALL UFBINT(LUNIT,RPSAL_8,1,1,IRET,'PSAL');RPSAL=RPSAL_8 IF(NINT(VSG(1)).EQ.32.AND.RPMSL.GE.BMISS.AND. $ MAX(RGP10(1),RPSAL).LT.BMISS) THEN cpppppppppp cc print'(" ~~IW3UNPBF/R03UBF: ID ",A," is a Cat. 6 type ", cc $ "RECCO with a mand-lvl GEOPOT")', sid cpppppppppp VSG(1) = 1 CALL UFBINT(LUNIT,PRGP10_8,1,255,NLEV,'PRLC') PRGP10=PRGP10_8 HDR(6) = RPSAL + SIGN(0.0000001,RPSAL) ELSE IF(MIN(VSG(1),RPMSL,RGP10(1)).GE.BMISS.AND.RPSAL.LT. $ BMISS) THEN cpppppppppp cc print'(" ~~IW3UNPBF/R03UBF: ID ",A," is a Cat. 6 type ", cc $ "RECCO")', sid cpppppppppp VSG(1) = 1 HDR(6) = RPSAL + SIGN(0.0000001,RPSAL) ELSE IF(MIN(VSG(1),RGP10(1)).GE.BMISS.AND.MAX(RPMSL,RPSAL) $ .LT.BMISS) THEN cpppppppppp cc print'(" ~~IW3UNPBF/R03UBF: ID ",A," is a Cat. 6 type ", cc $ "RECCO with a valid PMSL")', sid cpppppppppp VSG(1) = 1 HDR(6) = RPSAL + SIGN(0.0000001,RPSAL) ELSE print'(" ~~IW3UNPBF/R03UBF: ID ",A," is currently an ", $ "unknown type of RECCO - VSIG =",G0,"; PMSL =",G0,"; GP10", $ " =",G0," -- SKIP IT for now")', sid,VSG(1),RPMSL,RGP10(1) R03UBF = -9999 KSKUPA =KSKUPA + 1 RETURN END IF END IF obs8_8(1) = hdr_8(3) obs8_8(2) = hdr_8(2) XOB = HDR(2) YOB = HDR(3) RHR = BMISS IF(HDR(4).LT.BMISS) RHR = NINT(HDR(4))+NINT(HDR(5))/60. RCTIM = BMISS RSV1 = ' ' RSV2 = ' ' ELV = HDR(6) QMELV = XMISS CALL UFBINT(LUNIT,RAT_8, 1,255,NLEV,'RATP');RAT=RAT_8 ITP = MIN(IMISS,NINT(RAT(1))) RTP = ERTUBF(SUBSET,SID) IDS = IMISS IF(ELV.GE.BMISS) THEN IF((RTP.GT.20.AND.RTP.LT.24).OR.SUBSET.EQ.'NC002004') THEN print'(" IW3UNPBF/R03UBF: ID ",A," has a missing elev, so ", $ "elevation set to ZERO")', sid ELV = 0 ELSE print'(" ~~IW3UNPBF/R03UBF: ID ",A," has a missing elev")', $ sid END IF END IF cdak if(sid(5:5).eq.' ') print, sid IF(L02UBF(SID).AND.SID(5:5).EQ.' ') SID = '0'//SID RSTP = IMISS IF(RTP.EQ.31) THEN IF(SUBSET.EQ.'NC004005') THEN RSTP = 1 ELSE RSTP = 2 END IF END IF CALL S01UBF(SID,XOB,YOB,RHR,RCTIM,RSV1,RSV2,ELV,QMELV,ITP,RTP, $ RSTP,IDS) C PUT THE LEVEL DATA INTO SPECIFIED UNPACKED FORMAT C ------------------------------------------------- CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,LVSTR);ARR=ARR_8 PWMIN = 999999. DO L=1,NLEV POB(L) = BMISS IF(ARR(1,L).LT.BMISS) POB(L) = NINT(ARR(1,L)*.1) IF(NINT(ARR(1,L)).LE.0) THEN POB(L) = BMISS print'(" ~~@@IW3UNPBF/R03UBF: ID ",A," has a ZERO or ", $ "negative reported pressure that is reset to missing")', $ sid END IF QOB(L) = BMISS IF(ARR(2,L).LT.BMISS .AND. ARR(3,L).LT.BMISS) $ QOB(L) = (ARR(3,L)-ARR(2,L))*10. TOB(L) = BMISS IF(ARR(3,L).LT.BMISS) THEN ITMP = NINT(ARR(3,L)*100.) TOB(L) = NINT((ITMP-27315)*0.1) END IF XXX = BMISS IF(ARR(4,L).LT.BMISS) XXX = (ARR(4,L)/GRAV) YYY = BMISS IF(ARR(5,L).LT.BMISS) YYY = (ARR(5,L)/GRAV) ZOB(L) = MIN(XXX,YYY) DOB(L) = ARR(6,L) SOB(L) = MIN(ARR(7,L)*10.,BMISS) IF(NINT(DOB(L)).EQ.0.AND.NINT(SOB(L)).GT.0) THEN DOB(L) = 360 ELSE IF(NINT(DOB(L)).EQ.360.AND.NINT(SOB(L)).EQ.0) THEN DOB(L) = 0 END IF if(iprint.eq.1) then print'(" At lvl=",I0,"; VSG=",G0,"; POB = ",G0,"; QOB = ", $ G0,"; TOB = ",G0,"; ZOB = ",G0,"; DOB = ",G0,"; SOB = ", $ G0)', L,vsg(L),pob(L),qob(L),tob(L),zob(L),dob(L),sob(L) end if IF(MAX(POB(L),DOB(L),SOB(L)).LT.BMISS) PWMIN =MIN(PWMIN,POB(L)) ENDDO CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,QMSTR);ARR=ARR_8 DO L=1,NLEV PQM(L) = EQMUBF(ARR(1,L)) TQM(L) = EQMUBF(ARR(2,L)) QQM(L) = EQMUBF(ARR(3,L)) ZQM(L) = EQMUBF(ARR(4,L)) WQM(L) = EQMUBF(ARR(5,L)) ENDDO C SURFACE DATA MUST GO FIRST C -------------------------- CALL S02UBF(2,0,*9999) CALL S02UBF(3,0,*9999) CALL S02UBF(4,0,*9999) INDX2 = 0 INDX8 = 0 INDX16 = 0 P2 = BMISS P8 = BMISS P16 = BMISS LOOP1: DO L=1,NLEV IF(NINT(VSG(L)).EQ.64) THEN if(iprint.eq.1) then print'(" Lvl=",I0," is a surface level")', L end if if(iprint.eq.1.and.POB(L).LT.BMISS.AND.TOB(L).LT.BMISS) then print'(" --> valid cat. 2 sfc. lvl ")' end if IF(POB(L).LT.BMISS.AND.TOB(L).LT.BMISS) CALL SE01UBF(2,L) if(iprint.eq.1.and.POB(L).LT.BMISS.AND.DOB(L).LT.BMISS) then print'(" --> valid cat. 3 sfc. lvl ")' end if IF(POB(L).LT.BMISS.AND.DOB(L).LT.BMISS) CALL SE01UBF(3,L) IF(MAX(ZOB(L),DOB(L)).LT.BMISS) THEN if(iprint.eq.1) print'(" --> valid cat. 4 sfc. lvl ")' C DATA LEVEL CATEGORY 4 HEIGHT DOES NOT PASS ON A KEEP, PURGE, OR REJECT C LIST Q.M. ZQM(L) = 2 CALL SE01UBF(4,L) END IF VSG(L) = 0 ELSE IF(NINT(VSG(L)).EQ.2) THEN P2(L) = POB(L) INDX2 = L IF(INDX8.GT.0) THEN LOOP1n1: DO II = 1,INDX8 IF(NINT(POB(L)).EQ.NINT(P8(II)).AND.POB(L).LT.BMISS) $ THEN if(iprint.eq.1) then print'(" ## This cat. 3 level, on lvl ",I0, $ " will have already been processed as a cat. ", $ "3 MAX wind lvl (on lvl ",I0,") - skip this ", $ "Cat. 3 lvl")', L,II end if IF(MAX(SOB(II),DOB(II)).GE.BMISS) THEN SOB(II) = SOB(L) DOB(II) = DOB(L) if(iprint.eq.1) then print'(" ...... also on lvl ",I0," - ", $ "transfer wind data to dupl. MAX wind lvl ", $ "because its missing there")', L end if END IF VSG(L) = 0 CYCLE LOOP1 END IF ENDDO LOOP1n1 END IF ELSE IF(NINT(VSG(L)).EQ.8) THEN P8(L) = POB(L) INDX8 = L IF(INDX2.GT.0) THEN LOOP1n2: DO II = 1,INDX2 IF(NINT(POB(L)).EQ.NINT(P2(II)).AND.POB(L).LT.BMISS) $ THEN if(iprint.eq.1) then print'(" ## This MAX wind level, on lvl ",I0, $ " will have already been processed as a cat. ", $ "3 lvl (on lvl ",I0,") - skip this MAX wind ", $ "lvl but set")', L,II print'(" cat. 3 lvl XIND to ""2""")' end if XIND(II) = 2 IF(NINT(POB(L)).EQ.NINT(PWMIN)) XIND(II) = 3 IF(MAX(SOB(II),DOB(II)).GE.BMISS) THEN SOB(II) = SOB(L) DOB(II) = DOB(L) if(iprint.eq.1) then print'(" ...... also on lvl ",I0," - ", $ "transfer wind data to dupl. cat. 3 lvl ", $ "because its missing there")', L end if END IF VSG(L) = 0 CYCLE LOOP1 END IF ENDDO LOOP1n2 END IF IF(INDX8-1.GT.0) THEN LOOP1n3: DO II = 1,INDX8-1 IF(NINT(POB(L)).EQ.NINT(P8(II)).AND.POB(L).LT.BMISS) $ THEN if(iprint.eq.1) then print'(" ## This cat. 3 MAX wind lvl, on lvl ", $ I0," will have already been processed as a ", $ "cat. 3 MAX wind lvl (on lvl ",I0,") - skip ", $ "this Cat. 3 MAX wind lvl")', L,II end if IF(MAX(SOB(II),DOB(II)).GE.BMISS) THEN SOB(II) = SOB(L) DOB(II) = DOB(L) if(iprint.eq.1) then print'(" ...... also on lvl ",I0," - ", $ "transfer wind data to dupl. MAX wind lvl ", $ "because its missing there")', L end if END IF VSG(L) = 0 CYCLE LOOP1 END IF ENDDO LOOP1n3 END IF ELSE IF(NINT(VSG(L)).EQ.16) THEN INDX16 = INDX16 + 1 P16(INDX16) = POB(L) END IF ENDDO LOOP1 C REST OF THE DATA C ---------------- DO L=1,NLEV IF(NINT(VSG(L)).EQ.32) THEN LL = I04UBF(POB(L)*.1) IF(LL.LE.0) THEN print'("~~IW3UNPBF/R03UBF: ID ",A," has VSG=32 for lvl ", $ I0," but pressure (=",G0,"mb) not mand.!! --> this ", $ "level not processed")', sid,L,POB(L)*.1 ELSE IF(MIN(DOB(L),ZOB(L),TOB(L)).GE.BMISS) THEN if(iprint.eq.1) then print'(" ==> For lvl ",I0,"; VSG=32 & DOB,ZOB,TOB", $ " all missing --> this level not processed")', L end if VSG(L) = 0 ELSE if(iprint.eq.1) then print'(" ==> For lvl ",I0,"; VSG=32 & one or more", $ " of ZOB,TOB,DOB non-missing --> valid cat. 1 ", $ "lvl")', L end if CALL S02UBF(1,L,*9999) VSG(L) = 0 END IF END IF ELSE IF(NINT(VSG(L)).EQ. 4) THEN if(iprint.eq.1) then print'(" ==> For lvl ",I0,"; VSG= 4 --> valid cat. 2 ", $ "lvl")', L end if IF(INDX16.GT.0) THEN DO II = 1,INDX16 IF(NINT(POB(L)).EQ.NINT(P16(II)).AND.POB(L).LT.BMISS) $ THEN if(iprint.eq.1) then print'(" ## This cat. 2 level, on lvl ",I0, $ " is also the tropopause level, as its ", $ "pressure matches that of trop. lvl no. ",I0, $ " - set this cat. 2")', L,II print'(" lvl XIND to ""1""")' end if XIND(L) = 1 EXIT END IF ENDDO END IF CALL S02UBF(2,L,*9999) VSG(L) = 0 ELSEIF(NINT(VSG(L)).EQ.16) THEN if(iprint.eq.1) then print'(" ==> For lvl ",I0,"; VSG=16 --> valid cat. 5 ", $ "lvl")', L end if CALL S02UBF(5,L,*9999) VSG(L) = 0 ELSEIF(NINT(VSG(L)).EQ. 1) THEN if(iprint.eq.1) then print'(" ==> For lvl ",I0,"; VSG=1 --> valid cat. 6 lvl", $ " - can only be a Recco")', L end if POB(L) = BMISS ZOB(L) = ELV C All data level category 6 reports store specific humidity (g/kg) C as moisture variable C ---------------------------------------------------------------- TDD = BMISS IF(QOB(L).LT.BMISS) TDD = QOB(L) * 0.1 QOB(L) = BMISS IF(MAX(TOB(L),TDD).LT.BMISS.AND.TDD.GT.0) THEN IF(ZOB(L).LT.XMISS) THEN IF(NINT(ZOB(L)).LE.11000) THEN P = PRS1(ZOB(L)) ELSE P = PRS2(ZOB(L)) END IF TD = ((TOB(L) * 0.1) + 273.15) - TDD QQ = QFRMTP(TD,P) IF(QQ.GT.0.0) QOB(L) = QQ * 1000. END IF cpppppppppp cc print'("~#~# For sid = ",A,", a valid tdd = ",G0,"C, a valid tob", cc $ " = ",G0,"C, and a valid zob = ",G0,"m")', sid,tdd,tob(L)*0.1, cc $ zob(L) cc print'(" -- calc. quantities: p = ",G0,"mb, td = ",G0,"K, qq = ", cc $ G0,"kg/kg, qob = ",G0,"g/kg")', p,td,qq,qob(L) cpppppppppp END IF cpppppppppp cc print'("~#~# GOING INTO S02UFB, QOB(L) = ",G0)', qob(L) cpppppppppp CALL S02UBF(6,L,*9999) VSG(L) = 0 ELSEIF(NINT(VSG(L)).EQ. 2) THEN IF(POB(L).LT.BMISS) THEN IF(MAX(SOB(L),DOB(L)).LT.BMISS) THEN if(iprint.eq.1) then print'(" ==> For lvl ",I0,"; VSG= 2 & POB .ne. ", $ "missing --> valid cat. 3 lvl (expect that ZOB is ", $ "missing)")', L end if IF(INDX16.GT.0) THEN DO II = 1,INDX16 IF(NINT(POB(L)).EQ.NINT(P16(II))) THEN if(iprint.eq.1) then print'(" ## This cat. 3 level, on lvl ",I0, $ " is also the tropopause level, as its ", $ "pressure matches that of trop. lvl no. ", $ I0," - set this cat. 3")', L,II print'(" lvl XIND to ""1""")' end if XIND(L) = 1 EXIT END IF ENDDO END IF CALL S02UBF(3,L,*9999) ELSE if(iprint.eq.1) then print'(" ==> For lvl ",I0,"; VSG= 2 & POB .ne. ", $ "missing --> Cat. 3 level not processed - wind is ", $ "missing")', L end if END IF VSG(L) = 0 ELSE IF(ZOB(L).LT.BMISS) THEN IF(MAX(SOB(L),DOB(L)).LT.BMISS) THEN if(iprint.eq.1) then print'(" ==> For lvl ",I0,"; VSG= 2 & ZOB .ne. ", $ "missing --> valid cat. 4 lvl (POB must always ", $ "be missing)")', L end if C DATA LEVEL CATEGORY 4 HEIGHT DOES NOT PASS ON A KEEP, PURGE, OR C REJECT LIST Q.M. C --------------------------------------------------------------- ZQM(L) = 2 CALL S02UBF(4,L,*9999) ELSE if(iprint.eq.1) then print'(" ==> For lvl ",I0,"; VSG= 2 & ZOB .ne. ", $ "missing --> Cat. 4 level not processed - wind ", $ "is missing")', L end if END IF VSG(L) = 0 END IF ELSEIF(NINT(VSG(L)).EQ. 8) THEN IF(POB(L).LT.BMISS) THEN if(iprint.eq.1) then print'(" ==> For lvl ",I0,"; VSG= 8 & POB .ne. ", $ "missing --> valid cat. 3 lvl (expect that ZOB ", $ "is missing)")', L end if IF(INDX16.GT.0) THEN DO II = 1,INDX16 IF(NINT(POB(L)).EQ.NINT(P16(II))) THEN if(iprint.eq.1) then print'(" ## This cat. 3 level, on lvl ",I0, $ " is also the tropopause level, as its ", $ "pressure matches that of trop. lvl no. ", $ I0," - set this cat. 3")', L,II print'(" lvl XIND to ""1""")' end if XIND(L) = 1 EXIT END IF ENDDO END IF CALL S02UBF(3,L,*9999) VSG(L) = 0 ELSE IF(ZOB(L).LT.BMISS) THEN IF(MAX(SOB(L),DOB(L)).LT.BMISS) THEN if(iprint.eq.1) then print'(" ==> For lvl ",I0,"; VSG= 8 & ZOB .ne. ", $ "missing --> valid cat. 4 lvl (POB must always ", $ "be missing)")', L end if C DATA LEVEL CATEGORY 4 HEIGHT DOES NOT PASS ON A KEEP, PURGE, OR C REJECT LIST Q.M. C --------------------------------------------------------------- ZQM(L) = 2 CALL S02UBF(4,L,*9999) ELSE if(iprint.eq.1) then print'(" ==> For lvl ",I0,"; VSG= 8 & ZOB .ne. ", $ "missing --> Cat. 4 level not processed - wind ", $ "is missing")', L end if END IF VSG(L) = 0 END IF END IF C CHECK FOR LEVELS WHICH GOT LEFT OUT C ----------------------------------- IF(NINT(VSG(L)).GT.0) THEN PRINT 887, L,SID,NINT(VSG(L)) 887 FORMAT('##IW3UNPBF/R03UBF - ~~ON LVL',I4,' OF ID ',A8, $ ', A VERTICAL SIGNIFICANCE OF',I3,' WAS NOT SUPPORTED - ', $ 'LEAVE THIS LEVEL OUT OF THE PROCESSING') print'(" ..... at lvl=",I0,"; POB = ",G0,"; QOB = ",G0, $ "; TOB = ",G0,"; ZOB = ",G0,"; DOB = ",G0,";")', $ L,pob(L),qob(L),tob(L),zob(L),dob(L) print'(" SOB = ",G0)', sob(L) END IF ENDDO C ----------------------------------------------------- C MISC DATA GOES INTO DATA LEVEL CATEGORY 08 C ----------------------------------------------------- C CODE FIGURE 104 - RELEASE TIME IN .01*HR C CODE FIGURE 105 - RECEIPT TIME IN .01*HR C CODE FIGURE 351 - GEOPOTENTIAL HEIGHT (METERS) C INDICATOR 1 IS PRESSURE LEVEL (MB) C INDICATOR 2 CONTAINS GEOPOTENTIAL QUALITY MARKER C CODE FIGURE 352 - MEAN-SEA LEVEL PRESSURE IN .1*MB C CODE FIGURE 353 - SOLAR AND INFRARED RADIATION CORRECTION C INDICATOR C CODE FIGURE 354 - TRACKING TECHNIQUE/STATUS OF SYSTEM USED C INDICATOR C ----------------------------------------------------------- CALL UFBINT(LUNIT,RCT_8, 5,255,NRCT,RCSTR);RCT=RCT_8 C NOTE: MNEMONIC "RCTS" 008202 IS A LOCAL DESCRIPTOR DEFINED AS C RECEIPT TIME SIGNIFICANCE - THIS IS STORED IN INDICATOR 1 C FOR CATEGORY 8 CODE FIGURE 105 -- CODE TABLE FOLLOWS: C 0 General decoder receipt time C 1 NCEP receipt time C 2 OSO receipt time C 3 ARINC ground station receipt time C 4 Radiosonde TEMP AA part receipt time C 5 Radiosonde TEMP BB part receipt time C 6 Radiosonde TEMP CC part receipt time C 7 Radiosonde TEMP DD part receipt time C 8 Radiosonde PILOT AA part receipt time C 9 Radiosonde PILOT BB part receipt time C 10 Radiosonde PILOT CC part receipt time C 11 Radiosonde PILOT DD part receipt time C 12-62 Reserved for future use C 63 Missing DO L=1,NRCT CF8(L) = 105 OB8(L) = NINT((NINT(RCT(1,L))+NINT(RCT(2,L))/60.) * 100.) Q81(L) = IMISS IF(RCT(3,L).LT.BMISS) Q81(L) = NINT(RCT(3,L)) Q82(L) = IMISS CALL S02UBF(8,L,*9999) ENDDO CALL UFBINT(LUNIT,RMORE_8,4,1,NRMORE,'SIRC TTSS UALNHR UALNMN') RMORE=RMORE_8 IF(MAX(RMORE(3),RMORE(4)).LT.BMISS) THEN CF8(1) = 104 OB8(1) = NINT((RMORE(3)+RMORE(4)/60.) * 100.) Q81(1) = IMISS Q82(1) = IMISS CALL S02UBF(8,1,*9999) END IF IF(SUBSET.EQ.'NC004005') THEN IF(MAX(PRGP10(1),RGP10(1)).LT.BMISS) THEN RGP10(1) = (NINT(RGP10(1))/GRAV) if(iprint.eq.1) print'(" orig. RGP10 = ",G0)', rgp10(1) IF(MOD(NINT(RGP10(1)),10).NE.0) RGP10(1) = $ INT(RGP10(1)/10.) * 10 CF8(1) = 351 OB8(1) = NINT(RGP10(1)) Q81(1) = NINT(PRGP10(1)/100.) Q82(1) = 3 CALL S02UBF(8,1,*9999) END IF IF(RPMSL.LT.BMISS) THEN CF8(1) = 352 OB8(1) = NINT(RPMSL*.1) Q81(1) = IMISS Q82(1) = IMISS CALL S02UBF(8,1,*9999) END IF END IF IF(RMORE(1).LT.BMISS) THEN CF8(1) = 353 OB8(1) = NINT(RMORE(1)) Q81(1) = IMISS Q82(1) = IMISS CALL S02UBF(8,1,*9999) END IF IF(RMORE(2).LT.BMISS) THEN CF8(1) = 354 OB8(1) = NINT(RMORE(2)) Q81(1) = IMISS Q82(1) = IMISS CALL S02UBF(8,1,*9999) END IF C PUT THE UNPACKED REPORT INTO OBS C -------------------------------- CALL S03UBF(OBS,SUBSET,*9999,*9998,*9997) RETURN 9999 CONTINUE R03UBF = 999 RETURN 9998 CONTINUE print'("IW3UNPBF/R03UBF: RPT with ID= ",A," TOSSED - ZERO ", $ "CAT.1-6,51 LVLS")', SID 9997 CONTINUE R03UBF = -9999 KSKUPA =KSKUPA + 1 RETURN END C*********************************************************************** C*********************************************************************** C*********************************************************************** FUNCTION R04UBF(LUNIT,OBS,OBS2,OBS3,NOBS3,obs8_8) C ---> PROCESSES SURFACE AND MESONET DATA (000/*, 001/*, 255/*) COMMON/IUBFAA/BMISS COMMON/IUBFBB/KNDX,KSKACF(8),KSKUPA,KSKSFC,KSKSAT,KFLSAT(12), $ KSKSMI COMMON/IUBFCC/SUBSET COMMON/IUBFEE/POB(255),QOB(255),TOB(255),ZOB(255),DOB(255), $ SOB(255),VSG(255),OB8(255),CF8(255) COMMON/IUBFGG/PSL,STP,SDR,SSP,STM,DPD COMMON/IUBFHH/PSQ,SPQ,SWQ,STQ,DDQ COMMON/IUBFLL/Q81(255),Q82(255) CHARACTER*80 HDSTR,RCSTR CHARACTER*8 SUBSET,SID,RSV1,RSV2,PRVSTG,SPRVSTG,QCD INTEGER ITIWM(0:15) REAL(8) RID_8,UFBINT_8,OBS2_8(43),OBS3_8(5,255,7),RRVSTG_8(255), $ UFBINT2_8(12,255), RTMP(5,255),RRTMP, $ RPRVSTG_8(255),HDR_8(20),RCT_8(5,255),SOLR_8(3,255), $ TOPC_8(5,255),RMSO_8(2),RQCD_8,BMISS,AMINIMUM_8,obs8_8(2) DIMENSION OBS(*),OBS2(43),OBS3(5,255,7),NOBS3(7),HDR(20), $ RCT(5,255),RRSV(5),SOLR(3,255),TOPC(5,255) EQUIVALENCE (RID_8,SID),(RRVSTG_8,PRVSTG),(RPRVSTG_8,SPRVSTG), $ (RQCD_8,QCD) SAVE DATA HDSTR/'RPID CLON CLAT HOUR MINU SELV QCEVR '/ DATA RCSTR/'RCHR RCMI RCTS '/ DATA IMISS/99999/ DATA ITIWM/0,3*7,3,3*7,1,3*7,4,3*7/ R04UBF = 0 C STORE SINGLE LEVEL REPORT DATA DIRECTLY INTO OBS2 ARRAY, C MULTIPLE LEVEL REPORT DATA DIRECTLY INTO OBS3 ARRAY AND C DOUBLE-PRECISION SINGLE LEVEL REPORT DATA DIRECTLY INTO OBS8_8 ARRAY C --------------------------------------------------------------------- OBS2_8 = BMISS OBS3_8 = BMISS NOBS3 = 0 obs8_8 = bmiss RTMP = bmiss UFBINT2_8 = bmiss CALL UFBINT(LUNIT,OBS2_8(1),2,1,IRET,'RSRD EXPRSRD') CALL UFBINT(LUNIT,OBS2_8(4),1,1,IRET,'SST1') IF(IBFMS(OBS2_8(4)).EQ.0) OBS2_8(41) = 2.0 IF(SUBSET(1:5).EQ.'NC000') THEN ! All surface land IF(SUBSET(6:7).EQ.'10') THEN CALL UFBSEQ(LUNIT,UFBINT2_8(1,1),4,255,IRET, 'VISBSEQN') IF(UFBINT2_8(3,1).EQ.0) OBS2_8(7)=2 IF(UFBINT2_8(3,1).EQ.1) OBS2_8(7)=0 IF(UFBINT2_8(3,1).EQ.2) OBS2_8(7)=4 IF(UFBINT2_8(3,1).EQ.3) OBS2_8(7)=7 OBS2_8(8)=UFBINT2_8(4,1) ELSE CALL UFBINT(LUNIT,OBS2_8( 8),2,1,IRET,'HOVI VTVI') ENDIF IF(SUBSET(6:7).EQ.'10') THEN CALL UFBSEQ(LUNIT,UFBINT2_8(1,1),3,255,IRET, 'BSYWND2') RRTMP = UFBINT2_8(1,1) IF(RRTMP.LT.0.0) RRTMP=-RRTMP OBS2_8(14) = RRTMP OBS2_8(15) = UFBINT2_8(3,1) ELSE CALL UFBINT(LUNIT,OBS2_8(14),2,1,IRET,'.DTMMXGS MXGS') ENDIF CALL UFBINT(LUNIT,OBS2_8(17),3,1,IRET,'TP01 TP03 TP06') CALL UFBINT(LUNIT,OBS2_8(21),1,1,IRET,'TP24') CALL UFBINT(LUNIT,OBS2_8(30),2,1,IRET,'DOFS TOSD') CALL UFBINT(LUNIT,OBS3_8(1,1,2),5,255,IRET,'PRWE') IF(IRET.EQ.1) THEN ! reset iret from 1 to 0 if all obs missing ! (iret can be 1 even if all obs missing) IF(IBFMS(OBS3_8(1,1,2)).NE.0) IRET = 0 END IF NOBS3(2) = IRET IF(SUBSET(6:7).EQ.'10') THEN CALL UFBSEQ(LUNIT,OBS3_8(1,1,3),5,255,JRET, 'BSYBCLD') DO I=1,JRET DO J=1,5 RTMP(J,I)=OBS3_8(J,I,3) ENDDO ENDDO CALL UFBSEQ(LUNIT,OBS3_8(1,1,3),5,255,IRET, 'BSYSCLD') DO I=1,IRET OBS3_8(4,I,3)=OBS3_8(5,I,3) OBS3_8(5,I,3)=BMISS ENDDO CDONG -- BELOW NEED TO CHANGE IN THE FUTURE DO I=1,JRET OBS3_8(5,I,3)=RTMP(4,I) ENDDO ELSE CALL UFBINT(LUNIT,OBS3_8(1,1,3),5,255,IRET, $ 'VSSO CLAM CLTP HOCB HOCT') ENDIF IF(IRET.EQ.1) THEN ! reset iret from 1 to 0 if all obs missing ! (iret can be 1 even if all obs missing) AMINIMUM_8 = MIN(OBS3_8(1,1,3),OBS3_8(2,1,3),OBS3_8(3,1,3), $ OBS3_8(4,1,3),OBS3_8(5,1,3)) IF(IBFMS(AMINIMUM_8).NE.0) IRET = 0 END IF NOBS3(3) = IRET IF(SUBSET(6:7).EQ.'10') THEN ! SYNOPs (NC000100, NC000101, NC000102) CALL UFBSEQ(LUNIT,UFBINT2_8(1,1),12,255,IRET,'BSYEXTM') DO I=1,IRET IF(UFBINT2_8(3,I).LT.BMISS.AND.UFBINT2_8(4,I).LT.BMISS) $ OBS3_8(1,I,4)=UFBINT2_8(4,I)-UFBINT2_8(3,I) IF(UFBINT2_8(5,I).LT.BMISS) OBS3_8(2,I,4)=UFBINT2_8(5,I) IF(UFBINT2_8(6,I).LT.BMISS.AND.UFBINT2_8(7,I).LT.BMISS) $ OBS3_8(3,I,4)=UFBINT2_8(7,I)-UFBINT2_8(6,I) IF(UFBINT2_8(8,I).LT.BMISS) OBS3_8(4,I,4)=UFBINT2_8(8,I) ENDDO ELSE CALL UFBINT(LUNIT,OBS3_8(1,1,4),5,255,IRET, $ '.DTHMXTM MXTM .DTHMITM MITM') ENDIF IF(IRET.EQ.1) THEN ! reset iret from 1 to 0 if all obs missing ! (iret can be 1 even if all obs missing) AMINIMUM_8 = MIN(OBS3_8(1,1,4),OBS3_8(2,1,4),OBS3_8(3,1,4), $ OBS3_8(4,1,4)) IF(IBFMS(AMINIMUM_8).NE.0) IRET = 0 END IF NOBS3(4) = IRET IF(SUBSET(6:8).EQ.'007') THEN ! METARs CALL UFBINT(LUNIT,OBS2_8( 7),1,1,IRET,'.REHOVI') CALL UFBINT(LUNIT,OBS2_8(12),2,1,IRET,'PKWDSP PKWDDR') CALL UFBINT(LUNIT,OBS2_8(22),1,1,IRET,'TOSS') CALL UFBINT(LUNIT,OBS2_8( 3),1,1,IRET,'ALSE') ELSE IF(SUBSET(6:7).EQ.'10') THEN ! SYNOPs (NC000100, NC000101, NC000102) CALL UFBSEQ(LUNIT,UFBINT2_8(1,1),4,255,IRET, 'PWEATHER') OBS2_8(10)=UFBINT2_8(3,1) OBS2_8(11)=UFBINT2_8(4,1) CALL UFBINT(LUNIT,OBS2_8(23),2,1,IRET,'TOCC HBLCS') CALL UFBINT(LUNIT,OBS2_8(29),1,1,IRET,'.DTHDOFS') CALL UFBINT(LUNIT,OBS2_8(32),4,1,IRET,'HOWV POWV HOWW POWW') CALL UFBINT(LUNIT,OBS2_8(38),3,1,IRET,'CHPT 3HPC 24PC') CALL UFBSEQ(LUNIT,OBS3_8(1,1,1),5,255,IRET,'BSYPCP2') DO I=1,IRET RRTMP=OBS3_8(1,I,1) IF(RRTMP.LT.0.0) RRTMP=-RRTMP IF(RRTMP.EQ. 1.0) OBS2_8(17)=OBS3_8(2,I,1) IF(RRTMP.EQ. 3.0) OBS2_8(18)=OBS3_8(2,I,1) IF(RRTMP.EQ. 6.0) OBS2_8(19)=OBS3_8(2,I,1) IF(RRTMP.EQ.12.0) OBS2_8(20)=OBS3_8(2,I,1) IF(RRTMP.EQ.24.0) OBS2_8(21)=OBS3_8(2,I,1) ENDDO JRET=0 DO I=1,IRET RRTMP=OBS3_8(1,I,1) IF(RRTMP.LT.0.0) RRTMP=-RRTMP IF(RRTMP.NE.1.0.AND.RRTMP.NE.3.0.AND.RRTMP.NE.6.0 $ .AND.RRTMP.NE.12.AND.RRTMP.NE.24.0) THEN DO J=2,23 IF(RRTMP.EQ.J) THEN JRET=1 OBS3_8(1,JRET,1)=RRTMP OBS3_8(2,JRET,1)=OBS3_8(2,I,1) ENDIF ENDDO ENDIF ENDDO IRET=JRET IF(IRET.EQ.1) THEN ! reset iret from 1 to 0 if all obs msng ! (iret can be 1 even if all obs msng) AMINIMUM_8 = MIN(OBS3_8(1,1,1),OBS3_8(2,1,1)) IF(IBFMS(AMINIMUM_8).NE.0) IRET = 0 END IF NOBS3(1) = IRET CALL UFBINT(LUNIT,OBS3_8(1,1,5),5,255,IRET,'DOSW HOSW POSW') IF(IRET.EQ.1) THEN ! reset iret from 1 to 0 if all obs msng ! (iret can be 1 even if all obs msng) AMINIMUM_8 = MIN(OBS3_8(1,1,5),OBS3_8(2,1,5), $ OBS3_8(3,1,5)) IF(IBFMS(AMINIMUM_8).NE.0) IRET = 0 END IF NOBS3(5) = IRET ELSE ! SYNOPs (NC000000, NC000001, NC000002) CALL UFBINT(LUNIT,OBS2_8(10),2,1,IRET,'PSW1 PSW2') CALL UFBINT(LUNIT,OBS2_8(20),1,1,IRET,'TP12') CALL UFBINT(LUNIT,OBS2_8(23),2,1,IRET,'TOCC HBLCS') CALL UFBINT(LUNIT,OBS2_8(29),1,1,IRET,'.DTHDOFS') CALL UFBINT(LUNIT,OBS2_8(32),4,1,IRET,'HOWV POWV HOWW POWW') CALL UFBINT(LUNIT,OBS2_8(38),3,1,IRET,'CHPT 3HPC 24PC') CALL UFBINT(LUNIT,OBS3_8(1,1,1),5,255,IRET,'.DTHTOPC TOPC') IF(IRET.EQ.1) THEN ! reset iret from 1 to 0 if all obs msng ! (iret can be 1 even if all obs msng) AMINIMUM_8 = MIN(OBS3_8(1,1,1),OBS3_8(2,1,1)) IF(IBFMS(AMINIMUM_8).NE.0) IRET = 0 END IF NOBS3(1) = IRET CALL UFBINT(LUNIT,OBS3_8(1,1,5),5,255,IRET,'DOSW HOSW POSW') IF(IRET.EQ.1) THEN ! reset iret from 1 to 0 if all obs msng ! (iret can be 1 even if all obs msng) AMINIMUM_8 = MIN(OBS3_8(1,1,5),OBS3_8(2,1,5), $ OBS3_8(3,1,5)) IF(IBFMS(AMINIMUM_8).NE.0) IRET = 0 END IF NOBS3(5) = IRET END IF ELSE IF(SUBSET(1:5).EQ.'NC001') THEN ! All surface marine IF(IBFMS(OBS2_8(4)).NE.0) THEN ! SST1 missing c -- Buoy SSTs IF(SUBSET(6:8).EQ.'102'.or.SUBSET(6:8).EQ.'103') THEN ! buoys C Retrieve field SST0 from buoy reports originating in BUFR form CALL UFBINT(LUNIT,OBS2_8(4),1,1,IRET,'SST0') ELSE IF(SUBSET(6:8).EQ.'002') THEN C DBUOYs store sub-sfc temp, use 1st lvl if SST1 msg (unless > 10m down) CALL UFBINT(LUNIT,OBS2_8(4),2,1,IRET,'STMP DBSS') IF(OBS2_8(5).GT.10.) THEN OBS2_8(4:5) = BMISS END IF END IF ! subset(6:7) = 10 ! BUFR-feed types END IF ! obs2_8(4) ne 0 (SST1 missing) IF(IBFMS(OBS2_8(4)).EQ.0) OBS2_8(41) = 2.0 CALL UFBINT(LUNIT,OBS2_8( 6),1,1,IRET,'MSST') c -- BUFR Ships reports need ufbint() mnemonics split up CALL UFBINT(LUNIT,OBS2_8( 8),2,1,IRET,'HOVI VTVI') CALL UFBINT(LUNIT,OBS2_8(10),2,1,IRET,'PSW1 PSW2') CALL UFBINT(LUNIT,OBS2_8(12),4,1,IRET, $ 'PKWDSP PKWDDR .DTMMXGS MXGS') CALL UFBINT(LUNIT,OBS2_8(23),4,1,IRET,'TOCC HBLCS XS10 XS20') if(subset(6:8).eq.'102'.or.subset(6:8).eq.'103') then ! BUFR buoys CALL UFBINT(LUNIT,OBS2_8(32),2,1,IRET,'SGWH AVWP') else ! TAC reports CALL UFBINT(LUNIT,OBS2_8(32),4,1,IRET,'HOWV POWV HOWW POWW') endif ! not 102 103 CALL UFBINT(LUNIT,OBS2_8(36),5,1,IRET, $ 'TDMP ASMP CHPT 3HPC 24PC') CALL UFBINT(LUNIT,OBS3_8(1,1,2),5,255,IRET,'PRWE') IF(IRET.EQ.1) THEN ! reset iret from 1 to 0 if all obs missing ! (iret can be 1 even if all obs missing) IF(IBFMS(OBS3_8(1,1,2)).NE.0) IRET = 0 END IF NOBS3(2) = IRET IF(SUBSET(6:6).EQ.'1') THEN ! SFCSHP in BUFR-Feed CALL UFBSEQ(LUNIT,UFBINT2_8(1,1),12,255,IRET,'GENCLOUD') I=1 OBS3_8(1,I,3)=UFBINT2_8(2,I) OBS3_8(2,I,3)=UFBINT2_8(3,I) OBS3_8(4,I,3)=UFBINT2_8(4,I) OBS3_8(3,I,3)=UFBINT2_8(5,I) OBS3_8(3,I+1,3)=UFBINT2_8(6,I) OBS3_8(3,I+2,3)=UFBINT2_8(7,I) NOBS3(3) = IRET IF(UFBINT2_8(6,I).LT.BMISS) NOBS3(3) = 2 IF(UFBINT2_8(7,I).LT.BMISS) NOBS3(3) = 3 ELSE CALL UFBINT(LUNIT,OBS3_8(1,1,3),5,255,IRET, $ 'VSSO CLAM CLTP HOCB') IF(IRET.EQ.1) THEN ! reset iret from 1 to 0 if all obs missing ! (iret can be 1 even if all obs missing) AMINIMUM_8 = MIN(OBS3_8(1,1,3),OBS3_8(2,1,3), $ OBS3_8(3,1,3),OBS3_8(4,1,3)) IF(IBFMS(AMINIMUM_8).NE.0) IRET = 0 END IF NOBS3(3) = IRET ENDIF CALL UFBINT(LUNIT,OBS3_8(1,1,5),5,255,IRET,'DOSW HOSW POSW') IF(IRET.EQ.1) THEN ! reset iret from 1 to 0 if all obs missing ! (iret can be 1 even if all obs missing) AMINIMUM_8 = MIN(OBS3_8(1,1,5),OBS3_8(2,1,5),OBS3_8(3,1,5)) IF(IBFMS(AMINIMUM_8).NE.0) IRET = 0 END IF NOBS3(5) = IRET ELSE IF(SUBSET(1:5).EQ.'NC255') THEN ! All Mesonets CALL UFBINT(LUNIT,OBS2_8(15),2,1,IRET,'MXGS MXGD') CALL UFBINT(LUNIT,OBS2_8( 8),1,1,IRET,'HOVI') CALL UFBINT(LUNIT,OBS2_8( 3),1,1,IRET,'ALSE') CALL UFBINT(LUNIT,OBS3_8(1,1,1),5,255,IRET,'TPHR TOPC') IF(IRET.EQ.1) THEN ! reset iret from 1 to 0 if all obs msng ! (iret can be 1 even if all obs msng) AMINIMUM_8 = MIN(OBS3_8(1,1,1),OBS3_8(2,1,1)) IF(IBFMS(AMINIMUM_8).NE.0) IRET = 0 END IF NOBS3(1) = IRET END IF OBS2 = OBS2_8 OBS3 = OBS3_8 CALL S05UBF C PUT THE HEADER INFORMATION INTO UNPACKED FORMAT C ----------------------------------------------- CALL UFBINT(LUNIT,HDR_8,20, 1,IRET,HDSTR);HDR(2:)=HDR_8(2:) C IN EARLY 2004, MESONETS WILL CONVERT TO HIGH-RESOLUTION LAT/LON C C EXPLOITING HIGH-RESOLUTION LAT/LON DATA FROM MARINE STATIONS AS OF 10/2019 C --------------------------------------------------------------- IF(HDR_8(2).GE.BMISS) THEN CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'CLONH') HDR_8(2)=UFBINT_8 END IF IF(HDR_8(3).GE.BMISS) THEN CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'CLATH') HDR_8(3)=UFBINT_8 END IF IF(HDR_8(6).GE.BMISS) THEN CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'HSMSL') HDR_8(6)=UFBINT_8 HDR(6)=HDR_8(6) END IF obs8_8(1) = hdr_8(3) obs8_8(2) = hdr_8(2) CALL UFBINT(LUNIT,RCT_8, 5,255,NRCT,RCSTR);RCT=RCT_8 IF(HDR(5).GE.BMISS) HDR(5) = 0 RCTIM = NINT(RCT(1,1))+NINT(RCT(2,1))/60. RID_8 = HDR_8(1) XOB = HDR_8(2) YOB = HDR_8(3) RHR = BMISS IF(HDR(4).LT.BMISS) RHR = NINT(HDR(4))+NINT(HDR(5))/60. ELV = HDR(6) QMELV = HDR(7) ITP = IMISS RTP = ERTUBF(SUBSET,SID) IDS = IMISS RSV1 = ' ' RSV2 = ' ' IF(SUBSET(1:5).NE.'NC255') THEN C--------------------------------------------------------------------- C MESONET REPORTS DO NOT COME HERE C--------------------------------------------------------------------- C INDICATOR FOR PRECIPITATION (INCLUDED/EXCLUDED STORED IN BYTE 1 OF C HEADER RESERVE CHARACTER WORD 1 C INDICATOR FOR WIND SPEED (SOURCE/UNITS) STORED IN BYTE 3 OF HEADER C RESERVE CHARACTER WORD 1 C '0' - Wind speed estimated in m/s (uncertified instrument) C '1' - Wind speed obtained from anemometer in m/s (certified C instrument) C '3' - Wind speed estimated in knots (uncertified instrument) C '4' - Wind speed obtained from anemometer in knots (certified C instrument) C '7' - Missing C INDICATOR FOR STATION OPERATION/PAST WEATHER DATA STORED IN BYTE 5 OF C HEADER RESERVE CHARACTER WORD 1 CALL UFBINT(LUNIT,UFBINT_8,1,1,NRSV,'INPC');RRSV(1)=UFBINT_8 CALL UFBINT(LUNIT,UFBINT_8,1,1,NRSV,'TIWM');TIWM=UFBINT_8 IF(TIWM.LT.BMISS) THEN ! Effective 5/2002 RRSV(2) = 7 IF(NINT(TIWM).LE.15) RRSV(2) = ITIWM(NINT(TIWM)) ELSE ! Prior to 5/2002 CALL UFBINT(LUNIT,UFBINT_8,1,1,NRSV,'SUWS');RRSV(2)=UFBINT_8 END IF CALL UFBINT(LUNIT,UFBINT_8,1,1,NRSV,'ITSO');RRSV(3)=UFBINT_8 J = -1 DO I=1,3 J = J + 2 IF(RRSV(I).LT.BMISS) WRITE(RSV1(J:J),'(I1)') NINT(RRSV(I)) ENDDO IF(SUBSET(6:8).EQ.'007') THEN ! METARs C TYPE OF HOURLY REPORT ("METAR", "SPECI" OR "LWIS") STORED IN BYTES C 1-5 OF HEADER RESERVE CHARACTER WORD 2 (METAR REPORTS ONLY) CALL UFBINT(LUNIT,UFBINT_8,1,1,NRSV,'THRPT') RRSV(4)=UFBINT_8 IF(NINT(RRSV(4)).EQ.0) THEN RSV2(1:5) = 'METAR' ELSE IF(NINT(RRSV(4)).EQ.1) THEN RSV2(1:5) = 'SPECI' ELSE IF(NINT(RRSV(4)).EQ.2) THEN RSV2(1:5) = 'LWIS ' ELSE RSV2(1:5) = '?????' END IF C CORRECTED REPORT INDICATOR ("CORN") STORED IN BYTE 8 OF HEADER C RESERVE CHARACTER WORD 2 (METAR REPORTS ONLY) C '0' - Not corrected C '1' - Corrected by report originator C '2' - Corrected by NCEP SDM C '3' to '6' - Reserved C '7' - Missing CALL UFBINT(LUNIT,UFBINT_8,1,1,NRSV,'CORN');RRSV(5)=UFBINT_8 RSV2(8:8) = '7' IF(RRSV(5).LT.BMISS) WRITE(RSV2(8:8),'(I1)') NINT(RRSV(5)) END IF ELSE C--------------------------------------------------------------------- C MESONET REPORTS COME HERE C--------------------------------------------------------------------- C MESONET PROVIDER ID STORED IN HEADER RESERVE CHARACTER WORD 1 C (Note: Only first eight characters are stored) CALL UFBINT(LUNIT,RRVSTG_8,1,255,IRET,'PRVSTG') cccc IF(IRET.NE.0.AND.(RRVSTG_8(1).LE.BMISS-5000..OR.RRVSTG_8(1) cccc $ .GE.BMISS+5000.)) RSV1 = PRVSTG cxxxx cpppppppppp cc print'(" rrvstg_8(1),icbfms(prvstg,8): ",G0,1X,I0)', cc $ rrvstg_8(1),icbfms(prvstg,8) cpppppppppp IF(ICBFMS(PRVSTG,8).EQ.0) RSV1 = PRVSTG C above line not working right - may return 0 when missing, so use next C two lines below temporarily until this is fixed (readlc will return C all blanks for prvstg when mnemonic "PRVSTG" not found) - dak 2/19/13 call readlc(lunit,prvstg,'PRVSTG') cpppppppppp cc print'(" prvstg = """,A,"""")', prvstg cpppppppppp rsv1 = prvstg ! will set rsv1 back to all blanks if readlc ! returns prvstg as all blanks (rsv1 may have ! been set to garbage above if ICBFMS ! incorrectly returned as zero when prvstg is ! actually missing) -- if prvstg is filled ! with a valid character string by readlc, ! this will also get translated into rsv1 here cxxxx C MESONET SUBPROVIDER ID STORED IN HEADER RESERVE CHARACTER WORD 2 C (Note: Only first eight characters are stored) CALL UFBINT(LUNIT,RPRVSTG_8,1,255,IRET,'SPRVSTG') cccc IF(IRET.NE.0.AND.(RPRVSTG_8(1).LE.BMISS-5000..OR.RPRVSTG_8(1) cccc $ .GE.BMISS+5000.)) RSV2 = SPRVSTG cxxxx cpppppppppp cc print'(" rprvstg_8(1),icbfms(sprvstg,8): ",G0,1X,I0)', cc $ rprvstg_8(1),icbfms(sprvstg,8) cpppppppppp IF(ICBFMS(SPRVSTG,8).EQ.0) RSV2 = SPRVSTG C above line not working right - may return 0 when missing, so use next C two lines below temporarily until this is fixed (readlc will return C all blanks for sprvstg when mnemonic "SPRVSTG" not found)-dak 2/19/13 CCC DAK 2/26/13: READLC puts out diag. print when mnemonic not located CCC (i.e., missing) so to avoid thousands of lines of CCC print, will only call readlc if IRET is > 0, i.e., if CCC IRET is ZERO assume it is missing (a good bet) and CCC don't call READLC if(IRET.gt.0) then call readlc(lunit,sprvstg,'SPRVSTG') else sprvstg = ' ' endif cpppppppppp cc print'(" sprvstg = """,A,"""")', sprvstg cpppppppppp rsv2 = sprvstg ! will set rsv2 back to all blanks if readlc ! returns sprvstg as all blanks -- or IRET > 0 ! and sprvstg forced to be all blanks -- ! (rsv2 may have ! been set to garbage above if ICBFMS ! incorrectly returned as zero when sprvstg is ! actually missing) -- if sprvstg is filled ! with a valid character string by readlc, ! this will also get translated into rsv2 here cxxxx C--------------------------------------------------------------------- END IF C READ THE DATA LEVEL CATEGORY 51 SURFACE DATA FROM BUFR C ------------------------------------------------------ CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PMSL');PSL=UFBINT_8 CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PRES');STP=UFBINT_8 CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'WDIR');SDR=UFBINT_8 CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'WSPD');SSP=UFBINT_8 CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TMDB');STM=UFBINT_8 CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TMDP');DPD=UFBINT_8 C All surface types come here for possible SDMEDIT q. mark assignment C ------------------------------------------------------------------- CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'QMPR');QSL=UFBINT_8 CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'QMPR');QSP=UFBINT_8 CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'QMWN');QMW=UFBINT_8 CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'QMAT');QMT=UFBINT_8 CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'QMDD');QMD=UFBINT_8 QPR = 2 ! precip. rate (no q. marker available, set to neutral) QPT = 2 ! tot. precip. (no q. marker available, set to neutral) IF(SUBSET.EQ.'NC000007') THEN C METARs transfer the quality marker from pstn to altimeter setting if C pstn q.m. was either a purge or reject value (pstn is missing for C METARS, so most will obtain this from altimeter setting in C PREPDATA and assign the pstn q.m. to be same as that of the C altimeter setting - the logic here ensures that a purge or reject C flag on pressure in the sdmedit file will be honored) C -------------------------------------------------------------------- QAL = BMISS IF(NINT(QSP).EQ.14.OR.NINT(QSP).EQ.12) then QAL = QSP END IF END IF IF(SUBSET(1:5).EQ.'NC255') THEN C If no SDMEDIT quality mark assigned above, mesonets check for C MADIS quality marks which are then converted to standard QM values C -------------------------------------------------------------------- if(qsl.gt.14) QSL = BMISS ! msl pressure (PMSL missing) CALL UFBREP(LUNIT,RMSO_8,2,1,IRET,'PRES QCD') RQCD_8 = RMSO_8(2) cdak print'(" MADIS PRES QM is ",A)', QCD if(qsp.gt.14) QSP = MQMUBF(QCD) ! station pressure CALL UFBREP(LUNIT,RMSO_8,2,1,IRET,'ALSE QCD') RQCD_8 = RMSO_8(2) cdak print'(" MADIS ALSE QM is ",A)', QCD QAL = MQMUBF(QCD) ! altimeter CALL UFBREP(LUNIT,RMSO_8,2,1,IRET,'TMDB QCD') RQCD_8 = RMSO_8(2) cdak print'(" MADIS TMDB QM is ",A)', QCD if(qmt.gt.14) QMT = MQMUBF(QCD) ! temperature CALL UFBREP(LUNIT,RMSO_8,2,1,IRET,'TMDP QCD') RQCD_8 = RMSO_8(2) cdak print'(" MADIS TMDP QM is ",A)', QCD if(qmd.gt.14) QMD = MQMUBF(QCD) ! dewpoint temperature CALL UFBREP(LUNIT,RMSO_8,2,1,IRET,'WDIR QCD') RQCD_8 = RMSO_8(2) cdak print'(" MADIS WDIR QM is ",A)', QCD QWD = MQMUBF(QCD) ! wind direction CALL UFBREP(LUNIT,RMSO_8,2,1,IRET,'WSPD QCD') RQCD_8 = RMSO_8(2) cdak print'(" MADIS WSPD QM is ",A)', QCD QWS = MQMUBF(QCD) ! wind speed if(qmw.gt.14) QMW = MAX(QWD,QWS) ! wind (overall) CALL UFBREP(LUNIT,RMSO_8,2,1,IRET,'REQV QCD') RQCD_8 = RMSO_8(2) cdak print'(" MADIS REQV QM is ",A)', QCD QPR = MQMUBF(QCD) ! precipitation rate CALL UFBINT(LUNIT,TOPC_8,1,255,IRETU,'TOPC') IRET = 0 IF(IRETU.GT.0)CALL UFBSEQ(LUNIT,TOPC_8,5,IRETU,IRET,'MNTOPCSQ') QPT1 = BMISS QPT24 = BMISS IF(IRET.GT.0) THEN DO I = 1,IRET IF(NINT(TOPC_8(1,I)).EQ.1) THEN RQCD_8 = TOPC_8(3,I) cdak print'(" MADIS 1-hr total precip. QM is ",A)', QCD QPT1 = MQMUBF(QCD) ! total precip. over 1-hr ELSE IF(NINT(TOPC_8(1,I)).EQ.24) THEN RQCD_8 = TOPC_8(3,I) cdak print'(" MADIS 24-hr total precip. QM is ",A)', QCD QPT24 = MQMUBF(QCD) ! total precip. over 24-hr END IF ENDDO END IF END IF C PAOBS always have a missing elev, but we know they are at sea level IF(SUBSET.EQ.'NC001006') ELV = 0 C CALL FUNCTIONS TO TRANSFORM TO SPECIFIED UNPACKED FORMAT C -------------------------------------------------------- PSQ = EQSUBF(QSL) SPQ = EQSUBF(QSP) SWQ = EQSUBF(QMW) STQ = EQSUBF(QMT) DDQ = EQSUBF(QMD) IF(PSL.LT.BMISS) THEN PSL = NINT(PSL*.1) ELSE IF(PSQ.NE.14.AND.PSQ.NE.12) PSQ = 2 END IF C The following line needed because old QUIPC program always C corrected STP to be PSL value if PSL was corrected, even if C STP was orig. missing or at some elevation above sea-lvl C (this is now fixed in quipc but is left here for old runs) C ------------------------------------------------------------ IF(SUBSET(1:5).EQ.'NC001'.AND.NINT(QSL).EQ.4) STP = BMISS IF(STP.LT.BMISS) THEN STP = NINT(STP*.1) ELSE IF(SPQ.NE.14.AND.SPQ.NE.12) SPQ = 2 END IF SSP = MIN(SSP*10.,BMISS) IF(NINT(SDR).EQ.0) SDR = 360 IF(SDR.GE.BMISS.AND.NINT(SSP).EQ.0) SDR = 360 IF(MIN(SDR,SSP).GE.BMISS) SWQ = 2 IF(MAX(DPD,STM).LT.BMISS) THEN DPD = (STM-DPD)*10. ELSE DPD = BMISS C - note this was not set before & could make a bufr chg in checking DDQ = 2 END IF IF(STM.LT.BMISS) THEN ISTM = NINT(STM*100.) STM = NINT((ISTM-27315)*0.1) ELSE STQ = 2 END IF C MAKE THE UNPACKED REPORT INTO OBS C --------------------------------- RSTP = IMISS CALL S01UBF(SID,XOB,YOB,RHR,RCTIM,RSV1,RSV2,ELV,QMELV,ITP,RTP, $ RSTP,IDS) CALL S02UBF(51,1,*9999) C ------------------------------------------------------------------ C MISC DATA GOES INTO DATA LEVEL CATEGORY 08 C ------------------------------------------------------------------ C CODE FIGURE 003 - DIFFUSE SOLAR RADIATION IN 100.*JOULE/M**2 C INDICATOR 2 CONTAINS TIME PERIOD OVER WHICH C RADIATION WAS INTEGRATED (MINUTES) C CODE FIGURE 004 - DIRECT SOLAR RADIATION IN 100.*JOULE/M**2 C INDICATOR 2 CONTAINS TIME PERIOD OVER WHICH C RADIATION WAS INTEGRATED (MINUTES) C CODE FIGURE 005 - QUALITY MARKER FOR TOTAL PRECIP. OVER 1-HR C CODE FIGURE 006 - QUALITY MARKER FOR TOTAL PRECIP. OVER 24-HR C CODE FIGURE 020 - QUALITY MARKER FOR ALTIMETER SETTING C CODE FIGURE 198 - RAINFALL RATE (MM/SEC, TO 10**6 PRECISION FOR C SSM/I AND TO 10**4 PRECISION FOR ALL OTHER DATA C TYPES) C INDICATOR 2 CONTAINS RAINFALL RATE QUALITY MARKER C ------------------------------------------------------------------ IF(SUBSET(1:5).EQ.'NC255'.OR.SUBSET.EQ.'NC000007') THEN IF(QAL.LT.BMISS) THEN OB8(1) = QAL CF8(1) = 20 Q81(1) = IMISS Q82(1) = IMISS CALL S02UBF(8,1,*9999) END IF END IF IF(SUBSET(1:5).EQ.'NC255') THEN CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'REQV');REQV=UFBINT_8 IF(REQV.LT.BMISS) THEN OB8(1) = REQV CF8(1) = 198 Q81(1) = IMISS Q82(1) = QPR CALL S02UBF(8,1,*9999) END IF CALL UFBINT(LUNIT,SOLR_8,3,255,IRET,'DFSORD DRSORD TPMI') SOLR=SOLR_8 IF(SOLR(1,1).LT.BMISS) THEN OB8(1) = NINT(SOLR(1,1)*0.01) CF8(1) = 3 Q81(1) = IMISS Q82(1) = IMISS IF(SOLR(3,1).LT.BMISS) Q82(1) = SOLR(3,1) CALL S02UBF(8,1,*9999) END IF IF(SOLR(2,1).LT.BMISS) THEN OB8(1) = NINT(SOLR(2,1)*0.01) CF8(1) = 4 Q81(1) = IMISS Q82(1) = IMISS IF(SOLR(3,1).LT.BMISS) Q82(1) = SOLR(3,1) CALL S02UBF(8,1,*9999) END IF IF(QPT1.LT.BMISS) THEN OB8(1) = QPT1 CF8(1) = 5 Q81(1) = IMISS Q82(1) = IMISS CALL S02UBF(8,1,*9999) END IF IF(QPT24.LT.BMISS) THEN OB8(1) = QPT24 CF8(1) = 6 Q81(1) = IMISS Q82(1) = IMISS CALL S02UBF(8,1,*9999) END IF GO TO 75 END IF 75 CONTINUE CALL S03UBF(OBS,SUBSET,*9999,*9998,*9997) RETURN 9999 CONTINUE R04UBF = 999 RETURN 9998 CONTINUE print'(" IW3UNPBF/R04UBF: RPT with ID= ",A," TOSSED - ZERO ", $ "CAT.1-6,51 LVLS")', SID 9997 CONTINUE R04UBF = -9999 KSKSFC =KSKSFC + 1 RETURN END C*********************************************************************** C*********************************************************************** C*********************************************************************** FUNCTION R05UBF(LUNIT,OBS,OBS2,OBS3,NOBS3,obs8_8) C ---> PROCESSES AIRCRAFT DATA (004/001-004, 004/006-011, 004/103) COMMON/IUBFAA/BMISS COMMON/IUBFBB/KNDX,KSKACF(8),KSKUPA,KSKSFC,KSKSAT,KFLSAT(12), $ KSKSMI COMMON/IUBFCC/SUBSET COMMON/IUBFEE/POB(255),QOB(255),TOB(255),ZOB(255),DOB(255), $ SOB(255),VSG(255),OB8(255),CF8(255) COMMON/IUBFFF/PQM(255),QQM(255),TQM(255),ZQM(255),WQM(255) COMMON/IUBFLL/Q81(255),Q82(255) COMMON/IUBFRR/IDATEB COMMON/IUBFSS/CBULLX CHARACTER*80 HDSTR,LVSTR,QMSTR,RCSTR,CRAWR CHARACTER*500 CRAWRX CHARACTER*11 CBULLX CHARACTER*8 SUBSET,SID,RSV1,RSV2,CRAW(255),ACID,QCD,CBUHD, $ CBORG,actp,obsvr REAL(8) RID_8,UFBINT_8,RNS_8,OBS2_8(43),OBS3_8(5,255,7), $ RACID_8,RTAM_8(2),RTAM_WDIR_8,RQCD_8,BULL_8(2),RTAMB_8(7), $ ractp_8,robsvr_8,obs8_8(2) REAL(8) HDR_8(20),RCT_8(5,255),ARR_8(10,255),RAW_8(255),TRBX_8(5), $ ROLF_8,BMISS,AMINIMUM_8,AMAXIMUM_8,rialr_8 DIMENSION OBS(*),OBS2(43),OBS3(5,255,7),NOBS3(7),HDR(20), $ RCT(5,255),ARR(10,255),TRBX(5) EQUIVALENCE (RID_8,SID),(RAW_8,CRAW),(RACID_8,ACID), $ (RQCD_8,QCD),(BULL_8(1),CBORG),(BULL_8(2),CBUHD),(ractp_8,actp), $ (robsvr_8,obsvr) SAVE DATA HDSTR/'RPID CLON CLAT HOUR MINU SECO '/ DATA LVSTR/'PRLC MIXR TMDB WDIR WSPD REHU '/ DATA QMSTR/'QMPR QMAT QMDD QMGP QMWN '/ DATA RCSTR/'RCHR RCMI RCTS '/ DATA IMISS/99999/,XMISS/99999./ C FCNS HGTF_HI, HGTF_LO CALC. Z FROM P < 226.3MB AND P > 226.3MB; RESP C (U.S. STANDARD ATMOSPHERE) HGTF_HI(P) = 11000 - ALOG(P/226.3)/1.576106E-4 HGTF_LO(P) = (1.-(P/1013.25)**(1./5.256))*(288.15/.0065) C FCNS BELOW CONVERT SAT./SPEC. HUM.(KG/KG) & PRESS(MB) INTO TEMP/TD(K) C --------------------------------------------------------------------- AS(Q,P) = ALOG((Q * P)/(6.1078 * ((0.378 * Q) + 0.622))) TFRMQP(Q,P) = ((237.3 * AS(Q,P))/(17.269 - AS(Q,P)) + 273.16) C FCNS BELOW CONVERT TEMP/TD(K) & PRESS(MB) INTO SAT./SPEC. HUM.(KG/KG) C --------------------------------------------------------------------- ES(T) = 6.1078 * EXP((17.269 * (T - 273.16))/((T - 273.16)+237.3)) QFRMTP(T,P) = (0.622 * ES(T))/(P - (0.378 * ES(T))) C Fcns below estimate pressure (mb) using indicated altitude (m) via C U.S. Std. Atmos. Est. for Z <= 11,000 and Z > 11,000 respectively C ------------------------------------------------------------------ PR(Z) = 1013.25 * (((288.15 - (.0065 * Z))/288.15)**5.256) PRS(Z) = 226.3 * EXP(1.576106E-4 * (11000. - Z)) R05UBF = 0 C STORE SINGLE LEVEL REPORT DATA DIRECTLY INTO OBS2 ARRAY, C MULTIPLE LEVEL REPORT DATA DIRECTLY INTO OBS3 ARRAY AND C DOUBLE-PRECISION SINGLE LEVEL REPORT DATA DIRECTLY INTO OBS8_8 ARRAY C --------------------------------------------------------------------- OBS2_8 = BMISS OBS3_8 = BMISS NOBS3 = 0 obs8_8 = bmiss CALL UFBINT(LUNIT,OBS2_8,2,1,IRET,'RSRD EXPRSRD') ! All AIRCRAFT CALL UFBINT(LUNIT,OBS3_8(1,1,7),5,255,IRET,'DGOT HBOT HTOT') IF(IRET.EQ.1) THEN ! reset iret from 1 to 0 if all obs missing ! (iret can be 1 even if all obs missing) AMINIMUM_8 = MIN(OBS3_8(1,1,7),OBS3_8(2,1,7),OBS3_8(3,1,7)) IF(IBFMS(AMINIMUM_8).NE.0) IRET = 0 END IF NOBS3(7) = IRET IF(SUBSET.EQ.'NC004002') THEN ! PIREPs CALL UFBINT(LUNIT,OBS3_8(1,1,2),5,255,IRET,'PRWE') IF(IRET.EQ.1) THEN ! reset iret from 1 to 0 if all obs missing ! (iret can be 1 even if all obs missing) IF(IBFMS(OBS3_8(1,1,2)).NE.0) IRET = 0 END IF NOBS3(2) = IRET CALL UFBINT(LUNIT,OBS3_8(1,1,3),5,255,IRET, $ 'NUL CLAM CLTP HOCB HOCT') IF(IRET.EQ.1) THEN ! reset iret from 1 to 0 if all obs missing ! (iret can be 1 even if all obs missing) AMINIMUM_8 = MIN(OBS3_8(2,1,3),OBS3_8(3,1,3),OBS3_8(4,1,3), $ OBS3_8(5,1,3)) IF(IBFMS(AMINIMUM_8).NE.0) IRET = 0 END IF NOBS3(3) = IRET ELSE IF(SUBSET.EQ.'NC004004') THEN ! MDCRS ACARS CALL UFBINT(LUNIT,OBS2_8(42),1,1,IRET,'MSTQ') END IF IF(SUBSET.EQ.'NC004002'.OR.SUBSET.EQ.'NC004006'.OR. $ SUBSET.EQ.'NC004009'.OR.SUBSET.EQ.'NC004010') THEN ! PIREPs, E-AMDAR, Canadian AMDAR, TAMDARB CALL UFBINT(LUNIT,OBS3_8(1,1,6),5,255,IRET,'AFIC HBOI HTOI') ! For TAMDAR only AFIC is present ! and only in older AirDAT IF(IRET.EQ.1) THEN ! reset iret from 1 to 0 if all obs missing ! (iret can be 1 even if all obs missing) AMINIMUM_8 = MIN(OBS3_8(1,1,6),OBS3_8(2,1,6),OBS3_8(3,1,6)) IF(IBFMS(AMINIMUM_8).NE.0) IRET = 0 END IF NOBS3(6) = IRET END IF OBS2 = OBS2_8 OBS3 = OBS3_8 CALL S05UBF C PUT THE HEADER INFORMATION INTO UNPACKED FORMAT C ----------------------------------------------- CALL UFBINT(LUNIT,HDR_8,20, 1,IRET,HDSTR);HDR(2:)=HDR_8(2:) C If low res lat/lon missing, report likely contains hi res lat/lon C ----------------------------------------------------------------- IF(HDR_8(2).GE.BMISS) THEN CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'CLONH') HDR_8(2)=UFBINT_8 END IF IF(HDR_8(3).GE.BMISS) THEN CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'CLATH') HDR_8(3)=UFBINT_8 END IF obs8_8(1) = hdr_8(3) obs8_8(2) = hdr_8(2) IF(IRET.EQ.0) SID = ' ' CALL UFBINT(LUNIT,RCT_8, 5,255,NRCT,RCSTR);RCT=RCT_8 IF(HDR(5).GE.BMISS) HDR(5) = 0 IF(HDR(6).GE.BMISS) HDR(6) = 0 RCTIM = NINT(RCT(1,1))+NINT(RCT(2,1))/60. RID_8 = HDR_8(1) XOB = HDR_8(2) YOB = HDR_8(3) RHR = BMISS IF(HDR(4).LT.BMISS) RHR = (NINT(HDR(4)) + ((NINT(HDR(5)) * 60.) + cvvvvvdak port cdak $ NINT(HDR(6)))/3600.) + 0.0000000001 ! orig cdak $ NINT(HDR(6)))/3600.) + 0.0001 ! then changed to this caaaaadak port $ NINT(HDR(6)))/3600.) ! don't make this adjustment now that we ! store obs time to 10**5 in PREPBUFR C TRY TO FIND THE FLIGHT LEVEL HEIGHT C ----------------------------------- CALL UFBINT(LUNIT,HDR_8,20,1,IRET, $ 'PSAL FLVL IALT PRLC HEIT HMSL FLVLST') HDR=HDR_8 C If this type reports pressure (PRLC) store it here -- PREPDATA uses C this for pressure (currently applies to pre-v7 BUFR MDCRS and MADIS/ C TAMDAR only) C -- in this case PREPDATA uses a pressure-altitude derived from PRLC C via standard atmosphere function unless line C "IF(HDR(3).LT.BMISS) ELEV = HDR(3)" C below is uncommented, in which case PREPDATA uses IALT (altitude) C (if reported) as pressure-altitude (IALT is the only height C type reported for MDCRS, both pre- and post-v7 BUFR; it is not C reported for MADIS/TAMDAR, in fact no height type is reported for C MADIS/TAMDAR) C----------------------------------------------------------------------- C Otherwise, if this type does not report pressure (PRLC) but does C report PSAL (pressure altitude), PREPDATA uses reported PSAL as C pressure-altitude (currently applies to AMDAR format only, both PSAL C and FLVL are included but in most cases FLVL is missing, PSAL is C never missing and where PSAL and FLVL are both non-missing they are C identical) C PREPDATA later derives pressure from PSAL via standard atmosphere C function C----------------------------------------------------------------------- C Otherwise, if this type does not report pressure (PRLC) but does C report FLVL (flight level), PREPDATA uses reported FLVL as pressure- C altitude (currently applies to AIREP/PIREP format only, both PSAL C and FLVL are included but only FLVL is non-missing) C PREPDATA later derives pressure from FLVL via standard atmosphere C function C----------------------------------------------------------------------- C Otherwise, if this type does not report pressure (PRLC) but does C report FLVLST (flight level), PREPDATA uses reported FLVLST as C pressure-altitude {currently applies to Korean AMDAR, catch-all C AMDAR (from BUFR feed)} C PREPDATA later derives pressure from FLVLST via standard atmosphere C function C C 2016-07-27 C. Hill -- C - PAC/AirDat has confirmed HMSL is pressure-altitude for C the TAMDAR dataset, and should be used to derive pressure C values. FLVLST is GPS altitude for TAMDAR. C - For the previous UFBINT statement, FLVLST is reordered after C PRLC, HEIT, and HMSL, as HEIT and HMSL are both missing for C Korean AMDAR and catch-all AMDAR, and are therefore skipped. C - The order of precedence in defining ELEV is: C PRLC, IALT, PSAL, FLVL, HEIT, HMSL, and FLVLST C----------------------------------------------------------------------- C Otherwise, if this type does not report pressure (PRLC) but does C report IALT (altitude), PREPDATA uses reported IALT as pressure- C altitude (currently applies to post-v7 BUFR MDCRS only) C PREPDATA later derives pressure from IALT via standard atmosphere C function C----------------------------------------------------------------------- C Otherwise, if this type does not report pressure (PRLC) but does C report HEIT (height), PREPDATA uses reported HEIT as pressure- C altitude (currently applies to no reports, HEIT is included in C E-AMDAR and Canadian AMDAR but is always missing) C PREPDATA later derives pressure from HEIT via standard atmosphere C function C----------------------------------------------------------------------- C Otherwise, if this type does not report pressure (PRLC) but does C report HMSL (altitude), PREPDATA uses reported HMSL as pressure- C altitude (currently applies to E-AMDAR and Canadian AMDAR, both HEIT C and HMSL are included but only HMSL is non-missing; HMSL is C non-missing for AirDAT/TAMDAR) C PREPDATA later derives pressure from HMSL via standard atmosphere C function C----------------------------------------------------------------------- IF(HDR(4).LT.BMISS) THEN ! pressure is non-missing - initially get elev from pressure ! pre-v7 BUFR MDCRS and MADIS/TAMDAR IF(HDR(4).LT.22630) THEN ELEV = HGTF_HI(HDR(4)*.01) ELSE ELEV = HGTF_LO(HDR(4)*.01) END IF ELSE IF (HDR(3).LT.BMISS) THEN ELEV = HDR(3) ! IALT (post-v7 BUFR MDCRS) ELSE ELEV = BMISS ENDIF CCCC ELSE CCCC ELEV = BMISS IF(HDR(1).LT.BMISS) THEN ! PSAL (AMDAR format) ELEV = HDR(1) + SIGN(0.0000001,HDR(1)) ELSE IF(HDR(2).LT.BMISS) THEN ! FLVL (AIREP/PIREP format) ELEV = HDR(2) + SIGN(0.0000001,HDR(2)) !! uncomment next 2 lines to obtain elev from IALT when PRLC !! non-missing (applies to pre-v7 BUFR MDCRS) CCCC ELSE IF(HDR(3).LT.BMISS.AND.HDR(4).LT.BMISS) THEN CCCC ELEV = HDR(3) ELSE IF(HDR(5).LT.BMISS) THEN ! HEIT (none right now) ELEV = HDR(5) + SIGN(0.0000001,HDR(5)) ELSE IF(HDR(6).LT.BMISS) THEN ! HMSL (E-AMDAR, Canadian AMDAR & TAMDARB) ELEV = HDR(6) + SIGN(0.0000001,HDR(6)) ELSE IF(HDR(7).LT.BMISS) THEN ! FLVLST (Catch-all & Korean BUFR AMDAR) ELEV = HDR(7) + SIGN(0.0000001,HDR(7)) END IF CCCC END IF ELV = ELEV QMELV = XMISS C ACFT NAVIGATION SYSTEM STORED IN INSTR. TYPE LOCATION (AS WITH ON29) C -------------------------------------------------------------------- ITP = IMISS CALL UFBINT(LUNIT,RNS_8,1,1,IRET,'ACNS');RNS=RNS_8 IF(RNS.LT.BMISS) THEN IF(NINT(RNS).EQ.0) THEN ITP = 97 ! Inertial Navigation System ELSE IF(NINT(RNS).EQ.1) THEN ITP = 98 ! OMEGA END IF END IF RTP = 041 READ(SUBSET(6:8),'(I3.3)')ISTP RSTP=ISTP IDS = IMISS RSV1 = ' ' RSV2 = ' ' C BULLETIN HEADER AND ORIGINATOR STORED IN CBULLX C ----------------------------------------------- CALL UFBINT(LUNIT,BULL_8,2,1,IRET,'BORG BUHD') cccc IF(IRET.NE.0.AND.(BULL_8(1).LE.BMISS-5000..OR. cccc $ BULL_8(1).GE.BMISS+5000.)) THEN cxxxx cpppppppppp cc print'(" bull_8(1),icbfms(CBORG,8): ",G0,1X,I0)', bull_8(1), cc $ icbfms(CBORG,8) cpppppppppp ccccc IF(ICBFMS(CBORG,8).EQ.0) THEN C above line not working right - may return 0 when missing, so use next C two lines below temporarily until this is fixed (readlc will return C all blanks for CBORG when mnemonic "BORG" not found) - dak 2/19/13 C {Note: For Panasonic (AirDAT) TAMDAR, BORG and BUHD are always C missing, so set CBORG to all blanks and don't call READLC C because it will print out warning messages.} if(subset.eq.'NC004010') then CBORG = ' ' else call readlc(lunit,CBORG,'BORG') end if cpppppppppp cc print'(" CBORG = """,A,"""")', CBORG cpppppppppp if(CBORG.ne.' ') then cxxxx CBULLX = CBUHD(1:6)//' '//CBORG(1:4) ELSE CALL UFBINT(LUNIT,BULL_8,2,1,IRET,'ICLI') ! Prior to 5/2002 cccc IF(IRET.NE.0.AND.(BULL_8(1).LE.BMISS-5000..OR. cccc $ BULL_8(1).GE.BMISS+5000.)) CBULLX = ' '//CBORG(1:4) cxxxx cpppppppppp cc print'(" bull_8(1),icbfms(CBORG,8): ",G0,1X,I0)', bull_8(1), cc $ icbfms(CBORG,8) cpppppppppp IF(ICBFMS(CBORG,8).EQ.0) CBULLX = ' '//CBORG(1:4) C above line not working right - may return 0 when missing, so use next C two lines below temporarily until this is fixed (readlc will return C all blanks for CBORG when mnemonic "ICLI" not found) - dak 2/19/13 C {Note: For Panasonic (AirDAT) TAMDAR, ICLI is always missing, so set C CBORG to all blanks and don't call READLC because it will C print out warning messages.} if(subset.eq.'NC004010') then CBORG = ' ' else call readlc(lunit,CBORG,'ICLI') end if cpppppppppp cc print'(" CBORG = """,A,"""")', CBORG cpppppppppp CBULLX = ' '//CBORG(1:4) ! will set CBULLX back to all blanks ! if readlc returns CBORG as all blanks ! {CBULLX may have been set to ! garbage above if ICBFMS incorrectly ! returned as zero when CBORG is ! actually missing) -- if CBORG is ! filled with a valid character string ! by readlc, this will also get ! translated into CBULLX here ! will also set CBULLX to all blanks if ! if Panasonic (AirDAT) TAMDAR cxxxx END IF PCT = BMISS POF = BMISS TRBX = BMISS ROLF = BMISS RIALR = BMISS QTRBX = IMISS IF(SUBSET.EQ.'NC004003') THEN C -------------------------------------- C AMDAR FORMAT AIRCRAFT TYPE COME HERE C -------------------------------------- C AFWA (NEVER HAPPENS) INDICATOR STORED IN BYTE 1 OF HEADER RESERVE C CHARACTER WORD 2 C (NOTE: NAS9000 ONLY ASSIGNED BULLETIN ORIGINATOR "KAWN" AS AFWA, C ALTHOUGH BULLETIN ORIGINATORS "PHWR" AND "EGWR" ARE C APPARENTLY ALSO AFWA) C ----------------------------------------------------------------- IF(CBULLX(8:11).EQ.'KAWN') RSV2(1:1) = 'C' ELSE IF(SUBSET.EQ.'NC004004') THEN C ------------------------------------- C MDCRS ACARS AIRCRAFT TYPE COME HERE C ------------------------------------- CALL UFBINT(LUNIT,RID_8,1,1,IRET,'ACRN') cccc IF(IRET.EQ.0.OR.(RID_8.GT.BMISS-5000..AND.RID_8.LT.BMISS+ cccc $ 5000.)) SID = 'ACARS ' cxxxx cpppppppppp cc print'(" rid_8,icbfms(sid,8): ",G0,1X,I0)', rid_8,icbfms(sid,8) cpppppppppp ccccc IF(ICBFMS(SID,8).NE.0) SID = 'ACARS ' C above line not working right - may return 0 when missing, so use next C two lines below temporarily until this is fixed (readlc will return C all blanks for sid when mnemonic "ACRN" not found) - dak 2/19/13 call readlc(lunit,sid,'ACRN') cpppppppppp cc print'(" sid = """,A,"""")', sid cpppppppppp if(sid.eq.' ') sid = 'ACARS ' cxxxx C FLIGHT NUMBER STORED IN HEADER RESERVE CHARACTER WORD 2 (C*8) C ------------------------------------------------------------- CALL UFBINT(LUNIT,RACID_8,1,1,IRET,'ACID') cccc IF(IRET.EQ.0.OR.(RACID_8.GT.BMISS-5000..AND.RACID_8.LT.BMISS+ cccc $ 5000.)) ACID = ' ' cxxxx cpppppppppp cc print'(" racid_8,icbfms(acid,8): ",G0,1X,I0)', cc $ racid_8,icbfms(acid,8) cpppppppppp ccccc IF(ICBFMS(ACID,8).NE.0) ACID = ' ' C above line not working right - may return 0 when missing, so use next C two lines below temporarily until this is fixed (readlc will return C all blanks for acid when mnemonic "ACID" not found) - dak 2/19/13 call readlc(lunit,acid,'ACID') cpppppppppp cc print'(" acid = """,A,"""")', acid cpppppppppp if(acid.eq.' ') acid = ' ' ! kind of obvious! cxxxx RSV2 = ACID KNDX = KNDX + 1 C GET TURBULENCE INDEX FOR LATER STORAGE INTO DATA LEVEL CATEGORY 8 C ----------------------------------------------------------------- CALL UFBINT(LUNIT,TRBX_8,4,1,IRET, $ 'TRBX10 TRBX21 TRBX32 TRBX43');TRBX(1:4)=TRBX_8(1:4) ELSE IF(SUBSET.EQ.'NC004006'.OR.SUBSET.EQ.'NC004009'.OR. $ SUBSET.EQ.'NC004010') THEN C ------------------------------------------------------------ C E-AMDAR, CANADIAN AMDAR, and TAMDARB AIRCRAFT TYPE COME HERE C ------------------------------------------------------------ CALL UFBINT(LUNIT,RID_8,1,1,IRET,'ACRN') cccc IF(IRET.EQ.0.OR.(RID_8.GT.BMISS-5000..AND.RID_8.LT.BMISS+ cccc $ 5000.)) THEN cxxxx cpppppppppp cc print'(" rid_8,icbfms(sid,8): ",G0,1X,I0)', rid_8,icbfms(sid,8) cpppppppppp ccccc IF(ICBFMS(SID,8).NE.0) THEN C above line not working right - may return 0 when missing, so use next C two lines below temporarily until this is fixed (readlc will return C all blanks for sid when mnemonic "ACRN" not found) - dak 2/19/13 call readlc(lunit,sid,'ACRN') cpppppppppp cc print'(" sid = """,A,"""")', sid cpppppppppp if(sid.eq.' ') then cxxxx IF(SUBSET.EQ.'NC004006') THEN SID = 'E-AMDAR ' ELSE IF(SUBSET.EQ.'NC004009') THEN SID = 'CA-AMDAR' ELSE SID = 'TAMDARB ' END IF END IF IF(SUBSET.EQ.'NC004010') THEN C ................................................. C PANASONIC (AirDAT) TAMDAR AIRCRAFT TYPE COME HERE C ................................................. C GET INSTANTANEOUS ALTITUDE RATE FOR LATER STORAGE INTO DATA LEVEL C CATEGORY 8 C ----------------------------------------------------------------- CALL UFBINT(LUNIT,RIALR_8,1,1,IRET,'IALR');RIALR=RIALR_8 C TYPE OF COMMERCIAL AIRCRAFT STORED IN HEADER RESERVE CHARACTER C WORD 2 (C*8) C -------------------------------------------------------------- CALL UFBINT(LUNIT,RACTP_8,1,1,IRET,'ACTP') if(ibfms(RACTP_8).ne.0) ACTP = ' ' RSV2 = ACTP C OBSERVER IDENTIFICATION STORED IN BYTES 1-4 OF HEADER RESERVE C CHARACTER WORD 1 C ------------------------------------------------------------- CALL UFBINT(LUNIT,ROBSVR_8,1,1,IRET,'OBSVR') if(ibfms(ROBSVR_8).ne.0) OBSVR(1:4) = ' ' RSV1(1:4) = OBSVR(1:4) END IF else if(subset.eq.'NC004011'.or.subset.eq.'NC004103') then C -------------------------------------------------------- C KOREAN AMDAR AND CATCH-ALL AMDAR AIRCRAFT TYPE COME HERE C -------------------------------------------------------- CALL UFBINT(LUNIT,RID_8,1,1,IRET,'ACRN') CALL UFBINT(LUNIT,RACID_8,1,1,IRET,'ACID') if(ibfms(rid_8).eq.1) then ! ACRN missing; use ACID rid_8 = racid_8 if(ibfms(rid_8).eq.1) then ! ACRN and ACID both missing IF(SUBSET.EQ.'NC004011') THEN SID = 'K-AMDAR ' ELSE SID = 'AMDAR-BF' END IF end if end if if(ibfms(racid_8).eq.1) then ACID = ' ' end if C FLIGHT NUMBER STORED IN HEADER RESERVE CHARACTER WORD 2 (C*8) C ------------------------------------------------------------- if(subset.eq.'NC004103') RSV2 = ACID ELSE IF(SUBSET.EQ.'NC004008'.OR.SUBSET.EQ.'NC004012'.OR. $ SUBSET.EQ.'NC004013') THEN C ------------------------------------ C MADIS/TAMDAR AIRCRAFT TYPE COME HERE C ------------------------------------ CALL UFBINT(LUNIT,RID_8,1,1,IRET,'ACID') cccc IF(IRET.EQ.0.OR.(RID_8.GT.BMISS-5000..AND.RID_8.LT.BMISS+ cccc $ 5000.)) SID = 'TAMDAR-M' cxxxx cpppppppppp cc print'(" rid_8,icbfms(sid,8): ",G0,1X,I0)', rid_8,icbfms(sid,8) cpppppppppp ccccc IF(ICBFMS(SID,8).NE.0) SID = 'TAMDAR-M' C above line not working right - may return 0 when missing, so use next C two lines below temporarily until this is fixed (readlc will return C all blanks for sid when mnemonic "ACID" not found) - dak 2/19/13 call readlc(lunit,sid,'ACID') cpppppppppp cc print'(" sid = """,A,"""")', sid cpppppppppp if(sid.eq.' ') sid = 'TAMDAR-M' cxxxx C GET TURBULENCE INDEX FOR LATER STORAGE INTO DATA LEVEL CATEGORY 8 C ----------------------------------------------------------------- CALL UFBINT(LUNIT,TRBX_8(5),1,1,IRET,'TRBX');TRBX(5)=TRBX_8(5) C GET ROLL ANGLE FLAG FOR LATER STORAGE INTO DATA LEVEL CATEGORY 8 C ---------------------------------------------------------------- CALL UFBINT(LUNIT,ROLF_8,1,1,IRET,'ROLF');ROLF=ROLF_8 ELSE IF(SUBSET.EQ.'NC004001'.OR.SUBSET.EQ.'NC004002') THEN C ----------------------------------------------- C AIREP OR PIREP FORMAT AIRCRAFT TYPES COME HERE C ----------------------------------------------- C MAY POSSIBLY NEED TO MODIFY THE RPID HERE C (for later tests in prepacqc program) C ----------------------------------------- cdak no more!IF(SID(6:6).EQ.'Z') SID(6:6) = 'X' IF(SID.EQ.'A '.OR.SID.EQ.' '.OR.SID(1:3).EQ.'ARP' $ .OR.SID(1:3).EQ.'ARS') SID = 'AIRCFT ' cvvvvv temporary? C Determined that Hickum AFB reports are much like AFWA - they have C problems! They also are usually duplicates of either AFWA or C non-AFWA reports. Apparently the old front-end processing filtered C them out (according to B. Ballish). So, to make things match, we C will do the same here. C ACTUALLY, JEFF ATOR HAS REMOVED THESE FROM THE DECODER, SO WE C SHOULD NEVER EVEN SEE THEM IN THE DATABASE, but it won't hurt C anything to keep this in here. C (NOTE: These all have bulletin originator "PHWR".) if(CBULLX(8:11).eq.'PHWR') then cpppppppppp cc print'(" IW3UNPBF/R05UBF: TOSS ""PHWR"" AIREP FORMAT with ID = ", cc $ A,"; CBORG = ",A)', SID,CBULLX(8:11) cpppppppppp R05UBF = -9999 kskacf(8) = kskacf(8) + 1 return end if caaaaa temporary? cvvvvv temporary? C 1) AFWA converts ASDAR/ACARS reports originally in AMDAR C format into AIREP format. Nearly all of them are duplicated as C ASDAR/ACARS in true AMDAR format. The earlier version of the C aircraft dup-checker could not remove such duplicates; the new C verison now in operations can remove these. SO, WE HAVE C COMMENTED THIS OUT. C C These disguised reports can be identified by the string C " Sxyz" in the raw report (beyond byte 40), where y is 0,1, or 2. C (NOTE: Apparently AFWA here applies to more bulletin originators C than just "KAWN", so report header is not even checked.) C 2) AFWA also converts MDCRS ACARS reports into AIREP format. C These MAY duplicate true reports in the MDCRS ACARS subtype. C The NAS9000 decoder always excluded this type (no dup-checking C was done). All of these will be removed here. These disguised C reports can be identified by the string " Sxyz" in the raw C report (beyond byte 40), where y is 3 or greater. C (NOTE: Apparently AFWA here applies to more bulletin originators C than just "KAWN", so report header is not even checked.) crawrx = ' ' crawr = ' ' call ufbint(lunit,raw_8,1,255,nlev,'RRSTG') cppppp cc print *, 'this report''s RRSTG has nlev = ',nlev cc ni = -7 cc do mm = 1,nlev cc ni = ni + 8 cc crawrx(ni:ni+7) = craw(mm) cc if(ni+8.gt.500.and.mm.lt.nlev) print *, 'ni+8.gt.500' cc if(ni+8.gt.500) exit cc enddo cc print *, 'BULLETIN: "',crawrx(1:ni+7),'"' cppppp if(nlev.gt.5) then ni = -7 do mm = 6,nlev ni = ni + 8 crawr(ni:ni+7) = craw(mm) cppppp cc if(ni+8.gt.80.and.mm.lt.nlev) print *, 'ni+8.gt.80' cppppp if(ni+8.gt.80) exit enddo cppppp cc print *, 'BULLETIN(41-): " ', cc $ ' ',crawr(1:ni+7),'"' cppppp do mm = 1,ni+7 if(crawr(mm:mm+1).eq.' S') then if((crawr(mm+2:mm+2).ge.'0'.and.crawr(mm+2:mm+2).le. $ '9').or.crawr(mm+2:mm+2).eq.'/') then if((crawr(mm+3:mm+3).ge.'0'.and.crawr(mm+3:mm+3) $ .le.'9').or.crawr(mm+3:mm+3).eq.'/') then if((crawr(mm+4:mm+4).ge.'0'.and. $ crawr(mm+4:mm+4).le.'9').or.crawr(mm+4:mm+4) $ .eq.'/') then cpppppppppp cc print'(" IW3UNPBF/R05UBF: For ",A,", raw_8(",I0,") = ",G0)', cc $ SID,ni+7,crawr(1:ni+7) cpppppppppp if(crawr(mm+3:mm+3).lt.'3') then C THIS IS AN AMDAR FORMAT ASDAR/ACARS REPORT DISGUISED AS AN AIREP C FORMAT REPORT BY AFWA --> THROW OUT C (NOT ANYMORE, DUP-CHECKER IS HANDLING THESE OKAY NOW) C ---------------------------------------------------------------- cpppppppppp cc print'(" IW3UNPBF/R05UBF: Found a AFWA AMDAR in AIREP format ", cc $ "for ",A,"; CBORG = ",A)', SID,CBULLX(8:11) cpppppppppp cdak R05UBF = -9999 cdak KSKACF(3) = KSKACF(3) + 1 cdak RETURN else C THIS IS A MDCRS ACARS REPORT DISGUISED AS AN AIREP FORMAT REPORT C BY AFWA --> THROW OUT C ---------------------------------------------------------------- cpppppppppp cc print'(" IW3UNPBF/R05UBF: Found a AFWA ACARS in AIREP format ", cc $ "for ",A,"; CBORG = ",A)', SID,CBULLX(8:11) cpppppppppp R05UBF = -9999 KSKACF(4) = KSKACF(4) + 1 RETURN end if end if end if end if end if if(mm+5.gt.ni+7) exit enddo END IF caaaaa temporary? C AFWA INDICATOR STORED IN BYTE 1 OF HEADER RESERVE CHARACTER WORD 2 C (NOTE: NAS9000 ONLY ASSIGNED BULLETIN ORIGINATOR "KAWN" AS AFWA, C ALTHOUGH BULLETIN ORIGINATORS "PHWR" AND "EGWR" ARE C APPARENTLY ALSO AFWA) C ------------------------------------------------------------------ IF(CBULLX(8:11).EQ.'KAWN') RSV2(1:1) = 'C' END IF IF(SUBSET.EQ.'NC004003'.OR.SUBSET.EQ.'NC004004'.OR.SUBSET.EQ. $ 'NC004006'.OR.SUBSET.EQ.'NC004009'.OR.SUBSET.EQ.'NC004011'.OR. $ SUBSET.EQ.'NC004103'.OR.SUBSET.EQ.'NC004010') THEN C ----------------------------------------------------------------- C AMDAR FORMAT, MDCRS ACARS, E-AMDAR, CANADIAN AMDAR, KOREAN AMDAR, C CATCH-ALL AMDAR OR TAMDARB AIRCRAFT TYPES COME HERE C ----------------------------------------------------------------- C GET PRECISION OF TEMPERATURE OBSERVATION FOR LATER STORAGE C INTO DATA LEVEL CATEGORY 8 C ---------------------------------------------------------- CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PCAT');PCT=UFBINT_8 C GET PHASE OF FLIGHT FOR LATER STORAGE INTO DATA LEVEL CAT. 8 C ------------------------------------------------------------ CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'DPOF') if(ibfms(ufbint_8).eq.0) then C Translate DPOF values into POAF values if(int(ufbint_8).ge.7.and.int(ufbint_8).le.10) then ufbint_8 = 5. else if(int(ufbint_8).ge.11.and.int(ufbint_8).le.14) then ufbint_8 = 6. end if pof=ufbint_8 else CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'POAF');POF=UFBINT_8 endif END IF C ------------------------------ C ALL AIRCRAFT TYPES COME HERE C ------------------------------ C PUT THE LEVEL DATA INTO SPECIFIED UNPACKED FORMAT C ------------------------------------------------- CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,LVSTR);ARR=ARR_8 if(nlev.gt.0) then DO L=1,NLEV POB(L) = BMISS IF(ARR(1,L).LT.BMISS) POB(L) = NINT(ARR(1,L)*.1) TOB(L) = BMISS QOB(L) = BMISS IF(SUBSET.EQ.'NC004010') THEN IF(ARR(3,L).GE.BMISS) THEN CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TMDBST') ARR(3,L)=UFBINT_8 END IF IF(ARR(2,L).GE.BMISS.AND.ARR(6,L).GE.BMISS) THEN CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'RAWHU') ARR(6,L)=UFBINT_8 END IF ENDIF IF(ARR(3,L).LT.BMISS) THEN ITMP = NINT(ARR(3,L)*100.) TOB(L) = NINT((ITMP-27315)*0.1) IF(OBS2(42).EQ.0.OR.(SUBSET.EQ.'NC004008'.OR. $ SUBSET.EQ.'NC004012'.OR. $ SUBSET.EQ.'NC004013'.OR. $ SUBSET.EQ.'NC004006'.OR. $ SUBSET.EQ.'NC004103'.OR. $ SUBSET.EQ.'NC004010')) THEN C Process moisture (if present) if MADIS/TAMDAR (all types), C Panasonic(AirDAT)/TAMDAR, E-AMDAR, Catch-all AMDAR or MDCRS (but C for MDCRS only if MTSQ is zero) C dak-- is this still the case, is MTSQ=0 for all MDCRS with valid C moisture even in v7 BUFR??!!) C ---------------------------------------------------------------- C All data level category 6 rpts store specific humidity (g/kg) as C moisture variable C ---------------------------------------------------------------- C If pressure is not reported, calculate it here via U.S. Std. Atmos. C Est. solely for the purpose for calculating Td to gross check the C moisture if it is reported (this pressure will not be considered C as a reported pressure - the reported pressure will remain missing) C -------------------------------------------------------------------- if(pob(l).ge.bmiss) then if(nint(elev).le.11000) then p = pr(elev) else p = prs(elev) end if else p = pob(l)*0.1 end if QQ = -99999. mtyp_q = 1 IF(SUBSET.EQ.'NC004004') THEN C From 10/1/2006 through 10/31/2006, inclusive, and on 10/2/2007, C MDCRS ACARS MIXR may or may not have been scaled incorrectly by C ARINC - set to missing C ---------------------------------------------------------------- IF((IDATEB.GE.2006100100.AND.IDATEB.LE.2006103123) $ .OR. (IDATEB.GE.2007100200.AND.IDATEB.LE.2007100223)) $ ARR(2,L) = BMISS END IF IF(ARR(2,L).LT.BMISS) THEN IF(SUBSET.EQ.'NC004004') THEN C From 11/1/2006 through 10/1/2007, inclusive, MDCRS ACARS MIXR was C scaled incorrectly by ARINC (10 times too large), compensate for C this error by dividing reported MIXR by 10 C ----------------------------------------------------------------- IF(IDATEB.GE.2006110100.AND. $ IDATEB.LE.2007100123) ARR(2,L) = ARR(2,L)*0.1 END IF QQ = ARR(2,L)/(1.0 + ARR(2,L)) ELSE IF(ARR(6,L).LT.BMISS) THEN QQSAT = QFRMTP(ARR(3,L),P) QQ = (ARR(6,L) * 0.01) * QQSAT mtyp_q = 0 END IF IF(QQ.GT.0.0) THEN TD = TFRMQP(QQ,P) IF(NINT(TD*10.).LE.NINT(ARR(3,L)*10.)) THEN QOB(L) = QQ * 1000. if(mtyp_q.eq.1) then if(subset.ne.'NC004004'.and. $ subset.ne.'NC004006') $ print'(" ^^^^^ valid aircraft mixing ratio ",G0," kg/kg stored ", $ "as spec. humidity ",G0," g/kg - id ",A)', arr(2,L),qob(L),sid else if(subset.ne.'NC004010') $ print'(" ^^^^^ valid aircraft relative humidity ",G0," % stored", $ " as spec. humidity ",G0," g/kg - id ",A)', arr(6,L),qob(L),sid end if else if(mtyp_q.eq.1) then print'(" ^^^^^ INVALID aircraft mixing ratio ",G0," kg/kg - ", $ "spec. humidity set to missing - id ",A)', arr(2,L),sid else print'(" ^^^^^ INVALID aircraft relative humidity ",G0," % - ", $ "spec. humidity set to missing - id ",A)', arr(6,L),sid end if END IF END IF END IF END IF ZOB(L) = ELEV DOB(L) = ARR(4,L) SOB(L) = MIN(ARR(5,L)*10.,BMISS) ENDDO end if CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,QMSTR);ARR=ARR_8 C ----------------------------------------------------------------- C ALL AIRCRAFT TYPES COME HERE FOR QUALITY MARK ASSIGNMENT C ----------------------------------------------------------------- if(nlev.gt.0) then DO L=1,NLEV PQM(L) = EQMUBF(ARR(1,L)) TQM(L) = EQMUBF(ARR(2,L)) QQM(L) = EQMUBF(ARR(3,L)) ZQM(L) = EQMUBF(ARR(4,L)) WQM(L) = EQMUBF(ARR(5,L)) ENDDO end if IF(SUBSET.EQ.'NC004008'.OR.SUBSET.EQ.'NC004012'.OR. $ SUBSET.EQ.'NC004013') THEN C MADIS qual. markers for MADIS/TAMDAR (HONOR ALL BUT QM=2 FROM ABOVE) C -------------------------------------------------------------------- CALL UFBREP(LUNIT,RTAM_8,2,1,IRET,'PRLC QCD') RQCD_8 = RTAM_8(2) cdak print'(" MADIS PRLC QM is ",A)', QCD IF(PQM(1).EQ.2.AND.IBFMS(RTAM_8(1)).EQ.0) PQM(1) = MQMUBF(QCD) CALL UFBREP(LUNIT,RTAM_8,2,1,IRET,'TMDB QCD') RQCD_8 = RTAM_8(2) cdak print'(" MADIS TMDB QM is ",A)', QCD IF(TQM(1).EQ.2.AND.IBFMS(RTAM_8(1)).EQ.0) TQM(1) = MQMUBF(QCD) CALL UFBREP(LUNIT,RTAM_8,2,1,IRET,'REHU QCD') RQCD_8 = RTAM_8(2) cdak print'(" MADIS REHU QM is ",A)', QCD IF(QQM(1).EQ.2.AND.IBFMS(RTAM_8(1)).EQ.0) QQM(1) = MQMUBF(QCD) CALL UFBREP(LUNIT,RTAM_8,2,1,IRET,'WDIR QCD') RQCD_8 = RTAM_8(2) cdak print'(" MADIS WDIR QM is ",A)', QCD QWD = MQMUBF(QCD) ! wind direction RTAM_WDIR_8=RTAM_8(1) CALL UFBREP(LUNIT,RTAM_8,2,1,IRET,'WSPD QCD') RQCD_8 = RTAM_8(2) cdak print'(" MADIS WSPD QM is ",A)', QCD QWS = MQMUBF(QCD) ! wind speed AMAXIMUM_8 = MAX(RTAM_WDIR_8,RTAM_8(1)) IF(WQM(1).EQ.2.AND.IBFMS(AMAXIMUM_8).EQ.0) WQM(1) =MAX(QWD,QWS) CALL UFBREP(LUNIT,RTAM_8,2,1,IRET,'TRBX QCD') RQCD_8 = RTAM_8(2) cdak print'(" MADIS TRBX QM is ",A)', QCD QTRBX = MQMUBF(QCD) ! turbulence index else if(subset.eq.'NC004010') then C Quality markers for BUFR TAMDAR (2015 onward; assign QMs based on C the information from QMRKH/PCCF fields) (honor all but QM=2 from C just above) C transformation of TAMDAR QMRKH into PREPBUFR QM: C QMRKH 0 1 2 3 > 3 up to missing C -------------------------------------------------- C (T/W)QM 2 3 3 13 13 C ----------------------------------------------------------------- CALL UFBREP(LUNIT,RTAMB_8,1,7,IRET,'QMRKH') CCC print'(" RTAMB_8: ",4(1X,F7.2))', CCC & RTAMB_8(1), RTAMB_8(2), RTAMB_8(3), RTAMB_8(4) ! Order of QMRKH array representation: ! N = 1 2 3 4 5 6 7 ! SMMO, TMDBST, WDIR, WSPD, TRBXST, TOPEDR, AFIC Cfuture call ufbint(lunit,ufbint_8,1,1,iret,'SMMO') Cfuture if(ibfms(ufbint_8).eq.0) then Cfuture print'(" SMMO (not stored) is ",g0)', ufbint_8 Cfuture print'(" SMMO QMRKH is ",g0)', rtamb_8(1) Cfuture end if DO N = 2,4 RQCD_8 = 0.0 IF(RTAMB_8(N).GE.3.0) THEN RQCD_8 = 13.0 ELSE IF (RTAMB_8(N).GE.1.0) RQCD_8 = 3.0 IF (RTAMB_8(N).EQ.0.0) RQCD_8 = 2.0 ENDIF IF((N.EQ.2).AND.(TOB(1).LT.BMISS).AND.(TQM(1).EQ.2)) & TQM(1)=RQCD_8 ! T quality information IF((DOB(1).LT.BMISS).AND.(SOB(1).LT.BMISS).AND.(WQM(1).EQ.2)) & THEN IF(N.EQ.3) RTAM_WDIR_8=RQCD_8 ! WD quality IF(N.EQ.4) WQM(1)=MAX(RTAM_WDIR_8,RQCD_8) ! Total wind quality ENDIF ENDDO CCC print'(" TQM WQM ",2(1X,F7.2))', TQM(1), WQM(1) call UFBINT(LUNIT,RQCD_8,1,1,IRET,'PCCF') ! PCCF = percent confidence of RH quality IF((QOB(1).LT.BMISS).AND.(QQM(1).EQ.2)) THEN ! Always set QQM to 13 if TQM was set to 13 above (regardless of PCCF) IF((RQCD_8.LT.80.0).OR.(RQCD_8.GT.100.0) & .OR.(TQM(1).EQ.13.0)) THEN QQM(1) = 13.0 ELSE QQM(1) = 2.0 ENDIF ENDIF CCC print'(" REHU PCCF, QM ",2(1X,F5.1))', RQCD_8, QQM(1) END IF IF(SUBSET.NE.'NC004004' .and. SUBSET.NE.'NC004010') THEN C ------------------------------------------------------------------- C ALL AIRCRAFT TYPES EXCEPT MDCRS ACARS AND PANASONIC (AirDAT) TAMDAR C ALSO HAVE SPECIAL CASE: C IF PURGE FLAG ON WIND (14), TEMP Q.M. ALSO GETS PURGE FLAG (14) C (this is needed by PREPOBS_PREPACQC program) C (note: This should be moved to prepdata) C ------------------------------------------------------------------- if(nlev.gt.0) then DO L=1,NLEV IF(WQM(L).EQ.14) TQM(L) = 14 ENDDO end if END IF C PUT THE UNPACKED REPORT INTO OBS C -------------------------------- CALL S01UBF(SID,XOB,YOB,RHR,RCTIM,RSV1,RSV2,ELV,QMELV,ITP,RTP, $ RSTP,IDS) CALL S02UBF(6,1,*9999) C ------------------------------------------------------------------ C MISC DATA GOES INTO DATA LEVEL CATEGORY 08 C ------------------------------------------------------------------ C CODE FIGURE 021 - REPORT SEQUENCE NUMBER C (CURRENTLY ONLY FOR MDCRS ACARS) C CODE FIGURE 914 - PHASE OF FLIGHT C (CURRENTLY ONLY FOR AMDAR FORMAT, MDCRS ACARS, C E-AMDAR OR CANADIAN AMDAR) (BUFR C. TBL 0-08-004) C CODE FIGURE 915 - PRECISION OF TEMPERATURE OBSERVATION IN C 0.01*DEG. K C (CURRENTLY ONLY FOR AMDAR FORMAT, MDCRS ACARS, C E-AMDAR OR CANADIAN AMDAR) (BUFR C. TBL 0-02-005) C CODE FIGURE 926 - MDCRS ACARS TURBULENCE INDEX FOR PERIOD T-1 MINUTE C TO T-0 MINUTES (BUFR CODE TABLE 0-11-236) C CODE FIGURE 927 - MDCRS ACARS TURBULENCE INDEX FOR PERIOD T-2 MINUTE C TO T-1 MINUTES (BUFR CODE TABLE 0-11-237) C CODE FIGURE 928 - MDCRS ACARS TURBULENCE INDEX FOR PERIOD T-3 MINUTE C TO T-2 MINUTES (BUFR CODE TABLE 0-11-238) C CODE FIGURE 929 - MDCRS ACARS TURBULENCE INDEX FOR PERIOD T-4 MINUTE C TO T-3 MINUTES (BUFR CODE TABLE 0-11-239) C CODE FIGURE 930 - TAMDAR TURBULENCE INDEX (BUFR CODE TABLE 0-11-239) C INDICATOR 2 CONTAINS TURBULENCE INDEX QUALITY C MARKER (0-15) C CODE FIGURE 931 - TAMDAR ROLL ANGLE FLAG (BUFR CODE TABLE 0-02-199) C CODE FIGURE 932 - INSTANTANEOUS ALTITUDE RATE IN .001*METERS/SECOND C ------------------------------------------------------------------ IF(SUBSET.EQ.'NC004004') THEN OB8(1) = KNDX CF8(1) = 21 Q81(1) = IMISS Q82(1) = IMISS CALL S02UBF(8,1,*9999) END IF IF(PCT.LT.BMISS) THEN OB8(1) = NINT(PCT*100.) CF8(1) = 915 Q81(1) = IMISS Q82(1) = IMISS CALL S02UBF(8,1,*9999) END IF IF(POF.LT.BMISS) THEN OB8(1) = NINT(POF) CF8(1) = 914 Q81(1) = IMISS Q82(1) = IMISS CALL S02UBF(8,1,*9999) END IF DO I = 1,5 IF(TRBX(I).LT.BMISS) THEN OB8(1) = NINT(TRBX(I)) CF8(1) = 925 + I Q81(1) = IMISS Q82(1) = IMISS IF(I.EQ.5) Q82(1) = QTRBX CALL S02UBF(8,1,*9999) END IF ENDDO IF(ROLF.LT.BMISS) THEN OB8(1) = NINT(ROLF) CF8(1) = 931 Q81(1) = IMISS Q82(1) = IMISS CALL S02UBF(8,1,*9999) END IF IF(RIALR.LT.BMISS) THEN OB8(1) = NINT(RIALR*1000) CF8(1) = 932 Q81(1) = IMISS Q82(1) = IMISS CALL S02UBF(8,1,*9999) END IF CALL S03UBF(OBS,SUBSET,*9999,*9998,*9997) RETURN 9999 CONTINUE R05UBF = 999 RETURN 9998 CONTINUE print'(" IW3UNPBF/R05UBF: RPT with ID= ",A," TOSSED - ZERO ", $ "CAT.1-6,51 LVLS")', SID 9997 CONTINUE R05UBF = -9999 KSKACF(1) = KSKACF(1) + 1 RETURN END C*********************************************************************** C*********************************************************************** C*********************************************************************** FUNCTION R06UBF(LUNIT,OBS,OBS2,OBS3,NOBS3,obs8_8) C ---> PROCESSES SATWIND DATA (005/*) COMMON/IUBFAA/BMISS COMMON/IUBFBB/KNDX,KSKACF(8),KSKUPA,KSKSFC,KSKSAT,KFLSAT(12), $ KSKSMI COMMON/IUBFCC/SUBSET COMMON/IUBFEE/POB(255),QOB(255),TOB(255),ZOB(255),DOB(255), $ SOB(255),VSG(255),OB8(255),CF8(255) COMMON/IUBFFF/PQM(255),QQM(255),TQM(255),ZQM(255),WQM(255) COMMON/IUBFKK/KOUNT(499,18,2),KNTSAT(250:260),KNTMODIS(783:785), $ KNTavhrr(3:224),KNTviirs(224:225),IFLSAT,knts16(270:274) COMMON/IUBFLL/Q81(255),Q82(255) CHARACTER*80 HDSTR,HDSTR2,LVSTR,QMSTR,RCSTR CHARACTER*8 SUBSET,SID,RSV1,RSV2 CHARACTER*1 CSAT(499),CPROD(0:4),CPRDF(0:2),CPRDFN(51),C8(10) INTEGER IPRDF(0:2),ISWCM(5,9:10,2),ITP_C8(10),ISWDL(7) REAL(8) RID_8,UFBINT_8,PCCF_8(2,12),GNAP_8(12),HDR_8(20),RCT_8(5), $ ARR_8(10),OBS2_8(43),OBS3_8(5,255,7),WIND_8(2,5),PRLC_8(11), $ QFGU_8(8),BMISS,obs8_8(2) DIMENSION OBS(*),OBS2(43),OBS3(5,255,7),NOBS3(7),HDR(20), $ RCT(5),ARR(10),PCCF(2,12),GNAP(12),WIND(2,5),PRLC(11),QFGU(8) EQUIVALENCE (RID_8,SID) SAVE DATA HDSTR/'RPID CLON CLAT HOUR MINU SAID '/ DATA HDSTR2/'RPID CLONH CLATH HOUR MINU SAID '/ DATA LVSTR/'TMDP TMDB CCST '/ DATA RCSTR/'RCHR RCMI RCTS '/ DATA IMISS/99999/,XMISS/99999./ C======================================================================= C Note: CSAT, CPROD, CPRDF, CPRDFN, IPRDF and ISWCM below are valid C only for input data dump files prior to Dec 2000 where report C id has not yet been constructed (these no longer need to be C updated for new satellites, etc. - after Dec 2000 this is C handled in BUFR_DUPSAT) C (Note 1: GOES-16 & up do not construct a report id - it is C hardwired to "--------") C======================================================================= DATA CSAT C ** vestage from old days ** C --------------- 1 2 3 4 $ /'A', 'B', 'C', 'D', C --------------- spares (5-49) $ 45*'?', C ** Meteosat ** C --------------- 50 51 52 53 54 55 56 57 58 59 $ 'Z', 'W', 'X', 'Y', 'Z', 'W', 'X', 'Y', 'Z', 'W', C --------------- spares (60-98) 99 spares (100-149) $ 39* '?', 'X', 50* '?', C ** GMS ** C --------------- 150 151 152 153 154 155 156 157 158 159 $ 'R', 'O', 'P', 'Q', 'R', 'O', 'P', 'Q', 'R', 'O', C ** MTSAT ** C --------------- spares (160-170) 171 spares (172-198) 199 $ 11* '?', 'Q', 27* '?', 'Q', C --------------- spares (200-249) $ 50*'?', C ** GOES ** C --------------- 250 251 252 253 254 255 256 257 258 $ 'D','A','B','C','D','A','B','C','D', C --------------- spares (259-439) $ 181*'?', C ** Kalpana ** C --------------- 440 $ 'K', C --------------- spares (441-469) $ 29*'?', C ** Insat ** C --------------- 470 spares (471-498) 499 $ 'V', 28* '?', 'V'/ DATA CPROD /'C','D','?','?','E'/ DATA CPRDF /'V','C','B'/ DATA CPRDFN/'C','C','V','C','I','W','?','Z','P','I','W','Z','P', $ 'T','I','W','V','T',31*'?','C','V'/ DATA IPRDF / 4 , 1 , 6 / C ** High-Density Imager (+ low-dens. p. triplet) ** DATA ISWCM / 16, 17, 18, 3, 18, C ** High-Density Sounder ** $ 99, 99, 14, 99, 14, C ** Low-Density Imager ** $ 1, 6, 4, 99, 4, C ** Low-Density Sounder ** $ 99, 99, 99, 99, 99/ C======================================================================= C Note: C8 and ITP_C8 below are valid only for input data dump files C after Dec 2000 where report id has already beeen contructed by C BUFR_DUPSAT C======================================================================= C C8 is eighth character in report id, it determines instrument/ C product type (ITP_C8 later stored into ITP) for all producers and is C defined a bit further below DATA C8/'C','P','V','B','T','L','I','Z','W','S'/ DATA ITP_C8/ 1 , 3 , 4 , 6 ,14 ,15, 16, 17, 18, 19/ C======================================================================= C Note: ISWDL below is valid for all input data dump files regardless C of their date (Note: it is not used for GOES-16 & up) C======================================================================= DATA ISWDL / ! cloud top/deep-layer indicator for winds generated ! by NESDIS or NASA (meaning defined a bit further ! below) C -> Wind type: C IR(LW,SW) VISIBLE WV-CLTOP PTRIPLET WV-DPLYR N/A C --------- -------- -------- -------- -------- --- $ 2 , 2 , 2 , 99999, 1 , 2* 99999 / C======================================================================= C Note: IPRD16 below is valid only for GOES-16 & up satellite wind C reports C======================================================================= integer iprd16(30:39) data iprd16 /16,18,17,99999,18,4*99999,19/ C======================================================================= HGTF(P) = (1.-(P/1013.25)**(1./5.256))*(288.15/.0065) C FCNS BELOW CONVERT TEMP/TD(K) & PRESS(MB) INTO SAT./SPEC. HUM.(KG/KG) C --------------------------------------------------------------------- ES(T) = 6.1078 * EXP((17.269 * (T - 273.16))/((T - 273.16)+237.3)) QFRMTP(T,P) = (0.622 * ES(T))/(P - (0.378 * ES(T))) R06UBF = 0 C STORE SINGLE LEVEL REPORT DATA DIRECTLY INTO OBS2 ARRAY AND C DOUBLE-PRECISION SINGLE LEVEL REPORT DATA DIRECTLY INTO OBS8_8 ARRAY C --------------------------------------------------------------------- OBS2_8 = BMISS obs8_8 = bmiss CALL UFBINT(LUNIT,OBS2_8,2,1,IRET,'RSRD EXPRSRD') CALL UFBINT(LUNIT,OBS2_8(43),1,1,IRET,'SAZA') OBS2 = OBS2_8 IFLSAT = 1 CALL S05UBF C PUT THE HEADER INFORMATION INTO UNPACKED FORMAT C ----------------------------------------------- if(subset(6:7).eq.'03') then C GOES-16 & up (in subsets NC00503x) do not construct a report id and C they have high-res lat/lon C ------------------------------------------------------------------- call ufbint(lunit,hdr_8,20,1,iret, $ 'NUL CLONH CLATH HOUR MINU SAID');hdr(2:)=hdr_8(2:) else if(subset(7:8).eq.'67'.or.subset(7:8).eq.'68'.or. $ subset(7:8).eq.'69') then CALL UFBINT(LUNIT,HDR_8,20,1,IRET,HDSTR2);HDR(2:)=HDR_8(2:) else CALL UFBINT(LUNIT,HDR_8,20,1,IRET,HDSTR);HDR(2:)=HDR_8(2:) end if CALL UFBINT(LUNIT,RCT_8, 5,1,NRCT,RCSTR);RCT=RCT_8 obs8_8(1) = hdr_8(3) obs8_8(2) = hdr_8(2) IF(HDR(5).GE.BMISS) HDR(5) = 0 RCTIM = NINT(RCT(1))+NINT(RCT(2))/60. RID_8 = HDR_8(1) XOB = HDR(2) YOB = HDR(3) RHR = BMISS IF(HDR(4).LT.BMISS) RHR = NINT(HDR(4))+NINT(HDR(5))/60. RSV1 = ' ' RSV2 = ' ' IDS = IMISS IF(HDR(6).LT.BMISS) IDS = NINT(HDR(6)) C SATWIND PRODUCER INDICATOR STORED IN BYTE 1 OF HEADER RESERVE C CHARACTER WORD 1 C ------------------------------------------------------------- C = 1 - USA/NOAA/NESDIS C = 4 - USA/NOAA.NWS C = 5 - USA/UNIVERSITY C = 6 - USA/COMMERCIAL C = 7 - USA/DOD/NAVY C = 8 - USA/DOD/USAF C = 9 - USA/NASA C =12 - ESA/METEOSAT C =13 - GMS/MSC C =14 - INDIA/INSAT C CLOUD TOP/DEEP LAYER INDICATOR STORED IN BYTE 3 OF HEADER RESERVE C CHARACTER WORD 1 C ------------------------------------------------------------------ C = 1 - DEEP LAYER C = 2 - CLOUD TOP (NORMAL CLOUD DRIFT) C = 9 - INDICATOR MISSING (REVERTS TO DEFAULT CLOUD TOP) C THE INSTRUMENT TYPE INDICATES THE PRODUCT TYPE C ---------------------------------------------- C = 1 - IR (LONG-WAVE) AUTOMATED WINDS (LOW DENSITY) C = 2 - IR (LONG-WAVE) MANUAL WINDS C = 3 - PICTURE TRIPLET (LOW DENSITY) C = 4 - WATER VAPOR AUTOMATED (LOW DENSITY) C = 5 - VISIBLE MANUAL C = 6 - VISIBLE AUTOMATED (LOW DENSITY) C = 7 - GRADIENT WINDS C = 8 - PICTURE PAIR; C =10 - AMSU/SSMI MICROWAVE WINDS C =11 - SCATTEROMETER C =12 - ALTIMETER C =13 - LAWS C =14 - HIGH-DENSITY WATER VAPOR SOUNDER, CHN. 10 C =15 - HIGH-DENSITY WATER VAPOR SOUNDER, CHN. 11 C =16 - HIGH-DENSITY IR (LONG-WAVE) IMAGER AUTOMATED WINDS C =17 - HIGH-DENSITY VISIBLE IMAGER AUTOMATED WINDS C =18 - HIGH-DENSITY WATER VAPOR IMAGER C =19 - HIGH-DENSITY IR (SHORT-WAVE) IMAGER AUTOMATED WINDS ITP = IMISS if(subset(6:7).eq.'03') then C*********************************************************************** C GOES-16 & up (in subsets NC00503x) (which do not construct a report C id) store instrument (product) type as well as cloud top/deep layer C indicator based on last 2 digits of subset; satwind producer C indicator is hardwired as "1" (USA/NOAA/NESDIS); report id is C hardwired as "--------" since it does not exist C*********************************************************************** rsv1(1:1) = "1" rsv1(3:3) = "2" sid = "--------" read(subset(7:8),'(I2)') isubset78 itp = iprd16(isubset78) if(subset(7:8).eq.'31') rsv1(3:3) = "1" ELSE IF(SID(8:8).LT.'A'.OR.SID(8:8).GT.'Z') THEN C*********************************************************************** C IF THE EIGHTH CHARACTER OF THE INPUT STN. ID IS NOT "A" - "Z", THEN C THIS SUBROUTINE MUST CREATE THE STN. ID. C (INDICATES AN INPUT DATA DUMP FILE PRIOR TO DEC. 2000) C*********************************************************************** C REPROCESSED CHAR 1 -----> GOES: SAT. NO. 247,251,255 GET 'A' C SAT. NO. 248,252,256 GET 'B' C SAT. NO. 249,253,257 GET 'C' C SAT. NO. 250,254,258 GET 'D' C (Note: Sat. No. 253 gets 'P' C if producer is JMA) C -----> METEOSAT: SAT. NO. 52, 56 GET 'X' C SAT. NO. 53, 57 GET 'Y' C SAT. NO. 50, 54, 58 GET 'Z' C SAT. NO. 51, 55, 59 GET 'W' C SAT. NO. 99 (UNKNOWN) GET 'X' C -----> GMS(JA): SAT. NO. 152,156,253 GET 'P' C SAT. NO. 153,157 GET 'Q' C SAT. NO. 150,154,158 GET 'R' C SAT. NO. 151,155,159 GET 'O' C (Note: Sat. No. 253 gets 'C' C if producer is NESDIS) C -----> MTSAT: SAT. NO. 171 GET 'Q' C SAT. NO. 199 (UNKNOWN) GET 'Q' C -----> KALPANA: SAT. NO. 440 GET 'K' C -----> INSAT: SAT. NO. 470 GET 'V' C SAT. NO. 499 (UNKNOWN) GET 'V' C REPROCESSED CHAR 2 -----> WINDS PRODUCED BY NESDIS: C RETURNED VALUE IN BUFR FOR 'SWPR' C (PRODUCER), IF NON-MISSING; OTHERWISE C HARDWIRED TO '1' C -----> WINDS PRODUCED BY FOREIGN PRODUCERS: C SAT. PRODUCER -- ESA GET 'C' C -- GMS/MTSAT GET 'D' C -- INSAT/KALPANA GET 'E' C REPROCESSED CHAR 3-7 ---> SEQUENTIAL SERIAL INDEX (00001 - 99999) C (UNIQUE FOR EACH NCEP BUFR CHAR 1/2/6 C COMB.) C REPROCESSED CHAR 8 -----> WINDS PRODUCED BY NESDIS: C OLD FORMAT, (GOES -LOW-DENSITY-OBSOLETE) C -- IR(LW) CLOUD DRIFT GET 'C' C -- VISIBLE CLOUD DRIFT GET 'C' C -- PICTURE TRIPLET GET 'C' C -- WATER VAPOR GET 'V' C NEW FORMAT (GOES - HIGH-DENSITY) C -- IR(LW) IMAGER CLD DRIFT GET 'I' C -- VIS IMAGER CLOUD DRIFT GET 'Z' C -- WATER VAPOR IMAGER GET 'W' C -- WATER VAPR SNDR, CHN 10 GET 'T' C -- WATER VAPR SNDR, CHN 11 GET 'L' C NEW FORMAT (GMS - LOW-DENSITY) C -- IR(LW) CLOUD DRIFT GET 'C' C -- WATER VAPOR GET 'V' C -----> WINDS PRODUCED BY FOREIGN PRODUCERS: C -- IR(LW) CLOUD DRIFT GET 'C' C -- VISIBLE CLOUD DRIFT GET 'B' C -- WATER VAPOR GET 'V' SID = '????????' IPRODUCER = 99 IDENSITY = 99 IF(IDS.LT.500) THEN SID(1:1) = CSAT(IDS) C .... GOES-9 winds with BUFR message subtype 41-46 always get "P" C in 1st char. of stn. id (JMA began producing winds from C GOES-9 in place of failing GMS-5 on 23 May 2003, this lasted C until 15 July 2005 when MTSAT-1R replaced GOES-9) C (Note: When NESDIS produces winds from GOES-9, the first C char. in the stn. id is "C", but that would cause C problems in PREPOBS_PREPDATA in this case) IF(IDS.EQ.253.AND.SUBSET(7:7).EQ.'4') SID(1:1) = 'P' IF((SID(1:1).GE.'A'.AND.SID(1:1).LE.'D') .OR. $ (SUBSET(7:8).EQ.'50'.OR.SUBSET(7:8).EQ.'51')) THEN IF(SUBSET(7:8).EQ.'50'.OR.SUBSET(7:8).EQ.'51') THEN IDENSITY = 2 ELSE IDENSITY = 1 END IF C .. Satellite producer for winds generated by NESDIS CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SWPR');SWPR=UFBINT_8 IF(SWPR.LT.BMISS) THEN ! From NESDIS Binary Fmt (local) ! (both lo- and hi- density) IF(NINT(SWPR).GT.0.AND.NINT(SWPR).LT.10) $ WRITE(RSV1(1:1),'(I1)') NINT(SWPR) SID(2:2) = RSV1(1:1) ELSE CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'GCLONG') GCLONG=UFBINT_8 ! From NESDIS BUFR Fmt (WMO) ! Should come in as 160 (NESDIS), ! but irregardless hardwire here as ! 1 RSV1(1:1) = '1' SID(2:2) = RSV1(1:1) END IF IPRODUCER=1 C .. Product type for winds generated by NESDIS CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SWTP');SWTP=UFBINT_8 CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'CMCM');CMCM=UFBINT_8 IF(SWTP.LT.BMISS) THEN ITP = NINT(SWTP) ! From NESDIS Binary Fmt (local) ! (hi- density) ELSE IF(CMCM.LT.BMISS) THEN ! From NESDIS Binary Fmt (local) ! (lo- density) ! (Note: CMCM is non-missing in this ! case but may not be correct! IF(SUBSET(7:8).EQ.'01') THEN ITP = 1 ELSE IF(SUBSET(7:8).EQ.'02') THEN ITP = 6 ELSE IF(SUBSET(7:8).EQ.'03') THEN ITP = 4 ELSE IF(SUBSET(7:8).EQ.'04') THEN ITP = 3 END IF ELSE CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SWCM') SWCM=UFBINT_8 CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SIDP') SIDP=UFBINT_8 C Effective 3/10/2005 NESDIS fixed an error which had stored SIDP as C a code table value rather than correctly as a flag table value - in C response must redirect SIDP value back to original code table value C (will still work ok for historical runs prior to NESDIS fix) C -------------------------------------------------------------------- IF(NINT(SIDP).EQ.4194304) THEN SIDP = 9 ELSE IF(NINT(SIDP).EQ.2097152) THEN SIDP = 10 ENDIF IF((NINT(SWCM).GT. 0.AND.NINT(SWCM).LT. 6).AND. $ (NINT(SIDP).EQ. 9.OR. NINT(SIDP).EQ.10)) !From NESDIS BUFR Fmt (WMO) $ ITP = ISWCM(NINT(SWCM),NINT(SIDP),IDENSITY) IF(ITP.EQ.14) THEN CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SCCF') SCCF = UFBINT_8 SCCF = SCCF*1E-11 IF(INT(SCCF).EQ.405) ITP = 15 END IF END IF READ(SUBSET(7:8),'(I2)') INUM2 IF(INUM2.LT.52) SID(8:8) = CPRDFN(INUM2) IF(SID(8:8).EQ.'T') THEN IF(ITP.EQ.15) SID(8:8) = 'L' END IF C .. Cloud top/deep-layer indicator for winds generated by NESDIS CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SWDL');SWDL=UFBINT_8 IF(SWDL.GE.BMISS) THEN ! NESDIS GTS (& eventually V10 server ! too) & MODIS winds come here IF(NINT(SWCM).GT.0.AND.NINT(SWCM).LT.8) THEN IF(ISWDL(NINT(SWCM)).LT.3) SWDL = ISWDL(NINT(SWCM)) END IF END IF IF(NINT(SWDL).GT.-1.AND.NINT(SWDL).LT.10) $ WRITE(RSV1(3:3),'(I1)') NINT(SWDL) ELSE C .. Satellite producer for winds generated from foreign producers SID(2:2) = CPROD(IDS/100) C .... GOES-9 winds with BUFR message subtype 41-46 are assumed to C be produced by JMA (JMA began producing winds from GOES-9 C in place of failing GMS-5 on 23 May 2003, this lasted until C 15 July 2005 when MTSAT-1R replaced GOES-9) IF(IDS.EQ.253.AND.SUBSET(7:7).EQ.'4') SID(2:2)='D' IPRODUCER=2 RSV1(1:1) = SID(2:2) READ(SUBSET(8:8),'(I1)') INUM1 C .. Product type for winds generated from foreign producers SID(8:8) = CPRDF(MOD(INUM1,3)) ITP = IPRDF(MOD(INUM1,3)) C .. Cloud top/deep-layer indicator for winds generated from foreign C producers CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SWCM') SWCM=UFBINT_8 IF(NINT(SWCM).GT.0.AND.NINT(SWCM).LT.8) THEN IF(ISWDL(NINT(SWCM)).LT.3) SWDL = ISWDL(NINT(SWCM)) END IF IF(NINT(SWDL).GT.-1.AND.NINT(SWDL).LT.10) $ WRITE(RSV1(3:3),'(I1)') NINT(SWDL) END IF END IF IF(IDS.LT.500.AND.ITP.LT.19.AND.IPRODUCER.LT.3) THEN KOUNT(IDS,ITP,IPRODUCER) = $ MIN(KOUNT(IDS,ITP,IPRODUCER)+1,99999) WRITE(SID(3:7),'(I5.5)') KOUNT(IDS,ITP,IPRODUCER) END IF ELSE C*********************************************************************** C IF THE EIGHTH CHARACTER OF THE INPUT STN. ID IS "A" - "Z", THEN C THE DUMP PROGRAM BUFR_DUPSAT HAS ALREADY CREATED THE STN. ID. C (INDICATES AN INPUT DATA DUMP FILE AFTER DEC. 2000) C*********************************************************************** RSV1(1:1) = SID(2:2) IF((SID(1:1).GE.'A'.AND.SID(1:1).LE.'D') .OR. $ (SUBSET(7:8).EQ.'50'.OR.SUBSET(7:8).EQ.'51') .OR. $ (SUBSET(7:8).EQ.'70'.OR.SUBSET(7:8).EQ.'71') .OR. $ (SUBSET(7:8).EQ.'80') .OR. $ (SUBSET(7:8).EQ.'90')) THEN C .. Product type for winds generated by NESDIS/NASA CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SWTP');SWTP=UFBINT_8 CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'CMCM');CMCM=UFBINT_8 IF(SWTP.LT.BMISS) THEN ITP = NINT(SWTP) ! From NESDIS Binary Fmt (local) ! (hi- density) ELSE IF(CMCM.LT.BMISS) THEN ! From NESDIS Binary Fmt (local) ! (lo- density) ! (Note: CMCM is non-missing in this ! case but may not be correct! IF(SUBSET(7:8).EQ.'01') THEN ITP = 1 ELSE IF(SUBSET(7:8).EQ.'02') THEN ITP = 6 ELSE IF(SUBSET(7:8).EQ.'03') THEN ITP = 4 ELSE IF(SUBSET(7:8).EQ.'04') THEN ITP = 3 END IF ELSE !From NESDIS BUFR Fmt (WMO) DO K=1,10 IF(SID(8:8).EQ.C8(K)) THEN ITP = ITP_C8(K) EXIT END IF ENDDO END IF C .. Cloud top/deep-layer indicator for winds generated by NESDIS or C NASA CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SWDL');SWDL=UFBINT_8 IF(SWDL.GE.BMISS) THEN ! NESDIS GTS & MODIS/AVHRR/VIIRS ! winds come here CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SWCM') SWCM=UFBINT_8 IF(NINT(SWCM).GT.0.AND.NINT(SWCM).LT.8) THEN IF(ISWDL(NINT(SWCM)).LT.3) SWDL = ISWDL(NINT(SWCM)) END IF END IF IF(NINT(SWDL).GT.-1.AND.NINT(SWDL).LT.10) $ WRITE(RSV1(3:3),'(I1)') NINT(SWDL) ELSE C .. Product type for winds generated from foreign producers DO K=1,4 IF(SID(8:8).EQ.C8(K)) THEN ITP = ITP_C8(K) EXIT END IF ENDDO C .. Cloud top/deep-layer indicator for winds generated from foreign C producers CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SWCM') SWCM=UFBINT_8 IF(NINT(SWCM).GT.0.AND.NINT(SWCM).LT.8) THEN IF(ISWDL(NINT(SWCM)).LT.3) SWDL = ISWDL(NINT(SWCM)) END IF IF(NINT(SWDL).GT.-1.AND.NINT(SWDL).LT.10) $ WRITE(RSV1(3:3),'(I1)') NINT(SWDL) C From approximately 11 August through 30 September 2010, BUFR_DUPSAT C incorrectly placed a "?" in character 1 of the generated report id C for JMA MTSAT-2 wind reports -- change this to the correct value of C "R" for historical reruns, etc. C -------------------------------------------------------------------- IF(IDS.EQ.172.AND.SID(1:1).EQ.'?') SID(1:1) = 'R' END IF C*********************************************************************** END IF RTP = 63 C PUT THE SINGLE-LEVEL DATA INTO SPECIFIED UNPACKED FORMAT C -------------------------------------------------------- POB(1) = BMISS CALL UFBREP(LUNIT,PRLC_8,1,11,IRET,'PRLC');PRLC=PRLC_8 cpppppppppp cc print *,'IRET = ',iret cc do i=1,iret cc print'(" For I = ",I0,"; PRLC IS: ",G0)', I,PRLC(I) cc enddo cpppppppppp C Which pressure do you want: C JTP = 1 -- Final (observed) C = 2 -- Window channel height assignment C = 3 -- Histogram height assignment C = 4 -- H2O intercept height assignment C = 5 -- CO2 slicing height assignment C = 6 -- Original (primary height assignment) C Note: JTP = 1 always for GOES-16 & up, or non-GOES, or non-NESDIS C GTS, or non-MODIS/AVHRR/VIIRS wind types IF(IRET.EQ.1 .or. subset(6:7).eq.'03') THEN JTP = 1 ELSE JTP = 1 ! Here hardwired to be final for GOES, and NESDIS ! GTS, and MODIS/AVHRR/VIIRS wind types ENDIF IF(PRLC(JTP).LT.BMISS) POB(1) = NINT(PRLC(JTP)*.1) C GROSS CHECK ON PRESSURE C ----------------------- IF(NINT(POB(1)).EQ.0) THEN print'(" ~~IW3UNPBF/R06UBF: RPT with ID= ",A," TOSSED - PRES.", $ " IS ZERO MB")', SID R06UBF = -9999 KSKSAT = KSKSAT + 1 RETURN END IF C TRY TO FIND FIND THE HEIGHT ASSIGNMENT C -------------------------------------- CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'HGHT');HGHT=UFBINT_8 IF(HGHT.LT.BMISS) THEN ELV = HGHT ELSE IF(POB(1).LT.BMISS) THEN ELV = HGTF(POB(1)*.1) ELSE ELV = BMISS END IF QMELV = XMISS if(subset(6:7).eq.'03') THEN C GOES-16 & up (in subsets NC00503x) store TMDBST rather than TMDB C ---------------------------------------------------------------- call ufbint(lunit,arr_8,10,1,iret,'TMDP TMDBST CCST');arr=arr_8 else CALL UFBINT(LUNIT,ARR_8,10,1,IRET,LVSTR);ARR=ARR_8 end if QOB(1) = BMISS IF(MAX(ARR(1),ARR(2),POB(1)).LT.BMISS) THEN C All data level category 6 rpts store specific humidity (g/kg) as C moisture variable C ---------------------------------------------------------------- QQ = QFRMTP(ARR(1),POB(1)*0.1) IF(QQ.GT.0.0.AND.NINT(ARR(1)*10.).LE.NINT(ARR(2)*10.)) $ QOB(1) = QQ * 1000. END IF TOB(1) = BMISS IF(ARR(2).LT.BMISS) THEN ITMP = NINT(ARR(2)*100.) ! From NESDIS binary FMT & TOB(1) = NINT((ITMP-27315)*0.1) ! foreign pre-V10 BUFR, ! temp in "TMDB"; ! From NESDIS BUFR Fmt ! GOES-16 & up, ! temp in "TMDBST" ELSE IF(ARR(3).LT.BMISS) THEN ITMP = NINT(ARR(3)*100.) ! From NESDIS BUFR Fmt & TOB(1) = NINT((ITMP-27315)*0.1) ! foreign V10 BUFR, temp ! in "CCST" END IF ZOB(1) = ELV CALL UFBREP(LUNIT,WIND_8,2,5,IRET,'WDIR WSPD');WIND=WIND_8 cpppppppppp cc do i=1,iret cc print'(" For I = ",I0,"; WIND IS: ",2(G0,1X))',I,WIND(1,I), cc $ WIND(2,I) cc enddo cpppppppppp C Which wind speed and direction do you want: C KTP = 1 -- Final (observed) C = 2 -- First guess C = 3 -- Original C = 4 -- Image 1 to 2 C = 5 -- Image 2 to 3 C Note: KTP = 1 always for GOES-16 & up, or non-GOES, or non-NESDIS C GTS, or non-MODIS/AVHRR/VIIRS wind types IF(IRET.EQ.1 .or. subset(6:7).eq.'03') THEN KTP = 1 ELSE KTP = 1 ! Here hardwired to be final for GOES, and NESDIS ! GTS, and MODIS/AVHRR/VIIRS wind types ENDIF DOB(1) = WIND(1,KTP) SOB(1) = MIN(WIND(2,KTP)*10.,BMISS) CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SWQM');SWQM=UFBINT_8 IF(IRET.EQ.1) THEN WQM(1) = EQMUBF(SWQM) PQM(1) = 2 TQM(1) = 2 QQM(1) = 2 ZQM(1) = 2 END IF CVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVV CVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVV QI_with = BMISS QC_QI_with = BMISS QI_without = BMISS QC_QI_without = BMISS RFF = BMISS QC_RFF = BMISS EE = BMISS QC_EE = BMISS QI_without_common = bmiss IF((SUBSET(7:8).GE.'10'.AND.SUBSET(7:8).LE.'12') .OR. $ SUBSET(7:8).EQ.'14' .OR. $ (SUBSET(7:8).GE.'15'.AND.SUBSET(7:8).LE.'19') .OR. $ (SUBSET(7:8).GE.'44'.AND.SUBSET(7:8).LE.'46') .OR. $ (SUBSET(7:8).GE.'64'.AND.SUBSET(7:8).LE.'69') .OR. $ (SUBSET(7:8).GE.'70'.AND.SUBSET(7:8).LE.'71') .OR. $ (SUBSET(7:8).EQ.'80') .OR. $ (SUBSET(7:8).EQ.'90')) THEN IF(SUBSET(7:8).GE.'64'.AND.SUBSET(7:8).LE.'69') THEN !EUMETSAT INDX = 1 IOFF = 0 IVARS = 4 ! number of variables w/ quality info IQI = 1 ! value of GNAP for QI w/ forecast IQIwo = 2 ! value of GNAP for QI w/o forecast IRFF = 3 ! value of GNAP for RFF (present after ?-?-2006) ccccccccc LIMqi = 80 ! if QI less than or equal to this - flag LIMqi = 0 ! if QI less than or equal to this - flag ccccccccc LIMqc = 3 ! if Manual/automatic q.c. indicator greater ccccccccc ! than or equal to this - flag LIMqc = 999 ! if Manual/automatic q.c. indicator greater ! than or equal to this - flag ELSE IF(SUBSET(7:8).GE.'44'.AND.SUBSET(7:8).LE.'46') THEN !JMA INDX = 3 IOFF = 0 IVARS = 4 ! number of variables w/ quality info IQI = 101 ! value of GNAP for QI w/ forecast IQIwo = 102 ! value of GNAP for QI w/o forecast IRFF = 103 ! value of GNAP for RFF LIMqi = 80 ! if QI less than or equal to this - flag LIMqc = 3 ! if Manual/automatic q.c. indicator greater ! than or equal to this - flag ELSE IF(SUBSET(7:8).GE.'15'.AND.SUBSET(7:8).LE.'18') THEN ! GOES-15 & ! down-GTS INDX = 5 IVARS = 2 ! number of variables w/ quality info IOFF = 1 IQI = 3 ! value of GNAP for QI w/ forecast IQIwo = 1 ! value of GNAP for QI w/o forecast IRFF = 2 ! value of GNAP for RFF LIMqi = 49 ! if QI less than or equal to this - flag LIMqc = 3 ! if Manual/automatic q.c. indicator greater ! than or equal to this - flag ELSE IF((SUBSET(7:8).GE.'10'.AND.SUBSET(7:8).LE.'12') .OR. $ (SUBSET(7:8).EQ.'14') .OR. (SUBSET(7:8).EQ.'19')) THEN ! GOES-15 & ! down-V10 ! (server) INDX = 5 IVARS = 2 ! number of variables w/ quality info IOFF = 1 IQI = 3 ! value of GNAP for QI w/ forecast IQIwo = 1 ! value of GNAP for QI w/o forecast IRFF = 2 ! value of GNAP for RFF IEE = 4 ! value of GNAP for NESDIS Expected Error LIMqi = 49 ! if QI less than or equal to this - flag LIMqc = 3 ! if Manual/automatic q.c. indicator greater ! than or equal to this - flag ELSE IF(SUBSET(7:8).GE.'70'.AND.SUBSET(7:8).LE.'71') THEN !MODIS POES INDX = 7 IVARS = 2 ! number of variables w/ quality info IOFF = 1 IQI = 3 ! value of GNAP for QI w/ forecast IQIwo = 1 ! value of GNAP for QI w/o forecast IRFF = 2 ! value of GNAP for RFF IEE = 4 ! value of GNAP for NESDIS Expected Error LIMqi = 49 ! if QI less than or equal to this - flag LIMqc = 3 ! if Manual/automatic q.c. indicator greater ! than or equal to this - flag ELSE IF(SUBSET(7:8).EQ.'80') THEN !AVHRR POES INDX = 9 IVARS = 2 ! number of variables w/ quality info IOFF = 1 IQI = 3 ! value of GNAP for QI w/ forecast IQIwo = 1 ! value of GNAP for QI w/o forecast IRFF = 2 ! value of GNAP for RFF IEE = 4 ! value of GNAP for NESDIS Expected Error ccccccccc LIMqi = 49 ! if QI less than or equal to this - flag LIMqi = 0 ! if QI less than or equal to this - flag ccccccccc LIMqc = 3 ! if Manual/automatic q.c. indicator greater ccccccccc ! than or equal to this - flag LIMqc = 999 ! if Manual/automatic q.c. indicator greater ! than or equal to this - flag ELSE IF(SUBSET(7:8).EQ.'90') THEN !VIIRS POES INDX = 11 IVARS = 2 ! number of variables w/ quality info IOFF = 1 IQI = 3 ! value of GNAP for QI w/ forecast IQIwo = 1 ! value of GNAP for QI w/o forecast IRFF = 2 ! value of GNAP for RFF IEE = 4 ! value of GNAP for NESDIS Expected Error ccccccccc LIMqi = 49 ! if QI less than or equal to this - flag LIMqi = 0 ! if QI less than or equal to this - flag ccccccccc LIMqc = 3 ! if Manual/automatic q.c. indicator greater ccccccccc ! than or equal to this - flag LIMqc = 999 ! if Manual/automatic q.c. indicator greater ! than or equal to this - flag END IF CALL UFBREP(LUNIT,GNAP_8, 1,12,IRET_GNAP,'GNAP');GNAP=GNAP_8 CALL UFBREP(LUNIT,PCCF_8, 2,12,IRET_PCCF,'PCCF MAQC') PCCF=PCCF_8 CALL UFBREP(LUNIT,QFGU_8, 1, 8,IRET_QFGU,'QFGU');QFGU=QFGU_8 IF(IRET_PCCF.GT.0 .AND. IRET_PCCF.LT.13) THEN C For EUMETSAT (BUFR), if only four replications of PCCF/MAQC are C found in a report, it is prior to 6-4-2001 when only one EUMETSAT C Quality Index was calculated {using a forecast (first guess) C consistency test} {Note: JMA (BUFR) did not exist at this time} C C For EUMETSAT (BUFR) or JMA (BUFR), if eight (EUMETSAT prior to C ?-?-2006) or twelve (JMA all dates or EUMETSAT after ?/?/2006) C replications of PCCF/MAQC are found in a report, it is after C 6-4-2001 when EUMETSAT Quality Index with forecast (first guess) C consistency test, EUMETSAT Quality Index without forecast (first C guess) consistency test, and (for JMA all dates and EUMETSAT after C ?-?-2006 only) NESDIS Recursive Filter Function were calculated C ------------------------------------------------------------------- IF(IRET_QFGU.GT.0) THEN C For EUMETSAT (BUFR), during the period from 6-4-2001 through C 3-14-2005, QFGU and not GNAP was used to define whether or not the C EUMETSAT Quality Index was calculated with or without the forecast C (first guess) consistency test - take this into account C {Note: JMA (BUFR) did not exist at this time} C ------------------------------------------------------------------- IF(QFGU(1).LT.BMISS) THEN DO I=1,2 ! assume QFGU(1),(3),(5),(7) are the same ! and QFGU(2),(4),(6),(8) are the same IF(NINT(QFGU(I)).EQ.0) THEN GNAP(I) = 1. ELSE IF(NINT(QFGU(I)).EQ.1) THEN GNAP(I) = 2. ELSE GNAP(I) = BMISS END IF ENDDO END IF END IF IEND = IRET_PCCF/IVARS C Assumption: If IVARS = 4: C If IEND = 2: GNAP(1),(3),(5),(7) are the same C and GNAP(2),(4),(6),(8) are the same C If IEND = 3: GNAP(1),(4),(7),(10) are the same C GNAP(2),(5),(8),(11) are the same C and GNAP(3),(6),(9),(12) are the same C If IVARS = 2: C If IEND = 3: GNAP(1),(4) are the same C GNAP(2),(5) are the same C and GNAP(3),(6) are the same C If IEND = 4: GNAP(1),(4) are the same C GNAP(2),(5) are the same C GNAP(3),(6) are the same C and GNAP(4),(8) are the same DO J = 1,IEND IF(NINT(GNAP(J)).EQ.IQI .OR. IEND.EQ.1) THEN IF(MAX(PCCF(1,(IEND+J)-(IOFF*IEND)), $ PCCF(1,(2*IEND+J)-(IOFF*IEND))).LT.BMISS) $ QI_with = MIN(PCCF(1,(IEND+J)-(IOFF*IEND)), $ PCCF(1,(2*IEND+J)-(IOFF*IEND))) QC_QI_with = MAX(PCCF(2,(IEND+J)-(IOFF*IEND)), $ PCCF(2,(2*IEND+J)-(IOFF*IEND))) ELSE IF(NINT(GNAP(J)).EQ.IQIwo) THEN IF(MAX(PCCF(1,(IEND+J)-(IOFF*IEND)), $ PCCF(1,(2*IEND+J)-(IOFF*IEND))).LT.BMISS) $ QI_without = MIN(PCCF(1,(IEND+J)-(IOFF*IEND)), $ PCCF(1,(2*IEND+J)-(IOFF*IEND))) QC_QI_without = MAX(PCCF(2,(IEND+J)-(IOFF*IEND)), $ PCCF(2,(2*IEND+J)-(IOFF*IEND))) ELSE IF(NINT(GNAP(J)).EQ.IRFF) THEN IF(MAX(PCCF(1,(IEND+J)-(IOFF*IEND)), $ PCCF(1,(2*IEND+J)-(IOFF*IEND))).LT.BMISS) $ RFF = MIN(PCCF(1,(IEND+J)-(IOFF*IEND)), $ PCCF(1,(2*IEND+J)-(IOFF*IEND))) QC_RFF = MAX(PCCF(2,(IEND+J)-(IOFF*IEND)), $ PCCF(2,(2*IEND+J)-(IOFF*IEND))) ELSE IF(NINT(GNAP(J)).EQ.IEE) THEN IF(MAX(PCCF(1,(IEND+J)-(IOFF*IEND)), $ PCCF(1,(2*IEND+J)-(IOFF*IEND))).LT.BMISS) $ EE = MIN(PCCF(1,(IEND+J)-(IOFF*IEND)), $ PCCF(1,(2*IEND+J)-(IOFF*IEND))) QC_EE = MAX(PCCF(2,(IEND+J)-(IOFF*IEND)), $ PCCF(2,(2*IEND+J)-(IOFF*IEND))) END IF ENDDO C EUMETSAT QI with forecast must be > LIMqi % for EUMETSAT/JMA/GOES/ C POES (MODIS, AVHRR or VIIRS), else flag (note: This should be moved C to prepdata) ==> MAY NO LONGER BE NEEDED FOR NETs WHOSE GSI READS C SATWND DUMP DIRECTLY, RATHER THAN GETTING SATWND REPORTS OUT OF C PREPBUFR FILE C -------------------------------------------------------------------- IF(WQM(1).EQ.2.AND.QI_with.LT.BMISS) THEN IF(NINT(QI_with).LE.LIMqi) THEN WQM(1) = 13 PQM(1) = 13 ZQM(1) = 13 TQM(1) = 13 QQM(1) = 13 KFLSAT(INDX) = KFLSAT(INDX) + 1 END IF END IF C Manual/automatic q.c. indicator must be < LIMqc, else flag C (note: This should be moved to prepdata) ==> MAY NO LONGER BE C NEEDED FOR NETs WHOSE GSI READS SATWND DUMP DIRECTLY, RATHER THAN C GETTING SATWND REPORTS OUT OF PREPBUFR FILE C ----------------------------------------------------------------- IF(WQM(1).EQ.2.AND.QC_QI_with.LT.BMISS) THEN IF(NINT(QC_QI_with).GE.LIMqc) THEN WQM(1) = 13 PQM(1) = 13 ZQM(1) = 13 TQM(1) = 13 QQM(1) = 13 KFLSAT(INDX+1) = KFLSAT(INDX+1) + 1 END IF END IF END IF cpppppppppp cc if(wqm(1).lt.13)print'(" SID, QI_with, QC_QI_with = "A, cc $ 2(1X,I0))', sid,nint(QI_with),nint(QC_QI_with) cpppppppppp else if(subset(6:7).GE.'03') then C GOES-16 & up (in subsets NC00503x) store GNAP & PCCF in a standard 4 C replication sequence, not associated with any particular variable C -------------------------------------------------------------------- C ... first make sure originating/generating center is NESDIS (160) C ------------------------------------------------------------- call ufbint(lunit,ufbint_8,1,1,iret,'OGCE');ogce=ufbint_8 if(ogce.eq.160) then call ufbrep(lunit,pccf_8, 2,12,iret_pccf,'GNAP PCCF') pccf = pccf_8 if(iret_pccf.gt.0) then do iii = 1, iret_pccf if(pccf(1,iii).eq.5) then ! Note: Need new Cat. 8 code figure to store this, missing as of 3/28/18 QI_without_common = pccf(2,iii) else if(pccf(1,iii).eq.1) then QI_without = pccf(2,iii) else if(pccf(1,iii).eq.3) then QI_with = pccf(2,iii) else if(pccf(1,iii).eq.4) then EE = pccf(2,iii) else if(pccf(1,iii).eq.2) then RFF = pccf(2,iii) ! not available as of 3/28/18 end if end do end if end if END IF CAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA CAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA C PUT THE UNPACKED REPORT INTO OBS C -------------------------------- RSTP = IMISS CALL S01UBF(SID,XOB,YOB,RHR,RCTIM,RSV1,RSV2,ELV,QMELV,ITP,RTP, $ RSTP,IDS) CALL S02UBF(6,1,*9999) C ------------------------------------------------------------------ C MISC DATA GOES INTO DATA LEVEL CATEGORY 08 C ------------------------------------------------------------------ C CODE FIGURE 355 - PERCENT CONFIDENCE BASED ON NESDIS RECURSIVE C FILTER FUNCTION C -------------------------------------------------------------- CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'RFFL');RFFL=UFBINT_8 IF(RFFL.GE.BMISS) RFFL = RFF ! RFFL missing for all types except ! pre-V10 BUFR NESDIS GOES-15 & down ! winds from server IF(RFFL.LT.BMISS) THEN OB8(1) = NINT(RFFL) CF8(1) = 355 Q81(1) = IMISS Q82(1) = IMISS CALL S02UBF(8,1,*9999) END IF C CODE FIGURE 356 - PERCENT CONFIDENCE BASED ON EUMETSAT QUALITY C INDEX WITH FCST CONSISTENCY TEST C -------------------------------------------------------------- CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'QIFY');QIFY=UFBINT_8 IF(QIFY.GE.BMISS) QIFY = QI_with ! QIFY missing for all types ! except pre-V10 BUFR NESDIS ! GOES-15 & down winds from ! server and possibly MODIS winds ! from server IF(QIFY.LT.BMISS) THEN OB8(1) = NINT(QIFY) CF8(1) = 356 Q81(1) = IMISS Q82(1) = IMISS CALL S02UBF(8,1,*9999) END IF C CODE FIGURE 357 - PERCENT CONFIDENCE BASED ON EUMETSAT QUALITY C INDEX W/O FCST CONSISTENCY TEST C -------------------------------------------------------------- CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'QIFN');QIFN=UFBINT_8 IF(QIFN.GE.BMISS) QIFN = QI_without ! QIFN missing for all types ! except pre-V10 BUFR NESDIS ! GOES-15 & down winds from ! server and possibly MODIS ! winds from server IF(QIFN.LT.BMISS) THEN OB8(1) = NINT(QIFN) CF8(1) = 357 Q81(1) = IMISS Q82(1) = IMISS CALL S02UBF(8,1,*9999) END IF C CODE FIGURE 358 - PERCENT CONFIDENCE BASED ON NESDIS EXPECTED ERROR C ------------------------------------------------------------------- CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'EEQF');EEQF=UFBINT_8 IF(EEQF.GE.BMISS) EEQF = EE ! EEQF missing for all types except ! pre-V10 BUFR NESDIS GOES-15 & down ! winds from server and ossibly MODIS ! winds from server IF(EEQF.LT.BMISS) THEN OB8(1) = NINT(EEQF) CF8(1) = 358 Q81(1) = IMISS Q82(1) = IMISS CALL S02UBF(8,1,*9999) END IF CALL S03UBF(OBS,SUBSET,*9999,*9998,*9997) IF(SUBSET(7:8).LT.'21') THEN C KEEP TRACK OF NESDIS GOES-15 & DOWN SATELLITE WIND COUNTS BY SAT. ID C -------------------------------------------------------------------- IF(IDS.LT.IMISS) THEN IF(IDS.GT.249.AND.IDS.LT.260) THEN KNTSAT(IDS) = KNTSAT(IDS) + 1 ELSE KNTSAT(260) = KNTSAT(260) + 1 END IF END IF END IF if(subset(6:7).eq.'03') then C KEEP TRACK OF NESDIS GOES-16 & UP SATELLITE WIND COUNTS BY SAT. ID C ------------------------------------------------------------------ if(ids.lt.imiss) then if(ids.gt.269.and.ids.lt.274) then knts16(ids) = knts16(ids) + 1 else knts16(274) = knts16(274) + 1 end if end if end if IF(SUBSET(7:8).EQ.'70'.OR.SUBSET(7:8).EQ.'71') THEN C KEEP TRACK OF NASA/MODIS POES SATELLITE WIND COUNTS BY SATELLITE ID C ------------------------------------------------------------------- IF(IDS.LT.IMISS) THEN IF(IDS.GT.782.AND.IDS.LT.785) THEN KNTMODIS(IDS) = KNTMODIS(IDS) + 1 ELSE KNTMODIS(785) = KNTMODIS(785) + 1 END IF END IF END IF IF(SUBSET(7:8).EQ.'80') THEN C KEEP TRACK OF NESDIS/AVHRR POES SATELLITE WIND COUNTS BY SATELLITE ID C --------------------------------------------------------------------- IF(IDS.LT.IMISS) THEN IF((IDS.GT. 2.AND.IDS.LT. 6) .OR. $ (IDS.GT.199.AND.IDS.LT.210) .OR. $ (IDS.EQ.223)) THEN KNTavhrr(IDS) = KNTavhrr(IDS) + 1 ELSE KNTavhrr(224) = KNTavhrr(224) + 1 END IF END IF END IF IF(SUBSET(7:8).EQ.'90') THEN C KEEP TRACK OF NASA/VIIRS POES SATELLITE WIND COUNTS BY SATELLITE ID C ------------------------------------------------------------------- IF(IDS.LT.IMISS) THEN IF(IDS.EQ.224) THEN KNTviirs(IDS) = KNTviirs(IDS) + 1 ELSE KNTviirs(225) = KNTviirs(225) + 1 END IF END IF END IF RETURN 9999 CONTINUE R06UBF = 999 RETURN 9998 CONTINUE print'(" IW3UNPBF/R06UBF: RPT with ID= ",A," TOSSED - ZERO ", $ "CAT.1-6,51 LVLS")', SID 9997 CONTINUE R06UBF = -9999 KSKSAT =KSKSAT + 1 RETURN END C*********************************************************************** C*********************************************************************** C*********************************************************************** FUNCTION R07UBF(LUNIT,OBS,OBS2,OBS3,NOBS3,obs8_8) C ---> PROCESSES REPROCESSED SSM/I (SPSSMI) DATA (012/*) COMMON/IUBFAA/BMISS COMMON/IUBFBB/KNDX,KSKACF(8),KSKUPA,KSKSFC,KSKSAT,KFLSAT(12), $ KSKSMI COMMON/IUBFCC/SUBSET COMMON/IUBFEE/POB(255),QOB(255),TOB(255),ZOB(255),DOB(255), $ SOB(255),VSG(255),OB8(255),CF8(255) COMMON/IUBFLL/Q81(255),Q82(255) CHARACTER*80 HDSTR CHARACTER*8 SUBSET,SID,RSV1,RSV2 REAL(8) RID_8,UFBINT_8,OBS2_8(43),OBS3_8(5,255,7),HDR_8(20), $ PROD_8(2,2),ADDP_8(5),TMBRS_8(2,14),TMBR_8(7),BMISS,AMINIMUM_8, $ obs8_8(2) DIMENSION OBS(*),OBS2(43),OBS3(5,255,7),NOBS3(7),HDR(20), $ PROD(2,2),ADDP(5),TMBRS(2,14),TMBR(7) EQUIVALENCE (RID_8,SID) SAVE DATA HDSTR/'RPID CLON CLAT HOUR MINU SECO NMCT SAID ACAV'/ DATA IMISS/99999/,XMISS/99999./ R07UBF = 0 C STORE SINGLE LEVEL REPORT DATA DIRECTLY INTO OBS2 ARRAY AND C DOUBLE-PRECISION SINGLE LEVEL REPORT DATA DIRECTLY INTO OBS8_8 ARRAY C --------------------------------------------------------------------- OBS2_8 = BMISS obs8_8 = bmiss CALL UFBINT(LUNIT,OBS2_8,2,1,IRET,'RSRD EXPRSRD');OBS2=OBS2_8 CALL S05UBF C PUT THE HEADER INFORMATION INTO UNPACKED FORMAT C ----------------------------------------------- CALL UFBINT(LUNIT,HDR_8,20, 1,IRET,HDSTR);HDR(2:)=HDR_8(2:) IF(HDR(5).GE.BMISS) HDR(5) = 0 IF(HDR(6).GE.BMISS) HDR(6) = 0 obs8_8(1) = hdr_8(3) obs8_8(2) = hdr_8(2) RID_8 = HDR_8(1) XOB = HDR(2) YOB = HDR(3) RHR = BMISS IF(HDR(4).LT.BMISS) RHR = (NINT(HDR(4)) + ((NINT(HDR(5)) * 60.) + cvvvvvdak port cdak $ NINT(HDR(6)))/3600.) + 0.0000000001 ! orig cdak $ NINT(HDR(6)))/3600.) + 0.0001 ! then changed to this caaaaadak port $ NINT(HDR(6)))/3600.) ! don't make this adjustment now that we ! store obs time to 10**5 in PREPBUFR RSV1 = ' ' RSV2 = ' ' C FOR SUPEROBS, THE NUMBER OF ORIGINAL RETRIEVALS THAT WENT INTO C MAKING THE SUPEROB IS STORED IN BYTES 1-3 OF HEADER RESERVE C CHARACTER WORD 1 (FOR NONSUPEROBS THE VALUE HERE IS ALWAYS 1) C -------------------------------------------------------------- IF(HDR(9).LT.BMISS) WRITE(RSV1(1:3),'(I3.3)') NINT(HDR(9)) ITP = IMISS RTP = HDR(7) C CHECK ON VALUE FOR SATELLITE ID TO DETERMINE IF THIS IS A SUPEROB C (SATELLITE ID IS MISSING FOR SUPEROBS) C ----------------------------------------------------------------- ISUPOB = 1 IDS = IMISS IF(HDR(8).LT.BMISS) THEN IDS = NINT(HDR(8)) ISUPOB = 0 END IF RCTIM = BMISS ELV = BMISS QMELV = XMISS IF(RTP.EQ.571.OR.RTP.EQ.65..OR.RTP.EQ.66.OR.RTP.EQ.69) ELV = 0 RSTP = IMISS CALL S01UBF(SID,XOB,YOB,RHR,RCTIM,RSV1,RSV2,ELV,QMELV,ITP,RTP, $ RSTP,IDS) C PUT THE SSM/I DATA INTO SPECIFIED UNPACKED DATA LEVEL CATEGORY 8 FMT C - INDICATOR 1 HOLDS STANDARD DEV. OF VALUE (FOR SUPEROBS) C - INDICATOR 2 HOLDS QUALITY MARKER OF VALUE (RAIN FLAG) (WSDP,TPW) C -------------------------------------------------------------------- IF(RTP.EQ.571) THEN C --------------------------------------------------------------------- C ** OCEAN SURFACE WIND SPEED PRODUCT -- DUMP REPORT TYPE 571 ** C --------------------------------------------------------------------- C CODE FIGURE 196 - OCEANIC WIND SPEED (M/SEC TO 10**1 PRECISION) C --------------------------------------------------------------------- CF8(1) = 196 IF(ISUPOB.EQ.1) THEN CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST WSPD') AMINIMUM_8 = MIN(PROD_8(2,1),PROD_8(2,2)) IF(IBFMS(AMINIMUM_8).NE.0) $ CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST WSOS') PROD=PROD_8 C For SUPEROBs, replication is such that first WSPD/WSOS is always mean C value (FOST=4) and second WSPD/WSOS is always standard deviation C (FOST=10) OB8(1) = PROD(2,1) Q81(1) = PROD(2,2) ELSE CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'WSPD') IF(IBFMS(UFBINT_8).NE.0) $ CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'WSOS') PRODN=UFBINT_8 OB8(1) = PRODN CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'RFLG');RFLG=UFBINT_8 Q82(1) = MIN(NINT(RFLG),IMISS) END IF CALL S02UBF(8,1,*9999) ELSE IF(RTP.EQ.65) THEN C --------------------------------------------------------------------- C ** OCEAN TOTAL PRECIPITABLE WATER PRODUCT -- DUMP REPORT TYPE 65 ** C --------------------------------------------------------------------- C CODE FIGURE 197 - TOTAL PRECIPITABLE WATER (MM TO 10**1 PRECISION) C --------------------------------------------------------------------- CF8(1) = 197 IF(ISUPOB.EQ.1) THEN CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST TPWT') AMINIMUM_8 = MIN(PROD_8(2,1),PROD_8(2,2)) IF(IBFMS(AMINIMUM_8).NE.0) $ CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST PH2O') PROD=PROD_8 C For SUPEROBs, replication is such that first TPWT/PH2O is always mean C value (FOST=4) and second TPWT/PH2O is always standard deviation C (FOST=10) OB8(1) = PROD(2,1) Q81(1) = PROD(2,2) ELSE CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TPWT') IF(IBFMS(UFBINT_8).NE.0) $ CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PH2O') PRODN = UFBINT_8 OB8(1) = PRODN CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'RFLG');RFLG=UFBINT_8 Q82(1) = MIN(NINT(RFLG),IMISS) END IF CALL S02UBF(8,1,*9999) ELSE IF(RTP.EQ.68) THEN C --------------------------------------------------------------------- C ** 7-CHANNEL BRIGHTNESS TEMPERATURES -- DUMP REPORT TYPE 68 ** C --------------------------------------------------------------------- C CODE FIGURE 189 - 19 GHZ V BRIGHTNESS TEMP (DEG K TO 10**2 PRECISION) C CODE FIGURE 190 - 19 GHZ H BRIGHTNESS TEMP (DEG K TO 10**2 PRECISION) C CODE FIGURE 191 - 22 GHZ V BRIGHTNESS TEMP (DEG K TO 10**2 PRECISION) C CODE FIGURE 192 - 37 GHZ V BRIGHTNESS TEMP (DEG K TO 10**2 PRECISION) C CODE FIGURE 193 - 37 GHZ H BRIGHTNESS TEMP (DEG K TO 10**2 PRECISION) C CODE FIGURE 194 - 85 GHZ V BRIGHTNESS TEMP (DEG K TO 10**2 PRECISION) C CODE FIGURE 195 - 85 GHZ H BRIGHTNESS TEMP (DEG K TO 10**2 PRECISION) C --------------------------------------------------------------------- IF(ISUPOB.EQ.1) THEN CALL UFBREP(LUNIT,TMBRS_8,2,14,IRET,'FOST TMBR');TMBRS=TMBRS_8 C For SUPEROBs, replication is such that first TMBR is always mean C value (FOST=4) and second TMBR is always standard deviation (FOST=10) DO NCHN = 1,7 MINDX = (NCHN * 2) - 1 OB8(1) = TMBRS(2,MINDX ) CF8(1) = 188 + NCHN Q81(1) = TMBRS(2,MINDX+1) CALL S02UBF(8,1,*9999) ENDDO ELSE CALL UFBINT(LUNIT,TMBR_8,1,7,NLEV,'TMBR');TMBR=TMBR_8 DO NCHN = 1,7 OB8(1) = NINT(TMBR(NCHN)*100.) CF8(1) = 188 + NCHN CALL S02UBF(8,1,*9999) ENDDO END IF ELSE IF(RTP.EQ.575) THEN C --------------------------------------------------------------------- C ** ADDITIONAL PRODUCTS -- DUMP REPORT TYPE 575 ** C --------------------------------------------------------------------- C CODE FIGURE 210 - SURFACE TAG (RANGE: 0,1,3-6) C CODE FIGURE 211 - ICE CONCENTRATION (PERCENT) C CODE FIGURE 212 - ICE AGE (RANGE: 0,1) C CODE FIGURE 213 - ICE EDGE (RANGE: 0,1) C CODE FIGURE 214 - CALCULATED SURFACE TYPE (RANGE: 1-20) C --------------------------------------------------------------------- CALL UFBINT(LUNIT,ADDP_8,5,1,IRET,'SFTG ICON ICAG ICED SFTP') ADDP = ADDP_8 DO NADD = 1,5 IF(ADDP(NADD).LT.BMISS) THEN OB8(1) = NINT(ADDP(NADD)) CF8(1) = 209 + NADD CALL S02UBF(8,1,*9999) END IF ENDDO ELSE IF(RTP.EQ.66) THEN C --------------------------------------------------------------------- C ** LAND/OCEAN RAINFALL RATE -- REPORT TYPE 66 ** C --------------------------------------------------------------------- C CODE FIGURE 198 - RAINFALL RATE (MM/SEC TO 10**6 PRECISION) C Note: Prior to mid-2001, this was stored using standard descr. C mnemonic REQV (at the standard precision). Then from mid- C 2001 until ~9/2004 it was stored using local descr. mnemonic C REQ6 (at a higher precision). After ~9/2004 it will again C be stored using standard descr. mnemonic REQV, but operator C descriptors in the BUFR table will allow it to be stored C with the same high precision as before. The logic below C allows for all transitions from REQV to REQ6 and then back C again. C --------------------------------------------------------------------- CF8(1) = 198 IF(ISUPOB.EQ.1) THEN CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST REQV') AMINIMUM_8 = MIN(PROD_8(2,1),PROD_8(2,2)) IF(IBFMS(AMINIMUM_8).NE.0) $ CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST REQ6') PROD=PROD_8 C For SUPEROBs, replication is such that first REQV/REQ6 is always mean C value (FOST=4) and second REQV/REQ6 is always standard deviation C (FOST=10) OB8(1) = PROD(2,1) Q81(1) = PROD(2,2) ELSE CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'REQV') IF(IBFMS(UFBINT_8).NE.0) $ CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'REQ6') PRODN=UFBINT_8 OB8(1) = PRODN END IF CALL S02UBF(8,1,*9999) ELSE IF(RTP.EQ.576) THEN C --------------------------------------------------------------------- C ** SURFACE TEMPERATURE -- DUMP REPORT TYPE 576 ** C --------------------------------------------------------------------- C CODE FIGURE 199 - SURFACE TEMP. (DEG. KELVIN TO 10**2 PRECISION) C --------------------------------------------------------------------- CF8(1) = 199 IF(ISUPOB.EQ.1) THEN CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST TMSK');PROD=PROD_8 C For SUPEROBs, replication is such that first TMSK is always mean C value (FOST=4) and second TMSK is always standard deviation (FOST=10) OB8(1) = PROD(2,1) Q81(1) = PROD(2,2) ELSE CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TMSK');PRODN=UFBINT_8 OB8(1) = PRODN END IF CALL S02UBF(8,1,*9999) ELSE IF(RTP.EQ.69) THEN C --------------------------------------------------------------------- C ** OCEAN CLOUD WATER -- DUMP REPORT TYPE 69 ** C --------------------------------------------------------------------- C CODE FIGURE 200 - CLOUD WATER (MM * 100) C --------------------------------------------------------------------- CF8(1) = 200 IF(ISUPOB.EQ.1) THEN CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST CH2O');PROD=PROD_8 C For SUPEROBs, replication is such that first CH2O is always mean C value (FOST=4) and second CH2O is always standard deviation (FOST=10) OB8(1) = NINT(PROD(2,1)*100.) Q81(1) = NINT(PROD(2,2)*100.) ELSE CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'CH2O');PRODN=UFBINT_8 OB8(1) = NINT(PRODN*100.) END IF CALL S02UBF(8,1,*9999) ELSE IF(RTP.EQ.573) THEN C --------------------------------------------------------------------- C ** SOIL MOISTURE -- DUMP REPORT TYPE 573 ** C --------------------------------------------------------------------- C CODE FIGURE 201 - SOIL MOISTURE (MM) C --------------------------------------------------------------------- CF8(1) = 201 IF(ISUPOB.EQ.1) THEN CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST SMOI');PROD=PROD_8 C For SUPEROBs, replication is such that first SMOI is always mean C value (FOST=4) and second SMOI is always standard deviation (FOST=10) OB8(1) = NINT(PROD(2,1)*1000.) Q81(1) = NINT(PROD(2,2)*1000.) ELSE CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SMOI');PRODN=UFBINT_8 OB8(1) = NINT(PRODN*1000.) END IF CALL S02UBF(8,1,*9999) ELSE IF(RTP.EQ.574) THEN C --------------------------------------------------------------------- C ** SNOW DEPTH -- DUMP REPORT TYPE 574 ** C --------------------------------------------------------------------- C CODE FIGURE 202 - SNOW DEPTH (MM) C --------------------------------------------------------------------- CF8(1) = 202 IF(ISUPOB.EQ.1) THEN CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST TOSD') AMINIMUM_8 = MIN(PROD_8(2,1),PROD_8(2,2)) IF(IBFMS(AMINIMUM_8).NE.0) $ CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST SNDP') PROD=PROD_8 C For SUPEROBs, replication is such that first TOSD/SNDP is always mean C value (FOST=4) and second TOSD/SNDP is always standard deviation C (FOST=10) OB8(1) = NINT(PROD(2,1)*1000.) Q81(1) = NINT(PROD(2,2)*1000.) ELSE CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TOSD') IF(IBFMS(UFBINT_8).NE.0) $ CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SNDP') PRODN=UFBINT_8 OB8(1) = NINT(PRODN*1000.) END IF CALL S02UBF(8,1,*9999) ELSE IF(RTP.EQ.577) THEN C --------------------------------------------------------------------- C ** SEA-SURFACE TEMPERATURE -- DUMP REPORT TYPE 577 ** C --------------------------------------------------------------------- C CODE FIGURE 203 - SEA-SURFACE TEMP. (DEG. KELVIN TO 10**2 PRECISION) C --------------------------------------------------------------------- CF8(1) = 203 IF(ISUPOB.EQ.1) THEN CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST SST1');PROD=PROD_8 C For SUPEROBs, replication is such that first SST1 is always mean C value (FOST=4) and second SST1 is always standard deviation (FOST=10) OB8(1) = PROD(2,1) Q81(1) = PROD(2,2) ELSE CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SST1');PRODN=UFBINT_8 OB8(1) = PRODN END IF CALL S02UBF(8,1,*9999) END IF C PUT THE UNPACKED REPORT INTO OBS C -------------------------------- CALL S03UBF(OBS,SUBSET,*9999,*9998,*9997) RETURN 9999 CONTINUE R07UBF = 999 RETURN 9998 CONTINUE print'(" IW3UNPBF/R07UBF: RPT with ID= ",A," TOSSED - ZERO ", $ "CAT.1-6,8,51 LVLS")', SID 9997 CONTINUE R07UBF = -9999 KSKSMI = KSKSMI + 1 RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: I05UBF FINDS LOCATION OF NEXT NUMERIC C PRGMMR: RAY CRAYTON ORG: W/NMC41 DATE: 1989-07-07 C C ABSTRACT: FINDS THE LOCATION OF THE NEXT NUMERIC CHARACTER C IN A STRING OF CHARACTERS. C C PROGRAM HISTORY LOG: C 1989-07-07 RAY CRAYTON C C USAGE: LOC=I05UBF(STRING,NUM,CHAR) C INPUT ARGUMENT LIST: C STRING - CHARACTER ARRAY. C NUM - NUMBER OF CHARACTERS TO SEARCH IN STRING. C C OUTPUT ARGUMENT LIST: C I05UBF - INTEGER*4 LOCATION OF ALPHANUMERIC CHARACTER. C = 0 IF NOT FOUND. C CHAR - CHARACTER FOUND. C C REMARKS: NONE C C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ FUNCTION I05UBF(STRING,NUM,CHAR) CHARACTER*1 STRING(1),CHAR SAVE DO I = 1,NUM IF(STRING(I).GE.'0'.AND.STRING(I).LE.'9') THEN I05UBF = I CHAR = STRING(I) GO TO 200 END IF ENDDO I05UBF = 0 CHAR = '?' 200 CONTINUE RETURN END