iw3unp29.f

Go to the documentation of this file.

C>    @file
C>    @brief Reads and unpacks one report into the unpacked office note
C>    29/124 format
C>    @author Dennis Keyser @date 2013-03-20
 
C>    This routine has not been tested reading input data from any dump
C>    type in ON29/124 format on WCOSS. It likely will not work when
C>    attempting to read ON29/124 format dumps on WCOSS. It has also
C>    not been tested reading any dump file other than ADPUPA (BUFR
C>    input only) on WCOSS. It does work reading BUFR ADPUPA dump files
C>    on WCOSS. It will hopefully working reading other BUFR (only)
C>    dump files on WCOSS. Also, this routine is only known to work correctly
C>    when compiled using 8 byte machine words (real and integer).
C>
C>    Reads and unpacks one report into the unpacked office note
C>    29/124 format.  The input data may be packed into either bufr or
C>    true on29/124 format with a y2k compliant pseudo-on85 header label.
C>    (Note: as a temporary measure, this code will still operate on a
C>    true on29/124 format file with a non-y2k compliant on85 header
C>    label.  The code will use the "windowing" technique to obtain a
C>    4-digit year.) This routine will determine the format of the
C>    input data and take the appropriate action. It returns the
C>    unpacked report to the calling program in the array 'obs'.
C>    Various contingencies are covered by return value of the function
C>    and parameter 'ier' - function and ier have same value. Repeated
C>    calls of function will return a sequence of unpacked on29/124
C>    reports.  The calling program may switch to a new 'nunit' at any
C>    time, that dataset will then be read in sequence. If user
C>    switches back to a previous 'nunit', that data set will be read
C>    from the beginning, not from where the user left off (this is a
C>    'software tool', not an entire i/o system).
C>
C>    Program history log:
C>    - Jack Woollen 1996-12-13 (gsc) Note this new
C>    version of iw3gad incorporates the earlier version which
C>    was written by j. stackpole and dealt only with true
C>    on29/124 data as input - this option is still available
C>    but is a small part of the new routine which was written
C>    from scratch to read in bufr data.
C>    - Dennis Keyser 1997-01-27 Changes to more closely duplicate format
C>    obtained when reading from true on29/124 data sets.
C>    - Dennis Keyser 1997-02-04 Drops with missing stnid get stnid set to
C>    "drp88a"; satwnds with zero pressure are tossed.
C>    - Dennis Keyser 1997-02-12 To get around the 3-bit limitation to
C>    the on29 pressure q.m. mnemonic "qmpr", an sdmedit/quips
C>    purge or reject flag on pressure is changed from 12 or 14
C>    to 6 in order to fit into 3-bits, see function e35o29;
C>    interprets sdmedit and quips purge/keep/change flags
C>    properly for all data types; can now process cat. 6 and
C>    cat. 2/3 type flight-level reccos (before skipped these);
C>    tests for missing lat, lon, obtime decoded from bufr and
C>    retains missing value on these in unpacked on29/124
C>    format (before no missing check, led to possible non-
C>    missing but incorrect values for these); the check for
C>    drops with missing stnid removed since decoder fixed for
C>    this.
C>    - Dennis Keyser 1997-05-01 Looks for duplicate levels when
C>    processing on29 cat. 2, 3, and 4 (in all data on level)
C>    and removes duplicate level; in processing on29 cat. 3
C>    levels, removes all levels where wind is missing; fixed
C>    bug in aircraft (airep/pirep/amdar) quality mark
C>    assignment (was not assigning keep flag to report if
C>    pressure had a keep q.m. but temperature q.m. was
C>    missing).
C>    - Dennis Keyser 1997-05-30 For aircft: (only acars right now) -
C>    seconds are decoded (if avail.) and used to obtain
C>    report time; only asdar/amdar - new cat. 8 code figs.
C>    o-put 917 (char. 1 & 2 of actual stnid), 918 (char. 3 &
C>    4 of actual stnid), 919 (char. 5 & 6 of actual stnid);
C>    asdar/amdar and acars - new cat. 8 code fig. o-put 920
C>    (char. 7 & 8 of actual stnid); only acars - new cat. 8
C>    code fig. o-put 921 (report time to nearest 1000'th of
C>    an hour); only some acars - new mnemonic "ialt" now
C>    exists and can (if line not commented out) be used to
C>    obtain unpacked on29 cat. 6.
C>    - Dennis Keyser 1997-07-02 Removed filtering of aircraft data as
C>    follows: air france amdars no longer filtered, amdar/
C>    asdar below 7500 ft. no longer filtered, airep/pirep
C>    below 100 meters no longer filtered, all aircraft with
C>    missing wind but valid temperature are no longer
C>    filtered; reprocesses u.s. satwnd stn. ids to conform
C>    with previous on29 appearance except now 8-char (tag
C>    char. 1 & 6 not changed from bufr stn. id) - never any
C>    dupl. ids now for u.s. satwnds decoded from a single
C>    bufr file; streamlined/eliminated some do loops to
C>    speed up a bit.
C>    - Dennis Keyser 1997-09-18 Corrected errors in reformatting surface
C>    data into unpacked on124, specifically-header: inst. type
C>    (synoptic fmt flg, auto stn. type, converted hrly flg),
C>    indicators (precip., wind speed, wx/auto stn), cat51:
C>    p-tend, horiz. viz., present/past wx, cloud info, max/
C>    min temp, cat52: precip., snow dpth, wave info, ship
C>    course/speed, cat8: code figs. 81-85,98; corrected
C>    problem which coded upper-air mandatory level winds
C>    as cat. 3 instead of cat. 1 when mass data (only) was
C>    reported on same mandatory level in a separate reported
C>    level in the raw bulletin.
C>    - Dennis Keyser 1997-10-06 Updated logic to read and process nesdis
C>    hi-density satellite winds properly.
C>    - Dennis Keyser 1997-10-30 Added gross check on u-air pressure, all
C>    levels with reported pressure .le. zero now tossed; sfc
C>    cat. 52 sea-sfc temperature now read from hierarchy of
C>    sst in bufr {1st choice - hi-res sst ('sst2'), 2nd
C>    choice - lo-res sst ('sst1'), 3rd choice - sea temp
C>    ('stmp')}, before only read 'sst1'.
C>    - Dennis Keyser 1998-01-26 Changed pqm processing for adpupa types
C>    such that sdmedit flags are now honored (before, pqm
C>    was always hardwired to 2 for adpupa types); bumped
C>    limit for number of levels that can be processed from
C>    100 to 150 and added diagnostic print when the limit
C>    is exceeded.
C>    - Dennis Keyser 1998-05-19 Y2k compliant version of iw3gad routine
C>    accomplished by redefining original 32-character on85
C>    header label to be a 40-character label that contains a
C>    full 4-digit year, can still read "true" on29/124 data
C>    sets provided their header label is in this modified
C>    form.
C>    - Dennis Keyser 1998-07-22 Minor modifications to account for
C>    corrections in y2k/f90 bufrlib (mainly related to
C>    bufrlib routine dumpbf).
C>    - Dennis Keyser 1998-08-04 Fixed a bug that resulted in code being
C>    clobbered in certain situations for recco reports; minor
C>    modifications to give same answers on cray as on sgi;
C>    allowed code to read true on29/124 files with non-y2k
C>    compliant on85 label (a temporary measure during
C>    transition of main programs to y2k); added call to "aea"
C>    which converts ebcdic characters to ascii for input
C>    true on29/124 data set processing of sgi (which does
C>    not support "-cebcdic" in assign statement).
C>    - Dennis Keyser 1999-02-25 Added ability to read reprocessed ssm/i
C>    bufr data set (spssmi); added ability to read mean
C>    sea-level pressure bogus (paobs) data set (sfcbog).
C>    - Dennis Keyser 1999-05-14 Made changes necessary to port this
C>    routine to the ibm sp.
C>    - Dennis Keyser 1999-06-18 Can now process water vapor satwnds
C>    from foreign producers; stn. id for foreign satwnds
C>    now reprocessed in same way as for nesdis/goes satwnds,
C>    character 1 of stn. id now defines even vs. odd
C>    satellite while character 6 of stn. id now defines
C>    ir cloud-drft vs. visible cloud drft vs. water vapor.
C>    - Dennis Keyser 2002-03-05 Removed entry "e02o29", now performs
C>    height to press. conversion directly in code for cat. 7;
C>    test for missing "rpid" corrected for adpupa data (now
C>    checks ufbint return code rather than value=bmiss);
C>    accounts for changes in input adpupa, adpsfc, aircft
C>    and aircar bufr dump files after 3/2002: cat. 7 and cat.
C>    51 use mnemonic "hblcs" to get height of cloud base if
C>    mnemonic "hocb" not available (and it will not be for all
C>    cat. 7 and some cat. 51 reports); mnemonic "tiwm"
C>    replaces "suws" in header for surface data; mnemonic
C>    "borg" replaces "icli" in cat. 8 for aircraft data (will
C>    still work properly for input adpupa, adpsfc, aircft and
C>    aircar dump files prior to 3/2002).
C>    - Dennis Keyser 2013-03-20 Changes to run on wcoss, obtain value of
C>    bmiss set in calling program via call to bufrlib routine
C>    getbmiss rather than hardwiring it to 10e08 (or 10e10);
C>    use formatted print statements where previously
C>    unformatted print was used (wcoss splits unformatted
C>    print at 80 characters).
C>
C>    @param[in] lunit fortran unit number for sequential data set containing
C>    packed bufr reports or packed and blocked office note 29/124 reports
C>    @param[out] obs array containing one report in unpacked office note
C>    29/124 format. Format is mixed, user must equivalence
C>    integer and character arrays to this array (see
C>    docblock for w3fi64 in /nwprod/lib/sorc/w3nco
C>    or writeups on w3fi64, on29, on124 for help)
C>    the length of the array should be at least 1608.
C>    @param[out] ier return flag (equal to function value)
C>
C>    Input files:
C>    - unit aa sequential bufr or office note 29/124 data set ("aa"
C>    is unit number specified by input argument "nunit")
C>
C>    Output files:
C>    - unit 06 printout
C>
C>    @note
C>    - if input data set is on29/124, it should be assigned in this way:
C>     - cray:
C>      - assign -a adpupa -fcos -cebcdic fort.xx
C>     - sgi:
C>      - assign -a adpupa -fcos fort.xx
C>      (note: -cebcdic is not possible on sgi, so call to w3nco
C>      routine "aea" takes care of the conversion as each
C>      on29 record is read in)
C>    - if input data set is bufr, it should be assigned in this way:
C>     - cray:
C>      - assign -a adpupa fort.xx
C>     - sgi:
C>      - assign -a adpupa -f cos fort.xx
C>
C>    For input on29/124 data sets, a contingency has been built
C>    into this subroutine to perform the conversion from ebcdic to
C>    ascii in the event the assign does not perform the conversion
C>    the return flags in ier (and function iw3unp29 itself) are:
C>    - 0 Observation read and unpacked into location 'obs'.
C>    see writeup of w3fi64 for contents. (all character
C>    words are left-justified.) Next call to iw3unp29
C>    will return next observation in data set.
C>    - 1 A 40 byte header in the format described here
C>    (y2k compliant pseudo-office note 85) is returned
C>    in the first 10 words of 'obs' on a 4-byte machine
C>    (ibm) and in the first 5 words of 'obs' on an
C>    8-byte machine (cray). Next call to
C>    iw3unp29 will return first obs. in this data set.
C>    (note: if input data set is a true on29/124 file
C>    with the y2k compliant pseudo-on85 header record,
C>    then the pseudo-on85 header record is actually
C>    read in and returned; if input data set is a true
C>    on29/124 file with a non-y2k compliant on85 header
C>    record, then a y2k compliant pseudo-on85 header
C>    record is constructed from it using the "windowing"
C>    technique to obtain a 4-digit year from a 2-digit
C>    year.)
C>    format for y2k compliant pseudo-on85 header record
C>    returned (40 bytes in character):
C>     - bytes 1- 8 -- data set name (as defined in on85 except up to
C>       eight ascii char., left justified with blank fill)
C>     - bytes 9-10 -- set type (as defined in on85)
C>     - bytes 11-20 -- center (analysis) date for data
C>       set (ten ascii characters in form "yyyymmddhh")
C>     - bytes 21-24 -- set initialize (dump) time, as dedined in on85)
C>     - bytes 25-34 -- always "washington" (as in on85)
C>     - bytes 35-36 -- source machine (as defined in on85)
C>     - bytes 37-40 -- blank fill characters
C>    - 2 end-of-file (never an empty or null file):
C>     - input on29/124 data set: the "endof file" record is
C>     encountered - no useful information in 'obs' array.
C>     next call to iw3unp29 will return physical end of
C>     file for data set in 'nunit' (see ier=3 below).
C>     - input bufr data set: the physical end of file is
C>     encountered.
C>    -3 end-of-file:
C>    Physical end of file encountered on data set -
C>    this can only happen for an empty (null) data set
C>    or for a true on29/124 data set. There are no
C>    more reports (or never were any if null) associated
C>    with data set in this unit number - no useful
C>    information in 'obs' array. Either all done (if
C>    no more unit numbers are to be read in), or reset
C>    'nunit' to point to a new data set (in which case
C>    next call to iw3unp29 should return with ier=1).
C>    - 4 only valid for input on29/124 data set - i/o error
C>    reading the next record of reports - no useful
C>    information in 'obs' array. Calling program can
C>    choose to stop or again call iw3unp29 which will
C>    attempt to unpack the first observation in the next
C>    record of reports.
C>    - 999 applies only to non-empty data sets:
C>     - input on29/124 data set: first choice y2k compliant
C>     pseudo-on85 file header label not encountered where
C>     expected, and second choice non-y2k compliant on85
C>     file header label also not encountered.
C>     - input bufr data set either header label in
C>     format of pseudo-on85 could not be returned, or an
C>     abnormal error occurred in the attempt to decode an
C>     observation. For either input data set type, no
C>     useful information in 'obs' array. Calling program
C>     can choose to stop with non-zero condition code or
C>     reset 'nunit' to point to a new data set (in which
C>     case next call to iw3unp29 should return with
C>     ier=1).
C>     - input data set neither on29/124 nor bufr speaks for
C>     itself.
C>
C>    @author Dennis Keyser @date 2013-03-20
C>
 
      FUNCTION iw3unp29(LUNIT,OBS,IER)
 
      common/io29aa/jwfile(100),lastf
      common/io29bb/kndx,kskacf(8),kskupa,ksksfc,ksksat,ksksmi
      common/io29cc/subset,idat10
      common/io29dd/hdr(12),rcats(50,150,11),ikat(11),mcat(11),ncat(11)
      common/io29ee/robs(255,11)
      common/io29ff/qms(255,9)
      common/io29gg/sfo(34)
      common/io29hh/sfq(5)
      common/io29ii/pwmin
      common/io29jj/iset,manlin(1001)
      common/io29kk/kount(499,18)
      common/io29ll/bmiss
 
      dimension    obs(*)
      REAL(8)      bmiss,getbmiss
 
      SAVE
 
      DATA itimes/0/
 
      IF(itimes.EQ.0)  THEN
 
C  THE FIRST TIME IN, INITIALIZE SOME DATA
C  (NOTE: FORTRAN 77/90 STANDARD DOES NOT ALLOW COMMON BLOCK VARIABLES
C         TO BE INITIALIZED VIA DATA STATEMENTS, AND, FOR SOME REASON,
C         THE BLOCK DATA DOES NOT INITIALIZE DATA IN THE W3NCO LIBRARY
C         AVOID BLOCK DATA IN W3NCO/W3EMC)
C  --------------------------------------------------------------------
 
         itimes = 1
         jwfile = 0
         lastf = 0
         kndx = 0
         kskacf = 0
         kskupa = 0
         ksksfc = 0
         ksksat = 0
         ksksmi = 0
         kount = 0
         ikat(1)  =  1
         ikat(2)  =  2
         ikat(3)  =  3
         ikat(4)  =  4
         ikat(5)  =  5
         ikat(6)  =  6
         ikat(7)  =  7
         ikat(8)  =  8
         ikat(9)  = 51
         ikat(10) = 52
         ikat(11) =  9
         mcat(1)  =  6
         mcat(2)  =  4
         mcat(3)  =  4
         mcat(4)  =  4
         mcat(5)  =  6
         mcat(6)  =  6
         mcat(7)  =  3
         mcat(8)  =  3
         mcat(9)  = 21
         mcat(10) = 15
         mcat(11) =  3
         iset  = 0
      END IF
 
C  UNIT NUMBER OUT OF RANGE RETURNS A 999
C  --------------------------------------
 
      IF(lunit.LT.1 .OR. lunit.GT.100)  THEN
         print'(" ##IW3UNP29 - UNIT NUMBER ",I0," OUT OF RANGE -- ",
     $    "IER = 999")', lunit
         GO TO 9999
      END IF
      IF(lastf.NE.lunit .AND. lastf.GT.0) THEN
         CALL closbf(lastf)
         jwfile(lastf) = 0
      END IF
      lastf = lunit
 
C  THE JWFILE INDICATOR: =0 IF UNOPENED; =1 IF ON29; =2 IF BUFR
C  ------------------------------------------------------------
 
      IF(jwfile(lunit).EQ.0) THEN
         print'(" ===> IW3UNP29 - WCOSS VERSION: 03-20-2013")'
 
         bmiss = getbmiss()
         print'(1X)'
         print'(" BUFRLIB value for missing passed into IW3UNP29 is: ",
     $    G0)', bmiss
         print'(1X)'
 
         IF(i03o29(lunit,obs,ier).EQ.1) THEN
            print'(" IW3UNP29 - OPENED A TRUE OFFICE NOTE 29 FILE IN ",
     $       "UNIT ",I0)', lunit
            jwfile(lunit) = 1
            ier = 1
            iw3unp29 = 1
         ELSEIF(i03o29(lunit,obs,ier).EQ.3) THEN
            print 107, lunit
  107 FORMAT(/,' ##IW3UNP29 - FILE IN UNIT',i3,' IS EMPTY OR NULL -- ',
     $ 'IER = 3'/)
            ier = 3
            iw3unp29 = 3
         ELSEIF(i02o29(lunit,obs,ier).EQ.1) THEN
            print'(" IW3UNP29 - OPENED A BUFR FILE IN UNIT ",I0)', lunit
 
            jwfile(lunit) = 2
            kndx = 0
            kskacf = 0
            kskupa = 0
            ksksfc = 0
            ksksat = 0
            ksksmi = 0
            ier = 1
            iw3unp29 = 1
         ELSEIF(i03o29(lunit,obs,ier).EQ.999) THEN
            print'(" IW3UNP29 - OPENED A TRUE OFFICE NOTE 29 FILE IN ",
     $       "UNIT ",I0)', lunit
            print 88
   88 FORMAT(/' ##IW3UNP29/I03O29 - NEITHER EXPECTED Y2K COMPLIANT ',
     $ 'PSEUDO-ON85 LABEL NOR SECOND CHOICE NON-Y2K COMPLIANT ON85 ',
     $ 'LABEL FOUND IN'/21x,'FIRST RECORD OF FILE  -- IER = 999'/)
            GO TO 9999
         ELSE
            print 108, lunit
  108 FORMAT(/,' ##IW3UNP29 - FILE IN UNIT',i3,' IS NEITHER BUFR NOR ',
     $ 'TRUE OFFICE NOTE 29 -- IER = 999'/)
            GO TO 9999
         END IF
      ELSEIF(jwfile(lunit).EQ.1) THEN
         IF(i03o29(lunit,obs,ier).NE.0) jwfile(lunit) = 0
         IF(ier.GT.0) CLOSE (lunit)
         iw3unp29 = ier
      ELSEIF(jwfile(lunit).EQ.2) THEN
         IF(i02o29(lunit,obs,ier).NE.0) jwfile(lunit) = 0
         IF(ier.GT.0) CALL closbf(lunit)
         IF(ier.EQ.2.OR.ier.EQ.3)  THEN
            IF(kskacf(1).GT.0)  print'(" IW3UNP29 - NO. OF AIRCFT/",
     $      "AIRCAR REPORTS TOSSED DUE TO ZERO CAT. 6 LVLS = ",I0)',
     $      kskacf(1)
            IF(kskacf(2).GT.0)  print'(" IW3UNP29 - NO. OF AIRCFT ",
     $       "REPORTS TOSSED DUE TO BEING ""LFPW"" AMDAR = ",I0)',
     $       kskacf(2)
            IF(kskacf(8).GT.0)  print'(" IW3UNP29 - NO. OF AIRCFT ",
     $       "REPORTS TOSSED DUE TO BEING ""PHWR"" AIREP = ",I0)',
     $       kskacf(8)
            IF(kskacf(3).GT.0)  print'(" IW3UNP29 - NO. OF AIRCFT ",
     $       "REPORTS TOSSED DUE TO BEING CARSWELL AMDAR = ",I0)',
     $       kskacf(3)
            IF(kskacf(4).GT.0)  print'(" IW3UNP29 - NO. OF AIRCFT ",
     $       "REPORTS TOSSED DUE TO BEING CARSWELL ACARS = ",I0)',
     $       kskacf(4)
            IF(kskacf(5).GT.0)  print'(" IW3UNP29 - NO. OF AIRCFT/",
     $       "AIRCAR REPORTS TOSSED DUE TO HAVING MISSING WIND = ",I0)',
     $       kskacf(5)
            IF(kskacf(6).GT.0)  print'(" IW3UNP29 - NO. OF AIRCFT ",
     $       "REPORTS TOSSED DUE TO BEING AMDAR < 2286 M = ",I0)',
     $       kskacf(6)
            IF(kskacf(7).GT.0)  print'(" IW3UNP29 - NO. OF AIRCFT ",
     $       "REPORTS TOSSED DUE TO BEING AIREP <  100 M = ",I0)',
     $       kskacf(7)
            IF(kskacf(1)+kskacf(2)+kskacf(3)+kskacf(4)+kskacf(5)+
     $       kskacf(6)+kskacf(7)+kskacf(8).GT.0)
     $       print'(" IW3UNP29 - TOTAL NO. OF AIRCFT/AIRCAR REPORTS ",
     $        "TOSSED = ",I0)',
     $        kskacf(1)+kskacf(2)+kskacf(3)+kskacf(4)+
     $        kskacf(5)+kskacf(6)+kskacf(7)+kskacf(8)
            IF(kskupa.GT.0)  print'(" IW3UNP29 - TOTAL NO. OF ADPUPA ",
     $       "REPORTS TOSSED = ",I0)', kskupa
            IF(ksksfc.GT.0)  print'(" IW3UNP29 - TOTAL NO. OF ADPSFC/",
     $       "SFCSHP/SFCBOG REPORTS TOSSED = ",I0)', ksksfc
            IF(ksksat.GT.0)  print'(" IW3UNP29 - TOTAL NO. OF SATWND ",
     $       "REPORTS TOSSED = ",I0)', ksksat
            IF(ksksmi.GT.0)  print'(" IW3UNP29 - TOTAL NO. OF SPSSMI ",
     $       "REPORTS TOSSED = ",I0)', ksksmi
            kndx = 0
            kskacf = 0
            kskupa = 0
            ksksfc = 0
            ksksat = 0
            ksksmi = 0
         END IF
         iw3unp29 = ier
      END IF
 
      RETURN
 
 9999 CONTINUE
      ier = 999
      iw3unp29 = 999
      RETURN
 
      END
C***********************************************************************
C***********************************************************************
C***********************************************************************
C>    This function read obs files and returns error message.
C>    @param LUNIT full path of file
C>    @param HDR header of file
C>    @param IER  missing or invalid data indicator
C>    @return Y2K COMPLIANT
C>
C>    @author Dennis Keyser @date 2013-03-20
C>
C-----------------------------------------------------------------------
      FUNCTION i01o29(LUNIT,HDR,IER)
C     ---> formerly FUNCTION IW3HDR
 
      common/io29aa/jwfile(100),lastf
 
      dimension hdr(*)
 
      SAVE
 
C  UNIT NUMBER OUT OF RANGE RETURNS A 999
C  --------------------------------------
 
      IF(lunit.LT.1 .OR. lunit.GT.100)  THEN
         print'(" ##IW3UNP29/I01O29 - UNIT NUMBER ",I0," OUT OF RANGE ",
     $    "-- IER = 999")', lunit
         GO TO 9999
      END IF
 
C  THE JWFILE INDICATOR: =0 IF UNOPENED; =1 IF ON29; =2 IF BUFR
C  ------------------------------------------------------------
 
      IF(jwfile(lunit).EQ.0) THEN
         IF(i03o29(lunit,hdr,ier).EQ.1) THEN
            i01o29 = i03o29(0,hdr,ier)
            i01o29 = 1
            RETURN
         ELSEIF(i02o29(lunit,hdr,ier).EQ.1) THEN
            CALL closbf(lunit)
            i01o29 = 1
            RETURN
         ELSE
 
C  CAN'T READ FILE HEADER RETURNS A 999
C  ------------------------------------
 
            print'(" ##IW3UNP29/I01O29 - CAN""T READ FILE HEADER -- ",
     $       "IER = 999")'
            GO TO 9999
         END IF
      ELSE
 
