w3unpk77.f

Go to the documentation of this file.

C> @file
C> @brief Decodes single report from bufr messages
C> @author Dennis Keyser @date 2002-03-05
 
C> This subroutine decodes a single report from bufr messages
C> in a jbufr-type data file. Currently wind profiler, nexrad (vad)
C> wind and goes sounding/radiance data types are valid. Report is
C> returned in quasi-office note 29 unpacked format (see remarks 4.).
C>
C> ### Program History Log:
C> Date | Programmer | Comment
C> -----|------------|--------
C> 1996-12-16 | Dennis Keyser | Original author (based on w3lib routine w3fi77)
C> 1997-06-02 | Dennis Keyser | Added nexrad (vad) wind data type
C> 1997-06-16 | Dennis Keyser | Added goes sounding/radiance data type
C> 1997-09-18 | Dennis Keyser | Added instrument data used in processing,
C> solar zenith angle, and satellite zenith angle
C> to list of parameters returned from goes
C> sounding/radiance data type
C> 1998-07-09 | Dennis Keyser | Modified wind profiler cat. 11 (height, horiz.
C> significance, vert. significance) to account
C> for updates to bufrtable mnemonics in /dcom;
C> changed char. 6 of goes stnid to be unique for
C> two different even or odd satellite id's
C> (every other even or odd sat. id now gets same
C> char. 6 tag)
C> 1998-08-19 | Dennis Keyser | Subroutine now y2k and fortran 90 compliant
C> 1999-03-16 | Dennis Keyser | Incorporated bob kistler's changes needed
C> to port the code to the ibm sp
C> 1999-05-17 | Dennis Keyser | Made changes necessary to port this routine to
C> the ibm sp
C> 1999-09-26 | Dennis Keyser | Changes to make code more portable
C> 2002-03-05 | Dennis Keyser | Accounts for changes in input proflr (wind
C> profiler) bufr dump file after 3/2002: cat. 10
C> surface data now all missing (mnemonics "pmsl",
C> "wdir1","wspd1", "tmdb", "rehu", "reqv" no
C> longer available); cat. 11 mnemonics "acavh",
C> "acavv", "spp0", and "nphl" no longer
C> available; header mnemonic "npsm" is no longer
C> available, header mnemonic "tpse" replaces
C> "tpmi" (avg. time in minutes still output);
C> number of upper-air levels incr. from 43 to up
C> to 64 (size of output "rdata" array incr. from
C> 600 to 1200 to account for this) (will still
C> work properly for input proflr dump files prior
C> to 3/2002)
C>
C> @param[in] IDATE 4-word array holding "central" date to process (yyyy, mm, dd, hh)
C> @param[in] IHE Number of whole hours relative to "idate" for date of
C> earliest bufr message that is to be decoded; earliest date is "idate" +
C> "ihe" hours (if "ihe" is positive, latest message date is after "idate";
C> if "ihe" is negative latest message date is prior to "idate") example:
C> if ihe=1, then earliest date is 1-hr after idate; if ihe=-3, then earliest
C> date is 3-hr prior to idate
C> @param[in] IHL Number of whole hours relative to "idate" for date of
C> latest bufr message that is to be decoded; latest date is "idate" + ("ihl"
C> hours plus 59 min) if "ihl" is positive (latest message date is after
C> "idate"), and "idate" + ("ihl"+1 hours minus 1 min) if "ihl" is negative
C> (latest message date is prior to "idate") example: if ihl=3, then latest
C> date is 3-hr 59-min after idate; if ihl=-2, then latest date is 1-hr 1-min
C> prior to idate
C> @param[in] LUNIT Fortran unit number for input data file
C> @param[out] RDATA Single report returned an a quasi-office note 29 unpacked
C> format (see remarks 4.) (minimum size is 1200 words)
C> @param[inout] IRET [in] Controls degree of unit 6 printout (.ge. 0 -limited
C> printout; = -1 some additional diagnostic printout; = .lt. -1 -extensive
C> printout) (see remarks 3.)
C> [out] Return code as follows:
C> - IRET = 0 ---> Report successfully returned
C> - IRET > 0 ---> No report returned due to:
C>  - = 1 ---> All reports read in, end
C>  - = 2 ---> Lat and/or lon data missing
C>  - = 3 ---> Reserved
C>  - = 4 ---> Some/all date information missing
C>  - = 5 ---> No data levels processed (all levels are missing)
C>  - = 6 ---> Number of levels in report header is not 1
C>  - = 7 ---> Number of levels in another single level sequence is not 1
C>
C> @remark
C> - 1 A condition code (stop) of 15 will occur if the input
C> dates for start and/or stop time are specified incorrectly.
C> - 2 A condition code (stop) of 22 will occur if the
C> characters on this machine are neither ascii nor ebcdic.
C> - 3 The input argument "iret" should be set prior to each
C> call to this subroutine.
C>
C>   ***************************************************************
C>          4)
C>    BELOW IS THE FORMAT OF AN UNPACKED REPORT IN OUTPUT ARRAY RDATA
C>     (EACH WORD REPRESENTS A FULL-WORD ACCORDING TO THE MACHINE)
C>   N O T E :  THIS IS THE SAME FORMAT AS FOR W3LIB ROUTINE W3FI77
C>              EXCEPT WHERE NOTED
C>   ***************************************************************
C>
C> #### FORMAT FOR WIND PROFILER REPORTS
C>   WORD |  CONTENT               |  UNIT               | FORMAT
C>   ---- |  --------------------- | ------------------- | ---------
C>     1  |  LATITUDE                 |  0.01 DEGREES        | REAL
C>     2  |  LONGITUDE                |  0.01 DEGREES WEST   | REAL
C>     3  |  TIME SIGNIFICANCE | (BUFR CODE TABLE "0 08 021")  | INTEGER
C>     4  |  OBSERVATION TIME         |  0.01 HOURS (UTC)    | REAL
C>     5  |  YEAR/MONTH               |  4-CHAR. 'YYMM'  LEFT-JUSTIFIED | CHARACTER
C>     6  |  DAY/HOUR                 |  4-CHARACTERS 'DDHH' | CHARACTER
C>     7  |  STATION ELEVATION        |  METERS              | REAL
C>     8  |  SUBMODE/EDITION NO.      |  (SM X 10) + ED. NO. (ED. NO.=2, CONSTANT; SEE &,~) | INTEGER
C>     9  |  REPORT TYPE              |  71 (CONSTANT)       | INTEGER
C>    10  |  AVERAGING TIME           |  MINUTES (NEGATIVE MEANS PRIOR TO OBS. TIME) | INTEGER
C>    11  |  STN. ID. (FIRST 4 CHAR.) |  4-CHARACTERS LEFT-JUSTIFIED| CHARACTER
C>    12  |  STN. ID. (LAST  2 CHAR.) |  2-CHARACTERS LEFT-JUSTIFIED| CHARACTER
C> 13-34  |  ZEROED OUT - NOT USED    |                      | INTEGER
C>    35  |  CATEGORY 10, NO. LEVELS  |  COUNT               | INTEGER
C>    36  |  CATEGORY 10, DATA INDEX  |  COUNT               | INTEGER
C>    37  |  CATEGORY 11, NO. LEVELS  |  COUNT               | INTEGER
C>    38  |  CATEGORY 11, DATA INDEX  |  COUNT               | INTEGER
C> 39-42  |  ZEROED OUT - NOT USED    |                      | INTEGER
C> 43-END  | UNPACKED DATA GROUPS     | (FOLLOWS)            | REAL
C>
C> #### CATEGORY 10 - WIND PROFILER SFC DATA (EACH LEVEL, SEE WORD 35 ABOVE)
C>     WORD  | PARAMETER          |  UNITS             |  FORMAT
C>     ----  | ---------          |  ----------------- |  -------------
C>(SEE @)1   | SEA-LEVEL PRESSURE |  0.1 MILLIBARS     |  REAL
C>(SEE *)2   | STATION PRESSURE   |  0.1 MILLIBARS     |  REAL
C>(SEE @)3   | HORIZ. WIND DIR.   |  DEGREES           |  REAL
C>(SEE @)4   | HORIZ. WIND SPEED  |  0.1 M/S           |  REAL
C>(SEE @)5   | AIR TEMPERATURE    |  0.1 DEGREES K     |  REAL
C>(SEE @)6   | RELATIVE HUMIDITY  |  PERCENT           |  REAL
C>(SEE @)7   | RAINFALL RATE      |  0.0000001 M/S     |  REAL
C>
C> #### CATEGORY 11 - WIND PROFILER UPPER-AIR DATA (FIRST LEVEL IS SURFACE) (EACH LEVEL, SEE WORD 37 ABOVE)
C>     WORD  | PARAMETER            | UNITS               | FORMAT
C>     ----  | ---------            | -----------------   | -------------
C>       1   | HEIGHT ABOVE SEA-LVL | METERS              | REAL
C>       2   | HORIZ. WIND DIR.     | DEGREES             | REAL
C>       3   | HORIZ. WIND SPEED    | 0.1 M/S             | REAL
C>       4   | QUALITY CODE         | (SEE %)             | INTEGER
C>       5   | VERT. WIND COMP. (W) | 0.01 M/S            | REAL
C>(SEE @)6   | HORIZ. CONSENSUS NO. | (SEE $)             | INTEGER
C>(SEE @)7   | VERT.  CONSENSUS NO. | (SEE $)             | INTEGER
C>(SEE @)8   | SPECTRAL PEAK POWER  | DB                  | REAL
C>       9   | HORIZ. WIND SPEED    | 0.1 M/S             | REAL
C>           | STANDARD DEVIATION   | 0.1 M/S             | REAL
C>      10   | VERT. WIND COMPONENT | 0.1 M/S             | REAL
C>           | STANDARD DEVIATION   | 0.1 M/S             | REAL
C>(SEE @)11  | MODE                 | (SEE #)             | INTEGER
C>
C> ##### SEE:
C> - *-  ALWAYS MISSING
C> - &-  THIS IS A CHANGE FROM FORMAT IN W3LIB ROUTINE W3FI77
C> - %-  0 - MEDIAN AND SHEAR CHECKS BOTH PASSED
C>  - 2 - MEDIAN AND SHEAR CHECK RESULTS INCONCLUSIVE
C>  - 4 - MEDIAN CHECK PASSED; SHEAR CHECK FAILED
C>  - 8 - MEDIAN CHECK FAILED; SHEAR CHECK PASSED
C>  - 12 - MEDIAN AND SHEAR CHECKS BOTH FAILED
C> - $-  NO. OF INDIVIDUAL 6-MINUTE AVERAGE MEASUREMENTS THAT WERE
C>      INCLUDED IN FINAL ESTIMATE OF AVERAGED WIND (RANGE: 0, 2-10)
C>      (BASED ON A ONE-HOUR AVERAGE)
C> - #-  1 - DATA FROM LOW MODE
C>      2 - DATA FROM HIGH MODE
C>      3 - MISSING
C> - @-  THIS PARAMETER IS NO LONGER AVAILABLE AFTER 3/2002 AND IS SET
C>      TO MISSING (99999 FOR INTEGER OR 99999. FOR REAL)
C> - ~-  SUBMODE IS NO LONGER AVAILABLE AFTER 3/2002 AND IS SET TO 3
C>      (ITS MISSING VALUE)
C>
C>XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C>               FORMAT FOR GOES SOUNDING/RADIANCE REPORTS
C>XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C>                           HEADER
C>   WORD   CONTENT                   UNIT                 FORMAT
C>   ----   ----------------------    -------------------  ---------
C>     1    LATITUDE                  0.01 DEGREES         REAL
C>     2    LONGITUDE                 0.01 DEGREES WEST    REAL
C>     3    FIELD OF VIEW NUMBER      NUMERIC              INTEGER
C>     4    OBSERVATION TIME          0.01 HOURS (UTC)     REAL
c>vvvvvdak port
C>     5    YEAR/MONTH                4-CHAR. 'YYMM'       CHARACTER
c>aaaaadak port
C>                                    LEFT-JUSTIFIED
C>     6    DAY/HOUR                  4-CHARACTERS 'DDHH'  CHARACTER
C>     7    STATION ELEVATION         METERS               REAL
C>     8    PROCESS. TECHNIQUE        (=21-CLEAR;          INTEGER
C>     8    PROCESS. TECHNIQUE       =23-CLOUD-CORRECTED)
C>     9    REPORT TYPE               61 (CONSTANT)        INTEGER
C>    10    QUALITY FLAG      (BUFR CODE TABLE "0 33 002") INTEGER
C>    11    STN. ID. (FIRST 4 CHAR.)  4-CHARACTERS         CHARACTER
C>                                    LEFT-JUSTIFIED
C>    12    STN. ID. (LAST  2 CHAR.)  2-CHARACTERS         CHARACTER
C>                                    LEFT-JUSTIFIED (SEE %)
C>
C> 13-26    ZEROED OUT - NOT USED
C>    27    CATEGORY 08, NO. LEVELS   COUNT                INTEGER
C>    28    CATEGORY 08, DATA INDEX   COUNT                INTEGER
C> 29-38    ZEROED OUT - NOT USED
C>    39    CATEGORY 12, NO. LEVELS   COUNT                INTEGER
C>    40    CATEGORY 12, DATA INDEX   COUNT                INTEGER
C>    41    CATEGORY 13, NO. LEVELS   COUNT                INTEGER
C>    42    CATEGORY 13, DATA INDEX   COUNT                INTEGER
C>
C> 43-END   UNPACKED DATA GROUPS      (FOLLOWS)            REAL
C>
C>   CATEGORY 12 - SATELLITE SOUNDING LEVEL DATA (FIRST LEVEL IS SURFACE;
C>                 EACH LEVEL, SEE 39 ABOVE)
C>     WORD   PARAMETER            UNITS               FORMAT
C>     ----   ---------            -----------------   -------------
C>       1    PRESSURE             0.1 MILLIBARS       REAL
C>       2    GEOPOTENTIAL         METERS              REAL
C>       3    TEMPERATURE          0.1 DEGREES C       REAL
C>       4    DEWPOINT TEMPERATURE 0.1 DEGREES C       REAL
C>       5    NOT USED             SET TO MISSING      REAL
C>       6    NOT USED             SET TO MISSING      REAL
C>       7    QUALITY MARKERS      4-CHARACTERS        CHARACTER
C>                                 LEFT-JUSTIFIED (SEE &)
C>
C>   CATEGORY 13 - SATELLITE RADIANCE "LEVEL" DATA (EACH "LEVEL", SEE
C>                 41 ABOVE)
C>     WORD   PARAMETER            UNITS               FORMAT
C>     ----   ---------            -----------------   -------------
C>       1    CHANNEL NUMBER       NUMERIC             INTEGER
C>       2    BRIGHTNESS TEMP.     0.01 DEG. KELVIN    REAL
C>       3    QUALITY MARKERS      4-CHARACTERS        CHARACTER
C>                                 LEFT-JUSTIFIED (SEE &&)
C>
C>   CATEGORY 08 - ADDITIONAL (MISCELLANEOUS) DATA (EACH LEVEL, SEE @
C>                 BELOW)
C>     WORD   PARAMETER            UNITS               FORMAT
C>     ----   ---------            -----------------   -------------
C>       1    VARIABLE             SEE @ BELOW         REAL
C>       2    CODE FIGURE          SEE @ BELOW         REAL
C>       3    MARKERS              2-CHARACTERS        CHARACTER
C>                                 LEFT-JUSTIFIED (SEE #)
C>
C>  %-  SIXTH CHARACTER OF STATION ID IS A TAGGED AS FOLLOWS:
C>          "I" - GOES-EVEN-1 (252, 256, ...) SAT. , CLEAR COLUMN  RETR.
C>          "J" - GOES-EVEN-1 (252, 256, ...) SAT. , CLD-CORRECTED RETR.
 
C>          "L" - GOES-ODD-1  (253, 257, ...) SAT. , CLEAR COLUMN  RETR.
C>          "M" - GOES-ODD-1  (253, 257, ...) SAT. , CLD-CORRECTED RETR.
 
C>          "O" - GOES-EVEN-2 (254, 258, ...) SAT. , CLEAR COLUMN  RETR.
C>          "P" - GOES-EVEN-2 (254, 258, ...) SAT. , CLD-CORRECTED RETR.
 
C>          "Q" - GOES-ODD-2  (251, 255, ...) SAT. , CLEAR COLUMN  RETR.
C>          "R" - GOES-ODD-2  (251, 255, ...) SAT. , CLD-CORRECTED RETR.
 
C>          "?" - EITHER SATELLITE AND/OR RETRIEVAL TYPE UNKNOWN
 
C>  &-  FIRST  CHARACTER IS Q.M. FOR GEOPOTENTIAL
C>      SECOND CHARACTER IS Q.M. FOR TEMPERATURE
C>      THIRD  CHARACTER IS Q.M. FOR DEWPOINT TEMPERATURE
C>      FOURTH CHARACTER IS NOT USED
C>          " " - INDICATES DATA NOT SUSPECT
C>          "Q" - INDICATES DATA ARE SUSPECT
C>          "F" - INDICATES DATA ARE BAD
C>  &&- FIRST  CHARACTER IS Q.M. FOR BRIGHTNESS TEMPERATURE
C>      SECOND-FOURTH CHARACTERS ARE NOT USED
C>          " " - INDICATES DATA NOT SUSPECT
C>          "Q" - INDICATES DATA ARE SUSPECT
C>          "F" - INDICATES DATA ARE BAD
C>  @-  NUMBER OF "LEVELS" FROM WORD 27.  MAXIMUM IS 12, AND ARE ORDERED
C>      AS FOLLOWS (IF A DATUM ARE MISSING THAT LEVEL NOT STORED)
C>           1 - LIFTED INDEX ---------- .01 DEG. KELVIN -- C. FIG. 250.
C>           2 - TOTAL PRECIP. WATER  -- .01 MILLIMETERS -- C. FIG. 251.
C>           3 - 1. TO .9 SIGMA P.WATER- .01 MILLIMETERS -- C. FIG. 252.
C>           4 - .9 TO .7 SIGMA P.WATER- .01 MILLIMETERS -- C. FIG. 253.
C>           5 - .7 TO .3 SIGMA P.WATER- .01 MILLIMETERS -- C. FIG. 254.
C>           6 -  SKIN TEMPERATURE ----- .01 DEG. KELVIN -- C. FIG. 255.
C>           7 -  CLOUD TOP TEMPERATURE- .01 DEG. KELVIN -- C. FIG. 256.
C>           8 -  CLOUD TOP PRESSURE --- .1 MILLIBARS ----- C. FIG. 257.
C>           9 -  CLOUD AMOUNT (BUFR TBL. C.T. 0-20-011) -- C. FIG. 258.
C>          10 -  INSTR. DATA USED IN PROC.
C>                             (BUFR TBL. C.T. 0-02-021) -- C. FIG. 259.
C>          11 -  SOLAR ZENITH ANGLE --- .01 DEGREE ------- C. FIG. 260.
C>          12 -  SAT. ZENITH ANGLE ---- .01 DEGREE ------- C. FIG. 261.
C>  #-  FIRST  CHARACTER IS Q.M. FOR THE DATUM
C>          " " - INDICATES DATA NOT SUSPECT
C>          "Q" - INDICATES DATA ARE SUSPECT
C>          "F" - INDICATES DATA ARE BAD
C>      SECOND CHARACTER IS NOT USED
C>
C>XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C>                FORMAT FOR NEXRAD (VAD) WIND REPORTS
C>XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C>                           HEADER
C>   WORD   CONTENT                   UNIT                 FORMAT
C>   ----   ----------------------    -------------------  ---------
C>     1    LATITUDE                  0.01 DEGREES         REAL
C>     2    LONGITUDE                 0.01 DEGREES WEST    REAL
C>     3    ** RESERVED **            SET TO 99999         INTEGER
C>     4    OBSERVATION TIME          0.01 HOURS (UTC)     REAL
c>vvvvvdak port
C>     5    YEAR/MONTH                4-CHAR. 'YYMM'       CHARACTER
c>aaaaadak port
C>                                    LEFT-JUSTIFIED
C>     6    DAY/HOUR                  4-CHARACTERS 'DDHH'  CHARACTER
C>     7    STATION ELEVATION         METERS               REAL
C>     8    ** RESERVED **            SET TO 99999         INTEGER
C>
C>     9    REPORT TYPE               72 (CONSTANT)        INTEGER
C>    10    ** RESERVED **            SET TO 99999         INTEGER
C>    11    STN. ID. (FIRST 4 CHAR.)  4-CHARACTERS         CHARACTER
C>                                    LEFT-JUSTIFIED
C>    12    STN. ID. (LAST  2 CHAR.)  2-CHARACTERS         CHARACTER
C>                                    LEFT-JUSTIFIED
C>
C> 13-18    ZEROED OUT - NOT USED                          INTEGER
C>    19    CATEGORY 04, NO. LEVELS   COUNT                INTEGER
C>    20    CATEGORY 04, DATA INDEX   COUNT                INTEGER
C> 21-42    ZEROED OUT - NOT USED                          INTEGER
C>
C> 43-END   UNPACKED DATA GROUPS      (FOLLOWS)            REAL
C>
C>   CATEGORY 04 - UPPER-AIR WINDS-BY-HEIGHT DATA(FIRST LEVEL IS SURFACE)
C>                 (EACH LEVEL, SEE WORD 19 ABOVE)
C>     WORD   PARAMETER            UNITS               FORMAT
C>     ----   ---------            -----------------   -------------
C>       1    HEIGHT ABOVE SEA-LVL METERS              REAL
C>       2    HORIZ. WIND DIR.     DEGREES             REAL
C>       3    HORIZ. WIND SPEED    0.1 M/S (SEE *)     REAL
C>       4    QUALITY MARKERS      4-CHARACTERS        CHARACTER
C>                                 LEFT-JUSTIFIED (SEE %)
C>
C>  *-  UNITS HERE DIFFER FROM THOSE IN TRUE UNPACKED OFFICE NOTE 29
C>      (WHERE UNITS ARE KNOTS)
C>  %-  THE FIRST THREE CHARACTERS ARE ALWAYS BLANK, THE FOURTH
C>      CHARACTER IS A "CONFIDENCE LEVEL" WHICH IS RELATED TO THE ROOT-
C>      MEAN-SQUARE VECTOR ERROR FOR THE HORIZONTAL WIND.  IT IS
C>      DEFINED AS FOLLOWS:
C>               'A' = RMS OF  1.9 KNOTS
C>               'B' = RMS OF  3.9 KNOTS
C>               'C' = RMS OF  5.8 KNOTS
C>               'D' = RMS OF  7.8 KNOTS
C>               'E' = RMS OF  9.7 KNOTS
C>               'F' = RMS OF 11.7 KNOTS
C>               'G' = RMS  > 13.6 KNOTS
C>XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C>
C>   FOR ALL REPORT TYPES, MISSING VALUES ARE:
C>                       99999. FOR REAL
C>                       99999  FOR INTEGER
C>                       9'S    FOR CHARACTERS IN WORD  5,  6 OF HEADER
C>                       BLANK  FOR CHARACTERS IN WORD 11, 12 OF HEADER
C>                              AND FOR CHARACTERS IN ANY CATEGORY LEVEL
C>
C> @author Dennis Keyser @date 2002-03-05
      SUBROUTINE w3unpk77(IDATE,IHE,IHL,LUNIT,RDATA,IRET)
      CHARACTER*4  CBUFR
      INTEGER  IDATE(4),LSDATE(4),jdate(8),IDATA(1200)
      dimension  rinc(5)
      REAL  RDATA(*),RDATX(1200)
      COMMON /pk77bb/kdate(8),ldate(8),iprint
      COMMON /pk77cc/index
      COMMON /pk77dd/lshe,lshl,icdate(5),iddate(5)
      COMMON /pk77ff/ifov(3),kntsat(250:260)
 
      SAVE
 
      equivalence(rdatx,idata)
      DATA itm/0/,lunitl/-99/,kount/0/
      iprint = 0
      IF(iret.LT.0)  iprint = iabs(iret)
      iret = 0
      IF(itm.EQ.0)  THEN
C-----------------------------------------------------------------------
 
C FIRST AND ONLY TIME INTO THIS SUBROUTINE DO A FEW THINGS....
 
         itm = 1
         ifov = 0
         kntsat = 0
C DETERMINE MACHINE WORD LENGTH IN BYTES (=8 FOR CRAY) AND TYPE OF
C  CHARACTER SET {ASCII(ICHTP=0) OR EBCDIC(ICHTP=1)}
         CALL w3fi04(iendn,ichtp,lw)
         print 2213, lw, ichtp, iendn
 2213    FORMAT(/' ---> W3UNPK77: CALL TO W3FI04 RETURNS: LW = ',i3,
     $    ', ICHTP = ',i3,', IENDN = ',i3/)
         IF(ichtp.GT.1)  THEN
C CHARACTERS ON THIS MACHINE ARE NEITHER ASCII OR EBCDIC!! -- STOP 22
            print 217
  217       FORMAT(' *** W3UNPK77 ERROR: CHARACTERS ON THIS MACHINE ',
     $       'ARE NEITHER ASCII NOR EBCDIC - STOP 22'/)
            CALL errexit(22)
         END IF
C-----------------------------------------------------------------------
      END IF
      IF(lunit.NE.lunitl)  THEN
C-----------------------------------------------------------------------
 
C IF THE INPUT DATA UNIT NUMBER ARGUMENT IS DIFFERENT THAT THE LAST TIME
C  THIS SUBR. WAS CALLED, PRINT NEW HEADER, SET JRET = 1
 
         lunitl = lunit
         jret = 1
         print 101, lunit
  101    FORMAT(//' ---> W3UNPK77: VERSION 03/05/2002: JBUFR DATA SET ',
     $    'READ FROM UNIT ',i4/)
C-----------------------------------------------------------------------
      ELSE
 
C FOR SUBSEQUENT TIMES INTO THIS SUBR. W/ SAME LUNIT AS LAST TIME,
C  TEST INPUT DATE & HR RANGE ARGUMENTS AGAINST THEIR VALUES THE LAST
C  TIME SUBR. CALLED -- IF THEY ARE DIFFERENT, SET JRET = 1 (ELSE
C  JRET = 0), WILL TEST JRET SOON
 
         jret = 1
         DO i = 4,1,-1
            IF(idate(i).NE.lsdate(i))  GO TO 88
         ENDDO
         IF(ihe.NE.lshe.OR.ihl.NE.lshl)  GO TO 88
         jret = 0
   88    CONTINUE
C-----------------------------------------------------------------------
      END IF
      IF(jret.EQ.1)  THEN
         print 6680
 6680 FORMAT(/' JRET = 1 - REWIND DATA FILE & SET-UP TO DO DATE CHECK'/)
C-----------------------------------------------------------------------
 
C COME HERE IF FIRST CALL TO SUBROUTINE OR IF INPUT DATA UNIT NUMBER OR
C  IF INPUT DATE/TIME OR RANGE IN TIME HAS BEEN CHANGED FROM LAST CALL
 
C           CLOSE BUFR DATA SET (IN CASE OPEN FROM PREVIOUS RUN)
C       REWIND INPUT BUFR DATA SET, GET CENTER TIME AND DUMP TIME,
C                          OPEN BUFR DATA SET
 
C     SET-UP TO DETERMINE IF BUFR MESSAGE IS WITHIN REQUESTED DATES
 
C (ALSO SET INDEX=0, FORCES BUFR MSG TO BE READ BEFORE RPTS ARE DECODED)
 
C-----------------------------------------------------------------------
 
         CALL closbf(lunit)
 
         rewind lunit
 
         READ(lunit,END=9999,ERR=9999) cbufr
         IF(cbufr.NE.'BUFR') GO TO 9999
 
         call datelen(10)
 
         CALL dumpbf(lunit,icdate,iddate)
cppppp
         print *,'CENTER DATE (ICDATE) = ',icdate
         print *,'DUMP DATE (IDDATE)   = ',iddate
cppppp
 
         if(icdate(1).le.0)  then
C COME HERE IF CENTER DATE COULD NOT BE READ FROM FIRST DUMMY MESSAGE
C  - RETURN WITH IRET = 1
            print *, ' *** W3UNPK77 ERROR: CENTER DATE COULD NOT BE ',
     $       'OBTAINED FROM INPUT FILE ON UNIT ',lunit
            go to 9998
         end if
         if(iddate(1).le.0)  then
C COME HERE IF DUMP DATE COULD NOT BE READ FROM SECOND DUMMY MESSAGE
C  - RETURN WITH IRET = 1
            print *, ' *** W3UNPK77 ERROR: DUMP DATE COULD NOT BE ',
     $       'OBTAINED FROM INPUT FILE ON UNIT ',lunit
            go to 9998
         end if
         IF(icdate(1).LT.100)  THEN
 
C If 2-digit year returned in ICDATE(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 *, '##W3UNPK77 - THE FOLLOWING SHOULD NEVER ',
     $       'HAPPEN!!!!!'
            print *, '##W3UNPK77 - 2-DIGIT YEAR IN ICDATE(1) ',
     $       'RETURNED FROM DUMPBF (ICDATE IS: ',icdate,') - USE ',
     $       'WINDOWING TECHNIQUE TO OBTAIN 4-DIGIT YEAR'
            IF(icdate(1).GT.20)  THEN
               icdate(1) = 1900 + icdate(1)
            ELSE
               icdate(1) = 2000 + icdate(1)
            ENDIF
            print *, '##WW3UNPK77 - CORRECTED ICDATE(1) WITH 4-DIGIT ',
     $       'YEAR, ICDATE NOW IS: ',icdate
         ENDIF
 
         IF(iddate(1).LT.100)  THEN
 
C If 2-digit year returned in IDDATE(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 *, '##W3UNPK77 - THE FOLLOWING SHOULD NEVER ',
     $       'HAPPEN!!!!!'
            print *, '##W3UNPK77 - 2-DIGIT YEAR IN IDDATE(1) ',
     $       'RETURNED FROM DUMPBF (IDDATE IS: ',iddate,') - USE ',
     $       'WINDOWING TECHNIQUE TO OBTAIN 4-DIGIT YEAR'
            IF(iddate(1).GT.20)  THEN
               iddate(1) = 1900 + iddate(1)
            ELSE
               iddate(1) = 2000 + iddate(1)
            ENDIF
            print *, '##W3UNPK77 - CORRECTED IDDATE(1) WITH 4-DIGIT ',
     $       'YEAR, IDDATE NOW IS: ',iddate
         END IF
 
C  OPEN BUFR FILE - READ IN DICTIONARY MESSAGES (TABLE A, B, D ENTRIES)
 
         CALL openbf(lunit,'IN',lunit)
         print 100, lunit
  100    FORMAT(/5x,'===> BUFR DATA SET IN UNIT',i3,' SUCCESSFULLY ',
     $    'OPENED FOR INPUT; DCTNY MESSAGES CONTAIN BUFR TABLES A,B,D'/)
         index = 0
         kount = 0
         jdate(1:3) = idate(1:3)
         jdate(4) = 0
         jdate(5) = idate(4)
         jdate(6:8) = 0
         print 6681, idate
 6681 FORMAT(/' %%% REQUESTED "CENTRAL" DATE IS :',i5,3i3,'  0'/)
C DETERMINE EARLIEST DATE FOR ACCEPTING BUFR MESSAGES FOR DECODING
         call w3movdat((/0.,real(ihe),0.,0.,0./),jdate,kdate)
         print 6682, (kdate(i),i=1,3),kdate(5),kdate(6)
 6682 FORMAT(/' --> EARLIEST DATE FOR ACCEPTING BUFR MSGS IS:',i5,4i3/)
C DETERMINE LATEST   DATE FOR ACCEPTING BUFR MESSAGES FOR DECODING
         if(ihl.ge.0)  then
           xminl = (ihl * 60) + 59
         else
           xminl = ((ihl + 1) * 60) - 1
         end if
         call w3movdat((/0.,0.,xminl,0.,0./),jdate,ldate)
         print 6683, (ldate(i),i=1,3),ldate(5),ldate(6)
 6683 FORMAT(/' -->  LATEST  DATE FOR ACCEPTING BUFR MSGS IS:',i5,4i3/)
         call w3difdat(ldate,kdate,3,rinc)
         IF(rinc(3).LT.0)  THEN
            print 104
  104       FORMAT(' *** W3UNPK77 ERROR: DATES SPECIFIED INCORRECTLY -',
     $       ' STOP 15'/)
            CALL errexit(15)
         END IF
C-----------------------------------------------------------------------
      END IF
C SUBR. UNPK7701 RETURNS A SINGLE DECODED REPORT FROM BUFR MESSAGE
      CALL unpk7701(lunit,itp,iret)
C IRET=1 MEANS ALL DATA HAVE BEEN DECODED FOR SPECIFIED TIME PERIOD
C  (REWIND DATA FILE AND RETURN W/ IRET=1)
C IRET.GE.2 MEANS REPORT NOT RETURNED DUE TO ERROR IN DECODING (RETURN)
C  (ACTUALLY IRET.GE.2 CURRENTLY CANNOT HAPPEN OUT OF UNPK7701)
      IF(iret.GE.1)  THEN
         IF(iret.EQ.1)  THEN
            rewind lunit
            IF(itp.EQ.2)  THEN
               print 8101, ifov
 8101 FORMAT(/' ---> W3UNPK77: SUMMARY OF GOES REPORT COUNTS GROUPED',
     $ ' BY F-O-V NO. (PRIOR TO ANY FILTERING BY CALLING PROGRAM)'/15x,
     $ '# WITH F-O-V NO. 00 TO 02:',i6,' - GET "BAD" Q.MARK'/15x,
     $ '# WITH F-O-V NO. 03 TO 09:',i6,' - GET "SUSPECT" Q.MARK'/15x,
     $ '# WITH F-O-V NO. 10 TO 25:',i6,' - GET "NEUTRAL" Q.MARK'/20x,
     $ '(NOTE: RADIANCES ALWAYS HAVE NEUTRAL Q.MARK)'/)
               print 8102
 8102 FORMAT(/' ---> W3UNPK77: SUMMARY OF GOES REPORT COUNTS GROUPED',
     $ ' BY SATELLITE ID (PRIOR TO ANY FILTERING BY CALLING PROGRAM)'/)
               DO  idsat = 250,259
                  IF(kntsat(idsat).GT.0) print 8103, idsat,kntsat(idsat)
               ENDDO
 8103 FORMAT(15x,'NUMBER FROM SAT. ID',i4,4x,':',i6)
               IF(kntsat(260).GT.0)  print 8104
 8104 FORMAT(15x,'NUMBER FROM UNKNOWN SAT. ID:',i6)
               print 8105
 8105          FORMAT(/)
            END IF
         END IF
         GO TO 99
      END IF
      kount = kount + 1
C INITIALIZE THE OUTPUT ON29 ARRAY
      CALL unpk7702(rdata,itp)
      IF(itp.EQ.1)  THEN
C-----------------------------------------------------------------------
C          THE FOLLOWING PERTAINS TO WIND PROFILER REPORTS
C-----------------------------------------------------------------------
C STORE THE HEADER INFORMATION INTO ON29 FORMAT
         CALL unpk7703(lunit,rdata,iret)
C IRET.GE.2 MEANS RPT NOT RETURNED DUE TO MSG DATA IN HDR (RETURN)
         IF(iret.GE.2)  GO TO 99
C STORE THE SURFACE DATA INTO ON29 FORMAT (CATEGORY 10)
         CALL unpk7704(lunit,rdata)
C STORE THE UPPER-AIR DATA INTO ON29 FORMAT (CATEGORY 11)
         CALL unpk7705(lunit,rdata)
         rdatx(1:1200) = rdata(1:1200)
         IF(idata(35)+idata(37).EQ.0)  iret = 5
      ELSE  IF(itp.EQ.2)  THEN
C-----------------------------------------------------------------------
C        THE FOLLOWING PERTAINS TO GOES SOUNDING/RADIANCE REPORTS
C-----------------------------------------------------------------------
C STORE THE HEADER INFORMATION INTO ON29 FORMAT
         CALL unpk7708(lunit,rdata,kount,iret)
C IRET.GE.2 MEANS RPT NOT RETURNED DUE TO MSG DATA IN HDR (RETURN)
         IF(iret.GE.2)  GO TO 99
C STORE THE UPPER-AIR DATA/RADIANCE INTO ON29 FORMAT (CATEGORY 12, 13)
         CALL unpk7709(lunit,rdata,iret)
      ELSE  IF(itp.EQ.3)  THEN
C-----------------------------------------------------------------------
C       THE FOLLOWING PERTAINS TO NEXRAD (VAD) WIND REPORTS
C-----------------------------------------------------------------------
C STORE THE HEADER INFORMATION INTO ON29 FORMAT
         CALL unpk7706(lunit,rdata,iret)
C IRET.GE.2 MEANS RPT NOT RETURNED DUE TO MSG DATA IN HDR (RETURN)
         IF(iret.GE.2)  GO TO 99
C STORE THE UPPER-AIR DATA INTO ON29 FORMAT (CATEGORY 4)
         CALL unpk7707(lunit,rdata,iret)
C-----------------------------------------------------------------------
      END IF
   99 CONTINUE
C PRIOR TO RETURNING SAVE INPUT DATE & HR RANGE ARGUMENTS FROM THIS CALL
      lsdate = idate
      lshe = ihe
      lshl = ihl
      RETURN
C-----------------------------------------------------------------------
 9999 CONTINUE
C COME HERE IF NULL OR NON-BUFR FILE IS INPUT - RETURN WITH IRET = 1
      print *, ' *** W3UNPK77 ERROR: INPUT FILE IN UNIT ',lunit,' IS ',
     $ 'EITHER A NULL OR NON-BUFR FILE'
 9998 continue
      rewind lunit
      iret = 1
      lsdate = idate
      lshe = ihe
      lshl = ihl
      END
C> @brief Reads a single report out of bufr dataset
C> @author Dennis Keyser @date 1996-12-16
 
C> Calls bufrlib routines to read in a bufr message and then read a single
C> report (subset) out of the message.
C>
C> ### Program History Log:
C> Date | Programmer | Comment
C> -----|------------|--------
C> 1996-12-16 | Dennis Keyser NP22 | Initial.
C>
C> @param[in] LUNIT Fortran unit number for input data file.
C> @param[out] ITP The type of report that has been decoded {=1 - wind profiler,
C> =2 - goes sndg, =3 - nexrad(vad) wind}
C> @param[out] IRET Return code as described in w3unpk77 docblock
C>
C> @author Dennis Keyser @date 1996-12-16
      SUBROUTINE unpk7701(LUNIT,ITP,IRET)
      CHARACTER*8   SUBSET
      integer  mdate(4),ndate(8)
      dimension  rinc(5)
      COMMON /pk77bb/kdate(8),ldate(8),iprint
      COMMON /pk77cc/index
      COMMON /pk77dd/lshe,lshl,icdate(5),iddate(5)
 
      SAVE
 
      DATA  irec/0/
 
   10 CONTINUE
C=======================================================================
      IF(index.EQ.0)  THEN
 
C  READ IN NEXT BUFR MESSAGE
 
         CALL readmg(lunit,subset,ibdate,jret)
         IF(jret.NE.0)  THEN
C-----------------------------------------------------------------------
            print 101
  101   FORMAT(' ---> W3UNPK77: ALL BUFR MESSAGES READ IN AND DECODED'/)
            iret = 1
            RETURN
C-----------------------------------------------------------------------
         END IF
         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
            print *, '##W3UNP777/UNPK7701 - A 10-digit Sect. 1 BUFR ',
     $       'message date was not returned in unit ',lunit,' - ',
     $       'problem with BUFR file - ier = 1'
            iret = 1
            return
         end if
         CALL ufbcnt(lunit,irec,isub)
         mdate(1) = ibdate/1000000
         mdate(2) = mod((ibdate/10000),100)
         mdate(3) = mod((ibdate/100),100)
         mdate(4) = mod(ibdate,100)
C ALL JBUFR MESSAGES CURRENTLY HAVE "00" FOR MINUTES IN SECTION 1
         ndate(1:3) = mdate(1:3)
         ndate(4) = 0
         ndate(5) = mdate(4)
         ndate(6:8) = 0
         IF(iprint.GE.1)  THEN
            print *,'HAVE SUCCESSFULLY READ IN A BUFR MESSAGE'
            print 103
  103       FORMAT(' BUFR FOUND BEGINNING AT BYTE    1 OF MESSAGE')
            print 105, irec,mdate,subset
  105       FORMAT(8x,'HAVE READ IN A BUFR MESSAGE NO.',i3,', DATE: ',
     $      i6,3i4,'   0; TABLE A ENTRY = ',a8,' AND EDIT. NO. =    2'/)
         END IF
         IF(subset.EQ.'NC002007')  THEN
            IF(iprint.GE.1)  print *, 'THIS MESSAGE CONTAINS WIND ',
     $       'PROFILER REPORTS'
            itp = 1
         ELSE  IF(subset.EQ.'NC002008')  THEN
            IF(iprint.GE.1)  print *, 'THIS MESSAGE CONTAINS NEXRAD ',
     $       '(VAD) WIND REPORTS'
            itp = 3
         ELSE  IF(subset.EQ.'NC003001')  THEN
            IF(iprint.GE.1)  print *, 'THIS MESSAGE CONTAINS GOES ',
     $       'SOUNDING/RADIANCE REPORTS'
            itp = 2
         ELSE
            print 107, irec
  107 FORMAT(' *** W3UNPK77 WARNING: BUFR MESSAGE NO.',i3,' CONTAINS ',
     $ 'REPORTS THAT CANNOT BE DECODED BY W3UNPK77, TRY READING NEXT ',
     $ 'MSG'/)
            index = 0
            GO TO 10
         END IF
         call w3difdat(kdate,ndate,3,rinc)
         kmin = rinc(3)
         call w3difdat(ldate,ndate,3,rinc)
         lmin = rinc(3)
C CHECK DATE OF MESSAGE AGAINST SPECIFIED TIME RANGES
         if((kmin.gt.0.or.lmin.lt.0).AND.irec.GT.2)  then
            print 106, irec,mdate
  106 FORMAT('  BUFR MESSAGE NO.',i3,' WITH DATE:',i5,3i3,'  0 NOT W/I',
     $ ' REQ. TIME RANGE, TRY READING NEXT MSG'/)
            index = 0
            GO TO 10
         END IF
      END IF
C=======================================================================
C  READ NEXT SUBSET (REPORT) IN MESSAGE
 
      IF(iprint.GT.1)  print *,'CALL READSB'
      CALL readsb(lunit,jret)
      IF(iprint.GT.1)  print *,'BACK FROM READSB'
      IF(jret.NE.0) THEN
         IF(index.GT.0)  THEN
 
C ALL SUBSETS IN THIS MESSAGE PROCESSED, READ IN NEXT MESSAGE (IF ALL
C  MESSAGES READ IN NO MORE DATA TO PROCESS)
 
            IF(iprint.GT.1)  print *, 'ALL REPORTS IN THIS MESSAGE ',
     $       'DECODED, GO ON TO NEXT MESSAGE'
         ELSE
 
C THERE WERE NO SUBSETS FOUND IN THIS BUFR MESSAGE, GOOD CHANCE IT IS
C  ONE OF TWO DUMMY MESSAGES AT TOP OF FILE INDICATING CENTER TIME AND
C  DATA DUMP TIME ONLY; READ IN NEXT MESSAGE
 
            IF(irec.EQ.1)  THEN
               print 4567, icdate
 4567 FORMAT(/'===> BUFR MESSAGE NO.  1 IS A DUMMY MESSAGE CONTAINING ',
     $ 'ONLY CENTER DATE (',i5,4i3,') - NO DATA - GO ON TO NEXT ',
     $ 'MESSAGE'/)
            ELSE IF(irec.EQ.2)  THEN
               print 4568, iddate
 4568 FORMAT(/'===> BUFR MESSAGE NO.  2 IS A DUMMY MESSAGE CONTAINING ',
     $ 'ONLY  DUMP  DATE (',i5,4i3,') - NO DATA - GO ON TO NEXT ',
     $ 'MESSAGE'/)
            ELSE
               print 4569, irec,mdate
 4569 FORMAT(/'===> BUFR MESSAGE NO.',i3,' (DATE:',i5,3i3,'  0) ',
     $ 'CONTAINS ZERO REPORTS FOR SOME UNEXPLAINED REASON - GO ON TO ',
     $ 'NEXT MESSAGE'/)
            END IF
         END IF
         index = 0
         GO TO 10
      END IF
C-----------------------------------------------------------------------
      IF(iprint.GT.1)  print *, 'READY TO PROCESS NEW DECODED REPORT'
C***********************************************************************
C            A SINGLE REPORT HAS BEEN SUCCESSFULLY DECODED
C***********************************************************************
      index = index + 1
      IF(iprint.GE.1)  print *, 'WORKING WITH SUBSET NUMBER ',index
      RETURN
      END
C> @brief Initializes the output array for a report.
C> @author Dennis Keyser @date 1996-12-16
 
C> Initializes the output array which holds a single report in the quasi-office
C> note 29 unpacked format to all missing.
C>
C> ### Program History Log:
C> Date | Programmer | Comment
C> -----|------------|--------
C> 1996-12-16 | Dennis Keyser NP22 | Initial.
C> @param[in] ITP the type of report that has been decoded {=1 - wind profiler, =2 - goes sndg, =3 - nexrad(vad) wind}
C> @param[out] RDATA single report returned an a quasi-office note 29 unpacked format; all data are missing
C>
C> @author Dennis Keyser @date 1996-12-16
      SUBROUTINE unpk7702(RDATA,ITP)
      REAL  RDATA(*),RDATX(1200)
      INTEGER  IDATA(1200),IRTYP(3)
      CHARACTER*8  COB
C
      SAVE
C
      equivalence(rdatx,idata),(cob,iob)
      DATA  xmsg/99999./,imsg/99999/,irtyp/71,61,72/
      rdatx(1)  = xmsg
      rdatx(2)  = xmsg
      idata(3)  = imsg
      rdatx(4)  = xmsg
      cob = '999999  '
      idata(5)  = iob
      cob = '9999    '
      idata(6)  = iob
      rdatx(7)  = xmsg
      idata(8)  = imsg
      idata(9)  =  irtyp(itp)
      idata(10) = imsg
      cob = '        '
      idata(11) = iob
      idata(12) = iob
C
C       ALL TYPES -- LOAD ZEROS INTO THE DEFINING WORD PAIRS
C
      idata(13:42) = 0
C
C       ALL TYPES -- LOAD MISSINGS INTO THE DATA PORTION
C
      rdatx(43:1200) = xmsg
      IF(itp.EQ.1)  THEN
C
C       PROFILER -- LOAD INTEGER MISSING WHERE APPROPRIATE
C          (Current limit of 104 Cat. 11 levels)
C
         idata(53:1200:11) = imsg
         idata(55:1200:11) = imsg
         idata(56:1200:11) = imsg
         idata(60:1200:11) = imsg
      ELSE  IF(itp.EQ.2)  THEN
C
C       GOES -- LOAD DEFAULT OF BLANK CHARACTERS INTO CAT. 12
C               LEVEL QUALITY MARKERS
C          (Current limit of 50 Cat. 12 levels)
C          (could be expanded if need be)
C
         idata(49:392:7) = iob
C
C       GOES -- LOAD DEFAULT OF BLANK CHARACTER INTO FIRST CAT. 08
C               LEVEL QUALITY MARKER
C          (Current limit of 9 Cat. 08 levels)
C          (could be expanded if need be)
C
         idata(395:419:3) = iob
C       GOES -- LOAD INTEGER MISSING INTO CAT. 13 LEVEL CHANNEL NUMBER
C            -- LOAD DEFAULT OF BLANK CHARACTER INTO CAT. 13 LEVEL
C               QUALITY MARKER
C          (Current limit of 60 Cat. 13 levels)
C          (could be expanded if need be)
C
         idata(420:599:3) = imsg
         idata(422:599:3) = iob
      ELSE  IF(itp.EQ.3)  THEN
C
C       VADWND -- LOAD DEFAULT OF BLANK CHARACTER INTO HGHT CAT. 04
C                 LEVEL QUALITY MARKER
C            (Current limit of 70 Cat. 04 levels)
C            (could be expanded if need be)
C
         idata(46:1200:4) = iob
      END IF
      rdata(1:1200) = rdatx(1:1200)
      RETURN
      END
C> @brief Fills in header in o-put array - pflr rpt.
C> @author Dennis Keyser @date 2002-03-05
 
C> For report (subset) read out of bufr message (passed in
C> internally via bufrlib storage), calls bufrlib routine to decode
C> header data for wind profiler report.  header is then filled into
C> the output array which holds a single wind profiler report in the
C> quasi-office note 29 unpacked format.
C>
C> ### Program History Log:
C> Date | Programmer | Comment
C> -----|------------|--------
C> 1996-12-16 | Dennis Keyser NP22 | Initial.
C> 2002-03-05 | Dennis Keyser | Accounts for changes in input proflr (wind profiler) bufr dump file after 3/2002: mnemonic "npsm" is no longer available, mnemonic "tpse" replaces "tpmi" (avg. time in minutes still output) (will still work properly for input proflr dump files prior to 3/2002)
C>
C> @param[in] LUNIT Fortran unit number for input data file
C> @param[inout] RDATA Single wind profiler report in a quasi-office note 29 unpacked format with [out] header information filled in [in] all data initialized as missing
C> @param[out] IRET Return code as described in w3unpk77 docblock
C>
C> @author Dennis Keyser @date 2002-03-05
      SUBROUTINE unpk7703(LUNIT,RDATA,IRET)
      CHARACTER*6   STNID
      CHARACTER*8   COB
      CHARACTER*35  HDR1,HDR2
      INTEGER  IDATA(1200)
      REAL(8) HDR_8(16)
      REAL  HDR(16),RDATA(*),RDATX(1200)
      COMMON /pk77bb/kdate(8),ldate(8),iprint
 
      SAVE
 
      equivalence(rdatx,idata),(cob,iob)
      DATA  xmsg/99999./,imsg/99999/
      DATA  hdr1/'CLAT CLON TSIG SELV NPSM TPSE WMOB '/
      DATA  hdr2/'WMOS YEAR MNTH DAYS HOUR MINU TPMI '/
      rdatx(1:1200) = rdata(1:1200)
      hdr_8 = 10.0e10
      CALL ufbint(lunit,hdr_8,16,1,nlev,hdr1//hdr2);hdr=hdr_8
      IF(nlev.NE.1)  THEN
C.......................................................................
C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED --
C  SET IRET = 6 AND RETURN
         print 217, nlev
  217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',i5,') ',
     $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 6'/)
         iret = 6
         RETURN
C.......................................................................
      END IF
 
C         LATITUDE (STORED AS REAL)
 
      m = 1
      IF(iprint.GT.1)  print 199, hdr(1),m
  199 FORMAT(5x,'HDR HERE IS: ',f17.4,'; INDEX IS: ',i3)
      IF(hdr(1).LT.xmsg)  THEN
         rdatx(1) = nint(hdr(1) * 100.)
         nnnnn = 1
         IF(iprint.GT.1)  print 198, nnnnn,rdatx(nnnnn)
  198 FORMAT(5x,'DATA(',i5,') STORED AS: ',f10.2)
      ELSE
         iret = 2
         print 102
  102    FORMAT(' *** W3UNPK77 ERROR: LAT MISSING FOR WIND PROFILER ',
     $    'REPORT'/)
         RETURN
      END IF
 
C         LONGITUDE (STORED AS REAL)
 
      m = 2
      IF(iprint.GT.1)  print 199, hdr(2),m
      IF(hdr(2).LT.xmsg)  THEN
         rdatx(2) = nint(mod((36000.-(hdr(2)*100.)),36000.))
         nnnnn = 2
         IF(iprint.GT.1)  print 198, nnnnn,rdatx(nnnnn)
      ELSE
         iret = 2
         print 104
  104    FORMAT(' *** W3UNPK77 ERROR: LON MISSING FOR WIND PROFILER ',
     $    'REPORT'/)
         RETURN
      END IF
 
C         TIME SIGNIFICANCE (STORED AS INTEGER)
 
      m = 3
      IF(iprint.GT.1)  print 199, hdr(3),m
      IF(hdr(3).LT.xmsg)  idata(3) = nint(hdr(3))
      nnnnn = 3
      IF(iprint.GT.1)  print 197, nnnnn,idata(nnnnn)
  197 FORMAT(5x,'IDATA(',i5,') STORED AS: ',i10)
 
C         STATION ELEVATION (FROM REPORTED STN. HGHT; STORED IN OUTPUT)
C          (STORED AS REAL)
 
      m = 4
      IF(iprint.GT.1)  print 199, hdr(4),m
      IF(hdr(4).LT.xmsg)  rdatx(7) = nint(hdr(4))
      nnnnn = 7
      IF(iprint.GT.1)  print 198, nnnnn,rdatx(nnnnn)
 
C         SUBMODE INFORMATION
C         EDITION NUMBER (ALWAYS = 2)
C         (PACKED AS SUBMODE TIMES 10 PLUS EDITION NUMBER - INTEGER)
C          {NOTE: After 3/2002, the submode information is no longer
C                  available and is stored as missing (3).}
 
      m = 5
      iedtn = 2
      idata(8) = (3 * 10) + iedtn
      IF(iprint.GT.1)  print 199, hdr(5),m
      IF(hdr(5).LT.xmsg)  idata(8) = (nint(hdr(5)) * 10) + iedtn
      nnnnn = 8
      IF(iprint.GT.1)  print 197, nnnnn,idata(nnnnn)
 
C         AVERAGING TIME (STORED AS INTEGER)
C        (NOTE: Prior to 3/2002, this is decoded in minutes, after
C                3/2002 this is decoded in seconds - in either case
C                it is stored in minutes)
 
      m = 6
      IF(iprint.GT.1)  print 199, hdr(6),m
      IF(iprint.GT.1)  print 199, hdr(14),m
      IF(hdr(6).LT.xmsg)  THEN
         idata(10) = nint(hdr(6)/60.)
      ELSE  IF(hdr(14).LT.xmsg)  THEN
         idata(10) = nint(hdr(14))
      END IF
      nnnnn = 10
      IF(iprint.GT.1)  print 197, nnnnn,idata(nnnnn)
C-----------------------------------------------------------------------
 
C         STATION IDENTIFICATION (STORED AS CHARACTER)
C         (OBTAINED FROM ENCODED WMO BLOCK/STN NUMBERS)
 
      stnid = '      '
 
C            WMO BLOCK NUMBER (STORED AS CHARACTER)
 
      m = 7
      IF(iprint.GT.1)  print 199, hdr(7),m
      IF(hdr(7).LT.xmsg)  WRITE(stnid(1:2),'(I2.2)')  nint(hdr(7))
 
C            WMO STATION NUMBER (STORED AS CHARACTER)
 
      m = 8
      IF(iprint.GT.1)  print 199, hdr(8),m
      IF(hdr(8).LT.xmsg)  WRITE(stnid(3:5),'(I3.3)')  nint(hdr(8))
      cob(1:4) = stnid(1:4)
      idata(11) = iob
      nnnnn = 11
      IF(iprint.GT.1)  print 196, nnnnn,cob(1:4)
  196 FORMAT(5x,'IDATA(',i5,') STORED IN CHARACTER AS: "',a4,'"')
      cob(1:4) = stnid(5:6)//'  '
      idata(12) = iob
      nnnnn = 12
      IF(iprint.GT.1)  print 196, nnnnn,cob(1:4)
 
cvvvvvdak port
C         LOAD THE YEAR/MONTH (STORED AS CHARACTER IN FORM YYMM)
caaaaadak port
 
      m = 9
      IF(iprint.GT.1)  print 199, hdr(9),m
      iyear = imsg
      IF(hdr(9).LT.xmsg) iyear = nint(hdr(9))
      m = 10
      IF(iprint.GT.1)  print 199, hdr(10),m
      IF(hdr(10).LT.xmsg.AND.iyear.LT.imsg)  THEN
cvvvvvdak port
         iyear = mod(iyear,100)
caaaaadak port
         iyear = nint(hdr(10)) + (iyear * 100)
cvvvvvdak port
cdak     WRITE(COB,'(I6.6,2X)')  IYEAR
         WRITE(cob,'(I4.4,4X)')  iyear
caaaaadak port
         idata(5) = iob
         nnnnn = 5
         IF(iprint.GT.1)  print 9196, nnnnn,cob(1:6)
 9196 FORMAT(5x,'IDATA(',i5,') STORED IN CHARACTER AS: "',a6,'"')
      ELSE
         GO TO 30
      END IF
 
C         LOAD THE DAY/HOUR (STORED AS CHARACTER IN FORM DDHH)
C          AND THE OBSERVATION TIME (STORED AS REAL)
 
      m = 11
      IF(iprint.GT.1)  print 199, hdr(11),m
      iday = imsg
      IF(hdr(11).LT.xmsg)  iday = nint(hdr(11))
      m = 12
      IF(iprint.GT.1)  print 199, hdr(12),m
      IF(hdr(12).LT.xmsg.AND.iday.LT.imsg)  THEN
         ihrt = nint(hdr(12))
         m = 13
         IF(iprint.GT.1)  print 199, hdr(13),m
         IF(hdr(13).GE.xmsg)  GO TO 30
         rmnt = hdr(13)
         rdatx(4) = nint((ihrt * 100.) + (rmnt * 100.)/60.)
         nnnnn = 4
         IF(iprint.GT.1)  print 198, nnnnn,rdatx(nnnnn)
         ihrt = ihrt + (iday * 100)
         WRITE(cob(1:4),'(I4.4)')  ihrt
         idata(6) = iob
         nnnnn = 6
         IF(iprint.GT.1)  print 196, nnnnn,cob(1:4)
      ELSE
         GO TO 30
      END IF
      rdata(1:1200) = rdatx(1:1200)
      RETURN
   30 CONTINUE
      iret = 4
      RETURN
      END
C> @brief Fills cat.10 into o-put array - pflr rpt
C> @author Dennis Keyser @date 2002-03-05
 
C> For report (subset) read out of bufr message (passed in
C> internally via bufrlib storage), calls bufrlib routine to decode
C> surface data for wind profiler report. Surface data are then
C> filled into the output array as category 10. The ouput array
C> holds a single wind profiler report in the quasi-office note 29
C> unpacked format.
C>
C> ### Program History Log:
C> Date | Programmer | Comment
C> -----|------------|--------
C> 1996-12-16 | Dennis Keyser NP22 | Initial.
C> 2002-03-05 | Dennis Keyser | Accounts for changes in input proflr (wind profiler) bufr dump file after 3/2002: surface data now all missing (mnemonics "pmsl", "wdir1","wspd1", "tmdb", "rehu", "reqv" no longer available) (will still work properly for input proflr dump files prior to 3/2002)
C>
C> @param[in] LUNIT Fortran unit number for input data file
C> @param[inout] RDATA Single wind profiler report in a quasi-office note 29 unpacked format with [out] header information filled in [in] all data initialized as missing
C>
C> @remark Called by subroutine w3unpkb7.  after 3/2002, there is no surface data available.
C>
C$$$
      SUBROUTINE unpk7704(LUNIT,RDATA)
      CHARACTER*40  SRFC
      INTEGER  IDATA(1200)
      REAL(8) SFC_8(8)
      REAL  SFC(8),RDATA(*),RDATX(1200)
      COMMON /pk77bb/kdate(8),ldate(8),iprint
 
      SAVE
 
      equivalence(rdatx,idata)
      DATA  xmsg/99999./
      DATA  srfc/'PMSL WDIR1 WSPD1 TMDB REHU REQV         '/
      rdatx(1:1200) = rdata(1:1200)
      sfc_8 = 10.0e10
      CALL ufbint(lunit,sfc_8,8,1,nlev,srfc);sfc=sfc_8
      IF(nlev.NE.1)  THEN
C.......................................................................
C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED --
         print 217, nlev
  217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',i5,') ',
     $ 'IS NOT WHAT IS EXPECTED (1) - NO SFC DATA PROCESSED'/)
         GO TO 99
C.......................................................................
      END IF
 
C       MSL PRESSURE (STORED AS REAL)
 
      m = 1
      IF(iprint.GT.1)  print 199, sfc(1),m
  199 FORMAT(5x,'SFC HERE IS: ',f17.4,'; INDEX IS: ',i3)
      IF((sfc(1)*0.1).LT.xmsg)  rdatx(43) = nint(sfc(1) * 0.1)
      nnnnn = 43
      IF(iprint.GT.1)  print 198, nnnnn,rdatx(43)
  198 FORMAT(5x,'RDATA(',i5,') STORED AS: ',f10.2)
 
C       SURFACE HORIZONTAL WIND DIRECTION (STORED AS REAL)
 
      m = 2
      IF(iprint.GT.1)  print 199, sfc(2),m
      IF(sfc(2).LT.xmsg)  rdatx(43+2) = nint(sfc(2))
      nnnnn = 43 + 2
      IF(iprint.GT.1)  print 198, nnnnn,rdatx(43+2)
 
C       SURFACE HORIZONTAL WIND SPEED (STORED AS REAL)
 
      m = 3
      IF(iprint.GT.1)  print 199, sfc(3),m
      IF(sfc(3).LT.xmsg)  rdatx(43+3) = nint(sfc(3) * 10.)
      nnnnn = 43 + 3
      IF(iprint.GT.1)  print 198, nnnnn,rdatx(43+3)
 
C       SURFACE TEMPERATURE (STORED AS REAL)
 
      m = 4
      IF(iprint.GT.1)  print 199, sfc(4),m
      IF(sfc(4).LT.xmsg)  rdatx(43+4) = nint(sfc(4) * 10.)
      nnnnn = 43 + 4
      IF(iprint.GT.1)  print 198, nnnnn,rdatx(43+4)
 
C       RELATIVE HUMIDITY (STORED AS REAL)
 
      m = 5
      IF(iprint.GT.1)  print 199, sfc(5),m
      IF(sfc(5).LT.xmsg)  rdatx(43+5) = nint(sfc(5))
      nnnnn = 43 + 5
      IF(iprint.GT.1)  print 198, nnnnn,rdatx(43+5)
 
C       RAINFALL RATE (STORED AS REAL)
 
      m = 6
      IF(iprint.GT.1)  print 199, sfc(6),m
      IF(sfc(6).LT.xmsg)  rdatx(43+6) = nint(sfc(6) * 1.e7)
      nnnnn = 43 + 6
      IF(iprint.GT.1)  print 198, nnnnn,rdatx(43+6)
 
C       SET CATEGORY COUNTERS FOR SURFACE DATA
 
      idata(35) = 1
      idata(36) = 43
   99 CONTINUE
      IF(iprint.GT.1)  print *, 'IDATA(35)=',idata(35),'; IDATA(36)=',
     $ idata(36)
      rdata(1:1200) = rdatx(1:1200)
      RETURN
      END
C> @brief Fills cat.11 into o-put array - pflr rpt
C> @author Dennis Keyser @date 2002-03-05
 
C> For report (subset) read out of bufr message (passed in
C> internally via bufrlib storage), calls bufrlib routine to decode
C> upper-air data for wind profiler report.  upper-air data are then
C> filled into the output array as category 11.  the ouput array
C> holds a single wind profiler report in the quasi-office note 29
C> unpacked format.
C>
C> ### Program History Log:
C> Date | Programmer | Comment
C> -----|------------|--------
C> 1996-12-16 | Dennis Keyser NP22 | Initial.
C> 1998-07-09 | Dennis Keyser | Modified wind profiler cat. 11 (height, horiz. significance, vert. significance) processing to account for updates to bufrtable mnemonics in /dcom
C> 2002-03-05 | Dennis Keyser | Accounts for changes in input proflr (wind profiler) bufr dump file after 3/2002: mnemonics "acavh", "acavv", "spp0", and "nphl" no longer available; (will still work properly for input proflr dump files prior to 3/2002)
C>
C> @param[in] LUNIT Fortran unit number for input data file
C> @param[inout] RDATA Single wind profiler report in a quasi-office note 29 unpacked format with [out] header information filled in [in] all data initialized as missing
C>
C$$$
      SUBROUTINE unpk7705(LUNIT,RDATA)
      CHARACTER*31  UAIR1,UAIR2
      CHARACTER*16  UAIR3
      INTEGER  IDATA(1200)
      REAL(8) UAIR_8(16,255)
      REAL  UAIR(16,255),RDATA(*),RDATX(1200)
      COMMON /pk77bb/kdate(8),ldate(8),iprint
 
      SAVE
 
      equivalence(rdatx,idata)
      DATA  xmsg/99999./
      DATA  uair1/'HEIT WDIR WSPD NPQC WCMP ACAVH '/
      DATA  uair2/'ACAVV SPP0 SDHS SDVS NPHL      '/
      DATA  uair3/'HAST ACAV1 ACAV2'/
      rdatx(1:1200) = rdata(1:1200)
      nsfc = 0
      ilvl = 0
      ilc =  0
C FIRST UPPER-AIR LEVEL IS THE SURFACE INFORMATION
      IF(iprint.GT.1)  print 1078, ilc,ilvl
 1078 FORMAT(' ATTEMPTING 1ST (SFC) LVL WITH ILC =',i5,'; NO. LEVELS ',
     $ 'PROCESSED TO NOW =',i5)
      rdatx(50+ilc) = rdatx(7)
      IF(iprint.GT.1)  print 198, 50+ilc,rdatx(50+ilc)
  198 FORMAT(5x,'RDATA(',i5,') STORED AS: ',f10.2)
      IF(rdatx(50+ilc).LT.xmsg)  nsfc = 1
      IF(idata(35).GE.1)  THEN
         rdatx(50+ilc+1) = rdatx(idata(36)+2)
         rdatx(50+ilc+2) = rdatx(idata(36)+3)
      END IF
      IF(iprint.GT.1)  print 198, 50+ilc+1,rdatx(50+ilc+1)
      IF(rdatx(50+ilc+1).LT.xmsg)  nsfc = 1
      IF(iprint.GT.1)  print 198, 50+ilc+2,rdatx(50+ilc+2)
      IF(rdatx(50+ilc+2).LT.xmsg)  nsfc = 1
      ilvl = ilvl + 1
      ilc = ilc + 11
      IF(iprint.GT.1) print *,'HAVE COMPLETED LEVEL ',ilvl,' WITH ',
     $ 'NSFC=',nsfc,'; GOING INTO NEXT LEVEL WITH ILC=',ilc
      uair_8 = 10.0e10
      CALL ufbint(lunit,uair_8,16,255,nlev,uair1//uair2//uair3)
      uair=uair_8
      IF(nlev.EQ.0)  THEN
C.......................................................................
C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO --
         IF(nsfc.EQ.0)  THEN
C ... NO UPPER AIR DATA PROCESSED
            print 217
  217       FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA PROCESSED FOR THIS',
     $       ' REPORT -- NLEV = 0 AND NSFC = 0'/)
            GO TO 99
         ELSE
C ... ONLY FIRST (SURFACE) UPPER AIR LEVEL DATA PROCESSED
            print 218
  218 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA ABOVE FIRST (SURFACE) ',
     $ 'LEVEL PROCESSED FOR THIS REPORT -- NLEV = 0 AND NSFC > 0'/)
            GO TO 98
         END IF
C.......................................................................
      END IF
      IF(iprint.GT.1)  print 1068, nlev
 1068 FORMAT(' THIS REPORT CONTAINS ',i3,' LEVELS OF DATA (NOT ',
     $ 'INCLUDING BOTTOM -SURFACE- LEVEL)')
      DO i = 1,nlev
         IF(iprint.GT.1)  print 1079, ilc,ilvl
 1079 FORMAT(' ATTEMPTING NEW LEVEL WITH ILC =',i5,'; NO. LEVELS ',
     $ 'PROCESSED TO NOW =',i5)
 
C       HEIGHT ABOVE SEA-LEVEL (STORED AS REAL)
C        (NOTE: At one time, possibly even now, the height above sea
C               level was erroneously stored under mnemonic "HAST"
C               when it should have been stored under mnemonic "HEIT".
C               ("HAST" is defined as the height above the station.)
C               Will test first for valid data in "HEIT" - if missing,
C               then will use data in "HAST" - this will allow this
C               routine to transition w/o change when the fix is made.)
 
         IF(uair(1,i).LT.xmsg)  THEN
            m = 1
            IF(iprint.GT.1)  print 199, uair(1,i),m
  199 FORMAT(5x,'UAIR HERE IS: ',f17.4,'; INDEX IS: ',i3)
            rdatx(50+ilc) = nint(uair(1,i))
         ELSE
            m = 12
            IF(iprint.GT.1)  print 199, uair(12,i),m
            IF(uair(12,i).LT.xmsg)  rdatx(50+ilc) = nint(uair(12,i))
         END IF
         IF(iprint.GT.1)  print 198, 50+ilc,rdatx(50+ilc)
         ilvl = ilvl + 1
 
C       HORIZONTAL WIND DIRECTION (STORED AS REAL)
 
         m = 2
         IF(iprint.GT.1)  print 199, uair(2,i),m
         IF(uair(2,i).LT.xmsg)  rdatx(50+ilc+1) = nint(uair(2,i))
         IF(iprint.GT.1)  print 198, 50+ilc+1,rdatx(50+ilc+1)
 
C       HORIZONTAL WIND SPEED (STORED AS REAL)
 
         m = 3
         IF(iprint.GT.1)  print 199, uair(3,i),m
         IF(uair(3,i).LT.xmsg)  rdatx(50+ilc+2) =nint(uair(3,i) * 10.)
         IF(iprint.GT.1)  print 198, 50+ilc+2,rdatx(50+ilc+2)
 
C       QUALITY CODE (STORED AS INTEGER)
 
         m = 4
         IF(iprint.GT.1)  print 199, uair(4,i),m
         IF(uair(4,i).LT.xmsg)  idata(50+ilc+3) = nint(uair(4,i))
         IF(iprint.GT.1)  print 197, 50+ilc+3,idata(50+ilc+3)
  197 FORMAT(5x,'IDATA(',i5,') STORED AS: ',i10)
 
C       VERTICAL WIND COMPONENT (W) (STORED AS REAL)
 
         m = 5
         IF(iprint.GT.1)  print 199, uair(5,i),m
         IF(uair(5,i).LT.xmsg)  rdatx(50+ilc+4) = nint(uair(5,i) * 100.)
         IF(iprint.GT.1)  print 198, 50+ilc+4,rdatx(50+ilc+4)
 
C       HORIZONTAL CONSENSUS NUMBER (STORED AS INTEGER)
C        (NOTE: Prior to 2/18/1999, the horizonal consensus number was
C                stored under mnemonic "ACAV1".
C               From 2/18/1999 through 3/2002, the horizontal consensus
C                number was stored under mnemonic "ACAVH".
C               After 3/2002, the horizontal consensus number is no
C                longer stored.
C               Will test first for valid data in "ACAVH" - if missing,
C                then will test for data in "ACAV1" - this will allow
C                this routine to work properly with historical data.)
 
         IF(iprint.GT.1)  print 199, uair(6,i),m
         IF(iprint.GT.1)  print 199, uair(13,i),m
         IF(uair(6,i).LT.xmsg)  THEN
            m = 6
            idata(50+ilc+5) = nint(uair(6,i))
         ELSE
            m = 13
            IF(uair(13,i).LT.xmsg)  idata(50+ilc+5) = nint(uair(13,i))
         END IF
         IF(iprint.GT.1)  print 197, 50+ilc+5,idata(50+ilc+5)
 
C       VERTICAL CONSENSUS NUMBER (STORED AS INTEGER)
C        (NOTE: Prior to 2/18/1999, the vertical consensus number was
C                stored under mnemonic "ACAV2".
C               From 2/18/1999 through 3/2002, the vertical consensus
C                number was stored under mnemonic "ACAVV".
C               After 3/2002, the vertical consensus number is no
C                longer stored.
C               Will test first for valid data in "ACAVV" - if missing,
C                then will test for data in "ACAV2" - this will allow
C                this routine to work properly with historical data.)
 
         IF(iprint.GT.1)  print 199, uair(7,i),m
         IF(iprint.GT.1)  print 199, uair(14,i),m
         IF(uair(7,i).LT.xmsg)  THEN
            m = 7
            idata(50+ilc+6) = nint(uair(7,i))
         ELSE
            m = 14
            IF(uair(14,i).LT.xmsg)  idata(50+ilc+6) = nint(uair(14,i))
         END IF
         IF(iprint.GT.1)  print 197, 50+ilc+6,idata(50+ilc+6)
 
C       SPECTRAL PEAK POWER (STORED AS REAL)
C        (NOTE: After 3/2002, the spectral peak power is no longer
C                stored.)
 
         m = 8
         IF(iprint.GT.1)  print 199, uair(8,i),m
         IF(uair(8,i).LT.xmsg)  rdatx(50+ilc+7) = nint(uair(8,i))
         IF(iprint.GT.1)  print 198, 50+ilc+7,rdatx(50+ilc+7)
 
C       HORIZONTAL WIND SPEED STANDARD DEVIATION (STORED AS REAL)
 
         m = 9
         IF(iprint.GT.1)  print 199, uair(9,i),m
         IF(uair(9,i).LT.xmsg)  rdatx(50+ilc+8)=nint(uair(9,i) * 10.)
         IF(iprint.GT.1)  print 198, 50+ilc+8,rdatx(50+ilc+8)
 
C       VERTICAL WIND COMPONENT STANDARD DEVIATION (STORED AS REAL)
 
         m = 10
         IF(iprint.GT.1)  print 199, uair(10,i),m
         IF(uair(10,i).LT.xmsg)  rdatx(50+ilc+9) =nint(uair(10,i) * 10.)
         IF(iprint.GT.1)  print 198, 50+ilc+9,rdatx(50+ilc+9)
 
C       MODE INFORMATION (STORED AS INTEGER)
C        (NOTE: After 3/2002, the mode information is no longer stored.)
 
         m = 11
         IF(iprint.GT.1)  print 199, uair(11,i),m
         IF(uair(11,i).LT.xmsg)  idata(50+ilc+10) = nint(uair(11,i))
         IF(iprint.GT.1)  print 197, 50+ilc+10,idata(50+ilc+10)
C.......................................................................
         ilc = ilc + 11
         IF(iprint.GT.1)  print *,'HAVE COMPLETED LEVEL ',ilvl,
     $    '; GOING INTO NEXT LEVEL WITH ILC=',ilc
      ENDDO
 
C       SET CATEGORY COUNTERS FOR UPPER-AIR DATA
 
   98 CONTINUE
      idata(37) = ilvl
      idata(38) = 50
   99 CONTINUE
      IF(iprint.GT.1)  print *, 'NSFC=',nsfc,'; IDATA(37)=',idata(37),
     $ '; IDATA(38)=',idata(38)
      rdata(1:1200) = rdatx(1:1200)
      RETURN
      END
C> @brief Fills in header in o-put array - vadw rpt.
C> @author Dennis Keyser @date 1997-06-02
 
C> For report (subset) read out of bufr message (passed in
C> internally via bufrlib storage), calls bufrlib routine to decode
C> header data for nexrad (vad) wind report. Header is then filled
C> into the output array which holds a single vad wind report in the
C> quasi-office note 29 unpacked format.
C>
C> ### Program History Log:
C> Date | Programmer | Comment
C> -----|------------|--------
C> 1997-06-02 | Dennis Keyser NP22 | Initial.
C>
C> @param[in] LUNIT Fortran unit number for input data file
C> @param[inout] RDATA Single wind profiler report in a quasi-office note 29 unpacked format with [out] header information filled in [in] all data initialized as missing
C> @param[out] IRET Return code as described in w3unpk77 docblock
C>
C> @author Dennis Keyser @date 1997-06-02
      SUBROUTINE unpk7706(LUNIT,RDATA,IRET)
      CHARACTER*8   STNID,COB
      CHARACTER*45  HDR1
      INTEGER  IDATA(1200)
      REAL(8) HDR_8(9)
      REAL  HDR(9),RDATA(*),RDATX(1200)
      COMMON /pk77bb/kdate(8),ldate(8),iprint
 
      SAVE
 
      equivalence(rdatx,idata),(stnid,hdr_8(4)),(cob,iob)
      DATA  xmsg/99999./,imsg/99999/
      DATA  hdr1/'CLAT CLON SELV RPID YEAR MNTH DAYS HOUR MINU '/
      rdatx(1:1200) = rdata(1:1200)
      hdr_8 = 10.0e10
      CALL ufbint(lunit,hdr_8,9,1,nlev,hdr1);hdr=hdr_8
      IF(nlev.NE.1)  THEN
C.......................................................................
C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED --
C  SET IRET = 6 AND RETURN
         print 217, nlev
  217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',i5,') ',
     $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 6'/)
         iret = 6
         RETURN
