C$$$  SUBPROGRAM DOCUMENTATION BLOCK 
C                .      .    .                                       . 
C SUBPROGRAM:    ERRORS      CHECKS THE SOUNDING DATA FOR GROSS ERRORS
C   PRGMMR: TRACY SMITH      ORG: FSL/PROFS  DATE: 90-07-19 
C 
C ABSTRACT: CHECKS THE SOUNDING DATA FOR GROSS ERRORS, AND DELETES
C   LEVELS WITH BAD DATA. 
C 
C PROGRAM HISTORY LOG: 
C   84-??-??  RUTH LIEBERMAN     ORIGINAL VERSION
C   85-02-20  KEITH BREWSTER     MODIFIED 
C   85-03-02  KEITH BREWSTER     VARIABLE DIMENSION ADDED.
C   85-04-16  KEITH BREWSTER     QC STUFF   
C   85-07-10  KEITH BREWSTER     IMPROVEMENTS IN SUPER-ADIABATIC 
C                                ERROR CHECKING. 
C   86-08-13  S. BENJAMIN        SET TO ALLOW NO SUPER-ADIABATIC 
C                                LAYERS FOR ISENTROPIC INGEST.
C   87-05-28  S. BENJAMIN        PRE-CHECKING TO ENSURE NO DUPLICATE 
C                                PRESSURE LEVELS.
C 
C USAGE:    CALL ERRORS(ZIN,PIN,TIN,DPD,DD,FF,
C                       RAWQC,NLEVS,SKIP) 
C   INPUT ARGUMENT LIST: 
C     ZIN      - REAL ARRAY   HEIGHTS (M)
C     PIN      - REAL ARRAY   PRESSURES (MB)
C     TIN      - REAL ARRAY   TEMPERATURES (C)
C     DPD      - REAL ARRAY   DEW POINT DEPRESSIONS (C)
C     DD       - REAL ARRAY   WIND DIRECTION (DEG FROM N)
C     FF       - REAL ARRAY   WIND SPEED (KTS)
C     RAWQC    - INTEGER ARRAY   RAW QC VALUES
C     NLEVS    - INTEGER      NUMBER OF LEVES
C 
C   OUTPUT ARGUMENT LIST:   
C     ZIN      - REAL ARRAY   HEIGHTS
C     PIN      - REAL ARRAY   PRESSURES
C     TIN      - REAL ARRAY   TEMPERATURES
C     DPD      - REAL ARRAY   DEW POINT DEPRESSIONS
C     DD       - REAL ARRAY   WIND DIRECTION
C     FF       - REAL ARRAY   WIND SPEED
C     RAWQC    - INTEGER ARRAY   RAW QC VALUES
C     NLEVS    - INTEGER      NUMBER OF LEVES
C     SKIP     - LOGICAL      SKIP THIS STATION IF DATA IS BAD.
C
C   SUBPROGRAMS CALLED:
C     UNIQUE:    - DLEV, INFLST, SETQC, CHEKQC
C
C REMARKS: 
C 
C ATTRIBUTES: 
C   LANGUAGE: FORTRAN-77
C   MACHINE:  NAS-9000 
C$$$ 
           SUBROUTINE ERRORS(Z,P,T,DPD,DD,FF,RAWQC,NLEVS,SKIP)
