NCEPLIBS-bufr  12.0.0
writlc.f
Go to the documentation of this file.
1 C> @file
2 C> @brief Write a long character string (greater than 8 bytes) to a data subset.
3 C>
4 C> @author J. Woollen @author J. Ator @date 2003-11-04
5 
6 C> Write a long character string (greater than 8 bytes) to a data subset.
7 C>
8 C> The data subset should have already been written into a BUFR message before
9 C> calling this subroutine to write a long character string into the subset.
10 C>
11 C> If there is more than one occurrence of STR within the data subset
12 C> definition, then each occurrence can be written via a separate call
13 C> to this subroutine, and by appending the ordinal number of the
14 C> occurrence to STR in each case. For example, if there are 5
15 C> occurrences of mnemonic LSTID within a given data subset definition,
16 C> then 5 separate calls should be made to this subroutine, once each
17 C> with STR set to 'LSTID#1', 'LSTID#2', 'LSTID#3', 'LSTID#4' and
18 C> 'LSTID#5'. However, the first notation is superfluous, because
19 C> omitting the ordinal number always defaults to the first occurrence
20 C> of a particular string, so a user could just specify 'LSTID'
21 C> instead of 'LSTID#1'.
22 C>
23 C> Character strings which are 8 bytes or less in length can be
24 C> written by converting the string into a real*8 value within the
25 C> application program, and then using the real*8 USR array within a
26 C> call to one of the BUFRLIB
27 C> [values-writing subroutines](@ref hierarchy)
28 C> prior to calling one of the
29 C> [subset-writing subroutines](@ref hierarchy)
30 C> for the data subset.
31 C>
32 C> @param[in] LUNIT - integer: Fortran logical unit number for BUFR file.
33 C> @param[in] CHR - character*(*): Value corresponding to STR.
34 C> @param[in] STR - character*(*): Table B mnemonic of long character
35 C> string to be written, possibly supplemented with an ordinal occurrence notation.
36 C>
37 C> @author J. Woollen @author J. Ator @date 2003-11-04
38 
39  RECURSIVE SUBROUTINE writlc(LUNIT,CHR,STR)
40 
41  USE modv_im8b
42  USE modv_mxlcc
43 
44  USE moda_usrint
45  USE moda_msgcwd
46  USE moda_bitbuf
47  USE moda_tables
48  USE moda_comprs
49 
50  COMMON /quiet / iprt
51 
52  CHARACTER*(*) chr,str
53  CHARACTER*128 bort_str
54  CHARACTER*128 errstr
55  CHARACTER*10 ctag
56  CHARACTER*14 tgs(10)
57 
58  DATA maxtg /10/
59 
60 C-----------------------------------------------------------------------
61 C-----------------------------------------------------------------------
62 
63 C Check for I8 integers.
64 
65  IF(im8b) THEN
66  im8b=.false.
67 
68  CALL x84(lunit,my_lunit,1)
69  CALL writlc(my_lunit,chr,str)
70 
71  im8b=.true.
72  RETURN
73  ENDIF
74 
75 C Check the file status.
76 
77  CALL status(lunit,lun,il,im)
78  IF(il.EQ.0) GOTO 900
79  IF(il.LT.0) GOTO 901
80  IF(im.EQ.0) GOTO 902
81 
82 C Check for tags (mnemonics) in input string (there can only be one)
83 
84  CALL parstr(str,tgs,maxtg,ntg,' ',.true.)
85  IF(ntg.GT.1) GOTO 903
86 
87 C Check if a specific occurrence of the input string was requested;
88 C if not, then the default is to write the first occurrence.
89 
90  CALL parutg(lun,1,tgs(1),nnod,kon,roid)
91  IF(kon.EQ.6) THEN
92  ioid=nint(roid)
93  IF(ioid.LE.0) ioid = 1
94  ctag = ' '
95  ii = 1
96  DO WHILE((ii.LE.10).AND.(tgs(1)(ii:ii).NE.'#'))
97  ctag(ii:ii)=tgs(1)(ii:ii)
98  ii = ii + 1
99  ENDDO
100  ELSE
101  ioid = 1
102  ctag = tgs(1)(1:10)
103  ENDIF
104 
105  IF(iupbs3(mbay(1,lun),'ICMP').GT.0) THEN
106 
107 C The message is compressed.
108 
109  n = 1
110  itagct = 0
111  CALL usrtpl(lun,n,n)
112  DO WHILE (n+1.LE.nval(lun))
113  n = n+1
114  node = inv(n,lun)
115  IF(itp(node).EQ.1) THEN
116  nbmp=int(matx(n,ncol))
117  CALL usrtpl(lun,n,nbmp)
118  ELSEIF(ctag.EQ.tag(node)) THEN
119  itagct = itagct + 1
120  IF(itagct.EQ.ioid) THEN
121  IF(itp(node).NE.3) GOTO 904
122  catx(n,ncol)=' '
123 
124 C The following statement enforces a limit of MXLCC
125 C characters per long character string when writing
126 C compressed messages. This limit keeps the array
127 C CATX to a reasonable dimensioned size.
128 
129  nchr=min(mxlcc,ibt(node)/8)
130  catx(n,ncol)=chr(1:nchr)
131  CALL usrtpl(lun,1,1)
132  GOTO 100
133  ENDIF
134  ENDIF
135  ENDDO
136  ELSE
137 
138 C The message is not compressed. Locate the beginning of the
139 C data (Section 4) in the message.
140 
141  CALL getlens(mbay(1,lun),3,len0,len1,len2,len3,l4,l5)
142  mbyte = len0 + len1 + len2 + len3 + 4
143  nsubs = 1
144 
145 C Find the most recently written subset in the message.
146 
147  DO WHILE(nsubs.LT.nsub(lun))
148  ibit = mbyte*8
149  CALL upb(nbyt,16,mbay(1,lun),ibit)
150  mbyte = mbyte + nbyt
151  nsubs = nsubs + 1
152  ENDDO
153 
154  IF(nsubs.NE.nsub(lun)) THEN
155  IF(iprt.GE.0) THEN
156  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
157  errstr = 'BUFRLIB: WRITLC - COULDN''T WRITE VALUE FOR ' // ctag
158  . // ' INTO SUBSET, BECAUSE NO SUBSET WAS OPEN FOR WRITING'
159  CALL errwrt(errstr)
160  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
161  CALL errwrt(' ')
162  ENDIF
163  GOTO 100
164  ENDIF
165 
166 C Locate and write the long character string within this subset.
167 
168  itagct = 0
169  mbit = mbyte*8 + 16
170  nbit = 0
171  n = 1
172  CALL usrtpl(lun,n,n)
173  DO WHILE (n+1.LE.nval(lun))
174  n = n+1
175  node = inv(n,lun)
176  mbit = mbit+nbit
177  nbit = ibt(node)
178  IF(itp(node).EQ.1) THEN
179  CALL upbb(ival,nbit,mbit,mbay(1,lun))
180  CALL usrtpl(lun,n,ival)
181  ELSEIF(ctag.EQ.tag(node)) THEN
182  itagct = itagct + 1
183  IF(itagct.EQ.ioid) THEN
184  IF(itp(node).NE.3) GOTO 904
185  nchr = nbit/8
186  ibit = mbit
187  DO j=1,nchr
188  CALL pkc(' ',1,mbay(1,lun),ibit)
189  ENDDO
190  CALL pkc(chr,nchr,mbay(1,lun),mbit)
191  CALL usrtpl(lun,1,1)
192  GOTO 100
193  ENDIF
194  ENDIF
195  ENDDO
196  ENDIF
197 
198  IF(iprt.GE.0) THEN
199  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
200  errstr = 'BUFRLIB: WRITLC - COULDN''T WRITE VALUE FOR ' // ctag
201  . // ' INTO SUBSET, BECAUSE IT WASN''T FOUND IN THE SUBSET'
202  . // ' DEFINITION'
203  CALL errwrt(errstr)
204  errstr = '(' // ctag // ' MAY NOT BE IN THE BUFR TABLE(?))'
205  CALL errwrt(errstr)
206  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
207  CALL errwrt(' ')
208  ENDIF
209 
210 C EXITS
211 C -----
212 
213 100 RETURN
214 900 CALL bort('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS CLOSED, IT '//
215  . 'MUST BE OPEN FOR OUTPUT')
216 901 CALL bort('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS OPEN FOR '//
217  . 'INPUT, IT MUST BE OPEN FOR OUTPUT')
218 902 CALL bort('BUFRLIB: WRITLC - A MESSAGE MUST BE OPEN IN OUTPUT '//
219  . 'BUFR FILE, NONE ARE')
220 903 WRITE(bort_str,'("BUFRLIB: WRITLC - THERE CANNOT BE MORE THAN '//
221  . ' ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE",I4'//
222  . ',")")') str,ntg
223  CALL bort(bort_str)
224 904 WRITE(bort_str,'("BUFRLIB: WRITLC - MNEMONIC ",A," DOES NOT '//
225  . 'REPRESENT A CHARACTER ELEMENT (TYP=",A,")")') ctag,typ(node)
226  CALL bort(bort_str)
227  END
subroutine bort(STR)
Log one error message and abort application program.
Definition: bort.f:18
subroutine errwrt(STR)
This subroutine allows the user to specify a custom location for the logging of error and diagnostic ...
Definition: errwrt.f:36
recursive subroutine getlens(MBAY, LL, LEN0, LEN1, LEN2, LEN3, LEN4, LEN5)
This subroutine reads the lengths of all of the individual sections of a given BUFR message,...
Definition: getlens.f:36
recursive function iupbs3(MBAY, S3MNEM)
This function returns a specified value from within Section 3 of a BUFR message.
Definition: iupbs3.f:30
This module contains array and variable declarations used to store BUFR messages internally for multi...
integer ibit
Bit pointer within IBAY.
integer, dimension(:,:), allocatable mbay
Current BUFR message for each internal I/O stream.
This module contains arrays and variable declarations for the storage of data values needed when writ...
integer ncol
Number of data subsets in message.
integer(8), dimension(:,:), allocatable matx
Non-character data values for all data subsets in message.
character *(:), dimension(:,:), allocatable catx
Character data values for all data subsets in message.
This module contains declarations for arrays used to store information about the current BUFR message...
integer, dimension(:), allocatable nsub
Current subset pointer within message.
This module contains array and variable declarations used to store the internal jump/link table.
integer, dimension(:), allocatable ibt
Bit widths corresponding to tag and typ:
character *3, dimension(:), allocatable typ
Type indicators corresponding to tag:
character *10, dimension(:), allocatable tag
Mnemonics in the jump/link table.
integer, dimension(:), allocatable itp
Integer type values corresponding to typ:
This module contains declarations for arrays used to store data values and associated metadata for th...
integer, dimension(:), allocatable nval
Number of data values in BUFR data subset.
integer, dimension(:,:), allocatable, target inv
Inventory pointer which links each data value to its corresponding node in the internal jump/link tab...
This module declares and initializes the IM8B variable.
logical, public im8b
Status indicator to keep track of whether all future calls to BUFRLIB subroutines and functions from ...
This module declares and initializes the MXLCC variable.
integer mxlcc
Maximum length (in bytes) of a character string that can be written into a data subset of a compresse...
subroutine parstr(STR, TAGS, MTAG, NTAG, SEP, LIMIT80)
Parse a string containing one or more substrings into an array of substrings.
Definition: parstr.f:24
subroutine parutg(LUN, IO, UTG, NOD, KON, VAL)
Parse a mnemonic from a character string.
Definition: parutg.f:83
subroutine pkc(CHR, NCHR, IBAY, IBIT)
Encode a character string within an integer array.
Definition: pkc.f:31
recursive subroutine status(LUNIT, LUN, IL, IM)
Check whether a specified Fortran logical unit number is currently connected to the NCEPLIBS-bufr sof...
Definition: status.f:36
subroutine upb(NVAL, NBITS, IBAY, IBIT)
This subroutine decodes an integer value from within a specified number of bits of an integer array,...
Definition: upb.f:28
subroutine upbb(NVAL, NBITS, IBIT, IBAY)
This subroutine decodes an integer value from within a specified number of bits of an integer array,...
Definition: upbb.f:22
subroutine usrtpl(LUN, INVN, NBMP)
Store the subset template into internal arrays.
Definition: usrtpl.f:22
recursive subroutine writlc(LUNIT, CHR, STR)
Write a long character string (greater than 8 bytes) to a data subset.
Definition: writlc.f:40
subroutine x84(IIN8, IOUT4, NVAL)
Encode one or more 8-byte integer values as 4-byte integer values.
Definition: x84.F:19