C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    GBLEVENTS   PRE/POST PROCESSING OF PREPBUFR EVENTS
C   PRGMMR: D. A. KEYSER     ORG: NP22       DATE: 2002-05-10
C
C ABSTRACT: RUNS IN TWO MODES: "PREVENTS" AND "POSTEVENTS".  IN THE
C   PREVENTS MODE, PREPARES OBSERVATIONAL PREPBUFR REPORTS FOR
C   SUBSEQUENT QUALITY CONTROL AND ANALYSIS PROGRAMS.  THIS IS DONE
C   THROUGH THE FOLLOWING: INTERPOLATION OF GLOBAL SPECTRAL SIMGA
C   FIRST GUESS TO PREPBUFR OBSERVATION LOCATIONS WITH ENCODING OF
C   FIRST GUESS VALUES INTO PREPBUFR REPORTS; ENCODING OF "PREVENT"
C   AND/OR "VIRTMP" EVENTS INTO PREPBUFR REPORTS; AND ENCODING OF
C   OBSERVATION ERRORS FROM THE ERROR SPECIFICATION FILE INTO
C   PREPBUFR REPORTS.  IN THE POSTEVENTS MODE, AFTER ALL QUALITY
C   CONTROL AND ANALYSIS PROGRAMS HAVE RUN, INTERPOLATES THE GLOBAL
C   SPECTRAL SIMGA ANALYSIS TO PREPBUFR OBSERVATION LOCATIONS AND
C   ENCODES THESE ANALYZED VALUES INTO PREPBUFR REPORTS.  THE
C   REMAINDER OF THIS ABSTRACT APPLIES ONLY TO THE PREVENTS MODE.
C   THE "PREVENT" EVENT CAN CHANGE A QUALITY MARKER TO FLAG AN
C   OBSERVATION DATUM FOR NON-USE BY SUBSEQUENT QC AND ANALYSIS
C   PROGRAMS (FILTERING).  EXAMPLES WHERE THIS SUBROUTINE WILL WRITE
C   AN EVENT TO FLAG A DATUM INCLUDE: THE OBSERVATION ERROR FOR THAT
C   DATUM IS READ IN AS MISSING IN THE INPUT ERROR FILE, THE DATUM
C   ITSELF VIOLATES A GROSS OR "SANITY" CHECK, OR THE OBSERVED
C   PRESSURE DATUM IS MORE THAN 100 MB BELOW THE GUESS SURFACE
C   PRESSURE.  THE "VIRTMP" EVENT CAN CHANGE THE SPECIFIC HUMIDITY
C   OBSERVATION (RE-CALCULATED) AS WELL AS THE TEMPERATURE
C   OBSERVATION (FROM SENSIBLE TO VIRTUAL TEMPERATURE, BASED ON
C   JUST-CALCULATED SPECIFIC HUMIDITY).  CURRENTLY THIS APPLIES ONLY
C   TO SURFACE (LAND AND MARINE) DATA TYPES [OTHER DATA TYPES WITH
C   REPORTED SENSIBLE TEMPERATURE EITHER HAVE MISSING MOISTURE (E.G.,
C   ALL AIRCRAFT TYPES EXCEPT FOR SOME ACARS, SATELLITE WIND TYPES),
C   FLAGGED MOISTURE (E.G., SOME ACARS) OR CALCULATE SPECIFIC
C   HUMIDITY/VIRTUAL TEMPERATURE IN SUBSEQUENT PROGRAMS (E.G.,
C   RADIOSONDES WHICH CALCULATE THESE IN PROGRAM "CQCBUFR")]. FOR
C   CASES WHERE THE SWITCH "DOBERR" IS FALSE, THE OBSERVATION ERROR
C   FOR ALL DATA REMAINS MISSING IN THE PREPBUFR FILE.  IN THIS CASE,
C   THE INPUT ERROR FILE IS USUALLY A NULL FILE AND THE "PREVENT"
C   EVENT TO FLAG THE DATUM IS NOT INVOKED.  FOR CASES WHERE THE
C   SWITCH "DOFCST" IS FALSE, THE FORECAST VALUES FOR ALL DATA IN
C   THOSE MESSAGE TYPES FOR WHICH A GUESS VALUE IS NOT NEEDED BY
C   SUBSEQUENT QC PROGRAMS REMAINS MISSING.  IT SHOULD BE NOTED THAT
C   THE FILTERING OF DATA ASSOCIATED WITH THE "PREVENT" EVENT
C   PROCESSING IS NOT INVOKED IF ALL THREE ARE TRUE: DOBERR= FALSE,
C   THE FORECAST VALUES ARE MISSING (DOFCST=FALSE & MESSAGE TYPE IS
C   NOT "ADPUPA", "AIRCFT", "AIRCAR", "PROFLR", OR "VADWND"), AND
C   "VIRTMP" EVENT PROCESSING IS NOT INVOKED (MESSAGE TYPE IS NOT
C   "ADPSFC" OR "SFCSHP").
C
C PROGRAM HISTORY LOG:
C 1999-07-01 D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM PREVENTS
C             SUBROUTINE IN PREPDATA PROGRAM, BUT NOW GENERALIZED FOR
C             POSTEVENTS MODE)
C 1999-07-12 D. A. KEYSER -- MODIFIED TO INTERPOLATE MODEL SPECIFIC
C             HUMIDITY TO OBSERVATION LOCATION WHEN OBS. SPECIFIC
C             HUMIDITY IS MISSING AS LONG AS OBS. TEMPERATURE IS
C             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,
C             EVEN WHEN DOFCST=FALSE (NECESSARY BECAUSE THE NEW
C             PROGRAM CQCVAD NEEDS THE BACKGROUND DATA)
C 1999-09-09 D. A. KEYSER -- CHANGES TO MAKE CODE MORE PORTABLE;
C             'TFC' NOW GENERATED FOR VADWND MESSAGE TYPES EVEN
C             THOUGH TOB IS 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
C             (SUBJECT TO A SANITY CHECK), HOWEVER THE VIRT.
C             TEMPERATURE GETS A BAD 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
C             NOW READ IN AS A N-LIST SWITCH (QTOP_REJ), BEFORE IT
C             WAS HARDWIRED TO 300 MB
C 2000-12-13 D. A. KEYSER -- WILL NO LONGER PERFORM VIRTUAL TEMPERATURE
C             PROCESSING FOR ACARS DATA SINCE MOISTURE IS FLAGGED
C             RIGHT NOW (ACARS MOISTURE ONLY WRITTEN INTO PREPBUFR
C             FILE FOR STATISTICAL REASONS)
C 2001-02-02 D. A. KEYSER -- RESTORED LEGACY LOGIC TO FLAG CERTAIN
C             SATELLITE TEMPERATURE SOUNDINGS EITHER BELOW 100 MB
C             (TEMP. OBS) OR ON ALL LEVELS (SPEC. HUM. OBS), CONTROLLED
C             BY NEW NAMELIST 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
C             "TOB" AND "QOB" ARE MISSING (NEEDED BY SYNDATA PROGRAM);
C             IN PREPARATION FOR CHANGE FROM T170L42 TO T254L64 SGES,
C             NOW MAKES COEFFICIENT ARRAYS ALLOCATABLE TO ALLOW THEM
C             TO OBTAIN MEMORY FROM "HEAP" RATHER THAN FROM "STACK",
C             ALSO HAVE INCREASED THE MAX NUMBER OF LEVELS IN ARRAYS
C             FROM 42 TO 64, FINALLY ALSO NO LONGER STOPS WITH C. CODE
C             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
C             FILE IS NOT AVAILABLE; E.G., IN RUC2A RUNS) NOW PERFORMS
C             A LINEAR INTERPOLATION BETWEEN SPECTRAL COEFFICIENTS IN 2
C             SPANNING SIGMA GUESS/ANAL FILES 3-HRS APART TO CENERATE A
C             GUESS/ANAL FILE VALID 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
C             ENCODED WHEN DOFCST IS FALSE (BECAUSE ACARS ARE NOW
C             Q.C.'d IN PREPOBS_ACARSQC PROGRAM)
C
C USAGE:    CALL GBLEVENTS(IDATEP,IUNITF,IUNITE,IUNITP,IUNITS,SUBSET,
C          $               NEWTYP)
C   INPUT ARGUMENT LIST:
C     IDATEP   - CENTER DATE FOR PREPBUFR FILE IN THE FORM YYYYMMDDHH
C     IUNITF   - 2-WORD ARRAY:
C              - WORD 1 - UNIT NUMBER OF FIRST INPUT SPECTRAL (GLOBAL)
C              - SIGMA 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:      GBLENV01 GBLEVN02   GBLEVN03    GBLEVN04
C                  GBLEVN05 GBLEVN06   OEFG01      GBLEVN07
C                  GBLEVN08 GBLEVN09   GBLEVN10    GBLEVN11
C                  ZSG01    GBLEVN12   PSG01       GBLEVN13
C                  TG01     GBLEVN14   UG01        GBLEVN15
C                  VG01     GBLEVN16   QG01        GBLEVN17
C     LIBRARY:
C       SPLIB    - SPTEZM   SPTEZMV
C       W3LIB    - W3MOVDAT ERREXIT
C       BUFRLIB  - UFBINT   UFBQCD
C
C   EXIT STATES:
C     COND =   0 - SUCCESSFUL RUN
C     COND =  60 - OBSERVATION ERROR TABLE EMPTY OR DOES NOT EXIST
C     COND =  61 - VARIABLE NLTD .NE. VARIABLE NLEV
C     COND =  62 - VARIABLE NLTQ .NE. VARIABLE NLEV
C     COND =  63 - VARIABLE NLQQ .NE. VARIABLE NLEV
C     COND =  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  - WRITE VIRTUAL TEMPERATURE EVENT FOR SURFACE LAND AND
C               MARINE REPORTS?  THIS WILL ATTEMPT TO CALCULATE VIRTUAL
C               TEMPERATURE FROM SENSIBLE TEMPERATURE AND ENCODE IT AS
C               A STACKED EVENT IN THE PREPBUFR FILE.
C              DOVTMP = .TRUE.  ---> YES                       (DEFAULT)
C              DOVTMP = .FALSE. ---> NO
C      (NOTE1: DOVTMP=FALSE WILL STILL RE-CALCULATE SPECIFIC HUMIDITY
C              AND ENCODE IT AS A STACKED EVENT IN THE PREPBUFR FILE
C              UNLESS DOANLS IS TRUE.)
C      (NOTE2: ONLY APPLIES TO SURFACE LAND AND MARINE DATA TYPES.)
C      (NOTE3: IF DOANLS=TRUE, THEN DOVTMP IS NOT ONLY FORCED TO BE
C              FALSE, BUT ALSO SPECIFIC HUMIDITY IS NOT RE-CALCULATED.)
C
C    DOFCST  - ENCODE FORECAST (FIRST GUESS) VALUES, INTERPOLATED FROM
C              THE SPECTRAL SIGMA GUESS FILE, INTO THE PREPBUFR FILE?
C              DOFCST = .TRUE.  ---> YES, FOR ALL DATA TYPES   (DEFAULT)
C              DOFCST = .FALSE. ---> NO, UNLESS MESSAGE TYPE IS ONE
C                       OF THE FOLLOWING: "ADPUPA", "AIRCFT", "AIRCAR",
C                       "PROFLR" OR "VADWND" (VALUES REMAIN MISSING)
C      (NOTE1: DOFCST=FALSE MUST STILL WRITE THE FORECAST VALUES FOR
C              THE TYPES MENTIONED ABOVE BECAUSE THEY ARE NEEDED BY
C              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 DATA
C              TYPES IN THE PREPBUFR FILE.)
C      (NOTE3: IF DOANLS=TRUE, THEN DOFCST IS NOT ONLY FORCED TO BE
C              FALSE, BUT ALSO A GUESS WILL NOT BE ENCODED FOR ANY
C              DATA TYPE.)
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 DATA TYPES
C              DOANLS = .FALSE. ---> NO,  FOR ALL DATA 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 DATA TYPE AND SPECIFIC HUMIDITY WILL
C              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              NON-GLOBAL VERSIONS SINCE ONLY THE GLOBAL-SSI REQUIRES
C              OBSERVATIONAL ERRORS TO BE PRESENT IN THE PREPBUFR
C              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:  IBM-SP
C
C$$$
C----------------------------------------------------------------------
C----------------------------------------------------------------------
      SUBROUTINE GBLEVENTS(IDATEP,IUNITF,IUNITE,IUNITP,IUNITS,SUBSET,
     $                    NEWTYP)

      CHARACTER*80 HEADR,OBSTR,FCSTR,OESTR,ANSTR
      CHARACTER*8  SUBSET
      REAL(8)      OBS,BAK,SID,HDR(10)
      LOGICAL      DOVTMP,DOFCST,DOBERR,FCST,VIRT,DOANLS,SATMQC

      DIMENSION    IUNITF(2)

      COMMON /GBEVAA/ SID,OBS(8,255),BAK(8,255),NLEV,XOB,YOB,DHR,TYP
      COMMON /GBEVBB/ PVCD,VTCD
      COMMON /GBEVCC/ DOVTMP,DOFCST,DOBERR,FCST,VIRT,QTOP_REJ,SATMQC
      COMMON /GBEVDD/ ERRS(300,33,6)

      SAVE

      DATA IFIRST/0/

      DATA HEADR /'SID XOB YOB DHR TYP                       '/
      DATA OBSTR /'POB QOB TOB ZOB UOB VOB PWO CAT           '/
      DATA FCSTR /'PFC QFC TFC ZFC UFC VFC PWF               '/
      DATA ANSTR /'PAN QAN TAN ZAN UAN VAN PWA               '/
      DATA OESTR /'POE QOE TOE ZOE WOE PWE                   '/

      NAMELIST /PREVDATA/DOVTMP,DOFCST,DOBERR,DOANLS,QTOP_REJ,SATMQC

C----------------------------------------------------------------------
C----------------------------------------------------------------------

      IF(IFIRST.EQ.0)  THEN

C -------------------------------
C FIRST TIME IN DO A FEW THINGS...
C -------------------------------

         IFIRST = 1
         PRINT 700
  700 FORMAT(/1X,100('#')/' =====> SUBROUTINE GBLEVENTS INVOKED FOR ',
     $ 'THE FIRST TIME - VERSION LAST UPDATED 2002-05-10'/)

C  INITIALIZE NAMELIST SWITCHES TO DEFAULT VALUES
C  ----------------------------------------------

         DOVTMP = .TRUE.
         DOFCST = .TRUE.
         DOBERR = .TRUE.
         DOANLS = .FALSE.
         QTOP_REJ = 300.
         SATMQC = .FALSE.
         READ(5,PREVDATA,ERR=101,END=101)
         GO TO 102
C-----------------------------------------------------------------------
  101    CONTINUE

C  STANDARD INPUT IS EMPTY - THIS DEFAULTS TO POSTEVENTS MODE
C  ----------------------------------------------------------

         PRINT 7013
 7013 FORMAT(/' ##> GBLEVENTS: STANDARD INPUT DATA CARDS DO NOT ',
     $ 'EXIST -- DEFAULTS TO "POSTEVENTS" MODE'/)
         DOANLS = .TRUE.

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

         FCST = DOFCST
         VIRT = .FALSE.

C  CHECK VALID-TIME DATE OF GUESS/ANALYSIS FILE(S) AGAINST THE CENTER
C   DATE FOR THE PREPBUFR FILE AND OBTAIN THE FIRST GUESS/ANALYSIS
C  ------------------------------------------------------------------

         IF(.NOT.DOANLS)  THEN
            PRINT 701
  701 FORMAT(/' --> GBLEVENTS: PREVENTS MODE - DATE CHECK AND ',
     $ 'TRANSFORM THE FIRST GUESS'/)
         ELSE
            PRINT 7701
 7701 FORMAT(/' --> GBLEVENTS: POSTEVENTS MODE - DATE CHECK AND ',
     $ 'TRANSFORM THE ANALYSIS'/)
         END IF

         CALL GBLEVN10(IUNITF,IDATEP)

         IF(DOBERR)  THEN

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

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

            CALL GBLEVN01(IUNITE)

         ELSE

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

         END IF

C  SET INTERPOLATION FACTORS
C  -------------------------

         PRINT 902
  902 FORMAT(' --> GBLEVENTS: SET INTERPOLATION FACTORS'/)

         CALL GBLEVN07

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

         CALL UFBQCD(IUNITP,'PREVENT',PVCD)
         CALL UFBQCD(IUNITP,'VIRTMP ',VTCD)

         PRINT 703
  703 FORMAT(/1X,100('#')/)

C  SET-UP OUTPUT "PREVENT" EVENTS DATA FILTERING SUMMARY PRINT FILE
C  (ONLY USED IN PREVENTS MODE)
C  ----------------------------------------------------------------

         IF(.NOT.DOANLS)  WRITE(IUNITS,1701) IDATEP
 1701 FORMAT(//130('#')//38X,'*** "PREVENT" EVENTS DATA FILTERING ',
     $ 'SUMMARY ***'/35X,'--> CENTER DATE FOR PREPBUFR FILE IS: ',I10,
     $ ' <--'//)

C----------------------------------------------------------------------
C----------------------------------------------------------------------

      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)   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.'AIRCAR  ')
