SUBROUTINE CN_DCOD ( cldt, mesofl, bufrtb, nhours, iret ) C************************************************************************ C* CN_DCOD * C* * C* This routine decodes Mesonet CRN data files from FSL into BUFR * C* format (adapting from dcmeso). * C* * C* CN_DCOD ( CLDT, MESOFL, BUFRTB, NHOURS, IRET ) * C* * C* Input parameters: * C* CLDT CHAR* Date-time from command line * C* MESOFL CHAR* Mesonet CRN 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* S. Guan/NCEP 12/11 * C* J. Ator/NCEP 12/11 Change "mesonet" identifiers to "crn" * C* J. Ator/NCEP 01/19 Modify in response to call sequence * C* change for MSFCSTA in MADIS 4.3 * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'BRIDGE.PRM' INCLUDE 'cncmn.cmn' C* CHARACTER*(*) cldt, mesofl, bufrtb C* CHARACTER rundt*12, sysdt*12, + mesodn*(DCMXLN), mesobn*(DCMXLN), + stid(MXSTNS)*10, sprvid(MXSTNS)*11, + prvid(MXSTNS)*10, + crpttm(MXSTNS)*9, cstrtm*9, + qcd(MXSTNS,NVAR)*1, + vcname(NVAR)*7, + rimnem(NRIMN)*8, cimnem(NCIMN)*8, + cmsobn*18, + mesodn2*(DCMXLN), mesobn2*(DCMXLN) C* REAL slat ( MXSTNS ), slon ( MXSTNS ), + selv ( MXSTNS ), obs ( MXSTNS, NVAR ), + rtphr ( MXPCP ), rtpmi ( MXPCP ) C* REAL slin ( MXSOL ) C* INTEGER irundt (5), irptdt (5), + istnm ( MXSTNS ), isrcn ( MXSTNS ), + iqca ( MXSTNS, NVAR ), iqcr ( MXSTNS, NVAR ), + itpcp ( MXPCP ), + isolm1 ( MXSOL ), isolt1 ( MXSOL ), + isolm2 ( MXSOL ), isolt2 ( MXSOL ), + isolm3 ( MXSOL ), isolt3 ( MXSOL ) C* INCLUDE 'ERMISS.FNC' C* DATA rtphr + / 0., 24., 1. / C* DATA rtpmi + / 5., 0., 0. / C* C* The following variable code names define, in accordance C* with the MADIS table files "static/sfctbl.txt" and C* "static/sfcvcn.txt", the variables that will be read C* from the Mesonet data file. C* DATA vcname + / 'RH ', 'T ', 'DD ', 'FF ', + 'ELEV ', 'LAT ', 'LON ', 'PLATTYP', + 'SGT ', 'DDGUST ', 'FFGUST ', + 'PCPRATE', 'PCP5M ', 'PCP24H ', 'GSRD1H', + 'ST5S1 ', 'ST5S2 ', 'ST5S3 ', 'ST10S1 ', + 'ST10S2 ', 'ST10S3 ', 'ST20S1 ', 'ST20S2 ', + 'ST20S3 ', 'ST50S1 ', 'ST50S2 ', 'ST50S3 ', + 'ST100S1', 'ST100S2', 'ST100S3', 'SM5S1 ', + 'SM5S2 ', 'SM5S3 ', 'SM10S1 ', 'SM10S2 ', + 'SM10S3 ', 'SM20S1 ', 'SM20S2 ', 'SM20S3 ', + 'SM50S1 ', 'SM50S2 ', 'SM50S3 ', 'SM100S1', + 'SM100S2', 'SM100S3', 'PCPTOTL' / C* C* Indices (into vcname) of total precipitation C* variable code names. C* DATA itpcp + / 13, 14, 46 / C* C* Depth of soil ( cm ) DATA slin + / 5., 10., 20., 50., 100. / C* C* Indices (into vcname) of soil moisture variable code names (set 1-3, C* perhaps, can use two dimensions). C* DATA isolm1 + / 31, 34, 37, 40, 43 / DATA isolm2 + / 32, 35, 38, 41, 44 / DATA isolm3 + / 33, 36, 39, 42, 45 / C* C* Indices (into vcname) of soil temperature variable code names (set 1-3). C* DATA isolt1 + / 16, 19, 22, 25, 28 / DATA isolt2 + / 17, 20, 23, 26, 29 / DATA isolt3 + / 18, 21, 24, 27, 30 / C* C*----------------------------------------------------------------------- iret = 0 C C* Extract the basename from the input data file and write it to C* the decoder log. C CALL FL_PATH ( mesofl, mesodn, mesobn, ierpth ) logmsg = 'CRN filename: ' // mesobn CALL DC_WLOG ( 0, 'DC', 2, logmsg, ierwlg ) C C* Save the Mesonet data file basename in a separate variable C* for later use. C cmsobn = mesobn(1:18) C C* Extract the directory just before the basename to figure out C* whether data is CRN C CALL FL_PATH ( mesodn, mesodn2, mesobn2, ierpth ) C C* The MADIS (Meteorological Assimilation Data Ingest System) C* software from FSL will be used to read the CRN data file. C* Initialize this software. C CALL MINIT ( 'SFC', 'FSL', .false., ierfin ) IF ( ierfin .ne. 0 ) THEN CALL UT_EMSG ( 0, 'MINIT', ierfin ) RETURN END IF CALL MSETSFCPVDR ( 'ALL-SFC', .false., ierssp1 ) IF ( ierssp1 .ne. 0 ) THEN CALL UT_EMSG ( 0, 'MSETSFCPVDR', ierssp1 ) RETURN END IF IF ( mesobn2(1:3) .eq. 'crn' ) THEN CALL MSETSFCPVDR ( 'CRN', .true., ierssp2 ) ELSE logmsg = 'It is not a CRN file' CALL DC_WLOG ( 0, 'DC', 2, logmsg, ierwlg ) RETURN END IF IF ( ierssp2 .ne. 0 ) THEN CALL UT_EMSG ( 0, 'MSETSFCPVDR', ierssp2 ) RETURN END IF C Set the time window to return all records in the file C 0,0,0 is the settings for all variables in the file. minbck = 0 minfwd = 0 recwin = 0 CALL MSETWIN(minbck,minfwd,recwin,istatus) IF (istatus .ne. 0 ) THEN CALL UT_EMSG ( 0, 'MSETWIN', ierssp2 ) RETURN END IF C C* Using the Mesonet data file basename, C* compute the MADIS date-time. C READ ( UNIT = mesobn, 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* Mesonet data file. C CALL MSFCSTA ( cstrtm, nstns, stid, istnm, slat, slon, selv, + crpttm, prvid, ierfst, isrcn ) 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, 'MSFCSTA', ierfst ) END IF RETURN END IF C C* Now, retrieve the rest of the data for these stations. C DO ii = 1, NVAR CALL MGETSFC ( cstrtm, vcname ( ii ), itmp, nnmsg, + obs ( 1, ii ), qcd ( 1, ii ), + iqca ( 1, ii ), iqcr ( 1, ii ), ierfgs ) IF ( ( ierfgs .ne. 0 ) .and. + ( ierfgs .ne. 1006 ) .and. + ( ierfgs .ne. 1005 ) ) THEN CALL UT_EMSG ( 0, 'MGETSFC', ierfgs ) RETURN END IF END DO C C* Set the pointers for the interface arrays. C CALL CN_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 file. C CALL FL_GLUN ( iunbfo, 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 ( iunbfo, '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 mesonet report types that are not to be C* decoded into BUFR. C IF ( prvid (ii) (1:6) .ne. 'GPSMET' ) THEN C C* Check whether this is an AWS or APRSWXNET report, and if C* so don't decode it unless it was received within certain C* time intervals. We'll still decode all other reports C* received, regardless of the receipt time. C IF ( ( ( prvid (ii) (1:3) .ne. 'AWS' ) .and. + ( prvid (ii) (1:9) .ne. 'APRSWXNET' ) ) + .or. + ( ( ( prvid (ii) (1:3) .eq. 'AWS' ) .or. + ( prvid (ii) (1:9) .eq. 'APRSWXNET' ) ) + .and. + ( ( ( cmsobn (17:18) .ge. '01' ) .and. + ( cmsobn (17:18) .le. '05' ) ) + .or. + ( ( cmsobn (17:18) .ge. '16' ) .and. + ( cmsobn (17:18) .le. '20' ) ) + .or. + ( ( cmsobn (17:18) .ge. '41' ) .and. + ( cmsobn (17:18) .le. '45' ) ) ) ) ) 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 CN_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, and provider IDs. 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* Wind gust direction and speed. C rivals ( irgudr ) = UT_MDRI ( obs ( ii, 10 ) ) rivals ( irgums ) = UT_MDRI ( obs ( ii, 11 ) ) C C* Temperature (and associated QC values). C CALL UT_MDQI ( ii, 2, obs, qcd, iqca, iqcr, MXSTNS, + rivals ( irtmpk ), civals ( ictmpkqd ), + rivals ( irtmpkqa ), rivals ( irtmpkqr ), ierf ) C C* Relative humidity (and associated QC values). C CALL UT_MDQI ( ii, 1, obs, qcd, iqca, iqcr, MXSTNS, + rivals ( irrelh ), civals ( icrelhqd ), + rivals ( irrelhqa ), rivals ( irrelhqr ), ierf ) C C* Wind direction (and associated QC values). C CALL UT_MDQI ( ii, 3, obs, qcd, iqca, iqcr, MXSTNS, + rivals ( irdrct ), civals ( icdrctqd ), + rivals ( irdrctqa ), rivals ( irdrctqr ), ierf ) C C* Wind speed (and associated QC values). C CALL UT_MDQI ( ii, 4, obs, qcd, iqca, iqcr, MXSTNS, + rivals ( irsped ), civals ( icspedqd ), + rivals ( irspedqa ), rivals ( irspedqr ), ierf ) C C* Platform type. C rivals ( irpltp ) = UT_MDRI ( obs ( ii, 8 ) ) C C* Global solar radiation (and associated QC values). C CALL UT_MDQI ( ii, 15, obs, qcd, iqca, iqcr, MXSTNS, + rivals ( irsrdf ), civals ( icsrdfqd ), + rivals ( irsrdfqa ), rivals ( irsrdfqr ), ierf ) C C* Precipitation rate (and associated QC values). C CALL UT_MDQI ( ii, 12, obs, qcd, iqca, iqcr, MXSTNS, + rivals ( irrpcp ), civals ( icrpcpqd ), + rivals ( irrpcpqa ), rivals ( irrpcpqr ), ierf ) C C* Total precipitation amounts (and associated QC values). C rtphr ( MXPCP ) = rivals ( irhour ) kk = 0 DO jj = 1, MXPCP CALL UT_MDQI ( ii, itpcp ( jj ), + obs, qcd, iqca, iqcr, MXSTNS, + tpcp, + civals ( ictpcpqd ( kk + 1 ) ), + rivals ( irtpcpqa ( kk + 1 ) ), + rivals ( irtpcpqr ( kk + 1 ) ), + ierf ) IF (civals ( ictpcpqd ( kk + 1 ) ) .eq. 'Z') CYCLE IF ( .not. ERMISS ( tpcp ) ) THEN rivals ( irtpmi ( kk + 1 ) ) = rtpmi ( jj ) rivals ( irtphr ( kk + 1 ) ) = rtphr ( jj ) rivals ( irtpcp ( kk + 1 ) ) = tpcp kk = kk + 1 END IF END DO rivals ( irnpcp ) = kk C C* Soil moistures/temperatures (and associated QC values, set 1). C kk = 0 DO jj = 1, MXSOL CALL UT_MDQI ( ii, isolm1 ( jj ), + obs, qcd, iqca, iqcr, MXSTNS, + solm1, + civals ( icsolmqd1 ( kk + 1 ) ), + rivals ( irsolmqa1 ( kk + 1 ) ), + rivals ( irsolmqr1 ( kk + 1 ) ), + ierf ) CALL UT_MDQI ( ii, isolt1 ( jj ), + obs, qcd, iqca, iqcr, MXSTNS, + solt1, + civals ( icsoltqd1 ( kk + 1 ) ), + rivals ( irsoltqa1 ( kk + 1 ) ), + rivals ( irsoltqr1 ( kk + 1 ) ), + ierf ) IF ( ( .not. ERMISS ( solm1 ) ) .or. + ( .not. ERMISS ( solt1 ) ) ) THEN rivals ( irslin1 ( kk + 1 ) ) = slin ( jj ) rivals ( irsolm1 ( kk + 1 ) ) = solm1 rivals ( irsolt1 ( kk + 1 ) ) = solt1 kk = kk + 1 END IF END DO rivals ( irnsol1 ) = kk C C* Soil moistures/temperatures (and associated QC values, set 2). C kk = 0 DO jj = 1, MXSOL CALL UT_MDQI ( ii, isolm2 ( jj ), + obs, qcd, iqca, iqcr, MXSTNS, + solm2, + civals ( icsolmqd2 ( kk + 1 ) ), + rivals ( irsolmqa2 ( kk + 1 ) ), + rivals ( irsolmqr2 ( kk + 1 ) ), + ierf ) CALL UT_MDQI ( ii, isolt2 ( jj ), + obs, qcd, iqca, iqcr, MXSTNS, + solt2, + civals ( icsoltqd2 ( kk + 1 ) ), + rivals ( irsoltqa2 ( kk + 1 ) ), + rivals ( irsoltqr2 ( kk + 1 ) ), + ierf ) IF ( ( .not. ERMISS ( solm2 ) ) .or. + ( .not. ERMISS ( solt2 ) ) ) THEN rivals ( irslin2 ( kk + 1 ) ) = slin ( jj ) rivals ( irsolm2 ( kk + 1 ) ) = solm2 rivals ( irsolt2 ( kk + 1 ) ) = solt2 kk = kk + 1 END IF END DO rivals ( irnsol2 ) = kk C C* Soil moistures/temperatures (and associated QC values, set 3). C kk = 0 DO jj = 1, MXSOL CALL UT_MDQI ( ii, isolm3 ( jj ), + obs, qcd, iqca, iqcr, MXSTNS, + solm3, + civals ( icsolmqd3 ( kk + 1 ) ), + rivals ( irsolmqa3 ( kk + 1 ) ), + rivals ( irsolmqr3 ( kk + 1 ) ), + ierf ) CALL UT_MDQI ( ii, isolt3 ( jj ), + obs, qcd, iqca, iqcr, MXSTNS, + solt3, + civals ( icsoltqd3 ( kk + 1 ) ), + rivals ( irsoltqa3 ( kk + 1 ) ), + rivals ( irsoltqr3 ( kk + 1 ) ), + ierf ) IF ( ( .not. ERMISS ( solm3 ) ) .or. + ( .not. ERMISS ( solt3 ) ) ) THEN rivals ( irslin3 ( kk + 1 ) ) = slin ( jj ) rivals ( irsolm3 ( kk + 1 ) ) = solm3 rivals ( irsolt3 ( kk + 1 ) ) = solt3 kk = kk + 1 END IF END DO rivals ( irnsol3 ) = kk C C* Write the interface output to the decoder log. C CALL CN_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 CN_BUFR ( iunbfo, irundt, cmsobn, ierbfr ) END IF C 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 ( iunbfo, 'crn', 1, ierwbf ) C CALL CLOSBF ( iunbfo ) CALL FL_CLAL ( iercal ) C* RETURN END