C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    GBLEVENTS_CDAS  PRE/POST PROCESSING OF PREPBUFR EVENTS 
C   PRGMMR: J. Dong          ORG: EMC        DATE: 2020-01-09
C
C ABSTRACT: THIS IS A FROZEN VERSION OF THE 2006-07-14 VERSION OF W3LIB
C   (LATER W3NCO) ROUTINE GBLEVENTS (OTHER THAN CHANGES TO RENAME
C   GBLEVENTS TO GBLEVENTS_CDAS).  IT IS NEEDED TO READ THE CDAS-STYLE
C   SIGMA FIRST GUESS {THE NEW SIGIO VERSION OF W3LIB (LATER W3NCO)
C   ROUTINE GBLEVENTS CANNOT READ THE OLD CDAS-STYLE SIGMA FIRST
C   GUESS}.  THE REMAINDER OF THIS DOCBLOCK IS JUST A COPY FROM THE
C   2006-07-14 VERSION OF ROUTINE GBLEVENTS.
C           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
C AS W3LIB (LATER W3NCO) ROUTINE GBLEVENTS:
C
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 CGBLEVN03.  AS A RESULT OF THIS 
C     CHANGE, SUBROUTINE CGBLEVN07 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 2012-11-20  J. WOOLLEN  INITIAL PORT TO WCOSS 
C
C AS IN-LINE ROUTINE GBLEVENTS_CDAS:
C
C 2007-11-20 D. A. KEYSER -- RENAMED FROZEN 2006-07-14 VERSION OF W3LIB
C     ROUTINE GBLEVENTS TO GBLEVENTS_CDAS AND ADDED AS IN-LINE ROUTINE
C     TO PROGRAM PREPOBS_PREVENTS, IT IS NEEDED TO READ THE CDAS-STYLE
C     SIGMA FIRST GUESS (THE NEW SIGIO VERSION OF W3LIB ROUTINE
C     GBLEVENTS CANNOT READ THE OLD CDAS-STYLE SIGMA FIRST GUESS)
C 2012-11-20  J. WOOLLEN   -- INITIAL PORT TO WCOSS
C 2013-02-13  D. A. KEYSER -- FINAL CHANGES TO RUN ON WCOSS: OBTAINS
C     BUFRLIB MISSING (BMISS) VIA CALL TO GETBMISS RATHER THAN
C     HARDWIRING IT TO 10E10 (10E10 CAN CAUSE INTEGER OVERFLOW ON
C     WCOSS - SEE CALLING PROGRAM FOR MORE INFO); USE FORMATTED PRINT
C     STATEMENTS WHERE PREVIOUSLY UNFORMATTED PRINT WAS > 80
C     CHARACTERS; RENAME ALL REAL(8) VARIABLES AS *_8
C 2014-01-24 JWhiting - added logic to trap input XOB=360.0 values and
C     reset them to zero; left untrapped, this value leads to out of 
C     bounds referencing of IAR_8 array in the CGBLEVN06() subroutine.
C 2017-07-12 D. Keyser - Initializes REJT as TRUE in "RULES FOR
C     TEMPERATURE" section in subroutine cgblevn02 so it will be set in
C     the rare case where TOB is missing and QOB is not missing (since
C     REJT is referenced in the next "RULES FOR SPECIFIC HUMIDITY"
C     section). BENEFIT: Prevents a code failure due to undefined REJT
C     in this case (when full debugging is turned on).
C 2020-01-06  J. Dong -- In subroutine CGBLEVN10, changed the windowing
C     decade from 20 to 40 for cases when the year is represented by
C     2 digits instead of 4.
C
C USAGE:    CALL GBLEVENTS_CDAS(IDATEP,IUNITF,IUNITE,IUNITP,IUNITS,
C          $                    SUBSET,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 FILE (EITHER FIRST GUESS OR ANALYSIS); IF HH IN
C              - IDATEP IS A MULTIPLE OF 3 THEN THIS FILE IS VALID AT
C              - 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 FILE (EITHER FIRST GUESS OR ANALYSIS); IF HH IN
C              - IDATEP IS A MULTIPLE OF 3 THEN THIS FILE IS EMPTY, IF
C              - HH IN IDATEP IS NOT A MULTIPLE OF 3 THEN THIS FILE IS
C              - VALID AT THE CLOSEST TIME AFTER THE DATE IN IDATEP
C              - 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 GUESS (PREVENTS MODE) OR
C              - 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 GUESS (PREVENTS MODE) OR
C              - 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:      CGBLEVN01 CGBLEVN02   CGBLEVN03    CGBLEVN04
C                  CGBLEVN05 CGBLEVN06   OEFG01_C
C                  CGBLEVN08 CGBLEVN09   CGBLEVN10    CGBLEVN11
C                  ZSG01_C   CGBLEVN12   PSG01_C      CGBLEVN13
C                  TG01_C    CGBLEVN14   UG01_C       CGBLEVN15
C                  VG01_C    CGBLEVN16   QG01_C       CGBLEVN17
C     LIBRARY:
C       SPLIB    - SPTEZM   SPTEZMV
C       W3NCO    - W3MOVDAT ERREXIT
C       BUFRLIB  - UFBINT   UFBQCD   GETBMISS
C
C   EXIT STATES:
C     COND =   0 - SUCCESSFUL RUN
C     COND =  60 - OBSERVATION ERROR TABLE EMPTY OR DOES NOT EXIST
C     COND =  61 - VARIABLE NLTD .NE. VARIABLE NLEV
C     COND =  62 - VARIABLE NLTQ .NE. VARIABLE NLEV
C     COND =  63 - VARIABLE NLQQ .NE. VARIABLE NLEV
C     COND =  64 - END OF FILE READING SIGMA FIRST GUESS OR ANALYSIS
C                - - UNABLE TO TRANSFORM FIRST GUESS OR ANALYSIS
C     COND =  65 - ERROR READING FIRST GUESS OR ANALYSIS - UNABLE TO
C                - TRANSFORM FIRST GUESS OR ANALYSIS
C     COND =  66 - VARIABLE IDIM NOT FACTORABLE - UNABLE TO TRANSFORM
C                  FIRST GUESS OR ANALYSIS
C     COND =  67 - BAD OR MISSING FIRST GUESS OR ANALYSIS FILE(S)
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 - VARIABLE IMAX TOO SMALL - UNABLE TO TRANSFORM FIRST
C                - GUESS OR ANALYSIS FILE(S) (NOTE: Effective 9/27/01
C                - this can never occur)
C     COND =  71 - ONE OR MORE HEADER VALUES DO NOT MATCH WHEN TWO
C                - SIGMA FILES SPANNING THE CENTER DATE FOR THE
C                - PREPBUFR FILE ARE READ
C
C
C REMARKS: THIS ROUTINE PROCESSES ONE REPORT AT A TIME.  IT EXPECTS
C     THAT THE CALLING PROGRAM HAS ALREADY ENCODED THE REPORT INTO
C     THE PREPBUFR FILE VIA THE UFBINT OR UFBCPY ROUTINES.  THE CALLING
C     PROGRAM SHOULD THEN CALL THIS ROUTINE AND, UPON ITS RETURN, THE
C     CALLING PROGRAM SHOULD CALL WRITSB TO ACTUALLY WRITE THE UPDATED
C     SUBSET (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 GUESS FILE, INTO THE PREPBUFR
C                FILE FOR ALL MESSAGE TYPES OR AT LEAST SOME MESSAGE
C                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-SSI REQUIRES
C              A 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 ANALYSIS FILE, INTO THE PREPBUFR FILE - POSTEVENTS
C              MODE - ?
C              DOANLS = .TRUE.  ---> YES, FOR ALL MESSAGE TYPES
C              DOANLS = .FALSE. ---> NO,  FOR ALL MESSAGE TYPES
C                                          - PREVENTS MODE -   (DEFAULT)
C      (NOTE:  DOANLS=TRUE WILL OVERRIDE AND FORCE TO FALSE ALL OTHER
C              SWITCHES. IN ADDITION, THE FORECAST VALUES WILL NOT
C              BE ENCODED FOR ANY MESSAGE TYPE AND SPECIFIC HUMIDITY
C              WILL NOT BE RE-CALCULATED.)
C
C    DOBERR  - ENCODE OBSERVATIONAL ERROR VALUES, AS READ FROM OBS.
C              ERROR FILE, INTO THE PREPBUFR FILE?
C              DOBERR = .TRUE.  ---> YES                       (DEFAULT)
C              DOBERR = .FALSE. ---> NO (VALUES REMAIN MISSING)
C      (NOTE1: THIS WAS ADDED AS A TIME SAVING FEATURE IN THE
C              RAP -AND PREVIOUS RUC- VERSION SINCE IT DOES NOT REQUIRE
C              OBSERVATIONAL ERRORS TO BE PRESENT IN THE PREPBUFR FILE.)
C      (NOTE2: IF DOANLS=TRUE, THEN DOBERR IS FORCED TO BE FALSE.)
C
C    QTOP_REJ  - THE PRESSURE LEVEL (IN MB) ABOVE WHICH ALL SPECIFIC
C                HUMIDITY QUALITY MARKERS ARE "REJECTED" (THE QUALITY
C                MARKER IS SET TO 9 ON ALL PRESSURE LEVELS LESS THAN
C                THIS LEVEL)                              (DEFAULT=300.)
C
C    SATMQC  - PERFORM SPECIAL QUALITY CONTROL ON SATELLITE TEMPERATURE
C              SOUNDINGS IN REPORT TYPES 160-179?
C              SATMQC = .TRUE.  ---> YES
C              SATMQC = .FALSE. ---> NO                        (DEFAULT)
C      (NOTE: THIS APPLIES ONLY TO THE CDAS OR HISTORICAL RE-RUNS
C             WITH TEMPERATURE SOUNDINGS IN THESE REPORT TYPES)
C
CC
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE GBLEVENTS_CDAS(IDATEP,IUNITF,IUNITE,IUNITP,IUNITS,
     $                         SUBSET,NEWTYP)

      CHARACTER*80 HEADR,OBSTR,FCSTR,OESTR,ANSTR
      CHARACTER*8  SUBSET
      REAL(8)      OBS_8,BAK_8,SID_8,HDR_8(10)
      REAL(8)      BMISS,GETBMISS
      LOGICAL      DOVTMP,DOFCST,SOME_FCST,DOBERR,FCST,VIRT,DOANLS,
     $             SATMQC,ADPUPA_VIRT

      DIMENSION    IUNITF(2)

      COMMON /CGBEVAA/ SID_8,OBS_8(12,255),BAK_8(12,255),NLEV,XOB,YOB,
     $ DHR,TYP
      COMMON /CGBEVBB/ IPVCD,IVTCD
      COMMON /CGBEVCC/ DOVTMP,DOFCST,SOME_FCST,DOBERR,FCST,VIRT,
     $ QTOP_REJ,SATMQC,ADPUPA_VIRT
      COMMON /CGBEVDD/ ERRS(300,33,6)
      COMMON /CGBEVGG/ BMISS

      SAVE

      DATA IFIRST/0/

      DATA HEADR /
     $ 'SID XOB YOB DHR TYP                                  '/
      DATA OBSTR /
     $ 'POB QOB TOB ZOB UOB VOB PWO  PW1O PW2O PW3O PW4O CAT '/
      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

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_CDAS INVOKED ',
     $ 'FOR THE FIRST TIME - VERSION LAST UPDATED 2020-01-09'/)

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.
         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_CDAS: 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_CDAS: STANDARD INPUT DATA CARDS DO NOT ',
     $ 'EXIST -- DEFAULTS TO "POSTEVENTS" MODE'/)
         DOANLS = .TRUE.