c
c  Sienkiewicz 7/13/04 - eliminate virtual temp calculation
c            for all types for now because it will recalculate
c            specific humidity using the current temperature value
c            which, when PREVENTS is rerun, would be Tv instead.
c
c        VIRT = (SUBSET.EQ.'ADPSFC  '.OR.SUBSET.EQ.'SFCSHP  ')

         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,255,NLEV,OBSTR)
      CALL UFBINT(-IUNITP,HDR,10,  1,IRET,HEADR)
      SID = HDR(1)
      XOB = HDR(2)
      YOB = HDR(3)
      DHR = HDR(4)
      TYP = HDR(5)

      IF(FCST.OR.DOANLS)  THEN

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

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

         CALL GBLEVN03(SUBSET)
         IF(FCST)   THEN
            CALL UFBINT(IUNITP,BAK,8,NLEV,IRET,FCSTR)
         ELSE
            CALL UFBINT(IUNITP,BAK,8,NLEV,IRET,ANSTR)
            RETURN
         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 GBLEVN04
         CALL UFBINT(IUNITP,BAK,8,NLEV,IRET,OESTR)
      END IF

C  MAKE THE GBLEVENTS EVENTS AND ENCODE INTO REPORT
C  ------------------------------------------------

      IF(.NOT.FCST)  THEN
         IF(NEWTYP.EQ.1)  WRITE(IUNITS,1704)
 1704 FORMAT(/'  ==> FILTERING VIA POB VS. GESS PSFC TEST NOT POSSIBLE',
     $ ' FOR THIS TABLE A ENTRY SINCE FORECAST VALUES NOT PROCESSED/',
     $ 'STORED'/)
      ENDIF

      IF(.NOT.DOBERR)  THEN
         IF(NEWTYP.EQ.1)  WRITE(IUNITS,1705)
 1705 FORMAT(/'  ==> FILTERING VIA MISSING OBS ERROR TEST NOT POSSIBLE',
     $ ' FOR THIS TABLE A ENTRY SINCE OBS ERROR VALUES NOT PROCESSED/',
     $ 'STORED'/)
      ENDIF

      CALL GBLEVN02(IUNITP,IUNITS,NEWTYP)