C  FILE ALREADY OPEN RETURNS A 999
C  -------------------------------
 
         print'(" ##IW3UNP29/I01O29 - FILE ALREADY OPEN -- IER = 999")'
         GO TO 9999
      END IF
 
      RETURN
 
 9999 CONTINUE
      ier = 999
      i01o29 = 999
      RETURN
 
      END
C***********************************************************************
C***********************************************************************
C***********************************************************************
 
C>    This function read obs files and returns error message.
C>    @param LUNIT full path of file
C>    @param OBS data output
C>    @param IER  missing or invalid data indicator
C>    @return Y2K COMPLIANT
C>
C>    @author Dennis Keyser @date 2013-03-20
C>
 
      FUNCTION i02o29(LUNIT,OBS,IER)
C     ---> formerly FUNCTION JW3O29
 
      common/io29cc/subset,idat10
 
      CHARACTER*40 on85
      CHARACTER*10 cdate
      CHARACTER*8  subset,cbufr
      CHARACTER*6  c01o29
      CHARACTER*4  cdump
      dimension    obs(1608),ron85(16),jdate(5),jdump(5)
      equivalence(ron85(1),on85)
 
      SAVE
 
      DATA on85/'                                        '/
 
      jdate = -1
      jdump = -1
 
C  IF FILE IS CLOSED TRY TO OPEN IT AND RETURN A Y2K COMPLIANT
C    PSEUDO-ON85 LABEL
C  -----------------------------------------------------------
 
      CALL status(lunit,lun,il,im)
 
      IF(il.EQ.0) THEN
         iret = -1
         i02o29 = 2
         rewind lunit
         READ(lunit,END=10,ERR=10,FMT='(A8)') cbufr
         IF(cbufr(1:4).EQ.'BUFR') THEN
            print'(" IW3UNP29/I02O29 - INPUT FILE ON UNIT ",I0, " IS",
     $      " UNBLOCKED NCEP BUFR"/)', lunit
         ELSE  IF(cbufr(5:8).EQ.'BUFR') THEN
            print'(" IW3UNP29/I02O29 - INPUT FILE ON UNIT ",I0, " IS",
     $      " BLOCKED NCEP BUFR"/)', lunit
         ELSE
            rewind lunit
            GO TO 10
         END IF
         call datelen(10)
         CALL dumpbf(lunit,jdate,jdump)
cppppp
         print'(" CENTER DATE (JDATE) = ",I4,4I3.2/" DUMP DATE (JDUMP)",
     $    " (year not used anywhere) = "I4,4I3.2)',jdate,jdump
cppppp
         IF(jdate(1).GT.999)  THEN
            WRITE(cdate,'(I4.4,3I2.2)') (jdate(i),i=1,4)
         ELSE  IF(jdate(1).GT.0)  THEN
 
C If 2-digit year returned in JDATE(1), must use "windowing" technique
C  2 create a 4-digit year
 
            print'(" ##IW3UNP29/I02O29 - 2-DIGIT YEAR IN JDATE(1) ",
     $       "RETURNED FROM DUMPBF (JDATE IS: ",I4.4,3I2.2,") - USE ",
     $       "WINDOWING TECHNIQUE TO OBTAIN 4-DIGIT YEAR")', jdate
            IF(jdate(1).GT.20)  THEN
               WRITE(cdate,'("19",4I2.2)') (jdate(i),i=1,4)
            ELSE
               WRITE(cdate,'("20",4I2.2)') (jdate(i),i=1,4)
            ENDIF
            print'(" ##IW3UNP29/I02O29 - CORRECTED JDATE(1) WITH ",
     $       "4-DIGIT YEAR, JDATE NOW IS: ",I4.4,3I2.2)', jdate
         ELSE
            GO TO 10
         ENDIF
 
         CALL openbf(lunit,'IN',lunit)
 
C This next call, I believe, is needed only because SUBSET is not
C  returned in DUMPBF ...
         call readmg(lunit,subset,idat10,iret)
 
         WRITE(cdump,'(2I2.2)') jdump(4),100*jdump(5)/60
         IF(jdump(1).LT.0) cdump = '9999'
         on85=c01o29(subset)//'  C2'//cdate//cdump//'WASHINGTONCR    '
         obs(1:16) = ron85
         i02o29 = 1
   10    CONTINUE
         ier = i02o29
         RETURN
      END IF
 
C  IF THE FILE IS ALREADY OPENED FOR INPUT TRY TO READ THE NEXT SUBSET
C  -------------------------------------------------------------------
 
      IF(il.LT.0) THEN
 7822    CONTINUE
         CALL readns(lunit,subset,idat10,iret)
         IF(iret.EQ.0) i02o29 = r01o29(subset,lunit,obs)
         IF(iret.NE.0) i02o29 = 2
         IF(i02o29.EQ.-9999)  GO TO 7822
         ier = i02o29
         RETURN
      END IF
 
C  FILE MUST BE OPEN FOR INPUT!
C  ----------------------------
 
      print'(" ##IW3UNP29/I02O29 - FILE ON UNIT ",I0," IS OPENED FOR ",
     $ "OUTPUT -- IER = 999")', lunit
      i02o29 = 999
      ier = 999
      RETURN
 
      END
 
C>    This function reads a true (see *) on29/124 data set and unpacks one
C>    report into the unpacked office note 29/124 format. the input and
C>    output arguments here have the same meaning as for iw3unp29.
C>    repeated calls of function will return a sequence of unpacked
C>    on29/124 reports. * - unlike original "true" on29/124 data sets,
C>    the "expected" file header label is a y2k compliant 40-byte
C>    pseudo-on85 version - if this is not encountered this code, as a
C>    temporary measure during the y2k transition period, will look for
C>    the original non-y2k compliant 32-byte on85 header label and use
C>    the "windowing" technique to convert the 2-digit year to a 4-digit
C>    year in preparation for returning a 40-byte pseudo-on85 label in
C>    the first C call. (see iw3unp29 docblock for format of 40-byte
C>    pseudo-on85 header label.)
C>
C>    Program History Log:
C>    -1991-07-23 Dennis Keyser w3fi64 (f77) internal read error
C>    no longer causes calling program to fail but will move
C>    to next record if can't recover to next report
C>    -1993-10-07 Dennis Keyser -- adapted for use on cray (added save
C>    statement, removed ibm-specific code, etc.)
C>    -1993-10-15 R. E. Jones added code so if file is ebcdic it converts
C>    it to ascii
C>    -1996-10-04 Jack Woollen changed name to i03gad and incorporated
C>    into new w3lib routine iw3gad
C>    -2013-03-20 Dennis Keyser changes to run on wcoss
C>
C>    @param[in] nunit fortran unit number for sequential data set containing
C>    packed and blocked office note 29/124 reports
C>    @param[out] obs array containing one report in unpacked office note
C>    - 29/124 format is mixed, user must equivalence
C>    - integer and character arrays to this array (see
C>    - docblock for w3fi64 in /nwprod/lib/sorc/w3nco
C>    - or writeups on w3fi64, on29, on124 for help)
C>    - the length of the array should be at least 1608
C>    @param[out] ier return flag (equal to function value) in iw3unp29 docblock
C>    @return Y2K COMPLIANT
C>
C>    @note aa unit number specified by input argument "nunit")
C>    called by subprogram iw3unp29.
C>
C>    @author keyser @date 2013-03-20
C>
      FUNCTION i03o29(NUNIT, OBS, IER)
C     ---> formerly FUNCTION KW3O29
 
      CHARACTER*1  cbuff(6432),con85l(32)
      CHARACTER*2  cbf910
      CHARACTER*4  cyr4d
      CHARACTER*8  cbufr
      INTEGER  ibuff(5),obs(*)
 
      equivalence(ibuff,cbuff)
 
      SAVE
 
      DATA ioldun/0/
 
C TEST FOR NEW (OR PREVIOUSLY USED) NUNIT AND ADJUST 'NEXT'
C  (THIS ALLOWS USER TO SWITCH TO NEW NUNIT PRIOR TO READING TO
C  THE 'END OF FILE' ON AN OLD UNIT.  ANY SWITCH TO A NEW UNIT WILL
C  START THE READ AT THE BEGINNING)
C  ----------------------------------------------------------------
 
      if(nunit.eq.0) then
         if(ioldun.gt.0) rewind ioldun
         i03o29 = 0
         ioldun = 0
         return
      end if
 
      IF(nunit.NE.ioldun)  THEN
 
C THIS IS A NEW UNIT NUMBER, SET 'NEXT' TO 0 AND REWIND THIS UNIT
C ---------------------------------------------------------------
 
CDAKCDAK PRINT 87, NUNIT    NOW REDUNDANT TO PRINT THIS
   87 FORMAT(//' IW3UNP29/I03O29 - PREPARING TO READ ON29 DATA SET IN ',
     $ 'UNIT ',i3/)
         ioldun = nunit
         next = 0
         nfile = 0
         rewind nunit
         iswt = 0
      END IF
 
   10 CONTINUE
 
      IF(next.NE.0)  GO TO 70
 
C COME HERE TO READ IN A NEW RECORD (EITHER REPORTS, Y2K COMPLIANT 40-
C  BYTE PSEUDO-ON85 LBL, NON-Y2K 32-BYTE COMPLIANT ON85 LBL, OR E-O-F)
C --------------------------------------------------------------------
 
      READ(nunit,END=9997,ERR=9998,FMT='(A8)') cbufr
      IF(cbufr(1:4).EQ.'BUFR' .OR. cbufr(5:8).EQ.'BUFR') THEN
 
C  INPUT DATASET IS BUFR - EXIT IMMEDIATELY
C  ----------------------------------------
 
         ioldun = 0
         next = 0
         ier = 999
         GO TO 90
      END IF
 
      rewind nunit
 
      READ(nunit,err=9998,END=9997,FMT='(6432A1)')  cbuff
 
C  IF ISWT=1, CHARACTER DATA IN RECORD ARE EBCDIC - CONVERT TO ASCII
C  -----------------------------------------------------------------
 
      IF(iswt.EQ.1)  CALL aea(cbuff,cbuff,6432)
 
      IF(nfile.EQ.0)  THEN
 
C  TEST FOR EXPECTED HEADER LABEL
C  ------------------------------
 
         nfile = 1
 
         IF(cbuff(25)//cbuff(26)//cbuff(27)//cbuff(28).EQ.'WASH')  THEN
        ELSEIF(cbuff(21)//cbuff(22)//cbuff(23)//cbuff(24).EQ.'WASH')THEN
         ELSE
 
C  QUICK CHECK SHOWS SOMETHING OTHER THAN EITHER Y2K COMPLIANT PSEUDO-
C  ON85 LBL OR NON-Y2K COMPLIANT ON85 LBL FOUND -- COULD MEAN CHARACTER
C  DATA ARE IN EBCDIC, SO SEE IF CONVERSION TO ASCII RECTIFIES THIS
C ---------------------------------------------------------------------
 
            print 78
   78 FORMAT(/' ##IW3UNP29 - NEITHER EXPECTED Y2K COMPLIANT PSEUDO-',
     $ 'ON85 LABEL NOR SECOND CHOICE NON-Y2K COMPLIANT ON85 LABEL ',
     $ 'FOUND IN'/14x,'FIRST RECORD OF FILE  -- TRY EBCDIC TO ASCII ',
     $ 'CONVERSION'/)
            CALL aea(cbuff,cbuff,6432)
            iswt = 1
         END IF
 
         IF(cbuff(25)//cbuff(26)//cbuff(27)//cbuff(28).EQ.'WASH')  THEN
 
C  THIS IS Y2K COMPLIANT 40-BYTE PSEUDO-ON85 LBL; RESET 'NEXT', SET
C   'IER', FILL 'OBS(1)-(4)', AND QUIT
C  ---------------------------------------------------------------
            next = 0
            ier = 1
            obs(1:5) = ibuff(1:5)
            GO TO 90
         ELSE  IF(cbuff(21)//cbuff(22)//cbuff(23)//cbuff(24).EQ.'WASH')
     $    THEN
 
C  THIS IS NON-Y2K COMPLIANT 32-BYTE ON85 LBL; RESET 'NEXT', SET
C   'IER', USE "WINDOWING" TECHNIQUE TO CONTRUCT 4-DIGIT YEAR,
C   CONSTRUCT A 40-BYTE PSEUDO-ON85 LABE, FILL 'OBS(1)-(4)', AND QUIT
C  ------------------------------------------------------------------
            print'(" ==> THIS IS A TRUE OFFICE NOTE 29 FILE!! <==")'
            print 88
   88 FORMAT(/' ##IW3UNP29/I03O29 - WARNING: ORIGINAL NON-Y2K ',
     $ 'COMPLIANT ON85 LABEL FOUND IN FIRST RECORD OF FILE INSTEAD OF ',
     $ 'EXPECTED'/30x,'Y2K COMPLIANT PSEUDO-ON85 LABEL -- THIS ',
     $ 'ROUTINE IS FORCED TO USE "WINDOWING" TECHNIQUE TO CONTRUCT'/30x,
     $'A Y2K COMPLIANT PSEUDO-ON85 LABEL TO RETURN TO CALLING PROGRAM'/)
 
            next = 0
            ier = 1
 
            cbf910 = cbuff(9)//cbuff(10)
            READ(cbf910,'(I2)')  iyr2d
            print'(" ##IW3UNP29/I03O29 - 2-DIGIT YEAR FOUND IN ON85 ",
     $       "LBL (",A,") IS: ",I0/19X," USE WINDOWING TECHNIQUE TO ",
     $       "OBTAIN 4-DIGIT YEAR")', cbuff(1:32),iyr2d
            IF(iyr2d.GT.20)  THEN
               iyr4d = 1900 + iyr2d
            ELSE
               iyr4d = 2000 + iyr2d
            ENDIF
            print'(" ##IW3UNP29/I03O29 - 4-DIGIT YEAR OBTAINED VIA ",
     $       "WINDOWING TECHNIQUE IS: ",I0/)', iyr4d
            con85l = cbuff(1:32)
            cbuff(7:40) = ' '
            cbuff(9:10) = con85l(7:8)
            WRITE(cyr4d,'(I4.4)') iyr4d
            DO i=1,4
              cbuff(10+i) = cyr4d(i:i)
            ENDDO
            cbuff(15:36) = con85l(11:32)
            obs(1:5) = ibuff(1:5)
            GO TO 90
         ELSE
 
C  SOMETHING OTHER THAN EITHER Y2K COMPLIANT PSEUDO-ON85 LBL OR
C  NON-Y2K COMPLIANT ON85 LBL FOUND; RESET 'NEXT', SET 'IER' AND QUIT
C  ------------------------------------------------------------------
CDAKCDAK    PRINT 88  CAN'T PRINT THIS ANYMORE
CDA88 FORMAT(/' ##IW3UNP29/I03O29 - EXPECTED ON85 LABEL NOT FOUND IN ',
CDAK $ 'FIRST RECORD OF NEW LOGICAL FILE  -- IER = 999'/)
            ioldun = 0
            next = 0
            ier = 999
            GO TO 90
         END IF
 
      END IF
 
      IF(cbuff(1)//cbuff(2)//cbuff(3)//cbuff(4).EQ.'ENDO')  THEN
 
C  LOGICAL "ENDOF FILE" READ; RESET NEXT, SET IER, AND QUIT
C  --------------------------------------------------------
 
         next = 0
         ier = 2
         nfile = 0
         GO TO 90
      END IF
      GO TO 70
 
 9997 CONTINUE
 
C  PHYSICAL END OF FILE; RESET 'NEXT', SET 'IER' AND QUIT
C  ------------------------------------------------------
 
      next = 0
      ier = 3
      GO TO 90
 
 9998 CONTINUE
 
C  I/O ERROR; RESET 'NEXT', SET 'IER' AND QUIT
C  -------------------------------------------
 
cppppp
      print'(" ##IW3UNP29/I03O29 - ERROR READING DATA RECORD")'
cppppp
      next = 0
      ier = 4
      GO TO 90
 
   70 CONTINUE
 
C  WORKING WITHIN ACTUAL DATA REC. READ, CALL W3FI64 TO READ IN NEXT RPT
C  ---------------------------------------------------------------------
 
      CALL w3fi64(cbuff,obs,next)
 
      IF(next.GE.0)  THEN
 
C  REPORT SUCCESSFULLY RETURNED IN ARRAY 'OBS'
C  -------------------------------------------
 
         ier = 0
 
      ELSE
 
C HIT END-OF-RECORD, OR INTERNAL READ ERROR ENCOUNTERED & CAN'T RECOVER
C  -- READ IN NEXT RECORD OF REPORTS
C ---------------------------------------------------------------------
 
         next = 0
         GO TO 10
      END IF
 
   90 CONTINUE
 
      i03o29 = ier
 
      RETURN
 
      END
C***********************************************************************
C>    This function read subset and returns group name.
C>    @param SUBSET subset
C>    @return group name
C>
C>    @author Dennis Keyser @date 2013-03-20
C>
C***********************************************************************
      FUNCTION c01o29(SUBSET)
C     ---> formerly FUNCTION ADP
 
      CHARACTER*(*) subset
      CHARACTER*6   c01o29
 
      SAVE
 
      c01o29 = 'NONE'
 
      IF(subset(1:5).EQ.'NC000')  c01o29 = 'ADPSFC'
      IF(subset(1:5).EQ.'NC001')  THEN
         IF(subset(6:8).NE.'006')  THEN
            c01o29 = 'SFCSHP'
         ELSE
            c01o29 = 'SFCBOG'
         END IF
      END IF
      IF(subset(1:5).EQ.'NC002')  c01o29 = 'ADPUPA'
      IF(subset(1:5).EQ.'NC004')  c01o29 = 'AIRCFT'
      IF(subset(1:5).EQ.'NC005')  c01o29 = 'SATWND'
      IF(subset(1:5).EQ.'NC012')  c01o29 = 'SPSSMI'
 
      IF(subset .EQ. 'NC003101')  c01o29 = 'SATEMP'
      IF(subset .EQ. 'NC004004')  c01o29 = 'AIRCAR'
      IF(subset .EQ. 'NC004005')  c01o29 = 'ADPUPA'
 
      IF(subset .EQ. 'ADPSFC')  c01o29 = 'ADPSFC'
      IF(subset .EQ. 'SFCSHP')  c01o29 = 'SFCSHP'
      IF(subset .EQ. 'SFCBOG')  c01o29 = 'SFCBOG'
      IF(subset .EQ. 'ADPUPA')  c01o29 = 'ADPUPA'
      IF(subset .EQ. 'AIRCFT')  c01o29 = 'AIRCFT'
      IF(subset .EQ. 'SATWND')  c01o29 = 'SATWND'
      IF(subset .EQ. 'SATEMP')  c01o29 = 'SATEMP'
      IF(subset .EQ. 'AIRCAR')  c01o29 = 'AIRCAR'
      IF(subset .EQ. 'SPSSMI')  c01o29 = 'SPSSMI'
 
      IF(c01o29.EQ.'NONE') print'(" ##IW3UNP29/C01O29 - UNKNOWN SUBSET",
     $ " (=",A,") -- CONTINUE~~")', subset
 
      RETURN
      END
C***********************************************************************
C>    This function read subset and returns corresponding file data.
C>    @param SUBSET subset
C>    @param LUNIT full path of file
C>    @param OBS data output
C>    @return file data
C>
C>    @author Dennis Keyser @date 2013-03-20
C>
C***********************************************************************
      FUNCTION r01o29(SUBSET,LUNIT,OBS)
C     ---> formerly FUNCTION ADC
 
      CHARACTER*(*) subset
      CHARACTER*6   c01o29,adpsub
      dimension     obs(*)
 
      SAVE
 
C  FIND AN ON29/124 DATA TYPE AND CALL A TRANSLATOR
C  ------------------------------------------------
 
      r01o29 = 4
      adpsub = c01o29(subset)
      IF(adpsub .EQ. 'ADPSFC')  r01o29 = r04o29(lunit,obs)
      IF(adpsub .EQ. 'SFCSHP')  r01o29 = r04o29(lunit,obs)
      IF(adpsub .EQ. 'SFCBOG')  r01o29 = r04o29(lunit,obs)
      IF(adpsub .EQ. 'ADPUPA')  r01o29 = r03o29(lunit,obs)
      IF(adpsub .EQ. 'AIRCFT')  r01o29 = r05o29(lunit,obs)
      IF(adpsub .EQ. 'AIRCAR')  r01o29 = r05o29(lunit,obs)
      IF(adpsub .EQ. 'SATWND')  r01o29 = r06o29(lunit,obs)
      IF(adpsub .EQ. 'SPSSMI')  r01o29 = r07o29(lunit,obs)
      RETURN
      END
C***********************************************************************
C***********************************************************************
C***********************************************************************
      SUBROUTINE s01o29(SID,XOB,YOB,RHR,RCH,RSV,RSV2,ELV,ITP,RTP)
C     ---> Formerly SUBROUTINE O29HDR
 
      common/io29dd/hdr(12),rcats(50,150,11),ikat(11),mcat(11),ncat(11)
      common/io29ll/bmiss
 
      CHARACTER*(*) rsv,rsv2
      CHARACTER*8   cob,sid,rct
      dimension     ihdr(12),rhdr(12),icats(50,150,11)
      REAL(8)       bmiss
      equivalence(ihdr(1),rhdr(1)),(cob,iob),(icats,rcats)
 
      SAVE
 
      DATA omiss/99999/
 
C  INITIALIZE THE UNPACK ARRAY TO MISSINGS
C  ---------------------------------------
 
      ncat = 0
      rcats = omiss
      cob = '        '
      icats(6,1:149,1) = iob
      icats(4,1:149,2) = iob
      icats(4,1:149,3) = iob
      icats(4,1:149,4) = iob
      icats(6,1:149,5) = iob
      icats(6,1:149,6) = iob
      icats(3,1:149,7) = iob
      icats(3,1:149,8) = iob
 
C  WRITE THE RECEIPT TIME IN CHARACTERS
C  ------------------------------------
 
      rct = '9999    '
      IF(rch*100.LT.2401.AND.rch*100.GT.-1)
     $ WRITE(rct,'(I4.4)') nint(rch*100.)
 
C  STORE THE ON29 HEADER INFORMATION INTO UNP FORMAT
C  -------------------------------------------------
 
      rhdr( 1) = omiss
      IF(yob.LT.bmiss)  rhdr( 1) = nint(100.*yob)
cppppp
      IF(yob.GE.bmiss)  print'(" ~~IW3UNP29/S01O29: ID ",A," has a ",
     $ "missing LATITUDE - on29 hdr, word 1 is set to ",G0)',
     $ sid,rhdr(1)
cppppp
      rhdr( 2) = omiss
      IF(xob.LT.bmiss)  rhdr( 2) = nint(100.*mod(720.-xob,360.))
cppppp
      IF(xob.GE.bmiss)  print'(" ~~IW3UNP29/S01O29: ID ",A," has a ",
     $ "missing LONGITUDE - on29 hdr, word 2 is set to ",G0)',
     $ sid,rhdr(2)
cppppp
      rhdr( 3) = omiss
      rhdr( 4) = omiss
      IF(rhr.LT.bmiss)  rhdr( 4) = nint((100.*rhr)+0.0001)
cppppp
      IF(rhr.GE.bmiss)  print'(" ~~IW3UNP29/S01O29: ID ",A," has a ",
     $ "missing OB TIME - on29 hdr, word 4 is set to ",G0)', sid,rhdr(4)
cppppp
      IF(rsv2.EQ.'        ')  THEN
         cob = '        '
         cob(1:4) = rct(3:4)//rsv(1:2)
         ihdr(5) = iob
         cob = '        '
         cob(1:3) = rct(1:2)//rsv(3:3)
         ihdr(6) = iob
      ELSE
         cob = '        '
         cob(1:4) = rsv2(3:4)//rsv(1:2)
         ihdr(5) = iob
         cob = '        '
         cob(1:3) = rsv2(1:2)//rsv(3:3)
         ihdr(6) = iob
      END IF
      rhdr( 7) = nint(elv)
      ihdr( 8) = itp
      ihdr( 9) = rtp
      rhdr(10) = omiss
      cob = '        '
      cob(1:4) = sid(1:4)
      ihdr(11) = iob
      cob = '        '
      cob(1:4) = sid(5:6)//'  '
      ihdr(12) = iob
 
C  STORE THE HEADER INTO A HOLDING ARRAY
C  -------------------------------------
 
      hdr = rhdr
 
      RETURN
      END
C***********************************************************************
C***********************************************************************
C***********************************************************************
      SUBROUTINE s02o29(ICAT,N,*)