C.......................................................................
      END IF
 
C         LATITUDE (STORED AS REAL)
 
      m = 1
      IF(iprint.GT.1)  print 199, hdr(1),m
  199 FORMAT(5x,'HDR HERE IS: ',f17.4,'; INDEX IS: ',i3)
      IF(hdr(1).LT.xmsg)  THEN
         rdatx(1) = nint(hdr(1) * 100.)
         nnnnn = 1
         IF(iprint.GT.1)  print 198, nnnnn,rdatx(nnnnn)
  198 FORMAT(5x,'RDATA(',i5,') STORED AS: ',f10.2)
      ELSE
         iret = 2
         print 102
  102    FORMAT(' *** W3UNPK77 ERROR: LAT MISSING FOR VAD WIND REPORT'/)
         RETURN
      END IF
 
C         LONGITUDE (STORED AS REAL)
 
      m = 2
      IF(iprint.GT.1)  print 199, hdr(2),m
      IF(hdr(2).LT.xmsg)  THEN
         rdatx(2) = nint(mod((36000.-(hdr(2)*100.)),36000.))
         nnnnn = 2
         IF(iprint.GT.1)  print 198, nnnnn,rdatx(nnnnn)
      ELSE
         iret = 2
         print 104
  104    FORMAT(' *** W3UNPK77 ERROR: LON MISSING FOR VAD WIND REPORT'/)
         RETURN
      END IF
 
