SUBROUTINE DB_S4TP ( dburpt, iend, ipt, iptout, iret )
C************************************************************************
C* DB_S4TP *
C* *
C* This subroutine decodes the drifting buoy section 4 groups YYMMJ *
C* GGgg/ 7V(B)V(B)d(B)d(B). These groups give the exact time of the *
C* last known postion of the buoy, and at that position, the direction *
C* and speed of the buoy. *
C* *
C* DB_S4TP ( DBURPT, IEND, IPT, IPTOUT, IRET ) *
C* *
C* Input parameters: *
C* DBURPT CHAR* Report array *
C* IEND INTEGER end of section 4 *
C* *
C* Input parameters: *
C* IPT INTEGER On input, points to a character*
C* in group preceding the group *
C* YYMMJ. *
C* *
C* Output parameters: *
C* IPTOUT INTEGER On output, points to first of *
C* last two characters decoded. *
C* *
C* Output parameters passed via common: *
C* RIVALS(IRPSYR) REAL Year at last known position *
C* of buoy - YYYY *
C* RIVALS(IRPSMN) REAL Month at last known position *
C* of buoy - MM *
C* RIVALS(IRPSDY) REAL Day of month at last known *
C* position of buoy - DD *
C* RIVALS(IRPSHR) REAL Hour at last known position of *
C* buoy - HH *
C* RIVALS(IRPSMI) REAL Minute of hour at last known *
C* position of buoy - MI *
C* RIVALS(IRDBVV) REAL Drift speed of buoy in cm/sec *
C* RIVALS(IRDBDD) REAL Drift direction of buoy in tens*
C* of degrees *
C* *
C* Output parameters: *
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 03/2000 Fixed docblock comments. *
C* C. Caruso Magee/NCEP 07/2001 Add input/output args since s/r no *
C* longer assumes group 7 immediate *
C* follows GGgg/ group (need to search for*
C* it within section 4 now). Still check *
C* for group 7 as it will only be present *
C* when Q(L) = 1. *
C* C. Caruso Magee/NCEP 01/2006 Fix computation of year at last known *
C* position of buoy so it won't fail each *
C* decade. *
C************************************************************************
INCLUDE 'dbcmn.cmn'
C*
CHARACTER*(*) dburpt
C*
CHARACTER fld2*2, fld1*1
LOGICAL more
INTEGER iydif, iobyr
C------------------------------------------------------------------------
iret = 0
more = .TRUE.
C
ii = ipt + 4
C
DO WHILE ( more )
ipt = ipt + 1
IF ( dburpt ( ipt:ipt) .eq. ' ' ) THEN
more = .false.
ELSE IF ( ipt .ge. ii ) THEN
RETURN
END IF
END DO
C
ipt = ipt + 1
C* Get day of month of observation.
C
fld2 = dburpt ( ipt:ipt+1 )
CALL ST_INTG ( fld2, ival, ier )
IF ( ier .eq. 0 ) THEN
IF ( ival .gt. 0 .and. ival .lt. 32 ) THEN
rivals ( irpsdy ) = FLOAT ( ival )
ELSE
iret = 1
RETURN
END IF
ELSE
iret = 1
RETURN
END IF
C
C* Get month of observation.
C
ipt = ipt + 2
C
fld2 = dburpt ( ipt:ipt+1 )
CALL ST_INTG ( fld2, ival, ier )
IF ( ier .eq. 0 ) THEN
IF ( ival .ge. 1 .and. ival .le. 12 ) THEN
rivals ( irpsmn ) = FLOAT ( ival )
ELSE
iret = 1
RETURN
END IF
ELSE
iret = 1
RETURN
END IF
C
C* Get year of observation - (units digit of year only).
C
ipt = ipt + 2
fld1 = dburpt ( ipt:ipt )
CALL ST_INTG ( fld1, ival, ier )
IF ( ier .eq. 0 ) THEN
iobyr = irptdt (1)
iydif = ival - MOD ( iobyr, 10 )
IF ( iydif .gt. 1 ) THEN
itm = iobyr - 10 + iydif
ELSE IF ( iydif .eq. -9 ) THEN
itm = iobyr + 10 + iydif
ELSE
itm = iobyr + iydif
END IF
rivals ( irpsyr ) = FLOAT ( itm )
ELSE
iret = 1
RETURN
END IF
C
C* Get hour of observation.
C
ipt = ipt + 2
fld2 = dburpt ( ipt:ipt+1 )
CALL ST_INTG ( fld2, ival, ier )
IF ( ier .eq. 0 ) THEN
IF ( ival .ge. 0 .and. ival .le. 23 ) THEN
rivals ( irpshr ) = FLOAT ( ival )
ELSE
iret = 1
RETURN
END IF
ELSE
iret = 1
RETURN
END IF
C
C* Get minutes of hour of observation.
C
ipt = ipt + 2
fld2 = dburpt ( ipt:ipt+1 )
CALL ST_INTG ( fld2, ival, ier )
IF ( ier .eq. 0 ) THEN
IF ( ival .ge. 0 .and. ival .le. 59 ) THEN
rivals ( irpsmi ) = FLOAT ( ival )
ELSE
iret = 1
RETURN
END IF
ELSE
iret = 1
RETURN
END IF
C
C* Save pointer which points to last char of YYMMJ GGgg/ or last
C* char of LoLoLoLoLoLo, so that we can look for groups 3, 4, 5, and
C* 6 upon return to calling subroutine.
C
ipt = ipt + 2
iptout = ipt
C
C* Get drifting speed, in cm/sec, of buoy.
C
DO WHILE ( ipt .lt. iend )
ipt = ipt + 1
C
IF ( dburpt(ipt:ipt+1) .eq. ' 7' ) THEN
ipt = ipt + 2
fld2 = dburpt ( ipt:ipt+1 )
CALL ST_INTG ( fld2, ival, ier )
IF ( ier .eq. 0 ) THEN
rivals ( irdbvv ) = FLOAT ( ival )
ELSE
iret = 1
RETURN
END IF
C
C* Get drift direction of buoy, in tens of degrees.
C
ipt = ipt + 2
fld2 = dburpt ( ipt:ipt+1 )
CALL ST_INTG ( fld2, ival, ier )
IF ( ier .eq. 0 ) THEN
rivals ( irdbdd ) = 10.0 * FLOAT ( ival )
ELSE
iret = 1
RETURN
END IF
END IF
END DO
C
RETURN
END