C  MAKE THE VIRTUAL TEMPERATURE EVENTS AND ENCODE INTO REPORT
C  ----------------------------------------------------------

      IF(.NOT.VIRT)  THEN
         IF(NEWTYP.EQ.1)  WRITE(IUNITS,1706)
 1706 FORMAT(/'  ==> "VIRTMP" EVENT PROCESSING NOT PERFORMED FOR THIS ',
     $ 'TABLE A ENTRY'/)
      ELSE
         IF(NEWTYP.EQ.1)  WRITE(IUNITS,1707)
 1707 FORMAT(/'  ==> "VIRTMP" EVENT PROCESSING IS  PERFORMED FOR THIS ',
     $ 'TABLE A ENTRY'/)
         CALL GBLEVN08(IUNITP)
      ENDIF

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

      RETURN

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

      COMMON /GBEVDD/ ERRS(300,33,6)

C  READ THE OBSERVATION ERROR TABLES
C  ---------------------------------

      REWIND IUNITE

      IREC = 0

   10 CONTINUE
      READ(IUNITE,'(1X,I3)',END=100) KX
      IREC = IREC + 1
      DO K=1,33
         READ(IUNITE,'(1X,6E12.5)') (ERRS(KX,K,M),M=1,6)
      ENDDO
      GO TO 10

  100 CONTINUE
      IF(IREC.EQ.0) THEN
         PRINT *, '##GBLEVENTS/GBLEVN01 - OBS. ERROR TABLE EMPTY OR ',
     $    'DOES NOT EXIST - STOP 60'
         CALL ERREXIT(60)
      END IF

      RETURN

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

      DIMENSION    NFLGRT(100:299,8)
      CHARACTER*8  STNID
      CHARACTER*40 PEVN,QEVN,TEVN,WEVN,PWVN
      REAL(8)      PEV(4,255),QEV(4,255),TEV(4,255),WEV(5,255),
     $             PWV(4,255),OBS,BAK,SID
      LOGICAL      FCST,DN2FAR,REJPS,REJT,REJQ,REJW,REJPW,SATMQC,SATEMP,
     $             SOLN60,SOLS60

      COMMON /GBEVAA/ SID,OBS(8,255),BAK(8,255),NLEV,XOB,YOB,DHR,TYP
      COMMON /GBEVBB/ PVCD,VTCD
      COMMON /GBEVCC/ DOVTMP,DOFCST,DOBERR,FCST,VIRT,QTOP_REJ,SATMQC
      COMMON /GBEVEE/PSG01,ZSG01,TG01(100),UG01(100),VG01(100),QG01(100)

      EQUIVALENCE (SID,STNID)

      DATA PEVN /'POB PQM PPC PRC     '/
      DATA QEVN /'QOB QQM QPC QRC     '/
      DATA TEVN /'TOB TQM TPC TRC     '/
      DATA WEVN /'UOB VOB WQM WPC WRC '/
      DATA PWVN /'PWO PWQ PWP PWR     '/

      DATA BMISS /10E10/,NFLGRT/1600*0/

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

      IF(NEWTYP.EQ.1)  NFLGRT = 0

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

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

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

      PEV = BMISS
      QEV = BMISS
      TEV = BMISS
      WEV = BMISS
      PWV = BMISS

      MAXPEV = 0
      MAXQEV = 0
      MAXTEV = 0
      MAXWEV = 0
      MAXPWV = 0

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

      DO L=1,NLEV

         POB = OBS(1,L)
         QOB = OBS(2,L)
         TOB = OBS(3,L)
         UOB = OBS(5,L)
         VOB = OBS(6,L)
         PWO = OBS(7,L)
         CAT = OBS(8,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 = POB
            IF(POB-PSG01.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
  303 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2,
     $ 'E, REJECT ALL DATA ON SFC LVL - POB=',F6.1,' MB, > 100 MB ',
     $ 'BELOW GES PSFC(=',F6.1,'MB)')
                  ELSE
                     WRITE(IUNITS,102) STNID,NINT(TYP),YOB,XOB,POB,PSG01
  102 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2,
     $ 'E, REJECT ALL DATA ON LVL - POB=',F6.1,' MB, > 100 MB BELOW ',
     $ 'GES PSFC(=',F6.1,' MB)')
                  ENDIF
                  RCD = 1
               END IF
               REJ = 8
               DN2FAR = .TRUE.
               PEV(1,L) = POB
               PEV(2,L) = REJ
               PEV(3,L) = PVCD
               PEV(4,L) = RCD
               MAXPEV = L
            ENDIF
         ENDIF