C         STATION ELEVATION (FROM REPORTED STN. HGHT; STORED IN OUTPUT)
C          (STORED AS REAL)
 
      m = 3
      IF(iprint.GT.1)  print 199, hdr(3),m
      IF(hdr(3).LT.xmsg)  rdatx(7) = nint(hdr(3))
      nnnnn = 7
      IF(iprint.GT.1)  print 198, nnnnn,rdatx(nnnnn)
 
C         STATION IDENTIFICATION (STORED AS CHARACTER)
C            ('99'//LAST 3-CHARACTERS OF PRODUCT SOURCE ID//'   ')
 
      m = 4
      IF(iprint.GT.1)  print 299, stnid,m
  299 FORMAT(5x,'HDR HERE IS: ',9x,a8,'; INDEX IS: ',i3)
      cob(1:4) = '99'//stnid(2:3)
      idata(11) = iob
      nnnnn = 11
      IF(iprint.GT.1)  print 196, nnnnn,cob(1:4)
  196 FORMAT(5x,'IDATA(',i5,') STORED IN CHARACTER AS: "',a4,'"')
      cob(1:4) = stnid(4:4)//'   '
      idata(12) = iob
      nnnnn = 12
      IF(iprint.GT.1)  print 196, nnnnn,cob(1:4)
 
cvvvvvdak port
C         LOAD THE YEAR/MONTH (STORED AS CHARACTER IN FORM YYMM)
caaaaadak port
 
      m = 5
      IF(iprint.GT.1)  print 199, hdr(5),m
      iyear = imsg
      IF(hdr(5).LT.xmsg) iyear = nint(hdr(5))
      m = 6
      IF(iprint.GT.1)  print 199, hdr(6),m
      IF(hdr(6).LT.xmsg.AND.iyear.LT.imsg)  THEN
cvvvvvdak port
         iyear = mod(iyear,100)
caaaaadak port
         iyear = nint(hdr(6)) + (iyear * 100)
cvvvvvdak port
cdak     WRITE(COB,'(I6.6,2X)')  IYEAR
         WRITE(cob,'(I4.4,4X)')  iyear
caaaaadak port
         idata(5) = iob
         nnnnn = 5
         IF(iprint.GT.1)  print 9196, nnnnn,cob(1:6)
 9196 FORMAT(5x,'IDATA(',i5,') STORED IN CHARACTER AS: "',a6,'"')
      ELSE
         GO TO 30
      END IF
 
C         LOAD THE DAY/HOUR (STORED AS CHARACTER IN FORM DDHH)
C          AND THE OBSERVATION TIME (STORED AS REAL)
 
      m = 7
      IF(iprint.GT.1)  print 199, hdr(7),m
      iday = imsg
      IF(hdr(7).LT.xmsg)  iday = nint(hdr(7))
      m = 8
      IF(iprint.GT.1)  print 199, hdr(8),m
      IF(hdr(8).LT.xmsg.AND.iday.LT.imsg)  THEN
         ihrt = nint(hdr(8))
         m = 9
         IF(iprint.GT.1)  print 199, hdr(9),m
         IF(hdr(9).GE.xmsg)  GO TO 30
         rmnt = hdr(9)
         rdatx(4) = nint((ihrt * 100.) + (rmnt * 100.)/60.)
         nnnnn = 4
         IF(iprint.GT.1)  print 198, nnnnn,rdatx(nnnnn)
         ihrt = ihrt + (iday * 100)
         WRITE(cob(1:4),'(I4.4)')  ihrt
         idata(6) = iob
         nnnnn = 6
         IF(iprint.GT.1)  print 196, nnnnn,cob(1:4)
      ELSE
         GO TO 30
      END IF
      rdata(1:1200) = rdatx(1:1200)
      RETURN
   30 CONTINUE
      iret = 4
      RETURN
      END
C> @brief Fills cat. 4 into o-put array - vadw rpt
C> @author Dennis Keyser @date 1997-06-02
 
C> For report (subset) read out of bufr message (passed in
C> internally via bufrlib storage), calls bufrlib routine to decode
C> upper-air data for nexrad (vad) wind report. Upper-air data are
C> then filled into the output array as category 4. The ouput array
C> holds a single vad wind report in the quasi-office note 29
C> unpacked format.
C>
C> ### Program History Log:
C> Date | Programmer | Comment
C> -----|------------|--------
C> 1997-06-02 | Dennis Keyser NP22 | Initial.
C>
C> @param[in] LUNIT Fortran unit number for input data file
C> @param[inout] RDATA Single wind profiler report in a quasi-office note 29 unpacked format with [out] header information filled in [in] all data initialized as missing
C> @param[out] IRET Return code as described in w3unpk77 docblock
C>
C> @author Dennis Keyser @date 1997-06-02
      SUBROUTINE unpk7707(LUNIT,RDATA,IRET)
      CHARACTER*1  CRMS(0:12)
      CHARACTER*8  COB
      CHARACTER*25  UAIR1
      INTEGER  IDATA(1200)
      REAL(8) UAIR_8(5,255)
      REAL  UAIR(5,255),RDATA(*),RDATX(1200)
      COMMON /pk77bb/kdate(8),ldate(8),iprint
 
      SAVE
 
      equivalence(rdatx,idata),(cob,iob)
      DATA  xmsg/99999./
      DATA  uair1/'HEIT WDIR WSPD RMSW QMWN '/
      DATA  crms/' ','A',' ','B',' ','C',' ','D',' ','E',' ','F',' '/
      rdatx(1:1200) = rdata(1:1200)
      nsfc = 0
      ilvl = 0
      ilc =  0
C FIRST CATEGORY 4 LEVEL UPPER-AIR LEVEL CONTAINS ONLY HEIGHT (ELEV)
      IF(iprint.GT.1)  print 1078, ilc,ilvl
 1078 FORMAT(' ATTEMPTING 1ST (SFC) LVL WITH ILC =',i5,'; NO. LEVELS ',
     $ 'PROCESSED TO NOW =',i5)
      rdatx(43+ilc) = rdatx(7)
      IF(iprint.GT.1)  print 198, 43+ilc,rdatx(43+ilc)
  198 FORMAT(5x,'RDATA(',i5,') STORED AS: ',f10.2)
      IF(rdatx(43+ilc).LT.xmsg)  nsfc = 1
C NOTE: The following was added because of a problem on the sgi-ha
C       platform related to equivalencing character and non-character
C       -- for now the addition of these two lines will set the quality
C          mark for sfc. cat . 4 level to  the correct value of "    "
C          rather than to "9999" - Mary McCann notified SGI of this
C          problem on 08-21-1998
      cob = '        '
      idata(43+ilc+3) = iob
      ilvl = ilvl + 1
      ilc = ilc + 4
      IF(iprint.GT.1) print *,'HAVE COMPLETED LEVEL ',ilvl,' WITH ',
     $ 'NSFC=',nsfc,'; GOING INTO NEXT LEVEL WITH ILC=',ilc
      uair_8 = 10.0e10
      CALL ufbint(lunit,uair_8,5,255,nlev,uair1);uair=uair_8
      IF(nlev.EQ.0)  THEN
C.......................................................................
C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO --
         IF(nsfc.EQ.0)  THEN
C ... NO UPPER AIR DATA PROCESSED
            print 217
  217       FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA PROCESSED FOR THIS',
     $       ' REPORT -- NLEV = 0 AND NSFC = 0'/)
            GO TO 99
         ELSE
