C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    W3RTOVSUNP
C   PRGMMR: DONG             ORG: NP22        DATE: 2020-01-09
C
C ABSTRACT: READS AND UNPACKS ONE REPORT FROM INPUT RTOVS RETRIEVAL
C   BUFR (DUMP) FILE INTO SPECIFIED FORMAT. RETURNS INFORMATION IN THE
C   FORMAT DESCRIBED BELOW.  INCLUDES SOUNDING DATA ON 40 LEVELS AND
C   RTOVS RADIANCES FROM 32 CHANNELS (20 HIRS, 4 MSU, 3 SSU, AND 5
C   AVHRR CHANNELS).  ALSO, INFORMATION ABOUT THE INPUT DATA SET
C   ITSELF (NAME, CENTER DATE, DUMP TIME) IS RETURNED.
C
C PROGRAM HISTORY LOG:
C 1997-11-21  BERT B. KATZ/GSC -- ORIGINAL AUTHOR
C 1998-05-05  D.A. KEYSER/NP22 -- STREAMLINED, CORRECTED ERRORS
C 1998-06-15  D.A. KEYSER/NP22 -- MODIFIED TO READ IN LONGITUDE
C     (MNEMONIC "CLON") CORRECTLY WHETHER STORED IN DEG. E, OR IN
C     DEG. W (-) AND DEG. E (+)
C 1998-09-21  D.A. KEYSER/NP22 -- SUBROUTINE NOW Y2K AND FORTRAN 90
C      COMPLIANT
C 1999-01-20 D. A. KEYSER -- INCORPORATED BOB KISTLER'S CHANGES NEEDED
C      TO PORT THE CODE TO THE IBM SP
C 1999-11-02 D. A. KEYSER -- SATELLITE IDENTIFICATION RETURNED IN
C      ISATOB(1) IS NOW BUFR CODE TABLE VALUE; CHANGES TO MAKE CODE
C      MORE PORTABLE; SUBROUTINE RENAMED
C 2000-02-17 D. A. KEYSER -- IF DATE OF INPUT FILE IS PRIOR TO
C      7/1/1998, THEN DOES NOT USE "TOFF" TO GET FILTER FLAG (NOT
C      VALID AT THIS TIME), RATHER SETS OUTPUT FILTER FLAG TO "-99"
C      WHICH ALERTS CALLING PROGRAM TO PROCESS ONLY EVERY 4'TH
C      RETRIEVAL TO SIMULATE 250KM SAMPLING (NEEDED FOR HISTORICAL
C      CDAS RUNS)
C 2012-11-30 J. WOOLLEN   -- INITIAL PORT TO WCOSS; RESET BMISS TO A
C      VALUE (10E08) WHICH WILL NOT CAUSE INTEGER OVERFLOW WHICH CAN BE
C      UNPREDICTABLE (PRIOR BMISS VALUE WAS 10E10)
C 2013-02-14 D. A. KEYSER -- FINAL CHANGES TO RUN ON WCOSS;  OBTAIN
C      VALUE OF BMISS SET IN CALLING PROGRAM VIA CALL TO BUFRLIB
C      ROUTINE GETBMISS RATHER THAN HARDWIRING IT TO 10E08 (OR 10E10);
C      USE BUFRLIB FUNCTION IBFMS TO DETERMINE IF A VARIABLE READ FROM
C      BUFR FILE IS MISSING (I.E. RETURNED AS BMISS);  USE FORMATTED
C      PRINT STATEMENTS WHERE PREVIOUSLY UNFORMATTED PRINT WAS USED
C      (WCOSS SPLITS UNFORMATTED PRINT AT 80 CHARACTERS)
C 2020-01-09  J. Dong -- In subroutine W3RTOVSUNP, changed the windowing
C      decade from 20 to 40 for cases when the year is represented by
C      2 digits instead of 4.
C
C USAGE:    CALL W3RTOVSUNP(IUNIT,IBDATE,PP,TT,QQ,CLAL,CLAM,NLEV,
C                           IRTCHN,RTRAD,NCHN,STNID,ISATOB,RSATOB,
C                           DSNAME,IDSDAT,IDSDMP_8,IERR)
C   INPUT ARGUMENT LIST:
C     IUNIT    - UNIT NUMBER OF INPUT FILE CONTAINING RETRIEVAL DATA
C              - IN BUFR FORMAT.
C
C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
C     IBDATE   - DATE IN SECTION 1 OF BUFR MESSAGE CONTAINING THIS
C              - RETRIEVAL (IN FORM YYYYMMDDHH)
C     PP       - PRESSURE IN MB AT RETRIEVAL LEVELS (MUST BE
C              - DIMENSIONED TO AT LEAST 40 WORDS BY CALLING PROGRAM
C              - - ONLY 40 WORDS WILL BE FILLED HERE)
C     TT       - VIRTUAL TEMPERATURE IN DEG. K AT RETRIEVAL LEVELS
C              - (MUST BE DIMENSIONED TO AT LEAST 40 WORDS BY CALLING
C              - PROGRAM - ONLY 40 WORDS WILL BE FILLED HERE)
C     QQ       - SPECIFIC HUMIDITY IN G/G AT RETRIEVAL LEVELS (MUST
C              - BE DIMENSIONED TO AT LEAST 40 WORDS BY CALLING
C              - PROGRAM - ONLY 40 WORDS WILL BE FILLED HERE)
C     CLAL     - CLOUD TOP ALBEDO IN PERCENT AT RETRIEVAL LEVELS (MUST
C              - BE DIMENSIONED TO AT LEAST 40 WORDS BY CALLING
C              - PROGRAM - ONLY 40 WORDS WILL BE FILLED HERE)
C     CLAM     - CLOUD AMOUNT AT RETRIEVAL LEVELS (C.T. 0-20-011)
C              - (MUST BE DIMENSIONED TO AT LEAST 40 WORDS BY CALLING
C              - PROGRAM - ONLY 40 WORDS WILL BE FILLED HERE)
C     NLEV     - NUMBER OF RETRIEVAL LEVELS (SHOULD ALWAYS BE 40)
C     IRTCHN   - RTOVS RADIANCE CHANNELS (NUMERIC) (MUST BE
C              - DIMENSIONED TO AT LEAST 32 WORDS BY CALLING PROGRAM -
C              - ONLY 32 WORDS WILL BE FILLED HERE)
C     RTRAD    - RTOVS RADIANCES IN DEG. K (MUST BE DIMENSIONED TO AT
C              - LEAST 32 WORDS BY CALLING PROGRAM - ONLY 32 WORDS
C              - WILL BE FILLED HERE)
C     NCHN     - NUMBER OF RADIANCE CHANNELS (SHOULD ALWAYS BE 32)
C     STNID    - STATION ID (CHAR*8)
C     ISATOB   - 11-WORD INTEGER ARRAY CONTAINING RETURNED DATA
C              - (SEE REMARKS FOR CONTENTS)
C     RSATOB   - 17-WORD REAL ARRAY CONTAINING RETURNED DATA
C              - (SEE REMARKS FOR CONTENTS)
C     DSNAME   - CHARACTER*8 DATA SET NAME (SAME FOR ALL REPORTS IN
C              - A COMMON INPUT DATA SET - SEE REMARKS FOR IERR=1)
C     IDSDAT   - INTEGER DATA SET CENTER DATE IN FORM YYYYMMDDHH (SAME
C              - FOR ALL REPORTS IN A COMMON input data set - see
C              - REMARKS FOR IERR=1)
C     IDSDMP_8 - INTEGER*8 DATA SET DUMP TIME IN FORM YYYYMMDDHHMM
C              - (SAME FOR ALL REPORTS IN A COMMON INPUT DATA SET - SEE
C              - REMARKS FOR IERR=1)
C     IERR     - ERROR RETURN CODE
C                 =  0 OBSERVATION READ AND UNPACKED INTO OUTPUT
C                        ARGUMENT LOCATIONS (SEE ABOVE).  SEE REMARKS
C                        FOR CONTENTS. NEXT CALL TO W3RTOVSUNP WILL
C                        RETURN NEXT OBSERVATION IN DATA SET.
C                 =  1 INFORMATION ABOUT THE BUFR DATASET IS RETURNED
C                        IN THE OUTPUT ARGUMENTS DSNAME, IDSDAT,
C                        IDSDMP_8 (SEE OUTPUT ARGUMENT LIST ABOVE)
C
C                        THIS SHOULD ALWAYS OCCUR AFTER THE FIRST CALL
C                        TO THIS SUBROUTINE.  NO REPORT IS UNPACKED AT
C                        THIS POINT, AND ONLY DSNAME, IDSDAT, AND
C                        IDSDMP_8 CONTAIN INFORMATION.  ALL SUBSEQUENT
C                        CALLS TO W3RTOVSUNP SHOULD RETURN THE
C                        OBSERVATIONS IN THIS DATA SET, SEQUENTIALLY,
C                        (IERR=0) UNTIL THE END OF FILE IS ENCOUNTERED
C                        (IERR=2).  THE VALUES STORED IN DSNAME,
C                        IDSDAT, AND IDSDMP_8 WILL CONTINUE TO BE
C                        RETURNED ALONG WITH EACH REPORT WHEN IERR = 0.
C                 =  2 FOR NORMAL END-OF-FILE ENCOUNTERED.
C                 = -1 FOR END-OF-FILE ON FIRST READ -- EMPTY FILE
C                 = -2 FOR INPUT BUFR FILE NOT Y2K COMPLIANT -- NO
C                        PROCESSING DONE
C                 = -3 CENTER DATE COULD NOT BE OBTAINED FROM INPUT
C                        FILE -- NO PROCESSING DONE
C
C   INPUT FILES:
C     UNIT "IUNIT" - FILE CONTAINING BUFR RTOVS DATA
C
C   OUTPUT FILES:
C     UNIT 06 - STANDARD OUTPUT PRINT
C
C   SUBPROGRAMS CALLED:
C     LIBRARY:
C       W3NCO       - W3DIFDAT
C       BUFRLIB     - DATELEN  DUMPBF   OPENBF   READMG   READSB
C                   - UFBINT   CLOSBF   GETBMISS IBFMS
C
C
C REMARKS:
C
C     CONTENTS OF OUTPUT ARGUMENT ISATOB (11 INTEGER WORDS) FOR EACH
C      RETRIEVAL:
C        WORD  1 - SATELLITE IDENTIFIER
C                                      (BUFR C.T. 0-01-007)
C        WORD  2 - PREPBUFR REPORT TYPE
C                     (=161 FOR CLEAR PATH OVER LAND)
C                     (=163 FOR CLOUDY PATH OVER LAND)
C                     (=171 FOR CLEAR PATH OVER OCEAN)
C                     (=173 FOR CLOUDY PATH OVER OCEAN)
C                     {NOTE: R. TYPE 162 (NSTAR PATH OVER LAND) AND
C                            R. TYPE 172 (NSTAR PATH OVER OCEAN)
C                            ARE NOT VALID FOR RTOVS}
C        WORD  3 - SWATH LOCATION :  1 INDICATES LEFT  LIMB OF SWATH
C                                   56 INDICATES RIGHT LIMB OF SWATH
C                           USED FOR DETERMINING DISTANCE FROM NADIR
C        WORD  4 - ORBIT NUMBER
C        WORD  5 - NESDIS LAND-SEA FLAG
C        WORD  6 - SATELLITE DATA PROCESSING TECHNIQUE
C                     (=12 FOR CLOUDY PATH)
C                     (=36 FOR CLEAR PATH)
C                     (= 4 FOR UNKNOWN PATH????)
C        WORD  7 - ROVS FILTER FLAG (=  0 FOR GOOD)
C                                   (=  1 FOR REDUNDANT)
C                                   (=-99 FOR PRIOR TO 07/01/1998)
C                   IMPORTANT: REDUNDANT RETRIEVALS ARE AT FULL 80 KM
C                              RESOLUTION; GOOD RETRIEVALS ARE AT
C                              250 KM RESOLUTION
C        WORD  8 - SUPERADIABATIC FLAG (=0 FOR NOT SUPERADIABATIC)
C                                      (.NE. 0 FOR SUPERADIABATIC)
C        WORD  9 - DAY/NIGHT QUALIFIER (=0 FOR NIGHT)
C                                      (=1 FOR DAY)
C        WORD 10 - VERTICAL SIGNIFICANCE (SAT OBSERVATION)
C                                      (BUFR C.T. 0-08-003)
C        WORD 11 - SNOW/ICE FLAGS (TERRAIN TYPE)
C                                      (BUFR C.T. 0-13-039)
C
C     CONTENTS OF OUTPUT ARGUMENT RSATOB (17 REAL WORDS) FOR EACH
C      RETRIEVAL:
C        WORD  1 - OBSERVATION TIME IN HOURS GOOD TO 0.01 HOUR.
C        WORD  2 - LATITUDE IN DEGREES (N+,S-)
C        WORD  3 - LONGITUDE IN DEGREES EAST (0.0 to 359.99)
C        WORD  4 - SURFACE HEIGHT IN METERS
C        WORD  5 - FIRST ABOVE-GROUND RTOVS PRESSURE LEVEL IN MB
C        WORD  6 - SKIN TEMPERATURE IN DEGREES K
C        WORD  7 - TOTAL PRECIPITABLE WATER IN MM
C        WORD  8 - TOTAL OZONE IN DOBSONS
C        WORD  9 - SEA SURFACE TEMPERATURE IN DEGREES K
C        WORD 10 - CLOUD-TOP PRESSURE IN MB
C        WORD 11 - SOLAR ZENITH ANGLE IN DEGREES
C        WORD 12 - SATELLITE ELEVATION IN DEGREES
C        WORD 13 - NESDIS AVERAGE NSTAR (CLOUDINESS PARAMETER)
C                   (NOTE: THIS IS NOT OF ANY USE SINCE NSTAR
C                         PATH NOT VALID FOR RTOVS
C                         = -1 FOR CLOUDY PATH
C                         = MISSING FOR CLEAR PATH)
C        WORD 14 - HIRS CHANNEL UTILIZATION FLAGS
C        WORD 15 - MSU CHANNEL UTILIZATION FLAGS
C        WORD 16 - SSU CHANNEL UTILIZATION FLAGS
C        WORD 17 - AVHRR CHANNEL UTILIZATION FLAGS
C
C FOR ALL DATA: MISSING VALUES ARE RETURNED AS XMISS (99999.) (REAL) OR
C               IMISS (99999) (INTEGER)
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  NCEP WCOSS
C
C$$$
      SUBROUTINE W3RTOVSUNP(IUNIT,IBDATE,PP,TT,QQ,CLAL,CLAM,NLEV,
     $                      IRTCHN,RTRAD,NCHN,STNID,ISATOB,RSATOB,
     $                      DSNAME,IDSDAT,IDSDMP_8,IERR)
 
      DATA IFIRST/0/,KOUNTR/0/,ITOFF/0/

      REAL  PP(*),TT(*),QQ(*),CLAL(*),CLAM(*),RTRAD(*),RINC(5)

      INTEGER  IRTCHN(*),JDATE(5),JDUMP(5),NF(0:3),KDATE(8),LDATE(8)

      INTEGER(8) IDSDMP_8,JDUMP_8(5)

      CHARACTER*8 SUBSET,DSNAME

      CHARACTER*50 IDTSTR
      DATA IDTSTR/'SAID CLAT CLON TOFF HOUR MINU SECO FOVN ORBN SADF '/
      CHARACTER*5 IDTST2
      DATA IDTST2/'DNQL '/

      CHARACTER*50 INFSTR
      DATA INFSTR/'SOEL ELEV NSAV OZON SDPT HIRC MSUC SSUC AVHC TPWT '/
      CHARACTER*10 INFST1
      DATA INFST1/'CDTP VSAT '/

      CHARACTER*30 SRFSTR
      DATA SRFSTR/'PRES SELV LSQL TMSK SST1 TERR '/

      CHARACTER*25 RETSTR
      DATA RETSTR/'PRLC TMDB MIXR CLAL CLAM '/

      CHARACTER*10 BRTSTR
      DATA BRTSTR/'CHNM TMBR '/

      REAL(8) XIDENT_8(11),XINFO_8(12),SRFDAT_8(6),RETDAT_8(5,40),
     $        BRTDAT_8(2,32),AMAXIMUM_8
      REAL(8) BMISS,GETBMISS

      DIMENSION  KOUNT(0:3,0:3),ISATOB(11),RSATOB(17)
      DATA  KOUNT/16*0/,XMISS/99999./,IMISS/99999/,NF/31,13,35,17/

      CHARACTER*8   STNID

      CHARACTER*1   NMCHAR(0:35)

      SAVE

      DATA          NMCHAR/'0','1','2','3','4','5','6','7','8','9',
     $                     'A','B','C','D','E','F','G','H','I','J',
     $                     'K','L','M','N','O','P','Q','R','S','T',
     $                     'U','V','W','X','Y','Z'/

      IF(IFIRST.EQ.0) THEN

