SUBROUTINE DB_DST0 ( dburpt, ipt, iret ) C************************************************************************ C* DB_DST0 * C* * C* This subroutine gets (1) the drifting buoy ID, (2) the report obs GMT* C* time, (3) the indicator for the source and units of wind speed, (4) * C* the quadrant of the globe where the drifter is located, (5) the * C* latitude and longitude of the drifter, and (6) the quality control * C* indicators for position and time. These data are in Section 0 of * C* the report. Also, the routine stores the receipt time and obs time * C* of the report in the interface array. Since the drifting buoy is * C* assumed to be in an ocean, its elevation is set to 0.0 meters. * C* * C* DB_DST0 ( DBURPT, IPT, IRET ) * C* * C* Input parameters: * C* DBURPT CHAR* Report array * C* * C* Input parameters passed via common: * C* RCTIM (*) REAL Receipt date/time of bulletin * C* * C* Output parameters passed via common: * C* CIVALS(ICSTID) CHAR* Report ID * C* IHOUR INTEGER Hour of observation of report * C* IRPTDT (*) INTEGER Report date-time * C* (MM, DD, HH, MM). Year is * C* stored in dbdcod.f. * C* RIVALS(IRYDGT) REAL Report year - units digit * C* only * C* RIVALS(IRMNTH) REAL Report month - MM * C* RIVALS(IRDAYS) REAL Report day - DD * C* RIVALS(IRHOUR) REAL Report hour - HH * C* RIVALS(IRMINU) REAL Report minute - MM * C* RIVALS(IRISWS) REAL Indicator for source and * C* units of wind speed * C* (WMO Code Table 1855) * C* RIVALS(IRSELV) REAL Elevation of station in meters * C* RIVALS(IRSLAT) REAL Latitude (coarse) in degrees * C* RIVALS(IRSLON) REAL Longitude (coarse) in degrees * C* RIVALS(IRTOST) REAL Type of station indicator * C* * C* Output parameters: * C* IPT INTEGER Points to start of next group * C* in dburpt * C* IRET INTEGER Return code * C* 0 = Normal return * C* 1 = Problems * C* * C** * C* Log: * C* R. Hollern/NCEP 12/99 * C* C. Caruso Magee/NCEP 01/00 Removed setting of corrected report * C* indicator (ircorn). * C* C. Caruso Magee/NCEP 02/00 Remove reference to bpid. * C* C. Caruso Magee/NCEP 03/00 Remove 2 unneeded comments above * C* C. Caruso Magee/NCEP 03/00 Fix docblock comments above * C* J. Ator/NCEP 12/00 Check validity of iuwind * C* J. Ator/NCEP 01/02 SUWS -> ISWS * C* J. Ator/NCEP 01/06 Fix report year logic to work thru 2009 * C* C. Caruso Magee/NCEP 01/06 Save units digit of year only here. * C* Report year will be set in dbdcod.f. * C* J. Ator/NCEP 06/21 Skip reports where drifter ID = ///// * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'dbcmn.cmn' C* CHARACTER*(*) dburpt C* CHARACTER stnid*8, fld2*2, fld1*1 LOGICAL more C------------------------------------------------------------------------ iret = 0 more = .TRUE. stnid = ' ' C C* Skip over ZZYY string. C ip = 5 C C* Get drifter ID. C DO WHILE (more) C ip = ip + 1 IF ( dburpt ( ip:ip ) .ne.' ' ) THEN stnid ( 1:5 ) = dburpt ( ip:ip+4 ) ip = ip + 6 more = .false. END IF C END DO C IF ( stnid(1:5) .eq. '/////' ) THEN logmsg = 'Skipping report where drifter ID = /////' CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) iret = 1 RETURN END IF civals (icstid ) = stnid C C* Set the elevation to 0.0 meters. C rivals ( irselv ) = 0.0 C C* Get day of month of observation. C fld2 = dburpt ( ip:ip+1 ) CALL ST_INTG ( fld2, ival, ier ) IF ( ier .eq. 0 ) THEN ip = ip + 2 IF ( ival .gt. 0 .and. ival .lt. 32 ) THEN imnday = ival irptdt ( 3 ) = ival ELSE ierrno = 5 CALL DB_ERRS ( ierrno, dburpt, kret ) iret = 1 RETURN END IF ELSE iret = 1 RETURN END IF C C* Get month of observation. C fld2 = dburpt ( ip:ip+1 ) CALL ST_INTG ( fld2, ival, ier ) IF ( ier .eq. 0 ) THEN ip = ip + 2 IF ( ival .ge. 1 .and. ival .le. 12 ) THEN irptdt ( 2 ) = ival ELSE ierrno = 4 CALL DB_ERRS ( ierrno, dburpt, kret ) iret = 1 RETURN END IF ELSE iret = 1 RETURN END IF C C* Get year of observation - (units digit of year only). C fld1 = dburpt ( ip:ip ) CALL ST_INTG ( fld1, ival, ier ) IF ( ier .eq. 0 ) THEN ip = ip + 2 rivals ( irydgt ) = FLOAT ( ival ) ELSE ierrno = 3 CALL DB_ERRS ( ierrno, dburpt, kret ) iret = 1 RETURN END IF C C* Get hour of observation. C fld2 = dburpt ( ip:ip+1 ) CALL ST_INTG ( fld2, ival, ier ) IF ( ier .eq. 0 ) THEN ip = ip + 2 IF ( ival .ge. 0 .and. ival .le. 23 ) THEN ihour = ival irptdt ( 4 ) = ival ELSE ierrno = 6 CALL DB_ERRS ( ierrno, dburpt, kret ) iret = 1 RETURN END IF ELSE iret = 1 RETURN END IF C C* Get minutes of hour of observation. C fld2 = dburpt ( ip:ip+1 ) CALL ST_INTG ( fld2, ival, ier ) IF ( ier .eq. 0 ) THEN ip = ip + 2 IF ( ival .ge. 0 .and. ival .le. 59 ) THEN imins = ival irptdt ( 5 ) = ival ELSE ierrno = 7 CALL DB_ERRS ( ierrno, dburpt, kret ) iret = 1 RETURN END IF ELSE iret = 1 RETURN END IF C C* Save date/time data in interface array. Year will be stored in C* dbdcod.f. C rivals(irmnth) = float ( irptdt(2) ) rivals(irdays) = float ( irptdt(3) ) rivals(irhour) = float ( irptdt(4) ) rivals(irminu) = float ( irptdt(5) ) C C* Get indicator of units of wind speed. C fld1 = dburpt (ip:ip) CALL ST_INTG ( fld1, iuwind, ier ) IF ( ier .eq. 0 ) THEN IF ( ( iuwind .eq. 0 ) .or. ( iuwind .eq. 1 ) .or. + ( iuwind .eq. 3 ) .or. ( iuwind .eq. 4 ) ) THEN rivals ( irisws ) = FLOAT ( iuwind ) END IF END IF C C* Get quadrant of the globe. C ip = ip + 2 fld1 = dburpt ( ip:ip ) CALL ST_INTG ( fld1, ival, ier ) IF ( ier .eq. 0 ) THEN iquad = ival ELSE iret = 1 RETURN END IF C C* Get latitude. C lenm1 = 0 ip = ip + 1 IF ( dburpt ( ip+3:ip+4 ) .eq. '//' ) THEN C C* Latitude is reported in tenths of degrees. C lenm1 = 2 y = .1 ELSE IF ( dburpt ( ip+4:ip+4 ) .eq. '/' ) THEN C C* Latitude is reported in hundredths of degrees. C lenm1 = 3 y = .01 ELSE C C* Latitude is reported in thousandths of degrees. C lenm1 = 4 y = .001 END IF C CALL ST_INTG ( dburpt ( ip:ip+lenm1 ), ival, ier ) IF ( ier .eq. 0 ) THEN xlat = y * FLOAT ( ival ) ELSE iret = 1 RETURN END IF C IF ( xlat .gt. 90.0 ) THEN iret = 1 RETURN END IF C C* Get longitude. C lenm1 = 0 ip = ip + 6 C IF ( dburpt ( ip+4:ip+5 ) .eq. '//' ) THEN C C* Longitude is reported in tenths of degrees. C lenm1 = 3 y = .1 ELSE IF ( dburpt ( ip+5:ip+5 ) .eq. '/' ) THEN C C* Longitude is reported in hundredths of degrees. C lenm1 = 4 y = .01 ELSE C C* Longitude is reported in thousandths of degrees. C lenm1 = 5 y = .001 END IF C CALL ST_INTG ( dburpt ( ip:ip+lenm1 ), ival, ier ) IF ( ier .eq. 0 ) THEN xlong = y * FLOAT ( ival ) ELSE iret = 1 RETURN END IF C IF ( xlong .gt. 180.0 ) THEN iret = 1 RETURN END IF C ip = ip + 6 C C* Determine the sign of the lat/long from quadrant of globe. C IF ( iquad .eq. 7 ) THEN xlong = -xlong ELSE IF ( iquad .eq. 5 ) THEN xlat = -xlat xlong = -xlong ELSE IF ( iquad .eq. 3 ) THEN xlat = -xlat ELSE IF ( iquad .eq. 1 ) THEN ELSE iret = 1 RETURN END IF C rivals ( irslat ) = xlat rivals ( irslon ) = xlong C C* Get the quality control indicators for position and time. C IF ( dburpt (ip:ip+1) .eq. ' 6' ) THEN ip = ip + 2 CALL DB_D0QC( dburpt, ip, iret ) END IF C C* Set type of station to automatic. C rivals ( irtost ) = 0.0 C ipt = ip C* RETURN END