C-----------------------------------------------------------------------
  103    CONTINUE
         IF(DOANLS) THEN
            DOVTMP      = .FALSE.
            DOFCST      = .FALSE.
            SOME_FCST   = .FALSE.
            DOBERR      = .FALSE.
            ADPUPA_VIRT = .FALSE.
         ENDIF
         WRITE (6,PREVDATA)

         BMISS = GETBMISS()
         print *
         print'(" BUFRLIB value for missing passed into GBLEVENTS_CDAS",
     $    " is: ",G0)', bmiss
cccc $    " is: ",F21.5)', bmiss
         print *

         FCST = DOFCST
         VIRT = .FALSE.

         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_CDAS: PREVENTS MODE - FIRST GUESS NOT ',
     $ 'READ IN'/)
            ELSE
               PRINT 701
  701 FORMAT(/' --> GBLEVENTS_CDAS: PREVENTS MODE - DATE CHECK AND ',
     $ 'TRANSFORM THE FIRST GUESS'/)
            END IF
         ELSE
            PRINT 7701
 7701 FORMAT(/' --> GBLEVENTS_CDAS: POSTEVENTS MODE - DATE CHECK AND ',
     $ 'TRANSFORM THE ANALYSIS'/)
         END IF

         IF(DOFCST .OR. SOME_FCST .OR. DOANLS)
     $    CALL CGBLEVN10(IUNITF,IDATEP)

         IF(DOBERR)  THEN

C  IF REQUESTED, READ ERROR FILES (ONLY POSSIBLE IN PREVENTS MODE)
C  ---------------------------------------------------------------

            PRINT 702
  702 FORMAT(/' --> GBLEVENTS_CDAS: READ ERROR FILES'/)

            CALL CGBLEVN01(IUNITE)

         ELSE

            ERRS = 0
            IF(.NOT.DOANLS)  PRINT 3702
 3702 FORMAT(/' --> GBLEVENTS_CDAS: OBS. ERROR NOT ENCODED IN PREPBUFR',
     $ ' (BY CHOICE)'/)

         END IF

C  OBTAIN NECESSARY PROGRAM CODES (ONLY USED IN PREVENTS MODE)
C  -----------------------------------------------------------

         CALL UFBQCD(IUNITP,'PREVENT',IPVCD)
         CALL UFBQCD(IUNITP,'VIRTMP ',IVTCD)

         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----------------------------------------------------------------------

      END IF

      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.'ADPUPA  '.AND.
ccccc$           ADPUPA_VIRT)))
         VIRT = (SUBSET.EQ.'ADPSFC  '.OR.SUBSET.EQ.'SFCSHP  '.OR.
     $           SUBSET.EQ.'MSONET  '.OR.SUBSET.EQ.'RASSDA  '.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

      END IF

C  READY TO RETRIEVE NECESSARY INFORMATION OUT OF THE NEXT REPORT WHICH
C  HAS BEEN "UFB" ENCODED INTO THE PREPBUFR FILE BY THE CALLING PROGRAM
C  (USE NEGATIVE UNIT NUMBER HERE SINCE FILE OPEN FOR OUTPUT)
C  (NOTE: THE CALLING PROGRAM HAS NOT YET WRIITEN THE REPORT INTO
C         THE PREPBUFR FILE VIA WRITSB!)
C  ----------------------------------------------------------------

      CALL UFBINT(-IUNITP,OBS_8,12,255,NLEV,OBSTR)
      CALL UFBINT(-IUNITP,HDR_8,10,  1,IRET,HEADR)
      SID_8 = HDR_8(1)
      XOB   = HDR_8(2)

c Trap cases where XOB comes in w/ a value of 360.0 and reset to 0.0
      fuzzy_bound = XOB-360.0
      if (fuzzy_bound .ge. -0.0001 .and. fuzzy_bound .le. .0001) then 
c        print*, 'xob fuzzb:',xob,fuzzy_bound
c        write(*,*) 'failed the fuzzy check', xob
         XOB=0.0
      endif

      YOB   = HDR_8(3)
      DHR   = HDR_8(4)
      TYP   = HDR_8(5)

      IF(FCST.OR.DOANLS)  THEN

C  PREVENTS MODE:   ENCODE FIRST GUESS VALUES INTO PREPBUFR FILE
C  ------------------------------------------------------------

C  POSTEVENTS MODE: ENCODE ANALYSIS VALUES INTO REPORT AND RETURN TO
C                   CALLING PROGRAM TO WRITE GBL-EVENTED REPORT
C                   (SUBSET) INTO PREPBUFR FILE
C  -----------------------------------------------------------------

         CALL CGBLEVN03(SUBSET)
         IF(NLEV.GT.0)  THEN
            IF(FCST)   THEN
               CALL UFBINT(IUNITP,BAK_8,12,NLEV,IRET,FCSTR)
            ELSE
               CALL UFBINT(IUNITP,BAK_8,12,NLEV,IRET,ANSTR)
               RETURN
            END IF
         END IF
      END IF

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 CGBLEVN04
         IF(NLEV.GT.0)  CALL UFBINT(IUNITP,BAK_8,12,NLEV,IRET,OESTR)
      END IF

C  MAKE THE GBLEVENTS_CDAS 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 CGBLEVN02(IUNITP,IUNITS,NEWTYP)

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 CGBLEVN08(IUNITP,SUBSET)
      ENDIF

C  RETURN TO CALLING PROGRAM TO WRITE GBL-EVENTED REPORT (SUBSET) INTO
C   PREPBUFR FILE
C  -------------------------------------------------------------------

      RETURN

      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE CGBLEVN01(IUNITE) ! FORMERLY SUBROUTINE ETABLE

      COMMON /CGBEVDD/ 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.EQ.0) THEN
         PRINT'(" ##GBLEVENTS_CDAS/CGBLEVN01 - OBS. ERROR TABLE EMPTY",
     $    " OR DOES NOT EXIST - STOP 60")'
         CALL ERREXIT(60)
      END IF

      RETURN

      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE CGBLEVN02(IUNITP,IUNITS,NEWTYP)
                                         ! FORMERLY SUBROUTINE FILTAN

      DIMENSION    NFLGRT(100:299,12)
      CHARACTER*8  STNID
      CHARACTER*40 PEVN,QEVN,TEVN,WEVN,PWVN,PW1VN,PW2VN,PW3VN,PW4VN
      REAL(8)      PEV_8(4,255),QEV_8(4,255),TEV_8(4,255),WEV_8(5,255),
     $             PWV_8(4,255),PW1V_8(4,255),PW2V_8(4,255),
     $             PW3V_8(4,255),PW4V_8(4,255),OBS_8,BAK_8,SID_8
      REAL(8)      BMISS
      LOGICAL      FCST,DN2FAR,REJPS,REJT,REJQ,REJW,REJPW,REJPW1,REJPW2,
     $             REJPW3,REJPW4,SATMQC,SATEMP,SOLN60,SOLS60

      COMMON /CGBEVAA/ SID_8,OBS_8(12,255),BAK_8(12,255),NLEV,XOB,YOB,
     $ DHR,TYP
      COMMON /CGBEVBB/ IPVCD,IVTCD
      COMMON /CGBEVCC/ DOVTMP,DOFCST,SOME_FCST,DOBERR,FCST,VIRT,
     $ QTOP_REJ,SATMQC,ADPUPA_VIRT
      COMMON /CGBEVEE/PSG01_C,ZSG01_C,TG01_C(100),UG01_C(100),
     x     VG01_C(100),QG01_C(100),zint(100),pint(100),pintlog(100),
     x     plev(100),plevlog(100)
      COMMON /CGBEVGG/ BMISS

      EQUIVALENCE (SID_8,STNID)

      DATA PEVN  /'POB  PQM  PPC  PRC      '/
      DATA QEVN  /'QOB  QQM  QPC  QRC      '/
      DATA TEVN  /'TOB  TQM  TPC  TRC      '/
      DATA WEVN  /'UOB  VOB  WQM  WPC  WRC '/
      DATA PWVN  /'PWO  PWQ  PWP  PWR      '/
      DATA PW1VN /'PW1O PW1Q PW1P PW1R     '/
      DATA PW2VN /'PW2O PW2Q PW2P PW2R     '/
      DATA PW3VN /'PW3O PW3Q PW3P PW3R     '/
      DATA PW4VN /'PW4O PW4Q PW4P PW4R     '/

      DATA NFLGRT/2400*0/

      NI  = MOD((NINT(TYP)/10),10)

      IF(NEWTYP.EQ.1)  NFLGRT = 0