C**********************************************************************
C*    THIS SUBROUTINE CHECKS THE SOUNDING DATA FOR GROSS ERRORS. THE
C*    FOLLOWING PARAMETERS ARE CHECKED AND THE FOLLOWING CRITERIA ARE
C*    ARE EMPLOYED:
C*
C*        1. THE PRESURES AT THE SURFACE ARE CHECKED TO SEE IF THEY
C*           LIE BELOW 1100. MB and above 750. mb.
C*
C*        2. THE SURFACE TEMPERATURES ARE CHECKED TO SEE THAT THEY
C*           LIE BELOW  325. DEGREES K AND ABOVE 210. DEGREES C.
C*
C*        3. THE DEW POINT DEPRESSIONS ARE CHECKED TO SEE THAT
C*           THEY ARE NON-NEGATIVE, DON'T TAKE TD IF T LT 225K.
C*
C*        5. THE PRESSURES AT ALL LEVELS ARE CHECKED TO ENSURE THAT
C*           THEY ARE DESCENDING WITH HEIGHT.
C*
C*        6. THE HEIGHTS ARE CHECKED TO ENSURE THAT THEY ARE ASCENDING.
C*
C*        7. THE POTENTIAL TEMPERATURES ARE COMPUTED AT EVERY LEVEL AND
C*           CHECKED TO ENSURE THAT THEY ARE INCREASING WITH
C*           INCREASING HEIGHT.
C*           SUPER-ADIABATIC LEVELS ARE ALLOWED IN THE LOWEST 200 MB.
C*           For THERRORS, the sounding is set such that it is at least
C*              slightly stable in all layers.
C*           And no levels are taken above THMAX_P
C*
C**********************************************************************

      INCLUDE 'IMPLICIT'
      INCLUDE 'MAPSCON'
      INCLUDE 'METCON'

      REAL             P(SND_LEV_P),
     +                 Z(SND_LEV_P),
     +                 T(SND_LEV_P),
     +                 DPD(SND_LEV_P),
     +                 DD(SND_LEV_P),
     +                 FF(SND_LEV_P)

      INTEGER          RAWQC (NVAR_P,SND_LEV_P)
      LOGICAL          SKIP, NODATA
      REAL PLIM,PLIMB,TLIMB,TLIMT,DTHLIM

      PARAMETER(PLIM = 1100.,
     +          PLIMB = 500.,
     +          TLIMB = 170.,
     +          TLIMT = 345.,
     +          DTHLIM = 1.0)
C
C MISC DUMMY VARIABLES
C
      REAL*4 DIFF,PLAST,SLOPEB,SLOPET,TEMPCHK,
     +       THETAB,THETAK,THETAM2,THETAP1,THETAT,
     +       ZTEST
      INTEGER*4 ISTAT,QCFLAGT,QCFLAGP,
     +          I,K,KB,KD,KBASE,KBOLD,KBOT,KLAST,KM2,KP1,KP2,
     +          KTOP,NLEVS

C*** Set the logical false
      SKIP = .FALSE.

C*** Make sure there's data at them thar stations
      IF(NLEVS.LE.1) THEN
        SKIP=.TRUE.
        RETURN
      ENDIF
C
C     C H E C K    S U R F A C E   C O N D I T I O N S
C
      IF (      (P(1) .GT. PLIM
     ,                           .OR.   P(1).LT.PLIMB)
C                                                     ! P OUT OF RANGE
     ,    .OR.   ((T(1).GT.TLIMT .AND. T(1).LT.SPVAL_P)
C                                                     ! T OUT OF RANGE
     ,                          .OR.  T(1) .LT. TLIMB)
     ,   .OR.   (DPD(1) .LT. 0.)
C                                                         ! DPD < 0
     ,   .OR.   (DD(1) .LT. 0.)
C                                                         ! WIND SP. OR
     ,   .OR.   (FF(1) .LT. 0.)    )
C                                                         ! DIR < 0
     ,   THEN
         SKIP = .TRUE.
C          WRITE(6,553)
C          WRITE(6,556) P(1)
C          WRITE(6,557)T(1)
C          WRITE(6,558)DPD(1)
C          WRITE(6,559)DD(1)
C          WRITE(6,560)FF(1)
C          WRITE(6,561)
C553       FORMAT(1X,'SURFACE DATA READS AS FOLLOWS:')
C556       FORMAT(1X,'PRESSURE = ',F6.0,'MB')
C557       FORMAT(1X,'TEMPERATURE =',F6.0,'DEGREES C')
C558       FORMAT(1X,'DEW POINT DEPRESSION =',E15.8,' DEGREES')
C559       FORMAT(1X,'WIND DIRECTION = ',F6.0,'DEGREES FROM NORTH')
C560       FORMAT(1X,'WIND SPEED =',F6.0,' KNOTS ')
C561       FORMAT(1X,'AND IS THEREFORE INVALID. DATA FOR THIS STATION',
C    +           ' IS DISREGARDED')
        RETURN
       ENDIF