C  FIRST TIME IN, SET DATELEN, GET CENTER AND DUMP TIME FOR FILE, TEST
C   FOR CENTER FILE DATE PRIOR TO 07/01/1998, AND GET VALUE FOR "BMISS"
C  --------------------------------------------------------------------

         PRINT'("  ==> W3RTOVSUNP -- WCOSS VERSION 01-09-2020")'
         IFIRST = 1
         CALL DATELEN(10)
         CALL DUMPBF(IUNIT,JDATE,JDUMP)
cppppp
         print'("  -- CENTER DATE (JDATE) = ",5(I0,1X))', jdate
         print'("  -- DUMP DATE   (JDUMP) = ",5(I0,1X))', jdump
         print'(1X)'
cppppp
         IF(JDATE(1).LE.0)  then
            PRINT'(" ##W3RTOVSUNP - CENTER DATE COULD NOT BE OBTAINED ",
     $       "FROM INPUT FILE ON UNIT ",I0," -- IERR = -3")', IUNIT
            RETURN
         END IF
         IF(JDATE(1).LT.100)  THEN

C IF 2-DIGIT YEAR RETURNED IN JDATE(1), MUST USE "WINDOWING" TECHNIQUE
C  TO CREATE A 4-DIGIT YEAR

C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS
C            CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT
C            Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE)

            PRINT'(" ##W3RTOVSUNP - THE FOLLOWING SHOULD NEVER ",
     $       "HAPPEN!!!!!")'
            PRINT'(" ##W3RTOVSUNP - 2-DIGIT YEAR IN JDATE(1) RETURNED ",
     $       "FROM DUMPBF (JDATE IS: ",I5,4I3") - USE WINDOWING ",
     $       "TECHNIQUE TO OBTAIN 4-DIGIT YEAR")', JDATE
