NCEPLIBS-bufr  11.7.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> | Date | Programmer | Comments |
48 C> | -----|------------|----------|
49 C> | 2003-11-04 | J. Woollen | Original author |
50 C> | 2004-08-09 | J. Ator | Maximum message length increased from 20,000 to 50,000 bytes |
51 C> | 2007-01-19 | J. Ator | Replaced call to parseq with call to parstr() |
52 C> | 2009-03-23 | J. Ator | Added capability for compressed messages; added check for overflow of chr; added '#' option for more than one occurrence of STR |
53 C> | 2009-04-21 | J. Ator | Use errwrt() |
54 C> | 2012-12-07 | J. Ator | Allow str mnemonic length of up to 14 chars when used with '#' occurrence code |
55 C> | 2014-12-10 | J. Ator | Use modules instead of COMMON blocks |
56 C> | 2020-09-09 | J. Ator | Set CHR to "missing" instead of all blanks if STR isn't found in subset |
57 C>
58  SUBROUTINE readlc(LUNIT,CHR,STR)
59 
60  USE moda_usrint
61  USE moda_usrbit
62  USE moda_unptyp
63  USE moda_bitbuf
64  USE moda_tables
65  USE moda_rlccmn
66 
67  COMMON /quiet / iprt
68 
69  CHARACTER*(*) chr,str
70  CHARACTER*128 bort_str,errstr
71  CHARACTER*10 ctag
72  CHARACTER*14 tgs(10)
73 
74  DATA maxtg /10/
75 
76 C-----------------------------------------------------------------------
77 C-----------------------------------------------------------------------
78 
79  chr = ' '
80  lchr=len(chr)
81 
82 C CHECK THE FILE STATUS
83 C ---------------------
84 
85  CALL status(lunit,lun,il,im)
86  IF(il.EQ.0) goto 900
87  IF(il.GT.0) goto 901
88  IF(im.EQ.0) goto 902
89 
90 C CHECK FOR TAGS (MNEMONICS) IN INPUT STRING (THERE CAN ONLY BE ONE)
91 C ------------------------------------------------------------------
92 
93  CALL parstr(str,tgs,maxtg,ntg,' ',.true.)
94  IF(ntg.GT.1) goto 903
95 
96 C Check if a specific occurrence of the input string was requested;
97 C if not, then the default is to return the first occurrence.
98 
99  CALL parutg(lun,0,tgs(1),nnod,kon,roid)
100  IF(kon.EQ.6) THEN
101  ioid=nint(roid)
102  IF(ioid.LE.0) ioid = 1
103  ctag = ' '
104  ii = 1
105  DO WHILE((ii.LE.10).AND.(tgs(1)(ii:ii).NE.'#'))
106  ctag(ii:ii)=tgs(1)(ii:ii)
107  ii = ii + 1
108  ENDDO
109  ELSE
110  ioid = 1
111  ctag = tgs(1)(1:10)
112  ENDIF
113 
114 C LOCATE AND DECODE THE LONG CHARACTER STRING
115 C -------------------------------------------
116 
117  IF(msgunp(lun).EQ.0.OR.msgunp(lun).EQ.1) THEN
118 
119 C The message is uncompressed
120 
121  itagct = 0
122  DO n=1,nval(lun)
123  nod = inv(n,lun)
124  IF(ctag.EQ.tag(nod)) THEN
125  itagct = itagct + 1
126  IF(itagct.EQ.ioid) THEN
127  IF(itp(nod).NE.3) goto 904
128  nchr = nbit(n)/8
129  IF(nchr.GT.lchr) goto 905
130  kbit = mbit(n)
131  CALL upc(chr,nchr,mbay(1,lun),kbit,.true.)
132  goto 100
133  ENDIF
134  ENDIF
135  ENDDO
136  ELSEIF(msgunp(lun).EQ.2) THEN
137 
138 C The message is compressed
139 
140  IF(nrst.GT.0) THEN
141  itagct = 0
142  DO ii=1,nrst
143  IF(ctag.EQ.crtag(ii)) THEN
144  itagct = itagct + 1
145  IF(itagct.EQ.ioid) THEN
146  nchr = irnch(ii)
147  IF(nchr.GT.lchr) goto 905
148  kbit = irbit(ii)
149  CALL upc(chr,nchr,mbay(1,lun),kbit,.true.)
150  goto 100
151  ENDIF
152  ENDIF
153  ENDDO
154  ENDIF
155  ELSE
156  goto 906
157  ENDIF
158 
159 C If we made it here, then we couldn't find the requested string.
160 
161  IF(iprt.GE.0) THEN
162  CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
163  errstr = 'BUFRLIB: READLC - MNEMONIC ' // tgs(1) //
164  . ' NOT LOCATED IN REPORT SUBSET - RETURN WITH MISSING' //
165  . ' STRING FOR CHARACTER DATA ELEMENT'
166  CALL errwrt(errstr)
167  CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
168  CALL errwrt(' ')
169  ENDIF
170  DO ii=1,lchr
171  CALL ipkm(chr(ii:ii),1,255)
172  ENDDO
173 
174 C EXITS
175 C -----
176 
177 100 RETURN
178 900 CALL bort('BUFRLIB: READLC - INPUT BUFR FILE IS CLOSED, IT MUST'//
179  . ' BE OPEN FOR INPUT')
180 901 CALL bort('BUFRLIB: READLC - INPUT BUFR FILE IS OPEN FOR '//
181  . 'OUTPUT, IT MUST BE OPEN FOR INPUT')
182 902 CALL bort('BUFRLIB: READLC - A MESSAGE MUST BE OPEN IN INPUT '//
183  . 'BUFR FILE, NONE ARE')
184 903 WRITE(bort_str,'("BUFRLIB: READLC - THERE CANNOT BE MORE THAN '//
185  . 'ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE ",'//
186  . 'I3,")")') str,ntg
187  CALL bort(bort_str)
188 904 WRITE(bort_str,'("BUFRLIB: READLC - MNEMONIC ",A," DOES NOT '//
189  . 'REPRESENT A CHARACTER ELEMENT (ITP=",I2,")")') tgs(1),itp(nod)
190  CALL bort(bort_str)
191 905 WRITE(bort_str,'("BUFRLIB: READLC - MNEMONIC ",A," IS A '//
192  . 'CHARACTER STRING OF LENGTH",I4," BUT SPACE WAS PROVIDED '//
193  . 'FOR ONLY",I4, " CHARACTERS")') tgs(1),nchr,lchr
194  CALL bort(bort_str)
195 906 WRITE(bort_str,'("BUFRLIB: READLC - MESSAGE UNPACK TYPE",I3,'//
196  . '" IS NOT RECOGNIZED")') msgunp
197  CALL bort(bort_str)
198  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:55
subroutine ipkm(CBAY, NBYT, N)
This subroutine encodes an integer value within a specified number of bytes of a character string...
Definition: ipkm.f:27
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:41
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:22
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:58