C  LOGICAL SWITCHES FOR OBSERVATION LOCATION FILTERING
C  ---------------------------------------------------

      SATEMP = ((TYP.GE.160.AND.TYP.LE.179).AND.SATMQC)
      SOLN60 = ((TYP.GE.160.AND.TYP.LE.163).AND.YOB.GE.-60.AND.SATMQC)
      SOLS60 = ((TYP.EQ.160.OR.TYP.EQ.162.OR.TYP.EQ.163).AND.YOB.LT.-60
     $ .AND.SATMQC)

C  CLEAR THE EVENT ARRAYS
C  ----------------------

      PEV_8  = BMISS
      QEV_8  = BMISS
      TEV_8  = BMISS
      WEV_8  = BMISS
      PWV_8  = BMISS
      PW1V_8 = BMISS
      PW2V_8 = BMISS
      PW3V_8 = BMISS
      PW4V_8 = BMISS

      MAXPEV  = 0
      MAXQEV  = 0
      MAXTEV  = 0
      MAXWEV  = 0
      MAXPWV  = 0
      MAXPW1V = 0
      MAXPW2V = 0
      MAXPW3V = 0
      MAXPW4V = 0

C  LOOP OVER LEVELS APPLYING UNDERGROUND FILTERING AND SPECIAL RULES
C  -----------------------------------------------------------------

      IF(NLEV.GT.0)  THEN
      DO L=1,NLEV

         POB  = OBS_8( 1,L)
         QOB  = OBS_8( 2,L)
         TOB  = OBS_8( 3,L)
         UOB  = OBS_8( 5,L)
         VOB  = OBS_8( 6,L)
         PWO  = OBS_8( 7,L)
         PW1O = OBS_8( 8,L)
         PW2O = OBS_8( 9,L)
         PW3O = OBS_8(10,L)
         PW4O = OBS_8(11,L)
         CAT  = OBS_8(12,L)

         DN2FAR = .FALSE.
         REJ = 9
         RCD = 9

C  -------------------------------------------------------------------
C  RULES FOR PRESSURE (ON ANY LEVEL) -- ALL DATA ON 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  REJECTION MEANS Q.M. SET TO 8
C  -------------------------------------------------------------------

         IF(POB.LT.BMISS)  THEN
            IF(.NOT.FCST)  PSG01_C = POB
            IF(POB-PSG01_C.GE.100. .OR. POB.LE.0.) THEN
               IF(POB.LE.0.) 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_C
  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_C
  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
               END IF
               REJ = 8
               DN2FAR = .TRUE.
               PEV_8(1,L) = POB
               PEV_8(2,L) = REJ
               PEV_8(3,L) = IPVCD
               PEV_8(4,L) = RCD
               MAXPEV = L
            ENDIF
         ENDIF

C  -------------------------------------------------------------------
C  RULES FOR SURFACE PRESSURE -- ALL DATA ON SURFACE LEVEL 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
C    - PRESSURE VIOLATES RULES FOR PRESSURE ON ANY LEVEL (SEE ABOVE)
C  REJECTION FOR ALL BUT LAST RULE MEANS Q.M. SET TO 9
C  REJECTION FOR LAST RULE MEANS Q.M. SET TO 8
C  -------------------------------------------------------------------

         IF(POB.LT.BMISS .AND. CAT.EQ.0) THEN
            IF(.NOT.FCST)  PSG01_C = POB
            REJPS = OEFG01_C(POB,TYP,5).GE.BMISS          .OR.
     $              ABS(POB-PSG01_C).GE.100.              .OR.
     $              POB.LE.450.                           .OR.
     $              POB.GE.1100.
            IF(REJPS.OR.DN2FAR) THEN
               IF(.NOT.DN2FAR)  THEN
                  IF(OEFG01_C(POB,TYP,5).GE.BMISS)  THEN
                     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
                  ELSE  IF(ABS(POB-PSG01_C).GE.100.)  THEN
                     WRITE(IUNITS,104) STNID,NINT(TYP),YOB,XOB,POB,
     $                PSG01_C
  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
                     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')
                     RCD = 2
                  ENDIF
               ENDIF
               DN2FAR = .TRUE.
               PEV_8(1,L) = POB
               PEV_8(2,L) = REJ
               PEV_8(3,L) = IPVCD
               PEV_8(4,L) = RCD
               MAXPEV = L
            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    - 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       (SEE ABOVE)
C    - PRESSURE ON LEVEL VIOLATES RULES FOR PRESSURE (SEE ABOVE)
C  REJECTION FOR ALL BUT LAST RULE MEANS Q.M. SET TO 9
C  REJECTION FOR LAST RULE MEANS Q.M. SET TO 8
C  -------------------------------------------------------------------

! initialize REJT as T so it will be set if TOB is missing (since
!  referenced in "RULES FOR SPECIFIC HUMIDITY" below)
         REJT = .TRUE.
         IF(TOB.LT.BMISS) THEN
            REJT = OEFG01_C(POB,TYP,2).GE.BMISS         .OR. 
     $             (SOLN60.AND.NINT(POB*10.).GE.1000)   .OR.
     $             (SOLS60.AND.NINT(POB*10.).GT.1000)
            IF(REJT.OR.DN2FAR) THEN
               IF(.NOT.DN2FAR)  THEN
                  IF(OEFG01_C(POB,TYP,2).GE.BMISS)  THEN
                     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
                  ELSE  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
                  ENDIF
               ENDIF
               TEV_8(1,L) = TOB
               TEV_8(2,L) = REJ
               TEV_8(3,L) = IPVCD
               TEV_8(4,L) = RCD
               MAXTEV = L
            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    - TEMPERATURE ON LEVEL IS MISSING OR IS LESS THAN -150 DEG. C --