C     ---> Formerly SUBROUTINE O29CAT
 
      common/io29dd/hdr(12),rcats(50,150,11),ikat(11),mcat(11),ncat(11)
      common/io29ee/pob(255),qob(255),tob(255),zob(255),dob(255),
     $              sob(255),vsg(255),clp(255),cla(255),ob8(255),
     $              cf8(255)
      common/io29ff/pqm(255),qqm(255),tqm(255),zqm(255),wqm(255),
     $              qcp(255),qca(255),q81(255),q82(255)
      common/io29gg/psl,stp,sdr,ssp,stm,dpd,tmx,tmi,hvz,prw,pw1,ccn,chn,
     $              ctl,ctm,cth,hcb,cpt,apt,pc6,snd,p24,dop,pow,how,swd,
     $              swp,swh,sst,spg,spd,shc,sas,wes
      common/io29hh/psq,spq,swq,stq,ddq
      common/io29ii/pwmin
      common/io29ll/bmiss
 
      CHARACTER*8 cob,c11,c12
      CHARACTER*1 pqm,qqm,tqm,zqm,wqm,qcp,qca,q81,q82,psq,spq,swq,stq,
     $ ddq
      dimension   rcat(50),jcat(50)
      REAL(8)     bmiss
      equivalence(rcat(1),jcat(1)),(c11,hdr(11)),(c12,hdr(12)),
     $ (cob,iob)
      LOGICAL     surf
 
      SAVE
 
cppppp-ID
      iprint = 0
c     if(C11(1:4)//C12(1:2).eq.'59758 ')  iprint = 1
c     if(C11(1:4)//C12(1:2).eq.'59362 ')  iprint = 1
c     if(C11(1:4)//C12(1:2).eq.'57957 ')  iprint = 1
c     if(C11(1:4)//C12(1:2).eq.'74794 ')  iprint = 1
c     if(C11(1:4)//C12(1:2).eq.'74389 ')  iprint = 1
c     if(C11(1:4)//C12(1:2).eq.'96801A')  iprint = 1
cppppp-ID
 
      surf = .false.
      GOTO 1
 
C  ENTRY POINT SE01O29 FORCES DATA INTO THE SURFACE (FIRST) LEVEL
C  --------------------------------------------------------------
 
      entry se01o29(icat,n)
C     ---> formerly ENTRY O29SFC
      surf = .true.
 
C  CHECK THE PARAMETERS COMING IN
C  ------------------------------
 
1     kcat = 0
      DO i = 1,11
         IF(icat.EQ.ikat(i))  THEN
            kcat = i
            GO TO 991
         END IF
      ENDDO
 
  991 CONTINUE
 
C  PARAMETER ICAT (ON29 CATEGORY) OUT OF BOUNDS RETURNS A 999
C  ----------------------------------------------------------
 
      IF(kcat.EQ.0)  THEN
         print'(" ##IW3UNP29/S02O29 - ON29 CATEGORY ",I0," OUT OF ",
     $    "BOUNDS -- IER = 999")', icat
         RETURN 1
      END IF
 
C  PARAMETER N (LEVEL INDEX) OUT OF BOUNDS RETURNS A 999
C  -----------------------------------------------------
 
      IF(n.GT.255)  THEN
         print'(" ##IW3UNP29/S02O29 - LEVEL INDEX ",I0," EXCEEDS 255 ",
     $    "-- IER = 999")', n
         RETURN 1
      END IF
 
C  MAKE A MISSING LEVEL AND RETURN WHEN N=0 (NOT ALLOWED FOR CAT 01)
C  -----------------------------------------------------------------
 
      IF(n.EQ.0) THEN
         IF(kcat.EQ.1) RETURN
         ncat(kcat) = min(149,ncat(kcat)+1)
cppppp
         if(iprint.eq.1)
     $    print'(" To prepare for sfc. data, write all missings on ",
     $     "lvl ",I0," for cat ",I0)', ncat(kcat),kcat
cppppp
         RETURN
      END IF
 
C  FIGURE OUT WHICH LEVEL TO UPDATE AND RESET THE LEVEL COUNTER
C  ------------------------------------------------------------
 
      IF(kcat.EQ.1) THEN
         l = i04o29(pob(n)*.1)
         IF(l.EQ.999999)  GO TO 9999
 
C  BAD MANDATORY LEVEL RETURNS A 999
C  ---------------------------------
 
         IF(l.LE.0)  THEN
            print'(" ##IW3UNP29/S02O29 - BAD MANDATORY LEVEL (P = ",
     $       G0,") -- IER = 999")', pob(n)
            RETURN 1
         END IF
         ncat(kcat) = max(ncat(kcat),l)
cppppp
         if(iprint.eq.1)
     $    print'(" Will write cat. 1 data on lvl ",I0," for cat ",I0,
     $    ", - total no. cat. 1 lvls processed so far = ",I0)',
     $    l,kcat,ncat(kcat)
cppppp
      ELSEIF(surf) THEN
         l = 1
         ncat(kcat) = max(ncat(kcat),1)
cppppp
         if(iprint.eq.1)
     $    print'(" Will write cat. ",I0," SURFACE data on lvl ",I0,
     $    ", - total no. cat. ",I0," lvls processed so far = ",I0)',
     $    kcat,l,kcat,ncat(kcat)
cppppp
      ELSE
         l = min(149,ncat(kcat)+1)
         IF(l.EQ.149) THEN
cppppp
            print'(" ~~IW3UNP29/S02O29: ID ",A," - This cat. ",I0,
     $       " level cannot be processed because the limit has already",
     $       " been reached")', c11(1:4)//c12(1:2),kcat
cppppp
            RETURN
         END IF
         ncat(kcat) = l
cppppp
         if(iprint.eq.1)
     $    print'(" Will write cat. ",I0," NON-SFC data on lvl ",I0,
     $    ", - total no. cat. ",I0," lvls processed so far = ",I0)',
     $    kcat,l,kcat,ncat(kcat)
cppppp
      END IF
 
C  EACH CATEGORY NEEDS A SPECIFIC DATA ARRANGEMENT
C  -----------------------------------------------
 
      cob = '        '
      IF(icat.EQ.1) THEN
         rcat(1) = min(nint(zob(n)),nint(rcats(1,l,kcat)))
         rcat(2) = min(nint(tob(n)),nint(rcats(2,l,kcat)))
         rcat(3) = min(nint(qob(n)),nint(rcats(3,l,kcat)))
         rcat(4) = min(nint(dob(n)),nint(rcats(4,l,kcat)))
         rcat(5) = min(nint(sob(n)),nint(rcats(5,l,kcat)))
         cob(1:4) = zqm(n)//tqm(n)//qqm(n)//wqm(n)
         jcat(6) = iob
      ELSEIF(icat.EQ.2) THEN
         rcat(1) = min(nint(pob(n)),99999)
         rcat(2) = min(nint(tob(n)),99999)
         rcat(3) = min(nint(qob(n)),99999)
         cob(1:3) = pqm(n)//tqm(n)//qqm(n)
         jcat(4) = iob
      ELSEIF(icat.EQ.3) THEN
         rcat(1) = min(nint(pob(n)),99999)
         rcat(2) = min(nint(dob(n)),99999)
         rcat(3) = min(nint(sob(n)),99999)
 
C  MARK THE TROPOPAUSE LEVEL IN CAT. 3
 
         IF(nint(vsg(n)).EQ.16)  pqm(n) = 'T'
 
C  MARK THE MAXIMUM WIND LEVEL IN CAT. 3
 
         IF(nint(vsg(n)).EQ. 8)  THEN
            pqm(n) = 'W'
            IF(pob(n).EQ.pwmin)  pqm(n) = 'X'
         END IF
         cob(1:2) = pqm(n)//wqm(n)
         jcat(4) = iob
      ELSEIF(icat.EQ.4) THEN
         rcat(1) = min(nint(zob(n)),99999)
         rcat(2) = min(nint(dob(n)),99999)
         rcat(3) = min(nint(sob(n)),99999)
         cob(1:2) = zqm(n)//wqm(n)
         jcat(4) = iob
      ELSEIF(icat.EQ.5) THEN
         rcat(1) = min(nint(pob(n)),99999)
         rcat(2) = min(nint(tob(n)),99999)
         rcat(3) = min(nint(qob(n)),99999)
         rcat(4) = min(nint(dob(n)),99999)
         rcat(5) = min(nint(sob(n)),99999)
         cob(1:4) = pqm(n)//tqm(n)//qqm(n)//wqm(n)
         jcat(6) = iob
      ELSEIF(icat.EQ.6) THEN
         rcat(1) = min(nint(zob(n)),99999)
         rcat(2) = min(nint(tob(n)),99999)
         rcat(3) = min(nint(qob(n)),99999)
         rcat(4) = min(nint(dob(n)),99999)
         rcat(5) = min(nint(sob(n)),99999)
         cob(1:4) = zqm(n)//tqm(n)//qqm(n)//wqm(n)
         jcat(6) = iob
      ELSEIF(icat.EQ.7) THEN
         rcat(1) = min(nint(clp(n)),99999)
         rcat(2) = min(nint(cla(n)),99999)
         cob(1:2) = qcp(n)//qca(n)
         jcat(3) = iob
      ELSEIF(icat.EQ.8) THEN
         rcat(1) = min(nint(ob8(n)),99999)
         rcat(2) = min(nint(cf8(n)),99999)
         cob(1:2) = q81(n)//q82(n)
         jcat(3) = iob
      ELSEIF(icat.EQ.51) THEN
         rcat( 1) = min(nint(psl),99999)
         rcat( 2) = min(nint(stp),99999)
         rcat( 3) = min(nint(sdr),99999)
         rcat( 4) = min(nint(ssp),99999)
         rcat( 5) = min(nint(stm),99999)
         rcat( 6) = min(nint(dpd),99999)
         rcat( 7) = min(nint(tmx),99999)
         rcat( 8) = min(nint(tmi),99999)
         cob(1:4) = psq//spq//swq//stq
         jcat(9) = iob
         cob = '        '
         cob(1:1) = ddq
         jcat(10) = iob
         jcat(11) = min(nint(hvz),99999)
         jcat(12) = min(nint(prw),99999)
         jcat(13) = min(nint(pw1),99999)
         jcat(14) = min(nint(ccn),99999)
         jcat(15) = min(nint(chn),99999)
         jcat(16) = min(nint(ctl),99999)
         jcat(17) = min(nint(hcb),99999)
         jcat(18) = min(nint(ctm),99999)
         jcat(19) = min(nint(cth),99999)
         jcat(20) = min(nint(cpt),99999)
         rcat(21) = min(abs(nint(apt)),99999)
         IF(cpt.GE.bmiss.AND.apt.LT.0.)
     $    rcat(21) = min(abs(nint(apt))+500,99999)
      ELSEIF(icat.EQ.52) THEN
         jcat( 1) = min(nint(pc6),99999)
         jcat( 2) = min(nint(snd),99999)
         jcat( 3) = min(nint(p24),99999)
         jcat( 4) = min(nint(dop),99999)
         jcat( 5) = min(nint(pow),99999)
         jcat( 6) = min(nint(how),99999)
         jcat( 7) = min(nint(swd),99999)
         jcat( 8) = min(nint(swp),99999)
         jcat( 9) = min(nint(swh),99999)
         jcat(10) = min(nint(sst),99999)
         jcat(11) = min(nint(spg),99999)
         jcat(12) = min(nint(spd),99999)
         jcat(13) = min(nint(shc),99999)
         jcat(14) = min(nint(sas),99999)
         jcat(15) = min(nint(wes),99999)
      ELSE
 
C  UNSUPPORTED CATEGORY RETURNS A 999
C  ----------------------------------
 
         print'(" ##IW3UNP29/S02O29 - CATEGORY ",I0," NOT SUPPORTED ",
     $    "-- IER = 999")', icat
         RETURN 1
      END IF
 
C  TRANSFER THE LEVEL DATA INTO THE HOLDING ARRAY AND EXIT
C  -------------------------------------------------------
 
      DO i = 1,mcat(kcat)
         rcats(i,l,kcat) = rcat(i)
      ENDDO
 
      RETURN
 9999 CONTINUE
      RETURN 1
      END
C***********************************************************************
C***********************************************************************
C***********************************************************************
      SUBROUTINE s03o29(UNP,SUBSET,*,*)
C     ---> Formerly SUBROUTINE O29UNP
 
      common/io29dd/hdr(12),rcats(50,150,11),ikat(11),mcat(11),ncat(11)
 
      dimension   rcat(50),jcat(50),unp(*)
      CHARACTER*8  subset
      equivalence(rcat(1),jcat(1))
 
      SAVE
 
C  CALL TO SORT CATEGORIES 02, 03, 04, AND 08 LEVELS
C  -------------------------------------------------
 
      CALL s04o29
 
C  TRANSFER DATA FROM ALL CATEGORIES INTO UNP ARRAY & SET POINTERS
C  ---------------------------------------------------------------
 
      indx = 43
      jcat = 0
      nlevto = 0
      nlevc8 = 0
 
      DO k = 1,11
         jcat(2*k+11) = ncat(k)
         IF(k.NE.7.AND.k.NE.8.AND.k.NE.11)  THEN
            nlevto = nlevto + ncat(k)
         ELSE  IF(k.EQ.8)  THEN
            nlevc8 = nlevc8 + ncat(k)
         END IF
         IF(ncat(k).GT.0) jcat(2*k+12) = indx
         IF(ncat(k).EQ.0) jcat(2*k+12) = 0
         DO j = 1,ncat(k)
         DO i = 1,mcat(k)
 
C  UNPACKED ON29 REPORT CONTAINS MORE THAN 1608 WORDS - RETURNS A 999
C  ------------------------------------------------------------------
 
            IF(indx.GT.1608)  THEN
               print'(" ##IW3UNP29/S03O29 - UNPKED ON29 RPT CONTAINS ",
     $          I0," WORDS, > LIMIT OF 1608 -- IER = 999")', indx
               RETURN 1
            END IF
            unp(indx) = rcats(i,j,k)
            indx = indx+1
         ENDDO
         ENDDO
      ENDDO
 
C  RETURN WITHOUT PROCESSING THIS REPORT IF NO DATA IN CAT. 1-6, 51, 52
C   (UNLESS SSM/I REPORT, THEN DO NOT RETURN UNLESS ALSO NO CAT. 8 DATA)
C  --------------------------------------------------------------------
 
      IF(nlevto.EQ.0)  THEN
         IF(subset(1:5).NE.'NC012')  THEN
            RETURN 2
         ELSE
            IF(nlevc8.EQ.0)  RETURN 2
         END IF
      END IF
 
C  TRANSFER THE HEADER AND POINTER ARRAYS INTO UNP
C  -----------------------------------------------
 
      unp(1:12) =  hdr
      unp(13:42) = rcat(13:42)
 
      RETURN
      END
C***********************************************************************
C***********************************************************************
C***********************************************************************
      SUBROUTINE s04o29
C     ---> Formerly SUBROUTINE O29SRT
 
      common/io29dd/hdr(12),rcats(50,150,11),ikat(11),mcat(11),ncat(11)
cppppp
      character*8 c11,c12,sid
cppppp
 
      dimension rcat(50,150),iord(150),iwork(65536),scat(50,150),rctl(3)
cppppp
      equivalence(c11,hdr(11)),(c12,hdr(12))
cppppp
 
      SAVE
 
cppppp
      sid = c11(1:4)//c12(1:4)
cppppp
 
C  SORT CATEGORIES 2, 3, AND 4 - LEAVE THE FIRST LEVEL IN EACH INTACT
C  ------------------------------------------------------------------
 
      DO k=2,4
         IF(ncat(k).GT.1) THEN
            DO j=1,ncat(k)-1
            DO i=1,mcat(k)
               scat(i,j) = rcats(i,j+1,k)
            ENDDO
            ENDDO
            CALL orders(2,iwork,scat(1,1),iord,ncat(k)-1,50,8,2)
            rctl = 10e9
            DO j=1,ncat(k)-1
               IF(k.LT.4) jj = iord((ncat(k)-1)-j+1)
               IF(k.EQ.4) jj = iord(j)
               DO i=1,mcat(k)
                  rcat(i,j) = scat(i,jj)
               ENDDO
               idup = 0
               IF(nint(rcat(1,j)).EQ.nint(rctl(1)))  THEN
                  IF(nint(rcat(2,j)).EQ.nint(rctl(2)).AND.
     $               nint(rcat(3,j)).EQ.nint(rctl(3)))  THEN
cppppp
                     if(k.ne.4)  then
                        print'(" ~~@@IW3UNP29/S04O29: ID ",A," has a ",
     $ "dupl. cat. ",I0," lvl (all data) at ",G0," mb -- lvl will be ",
     $ "excluded from processing")', sid,k,rcat(1,j)*.1
                     else
                        print'(" ~~@@IW3UNP29/S04O29: ID ",A," has a ",
     $ "dupl. cat. ",I0," lvl (all data) at ",G0," m -- lvl will be ",
     $ "excluded from processing")', sid,k,rcat(1,j)
                     end if
cppppp
                     idup = 1
                  ELSE
cppppp
                     if(k.ne.4)  then
                        print'(" ~~@@#IW3UNP29/S04O29: ID ",A," has a ",
     $ "dupl. cat. ",I0," press. lvl (data differ) at ",G0," mb -- lvl",
     $ " will NOT be excluded")', sid,k,rcat(1,j)*.1
                     else
                        print'(" ~~@@#IW3UNP29/S04O29: ID ",A," has a ",
     $ "dupl. cat. ",I0," height lvl (data differ) at ",G0," m -- lvl ",
     $ "will NOT be excluded")', sid,k,rcat(1,j)
                     end if
cppppp
                  END IF
               END IF
               rctl = rcat(1:3,j)
               IF(idup.EQ.1)  rcat(1,j) = 10e8
            ENDDO
            jjj = 1
            DO j=2,ncat(k)
               IF(rcat(1,j-1).GE.10e8)  GO TO 887
               jjj = jjj + 1
               DO i=1,mcat(k)
                  rcats(i,jjj,k) = rcat(i,j-1)
               ENDDO
  887          CONTINUE
            ENDDO
cppppp
            if(jjj.ne.ncat(k))
     $       print'(" ~~@@IW3UNP29/S04O29: ID ",A," has had ",I0,
     $        " lvls removed due to their being duplicates")',
     $        sid,ncat(k)-jjj
cppppp
            ncat(k) = jjj
         end if
         IF(ncat(k).EQ.1)  THEN
            IF(min(rcats(1,1,k),rcats(2,1,k),rcats(3,1,k)).GT.99998.8)
     $       ncat(k) = 0
         END IF
      ENDDO
 
C  SORT CATEGORY 08 BY CODE FIGURE
C  -------------------------------
 
      DO k=8,8
      IF(ncat(k).GT.1) THEN
         CALL orders(2,iwork,rcats(2,1,k),iord,ncat(k),50,8,2)
         DO j=1,ncat(k)
         DO i=1,mcat(k)
         rcat(i,j) = rcats(i,iord(j),k)
         ENDDO
         ENDDO
         DO j=1,ncat(k)
         DO i=1,mcat(k)
         rcats(i,j,k) = rcat(i,j)
         ENDDO
         ENDDO
      END IF
      ENDDO
 
C  NORMAL EXIT
C  -----------
 
      RETURN
      END
C***********************************************************************
C***********************************************************************
C***********************************************************************
      SUBROUTINE s05o29
C     ---> Formerly SUBROUTINE O29INX
 
      common/io29ee/obs(255,11)
      common/io29ff/qms(255,9)
      common/io29gg/sfo(34)
      common/io29hh/sfq(5)
      common/io29ll/bmiss
 
      CHARACTER*1 qms,sfq
 
      REAL(8)     bmiss
 
      SAVE
 
C  SET THE INPUT DATA ARRAYS TO MISSING OR BLANK
C  ---------------------------------------------
 
      obs = bmiss
      qms = ' '
      sfo = bmiss
      sfq = ' '
 
      RETURN
      END
C***********************************************************************
C***********************************************************************
C***********************************************************************
      FUNCTION i04o29(P)
C     ---> formerly FUNCTION MANO29
 
      common/io29jj/iset,manlin(1001)
 
      SAVE
 
      IF(iset.EQ.0) THEN
         manlin = 0
 
         manlin(1000) =  1
         manlin(850)  =  2
         manlin(700)  =  3
         manlin(500)  =  4
         manlin(400)  =  5
         manlin(300)  =  6
         manlin(250)  =  7
         manlin(200)  =  8
         manlin(150)  =  9
         manlin(100)  = 10
         manlin(70)   = 11
         manlin(50)   = 12
         manlin(30)   = 13
         manlin(20)   = 14
         manlin(10)   = 15
         manlin(7)    = 16
         manlin(5)    = 17
         manlin(3)    = 18
         manlin(2)    = 19
         manlin(1)    = 20
 
         iset = 1
      END IF
 
      ip = nint(p*10.)
 
      IF(ip.GT.10000 .OR. ip.LT.10 .OR. mod(ip,10).NE.0) THEN
         i04o29 = 0
      ELSE
         i04o29 = manlin(ip/10)
      END IF
 
      RETURN
 
      END
C***********************************************************************
C***********************************************************************
C***********************************************************************
      FUNCTION r02o29()
C     ---> formerly FUNCTION ONFUN
 
      common/io29ll/bmiss
 
      CHARACTER*8 subset,rpid
      LOGICAL     l02o29,l03o29
      INTEGER kkk(0:99),kkkk(49)
      REAL(8) bmiss
 
      SAVE
 
      DATA grav/9.8/,cm2k/1.94/,tzro/273.15/
      DATA kkk /5*90,16*91,30*92,49*93/
      DATA kkkk/94,2*95,6*96,10*97,30*98/
 
      prs1(z) = 1013.25 * (((288.15 - (.0065 * z))/288.15)**5.256)
      prs2(z) = 226.3 * exp(1.576106e-4 * (11000. - z))
      prs3(pmnd,temp,z,zmnd)
     $ = pmnd * (((temp - (.0065 * (z - zmnd)))/temp)**5.256)
      es(t) = 6.1078 * exp((17.269 * (t-273.16))/((t-273.16)+237.3))
      qfrmtp(t,pppp) = (0.622 * es(t))/(pppp-(0.378 * es(t)))
      hgtf(p) = (1.-(p/1013.25)**(1./5.256))*(288.15/.0065)
 
      r02o29 = 0
 
      RETURN
 
      entry e01o29(prs)
C     ---> formerly ENTRY ONPRS
         IF(prs.LT.bmiss) e01o29 =  nint(prs*.1)
         IF(prs.GE.bmiss) e01o29 =  bmiss
         RETURN
      entry e37o29(pmnd,temp,hgt,zmnd,tqm)
C     ---> formerly ENTRY ONPFHT
         IF(hgt.GE.bmiss)  THEN
            e37o29 =  bmiss
         ELSE
            IF(hgt.LE.11000)  THEN
               p =  prs1(hgt)
            ELSE
               p =  prs2(hgt)
            END IF
            IF(max(pmnd,zmnd).GE.bmiss)  THEN
               e37o29 = p
               RETURN
            END IF
            IF(temp.GE.9999.) temp = bmiss
            IF(tqm.GE.bmiss)  tqm = 2
            IF(temp.GE.bmiss.OR.tqm.GE.4)  CALL w3fa03(p,d1,temp,d2)
            q = qfrmtp(temp,p)
            tvirt = temp * (1.0 + (0.61 * q))
            e37o29 = prs3(pmnd,tvirt,hgt,zmnd)
         END IF
         RETURN
      entry e03o29(prs)
C     ---> formerly ENTRY ONHFP
         IF(prs.LT.bmiss) e03o29 =  hgtf(prs)
         IF(prs.GE.bmiss) e03o29 =  bmiss
         RETURN
      entry e04o29(wdr,wsp)
C     ---> formerly ENTRY ONWDR
         e04o29 = wdr
         RETURN
      entry e05o29(wdr,wsp)
C     ---> formerly ENTRY ONWSP
         IF(wsp.LT.bmiss) THEN
            e05o29 = (wsp*cm2k)
            e05o29 = e05o29 + 0.0000001
         ELSE
            e05o29 = bmiss
         END IF
         RETURN
      entry e06o29(tmp)
C     ---> formerly ENTRY ONTMP
         itmp = nint(tmp*100.)
         itzro = nint(tzro*100.)
         IF(tmp.LT.bmiss) e06o29 = nint((itmp - itzro)*0.1)
         IF(tmp.GE.bmiss) e06o29 = bmiss
         RETURN
      entry e07o29(dpd,tmp)
C     ---> formerly ENTRY ONDPD
         IF(dpd.LT.bmiss .AND. tmp.LT.bmiss) e07o29 = (tmp-dpd)*10.
         IF(dpd.GE.bmiss .OR.  tmp.GE.bmiss) e07o29 = bmiss
         RETURN
      entry e08o29(hgt)
C     ---> formerly ENTRY ONHGT
         e08o29 = hgt
         IF(hgt.LT.bmiss) e08o29 = (hgt/grav)
         RETURN
      entry e09o29(hvz)
C     ---> formerly ENTRY ONHVZ
         IF(hvz.GE.bmiss.OR.hvz.LT.0.) THEN
            e09o29 = bmiss
         ELSE  IF(nint(hvz).LT.6000)  THEN
            e09o29 = min(int(nint(hvz)/100),50)
         ELSE  IF(nint(hvz).LT.30000)  THEN
            e09o29 = int(nint(hvz)/1000) + 50
         ELSE  IF(nint(hvz).LE.70000)  THEN
            e09o29 = int(nint(hvz)/5000) + 74
         ELSE
            e09o29 = 89
         END IF
         RETURN
      entry e10o29(prw)