C ... ONLY FIRST (SURFACE) UPPER AIR LEVEL DATA PROCESSED
            print 218
  218 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA ABOVE FIRST (SURFACE) ',
     $ 'LEVEL PROCESSED FOR THIS REPORT -- NLEV = 0 AND NSFC > 0'/)
            GO TO 98
         END IF
C.......................................................................
      END IF
      IF(iprint.GT.1)  print 1068, nlev
 1068 FORMAT(' THIS REPORT CONTAINS ',i3,' LEVELS OF DATA (NOT ',
     $ 'INCLUDING BOTTOM -SURFACE- LEVEL)')
      DO i = 1,nlev
         IF(iprint.GT.1)  print 1079, ilc,ilvl
 1079 FORMAT(' ATTEMPTING NEW LEVEL WITH ILC =',i5,'; NO. LEVELS ',
     $ 'PROCESSED TO NOW =',i5)
 
C       HEIGHT ABOVE SEA-LEVEL (STORED AS REAL)
 
         m = 1
         IF(iprint.GT.1)  print 199, uair(1,i),m
  199 FORMAT(5x,'UAIR HERE IS: ',f17.4,'; INDEX IS: ',i3)
         IF(uair(1,i).LT.xmsg)  THEN
            rdatx(43+ilc) = nint(uair(1,i))
 
