SUBROUTINE EL_SUPP ( iubfma, iubfmn, iret ) C************************************************************************ C* EL_SUPP * C* * C* This subroutine reads, decodes, and stores the supplementary data * C* from a satellite wind report which uses the 310014 sequence. * C* * C* EL_SUPP ( IUBFMA, IUBFMN, IRET ) * C* * C* Input parameters: * C* IUBFMA INTEGER Logical unit number of messages * C* file for BUFR input stream * C* IUBFMN INTEGER Logical unit number of messages * C* file for BUFR output stream * C* * C* Output parameters: * C* IRET INTEGER Return code: * C* 0 = normal return * C* -1 = quality marks were not * C* processed * C** * C* Log: * C* J. Ator/NCEP 09/23 * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'elcmn.cmn' CHARACTER, PARAMETER :: qcmnem(3)*4 = + ( / 'PCCF', 'MAQC', 'NCTH' / ) C*----------------------------------------------------------------------- iret = 0 C* Pressures. CALL UFBREP ( iubfma, r8wk, MXP, MXL, nprs, 'PRLC' ) CALL UFBREP ( iubfmn, r8wk, MXP, nprs, nlv, 'PRLC' ) C* Temperatures. CALL UFBREP ( iubfma, r8wk, MXP, MXL, ntmp, 'TMDBST' ) CALL UFBREP ( iubfmn, r8wk, MXP, ntmp, nlv, 'TMDBST' ) C* Winds. CALL UFBREP ( iubfma, r8wk, MXP, MXL, nwnd, 'WDIR WSPD' ) CALL UFBREP ( iubfmn, r8wk, MXP, nwnd, nlv, 'WDIR WSPD' ) C* Height assignment methods. CALL UFBREP ( iubfma, r8wk, MXP, MXL, nhmd, 'HAMD' ) DO jj = 2, nhmd r8wk2 (1,jj-1) = r8wk (1,jj) END DO CALL UFBREP ( iubfmn, r8wk2, MXP, nhmd-1, nlv, 'HAMD' ) C* Time significances. CALL UFBREP ( iubfma, r8wk, MXP, MXL, ntsg, 'TSIG' ) DO jj = 3, ntsg r8wk2 (1,jj-2) = r8wk (1,jj) END DO CALL UFBREP ( iubfmn, r8wk2, MXP, ntsg-2, nlv, 'TSIG' ) C* Hour, minute, and second values, including those that are C* associated with the previous time significances. CALL UFBREP ( iubfma, r8wk, MXP, MXL, nhr, 'HOUR' ) r8wk2 (1,1) = r8wk (1,1) DO jj = 3, nhr r8wk2 (1,jj-1) = r8wk (1,jj) END DO CALL UFBREP ( iubfmn, r8wk2, MXP, nhr-1, nlv, 'HOUR' ) CALL UFBREP ( iubfma, r8wk, MXP, MXL, nms, 'MINU SECO' ) CALL UFBREP ( iubfmn, r8wk, MXP, nms, nlv, 'MINU SECO' ) C* Confirm some bitmap values before processing the quality marks. CALL UFBREP ( iubfma, r8wk, MXP, MXL, ndpri, 'DPRI' ) IF ( ( ndpri .ne. 103 ) .or. + ( IDNINT ( r8wk (1,16) ) .ne. 0 ) .or. + ( IDNINT ( r8wk (1,17) ) .ne. 0 ) .or. + ( IDNINT ( r8wk (1,18) ) .ne. 0 ) ) THEN logmsg = 'Unexpected bitmap values were encountered' CALL DC_WLOG ( 2, 'DC', 2, logmsg, ierwlg ) iret = -1 RETURN END IF C* Quality marks (PCCF, MAQC, and NCTH) are reported from different C* combinations of originating centers (OGCE) and generating C* applications (GNAP). Some data providers include quality marks C* from 2 different OGCE and GNAP combinations, while some report C* from 3 different combinations. For purposes of this routine, C* always store 3 different combinations in the output, and the C* last output combination will just contain "missing" values if C* there were only 2 combinations reported by the data provider. nqco = 3 C* Originating centers. CALL UFBREP ( iubfma, r8wk, MXP, MXL, nogc, 'GCLONG' ) r8wk2 (1,1) = r8wk (1,1) IF ( nogc .eq. 7 ) r8wk (1,8) = r8bfms DO jj = 1, nqco r8wk2 (1, jj+1) = r8wk (1,(3*jj)-1) r8wk2 (1, nqco +jj+1) = r8wk (1,(3*jj)-1) r8wk2 (1,(2*nqco)+jj+1) = r8wk (1,(3*jj)-1) r8wk2 (1,(3*nqco)+jj+1) = r8wk (1,(3*jj)-1) END DO CALL UFBREP ( iubfmn, r8wk2, MXP, (4*nqco)+1, nlv, 'OGCE' ) C* Generating applications. CALL UFBREP ( iubfma, r8wk, MXP, MXL, ngap, 'GNAP' ) IF ( ngap .eq. 6 ) r8wk (1,7) = r8bfms DO jj = 1, nqco r8wk2 (1, jj) = r8wk (1,(3*jj)-2) r8wk2 (1, nqco +jj) = r8wk (1,(3*jj)-2) r8wk2 (1,(2*nqco)+jj) = r8wk (1,(3*jj)-2) r8wk2 (1,(3*nqco)+jj) = r8wk (1,(3*jj)-2) END DO C* Quality marks. DO ii = 1, 3 CALL UFBREP ( iubfma, r8wk, MXP, MXL, nmq, qcmnem(ii) ) IF ( nmq .eq. 8 ) THEN DO jj = 9, 12 r8wk (1,jj) = r8bfms END DO END IF DO jj = 1, nqco r8wk2 (ii+1, jj) = r8wk (1,(4*jj)-3) r8wk2 (ii+1, nqco + jj) = r8wk (1,(4*jj)-2) r8wk2 (ii+1,(2*nqco)+ jj) = r8wk (1,(4*jj)-1) r8wk2 (ii+1,(3*nqco)+ jj) = r8wk (1,(4*jj)) END DO END DO CALL UFBREP ( iubfmn, r8wk2, MXP, (4*nqco), nlv, + 'GNAP PCCF MAQC NCTH' ) RETURN END