C       "PREVENT" PGM REASON CODE 2
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    - 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 (SEE ABOVE)
C    - THIS IS SFC LEVEL AND PRESSURE VIOLATES RULES FOR SFC PRESSURE
C       (SEE ABOVE)
C    - PRESSURE ON LEVEL VIOLATES RULES FOR PRESSURE (SEE ABOVE)
C  REJECTION FOR ALL BUT LAST RULE MEANS Q.M. SET TO 9
C  REJECTION FOR LAST RULE MEANS Q.M. SET TO 8
C  -------------------------------------------------------------------

         IF(QOB.LT.BMISS) THEN
            REJQ = OEFG01_C(POB,TYP,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.DN2FAR) THEN
               IF(.NOT.DN2FAR.AND..NOT.REJT)  THEN
                  IF(OEFG01_C(POB,TYP,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
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  IF(NINT(POB*10.).LT.NINT(QTOP_REJ*10.))  THEN
                     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
                  ELSE  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
                     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
                  ENDIF
               ENDIF
               QEV_8(1,L) = QOB
               QEV_8(2,L) = REJ
               QEV_8(3,L) = IPVCD
               QEV_8(4,L) = RCD
               MAXQEV = L
            ENDIF
         ENDIF

C  -------------------------------------------------------------------
C  RULES FOR WINDS -- 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 PRESSURE VIOLATES RULES FOR SFC PRESSURE
C       (SEE ABOVE)
C    - PRESSURE ON LEVEL VIOLATES RULES FOR PRESSURE (SEE ABOVE)
C  REJECTION FOR ALL BUT LAST RULE MEANS Q.M. SET TO 9
C  REJECTION FOR LAST RULE MEANS Q.M. SET TO 8
C  -------------------------------------------------------------------

         IF(MIN(UOB,VOB).LT.BMISS) THEN
            REJW = OEFG01_C(POB,TYP,4).GE.BMISS
            IF(REJW.OR.DN2FAR) THEN
               IF(.NOT.DN2FAR)  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
               ENDIF
               WEV_8(1,L) = UOB
               WEV_8(2,L) = VOB
               WEV_8(3,L) = REJ
               WEV_8(4,L) = IPVCD
               WEV_8(5,L) = RCD
               MAXWEV = L
            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
C  -------------------------------------------------------------------

         IF(PWO.LT.BMISS) THEN
            REJPW = OEFG01_C(POB,TYP,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')
               PWV_8(1,L) = PWO
               PWV_8(2,L) = 9
               PWV_8(3,L) = IPVCD
               PWV_8(4,L) = 3
               MAXPWV = L
            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
C  -------------------------------------------------------------------

         IF(PW1O.LT.BMISS) THEN
            REJPW1 = OEFG01_C(POB,TYP,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')
               PW1V_8(1,L) = PW1O
               PW1V_8(2,L) = 9
               PW1V_8(3,L) = IPVCD
               PW1V_8(4,L) = 3
               MAXPW1V = L
            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
C  -------------------------------------------------------------------

         IF(PW2O.LT.BMISS) THEN
            REJPW2 = OEFG01_C(POB,TYP,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')
               PW2V_8(1,L) = PW2O
               PW2V_8(2,L) = 9
               PW2V_8(3,L) = IPVCD
               PW2V_8(4,L) = 3
               MAXPW2V = L
            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
C  -------------------------------------------------------------------

         IF(PW3O.LT.BMISS) THEN
            REJPW3 = OEFG01_C(POB,TYP,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')
               PW3V_8(1,L) = PW3O
               PW3V_8(2,L) = 9
               PW3V_8(3,L) = IPVCD
               PW3V_8(4,L) = 3
               MAXPW3V = L
            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
C  -------------------------------------------------------------------

         IF(PW4O.LT.BMISS) THEN
            REJPW4 = OEFG01_C(POB,TYP,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')
               PW4V_8(1,L) = PW4O
               PW4V_8(2,L) = 9
               PW4V_8(3,L) = IPVCD
               PW4V_8(4,L) = 3
               MAXPW4V = L
            ENDIF
         ENDIF

      ENDDO
      ENDIF

C  APPLY THE PROPER EVENTS
C  -----------------------

      IF(MAXPEV .GT.0) CALL UFBINT(IUNITP,PEV_8, 4,MAXPEV, IRET,PEVN)
      IF(MAXQEV .GT.0) CALL UFBINT(IUNITP,QEV_8, 4,MAXQEV, IRET,QEVN)
      IF(MAXTEV .GT.0) CALL UFBINT(IUNITP,TEV_8, 4,MAXTEV, IRET,TEVN)
      IF(MAXWEV .GT.0) CALL UFBINT(IUNITP,WEV_8, 5,MAXWEV, IRET,WEVN)
      IF(MAXPWV .GT.0) CALL UFBINT(IUNITP,PWV_8, 4,MAXPWV, IRET,PWVN)
      IF(MAXPW1V.GT.0) CALL UFBINT(IUNITP,PW1V_8,4,MAXPW1V,IRET,PW1VN)
      IF(MAXPW2V.GT.0) CALL UFBINT(IUNITP,PW2V_8,4,MAXPW2V,IRET,PW2VN)
      IF(MAXPW3V.GT.0) CALL UFBINT(IUNITP,PW3V_8,4,MAXPW3V,IRET,PW3VN)
      IF(MAXPW4V.GT.0) CALL UFBINT(IUNITP,PW4V_8,4,MAXPW4V,IRET,PW4VN)

      RETURN
      END
C***********************************************************************
C***********************************************************************
C  CGBLEVN03 - INTERPOLATE MODEL DATA (FIRST GUESS OR ANALYSIS) TO OB
C              LOCATIONS
C-----------------------------------------------------------------------
      SUBROUTINE CGBLEVN03(SUBSET) ! FORMERLY SUBROUTINE GETFC

      REAL(8)   OBS_8,BAK_8,SID_8
      REAL(8)   BMISS
      CHARACTER*8  SUBSET

      COMMON /CGBEVAA/ SID_8,OBS_8(12,255),BAK_8(12,255),NLEV,XOB,YOB,
     $ DHR,TYP
      COMMON /CGBEVFF/IMAX,JMAX,KMAX,kmaxs,DLAT,DLON,IDVC,SL(100),
     x     SI(101)
      COMMON /CGBEVEE/PSG01_C,ZSG01_C,TG01_C(100),UG01_C(100),
     x     VG01_C(100),QG01_C(100),zint(100),pint(100),pintlog(100),
     x     plev(100),plevlog(100)
      COMMON /CGBEVGG/ BMISS


      DATA TZERO / 273.15 /
      DATA BETAP / .0552  /
      DATA BETA  / .00650 /
      DATA ROG   / 29.261 /

C  CLEAR THE BACKGROUND EVENT ARRAY
C  --------------------------------

      BAK_8 = BMISS

C  GET GUESS PROFILE AT OB LOCATION
C  --------------------------------
      CALL CGBLEVN06(XOB,YOB)

      
C  INTERPOLATE GUESS PROFILES TO OB PRESSURES
C  ------------------------------------------

      IF(NLEV.GT.0)  THEN
      DO 10 L=1,NLEV

         POB  = OBS_8( 1,L)
         QOB  = OBS_8( 2,L)
         TOB  = OBS_8( 3,L)
         ZOB  = OBS_8( 4,L)
         UOB  = OBS_8( 5,L)
         VOB  = OBS_8( 6,L)
         PWO  = OBS_8( 7,L)
         PW1O = OBS_8( 8,L)
         PW2O = OBS_8( 9,L)
         PW3O = OBS_8(10,L)
         PW4O = OBS_8(11,L)
         CAT  = OBS_8(12,L)

         IF(POB.LE.0. .OR. POB.GE.BMISS) GOTO 10

         poblog = log(pob)
         
         la = -999
         lb = -999
         do k=1,kmax-1
            if (poblog<=plevlog(k) .and. poblog>plevlog(k+1)) then
               la = k
               lb = k+1
               exit
            endif
         end do
         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
         end do

C  SURFACE PRESSURE
C  ----------------

         IF(CAT.EQ.0 .AND. ZOB.LT.BMISS) THEN
            TS = TG01_C(1) + (PSG01_C-PLEV(1))*BETAP
            DZ  = ZOB-ZSG01_C
            TM  = TS - DZ*BETA*.5
            PFC = PSG01_C*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_C(LB) + (QG01_C(LA)-QG01_C(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_C(1) + (POB-PLEV(1))*BETAP
            ELSE
               TOB = TG01_C(LB) + (TG01_C(LA)-TG01_C(LB))*WT
            ENDIF
            TOB = TOB - TZERO
         ENDIF

C  HEIGHT
C  ------

         IF(ZOB.LT.BMISS) THEN
            IF(POB.GT.PLEV(1)) THEN
               TM = TG01_C(1) + (.5*(PINT(1)+POB)-PLEV(1))*BETAP
               ZOB = ZINT(1) - ROG*TM*LOG(POB/PINT(1))
            ELSE if(li.gt.0) then
! DAK: 2/14/13: added test for LI = 0 as this can happen and cause
!               zint array to go out of bounds when WCOSS debugging
!               turned on - now if LI = 0, zob-gess is stored as
!               missing rather than as -infinity
               TM = TG01_C(LB) + (TG01_C(LA)-TG01_C(LB))*WT
               ZOB = ZINT(LI) - ROG*TM*LOG(POB/PINT(LI))
            else
               zob = bmiss
            ENDIF
         ENDIF

C  U AND V COMPONENTS
C  ------------------

         IF(UOB.LT.BMISS .OR. VOB.LT.BMISS) THEN
            UOB = UG01_C(LB) + (UG01_C(LA)-UG01_C(LB))*WT
            VOB = VG01_C(LB) + (VG01_C(LA)-VG01_C(LB))*WT
         ENDIF


C  PRECIPITABLE WATER
C  ------------------

         PWO  = BMISS
         PW1O = BMISS
         PW2O = BMISS
         PW3O = BMISS
         PW4O = BMISS

C  RELATIVE HUMIDITY
C  -----------------

         RHO = BMISS

C  SCATTER THE PROPER FIRST GUESS/ANALYSIS VALUES
C  ----------------------------------------------

         BAK_8(1,L)  = PFC
         BAK_8(2,L)  = QOB
         BAK_8(3,L)  = TOB
         BAK_8(4,L)  = ZOB
         BAK_8(5,L)  = UOB
         BAK_8(6,L)  = VOB
         BAK_8(7,L)  = PWO
         BAK_8(8,L)  = PW1O
         BAK_8(9,L)  = PW2O
         BAK_8(10,L) = PW3O
         BAK_8(11,L) = PW4O
         BAK_8(12,L) = RHO

   10 ENDDO
      ENDIF

      RETURN
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE CGBLEVN04 ! FORMERLY SUBROUTINE GETOE

      REAL(8)   OBS_8,BAK_8,SID_8
      REAL(8)   BMISS

      COMMON /CGBEVAA/ SID_8,OBS_8(12,255),BAK_8(12,255),NLEV,XOB,YOB,
     $ DHR,TYP
      COMMON /CGBEVGG/ BMISS

C  CLEAR THE EVENT ARRAY
C  ---------------------

      BAK_8 = BMISS

C  LOOP OVER LEVELS LOOKING UP THE OBSERVATION ERROR
C  -------------------------------------------------

      IF(NLEV.GT.0)  THEN
      DO L=1,NLEV

         POB  = OBS_8( 1,L)
         QOB  = OBS_8( 2,L)
         TOB  = OBS_8( 3,L)
         WOB  = MAX(OBS_8(5,L),OBS_8(6,L))
         PWO  = OBS_8( 7,L)
         PW1O = OBS_8( 8,L)
         PW2O = OBS_8( 9,L)
         PW3O = OBS_8(10,L)
         PW4O = OBS_8(11,L)
         CAT  = OBS_8(12,L)

         IF(CAT .EQ.0    ) BAK_8( 1,L) = OEFG01_C(POB,TYP,5)
         IF(QOB .LT.BMISS) BAK_8( 2,L) = OEFG01_C(POB,TYP,3)
         IF(TOB .LT.BMISS) BAK_8( 3,L) = OEFG01_C(POB,TYP,2)
         IF(WOB .LT.BMISS) BAK_8( 5,L) = OEFG01_C(POB,TYP,4)
         IF(PWO .LT.BMISS) BAK_8( 6,L) = OEFG01_C(POB,TYP,6)
         IF(PW1O.LT.BMISS) BAK_8( 7,L) = OEFG01_C(POB,TYP,6)
         IF(PW2O.LT.BMISS) BAK_8( 8,L) = OEFG01_C(POB,TYP,6)
         IF(PW3O.LT.BMISS) BAK_8( 9,L) = OEFG01_C(POB,TYP,6)
         IF(PW4O.LT.BMISS) BAK_8(10,L) = OEFG01_C(POB,TYP,6)

      ENDDO
      ENDIF

      RETURN
      END
C***********************************************************************
C***********************************************************************
C  SUBROUTINE CGBLEVN05 - GUSER (CGBLEVN10) USER INTERFACE FOR
C                         PREPFIT (PSG01_C,ZSG01_C,TG01_C,UG01_C,VG01_C)
C-----------------------------------------------------------------------
      SUBROUTINE CGBLEVN05(GRD,IQ,LEV) ! FORMERLY SUBROUTINE GUSER

      COMMON /CGBEVFF/IMAX,JMAX,KMAX,kmaxs,DLAT,DLON,IDVC,SL(100),
     x     SI(101)

      DIMENSION   GRD(IMAX,JMAX,2)

C  PACK 2D FIRST GUESS/ANALYSIS FIELD INTO BIT PACKED ARRAYS
C  ---------------------------------------------------------

      IF(IQ.EQ.1) THEN
         DO J=1,JMAX
            DO I=1,IMAX
               CALL CGBLEVN12(I,J,GRD(I,J,1))
            ENDDO
         ENDDO
      ELSEIF(IQ.EQ.2) THEN
         DO J=1,JMAX
            DO I=1,IMAX
               CALL CGBLEVN13(I,J,GRD(I,J,1))
            ENDDO
         ENDDO
      ELSEIF(IQ.EQ.3) THEN
         DO J=1,JMAX
            DO I=1,IMAX
               CALL CGBLEVN14(I,J,LEV,GRD(I,J,1))
            ENDDO
         ENDDO
      ELSEIF(IQ.EQ.4) THEN
         DO J=1,JMAX
            DO I=1,IMAX
               CALL CGBLEVN15(I,J,LEV,GRD(I,J,1))
               CALL CGBLEVN16(I,J,LEV,GRD(I,J,2))
            ENDDO
         ENDDO
      ELSEIF(IQ.EQ.5) THEN
         DO J=1,JMAX
            DO I=1,IMAX
               CALL CGBLEVN17(I,J,LEV,MAX(0.,GRD(I,J,1))*1E6)
            ENDDO
         ENDDO
      ENDIF

      RETURN
      END
C***********************************************************************
C***********************************************************************
C  SUBROUTINE CGBLEVN06 - 2D LINEAR HORIZONTAL INTERPOLATION
C-----------------------------------------------------------------------
      SUBROUTINE CGBLEVN06(XOB,YOB) ! FORMERLY SUBROUTINE HTERP
      REAL KAP1,KAPR


      COMMON /CGBEVFF/IMAX,JMAX,KMAX,kmaxs,DLAT,DLON,IDVC,SL(100),
     x     SI(101)
      COMMON /CGBEVEE/ PSI,ZSI,TI(100),UI(100),VI(100),QI(100),
     x     zint(100),pint(100),pintlog(100),plev(100),plevlog(100)

      DATA ROG   / 29.261 /
      DATA KAP1 / 1.2857 /, KAPR / 3.4997 /


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  = ZSG01_C(I0,J0)
      P2  = ZSG01_C(I0,J1)
      P3  = ZSG01_C(I1,J0)
      P4  = ZSG01_C(I1,J1)
      P5  = P1+(P2-P1)*WY
      P6  = P3+(P4-P3)*WY
      ZSI = P5+(P6-P5)*WX

C  HTERP FOR SURFACE PRESSURE
C  --------------------------

      P1  = PSG01_C(I0,J0)
      P2  = PSG01_C(I0,J1)
      P3  = PSG01_C(I1,J0)
      P4  = PSG01_C(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 = TG01_C(I0,J0,K)
         P2 = TG01_C(I0,J1,K)
         P3 = TG01_C(I1,J0,K)
         P4 = TG01_C(I1,J1,K)
         P5 = P1+(P2-P1)*WY
         P6 = P3+(P4-P3)*WY
         TI(K) = P5+(P6-P5)*WX

         P1 = UG01_C(I0,J0,K)
         P2 = UG01_C(I0,J1,K)
         P3 = UG01_C(I1,J0,K)
         P4 = UG01_C(I1,J1,K)
         P5 = P1+(P2-P1)*WY
         P6 = P3+(P4-P3)*WY
         UI(K) = P5+(P6-P5)*WX

         P1 = VG01_C(I0,J0,K)
         P2 = VG01_C(I0,J1,K)
         P3 = VG01_C(I1,J0,K)
         P4 = VG01_C(I1,J1,K)
         P5 = P1+(P2-P1)*WY
         P6 = P3+(P4-P3)*WY
         VI(K) = P5+(P6-P5)*WX

         P1 = QG01_C(I0,J0,K)
         P2 = QG01_C(I0,J1,K)
         P3 = QG01_C(I1,J0,K)
         P4 = QG01_C(I1,J1,K)
         P5 = P1+(P2-P1)*WY
         P6 = P3+(P4-P3)*WY
         QI(K) = P5+(P6-P5)*WX

      ENDDO

c     Compute interface pressures and heights
      zint(1) = zsi
      pint(1) = psi
      pintlog(1) = log(pint(1))
      do k=2,kmax
        k0 = k-1
         if(idvc.eq.1) then
            pint(k) = psi*si(k)
         else if(idvc.eq.2) then
            pint(k)=si(k)+sl(k)*psi
         end if
         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 pressure at layer midpoints
      do k=1,kmax
         if (idvc.eq.1) then
            plev(k) = psi*sl(k)
         else if (idvc.eq.2) then
            plev(k) = ((PINT(k)**KAP1-PINT(k+1)**KAP1)/
     $           (KAP1*(PINT(k)-PINT(k+1))))**KAPR
         endif
         plevlog(k) = log(plev(k))
      end do


      RETURN
      END
C***********************************************************************
C***********************************************************************
      FUNCTION OEFG01_C(P,TYP,IE) ! FORMERLY FUNCTION OEF

      REAL(8) BMISS

      COMMON /CGBEVDD/ERRS(300,33,6)
      COMMON /CGBEVGG/ BMISS

      OEFG01_C = BMISS
      KX  = TYP

C  LOOK UP ERRORS FOR PARTICULAR OB TYPES
C  --------------------------------------

      IF(IE.GE.2 .AND. IE.LE.4) THEN
         DO LA=1,33
            IF(P.GE.ERRS(KX,LA,1)) GOTO 10
         ENDDO
   10    CONTINUE
         LB = LA-1
         IF(LB.EQ.33) LA = 6
         IF(LB.EQ.33) LB = 5
         IF(LB.EQ. 0) THEN
            OEFG01_C = ERRS(KX,1,IE)
         ELSE
            DEL = (P-ERRS(KX,LB,1))/(ERRS(KX,LA,1)-ERRS(KX,LB,1))
            OEFG01_C = (1.-DEL)*ERRS(KX,LB,IE) + DEL*ERRS(KX,LA,IE)
         ENDIF
      ELSEIF(IE.EQ.5) THEN
         OEFG01_C = ERRS(KX,1,5)
      ELSEIF(IE.EQ.6) THEN
         OEFG01_C = ERRS(KX,1,6)
      ENDIF

C  SET MISSING ERROR VALUE TO "BMISS"
C  ----------------------------------

      IF(OEFG01_C.GE.5E5) OEFG01_C = BMISS

      RETURN
      END

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    CGBLEVN08   CALCULATE SPEC. HUMIDITY AND VIRTUAL TEMP
C   PRGMMR: D.A. KEYSER      ORG: NP22       DATE: 2006-07-14
C
C ABSTRACT: CREATE VIRTUAL TEMPERATURE EVENTS WITHIN GBLEVENTS_CDAS
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") OR RASS ("RASSDA") DATA TYPES WHEN SWITCH "ADPUPA_VIRT"
C   IS FALSE AND ONLY FOR SURFACE LAND ("ADPSFC"), MARINE ("SFCSHP"),
C   MESONET ("MSONET"), RASS ("RASSDA"), RAOB/DROP/MULTI-LVL RECCO
C   ("ADPUPA") DATA TYPES WHEN SWITCH "ADPUPA_VIRT" IS TRUE.  IT IS
C   ALSO ONLY CALLED IN THE PREVENTS MODE.  THIS ROUTINE IS CALLED ONCE
C   FOR EACH VALID REPORT IN THE 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
C USAGE:    CALL CGBLEVN08(IUNITP)
C   INPUT ARGUMENT LIST:
C     IUNITP   - BUFR OUTPUT FILE UNIT
C     SUBSET   - THE BUFR MESSAGE TABLE A ENTRY FOR THE PARTICULAR
C              - REPORT BEING PROCESSED
C
C REMARKS: WILL IMMEDIATELY RETURN TO CALLING PROGRAM IF ANY OF THE
C   FOLLOWING CONDITIONS EXIST: THERE ARE NO LEVELS OF VALID DEWPOINT,
C   OBS, TEMPERATURE Q.M. OR SPEC. HUMIDITY Q.M. IN THE INPUT PREPBUFR
C   FILE FOR THE REPORT.  WILL NOT ATTEMPT EITHER SPEC. HUMIDITY NOR
C   VIRT. TEMP CALC. ON A GIVEN LEVEL IF ANY OF THE FOLLOWING
C   CONDITIONS EXIST: REPORTED PRESSURE OBS IS MISSING, REPORTED
C   (SENSIBLE) TEMPERATURE OBS IS MISSING, OR REPORTED DEWPOINT OBS IS
C   MISSING.
C 
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE CGBLEVN08(IUNITP,SUBSET) ! FORMERLY SUBROUTINE VTPEVN

      CHARACTER*80 EVNSTQ,EVNSTV
      CHARACTER*8  SUBSET
      REAL(8)      TDP_8(255),TQM_8(255),QQM_8(255),BAKQ_8(4,255),
     $             BAKV_8(4,255),OBS_8,BAK_8,SID_8
      REAL(8)      BMISS

      LOGICAL      EVNQ,EVNV,DOVTMP,TROP

      COMMON /CGBEVAA/ SID_8,OBS_8(12,255),BAK_8(12,255),NLEV,XOB,YOB,
     $ DHR,TYP
      COMMON /CGBEVBB/ IPVCD,IVTCD
      COMMON /CGBEVCC/ DOVTMP,DOFCST,SOME_FCST,DOBERR,FCST,VIRT,
     $ QTOP_REJ,SATMQC,ADPUPA_VIRT
      COMMON /CGBEVGG/ BMISS

      DATA EVNSTQ /'QOB QQM QPC QRC'/
      DATA EVNSTV /'TOB TQM TPC TRC'/

C-----------------------------------------------------------------------
C FCNS BELOW CONVERT TEMP/TD (K) & PRESS (MB) INTO SAT./ SPEC. HUM.(G/G)
C-----------------------------------------------------------------------
      ES(T) = 6.1078*EXP((17.269*(T - 273.16))/((T - 273.16)+237.3))
      QS(T,P) = (0.622*ES(T))/(P-(0.378*ES(T)))
C-----------------------------------------------------------------------

C  CLEAR TEMPERATURE AND SPECIFIC HUMIDITY EVENTS
C  ----------------------------------------------

      EVNQ   = .FALSE.
      EVNV   = .FALSE.
      BAKQ_8 = BMISS
      BAKV_8 = BMISS
      TROP   = .FALSE.

C  GET DEWPOINT TEMPERATURE AND CURRENT T,Q QUALITY MARKERS
C  --------------------------------------------------------

      CALL UFBINT(-IUNITP,TDP_8,1,255,NLTD,'TDO')
      CALL UFBINT(-IUNITP,QQM_8,1,255,NLQQ,'QQM')
      CALL UFBINT(-IUNITP,TQM_8,1,255,NLTQ,'TQM')
      IF(SUBSET.NE.'RASSDA  ') THEN
         IF(NLTD.EQ.0) RETURN
         IF(NLQQ.EQ.0) RETURN
      END IF
      IF(NLTQ.EQ.0) RETURN
      IF(SUBSET.NE.'RASSDA  ') THEN
         IF(NLTD.NE.NLEV) THEN
            PRINT'(" ##GBLEVENTS_CDAS/CGBLEVN08 - NLTD .NE. NLEV - ",
     $       "STOP 61")'
            CALL ERREXIT(61)
         END IF
         IF(NLQQ.NE.NLEV) THEN
            PRINT'(" ##GBLEVENTS_CDAS/CGBLEVN08 - NLQQ .NE. NLEV - ",
     $       "STOP 63")'
            CALL ERREXIT(63)
         END IF
      END IF
      IF(NLTQ.NE.NLEV) THEN
         PRINT'(" ##GBLEVENTS_CDAS/CGBLEVN08 - NLTQ .NE. NLEV - STOP ",
     $    "62")'
         CALL ERREXIT(62)
      END IF

C  COMPUTE VIRTUAL TEMPERATURE AND SPECIFIC HUMIDITY USING REPORTED DEWP
C  ---------------------------------------------------------------------

      IF(NLEV.GT.0)  THEN
      DO L=1,NLEV
         POB = OBS_8(1,L)
         TDO = TDP_8(L)
         TOB = OBS_8(3,L)
         CAT = OBS_8(12,L)
         IF(DOVTMP) THEN
            IF(SUBSET.EQ.'RASSDA  ') THEN
               IF(TOB.LT.BMISS) THEN
                  BAKV_8(1,L) = TOB
                  BAKV_8(2,L) = TQM_8(L)
                  BAKV_8(3,L) = IVTCD
                  BAKV_8(4,L) = 3
                  EVNV = .TRUE.
                  CYCLE
               END IF
            END IF
         END IF
         IF(POB.LT.BMISS .AND. TOB.LT.BMISS
     $                   .AND. TDO.LT.BMISS) THEN
            IF(QQM_8(L).GT.3) THEN
C  Don't update q or calculate Tv if bad moisture obs fails sanity check
cdak           IF(TDO.LT.-103.15 .OR. TDO.GT.46.83 .OR. POB.LT.0.1 .OR.
cdak $          POB.GT.1100.)
cdak $ print *, '&&& bad QM fails sanity check'
               IF(TDO.LT.-103.15 .OR. TDO.GT.46.83 .OR. POB.LT.0.1 .OR.
     $          POB.GT.1100.)  CYCLE
            ENDIF
            QOB = QS(TDO+273.16,POB)
            BAKQ_8(1,L) = QOB*1E6
            BAKQ_8(2,L) = QQM_8(L)  ! Moist qm same as before for
                                    !  re-calc. q
            BAKQ_8(3,L) = IVTCD
            BAKQ_8(4,L) = 0     ! Re-calc. q gets unique reason code 0
            EVNQ = .TRUE.
C  If message type ADPUPA, test this level to see if at or above trop
C   (trop must be above 500 mb to pass test; if no trop level found
C   assume it's at 80 mb)
C  Don't calculate Tv on this level if at or above trop (doesn't affect
C   q calculation)
            TROP = (SUBSET.EQ.'ADPUPA  ' .AND.
     $       ((CAT.EQ.5 .AND. POB.LT.500.) .OR. POB.LT. 80. .OR. TROP))
            IF(DOVTMP .AND. .NOT.TROP) THEN
               BAKV_8(1,L) = (TOB+273.16)*(1.+.61*QOB)-273.16
               BAKV_8(3,L) = IVTCD
               IF(SUBSET.EQ.'ADPUPA  ') THEN
C  Message type ADPUPA comes here
                  IF(QQM_8(L).LT.4 .OR. TQM_8(L).EQ.0 .OR.
     $             TQM_8(L).GT.3 .OR. POB.LE.700.) THEN
                     BAKV_8(2,L) = TQM_8(L) ! Tv qm same as for T when
                                            !  q ok
                     BAKV_8(4,L) = 0    ! Tv gets unique reason code 0
                  ELSE
                     BAKV_8(2,L) = 3    !Tv qm susp for bad moist below
                                        ! 700 mb
                     BAKV_8(4,L) = 6 !Tv gets unique reason code 6
                  ENDIF
               ELSE
C  All other message types come here
                  IF(QQM_8(L).LT.4) THEN
                     BAKV_8(2,L) = TQM_8(L) ! Tv qm same as for T when
                                            !  q ok
                     BAKV_8(4,L) = 0    ! Tv gets unique reason code 0
                  ELSE
cdak  print *, '%%% process tvirt on lvl ',l,' for bad QQM case'
                     BAKV_8(2,L) = 8 ! Tv qm bad for bad moist
                     BAKV_8(4,L) = 2 ! Tv gets unique reason code 2
                  ENDIF
               ENDIF
               EVNV = .TRUE.
            ENDIF
         ENDIF
      ENDDO
      ENDIF

C  ENCODE EVENTS INTO REPORT
C  -------------------------

      IF(NLEV.GT.0)  THEN
         IF(EVNQ) CALL UFBINT(IUNITP,BAKQ_8,4,NLEV,IRET,EVNSTQ)
         IF(EVNV) CALL UFBINT(IUNITP,BAKV_8,4,NLEV,IRET,EVNSTV)
      ENDIF

      RETURN
      END
C#######################
C#######################
C#######################
C#######################
C#######################
C#######################
C***********************************************************************
C***********************************************************************
      SUBROUTINE CGBLEVN10(IUNITF,IDATEP) ! FORMERLY SUBROUTINE GESRES
 
      COMMON /CGBEVFF/IMAX,JMAX,KMAX,kmaxs,DLAT,DLON,IDVC,SL(100),
     x     SI(101)
      COMMON /CGBEVHH/ JCAP,JCAP1,JCAP2,JCAP1X2,MDIMA,MDIMB,MDIMC

      DIMENSION  IDATE(8,2),JDATE(8,2),KDATE(8,2),IUNITF(2),FHR(2),
     $           KINDX(2)
 
      DIMENSION HEADR2(226,2)

      REAL RINC(5)

      CHARACTER*6 COORD(2)

      DATA COORD /'SIGMA ','HYBRID'/

      IF(MOD(MOD(IDATEP,100),3).EQ.0)  THEN
         KFILES = 1
         KINDX = 0
         PRINT 331, MOD(IDATEP,100)
  331    FORMAT(/' --> GBLEVENTS_CDAS: THE PREPBUFR CENTER HOUR (',I2.2,
     $    ') IS A MULTIPLE OF 3 - ONLY ONE GLOBAL SIGMA FILE IS READ,'/
     $    21X,'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_CDAS: THE PREPBUFR CENTER HOUR (',I2.2,
     $    ') IS NOT A MULTIPLE OF 3 - TWO SPANNING GLOBAL SIGMA FILES'/
     $    21X,'ARE READ AND THE SPECTRAL COEFFICIENTS ARE INTERPOLATED',
     $    ' TO THE PREPBUFR CENTER TIME'/)
      END IF

C  GET VALID-TIME DATE OF SIGMA FILE(S), ALSO READ HEADERS
C  -------------------------------------------------------

      JFILE = 0
      RINC  = 0
      DO IFILE=1,KFILES
         JFILE = IFILE
         REWIND IUNITF(IFILE)
         READ(IUNITF(IFILE),ERR=900) DUMMY
         IDATE(:,IFILE) = 0
         READ(IUNITF(IFILE),END=800,ERR=800) FHR(IFILE),idate(5,IFILE),
     $    idate(2,IFILE),idate(3,IFILE),idate(1,IFILE),HEADR2(:,IFILE)
         IHEADR2_SIZE = 226
cppppp
      print *
      print *, '##GBLEVENTS_CDAS/CGBLEVN10 - Guess file has a 226 word',
     $ ' header'
      print *
cppppp
         GO TO 801
  800    CONTINUE
         REWIND IUNITF(IFILE)
         READ(IUNITF(IFILE),ERR=900) DUMMY
         IDATE(:,IFILE) = 0
         READ(IUNITF(IFILE),END=900,ERR=900) FHR(IFILE),idate(5,IFILE),
     $    idate(2,IFILE),idate(3,IFILE),idate(1,IFILE),
     $    HEADR2(1:207,IFILE)
         IHEADR2_SIZE = 207
cppppp
      print *
      print *, '##GBLEVENTS_CDAS/CGBLEVN10 - Guess file has a 207 word',
     $ ' header'
      print *, '                           - most likely a CDAS sges ',
     $ 'file'
      print *
cppppp
  801    CONTINUE
         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_CDAS/CGBLEVN10 - 2-DIGIT YEAR FOUND ",
     $       "IN GLOBAL SIGMA FILE ",I0,"; INITIAL DATE (YEAR IS: ",I0,
     $       ") - USE WINDOWING TECHNIQUE TO OBTAIN 4-DIGIT YEAR")',
     $       IFILE,idate(1,IFILE)
C IF IDATE=41~99 THEN IDATE=1941~1999
C IF IDATE=00~40 THEN IDATE=2000~2040
            IF(IDATE(1,IFILE).GT.40)  THEN
               IDATE(1,IFILE) = 1900 + IDATE(1,IFILE)
            ELSE
               IDATE(1,IFILE) = 2000 + IDATE(1,IFILE)
            ENDIF
            PRINT'(" ##GBLEVENTS_CDAS/CGBLEVN10 - CORRECTED 4-DIGIT ",
     $       "YEAR IS NOW: ",I0)', IDATE(1,IFILE)
         ENDIF
         RINC(2) = ANINT(FHR(IFILE))
         CALL W3MOVDAT(RINC,IDATE(:,IFILE),JDATE(:,IFILE))
         PRINT 1, IFILE,ANINT(FHR(IFILE)),(IDATE(II,IFILE),II=1,3),
     $    IDATE(5,IFILE),(JDATE(II,IFILE),II=1,3),JDATE(5,IFILE)
    1    FORMAT(' --> GBLEVENTS_CDAS: GLOBAL SIGMA FILE',I2,' HERE IS ',
     $    'A ',F5.1,' HOUR FORECAST FROM ',I5.4,3I3.2,' VALID AT ',I5.4,
     $    3I3.2)
         KDATE(:,IFILE) = JDATE(:,IFILE)
         IF(KFILES.EQ.2) THEN
            RINC(2) = REAL(KINDX(IFILE))
            CALL W3MOVDAT(RINC,JDATE(:,IFILE),KDATE(:,IFILE))
         ENDIF
         IDATGS_COR = (KDATE(1,IFILE) * 1000000) + (KDATE(2,IFILE) *
     $    10000) + (KDATE(3,IFILE) * 100) + KDATE(5,IFILE)

C  VALID DATES MUST MATCH
C  ----------------------

         IF(IDATEP.NE.IDATGS_COR)  GO TO 901

      ENDDO

      IF(KFILES.EQ.2)  THEN

C  IF THERE ARE TWO SIGMA FILES, THEIR HEADERS MUST MATCH
C  -------------------------------------------------------

         JNDEX = 0
         DO  INDEX=1,IHEADR2_SIZE
            JNDEX = INDEX
            IF(HEADR2(INDEX,1).NE.HEADR2(INDEX,2)) GO TO 904
         ENDDO
      ENDIF

C  EXTRACT HEADER INFO
C  -------------------
 
      JCAP  = HEADR2(202,1)
      KMAX  = HEADR2(203,1)
      IF(IHEADR2_SIZE.EQ.226) THEN
         IDVC  = HEADR2(220,1)
      ELSE
         IDVC=0
      END IF
      kmaxs = 2*kmax+2

      if(idvc.eq.0)  idvc = 1  ! Reset IDVC=0 to 1 (sigma coord.)
      IF(IDVC.NE.1.AND.IDVC.NE.2) THEN
         PRINT'(" ##GBLEVENTS_CDAS/CGBLEVN10: INVALID VERT COORD ID ",
     $    "(=",I0,"), DEFAULTING TO SIGMA COORD, RESETTING IDVC = 1")',
     $    IDVC
        IDVC = 1
      END IF

      IF(KMAX.GT.100) GO TO 902
 
      IF(IDVC.EQ.1) THEN

C  SIGMA COORDINATE COEFFICIENTS
C  -----------------------------

         DO  L = 1,KMAX
            SI(L) = HEADR2(L,1)
            SL(L) = HEADR2(KMAX+1+L,1)
         ENDDO
         SI(KMAX+1) = HEADR2(KMAX+1,1)
      ELSEIF(IDVC.EQ.2) THEN

C  HYBRID COORDINATE COEFFICIENTS
C  ------------------------------

         DO  L = 1,KMAX+1

C  Convert AK HYBRID coeff for use in HPA
C  --------------------------------------

            SI(L) = (0.01)*HEADR2(L,1)
            SL(L) = HEADR2(KMAX+1+L,1)
         END DO
      END IF

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
 
cdak  IF(IMAX.LT.JCAP1X2) GO TO 903   ! commented out 9/27/01
 
      DLAT  = 180./(JMAX-1)
      DLON  = 360./IMAX
 
      PRINT 2, JCAP,KMAX,kmaxs,DLAT,DLON,COORD(IDVC)
    2 FORMAT(/' --> GBLEVENTS_CDAS: GLOBAL MODEL SPECS: T',I3,' ',I3,
     $ ' LEVELS ',I3,' SCALARS -------> ',F5.2,' X ',F5.2,' VERT. ',
     $ 'COORD: ',A)
 
      CALL CGBLEVN09(IUNITF,KINDX)
 
      RETURN

  900 CONTINUE
      PRINT'(" ##GBLEVENTS_CDAS/CGBLEVN10 - BAD OR MISSING GLOBAL ",
     $ "SIGMA FILE ",I0," - STOP 67")', JFILE
      CALL ERREXIT(67)
  901 CONTINUE
      PRINT 9901, JFILE,(JDATE(II,JFILE),II=1,3),JDATE(5,JFILE),IDATEP
 9901 FORMAT(/' ##GBLEVENTS_CDAS/CGBLEVN10 - SIGMA FILE',I2,' DATE (',
     $ I4.4,3(I2.2),'), DOES NOT MATCH -OR SPAN- PREPBUFR FILE CENTER ',
     $ 'DATE (',I10,') -STOP 68'/)
      CALL ERREXIT(68)
  902 CONTINUE
      PRINT'(" ##GBLEVENTS_CDAS/CGBLEVN10 - KMAX TOO BIG = ",I0," - ",
     $ "UNABLE TO TRANSFORM GLOBAL SIGMA FILE(S) - STOP 69")', KMAX
      CALL ERREXIT(69)
  903 CONTINUE
      PRINT'(" ##GBLEVENTS_CDAS/CGBLEVN10 - IMAX TOO SMALL = ",I0," - ",
     $ "UNABLE TO TRANSFORM GLOBAL SIGMA FILE(S) - STOP 70")', IMAX
      CALL ERREXIT(70)
  904 CONTINUE
      PRINT'(" ##GBLEVENTS_CDAS/CGBLEVN10 - HEADER INDEX ",I0," FOR ",
     $ "SIGMA FILE 1 (=",F8.3,") DOES NOT MATCH THAT FOR SIGMA FILE 2 ",
     $ "(=",F8.3," - STOP 71")', JNDEX,HEADR2(JNDEX,1),HEADR2(JNDEX,2)
      CALL ERREXIT(71)
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE CGBLEVN09(IUNITF,KINDX)
                                         ! FORMERLY SUBROUTINE COF2GRD
 
      use sp_mod

      parameter (PI180=.0174532)

      COMMON /CGBEVFF/IMAX,JMAX,KMAX,kmaxs,DLAT,DLON,IDVC,SL(100),
     x     SI(101)
      COMMON /CGBEVHH/ JCAP,JCAP1,JCAP2,JCAP1X2,MDIMA,MDIMB,MDIMC
 
      DIMENSION IUNITF(2),KINDX(2)

