C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    MREMRAOBLV  REMOVE USELESS & MOST DUPLICATE RAOB LEVS
C   PRGMMR: M. BARTH         ORG: FSL        DATE: 01-06-05
C
C ABSTRACT: REMOVE USELESS AND MOST DUPLICATE LEVELS FROM RAOB ARRAYS.
C
C PROGRAM HISTORY LOG:
C   01-06-05  M. BARTH    ORIGINAL VERSION
C   02-05-30  M. BARTH    - ONLY DEAL WITH THE MASTER_P QC CHECK VALUES
C                           IN THE QCDEP ARRAYS
C                         - RENAMED LOCAL VARIABLES TO CONFORM TO NEW
C                           RULES ON TEMPORARY STORAGE
C   06-01-26  M. BARTH    NOW NEED TO TRACK 3 ADJACENT VALUES, SINCE
C                         THE NEW SIGW-BY-P CAN WIND UP BETWEEN TWO
C                         REDUNDANT LEVELS.
C
C USAGE:    CALL MREMRAOBLV (ISTA,FNUM,NLEVELS,LINDEX,LTYPE,PHTYPE,P,HT,
C                            T,DPD,DD,FF)
C
C   INPUT ARGUMENT LIST:
C     ISTA     - I       STATION NUMBER INDEX FOR STRCCOM ARRAYS
C     FNUM     - I       FILE NUMBER INDEX FOR STRCCOM ARRAYS
C
C   INPUT/OUTPUT ARGUMENT LIST:
C     NLEVELS  - I       NUMBER OF LEVELS
C     LINDEX   - IA      INDEX INTO ORIGINAL NETCDF VARIABLE ARRAYS
C     LTYPE    - IA      LEVEL TYPES (E.G., MANDATORY, SIGT)
C     PHTYPE   - IA      P/H TYPE:  0-INPUT, 1-P INTERP, 2-H INTERP
C     P        - RA      RAOB SOUNDING DATA
C     HT       - RA      RAOB SOUNDING DATA
C     T        - RA      RAOB SOUNDING DATA
C     DPD      - RA      RAOB SOUNDING DATA
C     DD       - RA      RAOB SOUNDING DATA
C     FF       - RA      RAOB SOUNDING DATA
C
C SUBPROGRAMS CALLED:
C     NONE
C
C REMARKS:
C   THE ARRAYS IN THE ARG LIST ARE IN STRCCOM, BUT THEY ARE SENT INTO
C   THE SUBROUTINE FOR CONVENIENCE IN COPYING THIS OVER FROM THE RAOB
C   PROCESSING PROGRAM.  OTHER STRCCOM ARRAYS ARE HANDLED DIRECTLY
C   FROM STRCCOM FOR CONVENIENCE AS WELL.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN-77 + EXTENSIONS
C   MACHINE:  UNIX
C$$$


      SUBROUTINE MREMRAOBLV(ISTA,FNUM,NLEVELS,LINDEX,LTYPE,PHTYPE,P,HT,
     1                      T,DPD,DD,FF)


C     ------------------------------------------------------------------
C     INCLUDES AND COMMONS
C     ------------------------------------------------------------------
      INCLUDE 'IMPLICIT'
      INCLUDE 'MADISCON'
      INCLUDE 'STRCCOM'

C     ------------------------------------------------------------------
C     ARGUMENTS
C     ------------------------------------------------------------------
      INTEGER       ISTA
      INTEGER       FNUM
      INTEGER       NLEVELS
      INTEGER       LINDEX(*)
      INTEGER       LTYPE(*)
      INTEGER       PHTYPE(*)
      REAL          P(*),HT(*),T(*),DPD(*),DD(*),FF(*)