C
       DO  10 K=2,NLEVS
C** added extra if check 28 Nov 90 to catch multiple bad levels
 110      IF (P(K).GE.P(K-1).AND. P(K).LT.SPVAL_P) THEN
          KD = K
          CALL DLEV(P,T,Z,DPD,DD,FF,RAWQC,KD,NLEVS)
          IF(K.LT.NLEVS) GOTO 110
         ENDIF
C** added extra if check 28 Nov 90 to catch multiple bad levels
        IF (P(K).GE.P(K-1).AND. P(K).LT.SPVAL_P) THEN
          KD = K
          CALL DLEV(P,T,Z,DPD,DD,FF,RAWQC,KD,NLEVS)
         ENDIF
C *** added 24 Sept 92 for ridiculously high temperatures
        IF (T(K).GT.TLIMT.AND.T(K).LT.SPVAL_P) THEN
          KD = K
          CALL DLEV(P,T,Z,DPD,DD,FF,RAWQC,KD,NLEVS)
         ENDIF
C*** check for bad winds
        IF(DD(K).LT.0.OR.FF(K).LT.0 .or. ff(k).gt.160.
     1       .and. ff(k).lt.spval_p) THEN
           write(6,*) ' Threw out wind observation, dd/ff',
     1           dd(k),ff(k)
           DD(K)=SPVAL_P
           FF(K)=SPVAL_P
  
        ENDIF
C*** check for p = 0  ----SSW aug 2000
        IF(P(K).LT.0.1) THEN
           p(k) = spval_p
        ENDIF
        IF(DD(K).GE.360.) FF(K)=SPVAL_P
        IF(FF(K).GE.SPVAL_P) DD(K)=SPVAL_P

   10 CONTINUE
C       END DO

      PLAST=P(1)
      KLAST=0
      KBASE=0
      KBOLD=0
      KM2=-1
      IF(Z(1).LT.SPVAL_P) THEN
        KLAST=1
        IF(P(1).LT.SPVAL_P) KBASE=1
       ENDIF

C**********************************************************************
C*    NOTE: IF SURFACE CONDITIONS ARE WITHIN LIMITS, THEN FROM HERE ON
C*          FOR SOME CHECKS IT WILL BE ASSUMED THAT IF ANY VERTICAL
C*          DIFFERENCES ARE OUT OF RANGE, THEN THE UPPER LEVEL VARIABLE
C*          IS UNACCEPTABLE AND WILL BE CHANGED OR DISCARDED.
C*
C**********************************************************************
      IF (T(1) .LT. SPVAL_P .AND.  P(1) .LT. SPVAL_P)  THEN
        THETAB = T(1)*(1000./P(1))**ROVCP_P
      ELSE
        THETAB = 0.
       ENDIF
      IF (DD(1).GE.SPVAL_P) DD(1)=SPVAL_P
      IF (FF(1).GE.SPVAL_P) FF(1)=SPVAL_P
      K = 2
      KB = 1
550   IF (K .GT. NLEVS) RETURN
C     WRITE(6,5501) K
C5501 FORMAT(' CHECKLOOP STARTED-  K = ',I3)
C     WRITE(6,5505)Z(K)
C     WRITE(6,5506) P(K)
C     WRITE(6,5507)T(K)
C     WRITE(6,5508)DPD(K)
C     WRITE(6,5509)DD(K)
C     WRITE(6,5610)FF(K)
C5505 FORMAT(1X,'HEIGHT = ',E15.8,' METERS')
C5506 FORMAT(1X,'PRESSURE = ',E15.8,'MB')
C5507 FORMAT(1X,'TEMPERATURE =',E15.8,'DEGREES C')
C5508 FORMAT(1X,'DEW POINT DEPRESSION =',E15.8,' DEGREES')
C5509 FORMAT(1X,'WIND DIRECTION = ',E15.8,'DEGREES FROM NORTH')
C5610 FORMAT(1X,'WIND SPEED =',E15.8,' METERS PER SECOND')
C
C  CHECK TO SEE IF THERE IS ANY USEFUL DATA AT THIS LEVEL
C
      IF(P(K).LT.SPVAL_P.AND.T(K).GE.SPVAL_P.AND.DD(K).GE.SPVAL_P) THEN
        KD=K
        CALL DLEV(P,T,Z,DPD,DD,FF,RAWQC,KD,NLEVS)
        GO TO 550
       ENDIF
