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