C     ------------------------------------------------------------------
C     LOCAL
C     ------------------------------------------------------------------
      INTEGER       I,J,K,NL,NI,NDEL,LAST(2),L
      LOGICAL       DEL(MXRAOBLEV_P)
      INTEGER       LILCL(MXRAOBLEV_P),LTLCL(MXRAOBLEV_P)
      INTEGER       PHLCL(MXRAOBLEV_P)
      REAL          PLCL(MXRAOBLEV_P),HTLCL(MXRAOBLEV_P)
      REAL          TLCL(MXRAOBLEV_P),DPDLCL(MXRAOBLEV_P)
      REAL          DDLCL(MXRAOBLEV_P),FFLCL(MXRAOBLEV_P)
      REAL          QCALCL(MXRAOBLEV_P,MXRAOBVAR_P)
      REAL          QCRLCL(MXRAOBLEV_P,MXRAOBVAR_P)
      REAL          QCDEPLCL(MXRAOBLEV_P,MXRAOBVAR_P)
      CHARACTER*1   QCDLCL(MXRAOBLEV_P,MXRAOBVAR_P)

C     *****************************************************************
C     ******************* BEGIN OF MREMRAOBLV *************************
C     *****************************************************************

      NDEL = 0
      DO 1 I = 1, NLEVELS
         DEL(I) = .FALSE.
 1    CONTINUE

C     ------------------------------------------------------------------
C     REMOVE LEVELS THAT ARE:
C
C     - MISSING HT & P (ALL COORDINATES)
C     - MISSING T, DPD, DD & FF (ALL NON-COORDINATE DATA)
C     - SIGW LEVEL WITH HT = 0
C     - SFC/MANDATORY LEVELS MISSING HT
C     ------------------------------------------------------------------
      DO 2 I = 1, NLEVELS

         IF(HT(I).EQ.MISS_P)THEN
            IF(P(I).EQ.MISS_P.OR.(LTYPE(I).EQ.SFC_RAOB_P.OR.LTYPE(I).EQ.
     1         MAN_RAOB_P))DEL(I) = .TRUE.
         ENDIF

         IF(T(I).EQ.MISS_P.AND.DPD(I).EQ.MISS_P.AND.DD(I).EQ.MISS_P.AND.
     1      FF(I).EQ.MISS_P)DEL(I) = .TRUE.

         IF(LTYPE(I).EQ.SIGW_RAOB_P.AND.HT(I).EQ.0)DEL(I) = .TRUE.

         IF(DEL(I))NDEL = NDEL + 1

 2    CONTINUE

C     ------------------------------------------------------------------
C     REMOVE SOME LEVELS WITH DUPLICATE PRESSURES:
C
C     - IF SFC/MAN & SIGT OR SIGW --> KEEP SFC/MAN
C     - IF TROP & SIGT            --> KEEP TROP
C     - IF SAME LEVEL TYPE        --> KEEP ONE WITH MOST VARIABLES
C
C     NOTE THAT MXWND & TROP ARE NOT DELETED.
C     ------------------------------------------------------------------

C     ------------------------------------------------------------------
C     FIND THE FIRST LEVEL THAT HAS P AND HASN'T BEEN DELETED.
C     ------------------------------------------------------------------
      DO 3 I = 1, NLEVELS
         IF(.NOT.DEL(I).AND.P(I).NE.MISS_P)GO TO 4
 3    CONTINUE
      GO TO 10

 4    LAST(1) = I
      J = LAST(1)
      LAST(2) = LAST(1)

      DO 5 I = J+1, NLEVELS