C
C  CHECK FOR P INCREASING WITH HEIGHT -- IF SO DISCARD LEVEL, NOT
C  MUCH YOU CAN DO IF P IS BAD
C
      IF(P(K).LT.SPVAL_P.AND.P(K).GE.PLAST) THEN
C                                                ! P OUT OF RANGE
        KD=K
        CALL DLEV(P,T,Z,DPD,DD,FF,RAWQC,KD,NLEVS)
        GO TO 550
      ELSE
        PLAST=P(K)
       ENDIF
C
C CHECK FOR Z DECREASING WITH DECREASING PRESSURE
C IF SO REINTEGRATE HYDROSTATIC
C
 505  IF(Z(K) .LT. SPVAL_P) THEN
        IF(KLAST.EQ.0) THEN
          KLAST=K
          IF(P(K).LT.SPVAL_P) KBASE=K
        ELSE
          IF (Z(K) .LE. Z(KLAST)) THEN
C           WRITE(6,1010) K,P(K),Z(K)
C1010       FORMAT('  Z DECREASING WITH HEIGHT AT LEVEL =',I3,
C    +             '  P= ',E15.8,'   Z=',F12.0)
            IF(P(K).GE.SPVAL_P) THEN
C                                    !FORGET IT--HOPELESS TO FIX
              KD=K
              CALL DLEV(P,T,Z,DPD,DD,FF,RAWQC,KD,NLEVS)
              GO TO 550
             ENDIF
            IF(ABS(Z(KLAST)-Z(K)).LE.2.0) THEN
C                                              !DUPLICATE LEVEL
              KD=KLAST
              CALL DLEV(P,T,Z,DPD,DD,FF,RAWQC,KD,NLEVS)
              GO TO 550
             ENDIF
C
C IF YOU'RE HERE THEN YOU KNOW THERE'S A P AT K--TRY TO REINTEGRATE
C    KBASE IS LAST PLACE THERE WAS Z AND P
C
C REINTEGRATE FROM KBASE
C
            IF(KBASE.EQ.0 .OR. T(KBASE).GE.99990. OR.
     +         T(K).GE.99990.) THEN
C                                   !CANT DO REST OF TESTS, SO

C                                    ! TOSS LEVEL K
              KD=K
              CALL DLEV(P,T,Z,DPD,DD,FF,RAWQC,KD,NLEVS)
              GO TO 550
            ELSE
C                ! TRY REINTEGRATING Z(K)
              KBOT=KBASE
              KTOP=K
              CALL INTLST(P,Z,T,DPD,KBOT,KTOP,ZTEST)
             ENDIF
C
C SEE IF NEW Z IS OK, IF NOT THEN ZLAST IS PROBABLY BAD
C
            IF(ZTEST.GT.Z(KLAST)) THEN
C                                      !ZTEST IS OK, SUBSTITUTE
C                     WRITE(6,1020) K,Z(K),ZTEST
C1020         FORMAT(' *REPLACING Z AT LEV=',I4,' WAS=',F8.0,
C    +                '  NEW=',F8.0)
              CALL SETQC(RAWQC(H_P,K),MSTRCHG_P,RAWQC(H_P,K),ISTAT)
              CALL SETQC(RAWQC(H_P,K),VERTCHG_P,RAWQC(H_P,K),ISTAT)
              Z(K)=ZTEST
              KLAST=K
              KBOLD=KBASE
              KBASE=K
              GO TO 569
            ELSE
