This archive contains answers to questions sent to Unidata support through mid-2025. Note that the archive is no longer being updated. We provide the archive for reference; many of the answers presented here remain technically correct, even if somewhat outdated. For the most up-to-date information on the use of NSF Unidata software and data services, please consult the Software Documentation first.
Scott/Steve, I had a problem with dcrdf core dumping on Linux in the bridge/rd/rddcpm.f routine. I didn't see this in your 5.9.2 release notes on the web, so don't know if you have run in to this or not. The problem is that the sorted insertion iteration on "nn" in the section below can attempt to access an array index "0" when n=2 (eg (nn - 1) = 0): ELSE prmfnd = .false. n = 1 DO WHILE ( .not. prmfnd .and. n .le. 3 ) IF ( iwxp (m,k) .gt. i3num (n) ) THEN IF ( n .lt. 3 ) THEN DO nn = 3, 3 - n, -1 i3num (nn) = i3num (nn - 1) i3prm (nn) = i3prm (nn - 1) END DO END IF i3num (n) = iwxp (m,k) i3prm (n) = m prmfnd = .true. END IF n = n + 1 END DO I modified the loop to: nn = 3 DO WHILE (nn .gt. n ) i3num (nn) = i3num (nn - 1) i3prm (nn) = i3prm (nn - 1) nn = nn - 1 END DO I have attached the modified source file. Steve
SUBROUTINE RD_DCPM ( segmnt, lens, numnam, cpnam, lnpnm, nxtyp, + kpshr, jftmst, jftmen, iprms, mapprm, + lfchr, idtar, oristn, ispnt, rdata, more, + iret ) C************************************************************************ C* RD_DCPM * C* * C* This subroutine decodes the parameter lines. * C* * C* RD_DCPM ( SEGMNT, LENS, NUMNAM, CPNAM, LNPNM, NXTYP, KPSHR, JFTMST, * C* JFTMEN, IPRMS, MAPPRM, LFCHR, IDTAR, ORISTN, ISPNT, RDATA,* C* MORE, IRET ) * C* * C* Input parameters: * C* SEGMNT CHAR* Bulletin segment * C* LENS INTEGER Length of segment * C* NUMNAM INTEGER Number of fcst variable names * C* CPNAM (*) CHAR* Array of fcst variable names * C* LNPNM (*) INTEGER Lengths CPNAM * C* NXTYP (*) INTEGER First index of type in CPNAM * C* KPSHR (*) INTEGER Positions of forecast hours * C* JFTMST INTEGER Index of 1st valid fcst hour * C* JFTMEN INTEGER Index of last fcst hour * C* IPRMS (*) INTEGER Position of parameter in output * C* MAPPRM (*) INTEGER Mapping of cpnam to cprms * C* LFCHR (*) INTEGER Local forecast hour * C* IDTAR (*) INTEGER First integer date array * C* ORISTN CHAR* Originating station * C* * C* Input and output parameters: * C* ISPNT INTEGER Segment pointer * C* * C* Output parameters: * C* RDATA REAL Forecast data * C* ( MMPARM, * ) * C* MORE LOGICAL Flag for extended section * C* IRET INTEGER Return code * C* -1 = bad extended section * C** * C* Log: * C* F. J. Yen/NCEP 9/02 * C* F. J. Yen/NCEP 11/02 Added UTC, 3HRLY and 6HRLY to time line.* C* Cleaned up; Added new parameters & msg. * C* S. Chiswell/Unidata 3/06 Fixed sorted insertion "nn" bug * C************************************************************************ INCLUDE 'GEMPRM.PRM' C* CHARACTER*(*) segmnt, cpnam (*), oristn INTEGER kpshr (*), lnpnm (*), nxtyp (*), iprms (*) INTEGER mapprm (*), lfchr (*), idtar (*) REAL rdata ( MMPARM, * ) LOGICAL more C* C C* NUMWX is the number of weather phenomena C PARAMETER ( NUMWX = 11 ) CHARACTER cline (22)*3, idir (8)*3, clud (10)*2, + obvs (8)*3, pprb (10)*2 INTEGER line (22), mxmnln (22), ips12 (22) INTEGER idtar2 (5), i3prm (3) INTEGER iwxp (NUMWX,22), i3num (3), wnm (NUMWX), iadd(5) REAL drct (8), cfrt (10), ovis (8) REAL rlinu (22), rlinl (22), qrn (7) REAL snrn (5), ctsn (5) CHARACTER clin*200, tznlst (9)*4, errstr*80 LOGICAL prmfnd, mxmnfl, mxmndt, cont DATA tznlst / 'EDT ', 'EST ', 'CDT ', 'CST ', + 'MDT ', 'MST ', 'PDT ', 'PST ', + 'UTC ' / DATA idir / ' N', ' NE', ' E', ' SE', + ' S', ' SW', ' W', ' NW' / DATA drct / 0.0, 45.0, 90.0, 135.0, + 180.0, 225.0, 270.0, 315.0 / DATA clud / 'CL', 'FE', 'FW', 'SC', 'PC', + 'B1', 'B2', 'BK', 'MC', 'OV' / DATA cfrt / 0., 2., 2., 3., 3., + 5., 6., 6., 6., 8. / DATA obvs / ' F+', 'PF+', ' H', ' K', + ' F', ' PF', ' BD', ' BS' / DATA ovis / 1., 1., 2., 2., + 3., 3., 4., 4. / DATA pprb / ' S', ' C', ' L', ' O', ' D', + 'IS', 'WS', 'SC', 'NM', 'WP' / C* wnm has codes for drzl, lt rain, mod rain, snow, C* rain shwr, lt snow shwr (flurries), snow shwr, C* frz, drzl, frz rain, ice pellet (sleet), C* thunder shwr (tstms) DATA wnm / 2., 13., 1., 3., 16., 55., + 22., 19., 15., 23., 66. / DATA iadd / 0, 20, 40, 60, 80 / C* Use .004 in place of .01 for the start of C* second range, since "T" has been reported DATA qrn / .00, .004, .10, .25, .50, 1., 2. / DATA snrn / 0., .004, 2., 4., 6. / DATA ctsn / 0., 1., 2., 4., 6. / C------------------------------------------------------------------------ iret = 0 C* mxmndt = .false. DO k = 1, 22 ips12 ( k ) = 0 DO j = 1, NUMWX iwxp (j,k) = 0 END DO END DO more = .false. ierlin = 0 DO WHILE ( ierlin .eq. 0 ) ispnto = ispnt CALL RD_GLIN ( segmnt, lens, ispnt, clin, lenl, ierlin ) IF ( ierlin .eq. 0 ) THEN C C* Process range data C prmfnd = .false. jj = nxtyp (1) DO WHILE ( jj .lt. nxtyp (2) .and. .not. prmfnd ) IF ( clin (1:lnpnm(jj)) .eq. + cpnam (jj) (1:lnpnm(jj)) ) THEN CALL RD_RNGD ( clin, lenl, lnpnm(jj), kpshr, + jftmst, jftmen, rlinl, rlinu, ier ) prmfnd = .true. IF ( ier .eq. -1 ) THEN CALL ST_UNPR ( clin (:72), 72, errstr, + len1, ierr) errstr = oristn(:4) // ': ' CALL DC_WLOG ( 2, 'DCRDF', ier, errstr, + ierr ) ELSE mp = iprms ( mapprm (jj) ) IF ( jj .eq. 1 .or. jj .eq. 2 ) THEN C C* QPF 12HR --> QP12 C* MAX QPF --> QPX2 C DO ii = jftmst, jftmen IF ( rlinu ( ii ) .ne. RMISSD ) THEN cont = .true. jk = 1 DO WHILE ( jk .le. 7 .and. + cont ) IF ( rlinu (ii) .le. + qrn (jk) ) THEN cont = .false. IF ( ( rlinu ( ii ) .eq. + rlinl ( ii ) ) .and. + ( rlinl (ii) .eq. + qrn (jk) ) ) + THEN rdata (mp,ii) = jk - 1 ELSE rdata (mp,ii) = jk - 2 END IF ELSE jk = jk + 1 END IF END DO IF ( cont ) rdata (mp,ii) = 6. C C* ips12 ( ii ) is set to 1 when a C* 12-hr parm data exists. It is C* used for positioning MN/MX data. C ips12 ( ii ) = 1 END IF END DO ELSE IF ( jj .eq. 3 ) THEN C C* SNOW 12HR --> SN12 C DO ii = jftmst, jftmen IF ( rlinu ( ii ) .ne. RMISSD ) THEN cont = .true. jk = 1 DO WHILE ( jk .le. 5 .and. + cont ) IF ( rlinu (ii) .le. + snrn (jk) ) THEN cont = .false. IF ( rlinu (ii) .eq. + rlinl (ii) .and. + rlinl (ii) .eq. + snrn(jk) ) THEN rdata ( mp,ii ) = + ctsn (jk) ELSE rdata ( mp,ii ) = + ctsn (jk - 1) END IF END IF jk = jk + 1 END DO IF ( cont ) rdata ( mp,ii ) = 6. C C* ips12 ( ii ) is set to 1 when C* a 12-hr parm data exists for use C* in positioning MX/MN data. C ips12 ( ii ) = 1 END IF END DO END IF END IF END IF jj = jj + 1 END DO C C* Process single integer values C IF ( .not. prmfnd ) THEN jj = nxtyp (2) DO WHILE ( jj .lt. nxtyp (3) .and. .not. prmfnd ) IF ( clin (1:lnpnm(jj)) .eq. + cpnam (jj) (1:lnpnm(jj)) ) THEN mxmnfl = .false. CALL RD_IDAT ( clin, lenl, lnpnm(jj), + kpshr, jftmst, jftmen, mxmnfl, + line, ier ) prmfnd = .true. IF ( ier .eq. -1 ) THEN CALL ST_UNPR ( clin (:72), 72, errstr, + len1, ierr) errstr = oristn(:4) // ': ' CALL DC_WLOG ( 2, 'DCRDF', ier, errstr, + ierr ) ELSE mp = iprms ( mapprm (jj) ) DO ii = jftmst, jftmen IF ( line ( ii ) .ne. IMISSD ) THEN rdata ( mp, ii ) = + FLOAT ( line ( ii ) ) C C* jj equals 4 for POP 12HR C* which is a 12-hr parm, so C* ips12 is set to 1 if data C* exists in that position C IF ( jj .eq. 4 ) THEN ips12 ( ii ) = 1 END IF END IF END DO END IF END IF jj = jj + 1 END DO END IF C C* Process character data C IF ( .not. prmfnd ) THEN jj = nxtyp (3) DO WHILE ( jj .lt. nxtyp (4) .and. .not. prmfnd ) IF ( clin (1:lnpnm(jj)) .eq. + cpnam (jj) (1:lnpnm(jj)) ) THEN CALL RD_CDAT ( clin, lenl, lnpnm(jj), + kpshr, jftmst, jftmen, cline, ier ) prmfnd = .true. IF ( ier .eq. -1 ) THEN CALL ST_UNPR ( clin (:72), 72, errstr, + len1, ierr) errstr = oristn(:4) // ': ' CALL DC_WLOG ( 2, 'DCRDF', ier, errstr, + ierr ) ELSE IF ( jj .eq. 11 .or. jj .eq. 12 ) + THEN C C* WIND DIR --> DRCT C mp = iprms ( mapprm (jj) ) DO ii = jftmst, jftmen CALL ST_FIND ( cline (ii), idir, 8, + ipos, ierr) IF ( ipos .ne. 0 ) THEN rdata ( mp, ii ) = drct ( ipos ) END IF END DO ELSE IF ( jj .eq. 13 ) THEN C C* OBVIS --> OVIS C mp = iprms ( mapprm (jj) ) DO ii = jftmst, jftmen CALL ST_FIND ( cline (ii), obvs, + 10, ipos, ierr) IF ( ipos .ne. 0 ) THEN rdata ( mp, ii ) = ovis ( ipos ) END IF END DO ELSE IF ( jj .eq. 14 .or. jj .eq. 15 ) + THEN C C* CLOUDS and AVG CLOUDS --> CFRT C mp = iprms ( mapprm (jj) ) DO ii = jftmst, jftmen CALL ST_FIND ( cline (ii) (2:3), + clud, 10, ipos, ierr) IF ( ipos .ne. 0 ) THEN rdata ( mp, ii ) = cfrt ( ipos ) END IF END DO END IF END IF jj = jj + 1 END DO END IF C C* Process weather probability or areal coverage data C IF ( .not. prmfnd ) THEN jj = nxtyp (4) DO WHILE ( jj .lt. nxtyp (5) .and. .not. prmfnd ) IF ( clin (1:lnpnm(jj)) .eq. + cpnam (jj) (1:lnpnm(jj)) ) THEN CALL RD_CDAT ( clin, lenl, lnpnm(jj), kpshr, + jftmst, jftmen, cline, ier ) prmfnd = .true. IF ( ier .eq. -1 ) THEN CALL ST_UNPR ( clin (:72), 72, errstr, + len1, ierr) errstr = oristn(:4) // ': ' CALL DC_WLOG ( 2, 'DCRDF', ier, errstr, + ierr ) ELSE mprb = iprms ( mapprm (jj) ) DO ii = jftmst, jftmen CALL ST_FIND ( cline (ii) (2:3), pprb, + 10, iprb, ierr ) IF ( iprb .ne. 0 ) THEN C C* iadd is a (probability based) C* number added to the priority number C* of the precip phenomenon (1 for drzl C* having the lowest and up to NUMWX for C* tstms having the highest priority). C* This will produce a number iwxp. The C* highest 3 numbers in iwxp will C* correspond to the 3 precip phenomena C* to be used to calculate WNUM. (Thus, C* WNUM will have the 3 parameters that C* have the highest probability or areal C* coverage. In case there are more than C* 3 parameters having the highest C* probability, the 3 parameters having C* the highest priority will be selected. C* iprb is the WXPB for the parameter. C* nprm is the priority of the phenomena. C iprb = mod (iprb,5) IF ( iprb .eq. 0 ) iprb = 5 IF ( jj .ne. nxtyp(4) ) THEN nprm = nxtyp(5) - jj ELSE C C* Set nprm to 7 for duplicate C* SNOWSHWRS at postion nxtyp(4) C nprm = 7 END IF iwxp (nprm,ii) = nprm + iadd (iprb) END IF END DO END IF END IF jj = jj + 1 END DO END IF C C* Process MX/MN or MN/MX data C IF ( .not. prmfnd ) THEN jj = nxtyp (5) DO WHILE ( jj .lt. nxtyp (6) .and. .not. prmfnd ) IF ( clin (1:lnpnm(jj)) .eq. + cpnam (jj) (1:lnpnm(jj)) ) THEN mxmnfl = .true. CALL RD_IDAT ( clin, lenl, lnpnm(jj), + kpshr, jftmst, jftmen, + mxmnfl, mxmnln, mxmner ) IF ( mxmner .eq. 0 ) mxmndt = .true. prmfnd = .true. END IF jj = jj + 1 END DO END IF C C* Check if first date in date line for extended data is C* same as first date in first section, then bad section. C IF ( .not. prmfnd ) THEN ispn = ispnto - 2 CALL RD_GDTE ( segmnt, ispn + 90, ispn, + idtar2, idp, ier ) IF ( ier .eq. 0 ) THEN idate = 1 DO nn = 1, 5 IF ( idtar2 (nn) .ne. idtar (nn) ) THEN idate = 0 END IF END DO IF ( idate .eq. 1 ) THEN iret = -1 ierlin = -2 ispnt = ispnto + ispn END IF prmfnd = .true. END IF END IF C C* Check if time line for extended data C IF ( .not. prmfnd ) THEN jj = 1 jext = jj DO WHILE ( jj .le. 9 .and. + clin (1:4) .ne. tznlst (jj) ) jj = jj + 1 jext = jj END DO IF ( jext .lt. 10 ) THEN C C* Extended data; set pointer back for time line C ispnt = ispnto - 1 more = .true. ierlin = -2 END IF END IF END IF END DO IF ( mxmndt ) THEN C C* Continue processing MX/MN data to determine positioning C IF ( mxmner .eq. -1 ) THEN CALL ST_UNPR ( clin (:72), 72, errstr, len1, ierr) errstr = oristn(:4) // ': ' CALL DC_WLOG ( 2, 'DCRDF', ier, errstr, ierr ) ELSE i3 = 0 DO ii = jftmst, jftmen ips = ii IF ( mxmnln ( ii ) .ne. IMISSD .and. + i3 .eq. 0 ) THEN IF ( ii .lt. jftmen - 1 ) THEN IF ( mxmnln (ii + 1) .ne. IMISSD .and. + mxmnln (ii + 2) .ne. IMISSD ) THEN i3 = 2 C C* Assume if the next 2 positions have C* data, then it is a group of 3, so need C* to determine which value and position C* to use. (Positions of other existing C* 12-hr parameters must be set in ips12.) C* If MX/MN are in groups of 3, then the C* value in the same position will be C* used. If there are no other 12-hr C* parms nearby, then the first value in C* the group will be used. IF ( ips12 ( ii ) .eq. 1 ) THEN ips = ii ELSE IF (ips12 (ii + 1) .eq. 1) THEN ips = ii + 1 ELSE IF (ips12 (ii + 2) .eq. 1) THEN ips = ii + 2 ELSE ips = ii END IF ELSE ips = ii END IF END IF C C* Determine whether the MX/MN or MN/MX temperature C* is TNTF or TDYF. C IF ( lfchr (ips) .ge. 12 ) THEN C C* TDYF C CALL ST_FIND ( 'MN/MX', cpnam, NUMNAM, + ipos, ierr) mp = iprms ( mapprm (ipos) ) rdata ( mp, ips ) = FLOAT ( mxmnln ( ips ) ) ELSE C C* TNTF C CALL ST_FIND ( 'MX/MN', cpnam, NUMNAM, + ipos, ierr) mp = iprms ( mapprm (ipos) ) rdata ( mp, ips ) = FLOAT ( mxmnln ( ips ) ) END IF ELSE C C* This skips over the group of 3 C IF ( i3 .ne. 0 ) i3 = i3 - 1 END IF END DO END IF END IF C C* Determine wnum from weather probability or areal coverage data. C* i3num will have the highest 3 iwxp number based on priority and C* probability. i3prm will have the phenomenon priority C* (1 - NUMWX) of the corresponding i3num. C DO j = 1, 3 i3num (j) = 0 i3prm (j) = 0 END DO DO k = jftmst, jftmen np = 0 DO m = 1, NUMWX IF ( iwxp (m,k) .ne. 0 ) THEN IF ( np .eq. 0 ) THEN np = np + 1 i3num ( np ) = iwxp (m,k) i3prm ( np ) = m ELSE IF (np .eq. 1 ) THEN np = np + 1 IF ( iwxp (m,k) .gt. i3num (1) ) THEN i3num ( 2 ) = i3num ( 1 ) i3num ( 1 ) = iwxp (m,k) i3prm ( 2 ) = i3prm ( 1 ) i3prm ( 1 ) = m ELSE i3num ( 2 ) = iwxp (m,k) i3prm ( 2 ) = m END IF ELSE IF (np .eq. 2 ) THEN np = np + 1 IF ( iwxp (m,k) .gt. i3num (1) ) THEN i3num ( 3 ) = i3num ( 2 ) i3num ( 2 ) = i3num ( 1 ) i3num ( 1 ) = iwxp (m,k) i3prm ( 3 ) = i3prm ( 2 ) i3prm ( 2 ) = i3prm ( 1 ) i3prm ( 1 ) = m ELSE IF ( iwxp (m,k) .gt. i3num (2) ) THEN i3num ( 3 ) = i3num ( 2 ) i3num ( 2 ) = iwxp (m,k) i3prm ( 3 ) = i3prm ( 2 ) i3prm ( 2 ) = m ELSE i3num ( 3 ) = iwxp (m,k) i3prm ( 3 ) = m END IF ELSE prmfnd = .false. n = 1 DO WHILE ( .not. prmfnd .and. n .le. 3 ) IF ( iwxp (m,k) .gt. i3num (n) ) THEN IF ( n .lt. 3 ) THEN nn = 3 DO WHILE (nn .gt. n ) i3num (nn) = i3num (nn - 1) i3prm (nn) = i3prm (nn - 1) nn = nn - 1 END DO END IF i3num (n) = iwxp (m,k) i3prm (n) = m prmfnd = .true. END IF n = n + 1 END DO END IF END IF END DO IF (np .gt. 0 ) THEN C C* Calculate wnum C rdata (mprb,k) = wnm (i3prm(1)) IF ( np .ge. 2 ) THEN rdata (mprb,k) = rdata (mprb,k) + + 80 * wnm (i3prm(2)) END IF IF ( np .eq. 3 ) THEN rdata (mprb,k) = rdata (mprb,k) + + 6400 * wnm (i3prm(3)) END IF C C* Determine WXPB from iadd. C m = 5 prmfnd = .false. DO WHILE ( .not. prmfnd .and. m .ge. 1) IF ( i3num(1) .gt. iadd(m) ) THEN rdata (mprb+1,k) = float (m) prmfnd = .true. END IF m = m - 1 END DO END IF END DO C* RETURN END