SUBROUTINE UA_SNDG ( report, lenr, irptr, iret ) C************************************************************************ C* UA_SNDG * C* * C* This subroutine decodes sounding system and sea surface temperature * C* data from temp reports. * C* * C* UA_SNDG ( REPORT, LENR, IRPTR, IRET ) * C* * C* Input parameters: * C* REPORT CHAR* Temp report * C* LENR INTEGER Length of REPORT * C* * C* Input and output parameters: * C* IRPTR INTEGER Pointer within REPORT * C* * C* Output parameters: * C* RIVALS (IRSIRC) REAL Radiation correction * C* RIVALS (IRITPR) REAL Instrument type * C* RIVALS (IRTTSS) REAL Tracking technique * C* RIVALS (IRLNHR) REAL Launch hour * C* RIVALS (IRLNMN) REAL Launch minute * C* RIVALS (IRSSTC) REAL Sea surface temp. in Celsius * C* IRET INTEGER Return code: * C* 0 = normal return * C* -1 = critical error in REPORT * C* or reached end of REPORT * C** * C* Log: * C* J. Ator/NCEP 03/96 * C* J. Ator/NCEP 10/96 ERRGRP -> UA_EGRP, removed ERRRPT * C* J. Ator/NCEP 12/97 New interface format, style changes * C* J. Ator/NCEP 10/98 REGPID -> UA_RPID, NATPID -> UA_NPID * C* J. Ator/NCEP 10/99 Clean up function declarations * C* J. Ator/NCEP 03/00 Allow UA_CDID exit iff BB * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'uacmn.cmn' C* CHARACTER*(*) report C* CHARACTER field*(MXLENF) C* LOGICAL UA_EGRP, UA_SDID, UA_CDID, UA_RPID, UA_NPID, + ENDSDG, gotsdg C* C* Function to check for end of sounding system and sea surface C* temperature section. C* ENDSDG ( field ) = + ( ( ( prttyp .eq. BB ) .and. + ( UA_CDID ( field ) ) ) + .or. + ( UA_RPID ( field ) ) + .or. + ( UA_NPID ( field ) ) ) C------------------------------------------------------------------------ iret = 0 C C* Search for a sounding system and sea surface temperature C* data indicator. C gotsdg = .false. DO WHILE ( .not. gotsdg ) ipt1 = irptr CALL UA_GFLD ( report, lenr, irptr, field, lenf, ier ) IF ( ier .ne. 0 ) THEN iret = -1 RETURN ELSE IF ( ENDSDG ( field ) ) THEN irptr = ipt1 RETURN ELSE IF ( .not. UA_EGRP ( field, lenf ) ) THEN IF ( UA_SDID ( field ) ) THEN gotsdg = .true. END IF END IF END DO C C* Get the first group for this section. C CALL UA_GFLD ( report, lenr, irptr, field, lenf, ier ) IF ( ier .ne. 0 ) THEN iret = -1 RETURN ELSE IF ( .not. UA_EGRP ( field, lenf ) ) THEN C C* Decode and store the radiation correction. C* This value is stored in the interface format C* as a code figure from WMO Code Table 3849. C CALL ST_INTG ( field (1:1), isr, ier ) IF ( ier .eq. 0 ) THEN rivals ( irsirc ) = FLOAT ( isr ) END IF C C* Decode and store the report instrument type. C* This value is stored in the interface format C* as a code figure from WMO Code Table 3685. C CALL ST_INTG ( field (2:3), irara, ier ) IF ( ier .eq. 0 ) THEN rivals ( iritpr ) = FLOAT ( irara ) END IF C C* Decode and store the tracking technique. C* This value is stored in the interface format C* as a code figure from WMO Code Table 3872. C CALL ST_INTG ( field (4:5), isasa, ier ) IF ( ier .eq. 0 ) THEN rivals ( irttss ) = FLOAT ( isasa ) END IF END IF C C* Get the second group for this section. C CALL UA_GFLD ( report, lenr, irptr, field, lenf, ier ) IF ( ier .ne. 0 ) THEN iret = -1 RETURN ELSE IF ( .not. UA_EGRP ( field, lenf ) ) THEN IF ( field (1:1) .eq. '8' ) THEN C C* Decode and store the launch hour and launch minute. C CALL ST_INTG ( field (2:3), ilnhr, ier ) IF ( ier .eq. 0 ) THEN IF ( ilnhr .lt. 24 ) THEN rivals ( irlnhr ) = FLOAT ( ilnhr ) END IF END IF CALL ST_INTG ( field (4:5), ilnmn, ier ) IF ( ier .eq. 0 ) THEN IF ( ilnmn .lt. 60 ) THEN rivals ( irlnmn ) = FLOAT ( ilnmn ) END IF END IF END IF END IF C C* Is there a sea surface temperature group for this section ?? C IF ( stntyp .eq. SHIP ) THEN ipt1 = irptr CALL UA_GFLD ( report, lenr, irptr, field, lenf, ier ) IF ( ier .ne. 0 ) THEN iret = -1 RETURN ELSE IF ( ENDSDG ( field ) ) THEN irptr = ipt1 RETURN ELSE IF ( .not. UA_EGRP ( field, lenf ) ) THEN IF ( field (1:1) .eq. '9' ) THEN C C* Decode and store the sea surface temperature. C CALL ST_INTG ( field (3:5), isst, ier ) IF ( ier .eq. 0 ) THEN IF ( field (2:2) .eq. '0' ) THEN sstc = FLOAT ( isst ) / 10.0 ELSE IF ( field (2:2) .eq. '1' ) THEN sstc = FLOAT ( isst ) / ( -10.0 ) ELSE sstc = RMISSD END IF rivals ( irsstc ) = sstc END IF END IF END IF END IF C* RETURN END