C     ---> formerly ENTRY ONPRW
         e10o29 = bmiss
         IF(prw.LT.bmiss)  e10o29 = nint(mod(prw,100.))
         RETURN
      entry e11o29(paw)
C     ---> formerly ENTRY ONPAW
         e11o29 = bmiss
         IF(paw.LT.bmiss)  e11o29 = nint(mod(paw,10.))
         RETURN
      entry e12o29(ccn)
C     ---> formerly ENTRY ONCCN
         IF(nint(ccn).EQ.0)  THEN
            e12o29 = 0
         ELSE  IF(ccn.LT. 15)  THEN
            e12o29 = 1
         ELSE  IF(ccn.LT. 35)  THEN
            e12o29 = 2
         ELSE  IF(ccn.LT. 45)  THEN
            e12o29 = 3
         ELSE  IF(ccn.LT. 55)  THEN
            e12o29 = 4
         ELSE  IF(ccn.LT. 65)  THEN
            e12o29 = 5
         ELSE  IF(ccn.LT. 85)  THEN
            e12o29 = 6
         ELSE  IF(ccn.LT.100)  THEN
            e12o29 = 7
         ELSE  IF(nint(ccn).EQ.100)  THEN
            e12o29 = 8
         ELSE
            e12o29 = bmiss
         END IF
         RETURN
      entry e13o29(cla)
C     ---> formerly ENTRY ONCLA
         e13o29 = bmiss
         IF(cla.EQ.0) e13o29 = 0
         IF(cla.EQ.1) e13o29 = 5
         IF(cla.EQ.2) e13o29 = 25
         IF(cla.EQ.3) e13o29 = 40
         IF(cla.EQ.4) e13o29 = 50
         IF(cla.EQ.5) e13o29 = 60
         IF(cla.EQ.6) e13o29 = 75
         IF(cla.EQ.7) e13o29 = 95
         IF(cla.EQ.8) e13o29 = 100
         RETURN
      entry e14o29(ccl,ccm)
C     ---> formerly ENTRY ONCHN
         e14o29 = ccl
         IF(nint(e14o29).EQ.0)  e14o29 = ccm
         IF(nint(e14o29).LT.10)  RETURN
         IF(nint(e14o29).EQ.10)  THEN
            e14o29 = 9.
         ELSE  IF(nint(e14o29).EQ.15)  THEN
            e14o29 = 10.
         ELSE
            e14o29 = bmiss
         END IF
         RETURN
      entry e15o29(ctlmh)
C     ---> formerly ENTRY ONCTL, ONCTM, ONCTH
         e15o29 = ctlmh
         RETURN
      entry e18o29(chl,chm,chh,ctl,ctm,cth)
C     ---> formerly ENTRY ONHCB
         IF(nint(max(ctl,ctm,cth)).EQ.0)  THEN
            e18o29 = 9
            RETURN
         END IF
         e18o29 = bmiss
         IF(chh.LT.bmiss) e18o29 = chh
         IF(chm.LT.bmiss) e18o29 = chm
         IF(chl.LT.bmiss) e18o29 = chl
         IF(e18o29.GE.bmiss.OR.e18o29.LT.0)  RETURN
         IF(e18o29.LT. 150)  THEN
            e18o29 = 0
         ELSE  IF(e18o29.LT. 350)  THEN
            e18o29 = 1
         ELSE  IF(e18o29.LT. 650)  THEN
            e18o29 = 2
         ELSE  IF(e18o29.LT. 950)  THEN
            e18o29 = 3
         ELSE  IF(e18o29.LT.1950)  THEN
            e18o29 = 4
         ELSE  IF(e18o29.LT.3250)  THEN
            e18o29 = 5
         ELSE  IF(e18o29.LT.4950)  THEN
            e18o29 = 6
         ELSE  IF(e18o29.LT.6750)  THEN
            e18o29 = 7
         ELSE  IF(e18o29.LT.8250)  THEN
            e18o29 = 8
         ELSE
            e18o29 = 9
         END IF
         RETURN
      entry e19o29(cpt)
C     ---> formerly ENTRY ONCPT
         e19o29 = bmiss
         IF(nint(cpt).GT.-1.AND.nint(cpt).LT.9)  e19o29 = cpt
         RETURN
      entry e20o29(prc)
C     ---> formerly ENTRY ONPRC
         e20o29 = prc
         IF(prc.LT.0.) THEN
            e20o29 = 9998
         ELSE  IF(prc.LT.bmiss) THEN
            e20o29 = nint(prc*3.937)
         END IF
         RETURN
      entry e21o29(snd)
C     ---> formerly ENTRY ONSND
         e21o29 = snd
         IF(snd.LT.0.) THEN
            e21o29 = 998
         ELSE  IF(snd.LT.bmiss) THEN
            e21o29 = nint(snd*39.37)
         END IF
         RETURN
      entry e22o29(pc6)
C     ---> formerly ENTRY ONDOP
         e22o29 = bmiss
         IF(pc6.LT.bmiss)  e22o29 = 1
         RETURN
      entry e23o29(per)
C     ---> formerly ENTRY ONPOW, ONSWP
         e23o29 = nint(per)
         RETURN
      entry e24o29(hgt)
C     ---> formerly ENTRY ONHOW, ONSWH
         e24o29 = hgt
         IF(hgt.LT.bmiss) e24o29 = nint(2.*hgt)
         RETURN
      entry e25o29(swd)
C     ---> formerly ENTRY ONSWD
         e25o29 = swd
         IF(swd.EQ.0)  THEN
            e25o29 = 0
         ELSE  IF(swd.LT.5)  THEN
            e25o29 = 36
         ELSE  IF(swd.LT.bmiss)  THEN
            e25o29 = nint((swd+.001)*.1)
         END IF
         RETURN
      entry e28o29(spg)
C     ---> formerly ENTRY ONSPG
         e28o29 = spg
         RETURN
      entry e29o29(spd)
C     ---> formerly ENTRY ONSPD
         e29o29 = spd
         RETURN
      entry e30o29(shc)
C     ---> formerly ENTRY ONSHC
         e30o29 = bmiss
         IF(nint(shc).GT.-1.AND.nint(shc).LT.9)  e30o29 = nint(shc)
         RETURN
      entry e31o29(sas)
C     ---> formerly ENTRY ONSAS
         e31o29 = bmiss
         IF(nint(sas).GT.-1.AND.nint(sas).LT.10)  e31o29 = nint(sas)
         RETURN
      entry e32o29(wes)
C     ---> formerly ENTRY ONWES
         e32o29 = wes
         RETURN
      entry e33o29(subset,rpid)
C     ---> formerly ENTRY ONRTP
         e33o29 = bmiss
         IF(subset(1:5).EQ.'NC000'.AND.l02o29(rpid) ) e33o29 = 511
         IF(subset(1:5).EQ.'NC000'.AND.l03o29(rpid) ) e33o29 = 512
         IF(subset.EQ.'NC001001'.AND.rpid.NE.'SHIP') e33o29 = 522
         IF(subset.EQ.'NC001001'.AND.rpid.EQ.'SHIP') e33o29 = 523
         IF(subset.EQ.'NC001002') e33o29 = 562
         IF(subset.EQ.'NC001003') e33o29 = 561
         IF(subset.EQ.'NC001004') e33o29 = 531
         IF(subset.EQ.'NC001006') e33o29 = 551
         IF(subset.EQ.'NC002001')  THEN
 
C  LAND RADIOSONDE - FIXED
C  -----------------------
 
            e33o29 = 011
            IF(l03o29(rpid)) e33o29 = 012
            IF(rpid(1:4).EQ.'CLAS') e33o29 = 013
         END IF
         IF(subset.EQ.'NC002002')  THEN
 
C  LAND RADIOSONDE - MOBILE
C  ------------------------
 
            e33o29 = 013
         END IF
         IF(subset.EQ.'NC002003')  THEN
 
C  SHIP RADIOSONDE
C  ---------------
 
            e33o29 = 022
            IF(rpid(1:4).EQ.'SHIP') e33o29 = 023
         END IF
         IF(subset.EQ.'NC002004')  THEN
 
C  DROPWINSONDE
C  -------------
 
            e33o29 = 031
         END IF
         IF(subset.EQ.'NC002005')  THEN
 
C  PIBAL
C  -----
 
            e33o29 = 011
            IF(l03o29(rpid)) e33o29 = 012
         END IF
 
         IF(subset.EQ.'NC004001') e33o29 = 041
         IF(subset.EQ.'NC004002') e33o29 = 041
         IF(subset.EQ.'NC004003') e33o29 = 041
         IF(subset.EQ.'NC004004') e33o29 = 041
         IF(subset.EQ.'NC004005') e33o29 = 031
         IF(subset(1:5).EQ.'NC005') e33o29 = 063
         RETURN
      entry e34o29(hgt,z100)
C     ---> formerly ENTRY ONFIX
C - With Jeff Ator's fix on 1/30/97, don't need this anymore
cdak     HGT0 = HGT
cdak     IF(MOD(NINT(HGT),300).EQ.0.OR.MOD(NINT(HGT),500).EQ.0)
cdak $    HGT = HGT * 1.016
 
C  ALL WINDS-BY-HEIGHT HEIGHTS ARE TRUNCATED DOWN TO THE NEXT
C   10 METER LEVEL IF PART DD (ABOVE 100 MB LEVEL) (ON29 CONVENTION)
C  -----------------------------------------------------------------
 
         IF(hgt.GT.z100)  THEN
            IF(mod(nint(hgt),10).NE.0)  hgt = int(hgt/10.) * 10
            e34o29 = nint(hgt)
         ELSE
C - With Jeff Ator's fix on 1/30/97, don't need this anymore
cdak        IF(HGT.NE.HGT0)  THEN
cdak           IF(MOD(NINT(HGT0),1500).EQ.0)  HGT = HGT - 1.0
cdak        ELSE
               IF(mod(nint(hgt/1.016),1500).EQ.0) hgt = nint(hgt - 1.0)
cdak        END IF
            e34o29 = int(hgt)
         END IF
         RETURN
      entry e38o29(hvz)
         IF(hvz.GE.bmiss.OR.hvz.LT.0.) THEN
            e38o29 = bmiss
         ELSE  IF(nint(hvz).LT.1000)  THEN
            kk = min(int(nint(hvz)/10),99)
            e38o29 = kkk(kk)
         ELSE  IF(nint(hvz).LT.50000)  THEN
            kk = min(int(nint(hvz)/1000),49)
            e38o29 = kkkk(kk)
         ELSE
            e38o29 = 99
         END IF
         RETURN
      END
C***********************************************************************
C***********************************************************************
C***********************************************************************
      FUNCTION c02o29()
C     ---> formerly FUNCTION ONCHR
      CHARACTER*8 c02o29,e35o29,e36o29
      CHARACTER*1  cprt(0:11),cmr29(0:15)
 
      SAVE
 
C  (NOTE: Prior to mid-March 1999, a purge or reject flag on pressure
C         was set to 6 (instead of 14 or 12, resp.) to get around the
C         3-bit limit to ON29 pressure q.m. mnemonic "QMPR".  The 3-bit
C         limit on "QMPR" was changed to 4-bits with a decoder change
C         in February 1999.  However, the codes that write the q.m.'s
C         out (EDTBUFR and QUIPC) were not changed to write out 14 or
C         12 for purge or reject until mid-March 1999.  In order to
C         allow old runs to work properly, a q.m. of 6 will continue
C         to be interpreted as a "P".  This would have to change if
C         q.m.=6 ever has a defined meaning.)
 
C  Code Table Value:  0   1   2   3   4   5   6   7
 
      DATA cmr29    /'H','A',' ','Q','C','F','P','F',
 
C  Code Table Value:  8   9  10  11  12  13  14  15
 
     .               'F','F','O','B','R','F','P','F'/
 
      DATA cprt  /' ',' ',' ',' ','A','B','C','D','I','J','K','L'/
 
      c02o29 = ' '
      RETURN
      entry e35o29(qmk)
C     ---> formerly ENTRY ONQMK
         IF(qmk.GE.0 .AND. qmk.LE.15) e35o29 = cmr29(nint(qmk))
         IF(qmk.LT.0 .OR.  qmk.GT.15) e35o29 = ' '
         RETURN
      entry e36o29(nprt)
C     ---> formerly ENTRY ONPRT
         e36o29 = '        '
         IF(nprt.LT.12)  e36o29 = cprt(nprt)//'       '
         RETURN
      END
C***********************************************************************
C***********************************************************************
C***********************************************************************
      FUNCTION l01o29()
C     ---> formerly FUNCTION ONLOG
      CHARACTER*8 rpid
      LOGICAL l01o29,l02o29,l03o29
 
      SAVE
 
      l01o29 = .true.
 
      RETURN
 
      entry l02o29(rpid)
C     ---> formerly ENTRY ONBKS
         l02o29 = .false.
         READ(rpid,'(I5)',err=1) ibks
         l02o29 = .true.
1        RETURN
      entry l03o29(rpid)
C     ---> formerly ENTRY ONCAL
         l03o29 = .true.
         READ(rpid,'(I5)',err=2) ibks
         l03o29 = .false.
2        RETURN
      END
C***********************************************************************
C***********************************************************************
C***********************************************************************
      FUNCTION r03o29(LUNIT,OBS)
C     ---> formerly FUNCTION ADPUPA
 
      common/io29dd/hdr(12),rcats(50,150,11),ikat(11),mcat(11),ncat(11)
      common/io29ee/pob(255),qob(255),tob(255),zob(255),dob(255),
     $               sob(255),vsg(255),clp(255),cla(255),ob8(255),
     $               cf8(255)
      common/io29ff/pqm(255),qqm(255),tqm(255),zqm(255),wqm(255),
     $               qcp(255),qca(255),q81(255),q82(255)
      common/io29cc/subset,idat10
      common/io29bb/kndx,kskacf(8),kskupa,ksksfc,ksksat,ksksmi
      common/io29ii/pwmin
      common/io29ll/bmiss
 
      CHARACTER*80 hdstr,lvstr,qmstr,rcstr
      CHARACTER*8  subset,sid,e35o29,e36o29,rsv,rsv2
      CHARACTER*1  pqm,qqm,tqm,zqm,wqm,qcp,qca,q81,q82,pqml
      REAL(8)  rid_8,hdr_8(12),vsg_8(255)
      REAL(8)  rct_8(5,255),arr_8(10,255)
      REAL(8)  rat_8(255),rmore_8(4),rgp10_8(255),rpmsl_8,rpsal_8
      REAL(8)  bmiss
      INTEGER    ihblcs(0:9)
      dimension    obs(*),rct(5,255),arr(10,255)
      dimension    rat(255),rmore(4),rgp10(255)
      dimension  p2(255),p8(255),p16(255)
 
      equivalence(rid_8,sid)
      LOGICAL      l02o29
 
      SAVE
 
      DATA hdstr/'NULL CLON CLAT HOUR MINU SELV               '/
      DATA lvstr/'PRLC TMDP TMDB GP07 GP10 WDIR WSPD          '/
      DATA qmstr/'QMPR QMAT QMDD QMGP QMWN                    '/
      DATA rcstr/'RCHR RCMI RCTS                              '/
 
      DATA ihblcs/25,75,150,250,450,800,1250,1750,2250,2500/
 
      prs1(z) = 1013.25 * (((288.15 - (.0065 * z))/288.15)**5.256)
      prs2(z) = 226.3 * exp(1.576106e-4 * (11000. - z))
 
C  CHECK IF THIS IS A PREPBUFR FILE
C  --------------------------------
 
      r03o29 = 99
c#V#V#dak - future
cdak  IF(SUBSET.EQ.'ADPUPA') R03O29 = PRPUPA(LUNIT,OBS)
caaaaadak - future
      IF(r03o29.NE.99) RETURN
      r03o29 = 0
 
      CALL s05o29
 
C  VERTICAL SIGNIFICANCE DESCRIPTOR TO ASSIGN ON29 CATEGORY
C  --------------------------------------------------------
 
C NOTE: MNEMONIC "VSIG" 008001 IS DEFINED AS VERTICAL SOUNDING
C       SIGNIFICANCE -- CODE TABLE FOLLOWS:
C        64   Surface
C              processed as ON29 category 2 and/or 3 and/or 4
C        32   Standard (mandatory) level
C              processed as ON29 category 1
C        16   Tropopause level
C              processed as ON29 category 5
C         8   Maximum wind level
C              processed as ON29 category 3 or 4
C         4   Significant level, temperature
C              processed as ON29 category 2
C         2   Significant level, wind
C              processed as ON29 category 3 or 4
C         1   ???????????????????????
C              processed as ON29 category 6
C
C  anything else - the level is not processed
 
      CALL ufbint(lunit,vsg_8,1,255,nlev,'VSIG');vsg=vsg_8
 
C  PUT THE HEADER INFORMATION INTO ON29 FORMAT
C  -------------------------------------------
 
      CALL ufbint(lunit,hdr_8,12,  1,iret,hdstr);hdr(2:)=hdr_8(2:)
      IF(hdr(5).GE.bmiss) hdr(5) = 0
      CALL ufbint(lunit,rid_8,1,1,iret,'RPID')
      IF(iret.NE.1) sid = 'MISSING '
cppppp-ID
      iprint = 0
c     if(sid.eq.'59758   ')  iprint = 1
c     if(sid.eq.'61094   ')  iprint = 1
c     if(sid.eq.'62414   ')  iprint = 1
c     if(sid.eq.'59362   ')  iprint = 1
c     if(sid.eq.'57957   ')  iprint = 1
c     if(sid.eq.'74794   ')  iprint = 1
c     if(sid.eq.'74389   ')  iprint = 1
c     if(sid.eq.'96801A  ')  iprint = 1
      if(iprint.eq.1)
     $ print'(" @@@ START DIAGNOSTIC PRINTOUT FOR ID ",A)', sid
cppppp-ID
 
      irecco = 0
      CALL ufbint(lunit,rpmsl_8,1,  1,iret,'PMSL');rpmsl=rpmsl_8
      IF(subset.EQ.'NC004005')  THEN
         CALL ufbint(lunit,rgp10_8,1,255,nlev,'GP10');rgp10=rgp10_8
         CALL ufbint(lunit,rpsal_8,1,1,iret,'PSAL');rpsal=rpsal_8
         IF(nint(vsg(1)).EQ.32.AND.rpmsl.GE.bmiss.AND.
     $    max(rgp10(1),rpsal).LT.bmiss)  THEN
cppppp
cdak        print'(" ~~IW3UNP29/R03O29: ID ",A," is a Cat. 1 type ",
cdak $       "Flight-level RECCO")', sid
cppppp
            irecco = 1
         ELSE  IF(min(vsg(1),rpmsl,rgp10(1)).GE.bmiss.AND.rpsal.LT.
     $    bmiss)
     $    THEN
cppppp
cdak        print'(" ~~IW3UNP29/R03O29: ID ",A," is a Cat. 6 type ",
cdak $       "Flight-level RECCO (but reformatted into cat. 2/3)")', sid
cppppp
            irecco = 6
         ELSE  IF(min(vsg(1),rgp10(1)).GE.bmiss.AND.max(rpmsl,rpsal)
     $    .LT.bmiss)  THEN
cppppp
cdak        print'(" ~~IW3UNP29/R03O29: ID ",A," is a Cat. 2/3 type ",
cdak $       "Flight-level RECCO with valid PMSL")', sid
cppppp
            irecco = 23
         ELSE
cppppp
            print'(" ~~IW3UNP29/R03O29: ID ",A," is currently an ",
     $       "unknown type of Flight-level RECCO - VSIG =",G0,
     $       "; PMSL =",G0,"; GP10 =",G0," -- SKIP IT for now")',
     $       sid,vsg(1),rpmsl,rgp10(1)
            r03o29 = -9999
            kskupa =kskupa + 1
            RETURN
cppppp
         END IF
      END IF
 
      xob = hdr(2)
      yob = hdr(3)
      rhr = bmiss
      IF(hdr(4).LT.bmiss)  rhr = nint(hdr(4))+nint(hdr(5))/60.
      rch = bmiss
      rsv = '999     '
      elv = hdr(6)
      IF(irecco.GT.0)  THEN
         rpsal = rpsal + sign(0.0000001,rpsal)
         elv = rpsal
      END IF
 
      CALL ufbint(lunit,rat_8, 1,255,nlev,'RATP');rat=rat_8
      itp = min(99,nint(rat(1)))
      rtp = e33o29(subset,sid)
      IF(elv.GE.bmiss)  THEN
cppppp
         print'(" IW3UNP29/R03O29: ID ",A," has a missing elev, so ",
     $    "elevation set to ZERO")', sid
cppppp
         IF((rtp.GT.20.AND.rtp.LT.24).OR.subset.EQ.'NC002004')  elv = 0
      END IF
cdak  if(sid(5:5).eq.' ') print'(A)', sid
      IF(l02o29(sid).AND.sid(5:5).EQ.' ') sid = '0'//sid
      rsv2 = '        '
      CALL s01o29(sid,xob,yob,rhr,rch,rsv,rsv2,elv,itp,rtp)
 
C  PUT THE LEVEL DATA INTO ON29 UNITS
C  ----------------------------------
 
      CALL ufbint(lunit,arr_8,10,255,nlev,lvstr);arr=arr_8
 
      pwmin = 999999.
      jlv = 2
      IF(irecco.EQ.6)  jlv = 1
      IF(irecco.GT.0.AND.nlev.EQ.1)  THEN
         vsg(jlv) = 4
         vsg(jlv+1) = 2
         qob(jlv) = e07o29(arr(2,1),arr(3,1))
         tob(jlv) = e06o29(arr(3,1))
         arr(2,1) = bmiss
         arr(3,1) = bmiss
         dob(jlv+1) = e04o29(arr(6,1),arr(7,1))
         sob(jlv+1) = e05o29(arr(6,1),arr(7,1))
         IF(nint(dob(jlv+1)).EQ.0.AND.nint(sob(jlv+1)).GT.0)
     $    dob(jlv+1) = 360.
         IF(nint(dob(jlv+1)).EQ.360.AND.nint(sob(jlv+1)).EQ.0)
     $    dob(jlv+1) = 0.
         arr(6,1) = bmiss
         arr(7,1) = bmiss
         IF(irecco.EQ.23)  THEN
            vsg(1) = 64
            arr(1,1) = rpmsl
         END IF
      END IF
 
      IF(irecco.EQ.6)  GO TO 4523
 
      DO l=1,nlev
         pob(l) = e01o29(arr(1,l))
         IF(nint(arr(1,l)).LE.0) THEN
            pob(l) =  bmiss
cppppp
            print'(" ~~@@IW3UNP29/R03O29: ID ",A," has a ZERO or ",
     $       "negative reported pressure that is reset to missing")',
     $       sid
cppppp
         END IF
         qob(l) = e07o29(arr(2,l),arr(3,l))
         tob(l) = e06o29(arr(3,l))
         zob(l) = min(e08o29(arr(4,l)),e08o29(arr(5,l)))
cppppp
      if(iprint.eq.1)  then
         if(irecco.gt.0)  print'(" At lvl=",I0,"; orig. ZOB = ",G0)',
     $     l,zob(l)
      end if
cppppp
         IF(irecco.EQ.1)  THEN
            IF(mod(nint(zob(l)),10).NE.0)  zob(l) = int(zob(l)/10.) * 10
            zob(l) = nint(zob(l))
         ELSEIF(irecco.EQ.23)  THEN
            zob(l) = 0
         END IF
         dob(l) = e04o29(arr(6,l),arr(7,l))
         sob(l) = e05o29(arr(6,l),arr(7,l))
         IF(nint(dob(l)).EQ.0.AND.nint(sob(l)).GT.0)    dob(l) = 360.
         IF(nint(dob(l)).EQ.360.AND.nint(sob(l)).EQ.0)  dob(l) = 0.
cppppp
      if(iprint.eq.1)  then
         print'(" At lvl=",I0,"; VSG=",G0,"; POB = ",G0,"; QOB = ",G0,
     $    "; TOB = ",G0,"; ZOB = ",G0,"; DOB = ",G0,"; final SOB ",
     $    "(kts) = ",G0,"; origl SOB (mps) = ",G0)',
     $    l,vsg(l),pob(l),qob(l),tob(l),zob(l),dob(l),sob(l),arr(7,l)
      end if
cppppp
         IF(irecco.EQ.0.AND.max(pob(l),dob(l),sob(l)).LT.bmiss)
     $    pwmin=min(pwmin,pob(l))
      ENDDO
 
 4523 CONTINUE
 
      mlev = nlev
 
      CALL ufbint(lunit,arr_8,10,255,nlev,qmstr);arr=arr_8
 
      IF(irecco.GT.0.AND.mlev.EQ.1)  THEN
         pob1 = bmiss
         IF(pob(1).LT.bmiss)  pob1 = pob(1) * 0.1
         tob1 = bmiss
         IF(tob(jlv).LT.bmiss)  tob1 = (tob(jlv) * 0.1) + 273.15
         rps1 = rpsal
         zob1 = zob(1)
         tqm1 = arr(3,1)
         pob(jlv)=nint(e37o29(pob1,tob1,rps1,zob1,tqm1)) * 10
         pob(jlv+1) = pob(jlv)
