SUBROUTINE UA_PMLV ( report, lenr, irptr, iret ) C************************************************************************ C* UA_PMLV * C* * C* This subroutine decodes all mandatory level data of the format * C* 44NPP DDFFF DDFFF DDFFF and/or 55NPP DDFFF DDFFF DDFFF from * C* pilot AA and pilot CC reports. * C* * C* UA_PMLV ( 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* 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 03/98 Added iskpct * C* J. Ator/NCEP 10/98 REGPID -> UA_RPID, NATPID -> UA_NPID * 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* REAL prsdat ( 3 ) C* LOGICAL UA_EGRP, UA_MHID, UA_MPID, UA_RPID, UA_NPID, + ENDMLV C* C* Function to check for end of pilot mandatory level data. C* ENDMLV ( field ) = + ( ( UA_MPID ( field ) ) .or. + ( UA_MHID ( field ) ) .or. + ( UA_RPID ( field ) ) .or. + ( UA_NPID ( field ) ) ) C------------------------------------------------------------------------ C C* Initialize variables. C iret = 0 iskpct = 0 prevpr = RMXPRS C C* Loop through the mandatory level data. C DO WHILE ( .true. ) C C* Get the next group in the report. C ipt1 = irptr CALL UA_GFLD ( report, lenr, irptr, field, lenf, ier ) IF ( ier .ne. 0 ) THEN iret = -1 RETURN ELSE IF ( ENDMLV ( field ) ) THEN irptr = ipt1 RETURN ELSE IF ( .not. UA_EGRP ( field, lenf ) ) THEN C C* This group should be a pilot mandatory level pressure C* group. Attempt to decode it as such. C CALL UA_PMPR ( field, prsdat, nprs, ierprs ) IF ( ( ierprs .eq. 0 ) .and. ( nprs .gt. 0 ) ) THEN C C* Get and decode the wind group corresponding to C* each decoded pressure. C DO ii = 1, nprs drct = RMISSD sped = RMISSD ipt1 = irptr CALL UA_GFLD ( report, lenr, irptr, field, + lenf, ier ) IF ( ier .ne. 0 ) THEN iret = -1 RETURN ELSE IF ( ENDMLV ( field ) ) THEN irptr = ipt1 RETURN ELSE IF ( .not. UA_EGRP ( field, lenf ) ) THEN CALL UA_WIND ( field, drct, sped, ier ) END IF C C* The pressure is available for this mandatory C* level. Check if it is less than the pressure C* at the previous valid mandatory level, and, if C* so, then store all values for this mandatory C* level into the interface arrays. C IF ( prsdat ( ii ) .lt. prevpr ) THEN vsig = 32.0 pres = prsdat ( ii ) CALL UA_STLV ( vsig, pres, RMISSD, RMISSD, + RMISSD, drct, sped, RMISSD, RMISSD, + ierstv ) IF ( ierstv .lt. 0 ) THEN iret = -1 RETURN END IF prevpr = pres END IF END DO ELSE logmsg = 'pilot manlev pressure group ' // + field (1:lenf) CALL DC_WLOG ( 2, 'UA', 2, logmsg, ierwlg ) CALL UA_RDCS ( 113, ierrdc ) C iskpct = iskpct + 1 C C* How many groups have we skipped over so far?? C IF ( iskpct .gt. MXSKIP ) THEN WRITE ( UNIT = logmsg, FMT = '( A, I3, A )' ) + 'skipped ', iskpct, ' groups during recovery' CALL DC_WLOG ( 2, 'UA', -1, logmsg, ierwlg ) CALL UA_RDCS ( 116, ierrdc ) iret = -1 RETURN END IF END IF END IF END DO C* RETURN END