C                !SUSPECT Z AT KLAST
              IF(KLAST.EQ.KBASE.AND.KBOLD.GT.0.AND.T(KBOLD).LT.99990.
     +             .AND. T(KBASE).LT.99990. ) THEN
C                      CAN TRY TO REINTEGRATE LAST
                KBOT=KBOLD
                KTOP=KBASE
                CALL INTLST(P,Z,T,DPD,KBOT,KTOP,ZTEST)
                IF(Z(K).GT.ZTEST) THEN
C                                      !Z(KLAST) WAS BAD,REPLACE
C                 WRITE(6,1030) KLAST,Z(KLAST),ZTEST
C1030             FORMAT(' *REPLACING Z AT LEV=',I4,' WAS=',F8.0,
C    +                   '  NEW=',F8.0)
                  CALL SETQC(RAWQC(H_P,KLAST),VERTCHG_P,
     +                        RAWQC(H_P,KLAST),ISTAT)
                  CALL SETQC(RAWQC(H_P,KLAST),MSTRCHG_P,
     +                        RAWQC(H_P,KLAST),ISTAT)
                  Z(KLAST)=ZTEST
                  KLAST=K
                  KBOLD=KBASE
                  KBASE=K
                  GO TO 569
                ELSE
C                    ! TOSS LEVEL K
                  KD=K
                  CALL DLEV(P,T,Z,DPD,DD,FF,RAWQC,KD,NLEVS)
                  GO TO 550
                 ENDIF
              ELSE
C                  !HOPELESS TO REINTEGRATE LAST--TOSS IT
                KD=KLAST
                CALL DLEV(P,T,Z,DPD,DD,FF,RAWQC,KD,NLEVS)
                GO TO 550
               ENDIF
             ENDIF
          ELSE IF(P(K).LT.SPVAL_P) THEN
C                                        !Z(K) IS OK
            KBOLD=KBASE
            KBASE=K
            KLAST=K
          ELSE
C              !Z(K) IS OK, BUT P IS MISSING
            KLAST=K
           ENDIF
         ENDIF
       ENDIF
 569  CONTINUE
C              !DESTINATION FOR RESOLVED Z PROBLEM
C
C CHECK THAT THE DEW POINT DEPRESSION IS GREATER THAN ZERO
C AND THAT THE TEMPERATURE IS ABOVE APPX. -50.C
c     IF(DPD(K) .LT. 0. .OR. T(K).LT.225.) THEN
c       DPD(K)=SPVAL_P
c       IF(P(K).LT.300.) THEN
c         DO I=K,NLEVS
c           DPD(I)=SPVAL_P
c         ENDDO
c       ENDIF
c     ENDIF
C ! DPD < 0, OR T < -50C.
C
C  CHECK FOR DECLINING THETA WITH HEIGHT
C  IF SO, TRY TO INTERPOLATE BETWEEN NEIGHBORING PRESSURE LEVELS

C  Allow up to a 1.0 (DTHLIM) K superadiabatic difference
C    in potential temp over a layer - Stan Benjamin and
C    Barry Schwartz - 20 Mar 97
C  Ref:  Slonaker et al., Sept 96, Weather and Forecasting

C                               DENVER, CO 1980-1989 supers

C ANALYZED    7275 SOUNDINGS IN FILE: 80010100.rao

C          DT =    superadiabatic theta diff in tenths of deg
C          TH =    layer thickness in mb
C           DT 0- 5  5-10 10-15 15-20 20-25 25-30 30-35 35-40 40- 50 50-9999 TOTAL
C TH   0-  10     0   332   114    26     7     2     0     0     1     0    482
C     10-  20   368   126    39    10     3     3     0     1     0     0    550
C     20-  30   167    77    20    11     3     2     0     0     0     0    280
C     30-  40   102    43    14     2     0     0     0     0     0     0    161
C     40-  50   173    66    19     8     0     2     0     0     0     0    268
C     50-  75    89    51    28     9     1     0     1     0     0     0    179
C     75- 100    73    48    16     6     4     0     0     0     0     0    147
C    100- 150   215   153    53    11     6     2     0     0     0     0    440
C    150- 200   281   153    59    23     4     1     0     0     0     0    521
C    200-9999   208    64    21    10     4     1     1     0     0     0    309
C      TOTALS  1676  1113   383   116    32    13     2     1     1     0   3337