C  -------------------------------------------------------------------
C  RULES FOR SURFACE PRESSURE -- ALL 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 = POB
            REJPS = OEFG01(POB,TYP,5).GE.BMISS            .OR.
     $              ABS(POB-PSG01).GE.100.                .OR.
     $              POB.LE.450.                           .OR.
     $              POB.GE.1100.
            IF(REJPS.OR.DN2FAR) THEN
               IF(.NOT.DN2FAR)  THEN
                  IF(OEFG01(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).GE.100.)  THEN
                     WRITE(IUNITS,104) STNID,NINT(TYP),YOB,XOB,POB,PSG01
  104 FORMAT(' ~~> ID ',A8,' (RTP ',I3,'), LAT=',F6.2,'N, LON=',F6.2,
     $ 'E, REJECT ALL DATA ON SFC LVL - POB=',F6.1,' MB, > 100 MB ',
     $ 'ABOVE GES PSFC(=',F6.1,'MB)')
                     RCD = 4
                  ELSE
                     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(1,L) = POB
               PEV(2,L) = REJ
               PEV(3,L) = PVCD
               PEV(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  -------------------------------------------------------------------

         IF(TOB.LT.BMISS) THEN
            REJT = OEFG01(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(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(1,L) = TOB
               TEV(2,L) = REJ
               TEV(3,L) = PVCD
               TEV(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(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(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(1,L) = QOB
               QEV(2,L) = REJ
               QEV(3,L) = PVCD
               QEV(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(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(1,L) = UOB
               WEV(2,L) = VOB
               WEV(3,L) = REJ
               WEV(4,L) = PVCD
               WEV(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(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(1,L) = PWO
               PWV(2,L) = 9
               PWV(3,L) = PVCD
               PWV(4,L) = 3
               MAXPWV = L
            ENDIF
         ENDIF

      ENDDO

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

      IF(MAXPEV.GT.0) CALL UFBINT(IUNITP,PEV,4,MAXPEV,IRET,PEVN)
      IF(MAXQEV.GT.0) CALL UFBINT(IUNITP,QEV,4,MAXQEV,IRET,QEVN)
      IF(MAXTEV.GT.0) CALL UFBINT(IUNITP,TEV,4,MAXTEV,IRET,TEVN)
      IF(MAXWEV.GT.0) CALL UFBINT(IUNITP,WEV,5,MAXWEV,IRET,WEVN)
      IF(MAXPWV.GT.0) CALL UFBINT(IUNITP,PWV,4,MAXPWV,IRET,PWVN)

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

      DIMENSION PINT(KMAX),ZINT(KMAX)
      REAL(8)   OBS,BAK,SID
      CHARACTER*8  SUBSET

      COMMON /GBEVAA/ SID,OBS(8,255),BAK(8,255),NLEV,XOB,YOB,DHR,TYP
      COMMON /GBEVFF/ IMAX,JMAX,KMAX,kmaxs,DLAT,DLON,SL(100),SI(101)
      COMMON /GBEVGG/ MAXPRS,SITERP(1200),SLTERP(1200)
      COMMON /GBEVEE/PSG01,ZSG01,TG01(100),UG01(100),VG01(100),QG01(100)

      DATA BMISS / 10E10  /
      DATA TZERO / 273.15 /
      DATA BETAP / .0552  /
      DATA BETA  / .00650 /
      DATA ROG   / 29.261 /

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

      BAK = BMISS

C  GET SIGMA PROFILE AT OB LOCATION
C  --------------------------------

      CALL GBLEVN06(XOB,YOB)
      PS000 = 1000./PSG01
      PSIG  = PSG01*SL(1)
      PINT(1) = PSG01
      ZINT(1) = ZSG01
      DO K=2,KMAX
         K0 = K-1
         PINT(K) = PSG01*SI(K)
         ZINT(K) = ZINT(K0) - ROG*TG01(K0)*LOG(PINT(K)/PINT(K0))
      ENDDO

C  INTERPOLATE SIGMA PROFILES TO OB PRESSURES
C  ------------------------------------------

      DO 10 L=1,NLEV

         POB = OBS(1,L)
         QOB = OBS(2,L)
         TOB = OBS(3,L)
         ZOB = OBS(4,L)
         UOB = OBS(5,L)
         VOB = OBS(6,L)
         PWO = OBS(7,L)
         CAT = OBS(8,L)
         IF(POB.LE.0. .OR. POB.GE.BMISS) GOTO 10

         IP  = POB*PS000
         IP  = MIN(IP,MAXPRS)
         IP  = MAX(IP,1)

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

         IF(CAT.EQ.0 .AND. ZOB.LT.BMISS) THEN
            TS = TG01(1) + (PSG01-PSIG)*BETAP
            DZ  = ZOB-ZSG01
            TM  = TS - DZ*BETA*.5
            PFC = PSG01*EXP(-DZ/(TM*ROG))
         ELSE
            PFC = BMISS
         ENDIF

C  SPECIFIC HUMIDITY
C  -----------------

         IF(QOB.LT.BMISS.OR.TOB.LT.BMISS.OR.TYP.EQ.111) THEN

C  (QFC NEEDED BY SYNDATA PROGRAM BUT ONLY FOR REPORT TYPE 111)

            LB = SLTERP(IP)
            WT = SLTERP(IP)-LB
            LA = MIN(LB+1,KMAX)
            QOB = QG01(LB) + (QG01(LA)-QG01(LB))*WT
         ENDIF

C  TEMPERATURE
C  -----------

         IF(TOB.LT.BMISS.OR.SUBSET.EQ.'VADWND  '.OR.TYP.EQ.111) THEN

C  (TFC NEEDED BY CQCVAD AND SYNDATA PROGRAMS, LATTER ONLY FOR REPORT
C   TYPE 111)

            IF(POB.GT.PSIG) THEN
               TOB = TG01(1) + (POB-PSIG)*BETAP
            ELSE
               LB = SLTERP(IP)
               WT = SLTERP(IP)-LB
               LA = MIN(LB+1,KMAX)
               TOB = TG01(LB) + (TG01(LA)-TG01(LB))*WT
            ENDIF
            TOB = TOB - TZERO
         ENDIF

C  HEIGHT
C  ------

         IF(ZOB.LT.BMISS) THEN
            IF(POB.GT.PSIG) THEN
               TM = TG01(1) + (.5*(PINT(1)+POB)-PSIG)*BETAP
               ZOB = ZINT(1) - ROG*TM*LOG(POB/PINT(1))
            ELSE
               LI = SITERP(IP)
               MP = (POB+PINT(LI))*PS000*.5
               MP = MAX(MIN(MP,MAXPRS),1)
               LB = SLTERP(MP)
               WT = SLTERP(MP)-LB
               LA = MAX(MIN(LB+1,KMAX),1)
               TM = TG01(LB) + (TG01(LA)-TG01(LB))*WT
               ZOB = ZINT(LI) - ROG*TM*LOG(POB/PINT(LI))
            ENDIF
         ENDIF

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

         IF(UOB.LT.BMISS .OR. VOB.LT.BMISS) THEN
            LB = SLTERP(IP)
            WT = SLTERP(IP)-LB
            LA = MIN(LB+1,KMAX)
            UOB = UG01(LB) + (UG01(LA)-UG01(LB))*WT
            VOB = VG01(LB) + (VG01(LA)-VG01(LB))*WT
         ENDIF

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

         PWO = BMISS

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

         RHO = BMISS

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

         BAK(1,L) = PFC
         BAK(2,L) = QOB
         BAK(3,L) = TOB
         BAK(4,L) = ZOB
         BAK(5,L) = UOB
         BAK(6,L) = VOB
         BAK(7,L) = PWO
         BAK(8,L) = RHO

   10 ENDDO

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

      REAL(8)   OBS,BAK,SID

      COMMON /GBEVAA/ SID,OBS(8,255),BAK(8,255),NLEV,XOB,YOB,DHR,TYP

      DATA BMISS /10E10/

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

      BAK = BMISS

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

      DO L=1,NLEV

         POB = OBS(1,L)
         QOB = OBS(2,L)
         TOB = OBS(3,L)
         WOB = MAX(OBS(5,L),OBS(6,L))
         PWO = OBS(7,L)
         CAT = OBS(8,L)

         IF(CAT.EQ.0    ) BAK(1,L) = OEFG01(POB,TYP,5)
         IF(QOB.LT.BMISS) BAK(2,L) = OEFG01(POB,TYP,3)
         IF(TOB.LT.BMISS) BAK(3,L) = OEFG01(POB,TYP,2)
         IF(WOB.LT.BMISS) BAK(5,L) = OEFG01(POB,TYP,4)
         IF(PWO.LT.BMISS) BAK(6,L) = OEFG01(POB,TYP,6)

      ENDDO

      RETURN
      END
C***********************************************************************
C***********************************************************************
C  SUBROUTINE GBLEVN05 - GUSER (GBLEVN10) USER INTERFACE FOR
C                        PREPFIT (PSG01,ZSG01,TG01,UG01,VG01)
C-----------------------------------------------------------------------
      SUBROUTINE GBLEVN05(GRD,IQ,LEV) ! FORMERLY SUBROUTINE GUSER

      COMMON /GBEVFF/ IMAX,JMAX,KMAX,kmaxs,DLAT,DLON,SL(100),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 GBLEVN12(I,J,GRD(I,J,1))
            ENDDO
         ENDDO
      ELSEIF(IQ.EQ.2) THEN
         DO J=1,JMAX
            DO I=1,IMAX
               CALL GBLEVN13(I,J,GRD(I,J,1))
            ENDDO
         ENDDO
      ELSEIF(IQ.EQ.3) THEN
         DO J=1,JMAX
            DO I=1,IMAX
               CALL GBLEVN14(I,J,LEV,GRD(I,J,1))
            ENDDO
         ENDDO
      ELSEIF(IQ.EQ.4) THEN
         DO J=1,JMAX
            DO I=1,IMAX
               CALL GBLEVN15(I,J,LEV,GRD(I,J,1))
               CALL GBLEVN16(I,J,LEV,GRD(I,J,2))
            ENDDO
         ENDDO
      ELSEIF(IQ.EQ.5) THEN
         DO J=1,JMAX
            DO I=1,IMAX
               CALL GBLEVN17(I,J,LEV,MAX(0.,GRD(I,J,1))*1E6)
            ENDDO
         ENDDO
      ENDIF

      RETURN
      END
C***********************************************************************
C***********************************************************************
C  SUBROUTINE GBLEVN06 - 2D LINEAR HORIZONTAL INTERPOLATION
C-----------------------------------------------------------------------
      SUBROUTINE GBLEVN06(XOB,YOB) ! FORMERLY SUBROUTINE HTERP

      COMMON /GBEVFF/ IMAX,JMAX,KMAX,kmaxs,DLAT,DLON,SL(100),SI(101)
      COMMON /GBEVEE/ PSI,ZSI,TI(100),UI(100),VI(100),QI(100)

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

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

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

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

      ENDDO

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

      COMMON /GBEVDD/ERRS(300,33,6)

      OEFG01 = 10E10
      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 = ERRS(KX,1,IE)
         ELSE
            DEL = (P-ERRS(KX,LB,1))/(ERRS(KX,LA,1)-ERRS(KX,LB,1))
            OEFG01 = (1.-DEL)*ERRS(KX,LB,IE) + DEL*ERRS(KX,LA,IE)
         ENDIF
      ELSEIF(IE.EQ.5) THEN
         OEFG01 = ERRS(KX,1,5)
      ELSEIF(IE.EQ.6) THEN
         OEFG01 = ERRS(KX,1,6)
      ENDIF

C  SET MISSING ERROR VALUE TO 10E10
C  --------------------------------

      IF(OEFG01.GE.5E5) OEFG01 = 10E10

      RETURN
      END
C***********************************************************************
C***********************************************************************
C  SUBROUTINE GBLEVN07
C-----------------------------------------------------------------------
      SUBROUTINE GBLEVN07 ! FORMERLY SUBROUTINE SETTERP

      COMMON /GBEVFF/ IMAX,JMAX,KMAX,kmaxs,DLAT,DLON,SL(100),SI(101)
      COMMON /GBEVGG/ MAXPRS,SITERP(1200),SLTERP(1200)

      MAXPRS  = 1200

C  COMPUTE TABLE FOR THE SIGMA MIDPOINTS RELATIVE TO 1000 MB
C  ---------------------------------------------------------

      DO I=1,MAXPRS
         P = I
         DO LA=1,KMAX
            IF(P.GE.SL(LA)*1000.) GOTO 15
         ENDDO
   15    CONTINUE
         IF(LA.GT.KMAX) THEN
            LA = KMAX
            LB = KMAX
         ELSE IF(LA.EQ.1) THEN
            LA = 1
            LB = 1
         ELSE
            LB = LA-1
         ENDIF
         IF(LA.EQ.LB) THEN
            WP = 0.
         ELSE
            PA = SL(LA)*1000.
            PB = SL(LB)*1000.
            WP = LOG(P/PB)/LOG(PA/PB)
         ENDIF
         SLTERP(I) = LB + WP
      ENDDO

C  COMPUTE TABLE FOR THE SIGMA INTERFACES RELATIVE TO 1000 MB
C  ----------------------------------------------------------

      DO I=1,MAXPRS
         P = I
         DO LA=1,KMAX
            IF(P.GE.SI(LA)*1000.) GOTO 35
         ENDDO
   35    CONTINUE
         SITERP(I) = MAX(LA-1,1)
      ENDDO

      RETURN
      END
C***********************************************************************
C***********************************************************************
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    GBLEVN08    CALCULATE SPEC. HUMIDITY AND VIRTUAL TEMP
C   PRGMMR: D.A. KEYSER      ORG: NP22       DATE: 1999-12-01
C
C ABSTRACT: CREATE VIRTUAL TEMPERATURE EVENTS WITHIN GBLEVENTS
C   SUBROUTINE.  THIS CONSISTS OF FIRST RE-CALCULATING THE SPECIFIC
C   HUMIDITY FROM THE REPORTED DEWPOINT TEMPERATURE AND PRESSURE,
C   FOLLOWED BY THE CALCULATION OF VIRTUAL TEMPERATURE FROM THE
C   JUST-CALCULATED SPECIFIC HUMIDITY AND THE REPORTED (SENSIBLE)
C   TEMPERATURE.  THE RE-CALCULATED SPECIFIC HUMIDITY IS THEN
C   ENCODED AS A STACKED EVENT TO BE LATER WRITTEN INTO THE PREPBUFR
C   FILE (UNDER PROGRAM "VIRTMP", REASON CODE 0).  IF THE NAMELIST
C   SWITCH DOVTMP IS TRUE, THEN THE JUST-CALCULATED VIRTUAL
C   TEMPERATURE IS THEN ALSO ENCODED AS A STACKED EVENT TO BE LATER
C   WRITTEN INTO THE PREPBUFR FILE (UNDER PROGRAM "VIRTMP", REASON
C   CODE 0).  THIS SUBROUTINE IS CURRENTLY ONLY CALLED FOR SURFACE
C   LAND ("ADPSFC") OR MARINE ("SFCSHP") DATA TYPES AND ONLY IN THE
C   PREVENTS MODE.  THIS ROUTINE IS CALLED ONCE FOR EACH VALID REPORT
C   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
C             (SUBJECT TO A SANITY CHECK), HOWEVER THE VIRT.
C             TEMPERATURE GETS A BAD QUAL. MARKER (8)
C
C USAGE:    CALL GBLEVN08(IUNITP)
C   INPUT ARGUMENT LIST:
C     IUNITP   - BUFR OUTPUT FILE UNIT
C
C REMARKS: WILL IMMEDIATELY RETURN TO CALLING PROGRAM IF ANY OF THE
C   FOLLOWING CONDITIONS EXIST: THERE ARE NO LEVELS OF VALID DEWPOINT,
C   OBS, TEMPERATURE Q.M. OR SPEC. HUMIDITY Q.M. IN THE INPUT PREPBUFR
C   FILE FOR THE REPORT.  WILL NOT ATTEMPT EITHER SPEC. HUMIDITY NOR
C   VIRT. TEMP CALC. ON A GIVEN LEVEL IF ANY OF THE FOLLOWING
C   CONDITIONS EXIST: REPORTED PRESSURE OBS IS MISSING, REPORTED
C   (SENSIBLE) TEMPERATURE OBS IS MISSING, OR REPORTED DEWPOINT OBS IS
C   MISSING.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM-SP
C
C$$$
      SUBROUTINE GBLEVN08(IUNITP) ! FORMERLY SUBROUTINE VTPEVN

      CHARACTER*80 EVNSTQ,EVNSTV
      REAL(8)      TDP(255),TQM(255),QQM(255),BAKQ(4,255),BAKV(4,255),
     $             OBS,BAK,SID

      LOGICAL      EVNQ,EVNV,DOVTMP

      COMMON /GBEVAA/ SID,OBS(8,255),BAK(8,255),NLEV,XOB,YOB,DHR,TYP
      COMMON /GBEVBB/ PVCD,VTCD
      COMMON /GBEVCC/ DOVTMP,DOFCST,DOBERR,FCST,VIRT,QTOP_REJ,SATMQC

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

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

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

      EVNQ = .FALSE.
      EVNV = .FALSE.
      BAKQ = BMISS
      BAKV = BMISS

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

      CALL UFBINT(-IUNITP,TDP,1,255,NLTD,'TDO')
      CALL UFBINT(-IUNITP,TQM,1,255,NLTQ,'TQM')
      CALL UFBINT(-IUNITP,QQM,1,255,NLQQ,'QQM')
      IF(NLTD.EQ.0) RETURN
      IF(NLQQ.EQ.0) RETURN
      IF(NLTQ.EQ.0) RETURN
      IF(NLTD.NE.NLEV) THEN
         PRINT *, '##GBLEVENTS/GBLEVN08 - NLTD .NE. NLEV - STOP 61'
         CALL ERREXIT(61)
      END IF
      IF(NLTQ.NE.NLEV) THEN
         PRINT *, '##GBLEVENTS/GBLEVN08 - NLTQ .NE. NLEV - STOP 62'
         CALL ERREXIT(62)
      END IF
      IF(NLQQ.NE.NLEV) THEN
         PRINT *, '##GBLEVENTS/GBLEVN08 - NLQQ .NE. NLEV - STOP 63'
         CALL ERREXIT(63)
      END IF

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

      DO L=1,NLEV
         POB = OBS(1,L)
         TDO = TDP(L)
         TOB = OBS(3,L)
         IF(POB.LT.BMISS .AND. TOB.LT.BMISS
     $                   .AND. TDO.LT.BMISS) THEN
            IF(QQM(L).GT.3) THEN
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  ! Sanity check for bad QQM
            ENDIF
            QOB = QS(TDO+273.16,POB)
            BAKQ(1,L) = QOB*1E6
            BAKQ(2,L) = QQM(L)
            BAKQ(3,L) = VTCD
            BAKQ(4,L) = 0
            EVNQ = .TRUE.
            IF(DOVTMP) THEN
               BAKV(1,L) = (TOB+273.16)*(1.+.61*QOB)-273.16
               BAKV(3,L) = VTCD
               IF(QQM(L).LT.4) THEN
                  BAKV(2,L) = TQM(L)
                  BAKV(4,L) = 0
               ELSE
cdak  print *, '%%% process tvirt on lvl ',l,' for bad QQM case'
                  BAKV(2,L) = 8
                  BAKV(4,L) = 2
               ENDIF
               EVNV = .TRUE.
            ENDIF
         ENDIF
      ENDDO

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

      IF(EVNQ) CALL UFBINT(IUNITP,BAKQ,4,NLEV,IRET,EVNSTQ)
      IF(EVNV) CALL UFBINT(IUNITP,BAKV,4,NLEV,IRET,EVNSTV)

      RETURN
      END
C#######################
C#######################
C#######################
C#######################
C#######################
C#######################
C***********************************************************************
C***********************************************************************
      SUBROUTINE GBLEVN10(IUNITF,IDATEP) ! FORMERLY SUBROUTINE GESRES

      COMMON /GBEVFF/ IMAX,JMAX,KMAX,kmaxs,DLAT,DLON,SL(100),SI(101)
      COMMON /GBEVHH/ 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(207,2)

      IF(MOD(MOD(IDATEP,100),3).EQ.0)  THEN
         KFILES = 1
         KINDX = 0
         PRINT 331, MOD(IDATEP,100)
  331    FORMAT(/' --> GBLEVENTS: THE PREPBUFR CENTER HOUR (',I2.2,
     $    ') IS A MULTIPLE OF 3 - ONLY ONE GLOBAL SIGMA FILE IS READ,'/
     $    16X,'NO INTERPOLATION OF SPECTRAL COEFFICIENTS IS PERFORMED'/)
      ELSE
         KFILES = 2
         KINDX(1) = MOD(MOD(IDATEP,100),3)
         KINDX(2) = KINDX(1) - 3
         PRINT 332, MOD(IDATEP,100)
  332    FORMAT(/' --> GBLEVENTS: THE PREPBUFR CENTER HOUR (',I2.2,
     $    ') IS NOT A MULTIPLE OF 3 - TWO SPANNING GLOBAL SIGMA FILES'/
     $    16X,'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
      DO IFILE=1,KFILES
         JFILE = IFILE
         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(:,IFILE)
         IF(IDATE(1,IFILE).LT.100)  THEN

C IF 2-DIGIT YEAR FOUND IN GLOBAL SIMGA FILE INITIAL DATE
C  (IDATE(1,IFILE)), MUST USE "WINDOWING" TECHNIQUE TO CREATE A 4-DIGIT
C  YEAR (NOTE: THE T170 IMPLEMENTATION IN JUNE 1998 WAS TO INCLUDE THE
C  WRITING OF A 4-DIGIT YEAR HERE.  PRIOR TO THIS, THE YEAR HERE WAS
C  2-DIGIT.)

            PRINT *, '##GBLEVENTS/GBLEVN10 - 2-DIGIT YEAR FOUND IN ',
     $       'GLOBAL SIGMA FILE ',IFILE,'; INITIAL DATE (YEAR IS: ',
     $       idate(1,IFILE),') - USE WINDOWING TECHNIQUE TO OBTAIN ',
     $       '4-DIGIT YEAR'
            IF(IDATE(1,IFILE).GT.20)  THEN
               IDATE(1,IFILE) = 1900 + IDATE(1,IFILE)
            ELSE
               IDATE(1,IFILE) = 2000 + IDATE(1,IFILE)
            ENDIF
            PRINT *,'##GBLEVENTS/GBLEVN10 - CORRECTED 4-DIGIT YEAR IS ',
     $       'NOW: ',IDATE(1,IFILE)
         ENDIF
         CALL W3MOVDAT((/0.,ANINT(FHR(IFILE)),0.,0.,0./),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: 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) CALL W3MOVDAT((/0.,REAL(KINDX(IFILE)),0.,0.,
     $    0./),JDATE(:,IFILE),KDATE(:,IFILE))
         IDATGS_COR = (KDATE(1,IFILE) * 1000000) + (KDATE(2,IFILE) *
     $    10000) + (KDATE(3,IFILE) * 100) + KDATE(5,IFILE)

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

         IF(IDATEP.NE.IDATGS_COR)  GO TO 901

      ENDDO

      IF(KFILES.EQ.2)  THEN

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

         JNDEX = 0
         DO  INDEX=1,207
            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)
      kmaxs = 2*kmax+2

      IF(KMAX.GT.100) GO TO 902

      DO  L = 1,KMAX
         SI(L) = HEADR2(L,1)
         SL(L) = HEADR2(KMAX+1+L,1)
      ENDDO

      SI(KMAX+1) = HEADR2(KMAX+1,1)

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
    2 FORMAT(/' --> GBLEVENTS: GLOBAL MODEL SPECS: T',I3,' ',I3,
     $ ' LEVELS ',I3,' SCALARS -------> ',F4.2,' X ',F4.2)

      CALL GBLEVN09(IUNITF,KINDX)

      RETURN

  900 CONTINUE
      PRINT *, '##GBLEVENTS/GBLEVN10 - BAD OR MISSING GLOBAL SIGMA ',
     $ 'FILE ',JFILE,' - STOP 67'
      CALL ERREXIT(67)
  901 CONTINUE
      PRINT 9901, JFILE,(JDATE(II,JFILE),II=1,3),JDATE(5,JFILE),IDATEP
 9901 FORMAT(/' ##GBLEVENTS/GBLEVN10 - 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/GBLEVN10 - KMAX TOO BIG = ',KMAX,' - UNABLE',
     $ ' TO TRANSFORM GLOBAL SIGMA FILE(S) - STOP 69'
      CALL ERREXIT(69)
  903 CONTINUE
      PRINT *, '##GBLEVENTS/GBLEVN10 - IMAX TOO SMALL = ',IMAX,' - ',
     $ 'UNABLE TO TRANSFORM GLOBAL SIGMA FILE(S) - STOP 70'
      CALL ERREXIT(70)
  904 CONTINUE
      PRINT *, '##GBLEVENTS/GBLEVN10 - HEADER INDEX ',JNDEX,' FOR ',
     $ 'SIGMA FILE 1 (=',HEADR2(JNDEX,1),') DOES NOT MATCH THAT FOR ',
     $ ' SIGMA FILE 2 (=',HEADR2(JNDEX,2),' - STOP 71'
      CALL ERREXIT(71)
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE GBLEVN09(IUNITF,KINDX)
                                         ! FORMERLY SUBROUTINE COF2GRD

      parameter (PI180=.0174532)

      COMMON /GBEVFF/ IMAX,JMAX,KMAX,kmaxs,DLAT,DLON,SL(100),SI(101)
      COMMON /GBEVHH/ 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 gblevn11(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 GBLEVN05(GRDS(1,1,NS),I,L)
                 ns=ns+1
             enddo
         else
             NRD = 2
             DO L=1,LEV
                DO K=1,NRD
                    call gblevn11(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 GBLEVN05(GRD2,I,L)
             enddo
         endif
      enddo

      deallocate (cofs, cofv)
      deallocate (cofs_f, cofv_f)
      deallocate (grds, grdv)
      deallocate (grd2)

      RETURN

  900 CONTINUE
      PRINT *,'##GBLEVENTS/GBLEVN09 - EOF READING GLOBAL SIGMA FILE - ',
     $ 'UNABLE TO TRANSFORM GLOBAL SIGMA FILE - STOP 64'
      CALL ERREXIT(64)
  901 CONTINUE
      PRINT *,'##GBLEVENTS/GBLEVN09 - ERROR READING GLOBAL SIGMA FILE ',
     $ '- UNABLE TO TRANSFORM GLOBAL SIGMA FILE - STOP 65'
      CALL ERREXIT(65)
  902 CONTINUE
      PRINT *,'##GBLEVENTS/GBLEVN09 - IDIM NOT FACTORABLE - UNABLE TO ',
     $ 'TRANSFORM GLOBAL SIGMA FILE - STOP 66'
      CALL ERREXIT(66)
      END
C***********************************************************************
C***********************************************************************
      subroutine gblevn11(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       | ZSG01  | WORD | REAL       | 384,193         |   C
C |-------------+--------+------+------------+-----------------|   C
C | PSG01       | PSG01  | WORD | REAL       | 384,193         |   C
C |-------------+--------+------+------------+-----------------|   C
C | TG01        | TG01   | WORD | REAL       | 384,193,64      |   C
C |-------------+--------+------+------------+-----------------|   C
C | UG01        | UG01   | WORD | REAL       | 384,193,64      |   C
C |-------------+--------+------+------------+-----------------|   C
C | VG01        | VG01   | WORD | REAL       | 384,193,64      |   C
C |-------------+--------+------+------------+-----------------|   C
C | QG01        | QG01   | WORD | REAL       | 384,193,64      |   C
C ==============^========^======^============^==================   C
C                                                                  C
C***********************************************************************
C***********************************************************************
      FUNCTION ZSG01(I,J) ! FORMERLY FUNCTION ZS
      PARAMETER (IM = 384)
      PARAMETER (JM = 193)
      COMMON /GBEVJJ/IAR(IM,JM)
      REAL(8) IAR
      REAL ZSG01
      ZSG01 = IAR(I,J)
      RETURN
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE GBLEVN12(I,J,V) ! FORMERLY SUBROUTINE ZSP
      PARAMETER (IM = 384)
      PARAMETER (JM = 193)
      COMMON /GBEVJJ/IAR(IM,JM)
      REAL(8) IAR
      REAL V
      IAR(I,J) = V
      RETURN
      END
C***********************************************************************
C***********************************************************************
      FUNCTION PSG01(I,J) ! FORMERLY FUNCTION PS
      PARAMETER (IM = 384)
      PARAMETER (JM = 193)
      COMMON /GBEVKK/IAR(IM,JM)
      REAL(8) IAR
      REAL PSG01
      PSG01 = IAR(I,J)
      RETURN
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE GBLEVN13(I,J,V) ! FORMERLY SUBROUTINE PSP
      PARAMETER (IM = 384)
      PARAMETER (JM = 193)
      COMMON /GBEVKK/IAR(IM,JM)
      REAL(8) IAR
      REAL V
      IAR(I,J) = V
      RETURN
      END
C***********************************************************************
C***********************************************************************
      FUNCTION TG01(I,J,K) ! FORMERLY FUNCTION T
      PARAMETER (IM = 384)
      PARAMETER (JM = 193)
      PARAMETER (KM = 64)
      COMMON /GBEVLL/IAR(IM,JM,KM)
      REAL(8) IAR
      REAL TG01
      TG01 = IAR(I,J,K)
      RETURN
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE GBLEVN14(I,J,K,V) ! FORMERLY SUBROUTINE TP
      PARAMETER (IM = 384)
      PARAMETER (JM = 193)
      PARAMETER (KM = 64)
      COMMON /GBEVLL/IAR(IM,JM,KM)
      REAL(8) IAR
      REAL V
      IAR(I,J,K) = V
      RETURN
      END
C***********************************************************************
C***********************************************************************
      FUNCTION UG01(I,J,K) ! FORMERLY FUNCTION U
      PARAMETER (IM = 384)
      PARAMETER (JM = 193)
      PARAMETER (KM = 64)
      COMMON /GBEVMM/IAR(IM,JM,KM)
      REAL(8) IAR
      REAL UG01
      UG01 = IAR(I,J,K)
      RETURN
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE GBLEVN15(I,J,K,V) ! FORMERLY SUBROUTINE UP
      PARAMETER (IM = 384)
      PARAMETER (JM = 193)
      PARAMETER (KM = 64)
      COMMON /GBEVMM/IAR(IM,JM,KM)
      REAL(8) IAR
      REAL V
      IAR(I,J,K) = V
      RETURN
      END
C***********************************************************************
C***********************************************************************
      FUNCTION VG01(I,J,K) ! FORMERLY FUNCTION V
      PARAMETER (IM = 384)
      PARAMETER (JM = 193)
      PARAMETER (KM = 64)
      COMMON /GBEVNN/IAR(IM,JM,KM)
      REAL(8) IAR
      REAL VG01
      VG01 = IAR(I,J,K)
      RETURN
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE GBLEVN16(I,J,K,V) ! FORMERLY SUBROUTINE VP
      PARAMETER (IM = 384)
      PARAMETER (JM = 193)
      PARAMETER (KM = 64)
      COMMON /GBEVNN/IAR(IM,JM,KM)
      REAL(8) IAR
      REAL V
      IAR(I,J,K) = V
      RETURN
      END
C***********************************************************************
C***********************************************************************
      FUNCTION QG01(I,J,K) ! FORMERLY FUNCTION Q
      PARAMETER (IM = 384)
      PARAMETER (JM = 193)
      PARAMETER (KM = 64)
      COMMON /GBEVOO/IAR(IM,JM,KM)
      REAL(8) IAR
      REAL QG01
      QG01 = IAR(I,J,K)
      RETURN
      END
C***********************************************************************
C***********************************************************************
      SUBROUTINE GBLEVN17(I,J,K,V) ! FORMERLY SUBROUTINE QP
      PARAMETER (IM = 384)
      PARAMETER (JM = 193)
      PARAMETER (KM = 64)
      COMMON /GBEVOO/IAR(IM,JM,KM)
      REAL(8) IAR
      REAL V
      IAR(I,J,K) = V
      RETURN
      END


      SUBROUTINE TIMOUT(NOUT,TIM)
C
C     CONVERT THE TIME FROM SECONDS TO DAYS, HOURS, MINUTES, AND SECONDS
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DOUBLE PRECISION MINS, MINPHR
C
C
      DATA HRSPD /24.0D0/, MINPHR /60.0D0/
      DATA SECPD /86400.0D0/, SECPHR /3600.0D0/, SECPMI /60.0D0/
C
      DAYS = TIM / SECPD
      IDAYS = INT(DAYS)
      HOURS = (DAYS - FLOAT(IDAYS)) * HRSPD
      IHOURS = INT(HOURS)
      MINS = (HOURS - FLOAT(IHOURS)) * MINPHR
      IMINS = INT(MINS)
      SECS = (MINS - FLOAT(IMINS)) * SECPMI
C
      IF (IDAYS .GT. 1) THEN
         WRITE (NOUT,10) IDAYS,IHOURS,IMINS,SECS
      ELSE IF (IDAYS .EQ. 1) THEN
         WRITE (NOUT,20) IDAYS,IHOURS,IMINS,SECS
      ELSE IF (IHOURS .GT. 0) THEN
         WRITE (NOUT,30) IHOURS,IMINS,SECS
      ELSE IF (IMINS .GT. 0) THEN
         WRITE (NOUT,40) IMINS,SECS
      ELSE
         WRITE (NOUT,50) SECS
      END IF
C
   10 FORMAT (10X,'COMPUTATION TIME = ',I2,1X,'DAYS',2X,I2,1X,'HOURS',
     1        1X,I2,1X,'MINUTES AND',1X,F7.3,1X,'SECONDS')
   20 FORMAT (10X,'COMPUTATION TIME = ',I2,1X,'DAY',2X,I2,1X,'HOURS',
     1        1X,I2,1X,'MINUTES AND',1X,F7.3,1X,'SECONDS')
   30 FORMAT (10X,'COMPUTATION TIME = 'I2,1X,'HOURS',
     1        1X,I2,1X,'MINUTES AND',1X,F7.3,1X,'SECONDS')
   40 FORMAT (10X,'COMPUTATION TIME = ',I2,1X,'MINUTES AND',
     1        1X,F7.3,1X,'SECONDS')
   50 FORMAT (10X,'COMPUTATION TIME = ',F7.3,1X,'SECONDS')
      END


      SUBROUTINE SOLROT (NI,NJ,XI,XJ,WJ,WK,KR,E1B,E2A,ENUC,CUTOFF)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION XI(3), XJ(3), WJ(100), WK(100), E1B(10), E2A(10)
************************************************************************
*
*   SOLROT FORMS THE TWO-ELECTRON TWO-ATOM J AND K INTEGRAL STRINGS.
*          ON EXIT WJ = "J"-TYPE INTEGRALS
*                  WK = "K"-TYPE INTEGRALS
*
*      FOR MOLECULES, WJ = WK.
************************************************************************
      COMMON /EULER / TVEC(3,3), ID
      COMMON /UCELL / L1L,L2L,L3L,L1U,L2U,L3U
      DIMENSION WSUM(100), WBITS(100), LIMS(3,2), XJUC(3), E1BITS(10),
     1E2BITS(10), WMAX(100)
      LOGICAL FIRST
      EQUIVALENCE (L1L,LIMS(1,1))
      DATA FIRST/.TRUE./
      IF(FIRST)THEN
         FIRST=.FALSE.
         DO 10 I=1,ID
            LIMS(I,1)=-1
   10    LIMS(I,2)= 1
         DO 20 I=ID+1,3
            LIMS(I,1)=0
   20    LIMS(I,2)=0
      ENDIF
      ONE=1.D0
      IF(XI(1).EQ.XJ(1) .AND. XI(2).EQ.XJ(2) .AND. XI(3).EQ. XJ(3))
     1ONE=0.5D0
      DO 30 I=1,100
         WMAX(I)=0.D0
         WSUM(I)=0.D0
   30 WBITS(I)=0.D0
      NEQUAL=1
      DO 40 I=1,10
         E1B(I)=0.D0
   40 E2A(I)=0.D0
      ENUC=0.D0
      DO 90 I=L1L,L1U
         DO 90 J=L2L,L2U
            DO 90 K=L3L,L3U
               DO 50 L=1,3
   50          XJUC(L)=XJ(L)+TVEC(L,1)*I+TVEC(L,2)*J+TVEC(L,3)*K
               KB=1
               CALL ROTATE (NI,NJ,XI,XJUC,WBITS,KB,E1BITS,E2BITS,
     1ENUBIT,CUTOFF)
               KB=KB-1
               DO 60 II=1,KB
   60          WSUM(II)=WSUM(II)+WBITS(II)
               IF(WMAX(1).LT.WBITS(1))THEN
                  DO 70 II=1,KB
   70             WMAX(II)=WBITS(II)
               ENDIF
               DO 80 II=1,10
                  E1B(II)=E1B(II)+E1BITS(II)
   80          E2A(II)=E2A(II)+E2BITS(II)
               ENUC=ENUC+ENUBIT*ONE
   90 CONTINUE
      IF(ONE.LT.0.9D0) THEN
         DO 100 I=1,KB
  100    WMAX(I)=0.D0
      ENDIF
      DO 110 I=1,KB
         WK(I)=WMAX(I)
  110 WJ(I)=WSUM(I)
      KR=KB+KR
      RETURN
      END


      SUBROUTINE setvars     !  set variables we have found are undefined
C--------------------------------
      common /cantenna/ numants,iats(20),anttype(20),antname(20),
     +                  xfqs(20),xfqe(20),designfreq(20),antfile(20),
     +                  beammain(20),offazim(20),cond(20),diel(20),
     +                  array(30,91,22),aeff(30,20)
      character anttype*10,antname*70,antfile*24
      COMMON/GEOG/GYZ(5),RAT(5),GMDIP(5),CLCK(5),ABIY(5),ARTIC(5),SIGPAT
     A(5), EPSPAT(5)
      COMMON /RON /CLAT(5), CLONG(5), GLAT(5), RD(5), FI(3,5), YI(3,5),
     1HI(3,5), HPRIM(30,5), HTRUE(30,5), FVERT(30,5),KM,KFX, AFAC(30,5),
     2HTR(50,3), FNSQ(50,3)
      COMMON /RAYS/ ANG(40), IFOB(40,30,5), NANG
      COMMON/INFORM/INFO,IHSHR,IHLNG
      COMMON / ZON / ABPS(7), CREL(7), EFF(7), FLDST(7), GRLOS(7),
     1 HN(7), HP(7), PROB(7), RELY(7), RGAIN(7), SIGPOW(7), SN(7),
     2 SPRO(7), TGAIN(7), TIMED(7), TLOSS(7), B(7), FSLOS(7), ADV(7),
     3 OBF(7),NMODE(7),TLLOW(7),TLHGH(7)
c------------------------------------------------------------------------
      zero=0.
      numants=0
      do 10 i=1,5
10    ARTIC(i)=zero
      do 20 j=1,5
      do 20 i=1,30
      HTRUE(i,j)=zero
      FVERT(i,j)=zero
      AFAC(i,j)=zero
20    HPRIM(i,j)=zero
      do 30 k=1,5
      do 30 j=1,30
      do 30 i=1,40
30    IFOB(i,j,k)=zero
      IHSHR=0
      IHLNG=0
      do 40 i=1,7
      HP(i)=zero
      rely(i)=zero
      hn(i)=zero
      nmode(i)=0
      sn(i)=zero
      fldst(i)=zero
      sigpow(i)=zero
      b(i)=zero
      timed(i)=zero
      abps(i)=zero
      prob(i)=zero
      rgain(i)=zero
      tgain(i)=zero
      fslos(i)=zero
      spro(i)=zero
      EFF(i)=zero
      grlos(i)=zero
      adv(i)=zero
      obf(i)=zero
40    CREL(i)=zero
      return
      end
C--------------------------------