C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: GBLEVENTS PRE/POST PROCESSING OF PREPBUFR EVENTS
C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2006-07-14
C
C ABSTRACT: RUNS IN TWO MODES: "PREVENTS" AND "POSTEVENTS". IN THE
C PREVENTS MODE, PREPARES OBSERVATIONAL PREPBUFR REPORTS FOR
C SUBSEQUENT QUALITY CONTROL AND ANALYSIS PROGRAMS. THIS IS DONE
C THROUGH THE FOLLOWING: INTERPOLATION OF GLOBAL SPECTRAL SIMGA
C FIRST GUESS TO PREPBUFR OBSERVATION LOCATIONS WITH ENCODING OF
C FIRST GUESS VALUES INTO PREPBUFR REPORTS; ENCODING OF "PREVENT"
C AND/OR "VIRTMP" EVENTS INTO PREPBUFR REPORTS; AND ENCODING OF
C OBSERVATION ERRORS FROM THE ERROR SPECIFICATION FILE INTO
C PREPBUFR REPORTS. IN THE POSTEVENTS MODE, AFTER ALL QUALITY
C CONTROL AND ANALYSIS PROGRAMS HAVE RUN, INTERPOLATES THE GLOBAL
C SPECTRAL SIMGA ANALYSIS TO PREPBUFR OBSERVATION LOCATIONS AND
C ENCODES THESE ANALYZED VALUES INTO PREPBUFR REPORTS. THE
C REMAINDER OF THIS ABSTRACT APPLIES ONLY TO THE PREVENTS MODE.
C THE "PREVENT" EVENT CAN CHANGE A QUALITY MARKER TO FLAG AN
C OBSERVATION DATUM FOR NON-USE BY SUBSEQUENT QC AND ANALYSIS
C PROGRAMS (FILTERING). EXAMPLES WHERE THIS SUBROUTINE WILL WRITE
C AN EVENT TO FLAG A DATUM INCLUDE: THE OBSERVATION ERROR FOR THAT
C DATUM IS READ IN AS MISSING IN THE INPUT ERROR FILE, THE DATUM
C ITSELF VIOLATES A GROSS OR "SANITY" CHECK, OR THE OBSERVED
C PRESSURE DATUM IS MORE THAN 100 MB BELOW THE GUESS SURFACE
C PRESSURE. THE "VIRTMP" EVENT CAN CHANGE THE SPECIFIC HUMIDITY
C OBSERVATION (RE-CALCULATED) AS WELL AS THE TEMPERATURE
C OBSERVATION (FROM SENSIBLE TO VIRTUAL TEMPERATURE, BASED ON
C JUST-CALCULATED SPECIFIC HUMIDITY). CURRENTLY THIS APPLIES ONLY
C TO SURFACE (LAND, MARINE AND MESONET) DATA TYPES, POSSIBLY TO
C RAOB, DROP AND MULTI-LEVEL RECCO DAA TYPES IF THE SWITCH
C "ADPUPA_VIRT" IS TRUE (NORMALLY, HOWEVER IT IS FALSE) [OTHER DATA
C TYPES WITH REPORTED SENSIBLE TEMPERATURE EITHER HAVE MISSING
C MOISTURE (E.G., ALL AIRCRAFT TYPES EXCEPT FOR SOME ACARS, SATELLITE
C WIND TYPES), FLAGGED MOISTURE (E.G., SOME ACARS) OR CALCULATE
C SPECIFIC HUMIDITY/VIRTUAL TEMPERATURE IN SUBSEQUENT PROGRAMS (E.G.,
C RAOBS, DROPS AND MULTI-LEVEL RECCOS WHICH CALCULATE THESE IN
C PROGRAM "CQCBUFR", IN WHICH CASE THE SWITCH "ADPUPA_VIRT" HERE MUST
C BE FALSE!)]. FOR CASES WHERE THE SWITCH "DOBERR" IS FALSE, THE
C OBSERVATION ERROR FOR ALL DATA REMAINS MISSING IN THE PREPBUFR
C FILE. IN THIS CASE, THE INPUT ERROR FILE IS USUALLY A NULL FILE
C AND THE "PREVENT" EVENT TO FLAG THE DATUM IS NOT INVOKED. FOR
C CASES WHERE THE SWITCH "DOFCST" IS FALSE, IF THE SWITCH "SOME_FCST"
C IS ALSO FALSE, THEN FORECAST VALUES ARE NOT ENCODED FOR ANY MESSAGE
C TYPE; IF "SOME_FCST" IS TRUE THEN FORECAST VALUES ARE ENCODED, BUT
C ONLY FOR REPORTS IN THOSE MESSAGE TYPES FOR WHICH A GUESS VALUE IS
C NEEDED BY SUBSEQUENT QC PROGRAMS. IT SHOULD BE NOTED THAT THE
C FILTERING OF DATA ASSOCIATED WITH THE "PREVENT" EVENT PROCESSING IS
C NOT INVOKED IF ALL THREE ARE TRUE: DOBERR= FALSE, THE FORECAST
C VALUES ARE MISSING (DOFCST=FALSE & SOME_FCST=TRUE & MESSAGE TYPE IS
C NOT "ADPUPA", "AIRCFT", "AIRCAR", "PROFLR", OR "VADWND" -- OR --
C DOFCST=FALSE & SOME_FCST=FALSE), AND "VIRTMP" EVENT PROCESSING IS
C NOT INVOKED (EITHER MESSAGE TYPE IS NOT "ADPSFC", "SFCSHP" OR
C "MSONET" WHEN "ADPUPA_VIRT" IS FALSE, OR MESSAGE TYPE IS NOT
C "ADPSFC", "SFCSHP", "MSONET" OR "ADPUPA" WHEN "ADPUPA_VIRT" IS
C TRUE).
C
C PROGRAM HISTORY LOG:
C 1999-07-01 D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM PREVENTS
C SUBROUTINE IN PREPDATA PROGRAM, BUT NOW GENERALIZED FOR
C POSTEVENTS MODE)
C 1999-07-12 D. A. KEYSER -- MODIFIED TO INTERPOLATE MODEL SPECIFIC
C HUMIDITY TO OBSERVATION LOCATION WHEN OBS. SPECIFIC HUMIDITY IS
C MISSING AS LONG AS OBS. TEMPERATURE IS NON-MISSING
C 1999-09-09 D. A. KEYSER -- ADDED "VADWND" TO THE LIST OF MESSAGE
C TYPES FOR WHICH FORECAST VALUES MUST BE ENCODED, EVEN WHEN
C DOFCST=FALSE (NECESSARY BECAUSE THE NEW PROGRAM CQCVAD NEEDS THE
C BACKGROUND DATA)
C 1999-09-09 D. A. KEYSER -- CHANGES TO MAKE CODE MORE PORTABLE;
C 'TFC' NOW GENERATED FOR VADWND MESSAGE TYPES EVEN THOUGH TOB IS
C MISSING (NEEDED BY CQCVAD PROGRAM)
C 1999-12-01 D. A. KEYSER -- SPEC. HUMIDITY AND VIRT. TEMPERATURE ARE
C NOW CALCULATED WHEN SPEC. HUMIDITY QUAL. MARKER IS BAD (SUBJECT
C TO A SANITY CHECK), HOWEVER THE VIRT. TEMPERATURE GETS A BAD
C QUAL. MARKER (8)
C 2000-09-21 D. A. KEYSER -- THE PRESSURE LEVEL ABOVE WHICH ALL SPEC.
C HUMIDITY QUAL. MARKERS ARE "REJECTED" (Q.M. SET TO 9) IS NOW READ
C IN AS A N-LIST SWITCH (QTOP_REJ), BEFORE IT WAS HARDWIRED TO 300
C MB
C 2000-12-13 D. A. KEYSER -- WILL NO LONGER PERFORM VIRTUAL TEMPERATURE
C PROCESSING FOR ACARS DATA SINCE MOISTURE IS FLAGGED RIGHT NOW
C (ACARS MOISTURE ONLY WRITTEN INTO PREPBUFR FILE FOR STATISTICAL
C REASONS)
C 2001-02-02 D. A. KEYSER -- RESTORED LEGACY LOGIC TO FLAG CERTAIN
C SATELLITE TEMPERATURE SOUNDINGS EITHER BELOW 100 MB (TEMP. OBS)
C OR ON ALL LEVELS (SPEC. HUM. OBS), CONTROLLED BY NEW NAMELIST
C SWITCH "SATMQC"
C 2001-09-27 D. A. KEYSER -- 'TFC' AND 'QFC' NOW GENERATED FOR REPORT
C TYPE 111 (SYNDAT REPORTS AT STORM CENTER) EVEN THOUGH "TOB" AND
C "QOB" ARE MISSING (NEEDED BY SYNDATA PROGRAM); IN PREPARATION FOR
C CHANGE FROM T170L42 TO T254L64 SGES, NOW MAKES COEFFICIENT ARRAYS
C ALLOCATABLE TO ALLOW THEM TO OBTAIN MEMORY FROM "HEAP" RATHER
C THAN FROM "STACK", ALSO HAVE INCREASED THE MAX NUMBER OF LEVELS
C IN ARRAYS FROM 42 TO 64, FINALLY ALSO NO LONGER STOPS WITH C.
C CODE 70 IF EVEN NUMBER OF LONGITUDES IN SIGMA GUESS (IMAX,
C HARDWIRED TO 384) IS .LT. SPECTRAL RESOLUTION (JCAP) * 2
C 2001-10-10 D. A. KEYSER -- AT PREPBUFR CENTER DATES WITH AN HOUR THAT
C IS NOT A MULTIPLE OF 3 (WHEN A GLOBAL SIGMA GUESS/ANAL FILE IS
C NOT AVAILABLE; E.G., IN RUC2A RUNS) NOW PERFORMS A LINEAR
C INTERPOLATION BETWEEN SPECTRAL COEFFICIENTS IN 2 SPANNING SIGMA
C GUESS/ANAL FILES 3-HRS APART TO CENERATE A GUESS/ANAL FILE VALID
C AT THE PREPBUFR CENTER TIME
C 2002-05-10 D. A. KEYSER -- ADDED "AIRCAR" TO THE LIST OF TABLE A
C MESSAGE TYPES THAT WILL STILL HAVE THE BACKGROUND ENCODED WHEN
C DOFCST IS FALSE (BECAUSE ACARS ARE NOW Q.C.'d IN PREPOBS_ACARSQC
C PROGRAM)
C 2003-09-02 D. A. KEYSER -- ADDED "MSONET" TO THE LIST OF TABLE A
C MESSAGE TYPES THAT WILL HAVE THE VIRTUAL TEMPERATURE CALCULATED;
C DOES NOT CALL UFBINT FOR OUTPUTTING DATA IF "NLEV" (4'TH
C ARGUMENT) IS ZERO (NOW CAN ONLY HAPPEN FOR GOESND FORECAST DATA
C WHEN ONLY RADIANCES ARE PRESENT)
C 2004-08-30 D. A. KEYSER -- NOW INCLUDES THE 4 LAYER PWATERS, THESE
C GET AN OBS. ERROR (EACH THE SAME AS TOTAL PWATER) AND AN EVENT
C IS GENERATED WITH A REJECTED Q.M. FOR THE 4 LAYER PWATERS IF THE
C PWATER OBS. ERROR READ IN IS MISSING (THIS CHANGE ALLOWS THE ETA/
C GSI TO PROCESS OBS. ERRORS IN THE PREPBUFR FILE THE SAME AS THE
C ETA/3DVAR DID WHEN READING THE OBS. ERRORS FROM AN EXTERNAL
C FILE); FOR "RASSDA" TYPES, ENCODES A SIMPLE COPY OF THE REPORTED
C (VIRTUAL) TEMPERATURE AS A "VIRTMP" EVENT IF DOVTMP IS TRUE, GETS
C NEW REASON CODE 3
C 2004-09-10 D. T. KLEIST -- ADDED CAPABILITY TO READ GUESS FIELDS FROM
C EITHER HYBRID OR, AS BEFORE, SIGMA GLOBAL FORECAST FILES
C 2005-01-03 D. A. KEYSER -- FIXED ERROR READING CDAS SGES FILE WHICH
C STILL HAS A 207-WORD HEADER (T62) {2004-09-10 CHANGE ASSUMED ALL
C SGES FILES HAD A 226-WORD HEADER (T254), BUT THIS IS VALID ONLY
C FOR GFS SGES)
C 2006-05-05 R. E. TREADON -- CHANGE VERTICAL INTERPOLATION TO DIRECTLY
C USE PRESSURE PROFILE, NOT PRESSURE PROFILE CONVERTED TO SIGMA.
C THIS CHANGE IS IN SUBROUTINE GBLEVN03. AS A RESULT OF THIS
C CHANGE, SUBROUTINE GBLEVN07 WAS REMOVED.
C 2006-07-14 D. A. KEYSER -- ADDED NEW NAMELIST SWITCH "SOME_FCST"
C WHICH APPLIES ONLY WHEN EXISTING SWITCH "DOFCST" IS FALSE: IF
C DOFCST=F AND SOME_FCST=T THEN, JUST AS BEFORE WHEN DOFCST=F, A
C FORECAST WILL STILL BE ENCODED FOR REPORTS IN CERTAIN MESSAGE
C TYPES USED IN SUBSEQUENT Q.C. PROGRAMS (I.E, "ADPUPA", "AIRCFT",
C "AIRCAR", "PROFLR" OR "VADWND") (THE DEFAULT FOR SOME_FCST IS
C TRUE); HOWEVER IF DOFCST=F AND SOME_FCST=F THEN A FORECAST WILL
C NOT BE ENCODED INTO REPORTS IN ANY MESSAGE TYPE (THIS ALLOWS
C THIS PROGRAM TO ENCODE OBS ERRORS AND/OR VIRTUAL TEMPERATURE
C EVENTS INTO A PREPBUFR FILE WITHOUT ENCODING A FORECAST); ADDED
C NEW NAMELIST SWITCH "ADPUPA_VIRT" WHICH, WHEN TRUE, INCLUDES
C REPORTS IN MESSAGE TYPE ADPUPA (I.E., RAOBS, DROPS, MULTI-LEVEL
C RECCOS) IN THE "VIRTMP" PROCESSING (PROCESSING THEM WITH SAME
C LOGIC AS IN SUBROUTINE VTPEVN OF PROGRAM PREPOBS_CQCBUFR)
C {NORMALLY "ADPUPA_VIRT" IS FALSE (DEFAULT) BECAUSE SUBSEQUENT
C PROGRAM PREPOBS_CQCBUFR PERFORMS THIS FUNCTION}
C
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
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 & 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 RUC VERSION SINCE IT DOES NOT REQUIRE OBSERVATIONAL
C ERRORS TO BE PRESENT IN THE PREPBUFR FILE. THE GSI WILL
C REQUIRE THE OBS ERROR IN THE PREPBUFR FILE FOR THE ETA,
C UNLIKE THE 3DVAR WHICH DID NOT.)
C (NOTE2: IF DOANLS=TRUE, THEN DOBERR IS FORCED TO BE FALSE.)
C
C QTOP_REJ - THE PRESSURE LEVEL (IN MB) ABOVE WHICH ALL SPECIFIC
C HUMIDITY QUALITY MARKERS ARE "REJECTED" (THE QUALITY
C MARKER IS SET TO 9 ON ALL PRESSURE LEVELS LESS THAN
C THIS LEVEL) (DEFAULT=300.)
C
C SATMQC - PERFORM SPECIAL QUALITY CONTROL ON SATELLITE TEMPERATURE
C SOUNDINGS IN REPORT TYPES 160-179?
C SATMQC = .TRUE. ---> YES
C SATMQC = .FALSE. ---> NO (DEFAULT)
C (NOTE: THIS APPLIES ONLY TO THE CDAS OR HISTORICAL RE-RUNS
C WITH TEMPERATURE SOUNDINGS IN THESE REPORT TYPES)
C
CC
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 90
C MACHINE: IBM-SP
C
C$$$
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,SOME_FCST,DOBERR,FCST,VIRT,DOANLS,
$ SATMQC,ADPUPA_VIRT
DIMENSION IUNITF(2)
COMMON /GBEVAA/ SID,OBS(12,255),BAK(12,255),NLEV,XOB,YOB,DHR,TYP
COMMON /GBEVBB/ PVCD,VTCD
COMMON /GBEVCC/ DOVTMP,DOFCST,SOME_FCST,DOBERR,FCST,VIRT,
$ QTOP_REJ,SATMQC,ADPUPA_VIRT
COMMON /GBEVDD/ ERRS(300,33,6)
SAVE
DATA IFIRST/0/
DATA HEADR /
$ 'SID XOB YOB DHR TYP '/
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 INVOKED FOR ',
$ 'THE FIRST TIME - VERSION LAST UPDATED 2006-07-14'/)
C INITIALIZE NAMELIST SWITCHES TO DEFAULT VALUES
C ----------------------------------------------
DOVTMP = .TRUE.
DOFCST = .TRUE.
SOME_FCST = .TRUE.
DOBERR = .TRUE.
DOANLS = .FALSE.
QTOP_REJ = 300.
SATMQC = .FALSE.
ADPUPA_VIRT = .FALSE.
READ(5,PREVDATA,ERR=101,END=102)
GO TO 103
C-----------------------------------------------------------------------
101 CONTINUE
C ERROR READING STANDARD INPUT - THIS DEFAULTS TO POSTEVENTS MODE
C ---------------------------------------------------------------
PRINT 7013
7013 FORMAT(/' ##> GBLEVENTS: ERROR READING STANDARD INPUT DATA CARDS',
$ ' -- DEFAULTS TO "POSTEVENTS" MODE'/)
DOANLS = .TRUE.
GO TO 103
C-----------------------------------------------------------------------
102 CONTINUE
C STANDARD INPUT IS EMPTY - THIS DEFAULTS TO POSTEVENTS MODE
C ----------------------------------------------------------
PRINT 7014
7014 FORMAT(/' ##> GBLEVENTS: STANDARD INPUT DATA CARDS DO NOT ',
$ 'EXIST -- DEFAULTS TO "POSTEVENTS" MODE'/)
DOANLS = .TRUE.
C-----------------------------------------------------------------------
103 CONTINUE
IF(DOANLS) THEN
DOVTMP = .FALSE.
DOFCST = .FALSE.
SOME_FCST = .FALSE.
DOBERR = .FALSE.
ADPUPA_VIRT = .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 UNLESS ALL OF DOFCST, SOME_FCST, DOANLS ARE FALSE
C ------------------------------------------------------------------
IF(.NOT.DOANLS) THEN
IF(.NOT.DOFCST.AND..NOT.SOME_FCST) THEN
PRINT 901
901 FORMAT(/' --> GBLEVENTS: PREVENTS MODE - FIRST GUESS NOT READ ',
$ 'IN'/)
ELSE
PRINT 701
701 FORMAT(/' --> GBLEVENTS: PREVENTS MODE - DATE CHECK AND ',
$ 'TRANSFORM THE FIRST GUESS'/)
END IF
ELSE
PRINT 7701
7701 FORMAT(/' --> GBLEVENTS: POSTEVENTS MODE - DATE CHECK AND ',
$ 'TRANSFORM THE ANALYSIS'/)
END IF
IF(DOFCST .OR. SOME_FCST .OR. DOANLS)
$ 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 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 .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,12,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(NLEV.GT.0) THEN
IF(FCST) THEN
CALL UFBINT(IUNITP,BAK,12,NLEV,IRET,FCSTR)
ELSE
CALL UFBINT(IUNITP,BAK,12,NLEV,IRET,ANSTR)
RETURN
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 GBLEVN04
IF(NLEV.GT.0) CALL UFBINT(IUNITP,BAK,12,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(/' ==> FORECAST VALUES NOT ENCODED FOR THIS TABLE A ',
$ 'ENTRY'//' ==> FILTERING VIA POB VS. GESS PSFC TEST NOT ',
$ 'PERFORMED FOR THIS TABLE A ENTRY SINCE FORECAST VALUES NOT ',
$ 'PROCESSED/STORED'/)
ELSE
IF(NEWTYP.EQ.1) WRITE(IUNITS,1708)
1708 FORMAT(/' ==> FORECAST VALUES ARE ENCODED FOR THIS TABLE A ',
$ 'ENTRY'//' ==> FILTERING VIA POB VS. GESS PSFC TEST IS ',
$ 'PERFORMED FOR THIS TABLE A ENTRY SINCE FORECAST VALUES ARE ',
$ 'PROCESSED/STORED'/)
ENDIF
IF(.NOT.DOBERR) THEN
IF(NEWTYP.EQ.1) WRITE(IUNITS,1705)
1705 FORMAT(/' ==> FILTERING VIA MISSING OBS ERROR TEST NOT POSSIBLE',
$ ' FOR THIS TABLE A ENTRY SINCE OBS ERROR VALUES NOT PROCESSED/',
$ 'STORED'/)
ENDIF
CALL GBLEVN02(IUNITP,IUNITS,NEWTYP)
C MAKE THE VIRTUAL TEMPERATURE EVENTS AND ENCODE INTO REPORT
C ----------------------------------------------------------
IF(.NOT.VIRT) THEN
IF(NEWTYP.EQ.1) WRITE(IUNITS,1706)
1706 FORMAT(/' ==> "VIRTMP" EVENT PROCESSING NOT PERFORMED FOR THIS ',
$ 'TABLE A ENTRY'/)
ELSE
IF(NEWTYP.EQ.1) WRITE(IUNITS,1707)
1707 FORMAT(/' ==> "VIRTMP" EVENT PROCESSING IS PERFORMED FOR THIS ',
$ 'TABLE A ENTRY'/)
CALL GBLEVN08(IUNITP,SUBSET)
ENDIF
C RETURN TO CALLING PROGRAM TO WRITE GBL-EVENTED REPORT (SUBSET) INTO
C PREPBUFR FILE
C -------------------------------------------------------------------
RETURN
END
C***********************************************************************
C***********************************************************************
SUBROUTINE GBLEVN01(IUNITE) ! FORMERLY SUBROUTINE ETABLE
COMMON /GBEVDD/ ERRS(300,33,6)
C READ THE OBSERVATION ERROR TABLES
C ---------------------------------
REWIND IUNITE
IREC = 0
10 CONTINUE
READ(IUNITE,'(1X,I3)',END=100) KX
IREC = IREC + 1
DO K=1,33
READ(IUNITE,'(1X,6E12.5)') (ERRS(KX,K,M),M=1,6)
ENDDO
GO TO 10
100 CONTINUE
IF(IREC.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,12)
CHARACTER*8 STNID
CHARACTER*40 PEVN,QEVN,TEVN,WEVN,PWVN,PW1VN,PW2VN,PW3VN,PW4VN
REAL(8) PEV(4,255),QEV(4,255),TEV(4,255),WEV(5,255),
$ PWV(4,255),PW1V(4,255),PW2V(4,255),PW3V(4,255),
$ PW4V(4,255),OBS,BAK,SID
LOGICAL FCST,DN2FAR,REJPS,REJT,REJQ,REJW,REJPW,REJPW1,REJPW2,
$ REJPW3,REJPW4,SATMQC,SATEMP,SOLN60,SOLS60
COMMON /GBEVAA/ SID,OBS(12,255),BAK(12,255),NLEV,XOB,YOB,DHR,TYP
COMMON /GBEVBB/ PVCD,VTCD
COMMON /GBEVCC/ DOVTMP,DOFCST,SOME_FCST,DOBERR,FCST,VIRT,
$ QTOP_REJ,SATMQC,ADPUPA_VIRT
COMMON /GBEVEE/PSG01,ZSG01,TG01(100),UG01(100),VG01(100),
x QG01(100),zint(100),pint(100),pintlog(100),plev(100),
x plevlog(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 PW1VN /'PW1O PW1Q PW1P PW1R '/
DATA PW2VN /'PW2O PW2Q PW2P PW2R '/
DATA PW3VN /'PW3O PW3Q PW3P PW3R '/
DATA PW4VN /'PW4O PW4Q PW4P PW4R '/
DATA BMISS /10E10/,NFLGRT/2400*0/
NI = MOD((NINT(TYP)/10),10)
IF(NEWTYP.EQ.1) NFLGRT = 0
C LOGICAL SWITCHES FOR OBSERVATION LOCATION FILTERING
C ---------------------------------------------------
SATEMP = ((TYP.GE.160.AND.TYP.LE.179).AND.SATMQC)
SOLN60 = ((TYP.GE.160.AND.TYP.LE.163).AND.YOB.GE.-60.AND.SATMQC)
SOLS60 = ((TYP.EQ.160.OR.TYP.EQ.162.OR.TYP.EQ.163).AND.YOB.LT.-60
$ .AND.SATMQC)
C CLEAR THE EVENT ARRAYS
C ----------------------
PEV = BMISS
QEV = BMISS
TEV = BMISS
WEV = BMISS
PWV = BMISS
PW1V = BMISS
PW2V = BMISS
PW3V = BMISS
PW4V = BMISS
MAXPEV = 0
MAXQEV = 0
MAXTEV = 0
MAXWEV = 0
MAXPWV = 0
MAXPW1V = 0
MAXPW2V = 0
MAXPW3V = 0
MAXPW4V = 0
C LOOP OVER LEVELS APPLYING UNDERGROUND FILTERING AND SPECIAL RULES
C -----------------------------------------------------------------
IF(NLEV.GT.0) THEN
DO L=1,NLEV
POB = OBS( 1,L)
QOB = OBS( 2,L)
TOB = OBS( 3,L)
UOB = OBS( 5,L)
VOB = OBS( 6,L)
PWO = OBS( 7,L)
PW1O = OBS( 8,L)
PW2O = OBS( 9,L)
PW3O = OBS(10,L)
PW4O = OBS(11,L)
CAT = OBS(12,L)
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
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(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(1,L) = PW1O
PW1V(2,L) = 9
PW1V(3,L) = PVCD
PW1V(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(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(1,L) = PW2O
PW2V(2,L) = 9
PW2V(3,L) = PVCD
PW2V(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(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(1,L) = PW3O
PW3V(2,L) = 9
PW3V(3,L) = PVCD
PW3V(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(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(1,L) = PW4O
PW4V(2,L) = 9
PW4V(3,L) = PVCD
PW4V(4,L) = 3
MAXPW4V = L
ENDIF
ENDIF
ENDDO
ENDIF
C APPLY THE PROPER EVENTS
C -----------------------
IF(MAXPEV .GT.0) CALL UFBINT(IUNITP,PEV, 4,MAXPEV, IRET,PEVN)
IF(MAXQEV .GT.0) CALL UFBINT(IUNITP,QEV, 4,MAXQEV, IRET,QEVN)
IF(MAXTEV .GT.0) CALL UFBINT(IUNITP,TEV, 4,MAXTEV, IRET,TEVN)
IF(MAXWEV .GT.0) CALL UFBINT(IUNITP,WEV, 5,MAXWEV, IRET,WEVN)
IF(MAXPWV .GT.0) CALL UFBINT(IUNITP,PWV, 4,MAXPWV, IRET,PWVN)
IF(MAXPW1V.GT.0) CALL UFBINT(IUNITP,PW1V,4,MAXPW1V,IRET,PW1VN)
IF(MAXPW2V.GT.0) CALL UFBINT(IUNITP,PW2V,4,MAXPW2V,IRET,PW2VN)
IF(MAXPW3V.GT.0) CALL UFBINT(IUNITP,PW3V,4,MAXPW3V,IRET,PW3VN)
IF(MAXPW4V.GT.0) CALL UFBINT(IUNITP,PW4V,4,MAXPW4V,IRET,PW4VN)
RETURN
END
C***********************************************************************
C***********************************************************************
C GBLEVN03 - INTERPOLATE MODEL DATA (FIRST GUESS OR ANALYSIS) TO OB
C LOCATIONS
C-----------------------------------------------------------------------
SUBROUTINE GBLEVN03(SUBSET) ! FORMERLY SUBROUTINE GETFC
REAL(8) OBS,BAK,SID
CHARACTER*8 SUBSET
COMMON /GBEVAA/ SID,OBS(12,255),BAK(12,255),NLEV,XOB,YOB,DHR,TYP
COMMON /GBEVFF/IMAX,JMAX,KMAX,kmaxs,DLAT,DLON,IDVC,SL(100),SI(101)
COMMON /GBEVEE/PSG01,ZSG01,TG01(100),UG01(100),VG01(100),
x QG01(100),zint(100),pint(100),pintlog(100),plev(100),
x plevlog(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 GUESS PROFILE AT OB LOCATION
C --------------------------------
CALL GBLEVN06(XOB,YOB)
C INTERPOLATE GUESS PROFILES TO OB PRESSURES
C ------------------------------------------
IF(NLEV.GT.0) THEN
DO 10 L=1,NLEV
POB = OBS( 1,L)
QOB = OBS( 2,L)
TOB = OBS( 3,L)
ZOB = OBS( 4,L)
UOB = OBS( 5,L)
VOB = OBS( 6,L)
PWO = OBS( 7,L)
PW1O = OBS( 8,L)
PW2O = OBS( 9,L)
PW3O = OBS(10,L)
PW4O = OBS(11,L)
CAT = OBS(12,L)
IF(POB.LE.0. .OR. POB.GE.BMISS) GOTO 10
poblog = log(pob)
la = -999
lb = -999
do k=1,kmax-1
if (poblog<=plevlog(k) .and. poblog>plevlog(k+1)) then
la = k
lb = k+1
exit
endif
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(1) + (PSG01-PLEV(1))*BETAP
DZ = ZOB-ZSG01
TM = TS - DZ*BETA*.5
PFC = PSG01*EXP(-DZ/(TM*ROG))
ELSE
PFC = BMISS
ENDIF
C SPECIFIC HUMIDITY
C -----------------
IF(QOB.LT.BMISS.OR.TOB.LT.BMISS.OR.TYP.EQ.111) THEN
C (QFC NEEDED BY SYNDATA PROGRAM BUT ONLY FOR REPORT TYPE 111)
QOB = QG01(LB) + (QG01(LA)-QG01(LB))*WT
ENDIF
C TEMPERATURE
C -----------
IF(TOB.LT.BMISS.OR.SUBSET.EQ.'VADWND '.OR.TYP.EQ.111) THEN
C (TFC NEEDED BY CQCVAD AND SYNDATA PROGRAMS, LATTER ONLY FOR REPORT
C TYPE 111)
IF(POB.GT.PLEV(1)) THEN
TOB = TG01(1) + (POB-PLEV(1))*BETAP
ELSE
TOB = TG01(LB) + (TG01(LA)-TG01(LB))*WT
ENDIF
TOB = TOB - TZERO
ENDIF
C HEIGHT
C ------
IF(ZOB.LT.BMISS) THEN
IF(POB.GT.PLEV(1)) THEN
TM = TG01(1) + (.5*(PINT(1)+POB)-PLEV(1))*BETAP
ZOB = ZINT(1) - ROG*TM*LOG(POB/PINT(1))
ELSE
TM = TG01(LB) + (TG01(LA)-TG01(LB))*WT
ZOB = ZINT(LI) - ROG*TM*LOG(POB/PINT(LI))
ENDIF
ENDIF
C U AND V COMPONENTS
C ------------------
IF(UOB.LT.BMISS .OR. VOB.LT.BMISS) THEN
UOB = UG01(LB) + (UG01(LA)-UG01(LB))*WT
VOB = VG01(LB) + (VG01(LA)-VG01(LB))*WT
ENDIF
C PRECIPITABLE WATER
C ------------------
PWO = BMISS
PW1O = BMISS
PW2O = BMISS
PW3O = BMISS
PW4O = BMISS
C RELATIVE HUMIDITY
C -----------------
RHO = BMISS
C SCATTER THE PROPER FIRST GUESS/ANALYSIS VALUES
C ----------------------------------------------
BAK(1,L) = PFC
BAK(2,L) = QOB
BAK(3,L) = TOB
BAK(4,L) = ZOB
BAK(5,L) = UOB
BAK(6,L) = VOB
BAK(7,L) = PWO
BAK(8,L) = PW1O
BAK(9,L) = PW2O
BAK(10,L) = PW3O
BAK(11,L) = PW4O
BAK(12,L) = RHO
10 ENDDO
ENDIF
RETURN
END
C***********************************************************************
C***********************************************************************
SUBROUTINE GBLEVN04 ! FORMERLY SUBROUTINE GETOE
REAL(8) OBS,BAK,SID
COMMON /GBEVAA/ SID,OBS(12,255),BAK(12,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 -------------------------------------------------
IF(NLEV.GT.0) THEN
DO L=1,NLEV
POB = OBS( 1,L)
QOB = OBS( 2,L)
TOB = OBS( 3,L)
WOB = MAX(OBS(5,L),OBS(6,L))
PWO = OBS( 7,L)
PW1O = OBS( 8,L)
PW2O = OBS( 9,L)
PW3O = OBS(10,L)
PW4O = OBS(11,L)
CAT = OBS(12,L)
IF(CAT .EQ.0 ) BAK( 1,L) = OEFG01(POB,TYP,5)
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)
IF(PW1O.LT.BMISS) BAK( 7,L) = OEFG01(POB,TYP,6)
IF(PW2O.LT.BMISS) BAK( 8,L) = OEFG01(POB,TYP,6)
IF(PW3O.LT.BMISS) BAK( 9,L) = OEFG01(POB,TYP,6)
IF(PW4O.LT.BMISS) BAK(10,L) = OEFG01(POB,TYP,6)
ENDDO
ENDIF
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,IDVC,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
REAL KAP1,KAPR
COMMON /GBEVFF/IMAX,JMAX,KMAX,kmaxs,DLAT,DLON,IDVC,SL(100),SI(101)
COMMON /GBEVEE/ 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(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
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(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$$$ SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: GBLEVN08 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
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 GBLEVN08(IUNITP)
C INPUT ARGUMENT LIST:
C IUNITP - BUFR OUTPUT FILE UNIT
C SUBSET - THE BUFR MESSAGE TABLE A ENTRY FOR THE PARTICULAR
C - REPORT BEING PROCESSED
C
C REMARKS: WILL IMMEDIATELY RETURN TO CALLING PROGRAM IF ANY OF THE
C FOLLOWING CONDITIONS EXIST: THERE ARE NO LEVELS OF VALID DEWPOINT,
C OBS, TEMPERATURE Q.M. OR SPEC. HUMIDITY Q.M. IN THE INPUT PREPBUFR
C FILE FOR THE REPORT. WILL NOT ATTEMPT EITHER SPEC. HUMIDITY NOR
C VIRT. TEMP CALC. ON A GIVEN LEVEL IF ANY OF THE FOLLOWING
C CONDITIONS EXIST: REPORTED PRESSURE OBS IS MISSING, REPORTED
C (SENSIBLE) TEMPERATURE OBS IS MISSING, OR REPORTED DEWPOINT OBS IS
C MISSING.
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 90
C MACHINE: IBM-SP
C
C$$$
SUBROUTINE GBLEVN08(IUNITP,SUBSET) ! FORMERLY SUBROUTINE VTPEVN
CHARACTER*80 EVNSTQ,EVNSTV
CHARACTER*8 SUBSET
REAL(8) TDP(255),TQM(255),QQM(255),BAKQ(4,255),BAKV(4,255),
$ OBS,BAK,SID
LOGICAL EVNQ,EVNV,DOVTMP,TROP
COMMON /GBEVAA/ SID,OBS(12,255),BAK(12,255),NLEV,XOB,YOB,DHR,TYP
COMMON /GBEVBB/ PVCD,VTCD
COMMON /GBEVCC/ DOVTMP,DOFCST,SOME_FCST,DOBERR,FCST,VIRT,
$ QTOP_REJ,SATMQC,ADPUPA_VIRT
DATA EVNSTQ /'QOB QQM QPC QRC'/
DATA EVNSTV /'TOB TQM TPC TRC'/
DATA BMISS /10E10/
C-----------------------------------------------------------------------
C FCNS BELOW CONVERT TEMP/TD (K) & PRESS (MB) INTO SAT./ SPEC. HUM.(G/G)
C-----------------------------------------------------------------------
ES(T) = 6.1078*EXP((17.269*(T - 273.16))/((T - 273.16)+237.3))
QS(T,P) = (0.622*ES(T))/(P-(0.378*ES(T)))
C-----------------------------------------------------------------------
C CLEAR TEMPERATURE AND SPECIFIC HUMIDITY EVENTS
C ----------------------------------------------
EVNQ = .FALSE.
EVNV = .FALSE.
BAKQ = BMISS
BAKV = BMISS
TROP = .FALSE.
C GET DEWPOINT TEMPERATURE AND CURRENT T,Q QUALITY MARKERS
C --------------------------------------------------------
CALL UFBINT(-IUNITP,TDP,1,255,NLTD,'TDO')
CALL UFBINT(-IUNITP,QQM,1,255,NLQQ,'QQM')
CALL UFBINT(-IUNITP,TQM,1,255,NLTQ,'TQM')
IF(SUBSET.NE.'RASSDA ') 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/GBLEVN08 - NLTD .NE. NLEV - STOP 61'
CALL ERREXIT(61)
END IF
IF(NLQQ.NE.NLEV) THEN
PRINT *, '##GBLEVENTS/GBLEVN08 - NLQQ .NE. NLEV - STOP 63'
CALL ERREXIT(63)
END IF
END IF
IF(NLTQ.NE.NLEV) THEN
PRINT *, '##GBLEVENTS/GBLEVN08 - 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(1,L)
TDO = TDP(L)
TOB = OBS(3,L)
CAT = OBS(12,L)
IF(DOVTMP) THEN
IF(SUBSET.EQ.'RASSDA ') THEN
IF(TOB.LT.BMISS) THEN
BAKV(1,L) = TOB
BAKV(2,L) = TQM(L)
BAKV(3,L) = VTCD
BAKV(4,L) = 3
EVNV = .TRUE.
CYCLE
END IF
END IF
END IF
IF(POB.LT.BMISS .AND. TOB.LT.BMISS
$ .AND. TDO.LT.BMISS) THEN
IF(QQM(L).GT.3) THEN
C Don't update q or calculate Tv if bad moisture obs fails sanity check
cdak IF(TDO.LT.-103.15 .OR. TDO.GT.46.83 .OR. POB.LT.0.1 .OR.
cdak $ POB.GT.1100.)
cdak $ print *, '&&& bad QM fails sanity check'
IF(TDO.LT.-103.15 .OR. TDO.GT.46.83 .OR. POB.LT.0.1 .OR.
$ POB.GT.1100.) CYCLE
ENDIF
QOB = QS(TDO+273.16,POB)
BAKQ(1,L) = QOB*1E6
BAKQ(2,L) = QQM(L) ! Moist qm same as before for re-calc. q
BAKQ(3,L) = VTCD
BAKQ(4,L) = 0 ! Re-calc. q gets unique reason code 0
EVNQ = .TRUE.
C If message type ADPUPA, test this level to see if at or above trop
C (trop must be above 500 mb to pass test; if no trop level found
C assume it's at 80 mb)
C Don't calculate Tv on this level if at or above trop (doesn't affect
C q calculation)
TROP = (SUBSET.EQ.'ADPUPA ' .AND.
$ ((CAT.EQ.5 .AND. POB.LT.500.) .OR. POB.LT. 80. .OR. TROP))
IF(DOVTMP .AND. .NOT.TROP) THEN
BAKV(1,L) = (TOB+273.16)*(1.+.61*QOB)-273.16
BAKV(3,L) = VTCD
IF(SUBSET.EQ.'ADPUPA ') THEN
C Message type ADPUPA comes here
IF(QQM(L).LT.4 .OR. TQM(L).EQ.0 .OR. TQM(L).GT.3 .OR.
$ POB.LE.700.) THEN
BAKV(2,L) = TQM(L) ! Tv qm same as for T when q ok
BAKV(4,L) = 0 ! Tv gets unique reason code 0
ELSE
BAKV(2,L) = 3 !Tv qm susp for bad moist below 700mb
BAKV(4,L) = 6 !Tv gets unique reason code 6
ENDIF
ELSE
C All other message types come here
IF(QQM(L).LT.4) THEN
BAKV(2,L) = TQM(L) ! Tv qm same as for T when q ok
BAKV(4,L) = 0 ! Tv gets unique reason code 0
ELSE
cdak print *, '%%% process tvirt on lvl ',l,' for bad QQM case'
BAKV(2,L) = 8 ! Tv qm bad for bad moist
BAKV(4,L) = 2 ! Tv gets unique reason code 2
ENDIF
ENDIF
EVNV = .TRUE.
ENDIF
ENDIF
ENDDO
ENDIF
C ENCODE EVENTS INTO REPORT
C -------------------------
IF(NLEV.GT.0) THEN
IF(EVNQ) CALL UFBINT(IUNITP,BAKQ,4,NLEV,IRET,EVNSTQ)
IF(EVNV) CALL UFBINT(IUNITP,BAKV,4,NLEV,IRET,EVNSTV)
ENDIF
RETURN
END
C#######################
C#######################
C#######################
C#######################
C#######################
C#######################
C***********************************************************************
C***********************************************************************
SUBROUTINE GBLEVN10(IUNITF,IDATEP) ! FORMERLY SUBROUTINE GESRES
COMMON /GBEVFF/IMAX,JMAX,KMAX,kmaxs,DLAT,DLON,IDVC,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(226,2)
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: 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=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/GBLEVN10 - 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/GBLEVN10 - 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/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,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/GBLEVN10: INVALID VERT COORD ID (=',
$ IDVC,'), DEFAULTING TO SIGMA COORD, RESETTING IDVC = 1'
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: GLOBAL MODEL SPECS: T',I3,' ',I3,
$ ' LEVELS ',I3,' SCALARS -------> ',F4.2,' X ',F4.2,' VERT. ',
$ 'COORD: ',A)
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,IDVC,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