C
      IF(P(K) .LT. SPVAL_P.AND. T(K) .LT.SPVAL_P)  THEN
        CALL CHCKQC(RAWQC(P_P,K),MSTRBAD_P,QCFLAGP,ISTAT)
        CALL CHCKQC(RAWQC(T_P,K),MSTRBAD_P,QCFLAGT,ISTAT)
        IF(QCFLAGP.NE.0 .OR. QCFLAGT.NE.0) GO TO 595
        THETAT = T(K)*(1000./P(K))**ROVCP_P
C*** Check to see if theta is in the domain
          IF(THETAT.GE.THMAX_P) THEN
            IF(DD(K).GE.SPVAL_P) THEN
              KD=K
              CALL DLEV(P,T,Z,DPD,DD,FF,RAWQC,KD,NLEVS)
              GO TO 550
            ELSE
              CALL SETQC(RAWQC(T_P,K),MSTRBAD_P,
     +                    RAWQC(T_P,K),ISTAT)
              CALL SETQC(RAWQC(T_P,K),VERTBAD_P,
     +                    RAWQC(T_P,K),ISTAT)
              GO TO 595
             ENDIF
           ENDIF

C       WRITE(6,1050) THETAM2, THETAB, THETAT
C1050   FORMAT(' THETAM2= ',E15.8,' THETAB= ',E15.8,' THETAT= ',E15.8)
        DIFF=THETAB - THETAT
        IF (DIFF .GT. DTHLIM) THEN
C                                       ! Theta decreasing
C         WRITE(6,1060) P(K),T(K)
C1060     FORMAT(' THETA DECREASING WITH HEIGHT AT P=',F8.0,
C    +           '  T=',F8.1)
C         WRITE(6,1070) THETAB,THETAT,DIFF
C1070     FORMAT('      THETAB,THETAT,DIFF=',2F10.0,1X,F6.2)
C --- If theta is decreasing, first check for temperature totally
C       out of bounds.  If it is, get rid of it.
          IF(T(K).GT.50. .OR. T(K).LT.-100.) THEN
            IF(DD(K).GE.SPVAL_P) THEN
              KD=K
              CALL DLEV(P,T,Z,DPD,DD,FF,RAWQC,KD,NLEVS)
              GO TO 550
            ELSE
              CALL SETQC(RAWQC(T_P,K),MSTRBAD_P,
     +                    RAWQC(T_P,K),ISTAT)
              CALL SETQC(RAWQC(T_P,K),VERTBAD_P,
     +                    RAWQC(T_P,K),ISTAT)
              GO TO 595
             ENDIF
           ENDIF
C If temperature is OK, then find next temperature level
           DO  20 KP1=K+1, NLEVS
            IF(T(KP1).LT.SPVAL_P.AND.P(KP1).LT.SPVAL_P) THEN
              CALL CHCKQC(RAWQC(P_P,KP1),MSTRBAD_P,QCFLAGP,ISTAT)
              CALL CHCKQC(RAWQC(T_P,KP1),MSTRBAD_P,QCFLAGT,ISTAT)
              IF(QCFLAGP.EQ.0 .AND. QCFLAGT.EQ.0) GO TO 563
             ENDIF

   20 CONTINUE
C       END DO
C         WRITE(6,1080)
C1080     FORMAT('   T IS SET TO LAST POTENTIAL TEMPERATURE')
          T(K)=(THETAB*(P(K)/1000.)**ROVCP_P) + DTHLIM
          CALL SETQC(RAWQC(T_P,K),MSTRCHG_P,RAWQC(T_P,K),ISTAT)
          CALL SETQC(RAWQC(T_P,K),VERTCHG_P,RAWQC(T_P,K),ISTAT)
          GO TO 595
  563     CONTINUE
