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* M. Weiss/NCEP 10/23 Use new decod_ut library routines, * C* clean up and simplify logic * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'BRIDGE.PRM' INCLUDE 'apcmn.cmn' CHARACTER*(*) cldt, mapfl, bufrtb CHARACTER 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 REAL slat ( MXSTNS ), slon ( MXSTNS ), selv ( MXSTNS ), + obsml ( MXLVLS, MXSTNS, NVARML ), + obsbl ( MXSTNS, NVARBL ), + obssl ( MXSTNS, NVARSL ) REAL*8 r8date (5) 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* 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* Multi-level data. DATA vcnmml / 'HT ', 'DD ', 'FF ', 'W ', + 'TV ', 'LEVTYPE', 'USDEV ', 'VSDEV ', + 'WSDEV ' / C* Antenna beam data. DATA vcnmbl / 'GSW1 ', 'GSW2 ', 'GSW3 ' / C* Single-level data. DATA vcnmsl / 'AVGMIN ', 'STATYPE' / C*----------------------------------------------------------------------- iret = 0 C* Extract the basename from the MAP data file and write it to C* the decoder log. CALL FL_PATH ( mapfl, mapdn, mapbn, ierpth ) logmsg = 'MAP filename: ' // mapbn CALL DC_WLOG ( 0, 'DC', 2, logmsg, ierwlg ) 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. CALL MINIT ( 'MAP', 'FSL', .false., ierfin ) IF ( ierfin .ne. 0 ) THEN CALL UT_EMSG ( 0, 'MINIT', ierfin ) RETURN END IF C* Using the MAP data file basename, compute the MADIS date-time. 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* Retrieve all of the stations for which there is data in the C* MAP data file. 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* Now, retrieve the rest of the data for these stations. C* Multi-level data. 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* Antenna beam data. 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* Single-level data. 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* Set the pointers for the interface arrays. CALL AP_IFSP ( rimnem, cimnem, ierfsp ) IF ( ierfsp .ne. 0 ) RETURN C* Open the BUFR tables file. CALL FL_SOPN ( bufrtb, iunbft, ierspn ) IF ( ierspn .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', ierspn, bufrtb, ierwlg ) RETURN END IF C* Open the BUFR output files. 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* Connect the BUFR tables and output files to the BUFR interface. CALL OPENBF ( iunbfp, 'NUL', iunbft ) CALL OPENBF ( iunbfr, 'NUL', iunbft ) C* Close the BUFR tables file. CALL FL_CLOS ( iunbft, iercls ) IF ( iercls .ne. 0 ) THEN CALL DC_WLOG ( 0, 'FL', iercls, ' ', ierwlg ) END IF C* Get the run date-time. CALL UT_GET_RUNDT ( cldt, irundt, iergrd ) IF ( iergrd .ne. 0 ) RETURN C* Write the number of reports to the decoder log. WRITE ( UNIT = logmsg, FMT = '( A, I6, A )' ) + 'contained ', nstns, ' reports' CALL DC_WLOG ( 0, 'DC', 2, logmsg, ierwlg ) C* Loop on each report. DO ii = 1, nstns C* Filter out FSL MAP report types that are not to be C* decoded into BUFR. IF ( ( prvid (ii) (1:5) .ne. 'HKOBS' ) .and. + ( prvid (ii) (1:3) .ne. 'JMA' ) ) THEN C* Start an entry for this report in the decoder log. logmsg = '--------------------' CALL DC_WLOG ( 3, 'DC', 2, logmsg, ierwlg ) C* Initialize the interface values arrays. CALL AP_IFIV ( ierfiv ) C* Compute and store the date-time. 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 ) r8date (1) = rivals ( iryear ) r8date (2) = rivals ( irmnth ) r8date (3) = rivals ( irdays ) r8date (4) = rivals ( irhour ) r8date (5) = rivals ( irminu ) END IF C* Station ID and provider ID. civals ( icstid ) = stid ( ii ) civals ( icprvid ) = prvid ( ii ) C* Latitude, longitude and elevation. rivals ( irslat ) = UT_MDRI ( slat ( ii ) ) rivals ( irslon ) = UT_MDRI ( slon ( ii ) ) rivals ( irselv ) = UT_MDRI ( selv ( ii ) ) C* Averaging period in minutes. rivals ( iravpm ) = UT_MDRI ( obssl ( ii, 1 ) ) rivals ( irsttp ) = UT_MDRI ( obssl ( ii, 2 ) ) C* Gate spacing. rivals ( irgsw1 ) = UT_MDRI ( obsbl ( ii, 1 ) ) rivals ( irgsw2 ) = UT_MDRI ( obsbl ( ii, 2 ) ) rivals ( irgsw3 ) = UT_MDRI ( obsbl ( ii, 3 ) ) C* Number of levels. rivals ( irnlvl ) = FLOAT ( nlvl ( ii ) ) C* Loop on each level for the multi-level data. C############## DO jj = 1, nlvl ( ii ) C* Level type. rivals ( irltyp ( jj ) ) = + UT_MDRI ( obsml ( jj, ii, 6 ) ) C* Height above mean sea level. rivals ( irhgtm ( jj ) ) = + UT_MDRI ( obsml ( jj, ii, 1 ) ) C* Wind direction (and associated QC values). 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* Wind speed (and associated QC values). 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* Standard deviation of U-wind component. rivals ( irudev ( jj ) ) = + UT_MDRI ( obsml ( jj, ii, 7 ) ) C* Standard deviation of V-wind component. rivals ( irvdev ( jj ) ) = + UT_MDRI ( obsml ( jj, ii, 8 ) ) C* W-component. rivals ( irwcmp ( jj ) ) = + UT_MDRI ( obsml ( jj, ii, 4 ) ) C* Standard deviation of W-wind component. 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 ) END DO C############## C* Write the interface output to the decoder log. CALL AP_IFPT ( 3, rimnem, cimnem, ierfpt ) C* Don't create BUFR output for reports that are more than C* NHOURS before or more than 3 hours after the run time. CALL UT_CHECK_BUFRRPTDT ( 2, irundt, r8date(1), + r8date(2), r8date(3), r8date(4), r8date(5), + nhours, 180, irptdt, iercrt ) IF ( iercrt .ne. 0 ) CYCLE C* For this report, convert interface-format data into C* BUFR and then write it to the BUFR output stream. CALL AP_BUFR ( iunbfp, iunbfr, irundt, ierbfr ) END IF END DO C* Make sure that all BUFR output has been written before exiting. 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