SUBROUTINE AP_DCOD ( cldt, mapfl, bufrtb, nhours, iret )
C************************************************************************
C* AP_DCOD *
C* *
C* This routine decodes MAP (multi-agency profiler) data files from FSL *
C* into BUFR format. *
C* *
C* AP_DCOD ( CLDT, MAPFL, BUFRTB, NHOURS, IRET ) *
C* *
C* Input parameters: *
C* CLDT CHAR* Date-time from command line *
C* MAPFL CHAR* MAP data file from FSL *
C* BUFRTB CHAR* BUFR tables file *
C* NHOURS INTEGER Max # of hours before run time *
C* for creating BUFR output *
C* *
C* Output parameters: *
C* IRET INTEGER Return code: *
C* 0 = normal return *
C* *
C** *
C* Log: *
C* J. Ator/NCEP 10/08 *
C* J. Ator/NCEP 08/11 Add processing of STATYPE as BUFR A4ME *
C* J. Ator/NCEP 11/12 Fix faulty 3rd dimension in beam arrays *
C************************************************************************
INCLUDE 'GEMPRM.PRM'
INCLUDE 'BRIDGE.PRM'
INCLUDE 'apcmn.cmn'
C*
CHARACTER*(*) cldt, mapfl, bufrtb
C*
CHARACTER rundt*12, sysdt*12,
+ mapdn*(DCMXLN), mapbn*(DCMXLN),
+ stid(MXSTNS)*10,
+ crpttm(MXSTNS)*9, cstrtm*9,
+ prvid(MXSTNS)*10,
+ qcdml(MXLVLS,MXSTNS,NVARML)*1,
+ qcdbl(MXSTNS,NVARBL)*1,
+ qcdsl(MXSTNS,NVARSL)*1,
+ vcnmml(NVARML)*7,
+ vcnmbl(NVARBL)*7,
+ vcnmsl(NVARSL)*7,
+ rimnem(NRIMN)*8, cimnem(NCIMN)*8
C*
REAL slat ( MXSTNS ), slon ( MXSTNS ),
+ selv ( MXSTNS ),
+ obsml ( MXLVLS, MXSTNS, NVARML ),
+ obsbl ( MXSTNS, NVARBL ),
+ obssl ( MXSTNS, NVARSL )
C*
INTEGER irundt (5), irptdt (5),
+ istnm ( MXSTNS ),
+ nlvl ( MXLVLS ),
+ nbeam ( MXLVLS ),
+ nsta ( MXSTNS ),
+ iqcaml ( MXLVLS, MXSTNS, NVARML ),
+ iqcabl ( MXSTNS, NVARBL ),
+ iqcasl ( MXSTNS, NVARSL ),
+ iqcrml ( MXLVLS, MXSTNS, NVARML ),
+ iqcrbl ( MXSTNS, NVARBL ),
+ iqcrsl ( MXSTNS, NVARSL )
C*
INCLUDE 'ERMISS.FNC'
C*
C*
C* The following variable code names define, in accordance
C* with the MADIS table files "static/maptbl.txt" and
C* "static/mapvcn.txt", the variables that will be read
C* from the MAP data file.
C*
C* Multi-level data.
C*
DATA vcnmml
+ / 'HT ', 'DD ', 'FF ', 'W ',
+ 'TV ', 'LEVTYPE', 'USDEV ', 'VSDEV ',
+ 'WSDEV ' /
C*
C* Antenna beam data.
C*
DATA vcnmbl
+ / 'GSW1 ', 'GSW2 ', 'GSW3 ' /
C*
C* Single-level data.
C*
DATA vcnmsl
+ / 'AVGMIN ', 'STATYPE' /
C*-----------------------------------------------------------------------
iret = 0
C
C* Extract the basename from the MAP data file and write it to
C* the decoder log.
C
CALL FL_PATH ( mapfl, mapdn, mapbn, ierpth )
logmsg = 'MAP filename: ' // mapbn
CALL DC_WLOG ( 0, 'DC', 2, logmsg, ierwlg )
C
C* The MADIS (Meteorological Assimilation Data Ingest System)
C* software from FSL will be used to read the MAP data file.
C* Initialize this software.
C
CALL MINIT ( 'MAP', 'FSL', .false., ierfin )
IF ( ierfin .ne. 0 ) THEN
CALL UT_EMSG ( 0, 'MINIT', ierfin )
RETURN
END IF
C
C* Using the MAP data file basename, compute the MADIS date-time.
C
READ ( UNIT = mapbn, FMT = '( I4.4, 2I2.2, 1X, 2I2.2 )',
+ IOSTAT = ier )
+ ifyear, ifmnth, ifdays, ifhour, ifminu
IF ( ier .ne. 0 ) THEN
CALL UT_EMSG ( 0, 'READ', ier )
RETURN
END IF
CALL MCHRTIM ( ifyear, ifmnth, ifdays, ifhour, ifminu,
+ cstrtm, ierfct )
IF ( ierfct .ne. 0 ) THEN
CALL UT_EMSG ( 0, 'MCHRTIM', ierfct )
RETURN
END IF
C
C* Retrieve all of the stations for which there is data in the
C* MAP data file.
C
CALL MMAPSTA ( cstrtm, nstns, stid, istnm, slat, slon, selv,
+ crpttm, prvid, ierfst )
IF ( ierfst .ne. 0 ) THEN
IF ( ierfst .eq. 1006 ) THEN
logmsg = 'contained no reports'
CALL DC_WLOG ( 0, 'DC', 2, logmsg, ierwlg )
ELSE
CALL UT_EMSG ( 0, 'MMAPSTA', ierfst )
END IF
RETURN
END IF
C
C* Now, retrieve the rest of the data for these stations.
C
C* Multi-level data.
C
DO ii = 1, NVARML
CALL MGETMAP ( cstrtm, vcnmml ( ii ), itemp, nnmsg, nlvl,
+ obsml ( 1, 1, ii ), qcdml ( 1, 1, ii ),
+ iqcaml ( 1, 1, ii ), iqcrml ( 1, 1, ii ),
+ ierfgs )
IF ( ( ierfgs .ne. 0 ) .and. ( ierfgs .ne. 1006 ) ) THEN
CALL UT_EMSG ( 0, 'MGETMAP (multi)', ierfgs )
RETURN
END IF
END DO
C
C* Antenna beam data.
C
DO ii = 1, NVARBL
CALL MGETMAP ( cstrtm, vcnmbl ( ii ), itemp, nnmsg, nbeam,
+ obsbl ( 1, ii ), qcdbl ( 1, ii ),
+ iqcabl ( 1, ii ), iqcrbl ( 1, ii ),
+ ierfgs )
IF ( ( ierfgs .ne. 0 ) .and. ( ierfgs .ne. 1006 ) ) THEN
CALL UT_EMSG ( 0, 'MGETMAP (antenna)', ierfgs )
RETURN
END IF
END DO
C
C* Single-level data.
C
DO ii = 1, NVARSL
CALL MGETMAP ( cstrtm, vcnmsl ( ii ), itemp, nnmsg, nsta,
+ obssl ( 1, ii ), qcdsl ( 1, ii ),
+ iqcasl ( 1, ii ), iqcrsl ( 1, ii ),
+ ierfgs )
IF ( ( ierfgs .ne. 0 ) .and. ( ierfgs .ne. 1006 ) ) THEN
CALL UT_EMSG ( 0, 'MGETMAP (single)', ierfgs )
RETURN
END IF
END DO
C
C* Set the pointers for the interface arrays.
C
CALL AP_IFSP ( rimnem, cimnem, ierfsp )
IF ( ierfsp .ne. 0 ) THEN
RETURN
ENDIF
C
C* Open the BUFR tables file.
C
CALL FL_SOPN ( bufrtb, iunbft, ierspn )
IF ( ierspn .ne. 0 ) THEN
CALL DC_WLOG ( 0, 'FL', ierspn, bufrtb, ierwlg )
RETURN
END IF
C
C* Open the BUFR output files.
C
CALL FL_GLUN ( iunbfp, iergln )
IF ( iergln .ne. 0 ) THEN
CALL DC_WLOG ( 0, 'FL', iergln, ' ', ierwlg )
RETURN
END IF
CALL FL_GLUN ( iunbfr, iergln )
IF ( iergln .ne. 0 ) THEN
CALL DC_WLOG ( 0, 'FL', iergln, ' ', ierwlg )
RETURN
END IF
C
C* Connect the BUFR tables and output files to the BUFR interface.
C
CALL OPENBF ( iunbfp, 'NUL', iunbft )
CALL OPENBF ( iunbfr, 'NUL', iunbft )
C
C* Close the BUFR tables file.
C
CALL FL_CLOS ( iunbft, iercls )
IF ( iercls .ne. 0 ) THEN
CALL DC_WLOG ( 0, 'FL', iercls, ' ', ierwlg )
END IF
C
C* Get the system time.
C
itype = 1
CALL CSS_GTIM ( itype, sysdt, iergtm )
IF ( iergtm .ne. 0 ) THEN
CALL DC_WLOG ( 2, 'SS', iergtm, ' ', ierwlg )
RETURN
END IF
C
C* If a date-time was entered on the command line, then use it as
C* the run date-time. Otherwise, use the system time as the run
C* date-time.
C
IF ( cldt .eq. 'SYSTEM' ) THEN
rundt = sysdt
ELSE
CALL TI_STAN ( cldt, sysdt, rundt, ierstn )
IF ( ierstn .ne. 0 ) THEN
CALL DC_WLOG ( 2, 'TI', ierstn, ' ', ierwlg )
RETURN
END IF
END IF
C
C* Convert the run date-time to integer.
C
CALL TI_CTOI ( rundt, irundt, iercto )
IF ( iercto .ne. 0 ) THEN
CALL DC_WLOG ( 2, 'TI', iercto, ' ', ierwlg )
RETURN
END IF
C
C* Write the number of reports to the decoder log.
C
WRITE ( UNIT = logmsg, FMT = '( A, I6, A )' )
+ 'contained ', nstns, ' reports'
CALL DC_WLOG ( 0, 'DC', 2, logmsg, ierwlg )
C
C* Loop on each report.
C
DO ii = 1, nstns
C
C* Filter out FSL MAP report types that are not to be
C* decoded into BUFR.
C
IF ( ( prvid (ii) (1:5) .ne. 'HKOBS' ) .and.
+ ( prvid (ii) (1:3) .ne. 'JMA' ) ) THEN
C
C* Start an entry for this report in the decoder log.
C
logmsg = '--------------------'
CALL DC_WLOG ( 3, 'DC', 2, logmsg, ierwlg )
C
C* Initialize the interface values arrays.
C
CALL AP_IFIV ( ierfiv )
C
C* Compute and store the date-time.
C
CALL MINTTIM ( crpttm ( ii ), ifyear, ifmnth, ifdays,
+ ifhour, ifminu, ierftm )
IF ( ierftm .ne. 0 ) THEN
CALL UT_EMSG ( 2, 'MINTTIM', ierftm )
ELSE
rivals ( iryear ) = FLOAT ( 1900 + ifyear )
rivals ( irmnth ) = FLOAT ( ifmnth )
rivals ( irdays ) = FLOAT ( ifdays )
rivals ( irhour ) = FLOAT ( ifhour )
rivals ( irminu ) = FLOAT ( ifminu )
END IF
C
C* Station ID and provider ID.
C
civals ( icstid ) = stid ( ii )
civals ( icprvid ) = prvid ( ii )
C
C* Latitude, longitude and elevation.
C
rivals ( irslat ) = UT_MDRI ( slat ( ii ) )
rivals ( irslon ) = UT_MDRI ( slon ( ii ) )
rivals ( irselv ) = UT_MDRI ( selv ( ii ) )
C
C* Averaging period in minutes.
C
rivals ( iravpm ) = UT_MDRI ( obssl ( ii, 1 ) )
rivals ( irsttp ) = UT_MDRI ( obssl ( ii, 2 ) )
C
C* Gate spacing.
C
rivals ( irgsw1 ) = UT_MDRI ( obsbl ( ii, 1 ) )
rivals ( irgsw2 ) = UT_MDRI ( obsbl ( ii, 2 ) )
rivals ( irgsw3 ) = UT_MDRI ( obsbl ( ii, 3 ) )
C
C* Number of levels.
C
rivals ( irnlvl ) = FLOAT ( nlvl ( ii ) )
C
C* Loop on each level for the multi-level data.
C
DO jj = 1, nlvl ( ii )
C
C* Level type.
C
rivals ( irltyp ( jj ) ) =
+ UT_MDRI ( obsml ( jj, ii, 6 ) )
C
C* Height above mean sea level.
C
rivals ( irhgtm ( jj ) ) =
+ UT_MDRI ( obsml ( jj, ii, 1 ) )
C
C* Wind direction (and associated QC values).
C
rivals ( irdrct ( jj ) ) =
+ UT_MDRI ( obsml ( jj, ii, 2 ) )
rivals ( irdrctqa ( jj ) ) =
+ UT_MDRI ( FLOAT ( iqcaml ( jj, ii, 2 ) ) )
rivals ( irdrctqr ( jj ) ) =
+ UT_MDRI ( FLOAT ( iqcrml ( jj, ii, 2 ) ) )
civals ( icdrctqd ( jj ) ) = qcdml ( jj, ii, 2 )
C
C* Wind speed (and associated QC values).
C
rivals ( irsped ( jj ) ) =
+ UT_MDRI ( obsml ( jj, ii, 3 ) )
rivals ( irspedqa ( jj ) ) =
+ UT_MDRI ( FLOAT ( iqcaml ( jj, ii, 3 ) ) )
rivals ( irspedqr ( jj ) ) =
+ UT_MDRI ( FLOAT ( iqcrml ( jj, ii, 3 ) ) )
civals ( icspedqd ( jj ) ) = qcdml ( jj, ii, 3 )
C
C* Standard deviation of U-wind component.
C
rivals ( irudev ( jj ) ) =
+ UT_MDRI ( obsml ( jj, ii, 7 ) )
C
C* Standard deviation of V-wind component.
C
rivals ( irvdev ( jj ) ) =
+ UT_MDRI ( obsml ( jj, ii, 8 ) )
C
C* W-component.
C
rivals ( irwcmp ( jj ) ) =
+ UT_MDRI ( obsml ( jj, ii, 4 ) )
C
C* Standard deviation of W-wind component.
C
rivals ( irwdev ( jj ) ) =
+ UT_MDRI ( obsml ( jj, ii, 9 ) )
C
C* Virtual temperatures (and associated QC values).
C
rivals ( irvtmp ( jj ) ) =
+ UT_MDRI ( obsml ( jj, ii, 5 ) )
rivals ( irvtmpqa ( jj ) ) =
+ UT_MDRI ( FLOAT ( iqcaml ( jj, ii, 5 ) ) )
rivals ( irvtmpqr ( jj ) ) =
+ UT_MDRI ( FLOAT ( iqcrml ( jj, ii, 5 ) ) )
civals ( icvtmpqd ( jj ) ) = qcdml ( jj, ii, 5 )
C
END DO
C
C* Write the interface output to the decoder log.
C
CALL AP_IFPT ( 3, rimnem, cimnem, ierfpt )
C
C* Do not create BUFR output for reports that are
C* more than NHOURS before or more than 3 hours
C* after the run time.
C
IF ( ( ERMISS ( rivals ( iryear ) ) ) .or.
+ ( ERMISS ( rivals ( irmnth ) ) ) .or.
+ ( ERMISS ( rivals ( irdays ) ) ) .or.
+ ( ERMISS ( rivals ( irhour ) ) ) .or.
+ ( ERMISS ( rivals ( irminu ) ) ) ) THEN
iertmk = -1
ELSE
irptdt (1) = INT ( rivals ( iryear ) )
irptdt (2) = INT ( rivals ( irmnth ) )
irptdt (3) = INT ( rivals ( irdays ) )
irptdt (4) = INT ( rivals ( irhour ) )
irptdt (5) = INT ( rivals ( irminu ) )
CALL DC_TMCK ( 2, irundt, irptdt, nhours, 180,
+ iertmk )
END IF
IF ( iertmk .eq. 0 ) THEN
C
C* Convert interface-format data for this report
C* into BUFR output and then write the BUFR output
C* to the BUFR output stream.
C
CALL AP_BUFR ( iunbfp, iunbfr, irundt, ierbfr )
END IF
C
END IF
C
END DO
C
C* Make sure that all BUFR output has been written before exiting.
C
CALL UT_WBFR ( iunbfp, 'map', 1, ierwbf )
CALL UT_WBFR ( iunbfr, 'map', 1, ierwbf )
C
CALL CLOSBF ( iunbfp )
CALL CLOSBF ( iunbfr )
CALL FL_CLAL ( iercal )
C*
RETURN
END