C
C CHECK THE THETA LAPSE RATES ABOVE AND BELOW SUSPECT LAYER
C CORRECT THE POINT RESPONSIBLE FOR THE GREATEST THETA SLOPE
C THE POINT RESPONSIBLE FOR THE MOST STABLE ADJACENT LAYER
C
          THETAP1 = T(KP1)*(1000./P(KP1))**ROVCP_P
          SLOPET=(THETAP1-THETAT)/(P(K)-P(KP1))
C --- In surface layer, if super exists, force surface temperature
C       to be adjusted.
          IF(KM2.LE.0) THEN
            SLOPEB = 1.E8
          ELSE
            SLOPEB=(THETAB-THETAM2)/(P(KM2)-P(KB))
           ENDIF
C
C         DTB=THETAKB-THETAB  ! THETA DIFF AT BOTTOM
C         DTT=THETAK-THETAT  ! THETA DIFF AT TOP
C
C --- In ERRORS, adjust temperatures by using theta difference
C       which is slightly stable rather than using observed
C       lapse rate from layer above or below as was done in ERRORS.
C
          IF(SLOPET .GE. SLOPEB) THEN
C                                      ! FIX TOP LEVEL
            THETAK=THETAB + DTHLIM
            T(K)=THETAK*((P(K)/1000.)**ROVCP_P)
C                                                       ! T IN DEG C
            CALL SETQC(RAWQC(T_P,K),MSTRCHG_P,RAWQC(T_P,K),ISTAT)
            CALL SETQC(RAWQC(T_P,K),VERTCHG_P,RAWQC(T_P,K),ISTAT)
C           WRITE(6,1090) SLOPEB,SLOPET,T(K)
C1090       FORMAT(' TH SLOPE BOT, TOP:',2F8.4,
C    +             ' NEW T(K) (TOP) SET TO ',F8.1)
            THETAM2=THETAB
            THETAB=THETAK
          ELSE
C               ! FIX LOWER LEVEL
            THETAK=THETAT - DTHLIM
            T(KB)=THETAK*((P(KB)/1000.)**ROVCP_P)
C                                                         ! T IN DEG C
            CALL SETQC(RAWQC(T_P,KB),MSTRCHG_P,RAWQC(T_P,KB),ISTAT)
            CALL SETQC(RAWQC(T_P,KB),VERTCHG_P,RAWQC(T_P,KB),ISTAT)
C           WRITE(6,1095) SLOPEB,SLOPET,T(KB)
C1095       FORMAT(' TH SLOPE BOT,TOP ',2F8.4,
C    +             ' NEW T(KB) (BOT) SET TO ',F8.1)
            THETAM2=THETAK
            THETAB=THETAT
           ENDIF
        ELSE IF((T(K) - T(KB)).GT.20.) THEN
C --- If theta is decreasing, first check for temperature totally
C       out of bounds.  If it is, get rid of it.
          IF(T(K).GT.TLIMT .OR. T(K).LT.TLIMB) THEN
            IF(DD(K).GE.SPVAL_P) THEN
              KD=K
              CALL DLEV(P,T,Z,DPD,DD,FF,RAWQC,KD,NLEVS)
              GO TO 550
            ELSE
              CALL SETQC(RAWQC(T_P,K),MSTRBAD_P,
     +                    RAWQC(T_P,K),ISTAT)
              CALL SETQC(RAWQC(T_P,K),VERTBAD_P,
     +                    RAWQC(T_P,K),ISTAT)
              GO TO 595
             ENDIF
           ENDIF
