C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: GBLEVENTS PRE/POST PROCESSING OF PREPBUFR EVENTS C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2013-02-13 C C ABSTRACT: RUNS IN TWO MODES: "PREVENTS" AND "POSTEVENTS". IN THE C PREVENTS MODE, PREPARES OBSERVATIONAL PREPBUFR REPORTS FOR C SUBSEQUENT QUALITY CONTROL AND ANALYSIS PROGRAMS. THIS IS DONE C THROUGH THE FOLLOWING: INTERPOLATION OF GLOBAL SPECTRAL SIMGA C FIRST GUESS TO PREPBUFR OBSERVATION LOCATIONS WITH ENCODING OF C FIRST GUESS VALUES INTO PREPBUFR REPORTS; ENCODING OF "PREVENT" C AND/OR "VIRTMP" EVENTS INTO PREPBUFR REPORTS; AND ENCODING OF C OBSERVATION ERRORS FROM THE ERROR SPECIFICATION FILE INTO C PREPBUFR REPORTS. IN THE POSTEVENTS MODE, AFTER ALL QUALITY C CONTROL AND ANALYSIS PROGRAMS HAVE RUN, INTERPOLATES THE GLOBAL C SPECTRAL SIMGA ANALYSIS TO PREPBUFR OBSERVATION LOCATIONS AND C ENCODES THESE ANALYZED VALUES INTO PREPBUFR REPORTS. THE C REMAINDER OF THIS ABSTRACT APPLIES ONLY TO THE PREVENTS MODE. C THE "PREVENT" EVENT CAN CHANGE A QUALITY MARKER TO FLAG AN C OBSERVATION DATUM FOR NON-USE BY SUBSEQUENT QC AND ANALYSIS C PROGRAMS (FILTERING). EXAMPLES WHERE THIS SUBROUTINE WILL WRITE C AN EVENT TO FLAG A DATUM INCLUDE: THE OBSERVATION ERROR FOR THAT C DATUM IS READ IN AS MISSING IN THE INPUT ERROR FILE, THE DATUM C ITSELF VIOLATES A GROSS OR "SANITY" CHECK, OR THE OBSERVED C PRESSURE DATUM IS MORE THAN 100 MB BELOW THE GUESS SURFACE C PRESSURE. THE "VIRTMP" EVENT CAN CHANGE THE SPECIFIC HUMIDITY C OBSERVATION (RE-CALCULATED) AS WELL AS THE TEMPERATURE C OBSERVATION (FROM SENSIBLE TO VIRTUAL TEMPERATURE, BASED ON C JUST-CALCULATED SPECIFIC HUMIDITY). CURRENTLY THIS APPLIES ONLY C TO SURFACE (LAND, MARINE AND MESONET) DATA TYPES, POSSIBLY TO C RAOB, DROP AND MULTI-LEVEL RECCO DAA TYPES IF THE SWITCH C "ADPUPA_VIRT" IS TRUE (NORMALLY, HOWEVER IT IS FALSE) [OTHER DATA C TYPES WITH REPORTED SENSIBLE TEMPERATURE EITHER HAVE MISSING C MOISTURE (E.G., ALL AIRCRAFT TYPES EXCEPT FOR SOME ACARS, SATELLITE C WIND TYPES), FLAGGED MOISTURE (E.G., SOME ACARS) OR CALCULATE C SPECIFIC HUMIDITY/VIRTUAL TEMPERATURE IN SUBSEQUENT PROGRAMS (E.G., C RAOBS, DROPS AND MULTI-LEVEL RECCOS WHICH CALCULATE THESE IN C PROGRAM "CQCBUFR", IN WHICH CASE THE SWITCH "ADPUPA_VIRT" HERE MUST C BE FALSE!)]. FOR CASES WHERE THE SWITCH "DOBERR" IS FALSE, THE C OBSERVATION ERROR FOR ALL DATA REMAINS MISSING IN THE PREPBUFR C FILE. IN THIS CASE, THE INPUT ERROR FILE IS USUALLY A NULL FILE C AND THE "PREVENT" EVENT TO FLAG THE DATUM IS NOT INVOKED. FOR C CASES WHERE THE SWITCH "DOFCST" IS FALSE, IF THE SWITCH "SOME_FCST" C IS ALSO FALSE, THEN FORECAST VALUES ARE NOT ENCODED FOR ANY MESSAGE C TYPE; IF "SOME_FCST" IS TRUE THEN FORECAST VALUES ARE ENCODED, BUT C ONLY FOR REPORTS IN THOSE MESSAGE TYPES FOR WHICH A GUESS VALUE IS C NEEDED BY SUBSEQUENT QC PROGRAMS. IT SHOULD BE NOTED THAT THE C FILTERING OF DATA ASSOCIATED WITH THE "PREVENT" EVENT PROCESSING IS C NOT INVOKED IF ALL THREE ARE TRUE: DOBERR= FALSE, THE FORECAST C VALUES ARE MISSING (DOFCST=FALSE & SOME_FCST=TRUE & MESSAGE TYPE IS C NOT "ADPUPA", "AIRCFT", "AIRCAR", "PROFLR", OR "VADWND" -- OR -- C DOFCST=FALSE & SOME_FCST=FALSE), AND "VIRTMP" EVENT PROCESSING IS C NOT INVOKED (EITHER MESSAGE TYPE IS NOT "ADPSFC", "SFCSHP" OR C "MSONET" WHEN "ADPUPA_VIRT" IS FALSE, OR MESSAGE TYPE IS NOT C "ADPSFC", "SFCSHP", "MSONET" OR "ADPUPA" WHEN "ADPUPA_VIRT" IS C TRUE). C C PROGRAM HISTORY LOG: C 1999-07-01 D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM PREVENTS C SUBROUTINE IN PREPDATA PROGRAM, BUT NOW GENERALIZED FOR C POSTEVENTS MODE) C 1999-07-12 D. A. KEYSER -- MODIFIED TO INTERPOLATE MODEL SPECIFIC C HUMIDITY TO OBSERVATION LOCATION WHEN OBS. SPECIFIC HUMIDITY IS C MISSING AS LONG AS OBS. TEMPERATURE IS NON-MISSING C 1999-09-09 D. A. KEYSER -- ADDED "VADWND" TO THE LIST OF MESSAGE C TYPES FOR WHICH FORECAST VALUES MUST BE ENCODED, EVEN WHEN C DOFCST=FALSE (NECESSARY BECAUSE THE NEW PROGRAM CQCVAD NEEDS THE C BACKGROUND DATA) C 1999-09-09 D. A. KEYSER -- CHANGES TO MAKE CODE MORE PORTABLE; C 'TFC' NOW GENERATED FOR VADWND MESSAGE TYPES EVEN THOUGH TOB IS C MISSING (NEEDED BY CQCVAD PROGRAM) C 1999-12-01 D. A. KEYSER -- SPEC. HUMIDITY AND VIRT. TEMPERATURE ARE C NOW CALCULATED WHEN SPEC. HUMIDITY QUAL. MARKER IS BAD (SUBJECT C TO A SANITY CHECK), HOWEVER THE VIRT. TEMPERATURE GETS A BAD C QUAL. MARKER (8) C 2000-09-21 D. A. KEYSER -- THE PRESSURE LEVEL ABOVE WHICH ALL SPEC. C HUMIDITY QUAL. MARKERS ARE "REJECTED" (Q.M. SET TO 9) IS NOW READ C IN AS A N-LIST SWITCH (QTOP_REJ), BEFORE IT WAS HARDWIRED TO 300 C MB C 2000-12-13 D. A. KEYSER -- WILL NO LONGER PERFORM VIRTUAL TEMPERATURE C PROCESSING FOR ACARS DATA SINCE MOISTURE IS FLAGGED RIGHT NOW C (ACARS MOISTURE ONLY WRITTEN INTO PREPBUFR FILE FOR STATISTICAL C REASONS) C 2001-02-02 D. A. KEYSER -- RESTORED LEGACY LOGIC TO FLAG CERTAIN C SATELLITE TEMPERATURE SOUNDINGS EITHER BELOW 100 MB (TEMP. OBS) C OR ON ALL LEVELS (SPEC. HUM. OBS), CONTROLLED BY NEW NAMELIST C SWITCH "SATMQC" C 2001-09-27 D. A. KEYSER -- 'TFC' AND 'QFC' NOW GENERATED FOR REPORT C TYPE 111 (SYNDAT REPORTS AT STORM CENTER) EVEN THOUGH "TOB" AND C "QOB" ARE MISSING (NEEDED BY SYNDATA PROGRAM); IN PREPARATION FOR C CHANGE FROM T170L42 TO T254L64 SGES, NOW MAKES COEFFICIENT ARRAYS C ALLOCATABLE TO ALLOW THEM TO OBTAIN MEMORY FROM "HEAP" RATHER C THAN FROM "STACK", ALSO HAVE INCREASED THE MAX NUMBER OF LEVELS C IN ARRAYS FROM 42 TO 64, FINALLY ALSO NO LONGER STOPS WITH C. C CODE 70 IF EVEN NUMBER OF LONGITUDES IN SIGMA GUESS (IMAX, C HARDWIRED TO 384) IS .LT. SPECTRAL RESOLUTION (JCAP) * 2 C 2001-10-10 D. A. KEYSER -- AT PREPBUFR CENTER DATES WITH AN HOUR THAT C IS NOT A MULTIPLE OF 3 (WHEN A GLOBAL SIGMA GUESS/ANAL FILE IS C NOT AVAILABLE; E.G., IN RUC2A RUNS) NOW PERFORMS A LINEAR C INTERPOLATION BETWEEN SPECTRAL COEFFICIENTS IN 2 SPANNING SIGMA C GUESS/ANAL FILES 3-HRS APART TO CENERATE A GUESS/ANAL FILE VALID C AT THE PREPBUFR CENTER TIME C 2002-05-10 D. A. KEYSER -- ADDED "AIRCAR" TO THE LIST OF TABLE A C MESSAGE TYPES THAT WILL STILL HAVE THE BACKGROUND ENCODED WHEN C DOFCST IS FALSE (BECAUSE ACARS ARE NOW Q.C.'d IN PREPOBS_ACARSQC C PROGRAM) C 2003-09-02 D. A. KEYSER -- ADDED "MSONET" TO THE LIST OF TABLE A C MESSAGE TYPES THAT WILL HAVE THE VIRTUAL TEMPERATURE CALCULATED; C DOES NOT CALL UFBINT FOR OUTPUTTING DATA IF "NLEV" (4'TH C ARGUMENT) IS ZERO (NOW CAN ONLY HAPPEN FOR GOESND FORECAST DATA C WHEN ONLY RADIANCES ARE PRESENT) C 2004-08-30 D. A. KEYSER -- NOW INCLUDES THE 4 LAYER PWATERS, THESE C GET AN OBS. ERROR (EACH THE SAME AS TOTAL PWATER) AND AN EVENT C IS GENERATED WITH A REJECTED Q.M. FOR THE 4 LAYER PWATERS IF THE C PWATER OBS. ERROR READ IN IS MISSING (THIS CHANGE ALLOWS THE ETA/ C GSI TO PROCESS OBS. ERRORS IN THE PREPBUFR FILE THE SAME AS THE C ETA/3DVAR DID WHEN READING THE OBS. ERRORS FROM AN EXTERNAL C FILE); FOR "RASSDA" TYPES, ENCODES A SIMPLE COPY OF THE REPORTED C (VIRTUAL) TEMPERATURE AS A "VIRTMP" EVENT IF DOVTMP IS TRUE, GETS C NEW REASON CODE 3 C 2004-09-10 D. T. KLEIST -- ADDED CAPABILITY TO READ GUESS FIELDS FROM C EITHER HYBRID OR, AS BEFORE, SIGMA GLOBAL FORECAST FILES C 2005-01-03 D. A. KEYSER -- FIXED ERROR READING CDAS SGES FILE WHICH C STILL HAS A 207-WORD HEADER (T62) {2004-09-10 CHANGE ASSUMED ALL C SGES FILES HAD A 226-WORD HEADER (T254), BUT THIS IS VALID ONLY C FOR GFS SGES) C 2006-05-05 R. E. TREADON -- CHANGE VERTICAL INTERPOLATION TO DIRECTLY C USE PRESSURE PROFILE, NOT PRESSURE PROFILE CONVERTED TO SIGMA. C THIS CHANGE IS IN SUBROUTINE GBLEVN03. AS A RESULT OF THIS C CHANGE, SUBROUTINE GBLEVN07 WAS REMOVED. C 2006-07-14 D. A. KEYSER -- ADDED NEW NAMELIST SWITCH "SOME_FCST" C WHICH APPLIES ONLY WHEN EXISTING SWITCH "DOFCST" IS FALSE: IF C DOFCST=F AND SOME_FCST=T THEN, JUST AS BEFORE WHEN DOFCST=F, A C FORECAST WILL STILL BE ENCODED FOR REPORTS IN CERTAIN MESSAGE C TYPES USED IN SUBSEQUENT Q.C. PROGRAMS (I.E, "ADPUPA", "AIRCFT", C "AIRCAR", "PROFLR" OR "VADWND") (THE DEFAULT FOR SOME_FCST IS C TRUE); HOWEVER IF DOFCST=F AND SOME_FCST=F THEN A FORECAST WILL C NOT BE ENCODED INTO REPORTS IN ANY MESSAGE TYPE (THIS ALLOWS C THIS PROGRAM TO ENCODE OBS ERRORS AND/OR VIRTUAL TEMPERATURE C EVENTS INTO A PREPBUFR FILE WITHOUT ENCODING A FORECAST); ADDED C NEW NAMELIST SWITCH "ADPUPA_VIRT" WHICH, WHEN TRUE, INCLUDES C REPORTS IN MESSAGE TYPE ADPUPA (I.E., RAOBS, DROPS, MULTI-LEVEL C RECCOS) IN THE "VIRTMP" PROCESSING (PROCESSING THEM WITH SAME C LOGIC AS IN SUBROUTINE VTPEVN OF PROGRAM PREPOBS_CQCBUFR) C {NORMALLY "ADPUPA_VIRT" IS FALSE (DEFAULT) BECAUSE SUBSEQUENT C PROGRAM PREPOBS_CQCBUFR PERFORMS THIS FUNCTION} C 2007-09-14 S. MOORTHI -- ADDED CAPABILITY TO READ GENERALIZED SIGMA/ C HYBRID FILES FROM THE GFS USING "SIGIO" UTILITY; ALSO, CLEANED UP C SOME CODE; NEW ERROR CONDITION CODES 70 AND 71 ADDED C 2007-09-14 D. A. KEYSER -- FUNCTION OEFG01, WHICH RETURNS THE OBS C ERROR FOR A REQUESTED VARIABLE INTERP. TO A DEFINED PRESSURE C LEVEL FOR A DEFINED REPORT TYPE, MODIFIED TO USE EXACT LOGIC AS C IN GSI (MINIMUM LIMITING VALUE FOR OBS ERROR BASED ON VARIABLE C TYPE, LEVEL PRESSURE LIMITED TO MAX OF 2000 MB AND MIN OF ZERO C MB, A FEW OTHER MINOR CHANGES) - THIS WILL ALLOW GSI TO READ OBS C ERROR DIRECTLY OUT OF PREPBUFR FILE RATHER THAN OUT OF AN C EXTERNAL FILE; FOR PW TYPES, NOW PASSES REPORTED SURFACE PRESSURE C (PRSS * 0.01) INTO FUNCTION OEFG01 RATHER THAN VERTICAL C COORDINATE PRESSURE (POB), SINCE LATTER IS ALWAYS MISSING FOR C THESE TYPES (DOESN'T CHANGE VALUE COMING OUT OF OEFG01 SINCE IT C IS CONSTANT ON ALL LEVELS ANYWAY FOR PW); IN SUBR. GBLEVN02, Q.M. C 9 IS NOW ASSIGNED TO A VARIABLE ONLY IF ITS OBS ERROR IS MISSING, C OR IN THE CASE OF MOISTURE IF THE LEVEL IS ABOVE PRESSURE LEVEL C "QTOP_REJ" OR IF ITS TEMPERATURE OBS ERROR IS MISSING, ALL OTHER C EVENT (E.G., GROSS CHECK ERRORS) ASSIGN Q.M. 8 (EVEN IF OBS ERROR C IS MISSING), PRIOR TO THIS ONLY REJECTION OF PRESSURE ON LEVEL C RESULTED IN Q.M. 8, ALL OTHER REJECTIONS GOT Q.M. 9 - THIS MEANS C TRULY "BAD" OBS WILL NOW ALWAYS GET Q.M. 8 AND ONLY OBS FLAGGED C FOR NON-USE BY ASSIMILATION (BUT STILL "GOOD") WILL NOW GET Q.M. C 9 (GSI MONITORS, BUT DOES NOT USE, OBS WITH Q.M. 9, BUT IT DOES C NOT EVEN CONSIDER OBS WITH Q.M. 8); CORRECTED ERROR WHICH C MISTAKENLY ASSIGNED REASON CODE OF 9 INSTEAD OF 3 TO MOISTURE C WITH MISSING OBS ERROR; IN SUBR. GBLEVN02, Q.M. 9 WILL NOT BE C ASSIGNED TO A VARIABLE IF THAT VARIABLE ALREADY HAS A "BAD" Q.M. C (I.E., > 3 BUT < 15), IN FACT THE "PREVENT" EVENT WHICH WOULD C ASSIGN Q.M. 9 IS SKIPPED ENTIRELY (DO NOT WANT THE GSI TO MONITOR C THE OBS WHICH REALLY ARE ARE "BAD"); IN SUBR. GBLEVN08, FOR NON- C "ADPUPA" TYPES, Q.M. 9 IS NOW ASSIGNED TO CALCULATED VIRT. TEMPS C IF THE MOISTURE Q.M. IS 9 OR 15 AND ORIG. TEMP NOT "BAD", THESE C "VIRTMP" EVENTS RECEIVE NEW REASON CODE 4, HAD RECEIVED Q.M. 8 C WITH REASON CODE 2 LIKE VIRT. TEMPS CALCULATED FROM "BAD" C MOISTURE - THIS MEANS ONLY TRULY "BAD" VIRT. TEMPS WILL NOW GET C Q.M. 8 AND VIRT. TEMPS FLAGGED FOR NON-USE BY ASSIMILATION (BUT C STILL "GOOD") WILL NOW GET Q.M. 9 (GSI MONITORS, BUT DOES NOT C USE, OBS WITH Q.M. 9, BUT IT DOES NOT EVEN CONSIDER OBS WITH Q.M. C 8); IN SUBR. GBLEVN08, FOR "ADPUPA" TYPES, Q.M. 3 IS NOW ASSIGNED C TO CALCULATED VIRT. TEMPS ONLY IF THE MOISTURE Q.M. IS TRULY BAD C (I.E. > 3 BUT NOT 9 OR 15) (AND, AS BEFORE, ORIG. TQM IS 1 OR 2 C AND POB IS BELOW 700 MB) - BEFORE, TQM SET TO 3 WHEN QQM WAS 9 OR C 15 AND ALL OTHER CONDITIONS MET; FOR "SATEMP" TYPES, ENCODES A C SIMPLE COPY OF THE REPORTED (VIRTUAL) TEMPERATURE AS A "VIRTMP" C EVENT IF DOVTMP IS TRUE, GETS REASON CODE 3 (SIMILAR TO WHAT IS C ALREADY DONE FOR "RASSDA" TYPES) C 2010-01-29 D. A. KEYSER -- ADDED NEW NAMELIST SWITCH "RECALC_Q" C WHICH APPLIES ONLY WHEN EXISTING SWITCH "DOVTMP" IS FALSE: IF C DOVTMP=F AND RECALC_Q=T THEN, JUST AS BEFORE WHEN DOVTMP=F, SPEC. C HUMIDITY IS STILL RE-CALCULATED AND THE EVENT IS ENCODED INTO THE C PREPBUFR FILE (BUT VIRTUAL TEMP. IS NOT ENCODED) (THE DEFAULT FOR C RECALC_Q IS TRUE), HOWEVER IF DOVTMP=F AND RECALC_Q=F THEN SPEC. C HUMIDITY IS NOT RE-CALCULATED (AND NEITHER IS VIRTUAL C TEMPERATURE) (THIS ALLOWS THIS PROGRAM TO BYPASS ALL "VIRTMP" C EVENT PROCESSING); ADDED NEW NAMELIST SWITCH "DOPREV" WHICH, C WHEN TRUE, WRITES "PREVENT" EVENTS INTO THE PREPBUFR FILE (IT C ALWAYS DID THIS BEFORE) (DEFAULT), BUT NOW ALLOWS THE PROGRAM C TO BYPASS "PREVENT" EVENT PROCESSING WHEN DOPREV=F; INITIALIZED C ARRAY IDATE AS ZERO IN SUBR. GBLEVN10, CORRECTED BUG WHICH C EXPOSED PREVIOUSLY HIDDEN MEMORY CLOBBERING WHEN CALLING PROGRAMS C WERE LINKED TO NEW BUFRLIB; RULES IN SUBROUTINE GBLEVN02 REFINED C TO INCLUDE FULL SFC PRESSURE SANITY CHECK FOR ALL SFC REPORTS C (MASS, 18x, & WIND, 28x), BEFORE ONLY DONE FOR SFC MASS REPORTS C (18x) AND STILL NOT DONE FOR NON-SFC WIND REPORTS SINCE LOWEST C LEVEL PRESSURE NOT NECESSARILY AT THE SFC), AS A RESULT 28x WINDS C WILL NOW GET QM=8 IF PRESSURE FAILS SANITY CHECK (OFTEN HAPPENS C IN MESONET REPORTS) (GSI WAS ALREADY NOT USING THESE WINDS SINCE C PRESSURE QM SET TO 8 ALL ALONG) C 2012-11-20 J. WOOLLEN INITIAL PORT TO WCOSS. ADDED CALL TO BUFRLIB C ROUTINE GETBMISS TO ADAPT BMISS TO LINUX ENVIRONMENT IF NEED BE C {I.E., OBTAINS BUFRLIB MISSING (BMISS) VIA CALL TO GETBMISS C RATHER THAN HARDWIRING IT TO 10E10 (10E10 CAN CAUSE INTEGER C OVERFLOW ON WCOSS - SEE CALLING PROGRAM FOR MORE INFO)} C 2013-02-13 D. A. KEYSER -- FINAL CHANGES TO RUN ON WCOSS: USE C FORMATTED PRINT STATEMENTS WHERE PREVIOUSLY UNFORMATTED PRINT WAS C > 80 CHARACTERS; RENAME ALL REAL(8) VARIABLES AS *_8 C C USAGE: CALL GBLEVENTS(IDATEP,IUNITF,IUNITE,IUNITP,IUNITS,SUBSET, C $ NEWTYP) C INPUT ARGUMENT LIST: C IDATEP - CENTER DATE FOR PREPBUFR FILE IN THE FORM YYYYMMDDHH C IUNITF - 2-WORD ARRAY: C - WORD 1 - UNIT NUMBER OF FIRST INPUT SPECTRAL (GLOBAL) C - SIGMA OR HYBRID FILE (EITHER FIRST GUESS OR ANALYSIS); C - IF HH IN IDATEP IS A MULTIPLE OF 3 THEN THIS FILE IS C - VALID AT THE DATE IN IDATEP, IF HH IN IDATEP IS NOT A C - MULTIPLE OF 3 THEN THIS FILE IS VALID AT THE CLOSEST C - TIME PRIOR TO THE DATE IN IDATEP THAT IS A MULTIPLE C - OF 3 C - WORD 2 - UNIT NUMBER OF SECOND INPUT SPECTRAL (GLOBAL) C - SIGMA OR HYBRID FILE (EITHER FIRST GUESS OR ANALYSIS); C - IF HH IN IDATEP IS A MULTIPLE OF 3 THEN THIS FILE IS C - EMPTY, IF HH IN IDATEP IS NOT A MULTIPLE OF 3 THEN C - THIS FILE IS VALID AT THE CLOSEST TIME AFTER THE DATE C - IN IDATEP THAT IS A MULTIPLE OF 3 C IUNITE - UNIT NUMBER OF INPUT OBSERVATION ERROR FILE C - (USED ONLY IN PREVENTS MODE) C IUNITP - UNIT NUMBER OF OUTPUT PREPBUFR DATA SET C IUNITS - UNIT NUMBER OF "PREVENT" EVENTS DATA FILTERING C - SUMMARY PRINT FILE C - (USED ONLY IN PREVENTS MODE) C SUBSET - THE BUFR MESSAGE TABLE A ENTRY FOR THE PARTICULAR C - REPORT BEING PROCESSED C NEWTYP - INDICATOR IF THE BUFR MESSAGE TABLE A ENTRY HAS C - CHANGED FROM THAT OF THE PREVIOUS REPORT (=0 - NO, C - =1 - YES) C C C INPUT FILES: C UNIT 05 - STANDARD INPUT (DATA CARDS - SEE NAMELIST C DOCUMENTATION BELOW) C (NOTE: IF STANDARD INPUT FILE IS NULL, THEN THIS C SUBROUTINE RUNS IN POSTEVENTS MODE) C UNIT AA - PREPBUFR DATA SET C - (WHERE AA IS UNIT NUMBER DEFINED AS IUNITP IN C - INPUT ARGUMENT LIST) C UNIT BB - SPECTRAL (GLOBAL) SIGMA OR HYBRID GUESS (PREVENTS C - MODE) OR ANALYSIS (POSTEVENTS MODE) FILE C - (WHERE BB IS UNIT NUMBER DEFINED AS IUNITF(1) IN C - INPUT ARGUMENT LIST) C UNIT CC - SPECTRAL (GLOBAL) SIGMA OR HYBRID GUESS (PREVENTS C - MODE) OR ANALYSIS (POSTEVENTS MODE) FILE C - (WHERE CC IS UNIT NUMBER DEFINED AS IUNITF(2) IN C - INPUT ARGUMENT LIST) C UNIT DD - OBSERVATION ERROR FILE (WHERE DD IS UNIT NUMBER C - DEFINED AS IUNITE IN INPUT ARGUMENT LIST) C - (USED ONLY IN PREVENTS MODE) C C OUTPUT FILES: C UNIT 06 - STANDARD OUTPUT PRINT C UNIT AA - PREPBUFR DATA SET C - (WHERE AA IS UNIT NUMBER DEFINED AS IUNITP IN C - INPUT ARGUMENT LIST) C UNIT DD - "PREVENT" EVENTS DATA FILTERING SUMMARY PRINT FILE C - (WHERE DD IS UNIT NUMBER DEFINED AS IUNITS IN C - INPUT ARGUMENT LIST) C - (USED ONLY IN PREVENTS MODE) C C SUBPROGRAMS CALLED: C UNIQUE: GBLEVN02 GBLEVN03 GBLEVN04 C GBLEVN06 OEFG01 C GBLEVN08 GBLEVN10 GBLEVN11 C MODULE: GBLEVN_MODULE C LIBRARY: C SPLIB - SPTEZM SPTEZMV C W3NCO - W3MOVDAT ERREXIT C BUFRLIB - UFBINT UFBQCD GETBMISS C C EXIT STATES: C COND = 0 - SUCCESSFUL RUN C COND = 60 - OBSERVATION ERROR TABLE EMPTY OR DOES NOT EXIST C COND = 61 - VARIABLE NLTD .NE. VARIABLE NLEV C COND = 62 - VARIABLE NLTQ .NE. VARIABLE NLEV C COND = 63 - VARIABLE NLQQ .NE. VARIABLE NLEV C COND = 68 - DATE OF FIRST GUESS/ANALYSIS FILE(S) DOES NOT MATCH, C - OR AT LEAST SPAN, THE CENTER DATE FOR THE PREPBUFR C - FILE C COND = 69 - VARIABLE KMAX TOO BIG - UNABLE TO TRANSFORM FIRST C - GUESS OR ANALYSIS FILE(S) C COND = 70 - CALL TO SIGIO_RROPEN RETURNED WITH NON-ZERO R.C. C COND = 71 - CALL TO SIGIO_RRHEAD RETURNED WITH NON-ZERO R.C. C C C REMARKS: THIS SUBROUTINE MAY NOT WORK CORRECTLY IN THE EIGHT BYTE C INTEGER W3NCO (_8) LIBRARY. PLEASE COMPILE APPLICATION CODE C USING A FOUR BYTE REAL W3NCO LIBRARY (_4 OR _d). C C THIS ROUTINE PROCESSES ONE REPORT AT A TIME. IT EXPECTS THAT THE C CALLING PROGRAM HAS ALREADY ENCODED THE REPORT INTO THE PREPBUFR C FILE VIA THE UFBINT OR UFBCPY ROUTINES. THE CALLING PROGRAM C SHOULD THEN CALL THIS ROUTINE AND, UPON ITS RETURN, THE CALLING C PROGRAM SHOULD CALL WRITSB TO ACTUALLY WRITE THE UPDATED SUBSET C (REPORT) INTO THE BUFR MESSAGE. CC C ***** VARIABLES IN NAMELIST PREVDATA READ IN BY THIS SUBROUTINE ***** C (NOTE: IF STANDARD INPUT FILE IS NULL, THEN THIS C SUBROUTINE RUNS IN POSTEVENTS MODE - DOANLS=TRUE C AND ALL OTHER VARIABLES ARE SET TO FALSE) CC CC C DOPREV - WRITE "PREVENT" EVENT INTO THE PREPBUFR FILE? C DOPREV = .TRUE. ---> YES (DEFAULT) C DOPREV = .FALSE. ---> NO C DOVTMP, ADPUPA_VIRT & RECALC_Q: C DOVTMP - WRITE VIRTUAL TEMPERATURE EVENT ("VIRTMP") INTO THE C PREPBUFR FILE (I.E., RE-CALCULATE SPECIFIC HUMIDITY C THEN CALCULATE VIRTUAL TEMPERATURE) FOR THE FOLLOWING C TYPES OF REPORTS: C ADPUPA_VIRT = .FALSE. ---> SURFACE LAND, MARINE, C MESONET AND RASS REPORTS? C ADPUPA_VIRT = .TRUE. ---> SURFACE LAND, MARINE, C MESONET RASS, RAOB, DROP C AND MULTI-LEVEL RECCO C REPORTS? C FOR ALL TYPES EXCEPT RASS, THIS WILL ATTEMPT TO C CALCULATE VIRTUAL TEMPERATURE FROM SENSIBLE TEMPERATURE C AND THE JUST RE-CALCULATED SPECIFIC HUMIDITY AND ENCODE C IT AS A STACKED EVENT IN THE PREPBUFR FILE. FOR RASS C REPORTS THIS WILL JUST ENCODE THE REPORTED TEMPERATURE C AS A STACKED EVENT IN THE PREPBUFR FILE SINCE THE C REPORTED TEMPERATURE IS ALREADY VIRTUAL (NO MOISTURE IS C PRESENT SO Q IS NOT RE-CALCULATED FOR RASS REPORTS). C DOVTMP = .TRUE. ---> YES (DEFAULT) C DOVTMP = .FALSE. C RECALC_Q = .TRUE. ---> RE-CALCULATE SPECIFIC C HUMIDITY BUT DO NOT THEN C CALCULATE VIRTUAL C TEMPERATURE (DEFAULT) C RECALC_Q = .FALSE. ---> NO, DO NOT RE-CALCULATE C SPECIFIC HUMIDITY AND DO C NOT CALCULATE VIRTUAL C TEMPERATURE C {NOTE1: FOR SURFACE LAND, MARINE AND MESONET REPORTS, (AND C RAOB, DROP AND MULTI-LEVEL RECCO REPORTS IF C "ADPUPA_VIRT"=TRUE) DOVTMP=FALSE WILL STILL RE-CALCULATE C SPECIFIC HUMIDITY AND ENCODE IT AS A STACKED EVENT IN C THE PREPBUFR FILE UNLESS EITHER DOANLS IS TRUE OR C RECALC_Q IS FALSE.) C (NOTE2: DOES NOT APPLY TO ANY REPORT TYPES OTHER THAN THOSE C MENTIONED ABOVE) C (NOTE3: IF DOANLS=TRUE, THEN DOVTMP IS NOT ONLY FORCED TO BE C FALSE, BUT ALSO SPECIFIC HUMIDITY IS NOT RE-CALCULATED.) C (NOTE4: ADPUPA_VIRT DEFAULTS TO FALSE.) C (NOTE5: IF DOVTMP=TRUE, THEN RECALC_Q IS MEANINGLESS.) C (NOTE6: RECALC_Q DEFAULTS TO TRUE.) C C DOFCST & SOME_FCST: C DOFCST - ENCODE FORECAST (FIRST GUESS) VALUES, INTERPOLATED C FROM THE SPECTRAL SIGMA OR HYBRID GUESS FILE, INTO THE C PREPBUFR FILE FOR ALL MESSAGE TYPES OR AT LEAST SOME C MESSAGE TYPES? C DOFCST = .TRUE. ---> YES, ENCODE FORECST FOR ALL C MESSAGE TYPES (DEFAULT) C DOFCST = .FALSE. C SOME_FCST = .FALSE. ---> NO, DO NOT ENCODE FORECAST C FOR ANY MESSAGE TYPE C (VALUES REMAIN MISSING) C SOME_FCST = .TRUE. ---> YES, BUT ONLY FOR MESSAGE C TYPES "ADPUPA", "AIRCFT", C "AIRCAR", "PROFLR" OR C "VADWND" (VALUES REMAIN C MISSING FOR ALL OTHER C MESSAGE TYPES) C (NOTE1: THE CASE DOFCST=FALSE & SOME_FCST=TRUE WRITES THE C FORECAST VALUES FOR THE TYPES MENTIONED ABOVE BECAUSE C THEY ARE NEEDED BY SUBSEQUENT QUALITY CONTROL PROGRAMS.) C (NOTE2: THIS WAS ADDED AS A TIME SAVING FEATURE IN THE C NON-GLOBAL VERSIONS SINCE ONLY THE GLOBAL REQUIRES A C FIRST GUESS TO BE PRESENT FOR ALL CONVENTIONAL MESSAGE C TYPES IN THE PREPBUFR FILE.) C (NOTE3: IF DOANLS=TRUE, THEN DOFCST & SOME_FCST ARE FORCED TO BE C FALSE, MEANING A GUESS WILL NOT BE ENCODED FOR ANY C MESSAGE TYPE.) C (NOTE4: IF DOFCST=TRUE, THEN SOME_FCST IS MEANINGLESS.) C (NOTE5: SOME_FCST DEFAULTS TO TRUE.) C C DOANLS - ENCODE ANALYZED VALUES, INTERPOLATED FROM THE SPECTRAL C SIGMA OR HYBRID ANALYSIS FILE, INTO THE PREPBUFR FILE - C POSTEVENTS MODE - ? C DOANLS = .TRUE. ---> YES, FOR ALL MESSAGE TYPES C DOANLS = .FALSE. ---> NO, FOR ALL MESSAGE TYPES C - PREVENTS MODE - (DEFAULT) C (NOTE: DOANLS=TRUE WILL OVERRIDE AND FORCE TO FALSE ALL OTHER C SWITCHES. IN ADDITION, THE FORECAST VALUES WILL NOT C BE ENCODED FOR ANY MESSAGE TYPE AND SPECIFIC HUMIDITY C WILL NOT BE RE-CALCULATED.) C C DOBERR - ENCODE OBSERVATIONAL ERROR VALUES, AS READ FROM OBS. C ERROR FILE, INTO THE PREPBUFR FILE? C DOBERR = .TRUE. ---> YES (DEFAULT) C DOBERR = .FALSE. ---> NO (VALUES REMAIN MISSING) C (NOTE1: THIS WAS ADDED AS A TIME SAVING FEATURE IN THE C RAP -AND PREVIOUS RUC- VERSION SINCE IT DOES NOT REQUIRE C OBSERVATIONAL ERRORS TO BE PRESENT IN THE PREPBUFR FILE.) C (NOTE2: IF DOANLS=TRUE, THEN DOBERR IS FORCED TO BE FALSE.) C C QTOP_REJ - THE PRESSURE LEVEL (IN MB) ABOVE WHICH ALL SPECIFIC C HUMIDITY QUALITY MARKERS ARE "REJECTED" (THE QUALITY C MARKER IS SET TO 9 ON ALL PRESSURE LEVELS LESS THAN C THIS LEVEL) (DEFAULT=300.) C C SATMQC - PERFORM SPECIAL QUALITY CONTROL ON SATELLITE TEMPERATURE C SOUNDINGS IN REPORT TYPES 160-179? C SATMQC = .TRUE. ---> YES C SATMQC = .FALSE. ---> NO (DEFAULT) C (NOTE: THIS APPLIES ONLY TO THE CDAS OR HISTORICAL RE-RUNS C WITH TEMPERATURE SOUNDINGS IN THESE REPORT TYPES) C CC C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ MODULE GBLEVN_MODULE IMPLICIT NONE SAVE INTEGER IMAX,JMAX,KMAX,KMAXS INTEGER*4 IDVC,IDSL,NVCOORD,SFCPRESS_ID,THERMODYN_ID REAL (KIND=8), ALLOCATABLE :: IAR14T(:,:,:), IAR15U(:,:,:), $ IAR16V(:,:,:), IAR17Q(:,:,:), $ IAR12Z(:,:), IAR13P(:,:), $ IARPSI(:,:,:), IARPSL(:,:,:) REAL (KIND=4), ALLOCATABLE :: VCOORD(:,:) REAL DLAT,DLON END MODULE GBLEVN_MODULE SUBROUTINE GBLEVENTS(IDATEP,IUNITF,IUNITE,IUNITP,IUNITS,SUBSET, $ NEWTYP) INTEGER, PARAMETER :: IM=384, JM=IM/2+1, IDRT=0 CHARACTER*80 HEADR,OBSTR,QMSTR,FCSTR,OESTR,ANSTR CHARACTER*8 SUBSET REAL(8) OBS_8,QMS_8,BAK_8,SID_8,HDR_8(10) REAL(8) BMISS,GETBMISS LOGICAL DOVTMP,DOFCST,SOME_FCST,DOBERR,FCST,VIRT,DOANLS, $ SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV DIMENSION IUNITF(2) COMMON /GBEVAA/ SID_8,OBS_8(13,255),QMS_8(12,255),BAK_8(12,255), $ XOB,YOB,DHR,TYP,NLEV COMMON /GBEVBB/ PVCD,VTCD COMMON /GBEVCC/ DOVTMP,DOFCST,SOME_FCST,DOBERR,FCST,VIRT, $ QTOP_REJ,SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV COMMON /GBEVDD/ ERRS(300,33,6) COMMON /GBEVFF/ BMISS SAVE DATA IFIRST/0/ DATA HEADR / $ 'SID XOB YOB DHR TYP '/ DATA OBSTR / $ 'POB QOB TOB ZOB UOB VOB PWO PW1O PW2O PW3O PW4O CAT PRSS '/ DATA QMSTR / $ 'PQM QQM TQM ZQM WQM PWQ PW1Q PW2Q PW3Q PW4Q NUL NUL '/ DATA FCSTR / $ 'PFC QFC TFC ZFC UFC VFC PWF PW1F PW2F PW3F PW4F NUL '/ DATA ANSTR / $ 'PAN QAN TAN ZAN UAN VAN PWA PW1A PW2A PW3A PW4A NUL '/ DATA OESTR / $ 'POE QOE TOE ZOE WOE PWE PW1E PW2E PW3E PW4E NUL NUL '/ NAMELIST /PREVDATA/DOVTMP,DOFCST,SOME_FCST,DOBERR,DOANLS, $ QTOP_REJ,SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV C---------------------------------------------------------------------- C---------------------------------------------------------------------- IF(IFIRST.EQ.0) THEN C ------------------------------- C FIRST TIME IN DO A FEW THINGS... C ------------------------------- IFIRST = 1 PRINT 700 700 FORMAT(/1X,100('#')/' =====> SUBROUTINE GBLEVENTS INVOKED FOR ', $ 'THE FIRST TIME - VERSION LAST UPDATED 2013-02-13'/) BMISS = GETBMISS() print * print *, 'BUFRLIB value for missing passed into GBLEVENTS ', $ 'is: ',bmiss print * C INITIALIZE NAMELIST SWITCHES TO DEFAULT VALUES C ---------------------------------------------- DOVTMP = .TRUE. DOPREV = .TRUE. RECALC_Q = .TRUE. DOFCST = .TRUE. SOME_FCST = .TRUE. DOBERR = .TRUE. DOANLS = .FALSE. QTOP_REJ = 300. SATMQC = .FALSE. ADPUPA_VIRT = .FALSE. READ(5,PREVDATA,ERR=101,END=102) GO TO 103 C----------------------------------------------------------------------- 101 CONTINUE C ERROR READING STANDARD INPUT - THIS DEFAULTS TO POSTEVENTS MODE C --------------------------------------------------------------- PRINT 7013 7013 FORMAT(/' ##> GBLEVENTS: ERROR READING STANDARD INPUT DATA CARDS', $ ' -- DEFAULTS TO "POSTEVENTS" MODE'/) DOANLS = .TRUE. GO TO 103 C----------------------------------------------------------------------- 102 CONTINUE C STANDARD INPUT IS EMPTY - THIS DEFAULTS TO POSTEVENTS MODE C ---------------------------------------------------------- PRINT 7014 7014 FORMAT(/' ##> GBLEVENTS: STANDARD INPUT DATA CARDS DO NOT ', $ 'EXIST -- DEFAULTS TO "POSTEVENTS" MODE'/) DOANLS = .TRUE. C----------------------------------------------------------------------- 103 CONTINUE IF(DOANLS) THEN DOVTMP = .FALSE. DOPREV = .FALSE. DOFCST = .FALSE. SOME_FCST = .FALSE. DOBERR = .FALSE. ADPUPA_VIRT = .FALSE. ENDIF IF(DOVTMP) RECALC_Q=.TRUE. ! RECALC_Q must be T if DOVTMP is T WRITE (6,PREVDATA) FCST = DOFCST VIRT = .FALSE. C CHECK VALID-TIME DATE OF GUESS/ANALYSIS FILE(S) AGAINST THE CENTER C DATE FOR THE PREPBUFR FILE AND OBTAIN THE FIRST GUESS/ANALYSIS C UNLESS ALL OF DOFCST, SOME_FCST, DOANLS ARE FALSE C ------------------------------------------------------------------ IF(.NOT.DOANLS) THEN IF(.NOT.DOFCST.AND..NOT.SOME_FCST) THEN PRINT 901 901 FORMAT(/' --> GBLEVENTS: PREVENTS MODE - FIRST GUESS NOT READ ', $ 'IN'/) ELSE PRINT 701 701 FORMAT(/' --> GBLEVENTS: PREVENTS MODE - DATE CHECK AND ', $ 'TRANSFORM THE FIRST GUESS'/) ENDIF ELSE PRINT 7701 7701 FORMAT(/' --> GBLEVENTS: POSTEVENTS MODE - DATE CHECK AND ', $ 'TRANSFORM THE ANALYSIS'/) ENDIF IF(DOFCST .OR. SOME_FCST .OR. DOANLS) $ CALL GBLEVN10(IUNITF,IDATEP,IM,JM,IDRT) print *,' after returning from GBLEVN10',' idrt=',idrt IF(DOBERR) THEN C IF REQUESTED, READ ERROR FILES (ONLY POSSIBLE IN PREVENTS MODE) C --------------------------------------------------------------- PRINT 702 702 FORMAT(/' --> GBLEVENTS: READ ERROR FILES'/) CALL GBLEVN01(IUNITE) ELSE ERRS = 0 IF(.NOT.DOANLS) PRINT 3702 3702 FORMAT(/' --> GBLEVENTS: OBS. ERROR NOT ENCODED IN PREPBUFR ', $ '(BY CHOICE)'/) ENDIF C OBTAIN NECESSARY PROGRAM CODES (ONLY USED IN PREVENTS MODE) C ----------------------------------------------------------- CALL UFBQCD(IUNITP,'PREVENT',PVCD) CALL UFBQCD(IUNITP,'VIRTMP ',VTCD) PRINT 703 703 FORMAT(/1X,100('#')/) C SET-UP OUTPUT "PREVENT" EVENTS DATA FILTERING SUMMARY PRINT FILE C (ONLY USED IN PREVENTS MODE) C ---------------------------------------------------------------- IF(.NOT.DOANLS) WRITE(IUNITS,1701) IDATEP 1701 FORMAT(//130('#')//38X,'*** "PREVENT" EVENTS DATA FILTERING ', $ 'SUMMARY ***'/35X,'--> CENTER DATE FOR PREPBUFR FILE IS: ',I10, $ ' <--'//) C---------------------------------------------------------------------- C---------------------------------------------------------------------- ENDIF IF(.NOT.DOANLS) THEN IF(NEWTYP.EQ.1) WRITE(IUNITS,1702) SUBSET 1702 FORMAT(130('-')/39X,'--> SUMMARY FOR TABLE A ENTRY "',A8,'" <--'/) IF(.NOT.DOFCST .AND. SOME_FCST) FCST = (SUBSET.EQ.'ADPUPA ' $ .OR.SUBSET.EQ.'PROFLR '.OR.SUBSET .EQ.'AIRCFT '.OR.SUBSET $ .EQ.'AIRCAR '.OR.SUBSET .EQ.'VADWND ') C Will not subject ACARS reports to virtual temp. processing until C spec. humidity is used in production ccccc VIRT = (SUBSET.EQ.'ADPSFC '.OR.SUBSET.EQ.'SFCSHP '.OR. ccccc$ SUBSET.EQ.'MSONET '.OR.SUBSET.EQ.'AIRCAR '.OR. ccccc$ SUBSET.EQ.'RASSDA '.OR.SUBSET.EQ.'SATEMP '.OR. ccccc$ (SUBSET.EQ.'ADPUPA '.AND.ADPUPA_VIRT)) VIRT = (RECALC_Q.AND.(SUBSET.EQ.'ADPSFC '.OR. $ SUBSET.EQ.'SFCSHP '.OR. $ SUBSET.EQ.'MSONET '.OR. $ SUBSET.EQ.'RASSDA '.OR. $ SUBSET.EQ.'SATEMP '.OR. $ (SUBSET.EQ.'ADPUPA '.AND.ADPUPA_VIRT))) IF(.NOT.(FCST.OR.DOBERR.OR.VIRT.OR.DOPREV)) THEN IF(NEWTYP.EQ.1) WRITE(IUNITS,1703) 1703 FORMAT(/' ==> DATA FILTERING NOT PERFORMED FOR THIS TABLE A ', $ 'ENTRY -- FORECAST, OBS ERROR, "VIRTMP", "PREVENT" PROCESSING ', $ 'NOT DONE'/) RETURN ENDIF ENDIF C READY TO RETRIEVE NECESSARY INFORMATION OUT OF THE NEXT REPORT WHICH C HAS BEEN "UFB" ENCODED INTO THE PREPBUFR FILE BY THE CALLING PROGRAM C (USE NEGATIVE UNIT NUMBER HERE SINCE FILE OPEN FOR OUTPUT) C (NOTE: THE CALLING PROGRAM HAS NOT YET WRIITEN THE REPORT INTO C THE PREPBUFR FILE VIA WRITSB!) C ---------------------------------------------------------------- CALL UFBINT(-IUNITP,OBS_8,13,255,NLEV,OBSTR) CALL UFBINT(-IUNITP,QMS_8,12,255,NLEV,QMSTR) CALL UFBINT(-IUNITP,HDR_8,10, 1,IRET,HEADR) SID_8 = HDR_8(1) XOB = HDR_8(2) YOB = HDR_8(3) DHR = HDR_8(4) TYP = HDR_8(5) IF(FCST.OR.DOANLS) THEN C PREVENTS MODE: ENCODE FIRST GUESS VALUES INTO PREPBUFR FILE C ------------------------------------------------------------ C POSTEVENTS MODE: ENCODE ANALYSIS VALUES INTO REPORT AND RETURN TO C CALLING PROGRAM TO WRITE GBL-EVENTED REPORT C (SUBSET) INTO PREPBUFR FILE C ----------------------------------------------------------------- CALL GBLEVN03(SUBSET) IF(NLEV.GT.0) THEN IF(FCST) THEN CALL UFBINT(IUNITP,BAK_8,12,NLEV,IRET,FCSTR) ELSE CALL UFBINT(IUNITP,BAK_8,12,NLEV,IRET,ANSTR) RETURN ENDIF ENDIF ENDIF C -------------------------------------------------------------------- C LOGIC FROM HERE ON PERTAINS ONLY TO PREVENTS MODE OF THIS SUBROUTINE C -------------------------------------------------------------------- C ENCODE OBSERVATION ERRORS INTO REPORT C ------------------------------------- IF(DOBERR) THEN IF(NEWTYP.EQ.1) WRITE(IUNITS,1710) 1710 FORMAT(/' ==> OBS ERROR VALUES ARE ENCODED FOR THIS TABLE A ', $ 'ENTRY'//' ==> FILTERING VIA MISSING OBS ERROR TEST IS ', $ 'PERFORMED FOR THIS TABLE A ENTRY SINCE OBS ERROR VALUES ARE ', $ 'PROCESSED/STORED'/) CALL GBLEVN04 IF(NLEV.GT.0) CALL UFBINT(IUNITP,BAK_8,12,NLEV,IRET,OESTR) ELSE IF(NEWTYP.EQ.1) WRITE(IUNITS,1705) 1705 FORMAT(/' ==> OBS ERROR VALUES NOT ENCODED FOR THIS TABLE A ', $ 'ENTRY'//' ==> FILTERING VIA MISSING OBS ERROR TEST NOT ', $ 'PERFORMED FOR THIS TABLE A ENTRY SINCE OBS ERROR VALUES NOT ', $ 'PROCESSED/STORED'/) ENDIF C MAKE THE GBLEVENTS EVENTS AND ENCODE INTO REPORT C ------------------------------------------------ IF(.NOT.FCST) THEN IF(NEWTYP.EQ.1) WRITE(IUNITS,1704) 1704 FORMAT(/' ==> FORECAST VALUES NOT ENCODED FOR THIS TABLE A ', $ 'ENTRY'//' ==> FILTERING VIA POB VS. GESS PSFC TEST NOT ', $ 'PERFORMED FOR THIS TABLE A ENTRY SINCE FORECAST VALUES NOT ', $ 'PROCESSED/STORED'/) ELSE IF(NEWTYP.EQ.1) WRITE(IUNITS,1708) 1708 FORMAT(/' ==> FORECAST VALUES ARE ENCODED FOR THIS TABLE A ', $ 'ENTRY'//' ==> FILTERING VIA POB VS. GESS PSFC TEST IS ', $ 'PERFORMED FOR THIS TABLE A ENTRY SINCE FORECAST VALUES ARE ', $ 'PROCESSED/STORED'/) ENDIF IF(DOPREV) THEN IF(NEWTYP.EQ.1) WRITE(IUNITS,1807) 1807 FORMAT(/' ==> "PREVENT" EVENT PROCESSING IS PERFORMED FOR THIS', $ ' TABLE A ENTRY'/) CALL GBLEVN02(IUNITP,IUNITS,NEWTYP) ELSE IF(NEWTYP.EQ.1) WRITE(IUNITS,1806) 1806 FORMAT(/' ==> "PREVENT" EVENT PROCESSING NOT PERFORMED FOR THIS', $ ' TABLE A ENTRY'/) ENDIF C MAKE THE VIRTUAL TEMPERATURE EVENTS AND ENCODE INTO REPORT C ---------------------------------------------------------- IF(.NOT.VIRT) THEN IF(NEWTYP.EQ.1) WRITE(IUNITS,1706) 1706 FORMAT(/' ==> "VIRTMP" EVENT PROCESSING NOT PERFORMED FOR THIS ', $ 'TABLE A ENTRY'/) ELSE IF(NEWTYP.EQ.1) WRITE(IUNITS,1707) 1707 FORMAT(/' ==> "VIRTMP" EVENT PROCESSING IS PERFORMED FOR THIS ', $ 'TABLE A ENTRY'/) CALL GBLEVN08(IUNITP,SUBSET) ENDIF C RETURN TO CALLING PROGRAM TO WRITE GBL-EVENTED REPORT (SUBSET) INTO C PREPBUFR FILE C ------------------------------------------------------------------- RETURN END C*********************************************************************** C*********************************************************************** SUBROUTINE GBLEVN01(IUNITE) ! FORMERLY SUBROUTINE ETABLE COMMON /GBEVDD/ ERRS(300,33,6) C READ THE OBSERVATION ERROR TABLES C --------------------------------- REWIND IUNITE IREC = 0 10 CONTINUE READ(IUNITE,'(1X,I3)',END=100) KX IREC = IREC + 1 DO K=1,33 READ(IUNITE,'(1X,6E12.5)') (ERRS(KX,K,M),M=1,6) ENDDO GO TO 10 100 CONTINUE IF(IREC.LE.0) THEN PRINT'(" ##GBLEVENTS/GBLEVN01 - OBS. ERROR TABLE EMPTY OR ", $ "DOES NOT EXIST - STOP 60")' CALL ERREXIT(60) ENDIF RETURN END C*********************************************************************** C*********************************************************************** SUBROUTINE GBLEVN02(IUNITP,IUNITS,NEWTYP) ! FORMERLY SUBROUTINE FILTAN DIMENSION NFLGRT(100:299,12),OEMIN(2:6) CHARACTER*8 STNID CHARACTER*40 PEVN,QEVN,TEVN,WEVN,PWVN,PW1VN,PW2VN,PW3VN,PW4VN REAL(8) PEV_8(4,255),QEV_8(4,255),TEV_8(4,255),WEV_8(5,255), $ PWV_8(4,255),PW1V_8(4,255),PW2V_8(4,255), $ PW3V_8(4,255),PW4V_8(4,255),OBS_8,QMS_8,BAK_8,SID_8 LOGICAL FCST,REJP_PS,REJPS,REJT,REJQ,REJW,REJPW,REJPW1, $ REJPW2,REJPW3,REJPW4,SATMQC,SATEMP,SOLN60,SOLS60, $ MOERR_P,MOERR_T,ADPUPA_VIRT,DOBERR,DOFCST,SOME_FCST, $ DOVTMP,VIRT,RECALC_Q,DOPREV REAL(8) BMISS COMMON /GBEVAA/ SID_8,OBS_8(13,255),QMS_8(12,255),BAK_8(12,255), $ XOB,YOB,DHR,TYP,NLEV COMMON /GBEVBB/ PVCD,VTCD COMMON /GBEVCC/ DOVTMP,DOFCST,SOME_FCST,DOBERR,FCST,VIRT, $ QTOP_REJ,SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV COMMON /GBEVEE/PSG01,ZSG01,TG01(500),UG01(500),VG01(500), x QG01(500),zint(500),pint(500),pintlog(500),plev(500), x plevlog(500) COMMON /GBEVFF/ BMISS EQUIVALENCE (SID_8,STNID) DATA PEVN /'POB PQM PPC PRC '/ DATA QEVN /'QOB QQM QPC QRC '/ DATA TEVN /'TOB TQM TPC TRC '/ DATA WEVN /'UOB VOB WQM WPC WRC '/ DATA PWVN /'PWO PWQ PWP PWR '/ DATA PW1VN /'PW1O PW1Q PW1P PW1R '/ DATA PW2VN /'PW2O PW2Q PW2P PW2R '/ DATA PW3VN /'PW3O PW3Q PW3P PW3R '/ DATA PW4VN /'PW4O PW4Q PW4P PW4R '/ DATA NFLGRT/2400*0/ DATA OEMIN /0.5,0.1,1.0,0.5,1.0/ NI = MOD((NINT(TYP)/10),10) IF(NEWTYP.EQ.1) NFLGRT = 0 C LOGICAL SWITCHES FOR OBSERVATION LOCATION FILTERING C --------------------------------------------------- SATEMP = ((TYP.GE.160.AND.TYP.LE.179).AND.SATMQC) SOLN60 = ((TYP.GE.160.AND.TYP.LE.163).AND.YOB.GE.-60.AND.SATMQC) SOLS60 = ((TYP.EQ.160.OR.TYP.EQ.162.OR.TYP.EQ.163).AND.YOB.LT.-60 $ .AND.SATMQC) C CLEAR THE EVENT ARRAYS C ---------------------- PEV_8 = BMISS QEV_8 = BMISS TEV_8 = BMISS WEV_8 = BMISS PWV_8 = BMISS PW1V_8 = BMISS PW2V_8 = BMISS PW3V_8 = BMISS PW4V_8 = BMISS MAXPEV = 0 MAXQEV = 0 MAXTEV = 0 MAXWEV = 0 MAXPWV = 0 MAXPW1V = 0 MAXPW2V = 0 MAXPW3V = 0 MAXPW4V = 0 C LOOP OVER LEVELS APPLYING UNDERGROUND FILTERING AND SPECIAL RULES C ----------------------------------------------------------------- IF(NLEV.GT.0) THEN DO L=1,NLEV POB = OBS_8( 1,L) QOB = OBS_8( 2,L) TOB = OBS_8( 3,L) UOB = OBS_8( 5,L) VOB = OBS_8( 6,L) PWO = OBS_8( 7,L) PW1O = OBS_8( 8,L) PW2O = OBS_8( 9,L) PW3O = OBS_8(10,L) PW4O = OBS_8(11,L) CAT = OBS_8(12,L) PRSS = OBS_8(13,L) PQM = QMS_8( 1,L) QQM = QMS_8( 2,L) TQM = QMS_8( 3,L) ZQM = QMS_8( 4,L) WQM = QMS_8( 5,L) PWQ = QMS_8( 6,L) PW1Q = QMS_8( 7,L) PW2Q = QMS_8( 8,L) PW3Q = QMS_8( 9,L) PW4Q = QMS_8(10,L) REJP_PS = .FALSE. MOERR_P = .FALSE. MOERR_T = .FALSE. RCD = 99999 C ------------------------------------------------------------------- C RULES FOR PRESSURE (ON ANY LEVEL) -- ALL DATA (MASS AND WIND) ON C LEVEL REJECTED IF: C - PRESSURE MORE THAN 100 MB BELOW MODEL (GUESS) SURFACE PRESSURE C (AND SWITCH FCST=TRUE) -- "PREVENT" PGM REASON CODE 1 C - PRESSURE IS ZERO OR IS NEGATIVE -- "PREVENT" PGM REASON CODE 2 C - SURFACE (MASS OR WIND) REPORT PRESSURE IS REPORTED ABOVE 450 MB C OR BELOW 1100 MB -- "PREVENT" PGM REASON CODE 2 C REJECTION MEANS Q.M. SET TO 8 C ------------------------------------------------------------------- IF(POB.LT.BMISS) THEN IF(.NOT.FCST) PSG01 = POB IF(POB-PSG01.GE.100. .OR. POB.LE.0. .OR. $ ((POB.LE.450..OR.POB.GE.1100.) .AND. NI.EQ.8)) THEN IF(POB.LE.0..OR.POB.LE.450..OR.POB.GE.1100.) THEN IF(NI.EQ.8) THEN WRITE(IUNITS,302) STNID,NINT(TYP),YOB,XOB,POB 302 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, $ 'E, REJECT ALL DATA ON SFC LVL - POB=',F6.1,' MB, FAILS SANITY ', $ 'CHECK') ELSE WRITE(IUNITS,101) STNID,NINT(TYP),YOB,XOB,POB 101 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, $'E, REJECT ALL DATA ON LVL - POB=',F6.1,' MB, FAILS SANITY CHECK') ENDIF RCD = 2 ELSE IF(NI.EQ.8) THEN WRITE(IUNITS,303) STNID,NINT(TYP),YOB,XOB,POB,PSG01 303 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, $ 'E, REJECT ALL DATA ON SFC LVL - POB=',F6.1,' MB, > 100 MB ', $ 'BELOW GES PSFC(=',F6.1,'MB)') ELSE WRITE(IUNITS,102) STNID,NINT(TYP),YOB,XOB,POB,PSG01 102 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, $ 'E, REJECT ALL DATA ON LVL - POB=',F6.1,' MB, > 100 MB BELOW ', $ 'GES PSFC(=',F6.1,' MB)') ENDIF RCD = 1 ENDIF REJ = 8 REJP_PS = .TRUE. PEV_8(1,L) = POB PEV_8(2,L) = REJ PEV_8(3,L) = PVCD PEV_8(4,L) = RCD MAXPEV = L ENDIF ENDIF C ------------------------------------------------------------------- C RULES FOR SURFACE PRESSURE -- ALL MASS DATA ON SURFACE LEVEL C REJECTED IF: C - OBSERVATION ERROR IS MISSING (AND SWITCH DOBERR=TRUE) -- C "PREVENT" PGM REASON CODE 3 C - PRESSURE IS MORE THAN 100 MB ABOVE OR BELOW MODEL (GUESS) C SURFACE PRESSURE (AND SWITCH FCST=TRUE) -- C "PREVENT" PGM REASON CODE 4 C - PRESSURE IS REPORTED ABOVE 450 MB OR BELOW 1100 MB -- "PREVENT" C PGM REASON CODE 2 (NOTE: DOES NOT APPLY TO SURFACE REPORTS, C THESE WERE TESTED FOR THIS CRITERION IN ABOVE PRESSURE TEST) C - PRESSURE VIOLATES RULES FOR PRESSURE ON ANY LEVEL (SEE ABOVE) C REJECTION FOR FIRST RULE MEANS Q.M. SET TO 9 UNLESS: C - ANY OTHER RULE CAUSES REJECTION, THEN Q.M. SET TO 8 C - Q.M. IS ALREADY > 3 BUT NOT 15, THEN SKIP EVENT AND LEAVE Q.M. C AS IS C ------------------------------------------------------------------- IF(POB.LT.BMISS .AND. CAT.EQ.0) THEN IF(.NOT.FCST) PSG01 = POB REJPS = OEFG01(POB,TYP,5,OEMIN(5)).GE.BMISS .OR. $ ABS(POB-PSG01).GE.100. .OR. $ POB.LE.450. .OR. $ POB.GE.1100. IF(REJPS.OR.REJP_PS) THEN REJ = 8 IF(.NOT.REJP_PS) THEN IF(ABS(POB-PSG01).GE.100.) THEN WRITE(IUNITS,104) STNID,NINT(TYP),YOB,XOB,POB,PSG01 104 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, $ 'E, REJECT ALL DATA ON SFC LVL - POB=',F6.1,' MB, > 100 MB ', $ 'ABOVE GES PSFC(=',F6.1,'MB)') RCD = 4 ELSE IF(POB.LE.450..OR.POB.GE.1100.) THEN WRITE(IUNITS,105) STNID,NINT(TYP),YOB,XOB,POB 105 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, $ 'E, REJECT ALL DATA ON SFC LVL - POB=',F6.1,' MB, FAILS SANITY ', $ 'CHECK - this should never be printed since test now made in ', $ 'section above ') RCD = 2 ELSE IF(NFLGRT(NINT(TYP),1).EQ.0) THEN WRITE(IUNITS,201) NINT(TYP) 201 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', $ 'ALL DATA ON SURFACE LEVEL DUE TO MISSING SFC-P OBS ERROR'/) NFLGRT(NINT(TYP),1) = 1 ENDIF CDAK CDAK CDAK CDAK WRITE(IUNITS,103) STNID,NINT(TYP),YOB,XOB,POB CD103 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, CDAK $ 'E, REJECT ALL DATA ON SFC LVL - POB=',F6.1,'MB, MISSING OBS.', CDAK $ ' ERROR') RCD = 3 REJ = 9 ENDIF ENDIF REJP_PS = .TRUE. IF(RCD.EQ.3) MOERR_P = .TRUE. IF(REJ.EQ.9.AND.(PQM.GT.3.AND.PQM.LT.15)) THEN CDAKCDAKCDAKCDAK WRITE(IUNITS,1401) STNID,NINT(TYP),YOB,XOB,PQM 1401 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, $ 'E, INPUT PQM =',F4.0,' -- DO NOT APPLY PSFC QM=9 EVENT') ELSE PEV_8(1,L) = POB PEV_8(2,L) = REJ PEV_8(3,L) = PVCD PEV_8(4,L) = RCD MAXPEV = L ENDIF ENDIF ENDIF C ------------------------------------------------------------------- C RULES FOR TEMPERATURE -- TOB AND QOB ON LEVEL REJECTED IF: C - OBSERVATION ERROR IS MISSING (AND SWITCH DOBERR=TRUE) -- C "PREVENT" PGM REASON CODE 3 C - THIS IS SFC LEVEL AND OBSERVATION ERROR FOR SFC PRESSURE IS C MISSING (AND SWITCH DOBERR=TRUE) -- "PREVENT" PGM REASON CODE 3 C - REPORT IS TYPE 160-163 (LAND TOVS/RTOVS/ATOVS TEMPERATURE C SOUNDINGS, ALL PATHS), AND IS AT OR NORTH OF 60 DEGREES SOUTH C LATITUDE, AND PRESSURE ON LEVEL IS AT OR BELOW 100 MB (AND C SWITCH SATMQC=TRUE) -- "PREVENT" PGM REASON CODE 6 C - REPORT IS TYPE 160,162,163 (LAND TOVS/RTOVS/ATOVS TEMPERATURE C SOUNDINGS, ALL PATHS BUT CLEAR), AND IS SOUTH OF 60 DEGREES C SOUTH LATITUDE, AND PRESSURE ON LEVEL IS BELOW 100 MB (AND C SWITCH SATMQC=TRUE) -- "PREVENT" PGM REASON CODE 6 C - THIS IS SFC LEVEL AND PRESSURE VIOLATES RULES FOR SFC PRESSURE C (EXCEPT FOR MISSING OBSERVATION ERROR, ALREADY COVERED IN RULE C 2 ABOVE) (SEE ABOVE) C - PRESSURE ON LEVEL VIOLATES RULES FOR PRESSURE (SEE ABOVE) C REJECTION FOR FIRST TWO RULES MEANS Q.M. SET TO 9 UNLESS: C - ANY OTHER RULE CAUSES REJECTION, THEN Q.M. SET TO 8 C - Q.M. IS ALREADY > 3 BUT NOT 15, THEN SKIP EVENT AND LEAVE Q.M. C AS IS C ------------------------------------------------------------------- IF(TOB.LT.BMISS) THEN REJT = OEFG01(POB,TYP,2,OEMIN(2)).GE.BMISS .OR. $ (SOLN60.AND.NINT(POB*10.).GE.1000) .OR. $ (SOLS60.AND.NINT(POB*10.).GT.1000) IF(REJT.OR.REJP_PS) THEN REJ = 8 IF(.NOT.REJP_PS) THEN IF(SOLN60.AND.NINT(POB*10.).GE.1000) THEN IF(NFLGRT(NINT(TYP),6).EQ.0) THEN WRITE(IUNITS,7304) NINT(TYP) 7304 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', $'TOB/QOB AT AND BELOW 100 MB IF REPORT IS NORTH OF 60S LATITUDE'/) NFLGRT(NINT(TYP),6) = 1 ENDIF RCD = 6 ELSE IF(SOLS60.AND.NINT(POB*10.).GT.1000) THEN IF(NFLGRT(NINT(TYP),7).EQ.0) THEN WRITE(IUNITS,7305) NINT(TYP) 7305 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', $ 'TOB/QOB BELOW 100 MB IF REPORT IS SOUTH OF 60S LATITUDE'/) NFLGRT(NINT(TYP),7) = 1 ENDIF RCD = 6 ELSE IF(NFLGRT(NINT(TYP),2).EQ.0) THEN IF(NI.EQ.8) THEN WRITE(IUNITS,304) NINT(TYP) 304 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', $ 'TOB/QOB ON SFC LVL DUE TO MISSING OBS ERROR'/) ELSE WRITE(IUNITS,202) NINT(TYP) 202 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', $ 'TOB/QOB ON AT LEAST ONE LVL (IF AVAILABLE ON THAT LVL) DUE TO ', $ 'MISSING OBS ERROR'/) ENDIF NFLGRT(NINT(TYP),2) = 1 cdak cdak cdak cdak cdakWRITE(IUNITS,106) STNID,NINT(TYP),YOB,XOB,TOB cd106 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, cdak $ 'E, REJECT TOB/QOB ON LVL - TOB=',F5.1,'C, MISSING OBS. ERROR') ENDIF RCD = 3 REJ = 9 ENDIF ELSE IF(MOERR_P) THEN RCD = 3 REJ = 9 ENDIF ENDIF IF(RCD.EQ.3) MOERR_T = .TRUE. IF(REJ.EQ.9.AND.(TQM.GT.3.AND.TQM.LT.15)) THEN CDAKCDAKCDAKCDAK WRITE(IUNITS,1402) STNID,NINT(TYP),YOB,XOB,TQM 1402 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, $ 'E, INPUT TQM =',F4.0,' -- DO NOT APPLY TEMP QM=9 EVENT') ELSE TEV_8(1,L) = TOB TEV_8(2,L) = REJ TEV_8(3,L) = PVCD TEV_8(4,L) = RCD MAXTEV = L ENDIF ENDIF ENDIF C ------------------------------------------------------------------- C RULES FOR SPECIFIC HUMIDITY -- QOB ON LEVEL REJECTED IF: C - OBSERVATION ERROR IS MISSING (AND SWITCH DOBERR=TRUE) -- C "PREVENT" PGM REASON CODE 3 C - PRESSURE ON LEVEL IS ABOVE "QTOP_REJ" MB {WHERE QTOP_REJ IS C READ IN FROM NAMELIST "PREVDATA" (SEE DOCBLOCK)} -- "PREVENT" C PGM REASON CODE 5 C - OBSERVATION ERROR FOR TEMPERATURE ON LEVEL IS MISSING (AND C SWITCH DOBERR=TRUE) -- "PREVENT" PGM REASON CODE 3 C - THIS IS SFC LEVEL AND OBSERVATION ERROR FOR SFC PRESSURE IS C MISSING (AND SWITCH DOBERR=TRUE) -- "PREVENT" PGM REASON CODE 3 C - TEMPERATURE ON LEVEL IS MISSING OR IS LESS THAN -150 DEG. C -- C "PREVENT" PGM REASON CODE 2 C - SPECIFIC HUMIDITY IS ZERO OR IS NEGATIVE -- "PREVENT" PGM REASON C CODE 2 C - REPORT IS TYPE 160-179 (SATELLITE TEMPERATURE SOUNDINGS, ALL C TYPES, ALL PATHS, LAND AND SEA), ALL PRESSURE LEVELS (AND C SWITCH SATMQC=TRUE) -- "PREVENT" PGM REASON CODE 7 C - TEMPERATURE ON LEVEL VIOLATES RULES FOR TEMPERATURE (EXCEPT FOR C MISSING OBSERVATION ERROR, ALREADY COVERED IN RULE 2 ABOVE) C (SEE ABOVE) C - THIS IS SFC LEVEL AND PRESSURE VIOLATES RULES FOR SFC PRESSURE C (EXCEPT FOR MISSING OBSERVATION ERROR, ALREADY COVERED IN RULE C 4 ABOVE) (SEE ABOVE) C - PRESSURE ON LEVEL VIOLATES RULES FOR PRESSURE (SEE ABOVE) C REJECTION FOR FIRST FOUR RULES MEANS Q.M. SET TO 9 UNLESS: C - ANY OTHER RULE CAUSES REJECTION, THEN Q.M. SET TO 8 C - Q.M. IS ALREADY > 3 BUT NOT 15, THEN SKIP EVENT AND LEAVE Q.M. C AS IS C ------------------------------------------------------------------- IF(QOB.LT.BMISS) THEN REJQ = OEFG01(POB,TYP,3,OEMIN(3)).GE.BMISS .OR. $ TOB.GE.BMISS .OR. $ TOB.LE.-150. .OR. $ NINT(POB * 10.).LT.NINT(QTOP_REJ * 10.) .OR. $ QOB.LE.0. .OR. $ SATEMP .OR. $ REJT IF(REJQ.OR.REJP_PS) THEN REJ = 8 IF(.NOT.REJP_PS.AND..NOT.REJT) THEN IF(SATEMP) THEN IF(NFLGRT(NINT(TYP),8).EQ.0) THEN WRITE(IUNITS,7306) NINT(TYP) 7306 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', $ 'QOB ON ALL LEVELS'/) NFLGRT(NINT(TYP),8) = 1 ENDIF RCD = 7 ELSE IF(QOB.LE.0..OR.TOB.GE.BMISS.OR.TOB.LE.-150.)THEN WRITE(IUNITS,111) STNID,NINT(TYP),YOB,XOB, $ QOB/1000.,TOB 111 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, $ 'E, REJECT QOB ON LVL - QOB=',F6.3,' G/KG, FAILS SANITY CHECK ', $ '(TOB=',F5.1,' C)') RCD = 2 ELSE IF(OEFG01(POB,TYP,3,OEMIN(3)).GE.BMISS) THEN IF(NFLGRT(NINT(TYP),3).EQ.0) THEN IF(NI.EQ.8) THEN WRITE(IUNITS,305) NINT(TYP) 305 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', $ 'QOB ON SFC LVL DUE TO MISSING OBS ERROR'/) ELSE WRITE(IUNITS,203) NINT(TYP) 203 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', $ 'QOB ON AT LEAST ONE LEVEL (IF AVAILABLE ON THAT LEVEL) DUE TO ', $ 'MISSING OBS ERROR'/) ENDIF NFLGRT(NINT(TYP),3) = 1 ENDIF RCD = 3 REJ = 9 cdak cdak cdak cdak WRITE(IUNITS,108) STNID,NINT(TYP),YOB,XOB,QOB/1000. cd108 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, cdak $'E, REJECT QOB ON LVL - QOB=',F6.3,'G/KG, MISSING OBS. ERROR') ELSE WRITE(IUNITS,109) STNID,NINT(TYP),YOB,XOB, $ QOB/1000.,QTOP_REJ,POB 109 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, $ 'E, REJECT QOB ON LVL - QOB=',F6.3,' G/KG, ABOVE ',F6.1, $ 'MB (POB=',F6.1,' MB)') RCD = 5 REJ = 9 ENDIF ELSE IF(MOERR_P.OR.MOERR_T) THEN RCD = 3 REJ = 9 ENDIF ENDIF IF(REJ.EQ.9.AND.(QQM.GT.3.AND.QQM.LT.15)) THEN CDAKCDAKCDAKCDAK WRITE(IUNITS,1403) STNID,NINT(TYP),YOB,XOB,QQM 1403 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, $ 'E, INPUT QQM =',F4.0,' -- DO NOT APPLY MSTR QM=9 EVENT') ELSE QEV_8(1,L) = QOB QEV_8(2,L) = REJ QEV_8(3,L) = PVCD QEV_8(4,L) = RCD MAXQEV = L ENDIF ENDIF ENDIF C ------------------------------------------------------------------- C RULES FOR WIND -- UOB AND VOB ON LEVEL REJECTED IF: C - OBSERVATION ERROR IS MISSING (AND SWITCH DOBERR=TRUE) -- C "PREVENT" PGM REASON CODE 3 C - THIS IS SFC LEVEL AND OBSERVATION ERROR FOR SFC PRESSURE IS C MISSING (AND SWITCH DOBERR=TRUE) -- "PREVENT" PGM REASON CODE 3 C (Note: This can currently never happen because earlier check C for missing obs error for sfc pressure is only done if C "surface" level is category 0 and this is not possible C for wind reports.) C - THIS IS SFC LEVEL AND PRESSURE VIOLATES RULES FOR SFC PRESSURE C (EXCEPT FOR MISSING OBSERVATION ERROR, ALREADY COVERED IN RULE C 2 ABOVE) (SEE ABOVE) C - PRESSURE ON LEVEL VIOLATES RULES FOR PRESSURE (SEE ABOVE) C REJECTION FOR FIRST TWO RULES MEANS Q.M. SET TO 9 UNLESS: C - ANY OTHER RULE CAUSES REJECTION, THEN Q.M. SET TO 8 C - Q.M. IS ALREADY > 3 BUT NOT 15, THEN SKIP EVENT AND LEAVE Q.M. C AS IS C ------------------------------------------------------------------- IF(MIN(UOB,VOB).LT.BMISS) THEN REJW = OEFG01(POB,TYP,4,OEMIN(4)).GE.BMISS IF(REJW.OR.REJP_PS) THEN REJ = 8 IF(.NOT.REJP_PS) THEN IF(NFLGRT(NINT(TYP),4).EQ.0) THEN IF(NI.EQ.8) THEN WRITE(IUNITS,1304) NINT(TYP) 1304 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', $ 'UOB/VOB ON SFC LVL DUE TO MISSING OBS ERROR'/) ELSE WRITE(IUNITS,204) NINT(TYP) 204 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', $ 'UOB/VOB ON AT LEAST ONE LVL (IF AVAILABLE ON THAT LVL) DUE TO ', $ 'MISSING OBS ERROR'/) ENDIF NFLGRT(NINT(TYP),4) = 1 ENDIF cdak cdak cdak WRITE(IUNITS,112) STNID,NINT(TYP),YOB,XOB cd112 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, cdak $'E, REJECT UOB/VOB ON LVL - MISSING OBS. ERROR') RCD = 3 REJ = 9 ELSE IF(MOERR_P) THEN ! This currently can never be TRUE ! since CAT is never 0 for "sfc" ! level of wind reports RCD = 3 REJ = 9 ENDIF ENDIF IF(REJ.EQ.9.AND.(WQM.GT.3.AND.WQM.LT.15)) THEN CDAKCDAKCDAKCDAK WRITE(IUNITS,1404) STNID,NINT(TYP),YOB,XOB,WQM 1404 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, $ 'E, INPUT WQM =',F4.0,' -- DO NOT APPLY WIND QM=9 EVENT') ELSE WEV_8(1,L) = UOB WEV_8(2,L) = VOB WEV_8(3,L) = REJ WEV_8(4,L) = PVCD WEV_8(5,L) = RCD MAXWEV = L ENDIF ENDIF ENDIF C ------------------------------------------------------------------- C RULES FOR TOTAL COLUMN PRECIPITABLE WATER -- PWO REJECTED IF: C - OBSERVATION ERROR IS MISSING (AND SWITCH DOBERR=TRUE) -- C "PREVENT" PGM REASON CODE 3 C REJECTION MEANS Q.M. SET TO 9 UNLESS: C - Q.M. IS ALREADY > 3 BUT NOT 15, THEN SKIP EVENT AND LEAVE Q.M. C AS IS C ------------------------------------------------------------------- IF(PWO.LT.BMISS) THEN REJPW = OEFG01(PRSS*0.01,TYP,6,OEMIN(6)).GE.BMISS IF(REJPW) THEN IF(NFLGRT(NINT(TYP),5).EQ.0) THEN WRITE(IUNITS,205) NINT(TYP) 205 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', $ 'PWO DUE TO MISSING OBS ERROR'/) NFLGRT(NINT(TYP),5) = 1 ENDIF cdakcdakcdak WRITE(IUNITS,113) STNID,NINT(TYP),YOB,XOB,PWO cd113 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, cdak $'E, REJECT PWO ON LVL - PWO=',F5.1,'MM, MISSING OBS. ERROR') IF(PWQ.GT.3.AND.PWQ.LT.15) THEN CDAKCDAKCDAKCDAK WRITE(IUNITS,1405) STNID,NINT(TYP),YOB,XOB,PWQ 1405 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, $ 'E, INPUT PWQ =',F4.0,' -- DO NOT APPLY PWtO QM=9 EVENT') ELSE PWV_8(1,L) = PWO PWV_8(2,L) = 9 PWV_8(3,L) = PVCD PWV_8(4,L) = 3 MAXPWV = L ENDIF ENDIF ENDIF C ------------------------------------------------------------------- C RULES FOR LAYER 1 PRECIPITABLE WATER -- PW1O REJECTED IF: C - OBSERVATION ERROR IS MISSING (AND SWITCH DOBERR=TRUE) -- C "PREVENT" PGM REASON CODE 3 C REJECTION MEANS Q.M. SET TO 9 UNLESS: C - Q.M. IS ALREADY > 3 BUT NOT 15, THEN SKIP EVENT AND LEAVE Q.M. C AS IS C ------------------------------------------------------------------- IF(PW1O.LT.BMISS) THEN REJPW1 = OEFG01(PRSS*0.01,TYP,6,OEMIN(6)).GE.BMISS IF(REJPW1) THEN IF(NFLGRT(NINT(TYP),9).EQ.0) THEN WRITE(IUNITS,206) NINT(TYP) 206 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', $ 'PW1O DUE TO MISSING OBS ERROR'/) NFLGRT(NINT(TYP),9) = 1 ENDIF cdakcdakcdak WRITE(IUNITS,114) STNID,NINT(TYP),YOB,XOB,PW1O cd114 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, cdak $'E, REJECT PW1O ON LVL - PW1O=',F5.1,'MM, MISSING OBS. ERROR') IF(PW1Q.GT.3.AND.PW1Q.LT.15) THEN CDAKCDAKCDAKCDAK WRITE(IUNITS,1406) STNID,NINT(TYP),YOB,XOB,PW1Q 1406 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, $ 'E, INPUT PW1Q =',F4.0,' -- DO NOT APPLY PW1O QM=9 EVENT') ELSE PW1V_8(1,L) = PW1O PW1V_8(2,L) = 9 PW1V_8(3,L) = PVCD PW1V_8(4,L) = 3 MAXPW1V = L ENDIF ENDIF ENDIF C ------------------------------------------------------------------- C RULES FOR LAYER 2 PRECIPITABLE WATER -- PW2O REJECTED IF: C - OBSERVATION ERROR IS MISSING (AND SWITCH DOBERR=TRUE) -- C "PREVENT" PGM REASON CODE 3 C REJECTION MEANS Q.M. SET TO 9 UNLESS: C - Q.M. IS ALREADY > 3 BUT NOT 15, THEN SKIP EVENT AND LEAVE Q.M. C AS IS C ------------------------------------------------------------------- IF(PW2O.LT.BMISS) THEN REJPW2 = OEFG01(PRSS*0.01,TYP,6,OEMIN(6)).GE.BMISS IF(REJPW2) THEN IF(NFLGRT(NINT(TYP),10).EQ.0) THEN WRITE(IUNITS,207) NINT(TYP) 207 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', $ 'PW2O DUE TO MISSING OBS ERROR'/) NFLGRT(NINT(TYP),10) = 1 ENDIF cdakcdakcdak WRITE(IUNITS,115) STNID,NINT(TYP),YOB,XOB,PW2O cd115 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, cdak $'E, REJECT PW2O ON LVL - PW2O=',F5.1,'MM, MISSING OBS. ERROR') IF(PW2Q.GT.3.AND.PW2Q.LT.15) THEN CDAKCDAKCDAKCDAK WRITE(IUNITS,1407) STNID,NINT(TYP),YOB,XOB,PW2Q 1407 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, $ 'E, INPUT PW2Q =',F4.0,' -- DO NOT APPLY PW2O QM=9 EVENT') ELSE PW2V_8(1,L) = PW2O PW2V_8(2,L) = 9 PW2V_8(3,L) = PVCD PW2V_8(4,L) = 3 MAXPW2V = L ENDIF ENDIF ENDIF C ------------------------------------------------------------------- C RULES FOR LAYER 3 PRECIPITABLE WATER -- PW3O REJECTED IF: C - OBSERVATION ERROR IS MISSING (AND SWITCH DOBERR=TRUE) -- C "PREVENT" PGM REASON CODE 3 C REJECTION MEANS Q.M. SET TO 9 UNLESS: C - Q.M. IS ALREADY > 3 BUT NOT 15, THEN SKIP EVENT AND LEAVE Q.M. C AS IS C ------------------------------------------------------------------- IF(PW3O.LT.BMISS) THEN REJPW3 = OEFG01(PRSS*0.01,TYP,6,OEMIN(6)).GE.BMISS IF(REJPW3) THEN IF(NFLGRT(NINT(TYP),11).EQ.0) THEN WRITE(IUNITS,208) NINT(TYP) 208 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', $ 'PW3O DUE TO MISSING OBS ERROR'/) NFLGRT(NINT(TYP),11) = 1 ENDIF cdakcdakcdak WRITE(IUNITS,116) STNID,NINT(TYP),YOB,XOB,PW3O cd116 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, cdak $'E, REJECT PW3O ON LVL - PW3O=',F5.1,'MM, MISSING OBS. ERROR') IF(PW3Q.GT.3.AND.PW3Q.LT.15) THEN CDAKCDAKCDAKCDAK WRITE(IUNITS,1408) STNID,NINT(TYP),YOB,XOB,PW3Q 1408 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, $ 'E, INPUT PW3Q =',F4.0,' -- DO NOT APPLY PW3O QM=9 EVENT') ELSE PW3V_8(1,L) = PW3O PW3V_8(2,L) = 9 PW3V_8(3,L) = PVCD PW3V_8(4,L) = 3 MAXPW3V = L ENDIF ENDIF ENDIF C ------------------------------------------------------------------- C RULES FOR LAYER 4 PRECIPITABLE WATER -- PW4O REJECTED IF: C - OBSERVATION ERROR IS MISSING (AND SWITCH DOBERR=TRUE) -- C "PREVENT" PGM REASON CODE 3 C REJECTION MEANS Q.M. SET TO 9 UNLESS: C - Q.M. IS ALREADY > 3 BUT NOT 15, THEN SKIP EVENT AND LEAVE Q.M. C AS IS C ------------------------------------------------------------------- IF(PW4O.LT.BMISS) THEN REJPW4 = OEFG01(PRSS*0.01,TYP,6,OEMIN(6)).GE.BMISS IF(REJPW4) THEN IF(NFLGRT(NINT(TYP),12).EQ.0) THEN WRITE(IUNITS,209) NINT(TYP) 209 FORMAT(/' --> FOR ALL REPORTS WITH REPORT TYPE ',I3,', REJECT ', $ 'PW4O DUE TO MISSING OBS ERROR'/) NFLGRT(NINT(TYP),12) = 1 ENDIF cdakcdakcdak WRITE(IUNITS,117) STNID,NINT(TYP),YOB,XOB,PW4O cd117 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, cdak $'E, REJECT PW4O ON LVL - PW4O=',F5.1,'MM, MISSING OBS. ERROR') IF(PW4Q.GT.3.AND.PW4Q.LT.15) THEN CDAKCDAKCDAKCDAK WRITE(IUNITS,1409) STNID,NINT(TYP),YOB,XOB,PW4Q 1409 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2, $ 'E, INPUT PW4Q =',F4.0,' -- DO NOT APPLY PW4O QM=9 EVENT') ELSE PW4V_8(1,L) = PW4O PW4V_8(2,L) = 9 PW4V_8(3,L) = PVCD PW4V_8(4,L) = 3 MAXPW4V = L ENDIF ENDIF ENDIF ENDDO ENDIF C APPLY THE PROPER EVENTS C ----------------------- IF(MAXPEV .GT.0) CALL UFBINT(IUNITP,PEV_8, 4,MAXPEV, IRET,PEVN) IF(MAXQEV .GT.0) CALL UFBINT(IUNITP,QEV_8, 4,MAXQEV, IRET,QEVN) IF(MAXTEV .GT.0) CALL UFBINT(IUNITP,TEV_8, 4,MAXTEV, IRET,TEVN) IF(MAXWEV .GT.0) CALL UFBINT(IUNITP,WEV_8, 5,MAXWEV, IRET,WEVN) IF(MAXPWV .GT.0) CALL UFBINT(IUNITP,PWV_8, 4,MAXPWV, IRET,PWVN) IF(MAXPW1V.GT.0) CALL UFBINT(IUNITP,PW1V_8,4,MAXPW1V,IRET,PW1VN) IF(MAXPW2V.GT.0) CALL UFBINT(IUNITP,PW2V_8,4,MAXPW2V,IRET,PW2VN) IF(MAXPW3V.GT.0) CALL UFBINT(IUNITP,PW3V_8,4,MAXPW3V,IRET,PW3VN) IF(MAXPW4V.GT.0) CALL UFBINT(IUNITP,PW4V_8,4,MAXPW4V,IRET,PW4VN) RETURN END C*********************************************************************** C*********************************************************************** C GBLEVN03 - INTERPOLATE MODEL DATA (FIRST GUESS OR ANALYSIS) TO OB C LOCATIONS C----------------------------------------------------------------------- SUBROUTINE GBLEVN03(SUBSET) ! FORMERLY SUBROUTINE GETFC USE GBLEVN_MODULE REAL(8) OBS_8,QMS_8,BAK_8,SID_8 REAL(8) BMISS CHARACTER*8 SUBSET COMMON /GBEVAA/ SID_8,OBS_8(13,255),QMS_8(12,255),BAK_8(12,255), $ XOB,YOB,DHR,TYP,NLEV COMMON /GBEVEE/PSG01,ZSG01,TG01(500),UG01(500),VG01(500), x QG01(500),zint(500),pint(500),pintlog(500),plev(500), x plevlog(500) COMMON /GBEVFF/ BMISS DATA TZERO / 273.15 / DATA BETAP / .0552 / DATA BETA / .00650 / DATA ROG / 29.261 / C CLEAR THE BACKGROUND EVENT ARRAY C -------------------------------- BAK_8 = BMISS C GET GUESS PROFILE AT OB LOCATION C -------------------------------- CALL GBLEVN06(XOB,YOB) C INTERPOLATE GUESS PROFILES TO OB PRESSURES C ------------------------------------------ IF(NLEV.GT.0) THEN DO 10 L=1,NLEV POB = OBS_8( 1,L) QOB = OBS_8( 2,L) TOB = OBS_8( 3,L) ZOB = OBS_8( 4,L) UOB = OBS_8( 5,L) VOB = OBS_8( 6,L) PWO = OBS_8( 7,L) PW1O = OBS_8( 8,L) PW2O = OBS_8( 9,L) PW3O = OBS_8(10,L) PW4O = OBS_8(11,L) CAT = OBS_8(12,L) IF(POB.LE.0. .OR. POB.GE.BMISS) GOTO 10 poblog = log(pob) la = -999 lb = -999 do k=1,kmax-1 if (poblog<=plevlog(k) .and. poblog>plevlog(k+1)) then la = k lb = k+1 exit endif enddo if (la > 0) then wt = (poblog-plevlog(lb)) / (plevlog(la)-plevlog(lb)) else la = 1 lb = la+1 wt = 0.0 endif li=0 do k=1,kmax-1 if (poblog<=pintlog(k) .and. poblog>pintlog(k+1)) then li = k exit endif enddo C SURFACE PRESSURE C ---------------- IF(CAT.EQ.0 .AND. ZOB.LT.BMISS) THEN TS = TG01(1) + (PSG01-PLEV(1))*BETAP DZ = ZOB-ZSG01 TM = TS - DZ*BETA*.5 PFC = PSG01*EXP(-DZ/(TM*ROG)) ELSE PFC = BMISS ENDIF C SPECIFIC HUMIDITY C ----------------- IF(QOB.LT.BMISS.OR.TOB.LT.BMISS.OR.TYP.EQ.111) THEN C (QFC NEEDED BY SYNDATA PROGRAM BUT ONLY FOR REPORT TYPE 111) QOB = QG01(LB) + (QG01(LA)-QG01(LB))*WT ENDIF C TEMPERATURE C ----------- IF(TOB.LT.BMISS.OR.SUBSET.EQ.'VADWND '.OR.TYP.EQ.111) THEN C (TFC NEEDED BY CQCVAD AND SYNDATA PROGRAMS, LATTER ONLY FOR REPORT C TYPE 111) IF(POB.GT.PLEV(1)) THEN TOB = TG01(1) + (POB-PLEV(1))*BETAP ELSE TOB = TG01(LB) + (TG01(LA)-TG01(LB))*WT ENDIF TOB = TOB - TZERO ENDIF C HEIGHT C ------ IF(ZOB.LT.BMISS) THEN IF(POB.GT.PLEV(1)) THEN TM = TG01(1) + (.5*(PINT(1)+POB)-PLEV(1))*BETAP ZOB = ZINT(1) - ROG*TM*LOG(POB/PINT(1)) ELSE TM = TG01(LB) + (TG01(LA)-TG01(LB))*WT ZOB = ZINT(LI) - ROG*TM*LOG(POB/PINT(LI)) ENDIF ENDIF C U AND V COMPONENTS C ------------------ IF(UOB.LT.BMISS .OR. VOB.LT.BMISS) THEN UOB = UG01(LB) + (UG01(LA)-UG01(LB))*WT VOB = VG01(LB) + (VG01(LA)-VG01(LB))*WT ENDIF C PRECIPITABLE WATER C ------------------ PWO = BMISS PW1O = BMISS PW2O = BMISS PW3O = BMISS PW4O = BMISS C RELATIVE HUMIDITY C ----------------- RHO = BMISS C SCATTER THE PROPER FIRST GUESS/ANALYSIS VALUES C ---------------------------------------------- BAK_8(1,L) = PFC BAK_8(2,L) = QOB BAK_8(3,L) = TOB BAK_8(4,L) = ZOB BAK_8(5,L) = UOB BAK_8(6,L) = VOB BAK_8(7,L) = PWO BAK_8(8,L) = PW1O BAK_8(9,L) = PW2O BAK_8(10,L) = PW3O BAK_8(11,L) = PW4O BAK_8(12,L) = RHO 10 ENDDO ENDIF RETURN END C*********************************************************************** C*********************************************************************** SUBROUTINE GBLEVN04 ! FORMERLY SUBROUTINE GETOE DIMENSION OEMIN(2:6) REAL(8) OBS_8,QMS_8,BAK_8,SID_8 REAL(8) BMISS COMMON /GBEVAA/ SID_8,OBS_8(13,255),QMS_8(12,255),BAK_8(12,255), $ XOB,YOB,DHR,TYP,NLEV COMMON /GBEVFF/ BMISS DATA OEMIN /0.5,0.1,1.0,0.5,1.0/ C CLEAR THE EVENT ARRAY C --------------------- BAK_8 = BMISS C LOOP OVER LEVELS LOOKING UP THE OBSERVATION ERROR C ------------------------------------------------- IF(NLEV.GT.0) THEN DO L=1,NLEV POB = OBS_8( 1,L) QOB = OBS_8( 2,L) TOB = OBS_8( 3,L) WOB = MAX(OBS_8(5,L),OBS_8(6,L)) PWO = OBS_8( 7,L) PW1O = OBS_8( 8,L) PW2O = OBS_8( 9,L) PW3O = OBS_8(10,L) PW4O = OBS_8(11,L) CAT = OBS_8(12,L) IF(CAT .EQ.0 ) BAK_8( 1,L) = OEFG01(POB,TYP,5,OEMIN(5)) IF(QOB .LT.BMISS) BAK_8( 2,L) = OEFG01(POB,TYP,3,OEMIN(3)) IF(TOB .LT.BMISS) BAK_8( 3,L) = OEFG01(POB,TYP,2,OEMIN(2)) IF(WOB .LT.BMISS) BAK_8( 5,L) = OEFG01(POB,TYP,4,OEMIN(4)) IF(PWO .LT.BMISS) BAK_8( 6,L) = OEFG01(POB,TYP,6,OEMIN(6)) IF(PW1O.LT.BMISS) BAK_8( 7,L) = OEFG01(POB,TYP,6,OEMIN(6)) IF(PW2O.LT.BMISS) BAK_8( 8,L) = OEFG01(POB,TYP,6,OEMIN(6)) IF(PW3O.LT.BMISS) BAK_8( 9,L) = OEFG01(POB,TYP,6,OEMIN(6)) IF(PW4O.LT.BMISS) BAK_8(10,L) = OEFG01(POB,TYP,6,OEMIN(6)) ENDDO ENDIF RETURN END C*********************************************************************** C*********************************************************************** C SUBROUTINE GBLEVN06 - 2D LINEAR HORIZONTAL INTERPOLATION C----------------------------------------------------------------------- SUBROUTINE GBLEVN06(XOB,YOB) ! FORMERLY SUBROUTINE HTERP USE GBLEVN_MODULE COMMON /GBEVEE/ PSI,ZSI,TI(500),UI(500),VI(500),QI(500), x zint(500),pint(500),pintlog(500),plev(500),plevlog(500) DATA ROG / 29.261 / C CALCULATE HORIZONTAL WEIGHTS AND INTERPOLATE C -------------------------------------------- WX = XOB/DLON + 1.0 I0 = WX I1 = MOD(I0,IMAX) + 1 WX = WX-I0 WY = (YOB+90.)/DLAT + 1.0 J0 = WY J1 = MIN(J0+1,JMAX) WY = WY-J0 C HTERP FOR SURFACE HEIGHT C ------------------------ P1 = iar12z(I0,J0) P2 = iar12z(I0,J1) P3 = iar12z(I1,J0) P4 = iar12z(I1,J1) P5 = P1+(P2-P1)*WY P6 = P3+(P4-P3)*WY ZSI = P5+(P6-P5)*WX C HTERP FOR SURFACE PRESSURE C -------------------------- P1 = iar13p(I0,J0) P2 = iar13p(I0,J1) P3 = iar13p(I1,J0) P4 = iar13p(I1,J1) P5 = P1+(P2-P1)*WY P6 = P3+(P4-P3)*WY PSI = P5+(P6-P5)*WX C HTERP FOR UPA T,U,V,Q C --------------------- DO K=1,KMAX P1 = iar14t(I0,J0,K) P2 = iar14t(I0,J1,K) P3 = iar14t(I1,J0,K) P4 = iar14t(I1,J1,K) P5 = P1+(P2-P1)*WY P6 = P3+(P4-P3)*WY TI(K) = P5+(P6-P5)*WX P1 = iar15u(I0,J0,K) P2 = iar15u(I0,J1,K) P3 = iar15u(I1,J0,K) P4 = iar15u(I1,J1,K) P5 = P1+(P2-P1)*WY P6 = P3+(P4-P3)*WY UI(K) = P5+(P6-P5)*WX P1 = iar16v(I0,J0,K) P2 = iar16v(I0,J1,K) P3 = iar16v(I1,J0,K) P4 = iar16v(I1,J1,K) P5 = P1+(P2-P1)*WY P6 = P3+(P4-P3)*WY VI(K) = P5+(P6-P5)*WX P1 = iar17q(I0,J0,K) P2 = iar17q(I0,J1,K) P3 = iar17q(I1,J0,K) P4 = iar17q(I1,J1,K) P5 = P1+(P2-P1)*WY P6 = P3+(P4-P3)*WY QI(K) = P5+(P6-P5)*WX C Layer Pressure C -------------- P1 = iarpsl(I0,J0,K) P2 = iarpsl(I0,J1,K) P3 = iarpsl(I1,J0,K) P4 = iarpsl(I1,J1,K) P5 = P1+(P2-P1)*WY P6 = P3+(P4-P3)*WY PLEV(K) = P5+(P6-P5)*WX C Interface Pressure C ------------------ P1 = iarpsi(I0,J0,K+1) P2 = iarpsi(I0,J1,K+1) P3 = iarpsi(I1,J0,K+1) P4 = iarpsi(I1,J1,K+1) P5 = P1+(P2-P1)*WY P6 = P3+(P4-P3)*WY PINT(K+1) = P5+(P6-P5)*WX ENDDO C Compute interface heights C ------------------------- zint(1) = zsi pint(1) = psi pintlog(1) = log(pint(1)) do k=2,kmax k0 = k-1 zint(k) = zint(k0) - rog*ti(k0)*log(pint(k)/pint(k0)) pintlog(k) = log(pint(k)) enddo pint(kmax+1) = 0.0 C Compute log(pressure) at layer midpoints C ---------------------------------------- do k=1,kmax plevlog(k) = log(plev(k)) enddo ccccc print *,' pint=',pint(1:kmax) ccccc print *,' zint=',zint(1:kmax) RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: OEFG01 C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2007-09-14 C C ABSTRACT: FUNCTION WHICH RETURNS THE OBSERVATION ERROR FOR A C REQUESTED VARIABLE INTERPOLATED TO A DEFINED PRESSURE LEVEL FOR A C DEFINED REPORT TYPE. IT IS OBTAINED FROM AN INPUT ARRAY CONTAINING C OBSERVATION ERRORS ON FIXED PRESSURE LEVELS BY VARIABLE AND REPORT C TYPE (READ EARLIER FROM THE EXTERNAL OBSERVATION ERROR TABLE) C C PROGRAM HISTORY LOG: C 1995-05-17 J. WOOLLEN (NP20) - ORIGINAL AUTHOR (FUNCTION OEF) C 2007-09-14 D. A. KEYSER -- MODIFIED TO USE EXACT LOGIC AS IN GSI C (MINIMUM LIMITING VALUE FOR OBS ERROR BASED ON VARIABLE TYPE, C LEVEL PRESSURE LIMITED TO MAX OF 2000 MB AND MIN OF ZERO MB, A C FEW OTHER MINOR CHANGES) C C USAGE: XX = OEFG01(P,TYP,IE,OEMIN) C INPUT ARGUMENT LIST: C P - REAL PRESSURE LEVEL (MB) TO INTERPOLATE OBS ERROR TO C TYP - REAL PREPBUFR REPORT TYPE C IE - VARIABLE TYPE BEING INTERPOLATED (=2 - TEMPERATURE, C - =3 - MOISTURE, =4 - WIND, =5 - SURFACE PRESSURE, =6 - C - PRECIPITABLE WATER) C - (USED ONLY IN PREVENTS MODE) C OEMIN - REAL MINIMUM VALUE FOR OBS ERROR (FOR VARIABLE BEING C - INTERPOLATED) C C REMARKS: 'OEFG01' RETURNED IS OBSERVATION ERROR FOR VARIABLE "IE" IN C REPORT TYPE "TYP", INTERPOLATED TO PRESSURE LEVEL "P". CC C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ FUNCTION OEFG01(P,TYP,IE,OEMIN) REAL(8) BMISS COMMON /GBEVDD/ERRS(300,33,6) COMMON /GBEVFF/ BMISS OEFG01 = BMISS C LOOK UP ERRORS FOR PARTICULAR OB TYPES C -------------------------------------- KX = TYP P = MAX(0.,MIN(P,2000.)) IF(P.GE.ERRS(KX,1,1)) K1 = 1 DO KL = 1,32 IF(P.GE.ERRS(KX,KL+1,1).AND.P.LE.ERRS(KX,KL,1)) K1 = KL ENDDO IF(P.LE.ERRS(KX,33,1)) K1 = 5 K2 = K1 + 1 EDIFF = ERRS(KX,K2,1) - ERRS(KX,K1,1) IF(ABS(EDIFF).GT.0.0) THEN DEL = (P - ERRS(KX,K1,1))/EDIFF ELSE DEL = BMISS ENDIF DEL = MAX(0.,MIN(DEL,1.0)) OEFG01 = ((1.0 - DEL) * ERRS(KX,K1,IE)) + (DEL * ERRS(KX,K2,IE)) OEFG01 = MAX(OEFG01,OEMIN) C SET MISSING ERROR VALUE TO "BMISS" C ---------------------------------- IF(OEFG01.GE.5E5) OEFG01 = BMISS RETURN END C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: GBLEVN08 CALCULATE SPEC. HUMIDITY AND VIRTUAL TEMP C PRGMMR: D.A. KEYSER ORG: NP22 DATE: 2007-09-14 C C ABSTRACT: CREATE VIRTUAL TEMPERATURE EVENTS WITHIN GBLEVENTS C SUBROUTINE. FOR ALL TYPES EXCEPT RASS, THIS CONSISTS OF FIRST RE- C CALCULATING THE SPECIFIC HUMIDITY FROM THE REPORTED DEWPOINT C TEMPERATURE AND PRESSURE, FOLLOWED BY THE CALCULATION OF VIRTUAL C TEMPERATURE FROM THE JUST-CALCULATED SPECIFIC HUMIDITY AND THE C REPORTED (SENSIBLE) TEMPERATURE. THE RE-CALCULATED SPECIFIC C HUMIDITY IS THEN ENCODED AS A STACKED EVENT TO BE LATER WRITTEN C INTO THE PREPBUFR FILE (UNDER PROGRAM "VIRTMP", REASON CODE 0). C IF THE NAMELIST SWITCH DOVTMP IS TRUE, THEN THE JUST-CALCULATED C VIRTUAL TEMPERATURE IS THEN ALSO ENCODED AS A STACKED EVENT TO BE C LATER WRITTEN INTO THE PREPBUFR FILE (UNDER PROGRAM "VIRTMP", C REASON CODE 0, 2 OR 6). FOR RASS DATA, SPECIFIC HUMIDITY IS C MISSING HOWEVER IF THE NAMELIST SWITCH DOVTMP IS TRUE, A SIMPLE C COPY OF THE REPORTED (VIRTUAL) TEMPERATURE IS ENCODED AS A STACKED C EVENT TO BE LATER WRITTEN INTO THE PREPBUFR FILE (UNDER PROGRAM C "VIRTMP", REASON CODE 3). THIS SUBROUTINE IS CURRENTLY ONLY C CALLED FOR SURFACE LAND ("ADPSFC"), MARINE ("SFCSHP"), MESONET C ("MSONET"), RASS ("RASSDA") OR SATELLITE TEMPERATURE RETRIEVAL C ("SATEMP") DATA TYPES WHEN SWITCH "ADPUPA_VIRT" IS FALSE AND ONLY C FOR SURFACE LAND ("ADPSFC"), MARINE ("SFCSHP"), MESONET ("MSONET"), C RASS ("RASSDA"), SATELLITE TEMPERATURE RETRIEVAL ("SATEMP") OR C RAOB/DROP/MULTI-LVL RECCO ("ADPUPA") DATA TYPES WHEN SWITCH C "ADPUPA_VIRT" IS TRUE. IT IS ALSO ONLY CALLED IN THE PREVENTS C MODE. THIS ROUTINE IS CALLED ONCE FOR EACH VALID REPORT IN THE C PREPBUFR FILE. C C PROGRAM HISTORY LOG: C 1995-05-17 J. WOOLLEN (NP20) - ORIGINAL AUTHOR C 1997-06-01 D.A. KEYSER - STREAMLINED, ADDED SWITCH DOVTMP C 1999-12-01 D. A. KEYSER -- SPEC. HUMIDITY AND VIRT. TEMPERATURE ARE C NOW CALCULATED WHEN SPEC. HUMIDITY QUAL. MARKER IS BAD (SUBJECT C TO A SANITY CHECK), HOWEVER THE VIRT. TEMPERATURE GETS A BAD C QUAL. MARKER (8) C 2004-08-30 D. A. KEYSER -- FOR "RASSDA" TYPES, ENCODES A SIMPLE COPY C OF THE REPORTED (VIRTUAL) TEMPERATURE AS A "VIRTMP" EVENT IF C DOVTMP IS TRUE, GETS NEW REASON CODE 3 C 2006-07-14 D. A. KEYSER -- PROCESSES REPORTS IN MESSAGE TYPE ADPUPA C (I.E., RAOBS, DROPS, MULTI-LEVEL RECCOS) WITH SAME LOGIC AS IN C SUBROUTINE VTPEVN OF PROGRAM PREPOBS_CQCBUFR WHEN NEW NAMELIST C SWITCH "ADPUPA_VIRT" IS TRUE {NORMALLY "ADPUPA_VIRT" IS FALSE C (DEFAULT) BECAUSE SUBSEQUENT PROGRAM PREPOBS_CQCBUFR PERFORMS C THIS FUNCTION} C 2007-09-14 D. A. KEYSER -- FOR NON-"ADPUPA" TYPES, Q.M. 9 IS NOW C ASSIGNED TO CALCULATED VIRT. TEMPS IF THE MOISTURE Q.M. IS 9 OR C 15 AND ORIG. TEMP NOT "BAD", THESE "VIRTMP" EVENTS RECEIVE NEW C REASON CODE 4, HAD RECEIVED Q.M. 8 WITH REASON CODE 2 LIKE VIRT. C TEMPS CALCULATED FROM "BAD" MOISTURE - THIS MEANS ONLY TRULY C "BAD" VIRT. TEMPS WILL NOW GET Q.M. 8 AND VIRT. TEMPS FLAGGED FOR C NON-USE BY ASSIMILATION (BUT STILL "GOOD") WILL NOW GET Q.M. 9 C (GSI MONITORS, BUT DOES NOT USE, OBS WITH Q.M. 9, BUT IT DOES NOT C EVEN CONSIDER OBS WITH Q.M. 8); FOR "ADPUPA" TYPES, Q.M. 3 IS NOW C ASSIGNED TO CALCULATED VIRT. TEMPS ONLY IF THE MOISTURE Q.M. IS C TRULY BAD (I.E. > 3 BUT NOT 9 OR 15) (AND, AS BEFORE, ORIG. TQM C IS 1 OR 2 AND POB IS BELOW 700 MB) - BEFORE, TQM SET TO 3 WHEN C QQM WAS 9 OR 15 AND ALL OTHER CONDITIONS MET; FOR "SATEMP" TYPES, C ENCODES A SIMPLE COPY OF THE REPORTED (VIRTUAL) TEMPERATURE AS A C "VIRTMP" EVENT IF DOVTMP IS TRUE, GETS REASON CODE 3 (SIMILAR TO C WHAT IS ALREADY DONE FOR "RASSDA" TYPES) C C USAGE: CALL GBLEVN08(IUNITP) C INPUT ARGUMENT LIST: C IUNITP - BUFR OUTPUT FILE UNIT C SUBSET - THE BUFR MESSAGE TABLE A ENTRY FOR THE PARTICULAR C - REPORT BEING PROCESSED C C REMARKS: WILL IMMEDIATELY RETURN TO CALLING PROGRAM IF ANY OF THE C FOLLOWING CONDITIONS EXIST: THERE ARE NO LEVELS OF VALID DEWPOINT, C OBS, TEMPERATURE Q.M. OR SPEC. HUMIDITY Q.M. IN THE INPUT PREPBUFR C FILE FOR THE REPORT. WILL NOT ATTEMPT EITHER SPEC. HUMIDITY NOR C VIRT. TEMP CALC. ON A GIVEN LEVEL IF ANY OF THE FOLLOWING C CONDITIONS EXIST: REPORTED PRESSURE OBS IS MISSING, REPORTED C (SENSIBLE) TEMPERATURE OBS IS MISSING, OR REPORTED DEWPOINT OBS IS C MISSING. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: NCEP WCOSS C C$$$ SUBROUTINE GBLEVN08(IUNITP,SUBSET) ! FORMERLY SUBROUTINE VTPEVN CHARACTER*80 EVNSTQ,EVNSTV CHARACTER*8 SUBSET REAL(8) TDP_8(255),TQM_8(255),QQM_8(255),BAKQ_8(4,255), $ BAKV_8(4,255),OBS_8,QMS_8,BAK_8,SID_8 REAL(8) BMISS LOGICAL EVNQ,EVNV,DOVTMP,TROP,ADPUPA_VIRT,DOBERR,DOFCST, $ SOME_FCST,FCST,VIRT,SATMQC,RECALC_Q,DOPREV COMMON /GBEVAA/ SID_8,OBS_8(13,255),QMS_8(12,255),BAK_8(12,255), $ XOB,YOB,DHR,TYP,NLEV COMMON /GBEVBB/ PVCD,VTCD COMMON /GBEVCC/ DOVTMP,DOFCST,SOME_FCST,DOBERR,FCST,VIRT, $ QTOP_REJ,SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV COMMON /GBEVFF/ BMISS DATA EVNSTQ /'QOB QQM QPC QRC'/ DATA EVNSTV /'TOB TQM TPC TRC'/ C----------------------------------------------------------------------- C FCNS BELOW CONVERT TEMP/TD (K) & PRESS (MB) INTO SAT./ SPEC. HUM.(G/G) C----------------------------------------------------------------------- ES(T) = 6.1078*EXP((17.269*(T - 273.16))/((T - 273.16)+237.3)) QS(T,P) = (0.622*ES(T))/(P-(0.378*ES(T))) C----------------------------------------------------------------------- C CLEAR TEMPERATURE AND SPECIFIC HUMIDITY EVENTS C ---------------------------------------------- EVNQ = .FALSE. EVNV = .FALSE. BAKQ_8 = BMISS BAKV_8 = BMISS TROP = .FALSE. C GET DEWPOINT TEMPERATURE AND CURRENT T,Q QUALITY MARKERS C -------------------------------------------------------- CALL UFBINT(-IUNITP,TDP_8,1,255,NLTD,'TDO') CALL UFBINT(-IUNITP,QQM_8,1,255,NLQQ,'QQM') CALL UFBINT(-IUNITP,TQM_8,1,255,NLTQ,'TQM') IF(SUBSET.NE.'RASSDA '.AND.SUBSET.NE.'SATEMP ') THEN IF(NLTD.EQ.0) RETURN IF(NLQQ.EQ.0) RETURN ENDIF IF(NLTQ.EQ.0) RETURN IF(SUBSET.NE.'RASSDA '.AND.SUBSET.NE.'SATEMP ') THEN IF(NLTD.NE.NLEV) THEN PRINT'(" ##GBLEVENTS/GBLEVN08 - NLTD .NE. NLEV - STOP 61")' CALL ERREXIT(61) ENDIF IF(NLQQ.NE.NLEV) THEN PRINT'(" ##GBLEVENTS/GBLEVN08 - NLQQ .NE. NLEV - STOP 63")' CALL ERREXIT(63) ENDIF ENDIF IF(NLTQ.NE.NLEV) THEN PRINT'(" ##GBLEVENTS/GBLEVN08 - NLTQ .NE. NLEV - STOP 62")' CALL ERREXIT(62) ENDIF C COMPUTE VIRTUAL TEMPERATURE AND SPECIFIC HUMIDITY USING REPORTED DEWP C --------------------------------------------------------------------- IF(NLEV.GT.0) THEN DO L=1,NLEV POB = OBS_8(1,L) TDO = TDP_8(L) TOB = OBS_8(3,L) CAT = OBS_8(12,L) IF(DOVTMP) THEN IF(SUBSET.EQ.'RASSDA '.OR.SUBSET.EQ.'SATEMP ') THEN IF(TOB.LT.BMISS) THEN BAKV_8(1,L) = TOB BAKV_8(2,L) = TQM_8(L) BAKV_8(3,L) = VTCD BAKV_8(4,L) = 3 EVNV = .TRUE. CYCLE ENDIF ENDIF ENDIF IF(POB.LT.BMISS .AND. TOB.LT.BMISS $ .AND. TDO.LT.BMISS) THEN IF(QQM_8(L).GT.3) THEN C Don't update q or calculate Tv if bad moisture obs fails sanity check cdak IF(TDO.LT.-103.15 .OR. TDO.GT.46.83 .OR. POB.LT.0.1 .OR. cdak $ POB.GT.1100.) cdak $ print *, '&&& bad QM fails sanity check' IF(TDO.LT.-103.15 .OR. TDO.GT.46.83 .OR. POB.LT.0.1 .OR. $ POB.GT.1100.) CYCLE ENDIF QOB = QS(TDO+273.16,POB) ccccc BAKQ_8(1,L) = QOB*1E6 ! dak fix 2/27/13: can't be > bmiss ! else flting pt overflow in BUFRLIB ccc IF(QOB*1E6.LT.BMISS) BAKQ_8(1,L) = QOB*1E6 ! dak add'l fix 4/12/13: don't allow ! calc. q to be < 0 which can occur ! on WCOSS for cases of horribly bad ! mesonet data IF(QOB*1E6.LT.BMISS .AND. QOB.GT.0.) BAKQ_8(1,L) = QOB*1E6 BAKQ_8(2,L) = QQM_8(L) ! Moist qm same as before for ! re-calc. q BAKQ_8(3,L) = VTCD BAKQ_8(4,L) = 0 ! Re-calc. q gets unique reason code 0 EVNQ = .TRUE. C If message type ADPUPA, test this level to see if at or above trop C (trop must be above 500 mb to pass test; if no trop level found C assume it's at 80 mb) C Don't calculate Tv on this level if at or above trop (doesn't affect C q calculation) TROP = (SUBSET.EQ.'ADPUPA ' .AND. $ ((CAT.EQ.5 .AND. POB.LT.500.) .OR. POB.LT. 80. .OR. TROP)) IF(DOVTMP .AND. .NOT.TROP) THEN BAKV_8(1,L) = (TOB+273.16)*(1.+.61*QOB)-273.16 BAKV_8(3,L) = VTCD IF(SUBSET.EQ.'ADPUPA ') THEN C Message type ADPUPA comes here IF((QQM_8(L).LT.4.OR.QQM_8(L).EQ.9.OR.QQM_8(L).EQ.15) $ .OR. TQM_8(L).EQ.0 .OR. TQM_8(L).GT.3 $ .OR. POB.LE.700.) THEN BAKV_8(2,L) = TQM_8(L) ! Tv qm same as for T when ! q ok or q flagged by ! PREPRO (but not bad) BAKV_8(4,L) = 0 ! Tv gets unique reason code 0 ELSE BAKV_8(2,L) = 3 !Tv qm susp for bad moist below ! 700 mb BAKV_8(4,L) = 6 !Tv gets unique reason code 6 ENDIF ELSE C All other message types come here IF(QQM_8(L).LT.4) THEN BAKV_8(2,L) = TQM_8(L) ! Tv qm same as for T when ! q ok BAKV_8(4,L) = 0 ! Tv gets unique reason code 0 ELSE IF((QQM_8(L).EQ.9.OR.QQM_8(L).EQ.15).AND. $ (TQM_8(L).LE.3.OR.TQM_8(L).GE.15.OR. $ TQM_8(L).EQ.9)) THEN cdak print'(" %%% process tvirt on lvl ",I0," for missing moist obs ", cdak $ "error/high-up moist case when orig. T not ""bad"" (set TQM_8=", cdak $ "9)")', l BAKV_8(2,L) = 9 ! Tv qm 9 for moist w/ missing obs ! error or moist flagged by ! PREPRO (but not bad) and T qm ! orig not "bad" BAKV_8(4,L) = 4 ! Tv gets unique reason code 4 ELSE cdak print'(" %%% process tvirt on lvl ",I0," for ""bad"" QQM_8 case ", cdak $ "or missing moist obs error/high-up moist w/ ""bad"" TQM_8 case", cdak $ " (set TQM_8=8)")', l BAKV_8(2,L) = 8 ! Tv qm 8 (bad) for "bad" moist or ! moist w/ missing obs error or ! moist flagged by PREPRO (but ! not bad) and T qm orig "bad" BAKV_8(4,L) = 2 ! Tv gets unique reason code 2 ENDIF ENDIF EVNV = .TRUE. ENDIF ENDIF ENDDO ENDIF C ENCODE EVENTS INTO REPORT C ------------------------- IF(NLEV.GT.0) THEN IF(EVNQ) CALL UFBINT(IUNITP,BAKQ_8,4,NLEV,IRET,EVNSTQ) IF(EVNV) CALL UFBINT(IUNITP,BAKV_8,4,NLEV,IRET,EVNSTV) ENDIF RETURN END C####################### C####################### C####################### C####################### C####################### C####################### C*********************************************************************** C*********************************************************************** SUBROUTINE GBLEVN10(IUNITF,IDATEP,IM,JM,IDRT) ! FORMERLY ! SUBROUTINE GESRES USE GBLEVN_MODULE USE SIGIO_MODULE USE SIGIO_R_MODULE IMPLICIT NONE INTEGER IUNITF(2), IDATEP, IM, JM, IDRT REAL, PARAMETER :: PI180=.0174532 INTEGER*4, PARAMETER :: ONE=1, TEN=10 TYPE(SIGIO_HEAD) :: HEAD(2) TYPE(SIGIO_DATS) :: DATS TYPE(SIGIO_DATM) :: DATM INTEGER*4 IRET,IRET1,IRETS,IMJM4,KM4,IDVM,NTRAC,IUNIT4(2) INTEGER KFILES,IFILE,JFILE,IDATGS_COR,JCAP,JCAP1,JCAP2,JCAP1X2, $ MDIMA,MDIMB,MDIMC,IROMB,MAXWV,IDIR,NS,I,J,K,L,II,JJ,IB,IE INTEGER IDATE(8,2),JDATE(8,2),KDATE(8,2),KINDX(2) CHARACTER*6 COORD(3) CHARACTER*20 CFILE REAL FHOUR,RINC(5) DATA COORD /'SIGMA ','HYBRID','GENHYB'/ REAL, ALLOCATABLE :: cofs(:,:), cofv(:,:,:) REAL, ALLOCATABLE :: cofs_f(:,:,:), cofv_f(:,:,:,:) REAL (KIND=4),ALLOCATABLE :: grds(:,:,:), grdv(:,:,:,:), $ wrk1(:,:), wrk2(:,:) IMAX = IM JMAX = JM IMJM4 = IM*JM IUNIT4(:) = IUNITF(:) IF(MOD(MOD(IDATEP,100),3).EQ.0) THEN KFILES = 1 KINDX = 0 PRINT 331, MOD(IDATEP,100) 331 FORMAT(/' --> GBLEVENTS: THE PREPBUFR CENTER HOUR (',I2.2, $ ') IS A MULTIPLE OF 3 - ONLY ONE GLOBAL SIGMA OR HYBRID FILE', $ ' IS READ,'/16X,'NO INTERPOLATION OF SPECTRAL COEFFICIENTS ', $ 'IS PERFORMED'/) ELSE KFILES = 2 KINDX(1) = MOD(MOD(IDATEP,100),3) KINDX(2) = KINDX(1) - 3 PRINT 332, MOD(IDATEP,100) 332 FORMAT(/' --> GBLEVENTS: THE PREPBUFR CENTER HOUR (',I2.2, $ ') IS NOT A MULTIPLE OF 3 - TWO SPANNING GLOBAL SIGMA OR ', $ 'HYBRID FILES'/16X,'ARE READ AND THE SPECTRAL COEFFICIENTS ', $ 'ARE INTERPOLATED TO THE PREPBUFR CENTER TIME'/) ENDIF C GET VALID-TIME DATE OF SIGMA OR HYBRID FILE(S), ALSO READ HEADERS C ----------------------------------------------------------------- JFILE = 0 RINC = 0 DO IFILE=1,KFILES JFILE = IFILE WRITE(CFILE,'("fort.",I2.2)') IUNITF(IFILE) print *,' cfile=',cfile CALL SIGIO_RROPEN(IUNIT4(IFILE),CFILE,IRET) CALL SIGIO_RRHEAD(IUNIT4(IFILE),HEAD(IFILE),IRET1) IF(IRET.NE.0) GO TO 903 IF(IRET1.NE.0) GO TO 904 IDATE(:,IFILE) = 0 IDATE(1,IFILE) = HEAD(IFILE)%IDATE(4) IDATE(2:3,IFILE) = HEAD(IFILE)%IDATE(2:3) IDATE(5,IFILE) = HEAD(IFILE)%IDATE(1) FHOUR = HEAD(IFILE)%FHOUR print'(" idate=",I5,7I3.2," fhour=",F7.3)', idate(:,ifile), $ head(ifile)%fhour IF(IDATE(1,IFILE).LT.100) THEN C IF 2-DIGIT YEAR FOUND IN GLOBAL SIMGA FILE INITIAL DATE C (IDATE(1,IFILE)), MUST USE "WINDOWING" TECHNIQUE TO CREATE A 4-DIGIT C YEAR (NOTE: THE T170 IMPLEMENTATION IN JUNE 1998 WAS TO INCLUDE THE C WRITING OF A 4-DIGIT YEAR HERE. PRIOR TO THIS, THE YEAR HERE WAS C 2-DIGIT.) PRINT'(" ##GBLEVENTS/GBLEVN10 - 2-DIGIT YEAR FOUND IN ", $ "GLOBAL SIGMA OR HYBRID FILE ",I0,"; INITIAL DATE (YEAR ", $ "IS: ",I0,")")', IFILE,idate(1,IFILE) PRINT'(" - USE WINDOWING TECHNIQUE TO OBTAIN 4-DIGIT", $ " YEAR")' IF(IDATE(1,IFILE).GT.20) THEN IDATE(1,IFILE) = 1900 + IDATE(1,IFILE) ELSE IDATE(1,IFILE) = 2000 + IDATE(1,IFILE) ENDIF PRINT'(" ##GBLEVENTS/GBLEVN10 - CORRECTED 4-DIGIT YEAR IS", $ " NOW: ",I0)', IDATE(1,IFILE) ENDIF RINC(2) = FHOUR CALL W3MOVDAT(RINC,IDATE(:,IFILE),JDATE(:,IFILE)) PRINT 1, IFILE,HEAD(IFILE)%FHOUR, $ (IDATE(II,IFILE),II=1,3),IDATE(5,IFILE),(JDATE(II,IFILE), $ II=1,3),JDATE(5,IFILE) 1 FORMAT(' --> GBLEVENTS: GLOBAL SIGMA OR HYBRID FILE',I2, $ ' HERE IS A ',F5.1,' HOUR FORECAST FROM ',I5.4,3I3.2,' VALID', $ ' AT ',I5.4,3I3.2) KDATE(:,IFILE) = JDATE(:,IFILE) IF(KFILES.EQ.2) THEN RINC(2) = REAL(KINDX(IFILE)) CALL W3MOVDAT(RINC,JDATE(:,IFILE),KDATE(:,IFILE)) ENDIF IDATGS_COR = (KDATE(1,IFILE) * 1000000) + (KDATE(2,IFILE) * $ 10000) + (KDATE(3,IFILE) * 100) + KDATE(5,IFILE) C VALID DATES MUST MATCH C ---------------------- IF(IDATEP.NE.IDATGS_COR) GO TO 901 ENDDO C EXTRACT HEADER INFO C ------------------- JCAP = HEAD(1)%JCAP KMAX = HEAD(1)%LEVS KM4 = KMAX IDVC = HEAD(1)%IDVC IDVM = HEAD(1)%IDVM NTRAC = HEAD(1)%NTRAC NVCOORD = HEAD(1)%NVCOORD ALLOCATE (VCOORD(KMAX+1,NVCOORD)) VCOORD = HEAD(1)%VCOORD SFCPRESS_ID = MOD(HEAD(1)%IDVM,TEN) THERMODYN_ID = MOD(HEAD(1)%IDVM/TEN,TEN) IF(IDVC == 3 .AND. THERMODYN_ID == 3) THEN KMAXS = (NTRAC+1)*KMAX + 2 ELSE KMAXS = 2*KMAX + 2 NTRAC = 1 ENDIF ALLOCATE (iar12z(im,jm), iar13p(im,jm)) ALLOCATE (iar14t(im,jm,kmax), iar15u(im,jm,kmax), $ iar16v(im,jm,kmax), iar17q(im,jm,kmax), $ iarpsl(im,jm,kmax), iarpsi(im,jm,kmax+1)) if(idvc.eq.0) idvc = 1 ! Reset IDVC=0 to 1 (sigma coord.) IF(IDVC < 0 .or. IDVC > 3) THEN PRINT *, '##GBLEVENTS/GBLEVN10: INVALID VERT COORD ID (=',IDVC ENDIF C DEFINE THE OTHER RESOLUTION PARAMETERS C -------------------------------------- JCAP1 = JCAP+1 JCAP2 = JCAP+2 JCAP1X2 = JCAP1*2 MDIMA = JCAP1*JCAP2 MDIMB = MDIMA/2+JCAP1 MDIMC = MDIMB*2 IMAX = 384 JMAX = IMAX/2+1 DLAT = 180./(JMAX-1) DLON = 360./IMAX PRINT 2, JCAP,KMAX,kmaxs,DLAT,DLON,COORD(IDVC) 2 FORMAT(/' --> GBLEVENTS: GLOBAL MODEL SPECS: T',I3,' ',I3, $ ' LEVELS ',I3,' SCALARS -------> ',F5.2,' X ',F5.2,' VERT. ', $ 'COORD: ',A) GO TO 902 901 CONTINUE PRINT 9901, JFILE,(JDATE(II,JFILE),II=1,3),JDATE(5,JFILE),IDATEP 9901 FORMAT(/' ##GBLEVENTS/GBLEVN10 - SIGMA OR HYBRID FILE',I2,' DATE', $ ' (',I4.4,3(I2.2),'), DOES NOT MATCH -OR SPAN- PREPBUFR FILE ', $ 'CENTER DATE (',I10,') -STOP 68'/) CALL ERREXIT(68) 903 CONTINUE PRINT 9903, JFILE,IRET 9903 FORMAT(/' ##GBLEVENTS/GBLEVN10 - SIGMA OR HYBRID FILE',I2, $ ' RETURNED FROM SIGIO_RROPEN WITH R.C.',I3,' -STOP 70'/) CALL ERREXIT(70) 904 CONTINUE PRINT 9904, JFILE,IRET1 9904 FORMAT(/' ##GBLEVENTS/GBLEVN10 - SIGMA OR HYBRID FILE',I2, $ ' RETURNED FROM SIGIO_RRHEAD WITH R.C.',I3,' -STOP 71'/) CALL ERREXIT(71) 902 CONTINUE IF(KMAX.GT.500) then PRINT'(" ##GBLEVENTS/GBLEVN10 - KMAX TOO BIG = ",I0, $ " - UNABLE TO TRANSFORM GLOBAL SIGMA FILE(S) - STOP 69")', $ KMAX CALL ERREXIT(69) ENDIF C*********************************************************************** C*********************************************************************** C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C USAGE: CALL SPTEZM(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,WAVE,GRID,IDIR) C INPUT ARGUMENTS: C IROMB - INTEGER SPECTRAL DOMAIN SHAPE C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) C MAXWV - INTEGER SPECTRAL TRUNCATION C IDRT - INTEGER GRID IDENTIFIER C (IDRT=4 FOR GAUSSIAN GRID, C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) C IMAX - INTEGER EVEN NUMBER OF LONGITUDES C JMAX - INTEGER NUMBER OF LATITUDES C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM C WAVE - REAL (2*MX,KMAX) WAVE FIELD IF IDIR>0 C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 C GRID - REAL (IMAX,JMAX,KMAX) GRID FIELD (E->W,N->S) IF IDIR<0 C IDIR - INTEGER TRANSFORM FLAG C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) C OUTPUT ARGUMENTS: C WAVE - REAL (2*MX,KMAX) WAVE FIELD IF IDIR<0 C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 C GRID - REAL (IMAX,JMAX,KMAX) GRID FIELD (E->W,N->S) IF IDIR>0 C USAGE: CALL SPTEZMV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, C & WAVED,WAVEZ,GRIDU,GRIDV,IDIR) C INPUT ARGUMENTS: C WAVED - REAL (2*MX,KMAX) WAVE DIVERGENCE FIELD IF IDIR>0 C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 C WAVEZ - REAL (2*MX,KMAX) WAVE VORTICITY FIELD IF IDIR>0 C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 C GRIDU - REAL (IMAX,JMAX,KMAX) GRID U-WIND (E->W,N->S) IF IDIR<0 C GRIDV - REAL (IMAX,JMAX,KMAX) GRID V-WIND (E->W,N->S) IF IDIR<0 C OUTPUT ARGUMENTS: C WAVED - REAL (2*MX,KMAX) WAVE DIVERGENCE FIELD IF IDIR<0 C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 C WAVEZ - REAL (2*MX,KMAX) WAVE VORTICITY FIELD IF IDIR>0 C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 C GRIDU - REAL (IMAX,JMAX,KMAX) GRID U-WIND (E->W,N->S) IF IDIR>0 C GRIDV - REAL (IMAX,JMAX,KMAX) GRID V-WIND (E->W,N->S) IF IDIR>0 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ allocate (cofs_f(mdima,kmaxs,2), cofv_f(mdima,kmax,2,2)) IROMB = 0 MAXWV = JCAP if (idrt < 0 .or. idrt > 256) IDRT = 0 IDIR = 1 IF(KINDX(1).EQ.0) THEN KFILES = 1 ELSE KFILES = 2 ENDIF C Allocate for sigio read C ----------------------- SFCPRESS_ID = MOD(HEAD(1)%IDVM,TEN) THERMODYN_ID = MOD(HEAD(1)%IDVM/TEN,TEN) print *,' sfcpress_id=',sfcpress_id,' thermodyn_id=', $ thermodyn_id DO IFILE=1,KFILES CALL SIGIO_ALDATS(HEAD(IFILE),DATS,IRETS) CALL SIGIO_ALDATM(HEAD(IFILE),ONE,KM4,DATM,IRETS) ! Read surface fields CALL SIGIO_RRDATS(IUNIT4(IFILE),HEAD(IFILE),DATS,IRETS) IF(IRETS.NE.0) THEN print *,' irets from sigio_rrdats = ', irets RETURN ENDIF DO I=1,MDIMA COFS_F(I,1,IFILE) = DATS%HS(I) COFS_F(I,2,IFILE) = DATS%PS(I) ENDDO ! Read fields on levels 1 through kmax CALL SIGIO_RRDATM(IUNIT4(IFILE),HEAD(IFILE),DATM,IRETS) IF(IRETS.NE.0) THEN print *,' irets from sigio_rrdatm = ', irets RETURN ENDIF ccccc print *,' aft sigio_rrdatm irets=',irets IE = KMAX + 2 COFS_F(:,3:IE,IFILE) = DATM%T DO I=1,NTRAC IB = IE + 1 IE = IB + KMAX - 1 COFS_F(:,IB:IE,IFILE) = DATM%Q(:,1:KMAX,I) ENDDO COFV_F(:,:,1,IFILE) = DATM%D COFV_F(:,:,2,IFILE) = DATM%Z CALL SIGIO_AXDATS(DATS,IRETS) CALL SIGIO_AXDATM(DATM,IRETS) ENDDO ccccc print *,' after sigio_axdatm' ALLOCATE (COFS(MDIMA,KMAXS), COFV(MDIMA,KMAX,2)) ALLOCATE (GRDS(imax,jmax,KMAXS), GRDV(imax,jmax,KMAX,2)) ALLOCATE (WRK1(imax*jmax,KMAX), WRK2(imax*jmax,KMAX+1)) IF(KFILES.EQ.1) THEN DO I = 1,MDIMA COFS(I,1:KMAXS) = COFS_f(I,1:KMAXS,1) COFV(I,1:KMAX,1:2) = COFV_f(I,1:KMAX,1:2,1) ENDDO ELSE COFS= $ ((ABS(KINDX(2))*COFS_f(:,:,1)) +(KINDX(1)*COFS_f(:,:,2)))/3. COFV= $ ((ABS(KINDX(2))*COFV_f(:,:,:,1))+(KINDX(1)*COFV_f(:,:,:,2)))/3. ENDIF DEALLOCATE (COFS_F, COFV_F) CALL SPTEZM(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAXS,COFS,GRDS,IDIR) CALL SPTEZMV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, & COFV(1,1,1),COFV(1,1,2),GRDV(1,1,1,1),GRDV(1,1,1,2),IDIR) IF( SFCPRESS_ID == 2 ) THEN ! for enthalpy version GRDS(:,:,2) = 1000.0*GRDS(:,:,2) ! Now in Pa ELSE GRDS(:,:,2) = 1000.0*EXP(GRDS(:,:,2)) ! Now in Pa ENDIF DO NS=1, KMAXS CALL GBLEVN11(IMAX,JMAX,GRDS(1,1,NS)) ENDDO DO J=1,JMAX DO I=1,IMAX IAR12Z(I,J) = GRDS(I,J,1) ! Orography IAR13P(I,J) = GRDS(I,J,2) * 0.01 ! Surface Pressure in hPa ENDDO ENDDO IF(THERMODYN_ID == 3 .AND. IDVC == 3) THEN GRDS(:,:,3:2+KMAX) = GRDS(:,:,3:2+KMAX) / HEAD(1)%CPI(1) print *,' cpi(0)=',head(1)%cpi(1) ENDIF CALL SIGIO_MODPR(IMJM4,IMJM4,KM4,NVCOORD,IDVC,IDSL,VCOORD,IRET, $ GRDS(1,1,2),GRDS(1,1,3),PM=WRK1,PD=WRK2(1,2)) DO J=1,JMAX JJ = (J-1)*IMAX DO I=1,IMAX WRK2(I+JJ,1) = GRDS(I,J,2) ! in Pa ENDDO ENDDO DO L=1,KMAX WRK2(:,L+1) = WRK2(:,L) - WRK2(:,L+1) ! in Pa ENDDO ccccc print *,' wrk1=',wrk1(1001,:) ccccc print *,' wrk2=',wrk2(1001,:) ccccc CALL GBLEVN11(IMAX,JMAX,WRK2(1,KMAX+1)) ccccc DO L=1,KMAX ccccc CALL GBLEVN11(IMAX,JMAX,WRK1(1,L)) ccccc CALL GBLEVN11(IMAX,JMAX,WRK2(1,L)) ccccc ENDDO IF(THERMODYN_ID == 3 .AND. IDVC == 3) THEN ! Convert from enthalpy to temperature GRDS(:,:,3:2+KMAX) = GRDS(:,:,3:2+KMAX) * HEAD(1)%CPI(1) CALL SIGIO_CNVTDV(IMJM4,IMJM4,KM4,IDVC,IDVM,NTRAC,IRET, $ GRDS(1,1,3),GRDS(1,1,3+KMAX),HEAD(1)%CPI,1_4) ! Convert back to virtual temperature GRDS(:,:,3:KMAX+2) = GRDS(:,:,3:KMAX+2) * $ (1.+(461.50/287.05-1)*GRDS(:,:,3+KMAX:2+KMAX*2)) ENDIF DO L=1,KMAX DO K=1,2 CALL GBLEVN11(IMAX,JMAX,GRDV(1,1,L,K)) ENDDO DO J=1,JMAX JJ = (J-1)*IMAX DO I=1,IMAX IAR14T(I,J,L) = GRDS(I,J,2+L) ! Temp (virtual) IAR15U(I,J,L) = GRDV(I,J,L,1) ! U component IAR16V(I,J,L) = GRDV(I,J,L,2) ! V component ! specific humidity IAR17Q(I,J,L) = MAX(0.0,GRDS(I,J,2+KMAX+L)*1.0E6) IARPSL(I,J,L) = WRK1(I+JJ,L)*0.01 ! 3D layer pres(hPa) ENDDO ENDDO ENDDO DO L=1,KMAX+1 DO J=1,JMAX JJ = (J-1)*IMAX DO I=1,IMAX IARPSI(I,J,L) = WRK2(I+JJ,L)*0.01 ! 3D interface pressure ! (hPa) ENDDO ENDDO ENDDO ccccc print *,' iar14t=',iar14t(1,80,:) ccccc print *,' iar15u=',iar15u(1,80,:) ccccc print *,' iar16v=',iar16v(1,80,:) ccccc print *,' iarpsi=',iarpsi(1,80,:) ccccc print *,' iarpsl=',iarpsl(1,80,:) DEALLOCATE (COFS, COFV) DEALLOCATE (GRDS, GRDV, WRK1, WRK2) print *,' RETURNING from GBLENV10' RETURN END C*********************************************************************** C*********************************************************************** subroutine gblevn11(imax,jmax,grid) ! formerly subroutine n_s_swap implicit none integer imax, jmax real grid(imax,jmax) real temp (imax) integer i, j, jj do j=1,jmax/2 jj = jmax-j+1 do i=1,imax temp(i) = grid(i,j) grid(i,j) = grid(i,jj) grid(i,jj) = temp(i) enddo enddo return end