C Changes below allocates arrays from "heap" rather than "stack"
C     real      cofs(mdima,kmaxs), cofv(mdima,kmax,2)
C     real      cofs_f(mdima,kmaxs,2), cofv_f(mdima,kmax,2,2)
C     real      grds(IMAX,JMAX,kmaxs), grdv(IMAX,JMAX,kmax,2)
C     real      grd2(IMAX,JMAX,2)
      real,allocatable:: cofs(:,:), cofv(:,:,:)
      real,allocatable:: cofs_f(:,:,:), cofv_f(:,:,:,:)
      real,allocatable:: grds(:,:,:), grdv(:,:,:,:)
      real,allocatable:: grd2(:,:,:)

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(mdima,kmaxs), cofv(mdima,kmax,2))
      allocate (cofs_f(mdima,kmaxs,2), cofv_f(mdima,kmax,2,2))
      allocate (grds(IMAX,JMAX,kmaxs), grdv(IMAX,JMAX,kmax,2))
      allocate (grd2(IMAX,JMAX,2))

      IROMB=0
      MAXWV=JCAP
      IDRT=0
      IDIR=1


      IF(KINDX(1).EQ.0)  THEN
         KFILES = 1
      ELSE
         KFILES = 2
      ENDIF

      DO IFILE=1,KFILES
         ns=1
         DO I=1,5
            if (i.ne.4) then
                LEV = KMAX
                IF(I.LE.2) LEV = 1
                DO L=1,LEV
                  READ(IUNITF(IFILE),END=900,ERR=901)
     $             (COFS_f(II,NS,IFILE),II=1,MDIMA)
                  ns=ns+1
                enddo
            else
                NRD = 2
                DO L=1,LEV
                   DO K=1,NRD
                      READ(IUNITF(IFILE),END=900,ERR=901)
     $                 (COFV_f(II,L,K,IFILE),II=1,MDIMA)
                   ENDDO
                enddo
             endif
         enddo
      ENDDO

      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

      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)
      ns=1
      DO I=1,5
         if (i.ne.4) then
             LEV = KMAX
             IF(I.LE.2) LEV = 1
             DO L=1,LEV
                 call cgblevn11(imax,jmax,grds(1,1,ns))
                 if (ns.eq.2) then
                     DO J=1,JMAX
                         DO II=1,IMAX
                             GRDS(II,J,NS) = 10.*EXP(GRDS(II,J,NS))
                         ENDDO
                     ENDDO
                 endif
                 !print'(2i5,2e13.6)',i,l,grds(1,1,ns),GRDs(1,jmax/2,ns)
                 CALL CGBLEVN05(GRDS(1,1,NS),I,L)
                 ns=ns+1
             enddo
         else
             NRD = 2
             DO L=1,LEV
                DO K=1,NRD
                    call cgblevn11(imax,jmax,grdv(1,1,l,k))
                    do J=1,jmax
                        grd2(1:imax,j,k)=grdv(1:imax,j,l,k)
                    enddo
                enddo
                !print'(2i5,2e13.6)',i,l,grd2(1,1,1),GRD2(1,jmax/2,1)
                CALL CGBLEVN05(GRD2,I,L)
             enddo
         endif
      enddo
 
      deallocate (cofs, cofv)
      deallocate (cofs_f, cofv_f)
      deallocate (grds, grdv)
      deallocate (grd2)

      RETURN

  900 CONTINUE
      PRINT'(" ##GBLEVENTS_CDAS/CGBLEVN09 - EOF READING GLOBAL SIGMA ",
     $ "FILE - UNABLE TO TRANSFORM GLOBAL SIGMA FILE - STOP 64")'
      CALL ERREXIT(64)
  901 CONTINUE
      PRINT'(" ##GBLEVENTS_CDAS/CGBLEVN09 - ERROR READING GLOBAL SIGMA",
     $ " FILE - UNABLE TO TRANSFORM GLOBAL SIGMA FILE - STOP 65")'
      CALL ERREXIT(65)
  902 CONTINUE
      PRINT'(" ##GBLEVENTS_CDAS/CGBLEVN09 - IDIM NOT FACTORABLE - ",
     $ "UNABLE TO TRANSFORM GLOBAL SIGMA FILE - STOP 66")'
      CALL ERREXIT(66)
      END