C       ... WE HAVE A VALID CATEGORY 4 LEVEL -- THERE IS A VALID HEIGHT
 
            ilvl = ilvl + 1
         ELSE
 
C       ... WE DO NOT HAVE A VALID CATEGORY 4 LEVEL -- THERE IS NO VALID
C            HEIGHT GO ON TO NEXT INPUT LEVEL
 
            IF(iprint.GT.1)  print *, 'HEIGHT MISSING ON INPUT ',
     $       ' LEVEL ',i,', ALL OTHER DATA SET TO MSG ON THIS LEVEL'
            GO TO 10
         END IF
         IF(iprint.GT.1)  print 198, 43+ilc,rdatx(43+ilc)
 
C       HORIZONTAL WIND DIRECTION (STORED AS REAL)
 
         m = 2
         IF(iprint.GT.1)  print 199, uair(2,i),m
         IF(uair(2,i).LT.xmsg)  rdatx(43+ilc+1) = nint(uair(2,i))
         IF(iprint.GT.1)  print 198, 43+ilc+1,rdatx(43+ilc+1)
 
C       HORIZONTAL WIND SPEED (STORED AS REAL) (OUTPUT STORED
C       AS METERS/SECOND TIMES TEN, NOT IN KNOTS AS ON29 WOULD
C       INDICATE FOR CAT. 4 WIND SPEED)
 
         m = 3
         IF(iprint.GT.1)  print 199, uair(3,i),m
         IF(uair(3,i).LT.xmsg)  rdatx(43+ilc+2) =nint(uair(3,i) * 10.)
         IF(iprint.GT.1)  print 198, 43+ilc+2,rdatx(43+ilc+2)
 