cppppp
         if(iprint.eq.1)  then
         do l=jlv,jlv+1
            print'(" At lvl=",I0,"; VSG=",G0,"; POB = ",G0,"; QOB = ",
     $       G0,"; TOB = ",G0,"; ZOB = ",G0,"; DOB = ",G0,"; SOB = ",
     $       G0)', l,vsg(l),pob(l),qob(l),tob(l),zob(l),dob(l),sob(l)
         enddo
         end if
cppppp
      END IF
 
      IF(irecco.GT.0.AND.nlev.EQ.1)  THEN
         pqm(jlv) = 'E'
         pqm(jlv+1) = 'E'
         tqm(jlv) = e35o29(arr(2,1))
         arr(2,1) = bmiss
         qqm(jlv) = e35o29(arr(3,1))
         arr(3,1) = bmiss
         arr(4,1) = 3
         wqm(jlv+1) = e35o29(arr(5,1))
         arr(5,1) = bmiss
      END IF
 
      IF(irecco.EQ.6)  GO TO 4524
 
      DO l=1,nlev
      pqm(l) = e35o29(arr(1,l))
      tqm(l) = e35o29(arr(2,l))
      qqm(l) = e35o29(arr(3,l))
      zqm(l) = e35o29(arr(4,l))
      wqm(l) = e35o29(arr(5,l))
      ENDDO
 
 4524 CONTINUE
 
      IF(irecco.GT.0.AND.nlev.EQ.1)  nlev = jlv + 1
 
C  SURFACE DATA MUST GO FIRST
C  --------------------------
 
      CALL s02o29(2,0,*9999)
      CALL s02o29(3,0,*9999)
      CALL s02o29(4,0,*9999)
 
      indx2  = 0
      indx8  = 0
      indx16 = 0
      p2  = bmiss
      p8  = bmiss
      p16 = bmiss
 
      DO l=1,nlev
      IF(nint(vsg(l)).EQ.64) THEN
cppppp
      if(iprint.eq.1)  then
         print'(" Lvl=",L," is a surface level")'
      end if
      if(iprint.eq.1.and.pob(l).LT.bmiss.AND.(tob(l).LT.bmiss.OR.irecco
     $ .EQ.23))  then
         print'("  --> valid cat. 2 sfc. lvl ")'
      end if
cppppp
         IF(pob(l).LT.bmiss.AND.(tob(l).LT.bmiss.OR.irecco.EQ.23))
     $    CALL se01o29(2,l)
cppppp
      if(iprint.eq.1.and.pob(l).LT.bmiss.AND.(dob(l).LT.bmiss.OR.irecco
     $ .EQ.23))  then
         print'("  --> valid cat. 3 sfc. lvl ")'
      end if
cppppp
         IF(pob(l).LT.bmiss.AND.(dob(l).LT.bmiss.OR.irecco.EQ.23))
     $    CALL se01o29(3,l)
         IF(zob(l).LT.bmiss.AND.dob(l).LT.bmiss) THEN
cppppp
            if(iprint.eq.1)  print'("  --> valid cat. 4 sfc. lvl ")'
cppppp
 
C  CAT. 4 HEIGHT DOES NOT PASS ON A KEEP, PURGE, OR REJECT LIST Q.M.
C  -----------------------------------------------------------------
 
            zqm(l) = ' '
            CALL se01o29(4,l)
         END IF
         vsg(l) = 0
      ELSE  IF(nint(vsg(l)).EQ.2)  THEN
         p2(l) = pob(l)
         indx2 = l
         IF(indx8.GT.0)  THEN
            DO ii = 1,indx8
               IF(pob(l).EQ.p8(ii).AND.pob(l).LT.bmiss)  THEN
cppppp
                  if(iprint.eq.1)  then
                     print'("  ## This cat. 3 level, on lvl ",I0,
     $                " will have already been processed as a cat. 3 ",
     $                "MAX wind lvl (on lvl ",I0,") - skip this Cat. ",
     $                "3 lvl")', l,ii
                  end if
cppppp
                  IF(max(sob(ii),dob(ii)).GE.bmiss)  THEN
                     sob(ii) = sob(l)
                     dob(ii) = dob(l)
cppppp
                     if(iprint.eq.1)  then
                        print'("  ...... also on lvl ",I0," - transfer",
     $                  " wind data to dupl. MAX wind lvl because its ",
     $                  "missing there")', l
                     end if
cppppp
                  END IF
                  vsg(l) = 0
                  GO TO 7732
               END IF
            ENDDO
         END IF
      ELSE  IF(nint(vsg(l)).EQ.8)  THEN
         p8(l) = pob(l)
         indx8 = l
         IF(indx2.GT.0)  THEN
            DO ii = 1,indx2
               IF(pob(l).EQ.p2(ii).AND.pob(l).LT.bmiss)  THEN
cppppp
                  if(iprint.eq.1)  then
                     print'("  ## This MAX wind level, on lvl ",I0,
     $                " will have already been processed as a cat. 3 ",
     $                "lvl (on lvl ",I0,") - skip this MAX wind lvl ",
     $                "but set"/6X,"cat. 3 lvl PQM to ""W""")', l,ii
                  end if
cppppp
                  pqm(ii) = 'W'
                  IF(pob(l).EQ.pwmin)  pqm(ii) = 'X'
                  IF(max(sob(ii),dob(ii)).GE.bmiss)  THEN
                     sob(ii) = sob(l)
                     dob(ii) = dob(l)
cppppp
                     if(iprint.eq.1)  then
                        print'("  ...... also on lvl ",I0," - transfer",
     $                  " wind data to dupl. cat. 3 lvl because its ",
     $                  "missing there")', l
                     end if
cppppp
                  END IF
                  vsg(l) = 0
                  GO TO 7732
               END IF
            ENDDO
         END IF
         IF(indx8-1.GT.0)  THEN
            DO ii = 1,indx8-1
               IF(pob(l).EQ.p8(ii).AND.pob(l).LT.bmiss)  THEN
cppppp
                  if(iprint.eq.1)  then
                     print'("  ## This cat. 3 MAX wind lvl, on lvl ",I0,
     $                " will have already been processed as a cat. 3 ",
     $                "MAX wind lvl (on lvl ",I0,") - skip this Cat. ",
     $                "3 MAX wind lvl")', l,ii
                  end if
cppppp
                  IF(max(sob(ii),dob(ii)).GE.bmiss)  THEN
                     sob(ii) = sob(l)
                     dob(ii) = dob(l)
cppppp
                     if(iprint.eq.1)  then
                        print'("  ...... also on lvl ",I0," - transfer",
     $                  " wind data to dupl. MAX wind lvl because its ",
     $                  "missing there")', l
                     end if
cppppp
                  END IF
                  vsg(l) = 0
                  GO TO 7732
               END IF
            ENDDO
         END IF
      ELSE  IF(nint(vsg(l)).EQ.16)  THEN
         indx16 = indx16 + 1
         p16(indx16) = pob(l)
      END IF
 7732 CONTINUE
      ENDDO
 
C  TAKE CARE OF 925 MB NEXT
C  ------------------------
 
      DO l=1,nlev
      IF(nint(vsg(l)).EQ.32 .AND. nint(pob(l)).EQ.9250) THEN
         cf8(l) = 925
         ob8(l) = zob(l)
         q81(l) = ' '
         q82(l) = ' '
         IF(tob(l).LT.bmiss) CALL s02o29(2,l,*9999)
         IF(dob(l).LT.bmiss) CALL s02o29(3,l,*9999)
         IF(ob8(l).LT.bmiss) CALL s02o29(8,l,*9999)
         vsg(l) = 0
      END IF
      ENDDO
 
C  REST OF THE DATA
C  ----------------
 
      z100 = 16000
      DO l=1,nlev
      IF(nint(vsg(l)).EQ.32) THEN
         IF(min(dob(l),zob(l),tob(l)).GE.bmiss)  THEN
cppppp
            if(iprint.eq.1)  then
               print'("  ==> For lvl ",I0,"; VSG=32 & DOB,ZOB,TOB all ",
     $          "missing --> this level not processed")', l
            end if
            vsg(l) = 0
         ELSE  IF(min(zob(l),tob(l)).LT.bmiss) THEN
cppppp
            if(iprint.eq.1)  then
               print'("  ==> For lvl ",I0,"; VSG=32 & one or both of ",
     $          "ZOB,TOB non-missing --> valid cat. 1 lvl")', l
            end if
cppppp
            CALL s02o29(1,l,*9999)
            IF(nint(pob(l)).EQ.1000.AND.zob(l).LT.bmiss)  z100 = zob(l)
            vsg(l) = 0
         END IF
      END IF
      ENDDO
      DO l=1,nlev
      IF(nint(vsg(l)).EQ.32) THEN
         IF(dob(l).LT.bmiss.AND.min(zob(l),tob(l)).GE.bmiss) THEN
            ll = i04o29(pob(l)*.1)
            IF(ll.EQ.999999)  THEN
cppppp
               print'(" ~~IW3UNP29/R03O29: ID ",A," has VSG=32 for ",
     $          "lvl ",I0," but pressure not mand.!! --> this level ",
     $          "not processed")', sid,l
cppppp
            ELSE  IF(min(rcats(1,ll,1),rcats(2,ll,1)).LT.99999.)  THEN
               IF(rcats(4,ll,1).GE.99998.)  THEN
cppppp
                  if(iprint.eq.1)  then
                     print'("  ==> For lvl ",I0,"; VSG=32 & ZOB,TOB ",
     $                "both missing while DOB non-missing BUT one or ",
     $                "both of Z, T non-missing while wind missing ",
     $                "in"/7X,"earlier cat. 1 processing of this ",G0,
     $                "mb level --> valid cat. 1 lvl")', l,pob(l)*.1
                  end if
cppppp
                  CALL s02o29(1,l,*9999)
               ELSE
cppppp
                  if(iprint.eq.1)  then
                     print'("  ==> For lvl ",I0,"; VSG=32 & ZOB,TOB ",
     $                "both missing while DOB non-missing BUT one or ",
     $                "both of Z, T non-missing while wind non-missing",
     $                " in"/6X,"earlier cat. 1 processing of this ",G0,
     $                "mb level --> valid cat. 3 lvl")', l,pob(l)*.1
                  end if
cppppp
                  CALL s02o29(3,l,*9999)
               END IF
            ELSE
cppppp
               if(iprint.eq.1)  then
                  print'("  ==> For lvl ",I0,"; VSG=32 & ZOB,TOB both ",
     $             "missing while DOB non-missing AND both Z, T ",
     $             "missing on"/7X,"this ",G0,"mb level in cat. 1 --> ",
     $             "valid cat. 3 lvl")', l,pob(l)*.1
               end if
cppppp
               CALL s02o29(3,l,*9999)
            END IF
         ELSE
cppppp
            print'("  ~~IW3UNP29/R03O29: ID ",A," has VSG=32 for lvl ",
     $       I0," & should never come here!! - by default output",
     $       " as cat. 1 lvl")', sid,l
cppppp
            CALL s02o29(1,l,*9999)
         END IF
         vsg(l) = 0
      END IF
      ENDDO
 
      DO l=1,nlev
      IF(nint(vsg(l)).EQ. 4) THEN
cppppp
         if(iprint.eq.1)  then
            print'("   ==> For lvl ",I0,"; VSG= 4 --> valid cat. 2 ",
     $       "lvl")', l
         end if
cppppp
         IF(indx16.GT.0)  THEN
            DO ii = 1,indx16
               IF(pob(l).EQ.p16(ii).AND.pob(l).LT.bmiss)  THEN
cppppp
                  if(iprint.eq.1)  then
                     print'("  ## This cat. 2 level, on lvl ",I0," is",
     $                " also the tropopause level, as its pressure ",
     $                "matches that of trop. lvl no. ",I0," - ",
     $                "set this cat. 2"/5X,"lvl PQM to ""T""")', l,ii
                  end if
cppppp
                  pqm(l) = 'T'
                  GO TO 7738
               END IF
            ENDDO
         END IF
 7738    CONTINUE
         CALL s02o29(2,l,*9999)
         vsg(l) = 0
      ELSEIF(nint(vsg(l)).EQ.16) THEN
cppppp
         if(iprint.eq.1)  then
            print'("  ==> For lvl ",I0,"; VSG=16 --> valid cat. 3/5 ",
     $       "lvl")', l
         end if
cppppp
         pqml = pqm(l)
         IF(min(sob(l),dob(l)).LT.bmiss)  CALL s02o29(3,l,*9999)
         pqm(l) = pqml
         CALL s02o29(5,l,*9999)
         vsg(l) = 0
      ELSEIF(nint(vsg(l)).EQ. 1) THEN
cppppp
         print'(" ~~IW3UNP29/R03O29: HERE IS A VSG =1, SET TO CAT.6, ",
     $    "AT ID ",A,"; SHOULD NEVER HAPPEN!!")', sid
cppppp
         CALL s02o29(6,l,*9999)
         vsg(l) = 0
      ELSEIF(nint(vsg(l)).EQ. 2 .AND. pob(l).LT.bmiss) THEN
         IF(max(sob(l),dob(l)).LT.bmiss)  THEN
cppppp
         if(iprint.eq.1)  then
            print.ne.'("  ==> For lvl ",I0,"; VSG= 2 & POB  missing ",
     $       "--> valid cat. 3 lvl (expect that ZOB is missing)")', l
         end if
cppppp
         CALL s02o29(3,l,*9999)
         ELSE
cppppp
         if(iprint.eq.1)  then
            print.ne.'("  ==> For lvl ",I0,"; VSG= 2 & POB  missing ",
     $       "--> Cat. 3 level not processed - wind is missing")', l
         end if
cppppp
         END IF
         vsg(l) = 0
      ELSEIF(nint(vsg(l)).EQ. 2 .AND. zob(l).LT.bmiss) THEN
         IF(max(sob(l),dob(l)).LT.bmiss)  THEN
 
C  CERTAIN U.S. WINDS-BY-HEIGHT ARE CORRECTED TO ON29 CONVENTION
C  -------------------------------------------------------------
 
         IF(sid(1:2).EQ.'70'.OR.sid(1:2).EQ.'71'.OR.sid(1:2).EQ.'72'
     $    .OR.sid(1:2).EQ.'74')  zob(l) = e34o29(zob(l),z100)
cppppp
         if(iprint.eq.1)  then
            print.ne.'("  ==> For lvl ",I0,"; VSG= 2 & ZOB  missing ",
     $       "--> valid cat. 4 lvl (POB must always be missing)")', l
            if(sid(1:2).eq.'70'.or.sid(1:2).eq.'71'.or.sid(1:2).eq.'72'
     $       .or.sid(1:2).eq.'74')  print'("    .... ZOB at this ",
     $       "U.S. site adjusted to ",G0)', zob(l)
         end if
cppppp
 
C  CAT. 4 HEIGHT DOES NOT PASS ON A KEEP, PURGE, OR REJECT LIST Q.M.
C  -----------------------------------------------------------------
 
         zqm(l) = ' '
 
         CALL s02o29(4,l,*9999)
         ELSE
cppppp
         if(iprint.eq.1)  then
            print.ne.'("  ==> For lvl ",I0,"; VSG= 2 & ZOB  missing ",
     $       "--> Cat. 4 level not processed - wind is missing")', l
         end if
cppppp
         END IF
         vsg(l) = 0
      ELSEIF(nint(vsg(l)).EQ. 8 .AND. pob(l).LT.bmiss) THEN
cppppp
         if(iprint.eq.1)  then
            print.ne.'("  ==> For lvl ",I0,"; VSG= 8 & POB  missing ",
     $       "--> valid cat. 3 lvl (expect that ZOB is missing)")', l
         end if
cppppp
         CALL s02o29(3,l,*9999)
         vsg(l) = 0
      ELSEIF(nint(vsg(l)).EQ. 8 .AND. zob(l).LT.bmiss) THEN
         IF(max(sob(l),dob(l)).LT.bmiss)  THEN
 
C  CERTAIN U.S. WINDS-BY-HEIGHT ARE CORRECTED TO ON29 CONVENTION
C  -------------------------------------------------------------
 
         IF(sid(1:2).EQ.'70'.OR.sid(1:2).EQ.'71'.OR.sid(1:2).EQ.'72'
     $    .OR.sid(1:2).EQ.'74')  zob(l) = e34o29(zob(l),z100)
cppppp
         if(iprint.eq.1)  then
            print.ne.'("  ==> For lvl ",I0,"; VSG= 8 & ZOB  missing ",
     $       "--> valid cat. 4 lvl (POB must always be missing)")', l
            if(sid(1:2).eq.'70'.or.sid(1:2).eq.'71'.or.sid(1:2).eq.'72'
     $       .or.sid(1:2).eq.'74')  print'("    .... ZOB at this ",
     $       "U.S. site adjusted to ",G0)', zob(l)
         end if
cppppp
 
C  CAT. 4 HEIGHT DOES NOT PASS ON A KEEP, PURGE, OR REJECT LIST Q.M.
C  -----------------------------------------------------------------
 
         zqm(l) = ' '
 
         CALL s02o29(4,l,*9999)
         ELSE
cppppp
         if(iprint.eq.1)  then
            print.ne.'("  ==> For lvl ",I0,"; VSG= 8 & ZOB  missing ",
     $       "--> Cat. 4 level not processed - wind is missing")', l
         end if
cppppp
         END IF
         vsg(l) = 0
      END IF
      ENDDO
 
C  CHECK FOR LEVELS WHICH GOT LEFT OUT
C  -----------------------------------
 
      DO l=1,nlev
      IF(nint(vsg(l)).GT.0)  THEN
         print 887, l,sid,nint(vsg(l))
  887 FORMAT(' ##IW3UNP29/R03O29 - ~~ON LVL',i4,' OF ID ',a8,', A ',
     $    'VERTICAL SIGNIFICANCE OF',i3,' WAS NOT SUPPORTED - LEAVE ',
     $    'THIS LEVEL OUT OF THE PROCESSING')
         print'("  ..... at lvl=",I0,"; POB = ",G0,"; QOB = ",G0,
     $    "; TOB = ",G0,"; ZOB = ",G0,"; DOB = ",G0,";"/19X,"SOB = ",
     $    G0)', pob(l),qob(l),tob(l),zob(l),dob(l),sob(l)
      END IF
      ENDDO
 
C  CLOUD DATA GOES INTO CATEGORY 07
C  --------------------------------
 
      CALL ufbint(lunit,arr_8,10,255,nlev,'HOCB CLAM QMCA HBLCS')
      arr=arr_8
      DO l=1,nlev
         IF(arr(1,l).LT.bmiss/2.)  THEN
               ! Prior to 3/2002 HBLCS was not available, this will
               !  always be tested first because it is more precise
               !  in theory but will now be missing after 3/2002
            IF(elv+arr(1,l).GE.bmiss/2.)  THEN
               clp(l) =  bmiss
            ELSE  IF(elv+arr(1,l).LE.11000)  THEN
               clp(l) = (prs1(elv+arr(1,l))*10.)  + 0.001
            ELSE
               clp(l) = (prs2(elv+arr(1,l))*10.)  + 0.001
            END IF
         ELSE
               ! Effective 3/2002 only this will be available
            IF(nint(arr(4,l)).GE.10)  THEN
               clp(l) =  bmiss
            ELSE
               IF(elv+ihblcs(nint(arr(4,l))).GE.bmiss/2.)  THEN
                  clp(l) =  bmiss
               ELSE  IF(elv+ihblcs(nint(arr(4,l))).LE.11000)  THEN
                  clp(l) = (prs1(elv+ihblcs(nint(arr(4,l))))*10.) +0.001
               ELSE
                  clp(l) = (prs2(elv+ihblcs(nint(arr(4,l))))*10.) +0.001
               END IF
            END IF
         END IF
         cla(l) = e13o29(arr(2,l))
         qcp(l) = ' '
         qca(l) = e35o29(arr(3,l))
         IF(clp(l).LT.bmiss .OR. cla(l).LT.bmiss) CALL s02o29(7,l,*9999)
      ENDDO
 
C  -----------------------------------------------------
C  MISC DATA GOES INTO CATEGORY 08
C  -----------------------------------------------------
C  CODE FIGURE 104 - RELEASE TIME IN .01*HR
C  CODE FIGURE 105 - RECEIPT TIME IN .01*HR
C  CODE FIGURE 106 - RADIOSONDE INSTR. TYPE,
C                    SOLAR/IR CORRECTION INDICATOR,
C                    TRACKING TECH/STATUS OF SYSTEM USED
C  CODE FIGURE 925 - HEIGHT OF 925 LEVEL
C  -----------------------------------------------------
 
      CALL ufbint(lunit,rct_8, 5,255,nrct,rcstr);rct=rct_8
 
C NOTE: MNEMONIC "RCTS" 008202 IS A LOCAL DESCRIPTOR DEFINED AS
C       RECEIPT TIME SIGNIFICANCE -- CODE TABLE FOLLOWS:
C         0   General decoder receipt time
C         1   NCEP receipt time
C         2   OSO  receipt time
C         3   ARINC ground station receipt time
C         4   Radiosonde TEMP AA part receipt time
C         5   Radiosonde TEMP BB part receipt time
C         6   Radiosonde TEMP CC part receipt time
C         7   Radiosonde TEMP DD part receipt time
C         8   Radiosonde PILOT AA part receipt time
C         9   Radiosonde PILOT BB part receipt time
C        10   Radiosonde PILOT CC part receipt time
C        11   Radiosonde PILOT DD part receipt time
C      12-62  Reserved for future use
C        63   Missing
 
      DO l=1,nrct
      cf8(l) = 105
      ob8(l) = nint((nint(rct(1,l))+nint(rct(2,l))/60.) * 100.)
      IF(irecco.GT.0.AND.nint(rct(3,l)).EQ.0)  rct(3,l) = 9
      q81(l) = e36o29(nint(rct(3,l)))
      q82(l) = ' '
      CALL s02o29(8,l,*9999)
      ENDDO
 
      CALL ufbint(lunit,rmore_8,4,1,nrmore,'SIRC TTSS UALNHR UALNMN')
      rmore=rmore_8
      IF(max(rmore(3),rmore(4)).LT.bmiss)  THEN
         cf8(1) = 104
         ob8(1) = nint((rmore(3)+rmore(4)/60.) * 100.)
         q81(1) = ' '
         q82(1) = ' '
         CALL s02o29(8,1,*9999)
      END IF
      IF(nint(rat(1)).LT.100)  THEN
         cf8(1) = 106
         isir = 9
         IF(nint(rmore(1)).LT.9)  isir = nint(rmore(1))
         itec = 99
         IF(nint(rmore(2)).LT.99)  itec = nint(rmore(2))
         ob8(1) = (isir * 10000) +  (nint(rat(1)) * 100) + itec
         q81(1) = ' '
         q82(1) = ' '
         CALL s02o29(8,1,*9999)
      END IF
 
C  PUT THE UNPACKED ON29 REPORT INTO OBS
C  -------------------------------------
 
      CALL s03o29(obs,subset,*9999,*9998)
 
      RETURN
 9999 CONTINUE
      r03o29 = 999
      RETURN
 9998 CONTINUE
      print'(" IW3UNP29/R03O29: RPT with ID= ",A," TOSSED - ZERO ",
     $ "CAT.1-6,51,52 LVLS")', sid
      r03o29 = -9999
      kskupa =kskupa + 1
      RETURN
      END
C***********************************************************************
C***********************************************************************
C***********************************************************************
      FUNCTION r04o29(LUNIT,OBS)
C     ---> formerly FUNCTION SURFCE
 
      common/io29ee/pob(255),qob(255),tob(255),zob(255),dob(255),
     $              sob(255),vsg(255),clp(255),cla(255),ob8(255),
     $              cf8(255)
      common/io29ff/pqm(255),qqm(255),tqm(255),zqm(255),wqm(255),
     $              qcp(255),qca(255),q81(255),q82(255)
      common/io29gg/psl,stp,sdr,ssp,stm,dpd,tmx,tmi,hvz,prw,pw1,ccn,chn,
     $              ctl,ctm,cth,hcb,cpt,apt,pc6,snd,p24,dop,pow,how,swd,
     $              swp,swh,sst,spg,spd,shc,sas,wes
      common/io29hh/psq,spq,swq,stq,ddq
      common/io29cc/subset,idat10
      common/io29bb/kndx,kskacf(8),kskupa,ksksfc,ksksat,ksksmi
      common/io29ll/bmiss
 
      CHARACTER*80 hdstr,rcstr
      CHARACTER*8  subset,sid,e35o29,rsv,rsv2
      CHARACTER*1  pqm,qqm,tqm,zqm,wqm,qcp,qca,q81,q82,psq,spq,swq,stq,
     $ ddq
      REAL(8) rid_8,ufbint_8,bmiss
      REAL(8) hdr_8(20),rct_8(5,255),rrsv_8(3),clds_8(4,255),
     $ tmxmnm_8(4,255)
      INTEGER itiwm(0:15),ihblcs(0:9)
      dimension  obs(*),hdr(20),rct(5,255),rrsv(3),clds(4,255),jth(0:9),
     $ jtl(0:9),ltl(0:9),tmxmnm(4,255)
      equivalence(rid_8,sid)
 
      SAVE
 
      DATA hdstr/'RPID CLON CLAT HOUR MINU SELV AUTO          '/
      DATA rcstr/'RCHR RCMI RCTS                              '/
 
      DATA jth/0,1,2,3,4,5,6,8,7,9/,jtl/0,1,5,8,7,2,3,4,6,9/
      DATA ltl/0,1,5,6,7,2,8,4,3,9/
      DATA itiwm/0,3*7,3,3*7,1,3*7,4,3*7/
      DATA ihblcs/25,75,150,250,450,800,1250,1750,2250,2500/
 