C IF JDATE=41~99 THEN JDATE=1941~1999
C IF JDATE=00~40 THEN JDATE=2000~2040
            IF(JDATE(1).GT.40)  THEN
               JDATE(1) = 1900 + JDATE(1)
            ELSE
               JDATE(1) = 2000 + JDATE(1)
            ENDIF
            PRINT'(" ##W3RTOVSUNP - CORRECTED JDATE(1) WITH 4-DIGIT ",
     $       "YEAR, JDATE NOW IS: ",I5,4I3)', JDATE
         ENDIF
         IDSDAT = JDATE(1)*1000000+JDATE(2)*10000+JDATE(3)*100+JDATE(4)
         IF(JDUMP(1).LE.0)  THEN
            IDSDMP_8 = 999999999999_8
         ELSE
            IF(JDUMP(1).LT.100)  THEN

C IF 2-DIGIT YEAR RETURNED IN JDUMP(1), MUST USE "WINDOWING" TECHNIQUE
C  TO CREATE A 4-DIGIT YEAR

C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS
C            CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT
C            Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE)

               PRINT'(" ##W3RTOVSUNP - THE FOLLOWING SHOULD NEVER ",
     $          "HAPPEN!!!!!")'
               PRINT'(" ##W3RTOVSUNP - 2-DIGIT YEAR IN JDUMP(1) ",
     $          "RETURNED FROM DUMPBF (JDUMP IS: ",I5,4I3") - USE ",
     $          "WINDOWING TECHNIQUE TO OBTAIN 4-DIGIT YEAR")', JDUMP
