SUBROUTINE CX_GTV1( ist, odescr, cxrpt, chkdge, ckdigt, nsdcr, + sortdesc, mxrpt, mxdatv, nmrpts, + ic01flg, jdatwth, ic02flg, jscale, + expdesc, nn, dataval, iret ) C************************************************************************ C* CX_GTV1 * C* * C* This subroutine decodes the next group in Section 2 of the current * C* subset. The decoded value will be saved in the dataval array either * C* as a character string or a real*8 value, depending on the units * C* gotten from Table B for the element descriptor corresponding to the * C* data value. A missing value will be set to eight slashes. * C* * C* CX_GVT1 ( IST, ODESCR, CXRPT, CHKDGE, CKDIGT, NSDCR, SORTDESC, MXRPT,* C* MXDATV, NMRPTS, IC01FLG, JDATWTH, IC02FLG, JSCALE, EXPDESC,* C* NN, DATAVAL, IRET ) * C* * C* Input parameters: * C* IST INTEGER Pointer to location in cxrpt of * C* where to get the next data item * C* ODESCR CHAR* Current descriptor in expdesc * C* which corresponds to the data * C* item in Section 2 being decoded * C* CXRPT CHAR* Current CREX report * C* CHKDGE INTEGER Check digit indicator * C* NSDCR INTEGER Number of sorted descriptors in * C* array sortdesc * C* SORTDESC CHAR* List of unique descriptors in * C* expdesc sorted in ascending * C* order * C* MXRPT INTEGER Maximum number of reports * C* expected in message * C* MXDATV INTEGER Maximum number of data values * C* expected in a report * C* NMRPTS INTEGER Array index referring to the * C* current report in dataval. Will * C* also be used to get the total * C* number of reports in CREX msg. * C* IC01FLG INTEGER Operator data width replacement * C* flag * C* JDATWTH INTEGER Data width replacement value * C* IC02FLG INTEGER Operator scale factor * C* replacement flag * C* JSCALE INTEGER Scale factor replacement value * C* EXPDESC (MXDATV) * C* CHAR* List of the expanded Section 1 * C* descriptors. The expansion * C* consists of replacing the * C* sequence and non-delayed * C* replication descriptors with the* C* list they correspond to. The * C* final list will be close to a * C* one-to-one correspondence with * C* the data values in Section 2. * C* * C* NCHRS (100) INTEGER Descriptor data width * C* MUNITS (100) CHAR* Descriptor units * C* MSC (100) INTEGER Descriptor scaling value * C* * C* Input and Output parameters: * C* NN INTEGER Pointer to where to store * C* current data item in dataval * C* CKDIGT INTEGER Flag set to -1 when ist points * C* to the first check digit in * C* report; otherwise, set to 0. * C* * C* Output parameters: * C* * C* DATAVAL (MXRPT,MXDATV) * C* REAL Array to hold the Section 2 * C* decoded data values * C* * C* IRET INTEGER Return code * C* 0 = normal return * C* 1 = fatal error* C* * C** * C* Log: * C* R. Hollern/NCEP 8/03 * C* M. Weiss/NCEP IMSG 3/20 B22038 only. When necesssary, * C* increase the byte width count * C* to capture values greater than * C* 5 characters in length * C************************************************************************ INCLUDE 'GEMPRM.PRM' INCLUDE 'cxcmn.cmn' C* REAL*8 dataval ( mxrpt, mxdatv ) REAL*8 rtemp C* INTEGER mxdatv, chkdge, ckdigt INTEGER nwords, irem, nl C* CHARACTER*(*) cxrpt CHARACTER odescr*6 CHARACTER sortdesc ( mxdatv )*6 CHARACTER expdesc ( mxdatv )*6 CHARACTER ctemp*8, blanks*8, cval*8 CHARACTER field*10, misng*10 C* LOGICAL bbb, blank_flag C* EQUIVALENCE ( ctemp, rtemp ) C* DATA blanks / ' ' / C* DATA misng / '//////////' / C----------------------------------------------------------------------- iret = 0 C C* Locate descriptor in sortdesc C CALL DC_BSRC ( odescr, sortdesc, nsdcr, ilc, kret ) C IF ( ilc .le. 0 ) THEN C C* Element descriptor not found in table. C iret = 1 loglvl = 2 logmsg = ' ' logmsg(1:19) = 'Element descriptor ' logmsg(20:25) = odescr logmsg(26:53) = ' not found in CREX Table B ' CALL DC_WLOG( loglvl, 'CX', 2, logmsg, ierwlg ) logmsg = ' ' logmsg(1:12) = 'FATAL ERROR ' CALL DC_WLOG( loglvl, 'CX', 2, logmsg, ierwlg ) RETURN END IF C C* Skip leading blank(s) before start of next group. C bbb = .true. C DO WHILE ( bbb ) IF ( cxrpt(ist:ist) .eq. ' ' ) THEN ist = ist + 1 ELSE bbb = .false. END IF END DO C C* Character width of string. C IF ( ic01flg .eq. 1 ) THEN mchr = jdatwth ic01flg = 0 jdatwth = 0 ELSE mchr = nchrs(ilc) END IF C IF ( chkdge .eq. 1 ) THEN C C* Get check digit preceding data value. C CALL CX_CDGE ( ist, cxrpt, ckdigt, iret ) IF ( iret .ne. 0 ) RETURN END IF C IF ( cxrpt ( ist:ist) .eq. '-' ) THEN C C* CREX Table B does not count the '-' as part of the C* width of the group. C mchr = mchr + 1 C END IF C C* Section 2 data value. C cval = blanks C IF ( munits(ilc)(1:9) .eq. 'CHARACTER' ) THEN C nwords = mchr / 8 C irem = MOD ( mchr, 8 ) C IF ( irem .ne. 0 ) nwords = nwords + 1 C n1 = ist C DO j = 1, nwords C nn = nn + 1 ! next data-value: ex. dataval(18,13)->(18,14) ! in the report C IF ( j .lt. nwords ) THEN ctemp ( 1:8 ) = cxrpt ( n1:n1+7 ) dataval ( nmrpts, nn ) = rtemp n1 = n1 + 8 C ELSE C ctemp = blanks ctemp ( 1:irem ) = cxrpt ( n1:ist+mchr-1 ) dataval ( nmrpts, nn ) = rtemp C END IF C END DO C ELSE C C* Decode integer data and convert to real. C nn = nn + 1 ! next data-value: ex. dataval(18,13)->(18,14) ! in the report C C* For B22038 only, test for values > 5 characters in length. C* In a CREX report, the space following a 5th character, C* should either be a trailing blank, a report terminator '+', C* or the 1st '+' of a message terminator '++'. C* C* If neither are encountered then increase mchr to capture C* larger values ex. 101342. C blank_flag = .true. field(1:10) = ' ' IF ( odescr .eq. 'B22038' ) THEN DO WHILE ( blank_flag ) IF (( cxrpt(ist+mchr:ist+mchr) .eq. ' ' ) .or. 1 ( cxrpt(ist+mchr:ist+mchr) .eq. '+' )) THEN field(1:mchr) = cxrpt(ist:ist+mchr-1) blank_flag = .false. ELSE mchr = mchr + 1 END IF END DO ELSE field(1:mchr) = cxrpt(ist:ist+mchr-1) END IF C CALL ST_INTG ( field(1:mchr), ival, ier ) C IF ( ival .eq. IMISSD ) THEN ctemp = misng(1:8) dataval ( nmrpts, nn ) = rtemp C ELSE C C* Get scaling factor. C IF ( ic02flg .eq. 1 ) THEN ksc = jscale ic02flg = 0 ELSE ksc = msc ( ilc ) END IF C ysc = 10.**ksc C dataval ( nmrpts, nn ) = FLOAT ( ival ) / ysc c END IF C END IF C ist = ist + mchr - 1 C* RETURN END