C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: GBLEVENTS PRE/POST PROCESSING OF PREPBUFR EVENTS C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2010-01-29 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 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 W3LIB - W3MOVDAT ERREXIT C BUFRLIB - UFBINT UFBQCD 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 WILL NOT WORK CORRECTLY IN THE w3_8 LIBRARY. C PLEASE COMPILE APPLICATION CODE USING w3_4 OR w3_d LIBRARIES. 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 RUC VERSION SINCE IT DOES NOT REQUIRE OBSERVATIONAL C ERRORS TO BE PRESENT IN THE PREPBUFR FILE. THE GSI WILL C REQUIRE THE OBS ERROR IN THE PREPBUFR FILE FOR THE ETA, C UNLIKE THE 3DVAR WHICH DID NOT.) 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: IBM-SP 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,QMS,BAK,SID,HDR(10) LOGICAL DOVTMP,DOFCST,SOME_FCST,DOBERR,FCST,VIRT,DOANLS, $ SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV DIMENSION IUNITF(2) COMMON /GBEVAA/ SID,OBS(13,255),QMS(12,255),BAK(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) 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 2010-01-29'/) 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,13,255,NLEV,OBSTR) CALL UFBINT(-IUNITP,QMS,12,255,NLEV,QMSTR) CALL UFBINT(-IUNITP,HDR,10, 1,IRET,HEADR) SID = HDR(1) XOB = HDR(2) YOB = HDR(3) DHR = HDR(4) TYP = HDR(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,12,NLEV,IRET,FCSTR) ELSE CALL UFBINT(IUNITP,BAK,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,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(4,255),QEV(4,255),TEV(4,255),WEV(5,255), $ PWV(4,255),PW1V(4,255),PW2V(4,255),PW3V(4,255), $ PW4V(4,255),OBS,QMS,BAK,SID 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 COMMON /GBEVAA/ SID,OBS(13,255),QMS(12,255),BAK(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) EQUIVALENCE (SID,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 BMISS /10E10/,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 = BMISS QEV = BMISS TEV = BMISS WEV = BMISS PWV = BMISS PW1V = BMISS PW2V = BMISS PW3V = BMISS PW4V = 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( 1,L) QOB = OBS( 2,L) TOB = OBS( 3,L) UOB = OBS( 5,L) VOB = OBS( 6,L) PWO = OBS( 7,L) PW1O = OBS( 8,L) PW2O = OBS( 9,L) PW3O = OBS(10,L) PW4O = OBS(11,L) CAT = OBS(12,L) PRSS = OBS(13,L) PQM = QMS( 1,L) QQM = QMS( 2,L) TQM = QMS( 3,L) ZQM = QMS( 4,L) WQM = QMS( 5,L) PWQ = QMS( 6,L) PW1Q = QMS( 7,L) PW2Q = QMS( 8,L) PW3Q = QMS( 9,L) PW4Q = QMS(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(1,L) = POB PEV(2,L) = REJ PEV(3,L) = PVCD PEV(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(1,L) = POB PEV(2,L) = REJ PEV(3,L) = PVCD PEV(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(1,L) = TOB TEV(2,L) = REJ TEV(3,L) = PVCD TEV(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(1,L) = QOB QEV(2,L) = REJ QEV(3,L) = PVCD QEV(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(1,L) = UOB WEV(2,L) = VOB WEV(3,L) = REJ WEV(4,L) = PVCD WEV(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(1,L) = PWO PWV(2,L) = 9 PWV(3,L) = PVCD PWV(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(1,L) = PW1O PW1V(2,L) = 9 PW1V(3,L) = PVCD PW1V(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(1,L) = PW2O PW2V(2,L) = 9 PW2V(3,L) = PVCD PW2V(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(1,L) = PW3O PW3V(2,L) = 9 PW3V(3,L) = PVCD PW3V(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(1,L) = PW4O PW4V(2,L) = 9 PW4V(3,L) = PVCD PW4V(4,L) = 3 MAXPW4V = L ENDIF ENDIF ENDIF ENDDO ENDIF C APPLY THE PROPER EVENTS C ----------------------- IF(MAXPEV .GT.0) CALL UFBINT(IUNITP,PEV, 4,MAXPEV, IRET,PEVN) IF(MAXQEV .GT.0) CALL UFBINT(IUNITP,QEV, 4,MAXQEV, IRET,QEVN) IF(MAXTEV .GT.0) CALL UFBINT(IUNITP,TEV, 4,MAXTEV, IRET,TEVN) IF(MAXWEV .GT.0) CALL UFBINT(IUNITP,WEV, 5,MAXWEV, IRET,WEVN) IF(MAXPWV .GT.0) CALL UFBINT(IUNITP,PWV, 4,MAXPWV, IRET,PWVN) IF(MAXPW1V.GT.0) CALL UFBINT(IUNITP,PW1V,4,MAXPW1V,IRET,PW1VN) IF(MAXPW2V.GT.0) CALL UFBINT(IUNITP,PW2V,4,MAXPW2V,IRET,PW2VN) IF(MAXPW3V.GT.0) CALL UFBINT(IUNITP,PW3V,4,MAXPW3V,IRET,PW3VN) IF(MAXPW4V.GT.0) CALL UFBINT(IUNITP,PW4V,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,QMS,BAK,SID CHARACTER*8 SUBSET COMMON /GBEVAA/ SID,OBS(13,255),QMS(12,255),BAK(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) DATA BMISS / 10E10 / DATA TZERO / 273.15 / DATA BETAP / .0552 / DATA BETA / .00650 / DATA ROG / 29.261 / C CLEAR THE BACKGROUND EVENT ARRAY C -------------------------------- BAK = 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( 1,L) QOB = OBS( 2,L) TOB = OBS( 3,L) ZOB = OBS( 4,L) UOB = OBS( 5,L) VOB = OBS( 6,L) PWO = OBS( 7,L) PW1O = OBS( 8,L) PW2O = OBS( 9,L) PW3O = OBS(10,L) PW4O = OBS(11,L) CAT = OBS(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(1,L) = PFC BAK(2,L) = QOB BAK(3,L) = TOB BAK(4,L) = ZOB BAK(5,L) = UOB BAK(6,L) = VOB BAK(7,L) = PWO BAK(8,L) = PW1O BAK(9,L) = PW2O BAK(10,L) = PW3O BAK(11,L) = PW4O BAK(12,L) = RHO 10 ENDDO ENDIF RETURN END C*********************************************************************** C*********************************************************************** SUBROUTINE GBLEVN04 ! FORMERLY SUBROUTINE GETOE DIMENSION OEMIN(2:6) REAL(8) OBS,QMS,BAK,SID COMMON /GBEVAA/ SID,OBS(13,255),QMS(12,255),BAK(12,255),XOB, $ YOB,DHR,TYP,NLEV DATA BMISS /10E10/ DATA OEMIN /0.5,0.1,1.0,0.5,1.0/ C CLEAR THE EVENT ARRAY C --------------------- BAK = BMISS C LOOP OVER LEVELS LOOKING UP THE OBSERVATION ERROR C ------------------------------------------------- IF(NLEV.GT.0) THEN DO L=1,NLEV POB = OBS( 1,L) QOB = OBS( 2,L) TOB = OBS( 3,L) WOB = MAX(OBS(5,L),OBS(6,L)) PWO = OBS( 7,L) PW1O = OBS( 8,L) PW2O = OBS( 9,L) PW3O = OBS(10,L) PW4O = OBS(11,L) CAT = OBS(12,L) IF(CAT .EQ.0 ) BAK( 1,L) = OEFG01(POB,TYP,5,OEMIN(5)) IF(QOB .LT.BMISS) BAK( 2,L) = OEFG01(POB,TYP,3,OEMIN(3)) IF(TOB .LT.BMISS) BAK( 3,L) = OEFG01(POB,TYP,2,OEMIN(2)) IF(WOB .LT.BMISS) BAK( 5,L) = OEFG01(POB,TYP,4,OEMIN(4)) IF(PWO .LT.BMISS) BAK( 6,L) = OEFG01(POB,TYP,6,OEMIN(6)) IF(PW1O.LT.BMISS) BAK( 7,L) = OEFG01(POB,TYP,6,OEMIN(6)) IF(PW2O.LT.BMISS) BAK( 8,L) = OEFG01(POB,TYP,6,OEMIN(6)) IF(PW3O.LT.BMISS) BAK( 9,L) = OEFG01(POB,TYP,6,OEMIN(6)) IF(PW4O.LT.BMISS) BAK(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: IBM-SP C C$$$ FUNCTION OEFG01(P,TYP,IE,OEMIN) COMMON /GBEVDD/ERRS(300,33,6) OEFG01 = 10E10 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 = 1.E11 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 10E10 C -------------------------------- IF(OEFG01.GE.5E5) OEFG01 = 10E10 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: IBM-SP C C$$$ SUBROUTINE GBLEVN08(IUNITP,SUBSET) ! FORMERLY SUBROUTINE VTPEVN CHARACTER*80 EVNSTQ,EVNSTV CHARACTER*8 SUBSET REAL(8) TDP(255),TQM(255),QQM(255),BAKQ(4,255),BAKV(4,255), $ OBS,QMS,BAK,SID LOGICAL EVNQ,EVNV,DOVTMP,TROP,ADPUPA_VIRT,DOBERR,DOFCST, $ SOME_FCST COMMON /GBEVAA/ SID,OBS(13,255),QMS(12,255),BAK(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 DATA EVNSTQ /'QOB QQM QPC QRC'/ DATA EVNSTV /'TOB TQM TPC TRC'/ DATA BMISS /10E10/ 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 = BMISS BAKV = BMISS TROP = .FALSE. C GET DEWPOINT TEMPERATURE AND CURRENT T,Q QUALITY MARKERS C -------------------------------------------------------- CALL UFBINT(-IUNITP,TDP,1,255,NLTD,'TDO') CALL UFBINT(-IUNITP,QQM,1,255,NLQQ,'QQM') CALL UFBINT(-IUNITP,TQM,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(1,L) TDO = TDP(L) TOB = OBS(3,L) CAT = OBS(12,L) IF(DOVTMP) THEN IF(SUBSET.EQ.'RASSDA '.OR.SUBSET.EQ.'SATEMP ') THEN IF(TOB.LT.BMISS) THEN BAKV(1,L) = TOB BAKV(2,L) = TQM(L) BAKV(3,L) = VTCD BAKV(4,L) = 3 EVNV = .TRUE. CYCLE ENDIF ENDIF ENDIF IF(POB.LT.BMISS .AND. TOB.LT.BMISS $ .AND. TDO.LT.BMISS) THEN IF(QQM(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) BAKQ(1,L) = QOB*1E6 BAKQ(2,L) = QQM(L) ! Moist qm same as before for re-calc. q BAKQ(3,L) = VTCD BAKQ(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(1,L) = (TOB+273.16)*(1.+.61*QOB)-273.16 BAKV(3,L) = VTCD IF(SUBSET.EQ.'ADPUPA ') THEN C Message type ADPUPA comes here IF((QQM(L).LT.4.OR.QQM(L).EQ.9.OR.QQM(L).EQ.15) $ .OR. TQM(L).EQ.0 .OR. TQM(L).GT.3 $ .OR. POB.LE.700.) THEN BAKV(2,L) = TQM(L) ! Tv qm same as for T when q ok ! or q flagged by PREPRO (but ! not bad) BAKV(4,L) = 0 ! Tv gets unique reason code 0 ELSE BAKV(2,L) = 3 !Tv qm susp for bad moist below 700mb BAKV(4,L) = 6 !Tv gets unique reason code 6 ENDIF ELSE C All other message types come here IF(QQM(L).LT.4) THEN BAKV(2,L) = TQM(L) ! Tv qm same as for T when q ok BAKV(4,L) = 0 ! Tv gets unique reason code 0 ELSE IF((QQM(L).EQ.9.OR.QQM(L).EQ.15).AND.(TQM(L).LE. $ 3.OR.TQM(L).GE.15.OR.TQM(L).EQ.9)) THEN cdak print *, '%%% process tvirt on lvl ',l,' for missing moist obs ', cdak $ 'error/high-up moist case when orig. T not "bad" (set TQM=9)' BAKV(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(4,L) = 4 ! Tv gets unique reason code 4 ELSE cdak print *, '%%% process tvirt on lvl ',l,' for "bad" QQM case or ', cdak $ 'missing moist obs error/high-up moist w/ "bad" TQM case (set ', cdak $ 'TQM=8) BAKV(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(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,4,NLEV,IRET,EVNSTQ) IF(EVNV) CALL UFBINT(IUNITP,BAKV,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 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 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=',idate(:,ifile),' fhour=',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 ',IFILE,'; INITIAL DATE ', $ '(YEAR IS: ',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: ',IDATE(1,IFILE) ENDIF CALL W3MOVDAT((/0.,FHOUR,0.,0.,0./),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) CALL W3MOVDAT((/0.,REAL(KINDX(IFILE)),0.,0., $ 0./),JDATE(:,IFILE),KDATE(:,IFILE)) 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 -------> ',F4.2,' X ',F4.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 = ',KMAX, $ ' - UNABLE',' TO TRANSFORM GLOBAL SIGMA FILE(S) - STOP 69' 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,' cpi(0)=',head(1)%cpi(1) 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) 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