C IF JDUMP=41~99 THEN JDUMP=1941~1999
C IF JDUMP=00~40 THEN JDUMP=2000~2040
               IF(JDUMP(1).GT.40)  THEN
                  JDUMP(1) = 1900 + JDUMP(1)
               ELSE
                  JDUMP(1) = 2000 + JDUMP(1)
               ENDIF
               PRINT'(" ##W3RTOVSUNP - CORRECTED JDUMP(1) WITH 4-DIGIT",
     $          " YEAR, JDUMP NOW IS: ",I5,4I3)', JDUMP
            END IF
            JDUMP_8 = JDUMP
            IDSDMP_8 = JDUMP_8(1)*100000000+JDUMP_8(2)*1000000+
     $       JDUMP_8(3)*10000+JDUMP_8(4)*100+JDUMP_8(5)
         ENDIF
c-----------------------------------------------------------------------
c This logic is needed only because SUBSET is not returned in DUMPBF
c  and we need it in order to return dsname - after dsname is retrieved
c  close data set ..
         call openbf(iunit,'IN',iunit)
         call readmg(iunit,subset,ibdate,iret)
         if(subset.eq.'NC003102')  then
            dsname = 'RTOVS   '
         else
            dsname = '????????'
         end if
         call closbf(iunit)
c-----------------------------------------------------------------------
         KDATE(1:3) = JDATE(1:3)
         KDATE(4)   = 0
         KDATE(5:6) = JDATE(4:5)
         KDATE(7:8) = 0
         LDATE(1)   = 1998
         LDATE(2)   = 07
         LDATE(3)   = 01
         LDATE(4:8) = 0
         CALL W3DIFDAT(KDATE,LDATE,1,RINC)
         IF(RINC(1).LT.0.0)  THEN
            WRITE(6,3004)
 3004       FORMAT(/'##W3RTOVSUNP - DATE OF INPUT FILE IS PRIOR TO ',
     $       '07/01/1998 - VALUE IN "TOFF" NOT RELATED TO FILTER FLAG ',
     $       'SO SET'/15X,'OUTPUT FILTER FLAG TO -99 FOR ALL REPORTS'/)
            ITOFF = 1
         END IF