C     ------------------------------------------------------------------
C     COMPARE "LAST" LEVELS WITH THE "CURRENT" LEVEL.
C     ------------------------------------------------------------------
         IF(.NOT.DEL(I))THEN

            DO L = 1, 2

               IF(P(LAST(L)).EQ.P(I).AND.P(I).NE.MISS_P)THEN

                  IF((LTYPE(LAST(L)).EQ.SFC_RAOB_P.OR.
     1                LTYPE(LAST(L)).EQ.MAN_RAOB_P).AND.
     2               (LTYPE(I).EQ.SIGW_RAOB_P.OR.
     3                LTYPE(I).EQ.SIGT_RAOB_P))THEN

                     DEL(I) = .TRUE.

                  ELSE IF((LTYPE(I).EQ.SFC_RAOB_P.OR.
     1                     LTYPE(I).EQ.MAN_RAOB_P).AND.
     2                    (LTYPE(LAST(L)).EQ.SIGW_RAOB_P.OR.
     3                     LTYPE(LAST(L)).EQ.SIGT_RAOB_P))THEN

                     DEL(LAST(L)) = .TRUE.

                  ELSE IF(LTYPE(LAST(L)).EQ.TROP_RAOB_P.AND.
     1                    LTYPE(I).EQ.SIGT_RAOB_P)THEN

                     DEL(I) = .TRUE.

                  ELSE IF(LTYPE(I).EQ.TROP_RAOB_P.AND.
     1                    LTYPE(LAST(L)).EQ.SIGT_RAOB_P)THEN

                     DEL(LAST(L)) = .TRUE.

                  ELSE IF(LTYPE(I).EQ.LTYPE(LAST(L)))THEN

                     NI = 0
                     IF(P(I).NE.MISS_P)NI = NI + 1
                     IF(HT(I).NE.MISS_P)NI = NI + 1
                     IF(DPD(I).NE.MISS_P)NI = NI + 1
                     IF(DD(I).NE.MISS_P)NI = NI + 1
                     IF(FF(I).NE.MISS_P)NI = NI + 1
                     
                     NL = 0
                     IF(P(LAST(L)).NE.MISS_P)NL = NL + 1
                     IF(HT(LAST(L)).NE.MISS_P)NL = NL + 1
                     IF(DPD(LAST(L)).NE.MISS_P)NL = NL + 1
                     IF(DD(LAST(L)).NE.MISS_P)NL = NL + 1
                     IF(FF(LAST(L)).NE.MISS_P)NL = NL + 1
                     
                     IF(NI.GE.NL)THEN

                        DEL(LAST(L)) = .TRUE.

                     ELSE

                        DEL(I) = .TRUE.

                     ENDIF

                  ENDIF

                  IF(DEL(I).OR.DEL(LAST(L)))NDEL = NDEL + 1

               ENDIF

            ENDDO

C     ------------------------------------------------------------------
C     IF THE CURRENT LEVEL HASN'T BEEN DELETED AND IT HAS P, UPDATE
C     LAST POINTER.
C     ------------------------------------------------------------------
            IF(.NOT.DEL(I).AND.P(I).NE.MISS_P)THEN
               LAST(1) = LAST(2)
               LAST(2) = I
            ENDIF

         ENDIF

 5    CONTINUE

C     ------------------------------------------------------------------
C     IF ANY LEVELS ARE TO BE DELETED, DO SO NOW.
C     ------------------------------------------------------------------
 10   IF(NDEL.NE.0)THEN

         J = 0

         DO 20 I = 1, NLEVELS

            IF(.NOT.DEL(I))THEN

               J = J + 1
               LILCL(J) = LINDEX(I)
               LTLCL(J) = LTYPE(I)
               PHLCL(J) = PHTYPE(I)
               PLCL(J) = P(I)
               HTLCL(J) = HT(I)
               TLCL(J) = T(I)
               DPDLCL(J) = DPD(I)
               DDLCL(J) = DD(I)
               FFLCL(J) = FF(I)

               DO 21 K = 1, MXRAOBVAR_P

                  QCALCL(J,K) = RAOB_QCA(I,ISTA,K,FNUM)
                  QCRLCL(J,K) = RAOB_QCR(I,ISTA,K,FNUM)
                  QCDLCL(J,K) = RAOB_QCDD(I,ISTA,K,FNUM)
                  QCDEPLCL(J,K) = RAOB_QCDEP(I,ISTA,K,FNUM)

 21            CONTINUE

            ELSE IF(LTYPE(I).NE.SFC_RAOB_P)THEN

               RAOB_LT_COUNT(ISTA,LTYPE(I),FNUM) =
     1              RAOB_LT_COUNT(ISTA,LTYPE(I),FNUM) - 1

            ELSE

               RAOB_LT_COUNT(ISTA,MAN_RAOB_P,FNUM) =
     1              RAOB_LT_COUNT(ISTA,MAN_RAOB_P,FNUM) - 1

            ENDIF

 20      CONTINUE

         NLEVELS = J

         DO 30 I = 1, NLEVELS

            LINDEX(I) = LILCL(I)
            LTYPE(I) = LTLCL(I)
            PHTYPE(I) = PHLCL(I)
            P(I) = PLCL(I)
            HT(I) = HTLCL(I)
            T(I) = TLCL(I)
            DPD(I) = DPDLCL(I)
            DD(I) = DDLCL(I)
            FF(I) = FFLCL(I)

            DO 31 K = 1, MXRAOBVAR_P

               RAOB_QCA(I,ISTA,K,FNUM) = QCALCL(I,K)
               RAOB_QCR(I,ISTA,K,FNUM) = QCRLCL(I,K)
               RAOB_QCDD(I,ISTA,K,FNUM) = QCDLCL(I,K)
               RAOB_QCDEP(I,ISTA,K,FNUM) = QCDEPLCL(I,K)

 31         CONTINUE

 30      CONTINUE

      ENDIF

      RETURN
      END

