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/ IPVCD,IVTCD
      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'/)

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',IPVCD)
         CALL UFBQCD(IUNITP,'VIRTMP ',IVTCD)

      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 sp_mod, only: splat
      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