C  CHECK IF THIS IS A PREPBUFR FILE
C  --------------------------------
 
      r04o29 = 99
c#V#V#dak - future
cdak  IF(SUBSET.EQ.'ADPSFC') R04O29 = PRPSFC(LUNIT,OBS)
cdak  IF(SUBSET.EQ.'SFCSHP') R04O29 = PRPSFC(LUNIT,OBS)
cdak  IF(SUBSET.EQ.'SFCBOG') R04O29 = PRPSFC(LUNIT,OBS)
caaaaadak - future
      IF(r04o29.NE.99) RETURN
      r04o29 = 0
 
      CALL s05o29
 
C  PUT THE HEADER INFORMATION INTO ON29 FORMAT
C  -------------------------------------------
 
      CALL ufbint(lunit,hdr_8,20,  1,iret,hdstr);hdr(2:)=hdr_8(2:)
      CALL ufbint(lunit,rct_8, 5,255,nrct,rcstr);rct=rct_8
      IF(hdr(5).GE.bmiss) hdr(5) = 0
      rctim = nint(rct(1,1))+nint(rct(2,1))/60.
      rid_8 = hdr_8(1)
      xob = hdr(2)
      yob = hdr(3)
      rhr = bmiss
      IF(hdr(4).LT.bmiss)  rhr = nint(hdr(4))+nint(hdr(5))/60.
      rch = rctim
      elv = hdr(6)
 
C  I1 DEFINES SYNOPTIC FORMAT FLAG (SUBSET NC000001, NC000009)
C  I1 DEFINES AUTOMATED STATION TYPE (SUBSET NC000003-NC000008,NC000010)
C  I2 DEFINES CONVERTED HOURLY FLAG (SUBSET NC000xxx)
C  I2 DEFINES SHIP LOCATION FLAG (SUBSET NC001xxx) (WHERE xxx != 006)
 
      i1  = 9
      i2  = 9
      IF(subset(1:5).EQ.'NC000')  THEN
         IF(subset(6:8).EQ.'001'.OR.subset(6:8).EQ.'009')  THEN
            i1 = 1
            IF(subset(6:8).EQ.'009')  i2 = 1
         ELSE  IF(subset(6:8).NE.'002')  THEN
            IF(hdr(7).LT.15)  THEN
               IF(hdr(7).GT.0.AND.hdr(7).LT.5) THEN
                  i1 = 2
               ELSE  IF(hdr(7).EQ.8) THEN
                  i1 = 3
               ELSE
                  i1 = 4
               END IF
            END IF
         END IF
      END IF
      itp = (10 * i1) + i2
      rtp = e33o29(subset,sid)
 
C  THE 25'TH (RESERVE) CHARACTER IS INDICATOR FOR PRECIP. (INCL./EXCL.)
C  THE 26'TH (RESERVE) CHARACTER IS INDICATOR FOR W SPEED (SOURCE/UNITS)
C         '0' - Wind speed estimated in m/s (uncertified instrument)
C         '1' - Wind speed obtained from anemometer in m/s (certified
C               instrument)
C         '3' - Wind speed estimated in knots (uncertified instrument)
C         '4' - Wind speed obtained from anemometer in knots (certified
C               instrument)
C         '7' - Missing
C  THE 27'TH (RESERVE) CHARACTER IS INDICATOR FOR STN OPER./PAST WX DATA
 
      CALL ufbint(lunit,ufbint_8,1,1,nrsv,'INPC');rrsv(1)=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,nrsv,'TIWM');tiwm=ufbint_8
      IF(tiwm.LT.bmiss)  THEN   ! Effective 3/2002
         rrsv(2) = 7
         IF(nint(tiwm).LE.15)  rrsv(2) = itiwm(nint(tiwm))
      ELSE                      ! Prior to 3/2002
         CALL ufbint(lunit,ufbint_8,1,1,nrsv,'SUWS');rrsv(2)=ufbint_8
      END IF
      CALL ufbint(lunit,ufbint_8,1,1,nrsv,'ITSO');rrsv(3)=ufbint_8
      rsv = '999     '
      DO  i=1,3
         IF(rrsv(i).LT.bmiss)  WRITE(rsv(i:i),'(I1)') nint(rrsv(i))
      ENDDO
 
C  READ THE CATEGORY 51 SURFACE DATA FROM BUFR
C  -------------------------------------------
 
      CALL ufbint(lunit,ufbint_8,1,1,iret,'PMSL');psl=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'PRES');stp=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'WDIR');sdr=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'WSPD');ssp=ufbint_8
      wspd1 = ssp
      CALL ufbint(lunit,ufbint_8,1,1,iret,'TMDB');stm=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'TMDP');dpd=ufbint_8
      IF(subset.NE.'NC000007')  THEN
         CALL ufbint(lunit,ufbint_8,1,1,iret,'MXTM');tmx=ufbint_8
         CALL ufbint(lunit,ufbint_8,1,1,iret,'MITM');tmi=ufbint_8
      ELSE
         tmx = bmiss
         tmi = bmiss
      END IF
      CALL ufbint(lunit,ufbint_8,1,1,iret,'QMPR');qsl=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'QMPR');qsp=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'QMWN');qmw=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'QMAT');qmt=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'QMDD');qmd=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'HOVI');hvz=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'PRWE');prw=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'PSW1');pw1=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'PSW2');pw2=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'TOCC');ccn=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'CHPT');cpt=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'3HPC');apt=ufbint_8
      IF(max(apt,cpt).GE.bmiss) THEN
         apt = bmiss
         CALL ufbint(lunit,ufbint_8,1,1,iret,'24PC');apt24=ufbint_8
         IF(apt24.LT.bmiss)  THEN
            apt = apt24
            cpt = bmiss
         END IF
      END IF
 
 
C  READ THE CATEGORY 52 SURFACE DATA FROM BUFR
C  -------------------------------------------
 
      CALL ufbint(lunit,ufbint_8,1,1,iret,'TP06');pc6=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'TOSD');snd=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'TP24');p24=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'TOPC');pto=ufbint_8
      IF(pto.LT.bmiss)  THEN
         IF(pc6.GE.bmiss.AND.nint(dop).EQ. 6)  pc6 = pto
cppppp
         IF(pc6.GE.bmiss.AND.nint(dop).EQ. 6)
     $    print'(" ~~IW3UNP29/R04O29: PTO used for PC6 since latter ",
     $    "missing &  6-hr DOP")'
cppppp
         IF(p24.GE.bmiss.AND.nint(dop).EQ.24)  p24 = pto
cppppp
         IF(p24.GE.bmiss.AND.nint(dop).EQ.24)
     $    print'(" ~~IW3UNP29/R04O29: PTO used for P24 since latter ",
     $    "missing & 24-hr DOP")'
cppppp
      END IF
      CALL ufbint(lunit,ufbint_8,1,1,iret,'POWW');pow=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'HOWW');how=ufbint_8
      IF(subset(1:5).EQ.'NC001')  THEN
         IF(subset(6:8).NE.'006')  THEN
            IF(min(pow,how).GE.bmiss)  THEN
               CALL ufbint(lunit,ufbint_8,1,1,iret,'POWV');pow=ufbint_8
               CALL ufbint(lunit,ufbint_8,1,1,iret,'HOWV');how=ufbint_8
            END IF
         ELSE
C  PAOBS always have a missing elev, but we know they are at sea level
            elv = 0
         END IF
      END IF
      CALL ufbint(lunit,ufbint_8,1,1,iret,'DOSW');swd=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'POSW');swp=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'HOSW');swh=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'SST1');sst=ufbint_8
      IF(sst.GE.bmiss) THEN
          CALL ufbint(lunit,ufbint_8,1,1,iret,'STMP');sst=ufbint_8
      ENDIF
      CALL ufbint(lunit,ufbint_8,1,1,iret,'????');spg=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'????');spd=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'TDMP');shc=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'ASMP');sas=ufbint_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'????');wes=ufbint_8
      i52flg = 0
      IF(min(snd,p24,pow,how,swd,swp,swh,sst,spg,spd,shc,sas,wes)
     $ .GE.bmiss.AND.(pc6.EQ.0..OR.pc6.GE.bmiss))  i52flg= 1
 
C  SOME CLOUD DATA IS NEEDED FOR LOW, MIDDLE, AND HIGH CLOUDS IN CAT. 51
C  ---------------------------------------------------------------------
 
      CALL ufbint(lunit,clds_8,4,255,ncld,'VSSO CLAM CLTP HOCB')
      clds=clds_8
      cth = -9999.
      ctm = -9999.
      ctl = -9999.
      chh = bmiss
      chm = bmiss
      chl = bmiss
      IF(ncld.EQ.0)  THEN
         ccm = bmiss
         ccl = bmiss
      ELSE
         ccm = 0.
         ccl = 0.
         DO l=1,ncld
            vss = clds(1,l)
            cam = clds(2,l)
            ctp = clds(3,l)
            cht = bmiss
            IF(clds(4,l).LT.bmiss)  THEN
                 ! Prior to 3/2002 HBLCS was not available, this will
                 !  always be tested first because it is more precise
                 !  and may still be available for some types after
                 !  3/2002
               cht = clds(4,l)
            ELSE
                 ! Effective 3/2002 this will be available and can be
                 !  used for types where HOCB is not available - less
                 !  precise and only available on 1 level
               CALL ufbint(lunit,ufbint_8,1,1,iret,'HBLCS')
               hblcs=ufbint_8
               IF(nint(hblcs).LT.10) cht = ihblcs(nint(hblcs))
            END IF
            IF(cht.LT.bmiss)  cht = cht * 3.2808
            IF(nint(vss).EQ.0)  THEN
               IF(nint(ctp).GT.9.AND.nint(ctp).LT.20)  THEN
                  ith = mod(nint(ctp),10)
                  kth = jth(ith)
                  cth = max(kth,nint(cth))
                  chh = min(cht,chh)
               ELSE  IF(nint(ctp).LT.30)  THEN
                  itm = mod(nint(ctp),10)
                  ctm = max(itm,nint(ctm))
                  IF(itm.EQ.0)  cam = 0.
                  ccm = max(cam,ccm)
                  chm = min(cht,chm)
               ELSE  IF(nint(ctp).LT.40)  THEN
                  itl = mod(nint(ctp),10)
                  ktl = jtl(itl)
                  ctl = max(ktl,nint(ctl))
                  IF(itl.EQ.0)  cam = 0.
                  ccl = max(cam,ccl)
                  chl = min(cht,chl)
               ELSE  IF(nint(ctp).EQ.59)  THEN
                  cth = 10.
                  ctm = 10.
                  IF(ccm.EQ.0.)  ccm = 15.
                  ctl = 10.
                  IF(ccl.EQ.0.)  ccl = 15.
               ELSE  IF(nint(ctp).EQ.60)  THEN
                  cth = 10.
               ELSE  IF(nint(ctp).EQ.61)  THEN
                  ctm = 10.
                  IF(ccm.EQ.0.)  ccm = 15.
               ELSE  IF(nint(ctp).EQ.62)  THEN
                  ctl = 10.
                  IF(ccl.EQ.0.)  ccl = 15.
               END IF
            END IF
         ENDDO
      END IF
      IF(nint(cth).GT.-1.AND.nint(cth).LT.10)  THEN
         cth = jth(nint(cth))
      ELSE  IF(nint(cth).NE.10)  THEN
         cth = bmiss
      END IF
      IF(nint(ctm).LT.0.OR.nint(ctm).GT.10)  THEN
         ctm = bmiss
         ccm = bmiss
      END IF
      IF(nint(ctl).GT.-1.AND.nint(ctl).LT.10)  THEN
         ctl = ltl(nint(ctl))
      ELSE  IF(nint(ctl).NE.10)  THEN
         ctl = bmiss
         ccl = bmiss
      END IF
 
C  CALL FUNCTIONS TO TRANSFORM TO ON29/124 UNITS
C  ---------------------------------------------
 
      psl = e01o29(psl)
      stp = e01o29(stp)
      sdr = e04o29(sdr,ssp)
      ssp = e05o29(sdr,ssp)
      IF(nint(sdr).EQ.0)   sdr = 360.
      IF(sdr.GE.bmiss.AND.nint(ssp).EQ.0)   sdr = 360.
      dpd = e07o29(dpd,stm)
      stm = e06o29(stm)
      tmx = e06o29(tmx)
      tmi = e06o29(tmi)
 
      psq = e35o29(qsl)
      spq = e35o29(qsp)
      swq = e35o29(qmw)
      stq = e35o29(qmt)
      ddq = e35o29(qmd)
 
C  ADJUST QUIPS QUALITY MARKERS TO REFLECT UNPACKED ON29 CONVENTION
 
      IF(subset(1:5).EQ.'NC001'.AND.psq.EQ.'C')  stp = bmiss
      IF(psl.GE.bmiss)  psq = ' '
      IF(stp.GE.bmiss)  spq = ' '
      IF(max(sdr,ssp).GE.bmiss)  swq = ' '
      IF(stm.GE.bmiss)  stq = ' '
 
      IF(subset(1:5).EQ.'NC000'.OR.subset.EQ.'NC001004')  THEN
         hvz = e09o29(hvz)
      ELSE
         hvz = e38o29(hvz)
      END IF
      prw = e10o29(prw)
      pw1 = e11o29(pw1)
      pw2 = e11o29(pw2)
      IF(ddq.NE.'P'.AND.ddq.NE.'H'.AND.ddq.NE.'C')  THEN
         ddq = ' '
         ipw2 = nint(pw2)
         IF(ipw2.GT.-1.AND.ipw2.LT.10)  WRITE(ddq,'(I1)') ipw2
      END IF
      ccn = e12o29(ccn)
      chn = e14o29(ccl,ccm)
      ctl = e15o29(ctl)
      ctm = e15o29(ctm)
      cth = e15o29(cth)
      hcb = e18o29(chl,chm,chh,ctl,ctm,cth)
      cpt = e19o29(cpt)
      apt = e01o29(apt)
 
      pc6 = e20o29(pc6)
      snd = e21o29(snd)
      p24 = e20o29(p24)
      dop = e22o29(pc6)
      pow = e23o29(pow)
      how = e24o29(how)
      swd = e25o29(swd)
      swp = e23o29(swp)
      swh = e24o29(swh)
      sst = e06o29(sst)
      spg = e28o29(spg)
      spd = e29o29(spd)
      shc = e30o29(shc)
      sas = e31o29(sas)
      wes = e32o29(wes)
 
C  MAKE THE UNPACKED ON29/124 REPORT INTO OBS
C  ------------------------------------------
 
      rsv2 = '        '
      CALL s01o29(sid,xob,yob,rhr,rch,rsv,rsv2,elv,itp,rtp)
      CALL s02o29(51,1,*9999)
      IF(i52flg.EQ.0)  CALL s02o29(52,1,*9999)
 
C  ------------------------------------------------------------------
C  MISC DATA GOES INTO CATEGORY 08
C  ------------------------------------------------------------------
C  CODE FIGURE 020 - ALTIMETER SETTING IN 0.1*MB
C  CODE FIGURE 081 - CALENDAR DAY MAXIMUM TEMPERATURE
C  CODE FIGURE 082 - CALENDAR DAY MINIMUM TEMPERATURE
C  CODE FIGURE 083 - SIX HOUR MAXIMUM TEMPERATURE
C  CODE FIGURE 084 - SIX HOUR MINIMUM TEMPERATURE
C  CODE FIGURE 085 - PRECIPITATION OVER PAST HOUR IN 0.01*INCHES
C  CODE FIGURE 098 - DURATION OF SUNSHINE FOR CALENDAR DAY IN MINUTES
C  CODE FIGURE 924 - WIND SPEED IN 0.01*M/S
C  ------------------------------------------------------------------
 
      CALL ufbint(lunit,ufbint_8,1,1,iret,'ALSE');als=ufbint_8
      IF(als.LT.bmiss) THEN
         ob8(1) = e01o29(als)
         cf8(1) = 20
         q81(1) = ' '
         q82(1) = ' '
         CALL s02o29(8,1,*9999)
      END IF
      IF(subset.EQ.'NC000007')  THEN
         CALL ufbint(lunit,tmxmnm_8,4,255,ntxm,
     $    '.DTHMXTM MXTM .DTHMITM MITM');tmxmnm=tmxmnm_8
         IF(ntxm.GT.0)  THEN
            DO i = 1,ntxm
               DO j = 1,3,2
                  IF(nint(tmxmnm(j,i)).EQ.24) THEN
                     IF(tmxmnm(j+1,i).LT.bmiss)  THEN
                        tmx = e06o29(tmxmnm(j+1,i))
                        IF(tmx.LT.0)  THEN
                           ob8(1) = 1000 + abs(nint(tmx))
                        ELSE
                           ob8(1) = nint(tmx)
                        END IF
                        cf8(1) = 81 + int(j/2)
                        q81(1) = ' '
                        q82(1) = ' '
                        CALL s02o29(8,1,*9999)
                     END IF
                  ELSE  IF(nint(tmxmnm(j,i)).EQ.6) THEN
                     IF(tmxmnm(j+1,i).LT.bmiss)  THEN
                        tmx = e06o29(tmxmnm(j+1,i))
                        IF(tmx.LT.0)  THEN
                           ob8(1) = 1000 + abs(nint(tmx))
                        ELSE
                           ob8(1) = nint(tmx)
                        END IF
                        cf8(1) = 83 + int(j/2)
                        q81(1) = ' '
                        q82(1) = ' '
                        CALL s02o29(8,1,*9999)
                     END IF
                  END IF
               ENDDO
            ENDDO
         END IF
      END IF
      CALL ufbint(lunit,ufbint_8,1,1,iret,'TP01');pc1=ufbint_8
      IF(pc1.LT.10000) THEN
         ob8(1) = e20o29(pc1)
         cf8(1) = 85
         q81(1) = ' '
         q82(1) = ' '
         CALL s02o29(8,1,*9999)
      END IF
      CALL ufbint(lunit,ufbint_8,1,1,iret,'TOSS');dus=ufbint_8
      IF(nint(dus).LT.1000) THEN
         ob8(1) = nint(98000. + dus)
         cf8(1) = 98
         q81(1) = ' '
         q82(1) = ' '
         CALL s02o29(8,1,*9999)
      END IF
      IF(wspd1.LT.bmiss) THEN
         ob8(1) = nint(wspd1*10.)
         cf8(1) = 924
         q81(1) = ' '
         q82(1) = ' '
         CALL s02o29(8,1,*9999)
      END IF
 
      CALL s03o29(obs,subset,*9999,*9998)
 
      RETURN
 
 9999 CONTINUE
      r04o29 = 999
      RETURN
 
 9998 CONTINUE
      print'(" IW3UNP29/R04O29: RPT with ID= ",A," TOSSED - ZERO ",
     $ "CAT.1-6,51,52 LVLS")', sid
      r04o29 = -9999
      ksksfc =ksksfc + 1
      RETURN
 
      END
C***********************************************************************
C***********************************************************************
C***********************************************************************
      FUNCTION r05o29(LUNIT,OBS)
C     ---> formerly FUNCTION AIRCFT
 
      common/io29ee/pob(255),qob(255),tob(255),zob(255),dob(255),
     $               sob(255),vsg(255),clp(255),cla(255),ob8(255),
     $               cf8(255)
      common/io29ff/pqm(255),qqm(255),tqm(255),zqm(255),wqm(255),
     $               qcp(255),qca(255),q81(255),q82(255)
      common/io29cc/subset,idat10
      common/io29bb/kndx,kskacf(8),kskupa,ksksfc,ksksat,ksksmi
      common/io29ll/bmiss
 
      CHARACTER*80 hdstr,lvstr,qmstr,rcstr,crawr
      CHARACTER*8 subset,sid,sido,sidmod,e35o29,rsv,rsv2,ccl,craw(1,255)
      CHARACTER*1  pqm,qqm,tqm,zqm,wqm,qcp,qca,q81,q82,cturb(0:14)
      REAL(8) rid_8,rcl_8,ufbint_8,rns_8,bmiss
      REAL(8) hdr_8(20),rct_8(5,255),arr_8(10,255),raw_8(1,255)
      dimension    obs(*),hdr(20),rct(5,255),arr(10,255),raw(1,255)
      equivalence(rid_8,sid),(rcl_8,ccl),(raw_8,craw)
 
      SAVE
 
      DATA hdstr/'RPID CLON CLAT HOUR MINU SECO               '/
      DATA lvstr/'PRLC TMDP TMDB WDIR WSPD                    '/
      DATA qmstr/'QMPR QMAT QMDD QMGP QMWN                    '/
      DATA rcstr/'RCHR RCMI RCTS                              '/
 
      DATA cturb/'0','1','2','3','0','1','2','3','0','1','2',4*'3'/
 
C  CHECK IF THIS IS A PREPBUFR FILE
C  --------------------------------
 
      r05o29 = 99
c#V#V#dak - future
cdak  IF(SUBSET.EQ.'AIRCFT') R05O29 = PRPCFT(LUNIT,OBS)
cdak  IF(SUBSET.EQ.'AIRCAR') R05O29 = PRPCFT(LUNIT,OBS)
caaaaadak - future
      IF(r05o29.NE.99) RETURN
      r05o29 = 0
 
      CALL s05o29
 
C  PUT THE HEADER INFORMATION INTO ON29 FORMAT
C  -------------------------------------------
 
      CALL ufbint(lunit,hdr_8,20,  1,iret,hdstr);hdr(2:)=hdr_8(2:)
      IF(iret.EQ.0)  sid = '        '
      CALL ufbint(lunit,rct_8, 5,255,nrct,rcstr);rct=rct_8
      IF(hdr(5).GE.bmiss) hdr(5) = 0
      IF(hdr(6).GE.bmiss) hdr(6) = 0
      rctim = nint(rct(1,1))+nint(rct(2,1))/60.
      rid_8 = hdr_8(1)
      xob = hdr(2)
      yob = hdr(3)
      rhr = bmiss
      IF(hdr(4).LT.bmiss) rhr = nint(hdr(4)) + ((nint(hdr(5)) * 60.) +
     $ nint(hdr(6)))/3600.
      rch = rctim
 
C  TRY TO FIND FIND THE FLIGHT LEVEL HEIGHT
C  ----------------------------------------
 
      CALL ufbint(lunit,hdr_8,20,1,iret,'PSAL FLVL IALT HMSL PRLC')
      hdr=hdr_8
      elev = bmiss
      IF(hdr(5).LT.bmiss) elev = e03o29(hdr(5)*.01)
      IF(hdr(4).LT.bmiss) elev = hdr(4)
C FOR MDCARS ACARS DATA ONLY:
C  UNCOMMENTING NEXT LINE WILL SET P-ALT TO REPORTED "IALT" VALUE --
C    IN THIS CASE, PREPDATA WILL LATER GET PRESS. VIA STD. ATMOS. FCN.
C  COMMENTING NEXT LINE WILL USE REPORTED PRESSURE "PRLC" TO GET
C    P-ALT VIA INVERSE STD. ATMOS. FCN. -- IN THIS CASE, PREPDATA WILL
C    LATER RETURN THIS SAME PRESS. VIA STD. ATMOS. FCN.
cdak  IF(HDR(3).LT.BMISS) ELEV = HDR(3)
      IF(hdr(2).LT.bmiss)  elev = hdr(2) + sign(0.0000001,hdr(2))
      IF(hdr(1).LT.bmiss)  elev = hdr(1) + sign(0.0000001,hdr(1))
      elv = elev
 
C  ACFT NAVIGATION SYSTEM STORED IN INSTR. TYPE LOCATION (AS WITH ON29)
C  --------------------------------------------------------------------
 
      itp = 99
      CALL ufbint(lunit,rns_8,1,1,iret,'ACNS');rns=rns_8
      IF(rns.LT.bmiss)  THEN
         IF(nint(rns).EQ.0)  THEN
            itp = 97
         ELSE  IF(nint(rns).EQ.1)  THEN
            itp = 98
         END IF
      END IF
 
      rtp = e33o29(subset,sid)
 
      CALL ufbint(lunit,rcl_8,1,1,iret,'BORG')    ! Effective 3/2002
      IF(iret.EQ.0) THEN
         ccl = '        '
         CALL ufbint(lunit,rcl_8,1,1,iret,'ICLI') ! Prior to  3/2002
         IF(iret.EQ.0)  ccl = '        '
      END IF
cvvvvv temporary?
      IF(ccl(1:4).EQ.'KAWN')  THEN
 