C***********************************************************************
C***********************************************************************
      subroutine cgblevn11(imax,jmax,grid)! formerly subroutine n_s_swap
      real grid(imax,jmax)
      real temp (imax)

      do j=1,jmax/2
          jj=jmax-j+1
          temp(1:imax)   =grid(1:imax,j)
          grid(1:imax,j) =grid(1:imax,jj)
          grid(1:imax,jj)=temp(1:imax)
      enddo
      return
      end
C####################
C####################
C####################
C####################
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                  C
C ==============================================================   C
C | DESCRIPTION | NAME   | BITS | MAX VALUE  | DIMENSIONS      |   C
C |=============*========*======*============*=================|   C
C | ZSG01_C     | ZSG01_C| WORD | REAL       | 384,193         |   C
C |-------------+--------+------+------------+-----------------|   C
C | PSG01_C     | PSG01_C| WORD | REAL       | 384,193         |   C
C |-------------+--------+------+------------+-----------------|   C
C | TG01_C      | TG01_C | WORD | REAL       | 384,193,64      |   C
C |-------------+--------+------+------------+-----------------|   C
C | UG01_C      | UG01_C | WORD | REAL       | 384,193,64      |   C
C |-------------+--------+------+------------+-----------------|   C
C | VG01_C      | VG01_C | WORD | REAL       | 384,193,64      |   C
C |-------------+--------+------+------------+-----------------|   C
C | QG01_C      | QG01_C | WORD | REAL       | 384,193,64      |   C
C ==============^========^======^============^==================   C
C                                                                  C
C***********************************************************************
C***********************************************************************
      FUNCTION ZSG01_C(I,J) ! FORMERLY FUNCTION ZS
      PARAMETER (IM = 384)
      PARAMETER (JM = 193)
      COMMON /CGBEVJJ/IAR_8(IM,JM)
      REAL(8) IAR_8
      REAL ZSG01_C
      ZSG01_C = IAR_8(I,J)
      RETURN
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE CGBLEVN12(I,J,V) ! FORMERLY SUBROUTINE ZSP
      PARAMETER (IM = 384)
      PARAMETER (JM = 193)
      COMMON /CGBEVJJ/IAR_8(IM,JM)
      REAL(8) IAR_8
      REAL V
      IAR_8(I,J) = V
      RETURN
      END