C**---------------------------------------------------------------------
C**REQUIRED STANDARD FSL DISCLAIMER (NOVEMBER 2000)
C**---------------------------------------------------------------------
C**  OPEN SOURCE LICENSE/DISCLAIMER,  FORECAST SYSTEMS LABORATORY
C**  NOAA/OAR/FSL, 325 BROADWAY BOULDER, CO 80305
C**
C**  THIS SOFTWARE IS DISTRIBUTED UNDER THE OPEN SOURCE DEFINITION, 
C**  WHICH MAY BE FOUND AT http://www.opensource.org/osd.html.
C**
C**  IN PARTICULAR, REDISTRIBUTION AND USE IN SOURCE AND BINARY FORMS,
C**  WITH OR WITHOUT MODIFICATION, ARE PERMITTED PROVIDED THAT THE 
C**  FOLLOWING CONDITIONS ARE MET:
C**
C**  - REDISTRIBUTIONS OF SOURCE CODE MUST RETAIN THIS NOTICE, THIS LIST
C**    OF CONDITIONS AND THE FOLLOWING DISCLAIMER.
C**
C**  - REDISTRIBUTIONS IN BINARY FORM MUST PROVIDE ACCESS TO THIS 
C**    NOTICE, THIS LIST OF CONDITIONS AND THE FOLLOWING DISCLAIMER, AND
C**    THE UNDERLYING SOURCE CODE.
C**
C**  - ALL MODIFICATIONS TO THIS SOFTWARE MUST BE CLEARLY DOCUMENTED, 
C**    AND ARE SOLELY THE RESPONSIBILITY OF THE AGENT MAKING THE 
C**    MODIFICATIONS.
C**
C**  - IF SIGNIFICANT MODIFICATIONS OR ENHANCEMENTS ARE MADE TO THIS
C**    SOFTWARE, THE FSL SOFTWARE POLICY MANAGER 
C**    (softwaremgr.fsl@noaa.gov) BE NOTIFIED.
C**
C**  THIS SOFTWARE AND ITS DOCUMENTATION ARE IN THE PUBLIC DOMAIN AND 
C**  ARE FURNISHED "AS IS."  THE AUTHORS, THE UNITED STATES GOVERNMENT,
C**  ITS INSTRUMENTALITIES, OFFICERS, EMPLOYEES, AND AGENTS MAKE NO 
C**  WARRANTY, EXPRESS OR IMPLIED, AS TO THE USEFULNESS OF THE SOFTWARE
C**  AND DOCUMENTATION FOR ANY PURPOSE.  THEY ASSUME NO RESPONSIBILITY 
C**  (1) FOR THE USE OF THE SOFTWARE AND DOCUMENTATION; OR (2) TO 
C**  PROVIDE TECHNICAL SUPPORT TO USERS.
C**---------------------------------------------------------------------