C This will toss all Carswell/Tinker Aircraft reports - until Jack
C  fixes the dup-check to properly remove the duplicate Carswell
C  reports, we are better off removing them all since they are
C  often of less quality than the non-Carswell AIREP reports
C  RIGHT NOW WE ARE HAPPY WITH DUP-CHECKER'S HANDLING OF THESE,
C   SO COMMENT THIS OUT
 
cdak     R05O29 = -9999
cdak     KSKACF(?) = KSKACF(?) + 1
cdak     RETURN
      END IF
caaaaa temporary?
      IF(subset.EQ.'NC004003')  THEN
 
C  ------------------------------------
C  ASDAR/AMDAR AIRCRAFT TYPE COME HERE
C  ------------------------------------
 
cvvvvv temporary?
C  Currently, we throw out any ASDAR/AMDAR reports with header "LFPW" -
C   simply because they never appeared in NAS9000 ON29 AIRCFT data set
C   (NOTE: These should all have ACID's that begin with "IT")
C   (NOTE: These will not be removed from the new decoders, because
C          they are apparently unique reports of reasonable
C          quality.  EMC just needs to test them in a parallel run
C          to make sure prepacqc and the analysis handle them okay.)
 
C NOTE: NO, NO DON'T THROW THEM OUT ANY MORE !!!!!!
C        Keyser -- 6/13/97
 
CDAKCDAK if(ccl(1:4).eq.'LFPW')  then
cppppp
cdak  print'(" IW3UNP29/R05O29: TOSS ""LFPW"" AMDAR with ID = ",A,
cdak $ "; CCL = ",A)', SID,CCL(1:4)
cppppp
CDAKCDAK    R05O29 = -9999
CDAKCDAK    kskacf(2) = kskacf(2) + 1
CDAKCDAK    return
CDAKCDAK end if
caaaaa temporary?
 
C  MODIFY REPORT ID AS WAS DONE IN OLD ON29 AIRCRAFT PACKER
C  --------------------------------------------------------
 
         CALL s06o29(sid,sidmod)
         sido = sid
         sid = sidmod
 
C  THE 25'TH (RESERVE) CHARACTER INDICATES PHASE OF FLIGHT
C  THE 26'TH (RESERVE) CHARACTER INDICATES TEMPERATURE PRECISION
C  THE 27'TH (RESERVE) CHARACTER INDICATES CARSWELL (NEVER HAPPENS)
C   (NOTE: NAS9000 ONLY ASSIGNED HEADER "KAWN" AS CARSWELL, ALTHOUGH
C          "PHWR" AND "EGWR" ARE ALSO APPARENTLY ALSO CARSWELL)
 
         rsv = '71      '
         CALL ufbint(lunit,ufbint_8,1,1,iret,'POAF');pof=ufbint_8
         IF(pof.LT.bmiss)  WRITE(rsv(1:1),'(I1)') nint(pof)
         CALL ufbint(lunit,ufbint_8,1,1,iret,'PCAT');pct=ufbint_8
         IF(nint(pct).GT.1)  rsv(2:2) = '0'
         IF(ccl(1:4).EQ.'KAWN')  rsv(3:3) = 'C'
 
      ELSE IF(subset.EQ.'NC004004') THEN
 
C  ------------------------------
C  ACARS AIRCRAFT TYPE COME HERE
C  ------------------------------
 
         CALL ufbint(lunit,rid_8,1,1,iret,'ACRN')
         IF(iret.EQ.0)  sid = 'ACARS   '
         kndx = kndx + 1
         rsv = '999     '
 
      ELSE IF(subset.EQ.'NC004001'.OR.subset.EQ.'NC004002') THEN
 
C  -----------------------------------------
C  AIREP AND PIREP AIRCRAFT TYPES COME HERE
C  -----------------------------------------
 
C  MAY POSSIBLY NEED TO MODIFY THE RPID HERE
C  -----------------------------------------
 
         IF(sid(6:6).EQ.'Z')  sid(6:6) = 'X'
         IF(sid.EQ.'A       '.OR.sid.EQ.'        '.OR.sid(1:3).EQ.'ARP'
     $    .OR.sid(1:3).EQ.'ARS')  sid = 'AIRCFT  '
 
cvvvvv temporary?
C  Determined that Hickum AFB reports are much like Carswell - they have
C   problems!  They also are usually duplicates of either Carswell or
C   non-Carswell reports.  Apparently the front-end processing filters
C   them out (according to B. Ballish).  So, to make things match,
C   we will do the same here.
C   ACTUALLY, JEFF ATOR HAS REMOVED THESE FROM THE DECODER, SO WE
C    SHOULD NEVER EVEN SEE THEM IN THE DATABASE, but it won't hurt
C    anything to keep this in here.
C   (NOTE: These all have headers of "PHWR")
 
         if(ccl(1:4).eq.'PHWR')  then
cppppp
cdak  print'(" IW3UNP29/R05O29: TOSS ""PHWR"" AIREP with ID = ",A,
cdak $ "; CCL = ",A)', SID,CCL(1:4)
cppppp
            r05o29 = -9999
            kskacf(8) = kskacf(8) + 1
            return
         end if
caaaaa temporary?
 
cvvvvv temporary?
C        1) Carswell/Tinker AMDARS are processed as AIREP subtypes.
C      Nearly all of them are duplicated as true non-Carswell AMDARS in
C      the AMDAR subtype.  The earlier version of the aircraft dup-
C      checker could not remove such duplicates; the new verison now
C      in operations can remove these. SO, WE HAVE COMMENTED THIS OUT.
C
C      The Carswell AMDARS can be identified by the string " Sxyz" in
C      the raw report (beyond byte 40), where y is 0,1, or 2.
C      (NOTE: Apparently Carswell here applies to more headers than
C             just "KAWN", so report header is not even checked.)
 
C        2) Carswell/Tinker ACARS are processed as AIREP subtypes.
C      These MAY duplicate true non-Carswell ACARS in the ACARS
C      subtype.  The NAS9000 decoder always excluded this type (no
C      dup-checking was done).  All of these will be removed here.
C      The Carswell ACARS can be identified by the string " Sxyz" in
C      the raw report (beyond byte 40), where y is 3 or greater.
C      (NOTE: Apparently Carswell here applies to more headers than
C             just "KAWN", so report header is not even checked.)
 
         call ufbint(lunit,raw_8,1,255,nlev,'RRSTG');raw=raw_8
         if(nlev.gt.5)  then
            ni = -7
            do mm = 6,nlev
               ni = ni + 8
               crawr(ni:ni+7) = craw(1,mm)
               if(ni+8.gt.80)  go to 556
            enddo
  556       continue
            do mm = 1,ni+7
               if(crawr(mm:mm+1).eq.' S')  then
                  if((crawr(mm+2:mm+2).ge.'0'.and.crawr(mm+2:mm+2).le.
     $             '9').or.crawr(mm+2:mm+2).eq.'/')  then
                     if((crawr(mm+3:mm+3).ge.'0'.and.crawr(mm+3:mm+3)
     $                .le.'9').or.crawr(mm+3:mm+3).eq.'/')  then
                        if((crawr(mm+4:mm+4).ge.'0'.and.
     $                   crawr(mm+4:mm+4).le.'9').or.crawr(mm+4:mm+4)
     $                   .eq.'/')  then
cppppp
cdak  print'(" IW3UNP29/R05O29: For ",A,", raw_8(",I0,") = ",A)',
cdak $ SID,ni+7,crawr(1:ni+7)
cppppp
                           if(crawr(mm+3:mm+3).lt.'3')  then
 
C  THIS IS A CARSWELL/TINKER AMDAR REPORT --> THROW OUT
C   (NOT ANYMORE, DUP-CHECKER IS HANDLING THESE OKAY NOW)
C  ----------------------------------------------------
 
cppppp
cdak  print'(" IW3UNP29/R05O29: Found a Carswell AMDAR for ",A,
cdak $ "; CCL = ",A)', SID,CCL(1:4)
cppppp
cdak  R05O29 = -9999
cdak  KSKACF(3) = KSKACF(3) + 1
cdak  RETURN
                           else
 
C  THIS IS A CARSWELL/TINKER ACARS REPORT --> THROW OUT
C  ----------------------------------------------------
 
cppppp
cdak  print'(" IW3UNP29/R05O29: Found a Carswell ACARS for ",A,
cdak $ "; CCL = ",A)', SID,CCL(1:4)
cppppp
      r05o29 = -9999
      kskacf(4) = kskacf(4) + 1
      RETURN
 
                           end if
                        end if
                     end if
                  end iF
               end if
               if(mm+5.gt.ni+7)  go to 557
            enddo
  557       continue
         END IF
caaaaa temporary?
 
C  THE 25'TH (RESERVE) CHARACTER INDICATES 8'TH CHARACTER OF STATION ID
C  THE 26'TH (RESERVE) CHARACTER INDICATES 7'TH CHARACTER OF STATION ID
C  THE 27'TH (RESERVE) CHARACTER INDICATES CARSWELL
C   (NOTE: NAS9000 ONLY ASSIGNED HEADER "KAWN" AS CARSWELL, ALTHOUGH
C          "PHWR" AND "EGWR" ARE ALSO APPARENTLY ALSO CARSWELL)
 
         rsv = sid(8:8)//sid(7:7)//'      '
         IF(ccl(1:4).EQ.'KAWN')  rsv(3:3) = 'C'
 
      END IF
 
C  -----------------------------
C  ALL AIRCRAFT TYPES COME HERE
C  -----------------------------
 
      CALL ufbint(lunit,ufbint_8,1,1,iret,'DGOT');dgt=ufbint_8
 
C  PUT THE LEVEL DATA INTO ON29 UNITS
C  ----------------------------------
 
      CALL ufbint(lunit,arr_8,10,255,nlev,lvstr);arr=arr_8
      DO l=1,nlev
 
Cvvvvv temporary?
C  Even though PREPDATA filters out any aircraft reports with a missing
C   wind, or AIREP/PIREP and AMDAR reports below 100 and 2286 meters,
C   respectively, it will be done here for now in order to help in
C   the comparison between counts coming from the Cray dumps and the
C   NAS9000 ON29 dumps (the NAS9000 ON29 maker filters these out).
 
C  NO, NO LET'S NOT FILTER HERE ANY MORE - LEAVE IT UP TO PREPDATA
C   SINCE WE AREN'T COMPARING NAS9000 AND CRAY COUNTS ANY MORE
C     Keyser -- 6/13/97
 
CDAKCDAK if(arr(4,1).ge.bmiss.or.arr(5,1).ge.bmiss)  then
CDAKCDAK    R05O29 = -9999
CDAKCDAK    kskacf(5) = kskacf(5) + 1
CDAKCDAK    return
CDAKCDAK end if
CDAKCDAK if(subset.eq.'NC004003'.and.elev.lt.2286.)  then
CDAKCDAK    R05O29 = -9999
CDAKCDAK    kskacf(6) = kskacf(6) + 1
CDAKCDAK    return
CDAKCDAK else if(subset.ne.'NC004004'.and.elev.lt.100.)  then
CDAKCDAK    R05O29 = -9999
CDAKCDAK    kskacf(7) = kskacf(7) + 1
CDAKCDAK    return
CDAKCDAK end if
caaaaa temporary?
 
      pob(l) = e01o29(arr(1,l))
      qob(l) = e07o29(arr(2,l),arr(3,l))
      tob(l) = e06o29(arr(3,l))
      zob(l) = elev
      dob(l) = e04o29(arr(4,l),arr(5,l))
      sob(l) = e05o29(arr(4,l),arr(5,l))
      ENDDO
      wspd1 = arr(5,1)
 
      CALL ufbint(lunit,arr_8,10,255,nlev,qmstr);arr=arr_8
 
      IF(subset.EQ.'NC004004') THEN
 
C  ---------------------------------------------------------
C  ACARS AIRCRAFT TYPE COME HERE FOR QUALITY MARK ASSIGNMENT
C  ---------------------------------------------------------
 
         DO l=1,nlev
            pqm(l) = e35o29(arr(1,l))
            tqm(l) = e35o29(arr(2,l))
            qqm(l) = e35o29(arr(3,l))
            zqm(l) = e35o29(arr(4,l))
            wqm(l) = e35o29(arr(5,l))
         ENDDO
 
C  DEFAULT Q.MARK FOR WIND: "A"
C  ----------------------------
 
         IF(nlev.EQ.0.OR.arr(5,1).GE.bmiss)  wqm(1) = 'A'
 
      ELSE
 
C  --------------------------------------------------------------
C  ALL OTHER AIRCRAFT TYPES COME HERE FOR QUALITY MARK ASSIGNMENT
C  --------------------------------------------------------------
 
         DO l=1,nlev
            arr(4,l) =  2
 
C  IF KEEP  FLAG ON WIND, ENTIRE REPORT GETS KEEP  FLAG ('H' IN ZQM)
C   -- unless....
C  IF PURGE FLAG ON WIND, ENTIRE REPORT GETS PURGE FLAG ('P' IN ZQM)
C  IF PURGE FLAG ON TEMP, ENTIRE REPORT GETS PURGE FLAG ('P' IN ZQM)
C  IF FAIL  FLAG ON WIND, ENTIRE REPORT GETS FAIL  FLAG ('F' IN ZQM)
C  IF FAIL  FLAG ON TEMP, ENTIRE REPORT GETS FAIL  FLAG ('F' IN ZQM)
C  -----------------------------------------------------------------
 
            IF(arr(5,l).EQ.0.AND.(arr(2,l).LT.10.OR.arr(2,l).GT.15))THEN
               arr(4,l) =  0
            ELSE  IF(arr(5,l).EQ.14.OR.arr(2,l).EQ.14)  THEN
               arr(4,l) = 14
            ELSE  IF(arr(5,l).EQ.13.OR.arr(2,l).EQ.13)  THEN
               arr(4,l) = 13
            END IF
            pqm(l) = ' '
            tqm(l) = ' '
            qqm(l) = ' '
            zqm(l) = e35o29(arr(4,l))
 
C  DEGREE OF TURBULENCE IS STORED IN MOISTURE Q.M. SLOT
C  ----------------------------------------------------
 
            IF(nint(dgt).LT.15)  qqm(l) = cturb(nint(dgt))
         ENDDO
 
C  DEFAULT Q.MARK FOR WIND: "C"
C  ----------------------------
 
         wqm(1) = 'C'
      END IF
 
C  PUT THE UNPACKED ON29 REPORT INTO OBS
C  -------------------------------------
 
      rsv2 = '        '
      CALL s01o29(sid,xob,yob,rhr,rch,rsv,rsv2,elv,itp,rtp)
      CALL s02o29(6,1,*9999)
 
C  ------------------------------------------------------------------
C  MISC DATA GOES INTO CATEGORY 08
C  ------------------------------------------------------------------
C  CODE FIGURE 021 - REPORT SEQUENCE NUMBER
C  CODE FIGURE 917 - CHARACTERS 1 AND 2 OF ACTUAL STATION IDENTIFICATION
C                     (CURRENTLY ONLY FOR ASDAR/AMDAR)
C  CODE FIGURE 918 - CHARACTERS 3 AND 4 OF ACTUAL STATION IDENTIFICATION
C                     (CURRENTLY ONLY FOR ASDAR/AMDAR)
C  CODE FIGURE 919 - CHARACTERS 5 AND 6 OF ACTUAL STATION IDENTIFICATION
C                     (CURRENTLY ONLY FOR ASDAR/AMDAR)
C  CODE FIGURE 920 - CHARACTERS 7 AND 8 OF ACTUAL STATION IDENTIFICATION
C                     (CURRENTLY ONLY FOR ASDAR/AMDAR AND ACARS)
C  CODE FIGURE 921 - OBSERVATION TIME TO NEAREST 1000'TH OF AN HOUR
C                     (CURRENTLY ONLY FOR ACARS)
C  CODE FIGURE 922 - FIRST TWO CHARACTERS OF BULLETIN BEING MONITORED
C  CODE FIGURE 923 - LAST  TWO CHARACTERS OF BULLETIN BEING MONITORED
C  CODE FIGURE 924 - WIND SPEED IN 0.01*M/S
C  ------------------------------------------------------------------
 
      IF(subset.EQ.'NC004004') THEN
         ob8(1) = kndx
         cf8(1) = 21
         q81(1) = ' '
         q82(1) = ' '
         CALL s02o29(8,1,*9999)
         ob8(1) = 99999.
         q81(1) = sid(7:7)
         q82(1) = sid(8:8)
         cf8(1) = 920
         CALL s02o29(8,1,*9999)
         IF(rhr.LT.bmiss)  THEN
            ob8(1) = nint((rhr*1000.)+0.0000001)
            cf8(1) = 921
            q81(1) = ' '
            q82(1) = ' '
            CALL s02o29(8,1,*9999)
         END IF
      ELSE  IF(subset.EQ.'NC004003')  THEN
         DO  kkk = 1,4
            ob8(kkk) = 99999.
            q81(kkk) = sido(2*kkk-1:2*kkk-1)
            q82(kkk) = sido(2*kkk:2*kkk)
            cf8(kkk) = 916 + kkk
            CALL s02o29(8,kkk,*9999)
         ENDDO
      END IF
      IF(ccl.NE.'        ') THEN
         ob8(2) = 99999.
         q81(2) = ccl(1:1)
         q82(2) = ccl(2:2)
         cf8(2) = 922
         CALL s02o29(8,2,*9999)
         ob8(3) = 99999.
         q81(3) = ccl(3:3)
         q82(3) = ccl(4:4)
         cf8(3) = 923
         CALL s02o29(8,3,*9999)
      END IF
      IF(wspd1.LT.bmiss) THEN
         ob8(4) = nint(wspd1*10.)
         cf8(4) = 924
         q81(4) = ' '
         q82(4) = ' '
         CALL s02o29(8,4,*9999)
      END IF
 
      CALL s03o29(obs,subset,*9999,*9998)
 
      RETURN
 
 9999 CONTINUE
      r05o29 = 999
      RETURN
 
 9998 CONTINUE
      print'(" IW3UNP29/R05O29: RPT with ID= ",A," TOSSED - ZERO ",
     $ "CAT.1-6,51,52 LVLS")', sid
      r05o29 = -9999
      kskacf(1) = kskacf(1) + 1
      RETURN
 
      END
C***********************************************************************
C***********************************************************************
C***********************************************************************
      FUNCTION r06o29(LUNIT,OBS)
C     ---> formerly FUNCTION SATWND
 
      common/io29ee/pob(255),qob(255),tob(255),zob(255),dob(255),
     $               sob(255),vsg(255),clp(255),cla(255),ob8(255),
     $               cf8(255)
      common/io29ff/pqm(255),qqm(255),tqm(255),zqm(255),wqm(255),
     $               qcp(255),qca(255),q81(255),q82(255)
      common/io29cc/subset,idat10
      common/io29bb/kndx,kskacf(8),kskupa,ksksfc,ksksat,ksksmi
      common/io29kk/kount(499,18)
      common/io29ll/bmiss
 
      CHARACTER*80 hdstr,lvstr,qmstr,rcstr
      CHARACTER*8  subset,sid,e35o29,rsv,rsv2
      CHARACTER*3  cindx3
      CHARACTER*1  pqm,qqm,tqm,zqm,wqm,qcp,qca,q81,q82,csat(499),
     $ cprd(9),cindx7,c7(26),cprod(0:4),cprdf(3)
      INTEGER      iprdf(3)
      REAL(8) rid_8,ufbint_8,bmiss
      REAL(8) hdr_8(20),rct_8(5,255),arr_8(10,255)
      dimension    obs(*),hdr(20),rct(5,255),arr(10,255)
      equivalence(rid_8,sid)
 
      SAVE
 
      DATA hdstr/'RPID CLON CLAT HOUR MINU SAID               '/
      DATA lvstr/'PRLC TMDP TMDB WDIR WSPD                    '/
      DATA qmstr/'QMPR QMAT QMDD QMGP SWQM                    '/
      DATA rcstr/'RCHR RCMI RCTS                              '/
 
      DATA csat  /'A','B','C','D',45*'?','Z','W','X','Y','Z','W','X',
     $ 'Y','Z','W',90*'?','R','O','P','Q','R','O','P','Q','R','O',
     $ 339*'?','V'/
      DATA cprod /'C','D','?','?','E'/
      DATA cprdf /'C','B','V'/
      DATA iprdf / 1 , 6 , 4 /
      DATA cprd  /'C','V','I','W','P','T','L','Z','G'/
      DATA c7    /'A','B','C','D','E','F','G','H','I','J','K','L','M',
     $            'N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/
 
C  CHECK IF THIS IS A PREPBUFR FILE
C  --------------------------------
 
      r06o29 = 99
c#V#V#dak - future
cdak  IF(SUBSET.EQ.'SATWND') R06O29 = PRPWND(LUNIT,OBS)
caaaaadak - future
      IF(r06o29.NE.99) RETURN
      r06o29 = 0
 
      CALL s05o29
 
C  TRY TO FIND FIND THE HEIGHT ASSIGNMENT
C  --------------------------------------
 
      CALL ufbint(lunit,hdr_8,20,1,iret,'HGHT PRLC');hdr=hdr_8
      elev = bmiss
      IF(hdr(2).LT.bmiss) elev = e03o29(hdr(2)*.01)
      IF(hdr(1).LT.bmiss) elev = hdr(1)
 
C  PUT THE HEADER INFORMATION INTO ON29 FORMAT
C  -------------------------------------------
 
      CALL ufbint(lunit,hdr_8,20,  1,iret,hdstr);hdr(2:)=hdr_8(2:)
      CALL ufbint(lunit,rct_8, 5,255,nrct,rcstr);rct=rct_8
      IF(hdr(5).GE.bmiss) hdr(5) = 0
      rctim = nint(rct(1,1))+nint(rct(2,1))/60.
      rid_8 = hdr_8(1)
      xob = hdr(2)
      yob = hdr(3)
      rhr = bmiss
      IF(hdr(4).LT.bmiss)  rhr = nint(hdr(4))+nint(hdr(5))/60.
      rch = rctim
      rsv = '990     '
 
C  THE 25'TH (RESERVE) CHARACTER IS THE CLOUD MASK/DEEP LAYER INDICATOR
C   {=2 - CLOUD TOP (NORMAL CLOUD DRIFT), =1 - DEEP LAYER,
C    =9 - INDICATOR MISSING, THUS REVERTS TO DEFAULT CLOUD TOP}
C   (=9 FOR ALL BUT U.S. HIGH-DENSITY SATWND TYPES)
C  --------------------------------------------------------------------
 
C  THE 27'TH (RESERVE) CHARACTER INDICATES THE PRODUCER OF THE SATWND
C  ------------------------------------------------------------------
 
C  THE INSTRUMENT TYPE INDICATES THE PRODUCT TYPE
C  ----------------------------------------------
 
      itp = 99
 
C  REPROCESS THE STN. ID
C  ---------------------
 
C    REPROCESSED CHAR 1 -----> GOES: BUFR CHAR 1
C                       -----> METEOSAT: SAT. NO.  52, 56     GET 'X'
C                                        SAT. NO.  53, 57     GET 'Y'
C                                        SAT. NO.  50, 54, 58 GET 'Z'
C                                        SAT. NO.  51, 55, 59 GET 'W'
C                       -----> GMS(JA):  SAT. NO. 152,156     GET 'P'
C                                        SAT. NO. 153,157     GET 'Q'
C                                        SAT. NO. 150,154,158 GET 'R'
C                                        SAT. NO. 151,155,159 GET 'O'
C                       -----> INSAT:    SAT. NO. 499         GET 'V'
C    REPROCESSED CHAR 2 -----> GOES: RETURNED VALUE IN BUFR FOR 'SWPR'
C                               (PRODUCER)
C                       -----> OTHERS: SAT. PRODUCER -- ESA   GET 'C'
C                                                    -- GMS   GET 'D'
C                                                    -- INSAT GET 'E'
C    REPROCESSED CHAR 6 -----> GOES: BUFR CHAR 6
C                       -----> OTHERS -- INFRA-RED CLOUD DRIFT GET 'C'
C                                     -- VISIBLE   CLOUD DRIFT GET 'B'
C                                     -- WATER VAPOR           GET 'V'
C    REPROCESSED CHAR 3-5 ---> SEQUENTIAL SERIAL INDEX (001 - 999)
C                              (UNIQUE FOR EACH BUFR CHAR 1/6 COMB.)
C    REPROCESSED CHAR 7 -----> GROUP NUMBER FOR SERIAL INDEX IN
C                              REPROCESSED CHAR 3-5 (0 - 9, A - Z)
C    REPROCESSED CHAR 8 -----> ALWAYS BLANK (' ') FOR NOW
 
      READ(subset(8:8),'(I1)') inum
      IF(sid(1:1).GE.'A'.AND.sid(1:1).LE.'D')  THEN
         CALL ufbint(lunit,ufbint_8,1,1,iret,'SWPR');swpr=ufbint_8
         IF(nint(swpr).GT.0.AND.nint(swpr).LT.10)
     $    WRITE(rsv(3:3),'(I1)') nint(swpr)
         sid(2:2) = rsv(3:3)
         CALL ufbint(lunit,ufbint_8,1,1,iret,'SWTP');swtp=ufbint_8
         IF(swtp.LT.bmiss) itp = nint(swtp)
         CALL ufbint(lunit,ufbint_8,1,1,iret,'SWDL');swdl=ufbint_8
         IF(nint(swdl).GT.-1.AND.nint(swdl).LT.10)
     $    WRITE(rsv(1:1),'(I1)') nint(swdl)
      ELSE
         sid = '????????'
         IF(nint(hdr(6)).LT.500)  THEN
            sid(1:1) = csat(nint(hdr(6)))
            sid(2:2) = cprod(nint(hdr(6))/100)
            rsv(3:3) = sid(2:2)
         END IF
         IF(inum.LT.4)  THEN
            sid(6:6) = cprdf(inum)
            itp = iprdf(inum)
         END IF
      END IF
      cindx3 = '???'
      cindx7 = '?'
      IF(nint(hdr(6)).LT.500.AND.itp.LT.19)  THEN
         kount(nint(hdr(6)),itp) = min(kount(nint(hdr(6)),itp)+1,35999)
         kount3 = mod(kount(nint(hdr(6)),itp),1000)
         kount7 = int(kount(nint(hdr(6)),itp)/1000)
         WRITE(cindx3,'(I3.3)')  kount3
         IF(kount7.LT.10)  THEN
            WRITE(cindx7,'(I1.1)')  kount7
         ELSE
            cindx7 = c7(kount7-9)
         END IF
      END IF
      sid = sid(1:2)//cindx3//sid(6:6)//cindx7//' '
 
      elv = elev
      rtp = e33o29(subset,sid)
 
