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* M. Weiss/NCEP 11/23 Use new decod_ut library routines, *
C* clean up and simplify logic *
C************************************************************************
INCLUDE 'GEMPRM.PRM'
INCLUDE 'BRIDGE.PRM'
INCLUDE 'cncmn.cmn'
CHARACTER*(*) cldt, mesofl, bufrtb
CHARACTER 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)
REAL slat ( MXSTNS ), slon ( MXSTNS ),
+ selv ( MXSTNS ), obs ( MXSTNS, NVAR ),
+ rtphr ( MXPCP ), rtpmi ( MXPCP ), slin ( MXSOL )
REAL*8 r8date (5)
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 )
INCLUDE 'ERMISS.FNC'
DATA rtphr / 0., 24., 1. /
DATA rtpmi / 5., 0., 0. /
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.
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* Indices (into vcname) of total precipitation
C* variable code names.
DATA itpcp / 13, 14, 46 /
C* Depth of soil ( cm )
DATA slin / 5., 10., 20., 50., 100. /
C* Indices (into vcname) of soil moisture variable code names (set 1-3,
C* perhaps, can use two dimensions).
DATA isolm1 / 31, 34, 37, 40, 43 /
DATA isolm2 / 32, 35, 38, 41, 44 /
DATA isolm3 / 33, 36, 39, 42, 45 /
C* Indices (into vcname) of soil temperature variable code names (set 1-3).
DATA isolt1 / 16, 19, 22, 25, 28 /
DATA isolt2 / 17, 20, 23, 26, 29 /
DATA isolt3 / 18, 21, 24, 27, 30 /
C*-----------------------------------------------------------------------
iret = 0
C* Extract the basename from the input data file and write it to
C* the decoder log.
CALL FL_PATH ( mesofl, mesodn, mesobn, ierpth )
logmsg = 'CRN filename: ' // mesobn
CALL DC_WLOG ( 0, 'DC', 2, logmsg, ierwlg )
C* Save the Mesonet data file basename in a separate variable
C* for later use.
cmsobn = mesobn(1:18)
C* Extract the directory just before the basename to figure out
C* whether data is CRN
CALL FL_PATH ( mesodn, mesodn2, mesobn2, ierpth )
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.
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* Using the Mesonet data file basename,
C* compute the MADIS date-time.
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* Retrieve all of the stations for which there is data in the
C* Mesonet data file.
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* Now, retrieve the rest of the data for these stations.
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* Set the pointers for the interface arrays.
CALL CN_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 file.
CALL FL_GLUN ( iunbfo, 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 ( iunbfo, '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 mesonet report types that are not to be
C* decoded into BUFR.
IF ( prvid (ii) (1:6) .ne. 'GPSMET' ) THEN
CALL ST_NUMB ( cmsobn (17:18), icmsobn, ier )
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.
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.
+ ( ( ( icmsobn .ge. 1 ) .and. ( icmsobn .le. 5 ) ) .or.
+ ( ( icmsobn .ge. 16 ) .and. ( icmsobn .le. 20 ) ) .or.
+ ( ( icmsobn .ge. 41 ) .and. ( icmsobn .le. 45 ) )
+ ) ) ) 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 CN_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, and provider IDs.
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* Wind gust direction and speed.
rivals ( irgudr ) = UT_MDRI ( obs ( ii, 10 ) )
rivals ( irgums ) = UT_MDRI ( obs ( ii, 11 ) )
C* Temperature (and associated QC values).
CALL UT_MDQI ( ii, 2, obs, qcd, iqca, iqcr, MXSTNS,
+ rivals ( irtmpk ), civals ( ictmpkqd ),
+ rivals ( irtmpkqa ), rivals ( irtmpkqr ), ierf )
C* Relative humidity (and associated QC values).
CALL UT_MDQI ( ii, 1, obs, qcd, iqca, iqcr, MXSTNS,
+ rivals ( irrelh ), civals ( icrelhqd ),
+ rivals ( irrelhqa ), rivals ( irrelhqr ), ierf )
C* Wind direction (and associated QC values).
CALL UT_MDQI ( ii, 3, obs, qcd, iqca, iqcr, MXSTNS,
+ rivals ( irdrct ), civals ( icdrctqd ),
+ rivals ( irdrctqa ), rivals ( irdrctqr ), ierf )
C* Wind speed (and associated QC values).
CALL UT_MDQI ( ii, 4, obs, qcd, iqca, iqcr, MXSTNS,
+ rivals ( irsped ), civals ( icspedqd ),
+ rivals ( irspedqa ), rivals ( irspedqr ), ierf )
C* Platform type.
rivals ( irpltp ) = UT_MDRI ( obs ( ii, 8 ) )
C* Global solar radiation (and associated QC values).
CALL UT_MDQI ( ii, 15, obs, qcd, iqca, iqcr, MXSTNS,
+ rivals ( irsrdf ), civals ( icsrdfqd ),
+ rivals ( irsrdfqa ), rivals ( irsrdfqr ), ierf )
C* Precipitation rate (and associated QC values).
CALL UT_MDQI ( ii, 12, obs, qcd, iqca, iqcr, MXSTNS,
+ rivals ( irrpcp ), civals ( icrpcpqd ),
+ rivals ( irrpcpqa ), rivals ( irrpcpqr ), ierf )
C* Total precipitation amounts (and associated QC values).
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* Soil moistures/temperatures (and associated
C* QC values, set 1).
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* Soil moistures/temperatures (and associated QC
C* values, set 2).
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* Soil moistures/temperatures (and associated QC
C* values, set 3).
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* Write the interface output to the decoder log.
CALL CN_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* Convert interface-format data for this report
C* into BUFR output and then write the BUFR output
C* into the BUFR output stream.
CALL CN_BUFR ( iunbfo, irundt, cmsobn, ierbfr )
END IF
END IF
END DO
C* Make sure that all BUFR output has been written before exiting.
CALL UT_WBFR ( iunbfo, 'crn', 1, ierwbf )
CALL CLOSBF ( iunbfo )
CALL FL_CLAL ( iercal )
RETURN
END