NCEPLIBS-bufr  11.5.0
 All Data Structures Files Functions Variables Pages
readlc.f
Go to the documentation of this file.
1 C> @file
2 C> @brief Read a long character string (greater than 8 bytes) from
3 C> a data subset.
4 
5 C> This subroutine reads a long character string (greater than 8 bytes)
6 C> from a data subset.
7 C>
8 C> <p>The data subset should have already been read into internal arrays
9 C> via a previous call to one of the
10 C> [subset-reading subroutines](@ref hierarchy).
11 C>
12 C> @authors J. Woollen
13 C> @authors J. Ator
14 C> @date 2003-11-04
15 C>
16 C> @param[in] LUNIT - integer: Fortran logical unit number for BUFR file
17 C> @param[out] CHR - character*(*): Value corresponding to STR
18 C> @param[in] STR - character*(*): Table B mnemonic of long character
19 C> string to be retrieved, possibly supplemented
20 C> with an ordinal occurrence notation
21 C>
22 C> <p>If there is more than one occurrence of STR within the data subset
23 C> definition, then each occurrence can be retrieved via a separate call
24 C> to this subroutine, and by appending the ordinal number of the
25 C> occurrence to STR in each case. For example, if there are 5
26 C> occurrences of mnemonic LSTID within a given data subset definition,
27 C> then 5 separate calls should be made to this subroutine, once each
28 C> with STR set to 'LSTID#1', 'LSTID#2', 'LSTID#3', 'LSTID#4' and
29 C> 'LSTID#5'. However, the first notation is superfluous, because
30 C> omitting the ordinal number always defaults to the first occurrence
31 C> of a particular string, so a user could just specify 'LSTID'
32 C> instead of 'LSTID#1'.
33 C>
34 C> @remarks
35 C> - Character strings which are 8 bytes or less in length can be read
36 C> using the real*8 USR array within a call to one of the BUFRLIB
37 C> [values-reading subroutines](@ref hierarchy) and then converting the
38 C> corresponding real*8 value to character format within the
39 C> application program.
40 C> - If STR is not found within the data subset definition, then CHR is
41 C> returned with all bits set to 1, which is the standard WMO BUFR value
42 C> for "missing" data. Any CHR value returned by this subroutine can be
43 C> checked for equivalence to this "missing" value via a call to
44 C> function icbfms().
45 C>
46 C> <b>Program history log:</b>
47 C> - 2003-11-04 J. Woollen -- Original author
48 C> - 2004-08-09 J. Ator -- Maximum message length increased from
49 C> 20,000 to 50,000 bytes
50 C> - 2007-01-19 J. Ator -- Replaced call to parseq with call to
51 C> parstr()
52 C> - 2009-03-23 J. Ator -- Added capability for compressed messages;
53 C> added check for overflow of chr; added '#'
54 C> option for more than one occurrence of STR
55 C> - 2009-04-21 J. Ator -- Use errwrt()
56 C> - 2012-12-07 J. Ator -- Allow str mnemonic length of up to 14 chars
57 C> when used with '#' occurrence code
58 C> - 2014-12-10 J. Ator -- Use modules instead of COMMON blocks
59 C> - 2020-09-09 J. Ator -- Set CHR to "missing" instead of all blanks
60 C> if STR isn't found in subset
61 C>
62  SUBROUTINE readlc(LUNIT,CHR,STR)
63 
64  USE moda_usrint
65  USE moda_usrbit
66  USE moda_unptyp
67  USE moda_bitbuf
68  USE moda_tables
69  USE moda_rlccmn
70 
71  COMMON /quiet / iprt
72 
73  CHARACTER*(*) chr,str
74  CHARACTER*128 bort_str,errstr
75  CHARACTER*10 ctag
76  CHARACTER*14 tgs(10)
77 
78  DATA maxtg /10/
79 
80 C-----------------------------------------------------------------------
81 C-----------------------------------------------------------------------
82 
83  chr = ' '
84  lchr=len(chr)
85 
86 C CHECK THE FILE STATUS
87 C ---------------------
88 
89  CALL status(lunit,lun,il,im)
90  IF(il.EQ.0) goto 900
91  IF(il.GT.0) goto 901
92  IF(im.EQ.0) goto 902
93 
94 C CHECK FOR TAGS (MNEMONICS) IN INPUT STRING (THERE CAN ONLY BE ONE)
95 C ------------------------------------------------------------------
96 
97  CALL parstr(str,tgs,maxtg,ntg,' ',.true.)
98  IF(ntg.GT.1) goto 903
99 
100 C Check if a specific occurrence of the input string was requested;
101 C if not, then the default is to return the first occurrence.
102 
103  CALL parutg(lun,0,tgs(1),nnod,kon,roid)
104  IF(kon.EQ.6) THEN
105  ioid=nint(roid)
106  IF(ioid.LE.0) ioid = 1
107  ctag = ' '
108  ii = 1
109  DO WHILE((ii.LE.10).AND.(tgs(1)(ii:ii).NE.'#'))
110  ctag(ii:ii)=tgs(1)(ii:ii)
111  ii = ii + 1
112  ENDDO
113  ELSE
114  ioid = 1
115  ctag = tgs(1)(1:10)
116  ENDIF
117 
118 C LOCATE AND DECODE THE LONG CHARACTER STRING
119 C -------------------------------------------
120 
121  IF(msgunp(lun).EQ.0.OR.msgunp(lun).EQ.1) THEN
122 
123 C The message is uncompressed
124 
125  itagct = 0
126  DO n=1,nval(lun)
127  nod = inv(n,lun)
128  IF(ctag.EQ.tag(nod)) THEN
129  itagct = itagct + 1
130  IF(itagct.EQ.ioid) THEN
131  IF(itp(nod).NE.3) goto 904
132  nchr = nbit(n)/8
133  IF(nchr.GT.lchr) goto 905
134  kbit = mbit(n)
135  CALL upc(chr,nchr,mbay(1,lun),kbit,.true.)
136  goto 100
137  ENDIF
138  ENDIF
139  ENDDO
140  ELSEIF(msgunp(lun).EQ.2) THEN
141 
142 C The message is compressed
143 
144  IF(nrst.GT.0) THEN
145  itagct = 0
146  DO ii=1,nrst
147  IF(ctag.EQ.crtag(ii)) THEN
148  itagct = itagct + 1
149  IF(itagct.EQ.ioid) THEN
150  nchr = irnch(ii)
151  IF(nchr.GT.lchr) goto 905
152  kbit = irbit(ii)
153  CALL upc(chr,nchr,mbay(1,lun),kbit,.true.)
154  goto 100
155  ENDIF
156  ENDIF
157  ENDDO
158  ENDIF
159  ELSE
160  goto 906
161  ENDIF
162 
163 C If we made it here, then we couldn't find the requested string.
164 
165  IF(iprt.GE.0) THEN
166  CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
167  errstr = 'BUFRLIB: READLC - MNEMONIC ' // tgs(1) //
168  . ' NOT LOCATED IN REPORT SUBSET - RETURN WITH MISSING' //
169  . ' STRING FOR CHARACTER DATA ELEMENT'
170  CALL errwrt(errstr)
171  CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
172  CALL errwrt(' ')
173  ENDIF
174  DO ii=1,lchr
175  CALL ipkm(chr(ii:ii),1,255)
176  ENDDO
177 
178 C EXITS
179 C -----
180 
181 100 RETURN
182 900 CALL bort('BUFRLIB: READLC - INPUT BUFR FILE IS CLOSED, IT MUST'//
183  . ' BE OPEN FOR INPUT')
184 901 CALL bort('BUFRLIB: READLC - INPUT BUFR FILE IS OPEN FOR '//
185  . 'OUTPUT, IT MUST BE OPEN FOR INPUT')
186 902 CALL bort('BUFRLIB: READLC - A MESSAGE MUST BE OPEN IN INPUT '//
187  . 'BUFR FILE, NONE ARE')
188 903 WRITE(bort_str,'("BUFRLIB: READLC - THERE CANNOT BE MORE THAN '//
189  . 'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",'//
190  . 'I3,")")') str,ntg
191  CALL bort(bort_str)
192 904 WRITE(bort_str,'("BUFRLIB: READLC - MNEMONIC ",A," DOES NOT '//
193  . 'REPRESENT A CHARACTER ELEMENT (ITP=",I2,")")') tgs(1),itp(nod)
194  CALL bort(bort_str)
195 905 WRITE(bort_str,'("BUFRLIB: READLC - MNEMONIC ",A," IS A '//
196  . 'CHARACTER STRING OF LENGTH",I4," BUT SPACE WAS PROVIDED '//
197  . 'FOR ONLY",I4, " CHARACTERS")') tgs(1),nchr,lchr
198  CALL bort(bort_str)
199 906 WRITE(bort_str,'("BUFRLIB: READLC - MESSAGE UNPACK TYPE",I3,'//
200  . '" IS NOT RECOGNIZED")') msgunp
201  CALL bort(bort_str)
202  END
subroutine parstr(STR, TAGS, MTAG, NTAG, SEP, LIMIT80)
THIS SUBROUTINE PARSES A STRING CONTAINING ONE OR MORE SUBSTRINGS INTO AN ARRAY OF SUBSTRINGS...
Definition: parstr.f:37
subroutine upc(CHR, NCHR, IBAY, IBIT, CNVNULL)
THIS SUBROUTINE UNPACKS AND RETURNS A CHARACTER STRING OF LENGTH NCHR CONTAINED WITHIN NCHR BYTES OF ...
Definition: upc.f:49
This module contains array and variable declarations used to store the internal jump/link table...
Definition: moda_tables.F:13
subroutine status(LUNIT, LUN, IL, IM)
This subroutine checks whether a specified Fortran logical unit number is currently connected to the ...
Definition: status.f:61
subroutine ipkm(CBAY, NBYT, N)
This subroutine encodes an integer value within a specified number of bytes of a character string...
Definition: ipkm.f:29
subroutine parutg(LUN, IO, UTG, NOD, KON, VAL)
THIS SUBROUTINE PARSES A USER-SPECIFIED TAG (MNEMONIC) (UTG) THAT REPRESENTS A VALUE EITHER BEING DEC...
Definition: parutg.f:120
subroutine errwrt(STR)
This subroutine allows the user to specify a custom location for the logging of error and diagnostic ...
Definition: errwrt.f:39
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:23
This module contains array and variable declarations used to store BUFR messages internally for multi...
Definition: moda_bitbuf.F:10
subroutine readlc(LUNIT, CHR, STR)
This subroutine reads a long character string (greater than 8 bytes) from a data subset.
Definition: readlc.f:62