C
C Unreasonable positive lapse rate....
C   allow for a little greater lapse right near sfc, for those
C   awesome radiation inversions, otherwise kill off top level
C   Unless the bottom level is the lowest level, then check against
C   average of next two levels
C
          IF((P(1)-P(KB)) .LE. 200. .AND.
     +          (T(K)-T(KB)) .LT. 25.) THEN

              THETAM2=THETAB
              THETAB=THETAT
              KM2=KB
              KB=K
	      GO TO 594
          ENDIF
          IF(KB.NE.1) THEN
            WRITE(6,1096) K,P(K),T(K)
 1096       FORMAT ('  1:TRASHING T AT ',I4,' PRESS= ',F10.0,
     +               '  T= ',F7.0)
            CALL SETQC(RAWQC(T_P,K),MSTRBAD_P,RAWQC(T_P,K),ISTAT)
            CALL SETQC(RAWQC(T_P,K),VERTBAD_P,RAWQC(T_P,K),ISTAT)
            GO TO 595
          ELSE
C               ! bottom level was the sfc
C FIND NEXT TEMPERATURE LEVEL
             DO  30 KP1=K+1, NLEVS
              IF(T(KP1).LT.SPVAL_P.AND.P(KP1).LT.SPVAL_P) THEN
                CALL CHCKQC(RAWQC(P_P,KP1),MSTRBAD_P,QCFLAGP,ISTAT)
                CALL CHCKQC(RAWQC(T_P,KP1),MSTRBAD_P,QCFLAGT,ISTAT)
                IF(QCFLAGP.EQ.0 .AND. QCFLAGT.EQ.0) GO TO 590
               ENDIF

   30 CONTINUE
C       END DO
C ran out of data....set the first to "bad"
            NODATA = .TRUE.
            GO TO 593
590         CONTINUE
             DO  40 KP2=KP1+1, NLEVS
              IF(T(KP2).LT.SPVAL_P.AND.P(KP2).LT.SPVAL_P) THEN
                CALL CHCKQC(RAWQC(P_P,KP2),MSTRBAD_P,QCFLAGP,ISTAT)
                CALL CHCKQC(RAWQC(T_P,KP2),MSTRBAD_P,QCFLAGT,ISTAT)
                IF(QCFLAGP.EQ.0 .AND. QCFLAGT.EQ.0) GO TO 591
               ENDIF

   40 CONTINUE
C       END DO
C ran out of data settle for just kp1
            TEMPCHK=T(KP1)
            GO TO 592
 591        CONTINUE
            TEMPCHK=0.5*(T(KP1)+T(KP2))
 592        CONTINUE
            NODATA = .FALSE.
 593        CONTINUE
            IF( ((ABS(T(KB)-TEMPCHK)) .GT. (ABS(T(K)-TEMPCHK)))
     +           .OR.  NODATA ) THEN
              WRITE(6,1097) KB,P(KB),T(KB)
 1097         FORMAT ('  2:TRASHING T AT ',I4,' PRESS= ',F10.0,
     +               '  T= ',F7.0)
              CALL SETQC(RAWQC(T_P,KB),MSTRBAD_P,RAWQC(T_P,KB),ISTAT)
              CALL SETQC(RAWQC(T_P,KB),VERTBAD_P,RAWQC(T_P,KB),ISTAT)
              KM2 = -1
              THETAM2 = -1
            ELSE
C                  ! level k is bad
              WRITE(6,1098) K,P(K),T(K)
 1098         FORMAT ('  3:TRASHING T AT ',I4,' PRESS= ',F10.0,
     +            '  T= ',F7.0)
              CALL SETQC(RAWQC(T_P,K),MSTRBAD_P,RAWQC(T_P,K),ISTAT)
              CALL SETQC(RAWQC(T_P,K),VERTBAD_P,RAWQC(T_P,K),ISTAT)
              GO TO 595
             ENDIF
C                   ! which level is goofy
           ENDIF
        ELSE
C             ! theta change is positive and not too large
          THETAM2=THETAB
          THETAB=THETAT
          KM2=KB
          KB=K
         ENDIF
 594      CONTINUE
C              ! theta lapse check
       ENDIF
C            ! missing data check
 595  CONTINUE
C5502 FORMAT(' CHECKLOOP COMPLETED; K = ',I3)
      K=K+1
      GO TO 550
       END