C       CONFIDENCE LEVEL (BASED ON RMS VECTOR WIND ERROR)
C       (NOTE: CONVERTED TO ORIGINAL LETTER INDICATOR AND PACKED
C        IN BYTE 4 OF CATEGORY 4 QUALITY MARKER LOCATION -- SEE
C        W3UNPK77 DOCBLOCK REMARKS 5. FOR UNPACKED VAD WIND REPORT
C        LAYOUT FOR VALUES
 
         m = 4
         IF(iprint.GT.1)  print 199, uair(4,i),m
         IF(uair(4,i).LT.xmsg)  THEN
 
C       ... CONVERT FROM M/S TO KNOTS
 
CDAKCDAK    KRMS = INT(1.93333 * UAIR(4,I))
            krms = int(1.9425 * uair(4,i))
            cob = '        '
            IF(krms.LT.13)  THEN
               cob(4:4) = crms(krms)
            ELSE
               cob(4:4) = 'G'
            END IF
            idata(43+ilc+3) = iob
         END IF
         IF(iprint.GT.1)  print 196, 43+ilc+3,cob(1:4)
  196 FORMAT(5x,'IDATA(',i5,') STORED IN CHARACTER AS: "',a4,'"')
 
C       ON29 WIND QUALITY MARKER (CURRENTLY NOT STORED)
 
         m = 5
         IF(iprint.GT.1)  print 199, uair(5,i),m
C.......................................................................
         ilc = ilc + 4
         IF(iprint.GT.1)  print *,'HAVE COMPLETED LEVEL ',ilvl,
     $    '; GOING INTO NEXT LEVEL WITH ILC=',ilc
 
   10    CONTINUE
      ENDDO
 
C       SET CATEGORY COUNTERS FOR UPPER-AIR DATA
 
   98 CONTINUE
      idata(19) = ilvl
   99 CONTINUE
      IF(idata(19).EQ.0)  THEN
         idata(20) = 0
         iret = 5
      ELSE
         idata(20) = 43
      END IF
      IF(iprint.GT.1)  print *, 'NSFC=',nsfc,'; IDATA(37)=',idata(37),
     $ '; IDATA(38)=',idata(38)
      rdata(1:1200) = rdatx(1:1200)
      RETURN
      END
C> @brief Fills in header in o-put array - goes snd
C> @author Dennis Keyser @date 1998-07-09
 
C> For report (subset) read out of bufr message (passed in
C> internally via bufrlib storage), calls bufrlib routine to decode
C> header data for goes sounding report. Header is then filled into
C> the output array which holds a single goes sounding report in the
C> quasi-office note 29 unpacked format.
C>
C> ### Program History Log:
C> Date | Programmer | Comment
C> -----|------------|--------
C> 1997-06-05 | Dennis Keyser NP22 | Initial.
C> 1998-07-09 | Dennis Keyser | Changed char. 6 of goes stnid to be unique for two different even or odd satellite id's (every other even or odd sat. id now gets same char. 6 tag)
C>
C> @param[in] LUNIT Fortran unit number for input data file
C> @param[inout] RDATA Single wind profiler report in a quasi-office note 29 unpacked format with [out] header information filled in [in] all data initialized as missing
C> @param[in] KOUNT Number of reports processed including this one
C> @param[out] IRET Return code as described in w3unpk77 docblock
C>
C> @author Dennis Keyser @date 1998-07-09
      SUBROUTINE unpk7708(LUNIT,RDATA,KOUNT,IRET)
      CHARACTER*1  C6TAG(3,0:3)
      CHARACTER*8   STNID,COB
      CHARACTER*35  HDR1,HDR2
      INTEGER  IDATA(1200)
      REAL(8) HDR_8(12)
      REAL  HDR(12),RDATA(*),RDATX(1200)
      COMMON /pk77bb/kdate(8),ldate(8),iprint
      COMMON /pk77ff/ifov(3),kntsat(250:260)
 
      SAVE
 
      equivalence(rdatx,idata),(cob,iob)
      DATA  xmsg/99999./,imsg/99999/
      DATA  hdr1/'CLAT CLON ACAV GSDP QMRK SAID YEAR '/
      DATA  hdr2/'MNTH DAYS HOUR MINU SECO           '/
 
 
C     CURRENT LIST OF  SATELLITE IDENTIFIERS (BUFR C.F. 0-01-007)
C     -----------------------------------------------------------
 
C       GOES  6 -- 250     GOES  9 -- 253     GOES 12 -- 256
C       GOES  7 -- 251     GOES 10 -- 254     GOES 13 -- 257
C       GOES  8 -- 252     GOES 11 -- 255     GOES 14 -- 258
 
C  IDSAT =       -- EVEN1 --   --- ODD1 --   -- EVEN2 --   --- ODD2 --
C   Sat. No. -   252,256,...   253,257,...   250,254,...   251,255,...
C  IRTYP =       CLR COR UNKN  CLR COR UNKN  CLR COR UNKN  CLR COR UNKN
C                --- --- ----  --- --- ----  --- --- ----  --- --- ----
 
      DATA c6tag/'I','J','?',  'L','M','?',  'O','P','?',  'Q','R','?' /
 
      rdatx(1:1200) = rdata(1:1200)
      hdr_8 = 10.0e10
      CALL ufbint(lunit,hdr_8,12,1,nlev,hdr1//hdr2);hdr=hdr_8
      IF(nlev.NE.1)  THEN
C.......................................................................
C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED --
C  SET IRET = 6 AND RETURN
         print 217, nlev
  217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',i5,') ',
     $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 6'/)
         iret = 6
         RETURN
C.......................................................................
      END IF
 
C         LATITUDE (STORED AS REAL)
 
      m = 1
      IF(iprint.GT.1)  print 199, hdr(1),m
  199 FORMAT(5x,'HDR HERE IS: ',f17.4,'; INDEX IS: ',i3)
      IF(hdr(1).LT.xmsg)  THEN
         rdatx(1) = nint(hdr(1) * 100.)
         nnnnn = 1
         IF(iprint.GT.1)  print 198, nnnnn,rdatx(nnnnn)
  198 FORMAT(5x,'RDATA(',i5,') STORED AS: ',f10.2)
      ELSE
         iret = 2
         print 102
  102    FORMAT(' *** W3UNPK77 ERROR: LAT MISSING FOR GOES SOUNDING'/)
         RETURN
      END IF
 
C         LONGITUDE (STORED AS REAL)
 
      m = 2
      IF(iprint.GT.1)  print 199, hdr(2),m
      IF(hdr(2).LT.xmsg)  THEN
         rdatx(2) = nint(mod((36000.-(hdr(2)*100.)),36000.))
         nnnnn = 2
         IF(iprint.GT.1)  print 198, nnnnn,rdatx(nnnnn)
      ELSE
         iret = 2
         print 104
  104    FORMAT(' *** W3UNPK77 ERROR: LON MISSING FOR GOES SOUNDING'/)
         RETURN
      END IF
 
C         NUMBER OF FIELDS OF VIEW - SAMPLE SIZE (STORED AS INTEGER)
 
      m = 3
      IF(iprint.GT.1)  print 199, hdr(3),m
      IF(hdr(3).LT.xmsg)  idata(3) = nint(hdr(3))
      nnnnn = 3
      IF(iprint.GT.1)  print 197, nnnnn,idata(nnnnn)
  197 FORMAT(5x,'IDATA(',i5,') STORED AS: ',i10)
 
C         STATION ELEVATION (FROM HEIGHT OF FIRST -SURFACE- LEVEL)
C          (STORED AS REAL) -- STORED IN SUBROUTINE UNPK7709
 
 
C         RETRIEVAL TYPE (GEOSTATIONARY SATELLITE DATA-PROCESSING
C         TECHNIQUE USED) (STORED AS INTEGER)
 
      m = 4
      IF(iprint.GT.1)  print 199, hdr(4),m
      IF(hdr(4).LT.xmsg)  idata(8) = nint(hdr(4))
      irtyp = 3
      IF(idata(8).EQ.21)  THEN
         irtyp = 1
      ELSE  IF(idata(8).EQ.23)  THEN
         irtyp = 2
      END IF
      nnnnn = 8
      IF(iprint.GT.1)  print 197, nnnnn,idata(nnnnn)
 
C         PRODUCT QUALITY BIT FLAGS - QUALITY INFO. (STORED AS INTEGER)
 
      m = 5
      IF(iprint.GT.1)  print 199, hdr(5),m
      IF(hdr(5).LT.xmsg)  idata(10) = nint(hdr(5))
      nnnnn = 10
      IF(iprint.GT.1)  print 197, nnnnn,idata(nnnnn)
 
C         STATION IDENTIFICATION (STORED AS CHARACTER)
C         (FIRST 5-CHARACTERS OBTAINED FROM 5-DIGIT COUNT NUMBER,
C          6'TH CHARACTER OBTAINED FROM SAT. ID/RETRIEVAL TYPE TAG)
 
      WRITE(stnid(1:5),'(I5.5)') min(kount,99999)
 
C DECODE THE SATELLITE ID
 
      m = 6
      idsat = 2
      IF(iprint.GT.1)  print 199, hdr(6),m
      IF(hdr(6).LT.xmsg)  THEN
         idsat = mod(nint(hdr(6)),4)
         IF(nint(hdr(6)).GT.249.AND.nint(hdr(6)).LT.260)  THEN
            kntsat(nint(hdr(6))) = kntsat(nint(hdr(6))) + 1
         ELSE
            kntsat(260) = kntsat(260) + 1
         END IF
      END IF
      IF(iprint.GT.1)  print 2197, idsat,irtyp
 2197 FORMAT(5x,'IDSAT IS: ',i10,', IRTYP IS: ',i10)
      stnid(6:6) = c6tag(irtyp,idsat)
      cob(1:4) = stnid(1:4)
      idata(11) = iob
      nnnnn = 11
      IF(iprint.GT.1)  print 196, nnnnn,cob(1:4)
  196 FORMAT(5x,'IDATA(',i5,') STORED IN CHARACTER AS: "',a4,'"')
      cob(1:4) = stnid(5:6)//'  '
      idata(12) = iob
      nnnnn = 12
      IF(iprint.GT.1)  print 196, nnnnn,cob(1:4)
 
cvvvvvdak port
C         LOAD THE YEAR/MONTH (STORED AS CHARACTER IN FORM YYMM)
caaaaadak port
 
      m = 7
      IF(iprint.GT.1)  print 199, hdr(7),m
      iyear = imsg
      IF(hdr(7).LT.xmsg) iyear = nint(hdr(7))
      m = 8
      IF(iprint.GT.1)  print 199, hdr(8),m
      IF(hdr(8).LT.xmsg.AND.iyear.LT.imsg)  THEN
cvvvvvdak port
         iyear = mod(iyear,100)
caaaaadak port
         iyear = nint(hdr(8)) + (iyear * 100)
cvvvvvdak port
cdak     WRITE(COB,'(I6.6,2X)')  IYEAR
         WRITE(cob,'(I4.4,4X)')  iyear
caaaaadak port
         idata(5) = iob
         nnnnn = 5
         IF(iprint.GT.1)  print 9196, nnnnn,cob(1:6)
 9196 FORMAT(5x,'IDATA(',i5,') STORED IN CHARACTER AS: "',a6,'"')
      ELSE
         GO TO 30
      END IF
 
C         LOAD THE DAY/HOUR (STORED AS CHARACTER IN FORM DDHH)
C          AND THE OBSERVATION TIME (STORED AS REAL)
 
      m = 9
      IF(iprint.GT.1)  print 199, hdr(9),m
      m = 10
      IF(iprint.GT.1)  print 199, hdr(10),m
      IF(hdr(10).LT.xmsg.AND.hdr(9).LT.imsg)  THEN
         m = 11
         IF(iprint.GT.1)  print 199, hdr(11),m
         IF(hdr(11).GE.xmsg)  GO TO 30
         m = 12
         IF(iprint.GT.1)  print 199, hdr(12),m
         IF(hdr(12).GE.xmsg)  GO TO 30
         rdatx(4) = nint(((hdr(10) + ((hdr(11) * 60.) + hdr(12))/3600.)
     $    * 100.) + 0.0000000001)
         nnnnn = 4
         IF(iprint.GT.1)  print 198, nnnnn,rdatx(nnnnn)
         idayhr = nint(hdr(10)) + (nint(hdr(9)) * 100)
         WRITE(cob(1:4),'(I4.4)')  idayhr
         idata(6) = iob
         nnnnn = 6
         IF(iprint.GT.1)  print 196, nnnnn,cob(1:4)
      ELSE
         GO TO 30
      END IF
      rdata(1:1200) = rdatx(1:1200)
      RETURN
   30 CONTINUE
      iret = 4
      RETURN
      END
C> @brief Fills cat. 12,8 to o-put array -goes sndg
C> @author Dennis Keyser @date 1997-06-05
 
C> For report (subset) read out of bufr message (passed in
C> internally via bufrlib storage), calls bufrlib routine to decode
C> upper-air (sounding) and additional data for goes sounding. Upper-
C> air data are then filled into the output array as category 12
C> (satellite sounding) and additional data are filled as category 8.
C> The ouput array holds a single goes sounding in the quasi-office
C> note 29 unpacked format.
C>
C> ### Program History Log:
C> Date | Programmer | Comment
C> -----|------------|--------
C> 1997-06-05 | Dennis Keyser NP22 | Initial.
C>
C> @param[in] LUNIT Fortran unit number for input data file
C> @param[inout] RDATA Single wind profiler report in a quasi-office note 29 unpacked format with [out] header information filled in [in] all data initialized as missing
C> @param[out] IRET Return code as described in w3unpk77 docblock
C>
C> @author Dennis Keyser @date 1997-06-05
      SUBROUTINE unpk7709(LUNIT,RDATA,IRET)
      CHARACTER*1  CQMFLG
      CHARACTER*8  COB
      CHARACTER*37  CAT8A,CAT8B
      CHARACTER*48  UAIR1,RAD1
      INTEGER  IDATA(1200),ICDFG(12)
      REAL(8) UAIR_8(4,255),CAT8_8(12),RTCSF_8,RAD_8(2,255)
      REAL  UAIR(4,255),CAT8(12),RDATA(*),RDATX(1200),SC8(12),RAD(2,255)
      COMMON /pk77bb/kdate(8),ldate(8),iprint
      COMMON /pk77ff/ifov(3),kntsat(250:260)
 
      SAVE
 
      equivalence(rdatx,idata),(cob,iob)
      DATA  xmsg/99999./,ymsg/99999.8/
      DATA  uair1/'PRLC HGHT TMDB TMDP                             '/
      DATA  rad1 /'CHNM TMBR                                       '/
      DATA  cat8a/'GLFTI PH2O PH2O19 PH2O97 PH2O73 TMSK '/
      DATA  cat8b/'GCDTT CDTP CLAM   SIDU   SOEL   ELEV '/
      DATA icdfg/ 50 , 51 , 52 , 53 , 54 , 55 , 56 ,57 ,58,59, 60 , 61 /
      DATA   sc8/100.,100.,100.,100.,100.,100.,100.,10.,1.,1.,100.,100./
      rdatx(1:1200) = rdata(1:1200)
 
C ALL NON-RADIANCE DATA WILL BE Q.C.'D ACCORDING TO NUMBER OF FIELDS-OF-
C  VIEW FOR RETRIEVAL:  0-2 --> BAD, 3-9 --> SUSPECT, 10-25 OR MISSING
C   --> NEUTRAL
 
      cqmflg = ' '
      IF(idata(3).LT.3)  THEN
         cqmflg = 'F'
         ifov(1) = ifov(1) + 1
      ELSE  IF(idata(3).LT.10.OR.idata(10).EQ.1)  THEN
         cqmflg = 'Q'
         IF(idata(3).LT.10)  ifov(2) = ifov(2) + 1
      END IF
      IF(idata(3).GT.9)  ifov(3) = ifov(3) + 1
 
C***********************************************************************
C                  FILL CATEGORY 12 PART OF OUTPUT
C***********************************************************************
 
      ilvl = 0
      ilc =  0
      uair_8 = 10.0e10
      CALL ufbint(lunit,uair_8,4,255,nlev,uair1);uair=uair_8
      IF(nlev.EQ.0)  THEN
C.......................................................................
C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO --
         print 217
  217    FORMAT(/' ##W3UNPK77: NO UPPER-AIR (SOUNDING) DATA PROCESSED ',
     $   'FOR THIS  REPORT -- NLEV = 0'/)
         GO TO 98
      ELSE  IF(nlev.GT.50)  THEN
C.......................................................................
C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS GREATER THAN LIMIT OF 50 --
         print 218
  218    FORMAT(/' ##W3UNPK77: NO UPPER-AIR (SOUNDING) DATA PROCESSED ',
     $   'FOR THIS  REPORT -- NLEV > 50'/)
         GO TO 98
C.......................................................................
      END IF
      IF(iprint.GT.1)  print 1068, nlev
 1068 FORMAT(' THIS REPORT CONTAINS',i4,' INPUT LEVELS OF SOUNDING ',
     $ 'DATA')
      DO i = 1,nlev
         IF(iprint.GT.1)  print 1079, i,ilc,ilvl
 1079 FORMAT(' ATTEMPTING NEW CAT. 12 INPUT LEVEL NUMBER',i4,' WITH ',
     $ 'ILC =',i5,'; NO. LEVELS PROCESSED TO NOW =',i5)
 
C       LEVEL PRESSURE (STORED AS REAL)
 
         m = 1
         IF(iprint.GT.1)  print 199, uair(1,i),m
  199 FORMAT(5x,'UAIR HERE IS: ',f17.4,'; INDEX IS: ',i3)
         IF(i.EQ.1)  THEN
            psfc = uair(1,i) * 0.1
         ELSE  IF(uair(1,i)*0.1.GE.ymsg)  THEN
C WE DO NOT HAVE A VALID CATEGORY 12 LEVEL -- THERE IS NO VALID PRESSURE
C  -- GO ON TO NEXT INPUT LEVEL (IF SFC LEVEL MSG, CONTINUE PROCESSING)
            IF(iprint.GT.1)  print *, 'PRESSURE MISSING ON INPUT',
     $       ' LEVEL ',i,', SKIP THE PROCESSING OF THIS LEVEL'
            GO TO 10
         ELSE  IF(uair(1,i)*0.1.GE.psfc)  THEN
C WE DO NOT HAVE A VALID CATEGORY 12 LEVEL -- THE INPUT LEVEL PRESSURE
C  IS BELOW THE SURFACE PRESSURE -- GO ON TO THE NEXT INPUT LEVEL
            IF(iprint.GT.1)  print *,'PRESSURE ON INPUT LEVEL ',i,
     $       ' IS BELOW GROUND, SKIP THE PROCESSING OF THIS LEVEL'
            GO TO 10
         END IF
 
C WE HAVE A VALID CATEGORY 12 LEVEL -- THERE IS A VALID PRESSURE
 
         IF(uair(1,i)*0.1.LT.xmsg)  rdatx(43+ilc) = nint(uair(1,i)*0.1)
         ilvl = ilvl + 1
         IF(iprint.GT.1)  print 198, 43+ilc,rdatx(43+ilc)
  198 FORMAT(5x,'RDATA(',i5,') STORED AS: ',f10.2)
 
C       GEOPOTENTIAL HEIGHT (STORED AS REAL)
 
         m = 2
         IF(iprint.GT.1)  print 199, uair(2,i),m
         IF(uair(2,i).LT.xmsg)  rdatx(43+ilc+1) = nint(uair(2,i))
         IF(iprint.GT.1)  print 198, 43+ilc+1,rdatx(43+ilc+1)
         IF(i.EQ.1)  THEN
            IF(iprint.GT.1)  print *, 'THIS IS SURFACE LEVEL, SO ',
     $       'STORE HEIGHT ALSO AS ELEVATION IN HEADER'
            IF(uair(2,1).LT.xmsg)  rdatx(7) = nint(uair(2,1))
            nnnnn = 7
            IF(iprint.GT.1)  print 198, nnnnn,rdatx(nnnnn)
         END IF
 
C       TEMPERATURE (STORED AS REAL)
 
         m = 3
         IF(iprint.GT.1)  print 199, uair(3,i),m
         itmp = nint(uair(3,i)*100.)
         IF(uair(3,i).LT.xmsg)
     $    rdatx(43+ilc+2) = nint((itmp - 27315) * 0.1)
         IF(iprint.GT.1)  print 198, 43+ilc+2,rdatx(43+ilc+2)
 
C       DEWPOINT TEMPERATURE (STORED AS REAL)
 
         m = 4
         IF(iprint.GT.1)  print 199, uair(4,i),m
         itmp = nint(uair(4,i)*100.)
         IF(uair(4,i).LT.xmsg)
     $    rdatx(43+ilc+3) = nint((itmp - 27315) * 0.1)
         IF(iprint.GT.1)  print 198, 43+ilc+3,rdatx(43+ilc+3)
 
C       QUALITY MARKERS (STORED AS CHARACTER)
 
         cob = cqmflg//cqmflg//cqmflg//'     '
         idata(43+ilc+6) = iob
         IF(iprint.GT.1)  print 196, 43+ilc+6,cob(1:4)
  196 FORMAT(5x,'IDATA(',i5,') STORED IN CHARACTER AS: "',a4,'"')
C.......................................................................
         ilc = ilc + 7
         IF(i+1.LE.nlev.AND.iprint.GT.1)  print *,'HAVE COMPLETED ',
     $    'LEVEL ',ilvl,'; GOING INTO NEXT LEVEL WITH ILC=',ilc
 
   10    CONTINUE
      ENDDO
 
C       SET CATEGORY COUNTERS FOR CATEGORY 12 (SOUNDING) DATA
 
      idata(39) = ilvl
   98 CONTINUE
      IF(iprint.GT.1)  print *, idata(39),' CAT. 12 LEVELS PROCESSED'
      IF(idata(39).GT.0)  idata(40) = 43
 
C***********************************************************************
C                  FILL CATEGORY 8 PART OF OUTPUT
C                  WILL ATTEMPT TO FILL 12 "LEVELS"
C LVL  1- LIFTED INDEX (DEG. K X 100 - RELATIVE) -------- CODE FIG. 250.
C LVL  2- TOTAL COLUMN PRECIPITABLE WATER (MM X 100) ---- CODE FIG. 251.
C LVL  3- 1. TO .9 SIGMA LAYER PRECIP. WATER (MM X 100) - CODE FIG. 252.
C LVL  4- .9 TO .7 SIGMA LAYER PRECIP. WATER (MM X 100) - CODE FIG. 253.
C LVL  5- .7 TO .3 SIGMA LAYER PRECIP. WATER (MM X 100) - CODE FIG. 254.
C LVL  6- SKIN TEMPERATURE (DEG. K X 100) --------------- CODE FIG. 255.
C LVL  7- CLOUD TOP TEMPERATURE (DEG. K X 100) ---------- CODE FIG. 256.
C LVL  8- CLOUD TOP PRESSURE (MB X 10) ------------------ CODE FIG. 257.
C LVL  9- CLOUD AMOUNT (C. FIG. BUFR TABLE 0-20-011) ---- CODE FIG. 258.
C LVL 10- INSTR. DATA USED IN PROC.
C                       (C. FIG. BUFR TABLE 0-02-021) --- CODE FIG. 259.
C LVL 11- SOLAR ZENITH ANGLE (SOLAR ELEV) (DEG. X 100) -- CODE FIG. 260.
C LVL 12- SATELLITE ZENITH ANGLE (ELEV) (DEG. X 100)  --- CODE FIG. 261.
C
C     IF DATA ONE ANY LEVEL ARE MISSING, THAT LEVEL IS NOT PROCESSED
C***********************************************************************
 
      ilvl = 0
      ilc = 0
      cat8_8 = 10.0e10
      CALL ufbint(lunit,cat8_8,12,1,nlev8,cat8a//cat8b);cat8=cat8_8
      IF(nlev8.NE.1)  THEN
         IF(nlev8.EQ.0)  THEN
C.......................................................................
C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO --
            print 318
  318 FORMAT(/' ##W3UNPK77: NO ADDITIONAL (CAT. 8) DATA PROCESSED FOR ',
     $ 'THIS  REPORT -- NLEV8 = 0'/)
            GO TO 99
C.......................................................................
         ELSE
C.......................................................................
C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED --
C  SET IRET = 7 AND RETURN
            print 219, nlev8
  219 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',i5,') ',
     $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 7'/)
            iret = 7
            RETURN
C.......................................................................
         END IF
      END IF
 
C THE TEMPERATURE CHANNEL SELECTION FLAG WILL BE USED LATER TO
C  DETERMINE Q. MARK FOR SKIN TEMPERATURE (IF 0 - OK, OTHERWISE - BAD)
 
      rtcsf_8 = 10.0e10
      CALL ufbint(lunit,rtcsf_8,1,1,nlev0,'TCSF');rtcsf=rtcsf_8
      itcsf = 1
      m = 1
      IF(iprint.GT.1)  print 299, rtcsf,m
  299 FORMAT(5x,'RTCSF HERE IS: ',f17.4,'; INDEX IS: ',i3)
      IF(rtcsf.LT.xmsg)  itcsf = nint(rtcsf)
      IF(iprint.GT.1)  print 1798, itcsf
 1798 FORMAT(5x,'ITCSF IS: ',i10)
 
C LOOP THROUGH THE 12 POSSIBLE ADDITIONAL DATA
 
      DO m = 1,12
         IF(iprint.GT.1)  print 6079, m,ilc,ilvl
 6079 FORMAT(' ATTEMPTING MISCEL. INPUT',i5,' WITH ILC =',i5,'; NO. ',
     $ 'OUTPUT CAT.  8 LVLS PROCESSED TO NOW =',i5)
         IF(iprint.GT.1)  print 399, cat8(m),m
  399 FORMAT(5x,'CAT8 HERE IS: ',f17.4,'; INDEX IS: ',i3)
         IF(cat8(m).LT.xmsg)  THEN
 
C WE HAVE A VALID CATEGORY 8 "LEVEL"
 
            ilvl = ilvl + 1
 
C STORE THE DATUM IN WORD 1 OF THE CAT. 8 LEVEL
 
            rdatx(393+ilc) = nint(cat8(m) * sc8(m))
            IF(iprint.GT.1)  print 198, 393+ilc,rdatx(393+ilc)
 
C STORE THE CAT. 8 CODE FIGURE IN WORD 2 OF THE CAT. 8 LEVEL
 
            rdatx(393+ilc+1) = real(200+icdfg(m))
            IF(iprint.GT.1)  print 198, 393+ilc+1,rdatx(393+ilc+1)
 
C STORE THE QUALITY MARKER IN BYTE 1 OF WORD 3 OF THE CAT. 8 LEVEL
 
            cob = cqmflg//'       '
 
C IF THIS DATUM IS SKIN TEMPERATURE AND THE TEMPERATURE CHANNEL
C  SELECTION FLAG IS BAD (.NE. 0), SET QUALITY MARKER TO "F"
 
            IF(m.EQ.6.AND.itcsf.NE.0)  cob(1:1) = 'F'
            idata(393+ilc+2) = iob
            IF(iprint.GT.1)  print 196, 393+ilc+2,cob(1:4)
            ilc = ilc + 3
            IF(m.LT.12.AND.iprint.GT.1) print *,'HAVE COMPLETED OUTPUT',
     $       ' LVL',ilvl,'; GOING INTO NEXT INPUT DATUM WITH ILC=',ilc
         ELSE
            IF(iprint.GT.1)  print *, 'DATUM MISSING ON INPUT ',m,
     $       ', GO ON TO NEXT INPUT DATUM (NO. LVLS PROCESSED SO ',
     $       'FAR=',ilvl,'; ILC=',ilc,')'
         END IF
      ENDDO
 
C       SET CATEGORY COUNTERS FOR CATEGORY 8 (ADDITIONAL) DATA
 
      idata(27) = ilvl
   99 CONTINUE
      IF(iprint.GT.1)  print *, idata(27),' CAT. 08 LEVELS PROCESSED'
      IF(idata(27).GT.0)  idata(28) = 393
 
C***********************************************************************
C              FILL CATEGORY 13 PART OF OUTPUT (RADIANCES)
C***********************************************************************
 
      ilvl = 0
      ilc =  0
      rad_8 = 10.0e10
      CALL ufbint(lunit,rad_8,2,255,nlev13,rad1);rad=rad_8
      IF(nlev13.EQ.0)  THEN
C.......................................................................
C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO --
         print 417
  417    FORMAT(/' ##W3UNPK77: NO RADIANCE DATA PROCESSED FOR THIS ',
     $    'REPORT -- NLEV13 = 0'/)
         GO TO 100
      ELSE  IF(nlev13.GT.60)  THEN
C.......................................................................
C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS GREATER THAN LIMIT OF 60 --
         print 418
  418    FORMAT(/' ##W3UNPK77: NO RADIANCE DATA PROCESSED FOR THIS ',
     $    'REPORT -- NLEV13 > 60'/)
         GO TO 100
C.......................................................................
      END IF
      IF(iprint.GT.1)  print 2068, nlev13
 2068 FORMAT(' THIS REPORT CONTAINS',i4,' INPUT LEVELS (CHANNELS) OF ',
     $ 'RADIANCE DATA')
      DO i = 1,nlev13
         IF(iprint.GT.1)  print 2079, i,ilc,ilvl
 2079 FORMAT(' ATTEMPTING NEW CAT. 13 INPUT "LEVEL" NUMBER',i4,' WITH ',
     $ 'ILC =',i5,'; NO. LEVELS (CHANNELS) PROCESSED TO NOW =',i5)
 
C       CHANNEL NUMBER (STORED AS INTEGER)
 
         m = 1
         IF(iprint.GT.1)  print 499, rad(1,i),m
  499 FORMAT(5x,'RAD  HERE IS: ',f17.4,'; INDEX IS: ',i3)
         IF(rad(1,i).GE.ymsg)  THEN
C WE DO NOT HAVE A VALID CATEGORY 13 LEVEL -- THERE IS NO VALID CHANNEL
C  NUMBER -- GO ON TO NEXT INPUT LEVEL
            IF(iprint.GT.1)  print *, 'CHANNEL NUMBER MISSING ON INPUT',
     $       ' LEVEL ',i,', SKIP THE PROCESSING OF THIS LEVEL'
            GO TO 210
         END IF
 
C WE HAVE A VALID CATEGORY 13 LEVEL -- THERE IS A VALID CHANNEL NUMBER
 
         idata(429+ilc) = nint(rad(1,i))
         ilvl = ilvl + 1
         IF(iprint.GT.1)  print 197, 429+ilc,idata(429+ilc)
  197 FORMAT(5x,'IDATA(',i5,') STORED AS: ',i10)
 
C       BRIGHTNESS TEMPERATURE (STORED AS REAL)
 
         m = 2
         IF(iprint.GT.1)  print 499, rad(2,i),m
         IF(rad(2,i).LT.xmsg)  rdatx(429+ilc+1) = nint(rad(2,i) * 100.)
         IF(iprint.GT.1)  print 198, 429+ilc+1,rdatx(429+ilc+1)
 
C       QUALITY MARKERS (STORED AS CHARACTER)
 
         cob = '        '
         idata(429+ilc+2) = iob
         IF(iprint.GT.1)  print 196, 429+ilc+2,cob(1:4)
C.......................................................................
         ilc = ilc + 3
         IF(i+1.LE.nlev13.AND.iprint.GT.1)  print *,'HAVE COMPLETED ',
     $    'LEVEL ',ilvl,'; GOING INTO NEXT LEVEL WITH ILC=',ilc
 
  210    CONTINUE
      ENDDO
 
C       SET CATEGORY COUNTERS FOR CATEGORY 13 (RADIANCE) DATA
 
      idata(41) = ilvl
  100 CONTINUE
      IF(iprint.GT.1)  print *, idata(41),' CAT. 13 LEVELS PROCESSED'
      IF(idata(41).GT.0)  idata(42) = 429
 
      IF(idata(27)+idata(39)+idata(41).EQ.0)  iret = 5
 
      IF(iprint.GT.1)  print *,'IDATA(39)=',idata(39),'; IDATA(40)=',
     $ idata(40),'; IDATA(27)=',idata(27),'; IDATA(28)=',idata(28),
     $ '; IDATA(41)=',idata(41),'; IDATA(42)=',idata(42)
 
      rdata(1:1200) = rdatx(1:1200)
      RETURN
      END