SUBROUTINE UA_STAB ( report, lenr, irptr, iret ) C************************************************************************ C* UA_STAB * C* * C* This subroutine decodes 10164 stability index data. * C* * C* UA_STAB ( REPORT, LENR, IRPTR, IRET ) * C* * C* Input parameters: * C* REPORT CHAR* 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 (IRSTB5) REAL Stability index, sfc-500mb * 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 05/96 Decode STBS5 into range [-40,40] * 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/99 Clean up function declarations * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'uacmn.cmn' C* CHARACTER*(*) report C* CHARACTER field*(MXLENF) C* LOGICAL UA_EGRP C------------------------------------------------------------------------ iret = 0 C CALL UA_GFLD ( report, lenr, irptr, field, lenf, ier ) IF ( ier .ne. 0 ) THEN iret = -1 ELSE IF ( .not. UA_EGRP ( field, lenf ) ) THEN CALL ST_INTG ( field (4:5), istab, ier ) IF ( ier .eq. 0 ) THEN IF ( ( istab .ge. 0 ) .and. ( istab .le. 40 ) ) THEN stab = FLOAT ( istab ) ELSE IF ( ( istab .ge. 51 ) .and. + ( istab .le. 90 ) ) THEN stab = ( FLOAT ( istab - 50 ) ) * (-1) ELSE stab = RMISSD END IF rivals ( irstb5 ) = stab END IF END IF C* RETURN END