c-----------------------------------------------------------------------

C  GET VALUE FOR "BMISS"
C  --------------------

         BMISS = GETBMISS()
         print'(1X)'
         print'(" BUFRLIB value for missing passed into W3RTOVSUNP is:",
     $    1X,G0)', bmiss
         print'(1X)'
c-----------------------------------------------------------------------

         IERR = 1
         RETURN
      ELSE  IF(IFIRST.EQ.1) THEN

C  SECOND TIME IN, OPEN BUFR DATASET FOR INPUT AND DECODE FIRST MESSAGE
C  --------------------------------------------------------------------

         IFIRST = 2
         CALL OPENBF(IUNIT,'IN',IUNIT)
         CALL READMG(IUNIT,SUBSET,IBDATE,IRET)
         IF(IRET.NE.0) THEN
            WRITE(6,1009) IUNIT
 1009       FORMAT('##W3RTOVSUNP ERROR: EMPTY FILE IN UNIT ',I5)
            IERR = -1
            RETURN
         ENDIF
         IF(IBDATE.LT.100000000)  THEN
C IF INPUT BUFR FILE DOES NOT RETURN MESSAGES WITH A 4-DIGIT YEAR,
C  SOMETHING IS WRONG (EVEN NON-COMPLIANT BUFR MESSAGES SHOULD
C  CONSTRUCT A 4-DIGIT YEAR AS LONG AS DATELEN(10) HAS BEEN CALLED
            WRITE(6,1209) IUNIT
 1209       FORMAT('##W3RTOVSUNP ERROR: A 10-DIGIT SECT. 1 BUFR ',
     $       'MESSAGE DATE WAS NOT RETURNED IN UNIT',I5,' - PROBLEM ',
     $       'WITH BUFR FILE')
            IERR = -2
            RETURN
         END IF
      ENDIF

 1000 CONTINUE                                                          

C  EACH CALL TO READSB INCREASES "KOUNTR" BY 1 (REGARDLESS OF RESULT)
C  ------------------------------------------------------------------

      KOUNTR = KOUNTR + 1

      CALL READSB(IUNIT,IRET)
      IF(IRET.NE.0) THEN
        CALL READMG(IUNIT,SUBSET,IBDATE,IRET)
        IF(IRET.NE.0) THEN

C  ALL BUFR MESSAGES HAVE BEEN READ AND DECODED -- ALL DONE
C  --------------------------------------------------------

           WRITE(6,1001) IUNIT
 1001 FORMAT(//' ==> W3RTOVSUNP: END OF FILE ON UNIT',I3,' -- ALL DONE'
     $ /)
           IERR = 2
           RETURN
        ENDIF
         IF(IBDATE.LT.100000000)  THEN
C IF INPUT BUFR FILE DOES NOT RETURN MESSAGES WITH A 4-DIGIT YEAR,
C  SOMETHING IS WRONG (EVEN NON-COMPLIANT BUFR MESSAGES SHOULD
c  CONSTRUCT A 4-DIGIT YEAR AS LONG AS DATELEN(10) HAS BEEN CALLED
            WRITE(6,1209) IUNIT
            IERR = -2
            RETURN
         END IF
        GO TO 1000
      ENDIF

      XIDENT_8 = BMISS
      CALL UFBINT(IUNIT,XIDENT_8,11, 1,IRET,IDTSTR//IDTST2)

      XINFO_8 = BMISS
      CALL UFBINT(IUNIT,XINFO_8 ,12, 1,IRET,INFSTR//INFST1)

      SRFDAT_8 = BMISS
      CALL UFBINT(IUNIT,SRFDAT_8, 6, 1,IRET,SRFSTR)

      RETDAT_8 = BMISS
      CALL UFBINT(IUNIT,RETDAT_8, 5,40,NLEV,RETSTR)

      BRTDAT_8 = BMISS
      CALL UFBINT(IUNIT,BRTDAT_8, 2,32,NCHN,BRTSTR)

      ISATOB = IMISS
      RSATOB = XMISS
      PP(1:40) = XMISS
      TT(1:40) = XMISS
      QQ(1:40) = XMISS
      CLAL(1:40) = XMISS
      CLAM(1:40) = XMISS
      IRTCHN(1:32) = IMISS
      RTRAD(1:32) = XMISS

C  SATELLITE IDENTIFIER
C  --------------------

      IF(IBFMS(XIDENT_8(1)).EQ.0)  THEN
         ISATOB(1) = NINT(XIDENT_8(1))
         IF(ISATOB(1).LT.200.OR.ISATOB(1).GT.209) THEN
            WRITE(6,2071) KOUNTR,ISATOB(1)
 2071 FORMAT(/'##W3RTOVSUNP WARNING: A DECODED RETRIEVAL (#',I5,') HAS',
     $ ' AN UNRECOGNIZED SATELLITE ID (=',I5,') - SKIP IT')
            GO TO 1000
         ENDIF
      ELSE
         WRITE(6,2072) KOUNTR
 2072 FORMAT(/'##W3RTOVSUNP WARNING: A DECODED RETRIEVAL (#',I5,') HAS',
     $ ' A MISSING SATELLITE ID - SKIP IT')
         GO TO 1000
      ENDIF

C  LATITUDE
C  --------

      IF(IBFMS(XIDENT_8(2)).EQ.0)  THEN
         RSATOB(2) = XIDENT_8(2)
      ELSE
         WRITE(6,2073) KOUNTR
 2073 FORMAT(/'##W3RTOVSUNP WARNING: A DECODED RETRIEVAL (#',I5,') HAS',
     $ ' A MISSING LATITUDE - SKIP IT')
         GO TO 1000
      ENDIF

C  LONGITUDE
C  ---------

      IF(IBFMS(XIDENT_8(3)).EQ.0)  THEN

C Important: According to BUFR Manual, CLON (0-06-002) - represented
C  here by "XIDENT_8(3)" - should be in units of Degrees West - and
C  East + (-180.0 to +180.0); however some BUFR data sets (e.g.,
C  PREPBUFR) are known to encode 0-06-002 in units of Degrees East
C  (0.0 to 359.99)
C  -- So we use the following conversion to work in either case ...
         RSATOB(3) = 360._8 - MOD(360._8-XIDENT_8(3),360._8)
         IF(RSATOB(3).EQ.360.0)  RSATOB(3) = 0.0
      ELSE
         WRITE(6,2074) KOUNTR
 2074 FORMAT(/'##W3RTOVSUNP WARNING: A DECODED RETRIEVAL (#',I5,') HAS',
     $ ' A MISSING LONGITUDE - SKIP IT')
         GO TO 1000
      ENDIF

C  FILTER FLAG
C  -----------
c  If date of input file is prior to 7/1/1998, then "TOFF" does not
c   indicate filter flag, set filter flag to "-99" (alerts calling
c   program to process only every 4'th retrieval to simulate 250km
c   sampling - needed for historical cdas runs)

      IF(IBFMS(XIDENT_8(4)).EQ.0)  THEN
         IF(ITOFF.EQ.0)  THEN
            ISATOB(7) = NINT(XIDENT_8(4))
         ELSE
            ISATOB(7) = -99
         END IF
      ELSE
         WRITE(6,2075) KOUNTR
 2075 FORMAT(/'##W3RTOVSUNP WARNING: A DECODED RETRIEVAL (#',I5,') HAS',
     $ ' A MISSING FILTER FLAG - SKIP IT')
         GO TO 1000
       ENDIF

C  OBSERVATION TIME
C  ----------------

      AMAXIMUM_8 = MAX(XIDENT_8(5),XIDENT_8(6),XIDENT_8(7))
      IF(IBFMS(AMAXIMUM_8).EQ.0) THEN
         HRFRAC = (60.0 * XIDENT_8(6) + XIDENT_8(7)) / 3600.0
         RSATOB(1) = XIDENT_8(5) + HRFRAC
         RSATOB(1) = 0.01 * AINT(100.0 * RSATOB(1) + 0.5)
      ELSE
         WRITE(6,2076) KOUNTR
 2076 FORMAT(/'##W3RTOVSUNP WARNING: A DECODED RETRIEVAL (#',I5,') HAS',
     $ ' ONE OR MORE MISSING TIME UNITS - SKIP IT')
         GO TO 1000
      ENDIF

C  SWATH LOCATION
C  --------------

      IF(IBFMS(XIDENT_8(8)).EQ.0)  THEN
         ISATOB(3) = NINT(XIDENT_8(8))
      ELSE
         WRITE(6,2077) KOUNTR
 2077 FORMAT(/'##W3RTOVSUNP WARNING: A DECODED RETRIEVAL (#',I5,') HAS',
     $ ' A MISSING SWATH LOCATION - SKIP IT')
         GO TO 1000
      ENDIF

C  ORBIT NUMBER
C  ------------

      IF(IBFMS(XIDENT_8(9)).EQ.0)  ISATOB(4) = NINT(XIDENT_8(9))

C  SUPERADIABATIC FLAG
C  -------------------

      IF(IBFMS(XIDENT_8(10)).EQ.0)  ISATOB(8) = NINT(XIDENT_8(10))
      IF(ISATOB(8).NE.0)  THEN
         WRITE(6,2078) KOUNTR,ISATOB(8)
 2078 FORMAT(/'##W3RTOVSUNP WARNING: A DECODED RETRIEVAL (#',I5,') IS ',
     $ 'SUPERADIABATIC (FLAG=',I5,') - SKIP IT')
         GO TO 1000
      ENDIF

C  DAY-NIGHT INDICATOR
C  -------------------

      IF(IBFMS(XIDENT_8(11)).EQ.0)  ISATOB(9) = NINT(XIDENT_8(11))

C  SOLAR ZENITH ANGLE
C  ------------------

      IF(IBFMS(XINFO_8(1)).EQ.0)  RSATOB(11) = XINFO_8(1)

C  SOLAR ELEVATION
C  ---------------

      IF(IBFMS(XINFO_8(2)).EQ.0)  RSATOB(12) = XINFO_8(2)

C  AVERAGE NSTAR VALUE
C  -------------------

      IF(IBFMS(XINFO_8(3)).EQ.0)  RSATOB(13) = XINFO_8(3)

C  OZONE
C  -----

      IF(IBFMS(XINFO_8(4)).EQ.0)  RSATOB(8) = XINFO_8(4)

C  SATELLITE DATA PROCESSING TECHNIQUE
C  -----------------------------------

      IF(IBFMS(XINFO_8(5)).EQ.0)  THEN
         ISATOB(6) = NINT(XINFO_8(5))
      ELSE
         WRITE(6,2079) KOUNTR
 2079 FORMAT(/'##W3RTOVSUNP WARNING: A DECODED RETRIEVAL (#',I5,') HAS',
     $ ' A MISSING SATELLITE DATA PROCESSING TECHNIQUE - SKIP IT')
         GO TO 1000
      ENDIF

C  HIRS CHANNEL UTILIZATION FLAGS
C  ------------------------------

      IF(IBFMS(XINFO_8(6)).EQ.0)  RSATOB(14) = XINFO_8(6)

C  MSU CHANNEL UTILIZATION FLAGS
C  ------------------------------

      IF(IBFMS(XINFO_8(7)).EQ.0)  RSATOB(15) = XINFO_8(7)

C  SSU CHANNEL UTILIZATION FLAGS
C  -----------------------------

      IF(IBFMS(XINFO_8(8)).EQ.0)  RSATOB(16) = XINFO_8(8)

C  AVHRR CHANNEL UTILIZATION FLAGS
C  -------------------------------

      IF(IBFMS(XINFO_8(9)).EQ.0)  RSATOB(17) = XINFO_8(9)

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

      IF(IBFMS(XINFO_8(10)).EQ.0)  RSATOB(7) = XINFO_8(10) * 10.

C  CLOUD-TOP PRESSURE
C  ------------------

      IF(IBFMS(XINFO_8(11)).EQ.0)  RSATOB(10) = XINFO_8(11) * 0.01

C  VERTICAL SIGNIFICANCE INDICATOR (SATELLITE SOUNDINGS)
C  -----------------------------------------------------

      IF(IBFMS(XINFO_8(12)).EQ.0)  ISATOB(10) = NINT(XINFO_8(12))

C  STATION ID
C  ----------

      STNID = '      R '
      MODSAT = MOD(ISATOB(1),4)
      INST = IMISS
      IF(ISATOB(6).GE.32) THEN

C  CLEAR PATH
C  ----------

         INST = 1
         STNID(8:8) = NMCHAR(NF(MODSAT)-3)
      ELSE IF(ISATOB(6).GE.16) THEN

C  NSTAR PATH ===> NOT VALID FOR RTOVS!!!! - SHOULD NEVER SEE THIS
C  ---------------------------------------------------------------

         INST = 2
         STNID(8:8) = NMCHAR(NF(MODSAT)-2)
      ELSE IF(ISATOB(6).GE.8) THEN

C  CLOUDY PATH
C  -----------

         INST = 3
         STNID(8:8) = NMCHAR(NF(MODSAT)-1)
      ELSE

C  UNKNOWN PATH
C  ------------

         INST = 0
         STNID(8:8) = NMCHAR(NF(MODSAT))
         WRITE(6,2080) KOUNTR,STNID,ISATOB(6)
 2080 FORMAT(/'##W3RTOVSUNP WARNING: A DECODED RETRIEVAL (#',I5,',ID=',
     $ A8,') HAS AN UNKNOWN SATELLITE DATA PROCESSING TECH. (=',I5,
     $ ') - SKIP IT')
         GO TO 1000
      ENDIF

      KOUNT(INST,MODSAT) = MIN(99999,KOUNT(INST,MODSAT) + 1)
      WRITE(STNID(2:6),'(I5.5)') KOUNT(INST,MODSAT)

      NADIR = INT(ABS(FLOAT(ISATOB(3)) - 28.5)) / 3
      IF(NADIR.LT.9) NADIR = NADIR + 1
      IF(NADIR.GT.0.AND.NADIR.LT.10)  THEN
         STNID(1:1) = NMCHAR(NADIR)
      ELSE
         WRITE(6,2081) KOUNTR,STNID,NADIR
 2081 FORMAT(/'##W3RTOVSUNP WARNING: A DECODED RETRIEVAL (#',I5,',ID=',
     $ A8,') HAS AN INVALID NADIR PROX. IND. (=',I5,') - SKIP IT')
         GO TO 1000
      ENDIF

      IF(NLEV.EQ.40)  THEN

C  FILL IN THE LEVEL SOUNDING DATA - MUST HAVE 40 TEMP LEVELS TO ACCEPT
C  --------------------------------------------------------------------

         DO L = 1,NLEV
            LREV = NLEV + 1 - L
            PP(LREV) = RETDAT_8(1,L) * 0.01
            IF(IBFMS(RETDAT_8(2,L)).EQ.0) THEN
               IF(IBFMS(RETDAT_8(3,L)).NE.0) THEN
                  TT(LREV) = RETDAT_8(2,L)
               ELSE
                  QQ(LREV) = RETDAT_8(3,L) / (1.0 + RETDAT_8(3,L))
                  TT(LREV) = RETDAT_8(2,L) * (1.0 + 0.61 * QQ(LREV))
               ENDIF
            ELSE
               WRITE(6,3082) KOUNTR
 3082 FORMAT(/'##W3RTOVSUNP WARNING: A DECODED RETRIEVAL (#',I5,') ',
     $ 'CONTAINS 1 OR MORE MISSING TEMERATURES IN ITS SOUNDING - SKIP ',
     $ 'IT')
               GO TO 1000
            ENDIF
            IF(IBFMS(RETDAT_8(4,L)).EQ.0)  CLAL(LREV) = RETDAT_8(4,L)
            IF(IBFMS(RETDAT_8(5,L)).EQ.0)  CLAM(LREV) = RETDAT_8(5,L)
         ENDDO
      ELSE
         WRITE(6,2082) STNID,KOUNTR,NLEV
 2082 FORMAT(/'##W3RTOVSUNP WARNING: ID ',A8,' (#',I5,') DOES NOT ',
     $ 'CONTAIN 40 SOUNDING LEVELS (HAS ',I3,' LEVELS) -- NO SOUNDING ',
     $ 'LEVEL DATA PROCESSED')
      ENDIF

      IF(NCHN.EQ.32)  THEN

C  FILL IN THE RADIANCE DATA
C  -------------------------

         DO L = 1,NCHN
            IF(IBFMS(BRTDAT_8(1,L)).EQ.0) IRTCHN(L) =NINT(BRTDAT_8(1,L))
            IF(IBFMS(BRTDAT_8(2,L)).EQ.0) RTRAD(L)  = BRTDAT_8(2,L)
         ENDDO
      ELSE
         WRITE(6,2083) STNID,KOUNTR,NCHN
 2083 FORMAT(/'##W3RTOVSUNP WARNING: ID ',A8,' (#',I5,') DOES NOT ',
     $ 'CONTAIN 32 RADIANCE CHANNELS (HAS ',I3,' CHANNELS) -- NO ',
     $ 'RADIANCE DATA PROCESSED')
      ENDIF

C  BOTTOM LEVEL PRESSURE
C  ---------------------

      IF(IBFMS(SRFDAT_8(1)).EQ.0)  THEN
         RSATOB(5) = 0.01 * SRFDAT_8(1)
      ELSE
         WRITE(6,2084) KOUNTR,STNID
 2084 FORMAT(/'##W3RTOVSUNP WARNING: A DECODED RETRIEVAL (#',I5,',ID=',
     $ A8,') HAS A MISSING BOTTOM PRESSURE LEVEL - SKIP IT')
         GO TO 1000
      ENDIF

C  SURFACE HEIGHT
C  --------------

      IF(IBFMS(SRFDAT_8(2)).EQ.0)  THEN
         RSATOB(4) = SRFDAT_8(2)
      ELSE
         WRITE(6,2085) KOUNTR,STNID
 2085 FORMAT(/'##W3RTOVSUNP WARNING: A DECODED RETRIEVAL (#',I5,',ID=',
     $ A8,') HAS A MISSING SURFACE HEIGHT - SKIP IT')
         GO TO 1000
      ENDIF

C  REPORT TYPE AND LAND/SEA TAG
C  ----------------------------

      IF(IBFMS(SRFDAT_8(3)).EQ.0)  THEN
         ISATOB(5) = NINT(SRFDAT_8(3))
         IF(MOD(ISATOB(5),2).EQ.0)  THEN
            IF(INST.LT.IMISS)  ISATOB(2) = 170 + INST
            ISATOB(5) = 0
         ELSE 
            IF(INST.LT.IMISS)  ISATOB(2) = 160 + INST
            ISATOB(5) = 1
         ENDIF
      ELSE
         WRITE(6,2086) KOUNTR,STNID
 2086 FORMAT(/'##W3RTOVSUNP WARNING: A DECODED RETRIEVAL (#',I5,',ID=',
     $ A8,') HAS A MISSING LAND/SEA INDICATOR - SKIP IT')
            GO TO 1000
      ENDIF

C  SKIN TEMPERATURE
C  ----------------

      IF(IBFMS(SRFDAT_8(4)).EQ.0)  RSATOB(6) = SRFDAT_8(4)

C  SEA-SURFACE  TEMPERATURE
C  ------------------------

      IF(IBFMS(SRFDAT_8(5)).EQ.0)  RSATOB(9) = SRFDAT_8(5)

C  TERRAIN INDICATOR
C  -----------------

      IF(IBFMS(SRFDAT_8(6)).EQ.0)  ISATOB(11) = NINT(SRFDAT_8(6))

C  RETURN WITH DECODED RTOVS RETRIEVAL
C  -----------------------------------

      IERR = 0

      RETURN
      END
