SUBROUTINE READLC(LUNIT,CHR,STR)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: READLC
C PRGMMR: WOOLLEN ORG: NP20 DATE: 2003-11-04
C
C ABSTRACT: THIS SUBROUTINE RETURNS A CHARACTER DATA ELEMENT ASSOCIATED
C WITH A PARTICULAR SUBSET MNEMONIC FROM THE INTERNAL MESSAGE BUFFER
C (ARRAY MBAY IN COMMON BLOCK /BITBUF/). IT IS DESIGNED TO BE USED
C TO RETURN CHARACTER ELEMENTS GREATER THAN THE USUAL LENGTH OF EIGHT
C BYTES.
C
C PROGRAM HISTORY LOG:
C 2003-11-04 J. WOOLLEN -- ORIGINAL AUTHOR
C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED
C DOCUMENTATION; OUTPUTS MORE COMPLETE
C DIAGNOSTIC INFO WHEN ROUTINE TERMINATES
C ABNORMALLY OR UNUSUAL THINGS HAPPEN
C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM
C 20,000 TO 50,000 BYTES
C 2007-01-19 J. ATOR -- REPLACED CALL TO PARSEQ WITH CALL TO PARSTR
C 2009-03-23 J. ATOR -- ADDED CAPABILITY FOR COMPRESSED MESSAGES;
C ADDED CHECK FOR OVERFLOW OF CHR; ADDED '#'
C OPTION FOR MORE THAN ONE OCCURRENCE OF STR
C 2009-04-21 J. ATOR -- USE ERRWRT
C 2012-12-07 J. ATOR -- ALLOW STR MNEMONIC LENGTH OF UP TO 14 CHARS
C WHEN USED WITH '#' OCCURRENCE CODE
C
C USAGE: CALL READLC (LUNIT, CHR, STR)
C INPUT ARGUMENT LIST:
C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
C STR - CHARACTER*(*): STRING (I.E., MNEMONIC)
C
C OUTPUT ARGUMENT LIST:
C CHR - CHARACTER*(*): UNPACKED CHARACTER STRING (I.E.,
C CHARACTER DATA ELEMENT GREATER THAN EIGHT BYTES)
C
C REMARKS:
C THIS ROUTINE CALLS: BORT ERRWRT PARSTR PARUTG
C STATUS UPC
C THIS ROUTINE IS CALLED BY: UFBDMP UFDUMP WRTREE
C Also called by application programs.
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: PORTABLE TO ALL PLATFORMS
C
C$$$
INCLUDE 'bufrlib.prm'
COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES),
. MBAY(MXMSGLD4,NFILES)
COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
. JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
. IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
. ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
. ISEQ(MAXJL,2),JSEQ(MAXJL)
COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
COMMON /RLCCMN/ NRST,IRNCH(MXRST),IRBIT(MXRST),CRTAG(MXRST)
COMMON /USRBIT/ NBIT(MAXSS),MBIT(MAXSS)
COMMON /UNPTYP/ MSGUNP(NFILES)
COMMON /QUIET / IPRT
CHARACTER*(*) CHR,STR
CHARACTER*128 BORT_STR,ERRSTR
CHARACTER*10 TAG,CTAG,CRTAG
CHARACTER*14 TGS(10)
CHARACTER*3 TYP
REAL*8 VAL
DATA MAXTG /10/
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
CHR = ' '
C CHECK THE FILE STATUS
C ---------------------
CALL STATUS(LUNIT,LUN,IL,IM)
IF(IL.EQ.0) GOTO 900
IF(IL.GT.0) GOTO 901
IF(IM.EQ.0) GOTO 902
C CHECK FOR TAGS (MNEMONICS) IN INPUT STRING (THERE CAN ONLY BE ONE)
C ------------------------------------------------------------------
CALL PARSTR(STR,TGS,MAXTG,NTG,' ',.TRUE.)
IF(NTG.GT.1) GOTO 903
C Check if a specific occurrence of the input string was requested;
C if not, then the default is to return the first occurrence.
CALL PARUTG(LUN,0,TGS(1),NNOD,KON,ROID)
IF(KON.EQ.6) THEN
IOID=NINT(ROID)
IF(IOID.LE.0) IOID = 1
CTAG = ' '
II = 1
DO WHILE((II.LE.10).AND.(TGS(1)(II:II).NE.'#'))
CTAG(II:II)=TGS(1)(II:II)
II = II + 1
ENDDO
ELSE
IOID = 1
CTAG = TGS(1)(1:10)
ENDIF
C LOCATE AND DECODE THE LONG CHARACTER STRING
C -------------------------------------------
IF(MSGUNP(LUN).EQ.0.OR.MSGUNP(LUN).EQ.1) THEN
C The message is uncompressed
ITAGCT = 0
DO N=1,NVAL(LUN)
NOD = INV(N,LUN)
IF(CTAG.EQ.TAG(NOD)) THEN
ITAGCT = ITAGCT + 1
IF(ITAGCT.EQ.IOID) THEN
IF(ITP(NOD).NE.3) GOTO 904
NCHR = NBIT(N)/8
IF(NCHR.GT.LEN(CHR)) GOTO 905
KBIT = MBIT(N)
CALL UPC(CHR,NCHR,MBAY(1,LUN),KBIT)
GOTO 100
ENDIF
ENDIF
ENDDO
ELSEIF(MSGUNP(LUN).EQ.2) THEN
C The message is compressed
IF(NRST.GT.0) THEN
ITAGCT = 0
DO II=1,NRST
IF(CTAG.EQ.CRTAG(II)) THEN
ITAGCT = ITAGCT + 1
IF(ITAGCT.EQ.IOID) THEN
NCHR = IRNCH(II)
IF(NCHR.GT.LEN(CHR)) GOTO 905
KBIT = IRBIT(II)
CALL UPC(CHR,NCHR,MBAY(1,LUN),KBIT)
GOTO 100
ENDIF
ENDIF
ENDDO
ENDIF
ELSE
GOTO 906
ENDIF
C If we made it here, then we couldn't find the requested string.
IF(IPRT.GE.0) THEN
CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
ERRSTR = 'BUFRLIB: READLC - MNEMONIC ' // TGS(1) //
. ' NOT LOCATED IN REPORT SUBSET - RETURN WITH BLANK' //
. ' STRING FOR CHARACTER DATA ELEMENT'
CALL ERRWRT(ERRSTR)
CALL ERRWRT('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
CALL ERRWRT(' ')
ENDIF
C EXITS
C -----
100 RETURN
900 CALL BORT('BUFRLIB: READLC - INPUT BUFR FILE IS CLOSED, IT MUST'//
. ' BE OPEN FOR INPUT')
901 CALL BORT('BUFRLIB: READLC - INPUT BUFR FILE IS OPEN FOR '//
. 'OUTPUT, IT MUST BE OPEN FOR INPUT')
902 CALL BORT('BUFRLIB: READLC - A MESSAGE MUST BE OPEN IN INPUT '//
. 'BUFR FILE, NONE ARE')
903 WRITE(BORT_STR,'("BUFRLIB: READLC - THERE CANNOT BE MORE THAN '//
. 'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",'//
. 'I3,")")') STR,NTG
CALL BORT(BORT_STR)
904 WRITE(BORT_STR,'("BUFRLIB: READLC - MNEMONIC ",A," DOES NOT '//
. 'REPRESENT A CHARACTER ELEMENT (ITP=",I2,")")') TGS(1),ITP(NOD)
CALL BORT(BORT_STR)
905 WRITE(BORT_STR,'("BUFRLIB: READLC - MNEMONIC ",A," IS A '//
. 'CHARACTER STRING OF LENGTH",I4," BUT SPACE WAS PROVIDED '//
. 'FOR ONLY",I4, " CHARACTERS")') TGS(1),NCHR,LEN(CHR)
CALL BORT(BORT_STR)
906 WRITE(BORT_STR,'("BUFRLIB: READLC - MESSAGE UNPACK TYPE",I3,'//
. '" IS NOT RECOGNIZED")') MSGUNP
CALL BORT(BORT_STR)
END