C***********************************************************************
C***********************************************************************
      FUNCTION PSG01_C(I,J) ! FORMERLY FUNCTION PS
      PARAMETER (IM = 384)
      PARAMETER (JM = 193)
      COMMON /CGBEVKK/IAR_8(IM,JM)
      REAL(8) IAR_8
      REAL PSG01_C
      PSG01_C = IAR_8(I,J)
      RETURN
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE CGBLEVN13(I,J,V) ! FORMERLY SUBROUTINE PSP
      PARAMETER (IM = 384)
      PARAMETER (JM = 193)
      COMMON /CGBEVKK/IAR_8(IM,JM)
      REAL(8) IAR_8
      REAL V
      IAR_8(I,J) = V
      RETURN
      END
C***********************************************************************
C***********************************************************************
      FUNCTION TG01_C(I,J,K) ! FORMERLY FUNCTION T
      PARAMETER (IM = 384)
      PARAMETER (JM = 193)
      PARAMETER (KM = 64)
      COMMON /CGBEVLL/IAR_8(IM,JM,KM)
      REAL(8) IAR_8
      REAL TG01_C
      TG01_C = IAR_8(I,J,K)
      RETURN
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE CGBLEVN14(I,J,K,V) ! FORMERLY SUBROUTINE TP
      PARAMETER (IM = 384)
      PARAMETER (JM = 193)
      PARAMETER (KM = 64)
      COMMON /CGBEVLL/IAR_8(IM,JM,KM)
      REAL(8) IAR_8
      REAL V
      IAR_8(I,J,K) = V
      RETURN
      END
