SUBROUTINE UA_CLDD ( report, lenr, irptr, iret ) C************************************************************************ C* UA_CLDD * C* * C* This subroutine decodes cloud data from temp BB reports. * C* * C* UA_CLDD ( REPORT, LENR, IRPTR, IRET ) * C* * C* Input parameters: * C* REPORT CHAR* Temp BB 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 (IRCLAM) REAL Cloud amount * C* RIVALS (IRHBLC) REAL Height above surface of the * C* base of the lowest cloud seen * C* RIVALS (IRNCLT) REAL Number of cloud types * C* RIVALS (IRCLTP) REAL Cloud type * 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 Change /INTF mnemonics for cloud data, * C* clean up function declarations * C* J. Ator/NCEP 01/02 HOCB -> HBLCS * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'uacmn.cmn' C* CHARACTER*(*) report C* CHARACTER field*(MXLENF) C* LOGICAL UA_EGRP, UA_CDID, UA_RPID, UA_NPID, + ENDCLD, gotcld C* REAL clddat ( 5 ) C* INCLUDE 'ERMISS.FNC' C* C* Function to check for end of cloud data section. C* ENDCLD ( field ) = + ( ( UA_RPID ( field ) ) .or. + ( UA_NPID ( field ) ) ) C------------------------------------------------------------------------ iret = 0 C C* Look for a cloud data indicator. C gotcld = .false. DO WHILE ( .not. gotcld ) ipt1 = irptr CALL UA_GFLD ( report, lenr, irptr, field, lenf, ier ) IF ( ier .ne. 0 ) THEN iret = -1 RETURN ELSE IF ( ENDCLD ( field ) ) THEN irptr = ipt1 RETURN ELSE IF ( .not. UA_EGRP ( field, lenf ) ) THEN IF ( UA_CDID ( field ) ) THEN gotcld = .true. END IF END IF END DO C C* Initialize all cloud data values to missing. C DO ii = 1, 5 clddat ( ii ) = RMISSD END DO C C* Get, decode, and store the cloud data. 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 DO ii = 1, 5 CALL ST_INTG ( field (ii:ii), iintg, ier ) IF ( ier .eq. 0 ) THEN clddat ( ii ) = FLOAT ( iintg ) END IF END DO C nclt = 0 C C* The amount of sky coverage is stored in the interface C* format as a code figure from WMO BUFR Table 0 20 011. C rivals ( irclam ) = clddat (1) C C* The low-level cloud genera is stored in the interface C* format as a code figure from WMO BUFR Table 0 20 012. C IF ( .not. ERMISS ( clddat (2) ) ) THEN nclt = nclt + 1 rivals ( ircltp ( nclt ) ) = clddat (2) + 30. ELSE IF ( field (2:2) .eq. '/' ) THEN nclt = nclt + 1 rivals ( ircltp ( nclt ) ) = 62. END IF C C* The "height above the surface of the base of the lowest C* cloud seen" is stored in the interface format as a code C* figure from WMO BUFR Table 0 20 201. C IF ( .not. ERMISS ( clddat (3) ) ) THEN rivals ( irhblc ) = clddat (3) ELSE IF ( field (3:3) .eq. '/' ) THEN rivals ( irhblc ) = 14. END IF C C* The mid-level cloud genera is stored in the interface C* format as a code figure from WMO BUFR Table 0 20 012. C IF ( .not. ERMISS ( clddat (4) ) ) THEN nclt = nclt + 1 rivals ( ircltp ( nclt ) ) = clddat (4) + 20. ELSE IF ( field (4:4) .eq. '/' ) THEN nclt = nclt + 1 rivals ( ircltp ( nclt ) ) = 61. END IF C C* The high-level cloud genera is stored in the interface C* format as a code figure from WMO BUFR Table 0 20 012. C IF ( .not. ERMISS ( clddat (5) ) ) THEN nclt = nclt + 1 rivals ( ircltp ( nclt ) ) = clddat (5) + 10. ELSE IF ( field (5:5) .eq. '/' ) THEN nclt = nclt + 1 rivals ( ircltp ( nclt ) ) = 60. END IF C rivals ( irnclt ) = FLOAT ( nclt ) C END IF C* RETURN END