C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: GBLEVENTS PRE/POST PROCESSING OF PREPBUFR EVENTS
C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2007-09-14
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
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 DOVTMP & ADPUPA_VIRT:
C DOVTMP - WRITE VIRTUAL TEMPERATURE EVENT 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 ENCODE IT AS A STACKED EVENT IN THE PREPBUFR FILE.
C FOR RASS REPORTS THIS WILL JUST ENCODE THE REPORTED
C TEMPERATURE AS A STACKED EVENT IN THE PREPBUFR FILE
C SINCE THE REPORTED TEMPERATURE IS ALREADY VIRTUAL.
C DOVTMP = .TRUE. ---> YES (DEFAULT)
C DOVTMP = .FALSE. ---> NO
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 DOANLS IS TRUE.)
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
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,NBAK
!INTEGER*4 IDVC,IDSL,NVCOORD,SFCPRESS_ID,THERMODYN_ID
REAL (KIND=8), ALLOCATABLE :: IAR14T(:,:,:), IAR15U(:,:,:),
$ IAR16V(:,:,:), IAR17Q(:,:,:),
$ IARPSI(:,:,:), IARPSL(:,:,:),
$ IAR12Z(:,:), IAR13P(:,:)
REAL (KIND=4), ALLOCATABLE :: iarps(:,:,:),iarzs(:,:,:)
REAL (KIND=4), ALLOCATABLE :: iarqq(:,:,:,:),iartt(:,:,:,:)
REAL (KIND=4), ALLOCATABLE :: iaruu(:,:,:,:),iarvv(:,:,:,:)
REAL (KIND=4), ALLOCATABLE :: iarzi(:,:,:,:),iarzl(:,:,:,:)
REAL (KIND=4), ALLOCATABLE :: iarpi(:,:,:,:),iarpl(:,:,:,:)
REAL (KIND=4), ALLOCATABLE :: VCOORD(:,:)
REAL (KIND=4), ALLOCATABLE :: slats(:)
REAL(4) DLAT,DLON,TSPAN,stnelev
REAL(8) XYT(3,255),OBX(15,255),bmiss/10E10/
INTEGER, PARAMETER :: idrt=4
logical rsfc,fits,obl
END MODULE GBLEVN_MODULE
SUBROUTINE GBLEVENTS(IDATEP,IUNITF,IUNITE,IUNITP,IUNITS,SUBSET,
$ NEWTYP)
USE GBLEVN_MODULE
!!INTEGER, PARAMETER :: IM=384 , JM=190 ! im==384,768,1152
!!INTEGER, PARAMETER :: IM=1152, JM=IM/2+1 ! im==384,768,1152
!!INTEGER, PARAMETER :: IM=1536, JM=IM/2+1 ! im==384,768,1152
!!INTEGER, PARAMETER :: IM=1760, JM=880 ! im==384,768,1152
INTEGER :: IM=0000, JM=000 ! gets latb,lonb from the sigma files
CHARACTER*255 parm
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
INTEGER IUNITF
COMMON /GBEVAA/ SID,OBS(15,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
COMMON /GBEVDD/ ERRS(300,33,6)
SAVE
DATA IFIRST/0/
DATA HEADR /
$ 'SID XOB YOB DHR TYP ELV '/
DATA OBSTR /
$ 'POB QOB TOB ZOB UOB VOB PWO PW1O PW2O PW3O PW4O CAT PRSS TVO'/
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,nbax,span,fits,rsfc
include "mpif.h"
C----------------------------------------------------------------------
C----------------------------------------------------------------------
C -------------------------------
C FIRST TIME IN DO A FEW THINGS...
C -------------------------------
IF(IFIRST.EQ.0) THEN
!BMISS INITIALIZED IN PREVENT MAIN PROGRAM
call mpi_comm_rank(MPI_COMM_WORLD,myid,ierr)
IFIRST = 1
if(myid==0)PRINT 700
700 FORMAT(/1X,100('#')/' =====> SUBROUTINE GBLEVENTS INVOKED FOR ',
$ 'THE FIRST TIME - VERSION LAST UPDATED 2007-09-14'/)
print*,'JSW---myid=',myid
C INITIALIZE NAMELIST SWITCHES TO DEFAULT VALUES
C ----------------------------------------------
DOVTMP = .TRUE.
DOFCST = .TRUE.
SOME_FCST = .TRUE.
DOBERR = .TRUE.
DOANLS = .FALSE.
QTOP_REJ = 300.
SATMQC = .FALSE.
ADPUPA_VIRT = .FALSE.
nbax = 1
span = 0
rsfc = .true.
fits = .true.
c open and/or read parmfile with namelist override values
c -------------------------------------------------------
NARG=IARGC(); IF(NARG==0) goto 100 ! try to read stdin
call getarg(1,parm); parm = TRIM(parm)//CHAR(0)
open(5,file=parm) ! open parm in lieu of stdin
100 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.or.fits) THEN
DOVTMP = .FALSE.
SOME_FCST = .FALSE.
DOBERR = .FALSE.
ADPUPA_VIRT = .FALSE.
fits = .true.
ENDIF
IF(DOANLS) dofcst=.false.
if(myid==0) WRITE (6,PREVDATA)
FCST = DOFCST
VIRT = .FALSE.
nbak=nbax;tspan=span ! move nl vals to module level
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(myid==0) then
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
endif
IF(DOFCST .OR. SOME_FCST .OR. DOANLS) then
iunitf=20
CALL SELECTFILE(IUNITF,INPTYP)
if(inptyp==0) call bort('bad inptyp from selectfile')
rsfc=(rsfc.and.inptyp==1)
DO KBAK=1,NBAK
if(kbak==myid+1) then
IUNITF=KBAK+19
idhr=tspan*(kbak-(nbak+1)/2)
CALL ADDATE(IDATEP,idhr,IDATEC)
if(kbak==4) idatec=idatep
if(inptyp==1) CALL GBLEVN10(IUNITF,IDATEC,IM,JM,kbak)
if(inptyp==2) CALL GBLEVN10nems(IUNITF,IDATEC,IM,JM,kbak)
if(inptyp==3) CALL GBLEVN10netc(IUNITF,IDATEC,IM,JM,kbak)
if(myid==0 ) call prttime('gblevn10')
if(inptyp==1) CALL GBLEVN12(KBAK) ! copies one background time level to hterpt arrays
if(myid==0 ) call prttime('gblevn12')
endif
lug=kbak+29
if(rsfc) call readsf(lug,idatec,kbak) ! read surface fields
ENDDO
!at this barrier broadcast backgrounds to comm world
!print*,'myid=',myid,' into barrier'
call mpicast
if(myid==0) call prttime('mpicast')
ENDIF
if(nbax==4)then
call comp_amf
nbak=3
endif
IF('KILL'=='KILL')THEN
!if(myid==0)CALL W3TAGE('PREPOBS_PREVENTS')
!call mpi_finalize(mret)
!stop
ENDIF
IF(DOBERR) THEN
C IF REQUESTED, READ ERROR FILES (ONLY POSSIBLE IN PREVENTS MODE)
C ---------------------------------------------------------------
if(myid==0)PRINT 702
702 FORMAT(/' --> GBLEVENTS: READ ERROR FILES'/)
CALL GBLEVN01(IUNITE)
ELSE
ERRS = 0
IF(myid==0.and..NOT.DOANLS) PRINT 3702
3702 FORMAT(/' --> GBLEVENTS: OBS. ERROR NOT ENCODED IN PREPBUFR ',
$ '(BY CHOICE)'/)
ENDIF
if(myid==0)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.and.myid==0) WRITE(IUNITS,1701) IDATEP
1701 FORMAT(//130('#')//38X,'*** "PREVENT" EVENTS DATA FILTERING ',
$ 'SUMMARY ***'/35X,'--> CENTER DATE FOR PREPBUFR FILE IS: ',I10,
$ ' <--'//)
C----------------------------------------------------------------------
C----------------------------------------------------------------------
if(subset=='NONE')return ! this for call before reading any bufr
ENDIF
C OBTAIN NECESSARY PROGRAM CODES (ONLY USED IN PREVENTS MODE)
C -----------------------------------------------------------
CALL UFBQCD(IUNITP,'PREVENT',PVCD)
CALL UFBQCD(IUNITP,'VIRTMP ',VTCD)
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 = (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)) THEN
IF(NEWTYP.EQ.1) WRITE(IUNITS,1703)
1703 FORMAT(/' ==> DATA FILTERING NOT PERFORMED FOR THIS TABLE A ',
$ 'ENTRY -- FORECAST, OBS ERROR, "VIRTMP" 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 ----------------------------------------------------------------
!print*,'into main'
CALL UFBINT(-IUNITP,OBS,15,255,NLEV,OBSTR); !print*,'after read1'
CALL UFBINT(-IUNITP,QMS,12,255,NLEV,QMSTR); !print*,'after read2'
CALL UFBINT(-IUNITP,HDR,10, 1,IRET,HEADR); !print*,'after read3'
SID = HDR(1)
XOB = HDR(2)
YOB = HDR(3)
DHR = HDR(4)
TYP = HDR(5)
stnelev = hdr(6)
CALL UFBINT(-IUNITP,XYT,3,255,IRET,'XDR YDR HRDR')
!print*,'after read4'
C -----------------------------------------------------------------
C PREVENTS MODE: ENCODE FIRST GUESS VALUES INTO PREPBUFR FILE
C and return if fits mode
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 -----------------------------------------------------------------
IF(FCST.OR.DOANLS) THEN
if(nbak==2) CALL GBLEVN03(SUBSET)
if(nbak/=2) CALL GBLEVN35(SUBSET)
IF(NLEV.GT.0) THEN
IF(FCST) THEN
CALL UFBINT(IUNITP,BAK,12,NLEV,IRET,FCSTR)
IF(FITS) RETURN
ELSE
CALL UFBINT(IUNITP,BAK,12,NLEV,IRET,ANSTR)
RETURN
ENDIF
ENDIF
ENDIF
!print*,myid,'after gb35'
C --------------------------------------------------------------------
C LOGIC FROM HERE ON PERTAINS ONLY TO PREVENTS MODE OF THIS SUBROUTINE
C --------------------------------------------------------------------
IF(DOBERR) THEN
C ENCODE OBSERVATION ERRORS INTO REPORT
C -------------------------------------
CALL GBLEVN04 ;!print*,'after gblevn04'
IF(NLEV.GT.0) CALL UFBINT(IUNITP,BAK,12,NLEV,IRET,OESTR)
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(.NOT.DOBERR) THEN
IF(NEWTYP.EQ.1) WRITE(IUNITS,1705)
1705 FORMAT(/' ==> FILTERING VIA MISSING OBS ERROR TEST NOT POSSIBLE',
$ ' FOR THIS TABLE A ENTRY SINCE OBS ERROR VALUES NOT PROCESSED/',
$ 'STORED'/)
ENDIF
CALL GBLEVN02(IUNITP,IUNITS,NEWTYP); !print*,'after gblevn02'
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); !print*,'after gblevn08'
ENDIF
C RETURN TO CALLING PROGRAM TO WRITE GBL-EVENTED REPORT (SUBSET) INTO
C PREPBUFR FILE
C -------------------------------------------------------------------
RETURN
END
c-----------------------------------------------------------------------
c-----------------------------------------------------------------------
MODULE READSF_MODULE
IMPLICIT NONE
SAVE
INTEGER ni,nj,jg,kg,nsfc
integer,allocatable::nin(:)
REAL(4),allocatable::f10(:,:,:)
REAL(4),allocatable::slat(:),wlat(:),sfclat(:)
REAL(4) x1,x2,y1,y2,dx,dy
DATA jg/1000000/
data nsfc/11/
END MODULE READSF_MODULE
c-----------------------------------------------------------------------
c-----------------------------------------------------------------------
subroutine readsf(lug,idateg,kbac)
use gblevn_module
use readsf_module
use sfcio_module, only: sfcio_intkind,sfcio_head,sfcio_data,
. sfcio_srohdc,sfcio_axdata
character(24) filename
real(4),allocatable::work(:,:,:)
type(sfcio_head):: sfc_head
type(sfcio_data):: sfc_data
c-----------------------------------------------------------------------
c-----------------------------------------------------------------------
write(filename,'("fort.",i2.2)')lug
! Read surface file
call sfcio_srohdc(lug,filename,sfc_head,sfc_data,irets)
!print*,lug,filename,irets
! Check for possible problems
if (irets /= 00000) then
write(6,*)'READ_GFSSFC: ***ERROR*** problem reading ',filename,
. ', irets=',irets
call sfcio_axdata(sfc_data,irets)
stop
endif
latb=sfc_head%latb
lonb=sfc_head%lonb
if(kbac==1) allocate(f10(lonb,latb,nbak),nin(latb))
! Load surface fields into local work array
allocate(work(lonb,latb,nsfc)); work=0
do j=1,latb
do i=1,lonb
work(i,j,1) = sfc_data%tsea(i,j) ! skin temperature
work(i,j,2) = sfc_data%smc(i,j,1) ! soil moisture
work(i,j,3) = sfc_data%sheleg(i,j) ! snow depth
work(i,j,4) = sfc_data%stc(i,j,1) ! soil temperature
work(i,j,5) = sfc_data%slmsk(i,j) ! sea/land/ice mask
work(i,j,6) = sfc_data%vfrac(i,j) ! vegetation cover
work(i,j,7) = sfc_data%f10m(i,j) ! 10m wind factor
work(i,j,8) = sfc_data%vtype(i,j) ! vegetation type
work(i,j,9) = sfc_data%stype(i,j) ! soil type
work(i,j,10) = sfc_data%zorl(i,j) ! surface roughness length (cm)
work(i,j,11) = sfc_data%orog(i,j) ! terrain
end do
end do
f10(:,:,kbac)=work(:,:,7)
c save grid parameters first time through
if(kbac==1) then
!print*,'readsf',latb,lonb
do i=1,latb/2; j=latb+1-i
nin(i)=sfc_head%lpl(i)
nin(j)=sfc_head%lpl(i);!print*,i,nin(i),j,nin(j)
enddo
ni=lonb; nj=latb; rad2deg=180./acos(-1.)
allocate(slat(latb),wlat(latb),sfclat(latb))
call splat(4,latb,slat,wlat)
sfclat(:)=asin(slat)*rad2deg
deallocate(slat,wlat)
endif
! normal exit
!print*,'from readsf',kpds(5),kg,iret
!print*,kgds(2) ,' - N(I) NR POINTS ON LATITUDE CIRCLE'
!print*,kgds(3) ,' - N(J) NR POINTS ON LONGITUDE MERIDIAN'
!print*,kgds(4) ,' - LA(1) LATITUDE OF ORIGIN'
!print*,kgds(5) ,' - LO(1) LONGITUDE OF ORIGIN'
!print*,kgds(6) ,' - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17)'
!print*,kgds(7) ,' - LA(2) LATITUDE OF EXTREME POINT'
!print*,kgds(8) ,' - LO(2) LONGITUDE OF EXTREME POINT'
!print*,kgds(9) ,' - DI LONGITUDINAL DIRECTION OF INCREMENT'
!print*,kgds(10),'- DJ LATITUDINAL DIRECTION INCREMENT'
!print*,kgds(11),'- SCANNING MODE FLAG (RIGHT ADJ COPY OF )'
deallocate(work)
return
900 print*,iret,' reading ',jpds(5),jpds(6),jpds(7),jg,kg,kgx
call bort('readsl - error from getgb')
end
C-----------------------------------------------------------------------
C SUBROUTINE HTERPSF - Surface 3D LINEAR INTERPOLATION IN X,Y,T
C-----------------------------------------------------------------------
SUBROUTINE HTERPSF(XOB,YOB,DHR,GRID,TERP)
USE GBLEVN_MODULE
USE READSF_MODULE
integer ibk
REAL GRID(NI,NJ,NBAK),TERP
REAL xob,yob,dhr,bak1,bak2
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
C CALCULATE interpolation parameters for x,y,t
C --------------------------------------------
idir=-1; !sign(1.,y1)
wy=yob;call grdcrd(wy,1,sfclat,nj,idir)
J0 = WY
J1 = MIN(J0+1,NJ)
WY = WY-J0
DX0 = 360./FLOAT(NIN(J0))
WX0 = XOB/DX0 + 1.0
I00 = WX0
I01 = MOD(I00,NIN(J0)) + 1
WX0 = WX0-I00
DX1 = 360./FLOAT(NIN(J1))
WX1 = XOB/DX1 + 1.0
I10 = WX1
I11 = MOD(I10,NIN(J1)) + 1
WX1 = WX1-I10
call tterp(dhr,ibk,twt)
c interpolate from grid in space and time
c ---------------------------------------
DO I=IBK,IBK+1; N=MIN(I,NBAK)
P1 = GRID(I00,J0,N)
P2 = GRID(I01,J0,N)
P3 = GRID(I10,J1,N)
P4 = GRID(I11,J1,N)
P5 = P1+(P2-P1)*WX0
P6 = P3+(P4-P3)*WX1
if(i==ibk) bak1 = P5 + (P6-P5)*WY
if(i/=ibk) bak2 = P5 + (P6-P5)*WY
enddo
terp = bak1+(bak2-bak1)*twt
RETURN
END
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: ADDATE
C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06
C
C ABSTRACT: THIS SUBROUTINE UPDATES AN EIGHT (YYMMDDHH) OR TEN
C (YYYYMMDDHH) DIGIT INTEGER DATE BY A SPECIFIED NUMBER OF HOURS.
C IT MAY BE REMOVED FROM THE BUFR ARCHIVE LIBRARY IN A FUTURE VERSION,
C SINCE IT IS NO LONGER CALLED BY ANY BUFR ARCHIVE LIBRARY ROUTINES
C AND SINCE THE SAME LOGIC IS AVAILABLE IN THE NCEP W3 LIBRARY
C (E.G. SUBROUTINE W3MOVDAT). USERS SHOULD MIGRATE TO THE USE OF
C THE NCEP W3 LIBRARY INSTEAD.
C
C PROGRAM HISTORY LOG:
C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR
C 1996-12-11 J. WOOLLEN -- NEW DATE ARITHMETIC ROUTINE ADDED
C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE
C INTERDEPENDENCIES
C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED
C DOCUMENTATION (INCLUDING HISTORY)
C 2004-08-18 J. ATOR -- FIX BUG FOR YEARS THAT ARE MULTIPLE
C OF 100 BUT NOT OF 400
C 2009-03-23 J. ATOR -- MARKED AS OBSOLETE AND ADDED PRINT
C NOTIFICATION USING ERRWRT
C
C USAGE: CALL ADDATE (IDATE, JH, JDATE)
C INPUT ARGUMENT LIST:
C IDATE - INTEGER: EIGHT- OR TEN-DIGIT DATE
C JH - INTEGER: NUMBER OF HOURS (+ OR -) BY WHICH IDATE
C SHOULD BE UPDATED
C
C OUTPUT ARGUMENT LIST:
C JDATE - INTEGER: EIGHT- OR TEN-DIGIT UPDATED DATE
C
C REMARKS:
C THIS ROUTINE CALLS: ERRWRT
C THIS ROUTINE IS CALLED BY: None
C Normally called only by application
C programs (W3LIB routine W3MOVDAT is
C much better).
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: PORTABLE TO ALL PLATFORMS
C
C$$$
SUBROUTINE ADDATE(IDATE,JH,JDATE)
COMMON /QUIET / IPRT
DIMENSION MON(12)
CHARACTER*128 ERRSTR
DATA MON/31,28,31,30,31,30,31,31,30,31,30,31/
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
IY = IDATE/1000000
IM = MOD(IDATE/10000 ,100)
ID = MOD(IDATE/100 ,100)
IH = MOD(IDATE ,100)
IH = IH+JH
IF(MOD(IY,4).EQ.0) MON(2) = 29
IF(MOD(IY,100).EQ.0) MON(2) = 28
IF(MOD(IY,400).EQ.0) MON(2) = 29
1 IF(IH.LT.0) THEN
IH = IH+24
ID = ID-1
IF(ID.EQ.0) THEN
IM = IM-1
IF(IM.EQ.0) THEN
IM = 12
IY = IY-1
IF(IY.LT.0) IY = 99
ENDIF
ID = MON(IM)
ENDIF
GOTO 1
ELSEIF(IH.GE.24) THEN
IH = IH-24
ID = ID+1
IF(ID.GT.MON(IM)) THEN
ID = 1
IM = IM+1
IF(IM.GT.12) THEN
IM = 1
IY = IY+1
IF(IY.EQ.100) IY = 00
ENDIF
ENDIF
GOTO 1
ENDIF
JDATE = IY*1000000 + IM*10000 + ID*100 + IH
RETURN
END
c-------------------------------------------------------------------------------------
c compute the analysis increment to adjust time interpolated guess to analysed values
c-------------------------------------------------------------------------------------
subroutine comp_amf
USE GBLEVN_MODULE
USE READSF_MODULE
! compute the analysis increments
iarzs(:,:,4) = iarzs(:,:,4)-iarzs(:,:,2)
iarps(:,:,4) = iarps(:,:,4)-iarps(:,:,2)
iarqq(:,:,:,4) = iarqq(:,:,:,4)-iarqq(:,:,:,2)
iartt(:,:,:,4) = iartt(:,:,:,4)-iartt(:,:,:,2)
iaruu(:,:,:,4) = iaruu(:,:,:,4)-iaruu(:,:,:,2)
iarvv(:,:,:,4) = iarvv(:,:,:,4)-iarvv(:,:,:,2)
iarpl(:,:,:,4) = iarpl(:,:,:,4)-iarpl(:,:,:,2)
iarzl(:,:,:,4) = iarzl(:,:,:,4)-iarzl(:,:,:,2)
f10(:,:,4) = f10(:,:,4)-f10(:,:,2)
! increment the background fields to the analysis
do i=1,3
iarzs(:,:,i) = iarzs(:,:,i)+iarzs(:,:,4)
iarps(:,:,i) = iarps(:,:,i)+iarps(:,:,4)
iarqq(:,:,:,i) = iarqq(:,:,:,i)+iarqq(:,:,:,4)
iartt(:,:,:,i) = iartt(:,:,:,i)+iartt(:,:,:,4)
iaruu(:,:,:,i) = iaruu(:,:,:,i)+iaruu(:,:,:,4)
iarvv(:,:,:,i) = iarvv(:,:,:,i)+iarvv(:,:,:,4)
iarpl(:,:,:,i) = iarpl(:,:,:,i)+iarpl(:,:,:,4)
iarzl(:,:,:,i) = iarzl(:,:,:,i)+iarzl(:,:,:,4)
f10(:,:,i) = f10(:,:,i)+f10(:,:,4)
enddo
return
end
c-----------------------------------------------------------------------------------
c-----------------------------------------------------------------------------------
subroutine prttime(title)
character(*) title
data t0/0.00/
data t1/0.00/
data t2/0.00/
save t0,t1,t2
if(t0==0.00)then
call system_clock(ic,ir,im); t0=float(ic)/float(ir)
call system_clock(ic,ir,im); t1=float(ic)/float(ir)
endif
call system_clock(ic,ir,im); t2=float(ic)/float(ir)
print1,title,t2-t1,t2-t0
call system_clock(ic,ir,im); t1=float(ic)/float(ir)
1 format('time>>>',a8,3(2x,f8.2))
return
end