C***********************************************************************
C***********************************************************************
      FUNCTION UG01_C(I,J,K) ! FORMERLY FUNCTION U
      PARAMETER (IM = 384)
      PARAMETER (JM = 193)
      PARAMETER (KM = 64)
      COMMON /CGBEVMM/IAR_8(IM,JM,KM)
      REAL(8) IAR_8
      REAL UG01_C
      UG01_C = IAR_8(I,J,K)
      RETURN
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE CGBLEVN15(I,J,K,V) ! FORMERLY SUBROUTINE UP
      PARAMETER (IM = 384)
      PARAMETER (JM = 193)
      PARAMETER (KM = 64)
      COMMON /CGBEVMM/IAR_8(IM,JM,KM)
      REAL(8) IAR_8
      REAL V
      IAR_8(I,J,K) = V
      RETURN
      END
C***********************************************************************
C***********************************************************************
      FUNCTION VG01_C(I,J,K) ! FORMERLY FUNCTION V
      PARAMETER (IM = 384)
      PARAMETER (JM = 193)
      PARAMETER (KM = 64)
      COMMON /CGBEVNN/IAR_8(IM,JM,KM)
      REAL(8) IAR_8
      REAL VG01_C
      VG01_C = IAR_8(I,J,K)
      RETURN
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE CGBLEVN16(I,J,K,V) ! FORMERLY SUBROUTINE VP
      PARAMETER (IM = 384)
      PARAMETER (JM = 193)
      PARAMETER (KM = 64)
      COMMON /CGBEVNN/IAR_8(IM,JM,KM)
      REAL(8) IAR_8
      REAL V
      IAR_8(I,J,K) = V
      RETURN
      END
C***********************************************************************
C***********************************************************************
      FUNCTION QG01_C(I,J,K) ! FORMERLY FUNCTION Q
      PARAMETER (IM = 384)
      PARAMETER (JM = 193)
      PARAMETER (KM = 64)
      COMMON /CGBEVOO/IAR_8(IM,JM,KM)
      REAL(8) IAR_8
      REAL QG01_C
      QG01_C = IAR_8(I,J,K)
      RETURN
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE CGBLEVN17(I,J,K,V) ! FORMERLY SUBROUTINE QP
      PARAMETER (IM = 384)
      PARAMETER (JM = 193)
      PARAMETER (KM = 64)
      COMMON /CGBEVOO/IAR_8(IM,JM,KM)
      REAL(8) IAR_8
      REAL V
      IAR_8(I,J,K) = V
      RETURN
      END