C  PUT THE LEVEL DATA INTO ON29 UNITS
C  ----------------------------------
 
      CALL ufbint(lunit,arr_8,10,255,nlev,lvstr);arr=arr_8
      DO l=1,nlev
         pob(l) = e01o29(arr(1,l))
 
C  GROSS CHECK ON PRESSURE
C  -----------------------
 
         IF(nint(pob(l)).EQ.0)  THEN
            print'(" ~~IW3UNP29/R06O29: RPT with ID= ",A," TOSSED - ",
     $       "PRES. IS ZERO MB")', sid
            r06o29 = -9999
            ksksat = ksksat + 1
            RETURN
         END IF
 
         qob(l) = e07o29(arr(2,l),arr(3,l))
         tob(l) = e06o29(arr(3,l))
         zob(l) = elev
         dob(l) = e04o29(arr(4,l),arr(5,l))
         sob(l) = e05o29(arr(4,l),arr(5,l))
      ENDDO
      wspd1 = arr(5,1)
 
C  DETERMINE QUALITY MARKERS
C  -------------------------
 
      CALL ufbint(lunit,arr_8,10,255,nlev,qmstr);arr=arr_8
      CALL ufbint(lunit,ufbint_8,1,1,iret,'RFFL');rffl=ufbint_8
      IF(rffl.LT.bmiss.AND.(nint(arr(5,1)).EQ.2.OR.nint(arr(5,1)).GE.
     $ bmiss))  THEN
         IF(nint(rffl).GT.84)  THEN
            arr(5,1) = 1
         ELSE  IF(nint(rffl).GT.55)  THEN
            arr(5,1) = 2
         ELSE  IF(nint(rffl).GT.49)  THEN
            arr(5,1) = 3
         ELSE
            arr(5,1) = 13
         END IF
      END IF
 
      DO l=1,nlev
         wqm(l) = e35o29(arr(5,l))
 
         IF(wqm(l).EQ.'R'.OR.wqm(l).EQ.'P'.OR.wqm(l).EQ.'F')  THEN
 
C  A REJECT, PURGE, OR FAIL FLAG ON WIND IS TRANSFERRED TO ALL VARIABLES
C  ---------------------------------------------------------------------
 
            pqm(l) = wqm(l)
            tqm(l) = wqm(l)
            qqm(l) = wqm(l)
            zqm(l) = wqm(l)
 
         ELSE
 
            pqm(l) = e35o29(arr(1,l))
            tqm(l) = e35o29(arr(2,l))
            qqm(l) = e35o29(arr(3,l))
            zqm(l) = e35o29(arr(4,l))
 
         END IF
 
      ENDDO
 
C  PUT THE UNPACKED ON29 REPORT INTO OBS
C  -------------------------------------
 
      rsv2 = '        '
      CALL s01o29(sid,xob,yob,rhr,rch,rsv,rsv2,elv,itp,rtp)
      CALL s02o29(6,1,*9999)
 
C  ---------------------------------------------------------------------
C  MISC DATA GOES INTO CATEGORY 08
C  ---------------------------------------------------------------------
C  CODE FIGURE 013 - PRESSURE
C  CODE FIGURE 920 - CHARACTERS 7 AND 8 OF ACTUAL STATION IDENTIFICATION
C                     (CURRENTLY ONLY APPLIES TO U.S. SATWND TYPES)
C  CODE FIGURE 924 - WIND SPEED IN 0.01*M/S
C  ---------------------------------------------------------------------
C  ---------------------------------------------------------------------
 
      IF(pob(1).LT.bmiss) THEN
         ob8(1) = nint(pob(1)*0.1)
         cf8(1) = 13
         q81(1) = ' '
         q82(1) = ' '
         CALL s02o29(8,1,*9999)
      END IF
      IF(sid(1:1).GE.'A'.AND.sid(1:1).LE.'D')  THEN
         ob8(1) = 99999.
         q81(1) = sid(7:7)
         q82(1) = sid(8:8)
         cf8(1) = 920
         CALL s02o29(8,1,*9999)
      END IF
      IF(wspd1.LT.bmiss) THEN
         ob8(2) = nint(wspd1*10.)
         cf8(2) = 924
         q81(2) = ' '
         q82(2) = ' '
         CALL s02o29(8,2,*9999)
      END IF
 
      CALL s03o29(obs,subset,*9999,*9998)
 
      RETURN
 
 9999 CONTINUE
      r06o29 = 999
      RETURN
 
 9998 CONTINUE
      print'(" IW3UNP29/R06O29: RPT with ID= ",A," TOSSED - ZERO ",
     $ "CAT.1-6,51,52 LVLS")', sid
      r06o29 = -9999
      ksksat =ksksat + 1
      RETURN
 
      END
C***********************************************************************
C***********************************************************************
C***********************************************************************
      FUNCTION r07o29(LUNIT,OBS)
C     ---> formerly FUNCTION SPSSMI
 
      common/io29ee/pob(255),qob(255),tob(255),zob(255),dob(255),
     $              sob(255),vsg(255),clp(255),cla(255),ob8(255),
     $              cf8(255)
      common/io29ff/pqm(255),qqm(255),tqm(255),zqm(255),wqm(255),
     $              qcp(255),qca(255),q81(255),q82(255)
      common/io29cc/subset,idat10
      common/io29bb/kndx,kskacf(8),kskupa,ksksfc,ksksat,ksksmi
      common/io29ll/bmiss
 
      CHARACTER*80 hdstr
      CHARACTER*8  subset,sid,rsv,rsv2
      CHARACTER*4  cstdv
      CHARACTER*1  pqm,qqm,tqm,zqm,wqm,qcp,qca,q81,q82,crf
      REAL(8) rid_8,ufbint_8,hdr_8(20),tmbr_8(7),addp_8(5),prod_8(2,2)
      REAL(8) bmiss
      dimension    obs(*),hdr(20),addp(5),prod(2,2),tmbr(7)
 
      equivalence(rid_8,sid)
 
      SAVE
 
      DATA hdstr/'RPID CLON CLAT HOUR MINU SECO NMCT SAID     '/
 
C  CHECK IF THIS IS A PREPBUFR FILE
C  --------------------------------
 
      r07o29 = 99
c#V#V#dak - future
cdak  IF(SUBSET.EQ.'SPSSMI') R07O29 = PRPSMI(LUNIT,OBS)
caaaaadak - future
      IF(r07o29.NE.99) RETURN
      r07o29 = 0
 
      CALL s05o29
 
C  PUT THE HEADER INFORMATION INTO ON29 FORMAT
C  -------------------------------------------
 
      CALL ufbint(lunit,hdr_8,20,  1,iret,hdstr);hdr(2:)=hdr_8(2:)
      IF(hdr(5).GE.bmiss) hdr(5) = 0
      IF(hdr(6).GE.bmiss) hdr(6) = 0
      rid_8 = hdr_8(1)
      xob = hdr(2)
      yob = hdr(3)
      rhr = bmiss
      IF(hdr(4).LT.bmiss) rhr = nint(hdr(4)) + ((nint(hdr(5)) * 60.) +
     $ nint(hdr(6)))/3600.
      rch = 99999.
      elv = 99999.
      itp = 99
      rtp = hdr(7)
 
C  CHECK ON VALUE FOR SATELLITE ID TO DETERMINE IF THIS IS A SUPEROB
C   (SATELLITE ID IS MISSING FOR SUPEROBS)
C  -----------------------------------------------------------------
 
      isupob = 1
      IF(hdr(8).LT.bmiss)  isupob = 0
 
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
      stdv = bmiss
 
C  PUT THE SSM/I DATA INTO ON29 UNITS (WILL RETURN TO HEADER DATA LATER)
C    ALL PROCESSING GOES INTO CATEGORY 08
C  ---------------------------------------------------------------------
 
      IF(rtp.EQ.68)  THEN
C  ---------------------------------------------------------------------
C          ** 7-CHANNEL BRIGHTNESS TEMPERATURES -- REPORT TYPE 68 **
C  ---------------------------------------------------------------------
C  CODE FIGURE 189 - 19 GHZ V BRIGHTNESS TEMPERATURE (DEG. K X 100)
C  CODE FIGURE 190 - 19 GHZ H BRIGHTNESS TEMPERATURE (DEG. K X 100)
C  CODE FIGURE 191 - 22 GHZ V BRIGHTNESS TEMPERATURE (DEG. K X 100)
C  CODE FIGURE 192 - 37 GHZ V BRIGHTNESS TEMPERATURE (DEG. K X 100)
C  CODE FIGURE 193 - 37 GHZ H BRIGHTNESS TEMPERATURE (DEG. K X 100)
C  CODE FIGURE 194 - 85 GHZ V BRIGHTNESS TEMPERATURE (DEG. K X 100)
C  CODE FIGURE 195 - 85 GHZ H BRIGHTNESS TEMPERATURE (DEG. K X 100)
C  ---------------------------------------------------------------------
         nlcat8 = 7
         CALL ufbint(lunit,tmbr_8,1,7,nlev,'TMBR');tmbr=tmbr_8
         DO  nchn = 1,7
            ob8(nchn) = min(nint(tmbr(nchn)*100.),99999)
            cf8(nchn) = 188 + nchn
         ENDDO
      ELSE  IF(rtp.EQ.575)  THEN
C  ---------------------------------------------------------------------
C          ** ADDITIONAL PRODUCTS -- REPORT TYPE 575 **
C  ---------------------------------------------------------------------
C  CODE FIGURE 210 - SURFACE TAG (RANGE: 0,1,3-6)
C  CODE FIGURE 211 - ICE CONCENTRATION (PERCENT)
C  CODE FIGURE 212 - ICE AGE (RANGE: 0,1)
C  CODE FIGURE 213 - ICE EDGE (RANGE: 0,1)
C  CODE FIGURE 214 - CALCULATED SURFACE TYPE (RANGE: 1-20)
C  ---------------------------------------------------------------------
         nlcat8 = 5
         CALL ufbint(lunit,addp_8,5,1,iret,'SFTG ICON ICAG ICED SFTP')
         addp=addp_8
         DO nadd = 1,5
            IF(addp(nadd).LT.bmiss) THEN
               ob8(nadd) = nint(addp(nadd))
               cf8(nadd) = 209 + nadd
            END IF
         ENDDO
      ELSE  IF(rtp.EQ.571)  THEN
C  ---------------------------------------------------------------------
C          ** OCEAN SURFACE WIND SPEED PRODUCT -- REPORT TYPE 571 **
C  ---------------------------------------------------------------------
C  CODE FIGURE 196 - OCEANIC WIND SPEED (M/S * 10)
C                    (RAIN FLAG IN Q.M. BYTE 2)
C  ---------------------------------------------------------------------
         cf8(1) = 196
         elv = 0
         nlcat8 = 1
         IF(isupob.EQ.1)  THEN
            CALL ufbrep(lunit,prod_8,2,2,iret,'FOST WSOS');prod=prod_8
            DO  jj = 1,2
               IF(prod(1,jj).EQ.4)  THEN
                  ob8(1) = nint(prod(2,jj)*10.)
               ELSE  IF(prod(1,jj).EQ.10)  THEN
                  stdv = nint(prod(2,jj)*100.)
               END IF
            ENDDO
         ELSE
            CALL ufbint(lunit,ufbint_8,1,1,iret,'WSOS');prodn=ufbint_8
            ob8(1) = nint(prodn*10.)
            CALL ufbint(lunit,ufbint_8,1,1,iret,'RFLG');rflg=ufbint_8
            IF(rflg.LT.bmiss) THEN
               WRITE(crf,'(I1.1)')  nint(rflg)
               q82(1) = crf
            END IF
         END IF
      ELSE  IF(rtp.EQ.65)  THEN
C  ---------------------------------------------------------------------
C      ** OCEAN TOTAL PRECIPITABLE WATER PRODUCT -- REPORT TYPE 65 **
C  ---------------------------------------------------------------------
C  CODE FIGURE 197 - TOTAL PRECIPITABLE WATER (MM * 10)
C                    (RAIN FLAG IN Q.M. BYTE 2)
C  ---------------------------------------------------------------------
         cf8(1) = 197
         elv = 0
         nlcat8 = 1
         IF(isupob.EQ.1)  THEN
            CALL ufbrep(lunit,prod_8,2,2,iret,'FOST PH2O');prod=prod_8
            DO  jj = 1,2
               IF(prod(1,jj).EQ.4)  THEN
                  ob8(1) = nint(prod(2,jj)*10.)
               ELSE  IF(prod(1,jj).EQ.10)  THEN
                  stdv = nint(prod(2,jj)*100.)
               END IF
            ENDDO
         ELSE
            CALL ufbint(lunit,ufbint_8,1,1,iret,'PH2O');prodn=ufbint_8
            ob8(1) = nint(prodn*10.)
            CALL ufbint(lunit,ufbint_8,1,1,iret,'RFLG');rflg=ufbint_8
            IF(rflg.LT.bmiss) THEN
               WRITE(crf,'(I1)')  nint(rflg)
               q82(1) = crf
            END IF
         END IF
      ELSE  IF(rtp.EQ.66)  THEN
C  ---------------------------------------------------------------------
C      ** LAND/OCEAN RAINFALL RATE -- REPORT TYPE 66 **
C  ---------------------------------------------------------------------
C  CODE FIGURE 198 - RAINFALL RATE (MM/HR)
C  ---------------------------------------------------------------------
         cf8(1) = 198
         nlcat8 = 1
         IF(isupob.EQ.1)  THEN
            CALL ufbrep(lunit,prod_8,2,2,iret,'FOST REQV');prod=prod_8
            DO  jj = 1,2
               IF(prod(1,jj).EQ.4)  THEN
                  ob8(1) = nint(prod(2,jj)*3600.)
               ELSE  IF(prod(1,jj).EQ.10)  THEN
                  stdv = nint(prod(2,jj)*36000.)
               END IF
            ENDDO
         ELSE
            CALL ufbint(lunit,ufbint_8,1,1,iret,'REQV');prodn=ufbint_8
            ob8(1) = nint(prodn*3600.)
         END IF
      ELSE  IF(rtp.EQ.576)  THEN
C  ---------------------------------------------------------------------
C      ** SURFACE TEMPERATURE -- REPORT TYPE 576 **
C  ---------------------------------------------------------------------
C  CODE FIGURE 199 - SURFACE TEMPERATURE (DEGREES KELVIN)
C  ---------------------------------------------------------------------
         cf8(1) = 199
         nlcat8 = 1
         IF(isupob.EQ.1)  THEN
            CALL ufbrep(lunit,prod_8,2,2,iret,'FOST TMSK');prod=prod_8
            DO  jj = 1,2
               IF(prod(1,jj).EQ.4)  THEN
                  ob8(1) = nint(prod(2,jj))
               ELSE  IF(prod(1,jj).EQ.10)  THEN
                  stdv = nint(prod(2,jj)*10.)
               END IF
            ENDDO
         ELSE
            CALL ufbint(lunit,ufbint_8,1,1,iret,'TMSK');prodn=ufbint_8
            ob8(1) = nint(prodn)
         END IF
      ELSE  IF(rtp.EQ.69)  THEN
C  ---------------------------------------------------------------------
C      ** OCEAN CLOUD WATER -- REPORT TYPE 69 **
C  ---------------------------------------------------------------------
C  CODE FIGURE 200 - CLOUD WATER (MM * 100)
C  ---------------------------------------------------------------------
         cf8(1) = 200
         elv = 0
         nlcat8 = 1
         IF(isupob.EQ.1)  THEN
            CALL ufbrep(lunit,prod_8,2,2,iret,'FOST CH2O');prod=prod_8
            DO  jj = 1,2
               IF(prod(1,jj).EQ.4)  THEN
                  ob8(1) = nint(prod(2,jj)*100.)
               ELSE  IF(prod(1,jj).EQ.10)  THEN
                  stdv = nint(prod(2,jj)*1000.)
               END IF
            ENDDO
         ELSE
            CALL ufbint(lunit,ufbint_8,1,1,iret,'CH2O');prodn=ufbint_8
            ob8(1) = nint(prodn*100.)
         END IF
      ELSE  IF(rtp.EQ.573)  THEN
C  ---------------------------------------------------------------------
C      ** SOIL MOISTURE -- REPORT TYPE 573 **
C  ---------------------------------------------------------------------
C  CODE FIGURE 201 - SOIL MOISTURE (MM)
C  ---------------------------------------------------------------------
         cf8(1) = 201
         nlcat8 = 1
         IF(isupob.EQ.1)  THEN
            CALL ufbrep(lunit,prod_8,2,2,iret,'FOST SMOI');prod=prod_8
            DO  jj = 1,2
               IF(prod(1,jj).EQ.4)  THEN
                  ob8(1) = nint(prod(2,jj)*1000.)
               ELSE  IF(prod(1,jj).EQ.10)  THEN
                  stdv = nint(prod(2,jj)*10000.)
               END IF
            ENDDO
         ELSE
            CALL ufbint(lunit,ufbint_8,1,1,iret,'SMOI');prodn=ufbint_8
            ob8(1) = nint(prodn*1000.)
         END IF
      ELSE  IF(rtp.EQ.574)  THEN
C  ---------------------------------------------------------------------
C      ** SNOW DEPTH -- REPORT TYPE 574 **
C  ---------------------------------------------------------------------
C  CODE FIGURE 202 - SNOW DEPTH (MM)
C  ---------------------------------------------------------------------
         cf8(1) = 202
         nlcat8 = 1
         IF(isupob.EQ.1)  THEN
            CALL ufbrep(lunit,prod_8,2,2,iret,'FOST SNDP');prod=prod_8
            DO  jj = 1,2
               IF(prod(1,jj).EQ.4)  THEN
                  ob8(1) = nint(prod(2,jj)*1000.)
               ELSE  IF(prod(1,jj).EQ.10)  THEN
                  stdv = nint(prod(2,jj)*10000.)
               END IF
            ENDDO
         ELSE
            CALL ufbint(lunit,ufbint_8,1,1,iret,'SNDP');prodn=ufbint_8
            ob8(1) = nint(prodn*1000.)
         END IF
      END IF
 
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
C  FINISH PUTTING THE HEADER INFORMATION INTO ON29 FORMAT
C  ------------------------------------------------------
 
      rsv  = '999     '
      rsv2 = '        '
 
      IF(stdv.LT.bmiss)  THEN
         WRITE(cstdv,'(I4.4)')  nint(stdv)
      ELSE
         cstdv = '9999'
      END IF
      rsv2(3:4) = cstdv(1:2)
      rsv(1:2)  = cstdv(3:4)
 
      CALL ufbint(lunit,ufbint_8,1,1,iret,'ACAV');acav=ufbint_8
      IF(acav.LT.bmiss)  THEN
         WRITE(cstdv(1:2),'(I2.2)')  nint(acav)
      ELSE
         cstdv = '9999'
      END IF
      rsv2(1:2) = cstdv(1:2)
 
      CALL s01o29(sid,xob,yob,rhr,rch,rsv,rsv2,elv,itp,rtp)
 
      DO ii = 1,nlcat8
         IF(cf8(ii).LT.bmiss)  CALL s02o29(8,ii,*9999)
      ENDDO
 
C  PUT THE UNPACKED ON29 REPORT INTO OBS
C  -------------------------------------
 
      CALL s03o29(obs,subset,*9999,*9998)
 
      RETURN
 9999 CONTINUE
      r07o29 = 999
      RETURN
 9998 CONTINUE
      print'(" IW3UNP29/R07O29: RPT with ID= ",A," TOSSED - ZERO ",
     $ "CAT.1-6,8,51,52 LVLS")', sid
      r07o29 = -9999
      ksksmi = ksksmi + 1
      RETURN
      END
 
C>    This subrountine modifies amdar reports so that last character ends
C>    with 'Z'.
C>    @param[in] IDEN Acft id
C>    @param[out] ID Modified aircraft id.
C>
C>    @author RAY CRAYTON @date 1992-02-16
 
      SUBROUTINE s06o29(IDEN,ID)
C     ---> formerly SUBROUTINE IDP
 
      CHARACTER*8  IDEN,ID
      CHARACTER*6  ZEROES
      CHARACTER*1  JCHAR
 
      SAVE
 
      DATA  zeroes/'000000'/
 
      id = '        '
 
      l = index(iden(1:8),' ')
      IF(l.EQ.0)  THEN
         n = 8
      ELSE
         n = l - 1
         IF(n.LT.1)  THEN
            id = 'AMDARZ'
         END IF
      END IF
 
      IF(n.EQ.8)  THEN
         IF(iden(8:8).EQ.'Z')  THEN
 
C  THE ID INDICATES IT IS AN 8-CHARACTER ASDAR REPORT. COMPRESS IT BY
C  DELETING THE 6TH AND 7TH CHARACTER
C  ------------------------------------------------------------------
 
            id = iden(1:5)//'Z'
            GO TO 500
         END IF
      END IF
 
      l = i05o29(iden(1:1),7,jchar)
 
      IF(l.EQ.0.OR.l.GT.6.OR.n.GT.6)  THEN
 
C  UP THROUGH 6 CHARACTERS ARE LETTERS. CHANGE 6TH CHARACTER TO 'Z'
C  ---------------------------------------------------------------
 
         IF(n.GE.5)  THEN
            id = iden
            id(6:6) = 'Z'
         ELSE
 
C  ZERO FILL AND ADD 'Z' TO MAKE 6 CHARAACTERS
C  -------------------------------------------
 
            id = iden(1:n)//zeroes(n+1:5)//'Z'
         END IF
 
      ELSE IF(n.EQ.6)  THEN
 
C  THE IDEN HAS 6 NUMERIC OR ALPHANUMERIC CHARACTERS
C  -------------------------------------------------
 
         IF(iden(6:6).EQ.'Z')  THEN
            id = iden(1:6)
         ELSE  IF(l.GT.3)  THEN
            id = iden(1:3)//iden(5:6)//'Z'
         ELSE  IF(l.EQ.1)  THEN
            id = iden(2:6)//'Z'
         ELSE
            id = iden(1:l-1)//iden(l+1:6)//'Z'
         END IF
 
      ELSE IF(n.EQ.5)  THEN
 
C  THE IDEN HAS 5 NUMERIC OR ALPHANUMERIC CHARACTERS
C  -------------------------------------------------
 
         id = iden(1:5)//'Z'
      ELSE
 
C  THE IDEN HAS 1-4 NUMERIC OR ALPHANUMERIC CHARACTERS
C  ---------------------------------------------------
 
         IF(l.EQ.1)  THEN
            id = zeroes(1:5-n)//iden(1:n)//'Z'
         ELSE
            IF(n.LT.l)  THEN
               iden(1:6) = 'AMDARZ'
            ELSE
               id = iden(1:l-1)// zeroes(1:5-n)//iden(l:n)//'Z'
            END IF
         END IF
      END IF
 
 500  CONTINUE
      RETURN
      END
 
C>    This function finds the location of the next numeric character
C>    in a string of characters.
C>
C>    @param[in] STRING Character array.
C>    @param[in] NUM Number of characters to search in string.
C>    @param[out] CHAR Character found.
C>    @return I05O29 Integer*4 location of alphanumeric character, = 0 if not found.
C>    @author Ray Crayton @date 1989-07-07
C>
      FUNCTION i05o29(STRING,NUM,CHAR)
C     ---> formerly FUNCTION IFIG
      CHARACTER*1  string(1),char
 
      SAVE
 
      DO i = 1,num
         IF(string(i).GE.'0'.AND.string(i).LE.'9')  THEN
            i05o29 = i
            char = string(i)
            GO TO 200
         END IF
      ENDDO
      i05o29 = 0
      char = '?'
 200  CONTINUE
      RETURN
      END