NCEPLIBS-bufr  11.6.0
 All Data Structures Files Functions Variables Pages
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
3 C> a data subset.
4 
5 C> This subroutine writes a long character string (greater than 8 bytes)
6 C> to a data subset.
7 C>
8 C> <p>The data subset should have already been written into a BUFR
9 C> message via a previous call to one of the
10 C> [subset-writing subroutines](@ref hierarchy), before calling this
11 C> subroutine to write any long character strings into the same subset.
12 C>
13 C> @authors J. Woollen
14 C> @authors J. Ator
15 C> @date 2003-11-04
16 C>
17 C> @param[in] LUNIT -- integer: Fortran logical unit number for BUFR file
18 C> @param[in] CHR -- character*(*): Value corresponding to STR
19 C> @param[in] STR -- character*(*): Table B mnemonic of long character
20 C> string to be written, possibly supplemented
21 C> with an ordinal occurrence notation
22 C>
23 C> <p>If there is more than one occurrence of STR within the data subset
24 C> definition, then each occurrence can be written via a separate call
25 C> to this subroutine, and by appending the ordinal number of the
26 C> occurrence to STR in each case. For example, if there are 5
27 C> occurrences of mnemonic LSTID within a given data subset definition,
28 C> then 5 separate calls should be made to this subroutine, once each
29 C> with STR set to 'LSTID#1', 'LSTID#2', 'LSTID#3', 'LSTID#4' and
30 C> 'LSTID#5'. However, the first notation is superfluous, because
31 C> omitting the ordinal number always defaults to the first occurrence
32 C> of a particular string, so a user could just specify 'LSTID'
33 C> instead of 'LSTID#1'.
34 C>
35 C> @remarks
36 C> - Character strings which are 8 bytes or less in length can be
37 C> written by converting the string into a real*8 value within the
38 C> application program, and then using the real*8 USR array within a
39 C> call to one of the BUFRLIB
40 C> [values-writing subroutines](@ref hierarchy)
41 C> prior to calling one of the
42 C> [subset-writing subroutines](@ref hierarchy)
43 C> for the data subset.
44 C>
45 C> <b>Program history log:</b>
46 C> | Date | Programmer | Comments |
47 C> | -----|------------|----------|
48 C> | 2003-11-04 | J. Woollen | Original author |
49 C> | 2004-08-09 | J. Ator | Maximum message length increased from 20,000 to 50,000 bytes |
50 C> | 2005-11-29 | J. Ator | Use getlens() |
51 C> | 2007-01-19 | J. Ator | Replaced call to parseq with call to parstr() |
52 C> | 2009-03-23 | J. Ator | Added '#' option for more than one occurrence of STR |
53 C> | 2009-08-11 | J. Woollen | Added COMMON COMPRS along with logic to write long strings into compressed subsets |
54 C> | 2012-12-07 | J. Ator | Allow str mnemonic length of up to 14 chars when used with '#' occurrence code |
55 C> | 2014-10-22 | J. Ator | No longer abort if no subset available for writing; just print a warning message |
56 C> | 2014-12-10 | J. Ator | USE modules instead of COMMON blocks |
57 C> | 2020-09-09 | J. Ator | No longer abort if STR not available within subset definition; instead, just print a warning message |
58 C>
59  SUBROUTINE writlc(LUNIT,CHR,STR)
60 
61  USE moda_usrint
62  USE moda_msgcwd
63  USE moda_bitbuf
64  USE moda_tables
65  USE moda_comprs
66 
67  COMMON /quiet / iprt
68 
69  CHARACTER*(*) chr,str
70  CHARACTER*128 bort_str
71  CHARACTER*128 errstr
72  CHARACTER*10 ctag
73  CHARACTER*14 tgs(10)
74 
75  DATA maxtg /10/
76 
77 C-----------------------------------------------------------------------
78 C-----------------------------------------------------------------------
79 
80 C Check the file status.
81 
82  CALL status(lunit,lun,il,im)
83  IF(il.EQ.0) goto 900
84  IF(il.LT.0) goto 901
85  IF(im.EQ.0) goto 902
86 
87 C Check for tags (mnemonics) in input string (there can only be one)
88 
89  CALL parstr(str,tgs,maxtg,ntg,' ',.true.)
90  IF(ntg.GT.1) goto 903
91 
92 C Check if a specific occurrence of the input string was requested;
93 C if not, then the default is to write the first occurrence.
94 
95  CALL parutg(lun,1,tgs(1),nnod,kon,roid)
96  IF(kon.EQ.6) THEN
97  ioid=nint(roid)
98  IF(ioid.LE.0) ioid = 1
99  ctag = ' '
100  ii = 1
101  DO WHILE((ii.LE.10).AND.(tgs(1)(ii:ii).NE.'#'))
102  ctag(ii:ii)=tgs(1)(ii:ii)
103  ii = ii + 1
104  ENDDO
105  ELSE
106  ioid = 1
107  ctag = tgs(1)(1:10)
108  ENDIF
109 
110  IF(iupbs3(mbay(1,lun),'ICMP').GT.0) THEN
111 
112 C The message is compressed.
113 
114  n = 1
115  itagct = 0
116  CALL usrtpl(lun,n,n)
117  DO WHILE (n+1.LE.nval(lun))
118  n = n+1
119  node = inv(n,lun)
120  IF(itp(node).EQ.1) THEN
121  CALL usrtpl(lun,n,matx(n,ncol))
122  ELSEIF(ctag.EQ.tag(node)) THEN
123  itagct = itagct + 1
124  IF(itagct.EQ.ioid) THEN
125  IF(itp(node).NE.3) goto 904
126  catx(n,ncol)=' '
127 
128 C The following statement enforces a limit of MXLCC
129 C characters per long character string when writing
130 C compressed messages. This limit keeps the array
131 C CATX to a reasonable dimensioned size.
132 
133  nchr=min(mxlcc,ibt(node)/8)
134  catx(n,ncol)=chr(1:nchr)
135  CALL usrtpl(lun,1,1)
136  goto 100
137  ENDIF
138  ENDIF
139  ENDDO
140  ELSE
141 
142 C The message is not compressed. Locate the beginning of the
143 C data (Section 4) in the message.
144 
145  CALL getlens(mbay(1,lun),3,len0,len1,len2,len3,l4,l5)
146  mbyte = len0 + len1 + len2 + len3 + 4
147  nsubs = 1
148 
149 C Find the most recently written subset in the message.
150 
151  DO WHILE(nsubs.LT.nsub(lun))
152  ibit = mbyte*8
153  CALL upb(nbyt,16,mbay(1,lun),ibit)
154  mbyte = mbyte + nbyt
155  nsubs = nsubs + 1
156  ENDDO
157 
158  IF(nsubs.NE.nsub(lun)) THEN
159  IF(iprt.GE.0) THEN
160  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
161  errstr = 'BUFRLIB: WRITLC - COULDN''T WRITE VALUE FOR ' // ctag
162  . // ' INTO SUBSET, BECAUSE NO SUBSET WAS OPEN FOR WRITING'
163  CALL errwrt(errstr)
164  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
165  CALL errwrt(' ')
166  ENDIF
167  goto 100
168  ENDIF
169 
170 C Locate and write the long character string within this subset.
171 
172  itagct = 0
173  mbit = mbyte*8 + 16
174  nbit = 0
175  n = 1
176  CALL usrtpl(lun,n,n)
177  DO WHILE (n+1.LE.nval(lun))
178  n = n+1
179  node = inv(n,lun)
180  mbit = mbit+nbit
181  nbit = ibt(node)
182  IF(itp(node).EQ.1) THEN
183  CALL upbb(ival,nbit,mbit,mbay(1,lun))
184  CALL usrtpl(lun,n,ival)
185  ELSEIF(ctag.EQ.tag(node)) THEN
186  itagct = itagct + 1
187  IF(itagct.EQ.ioid) THEN
188  IF(itp(node).NE.3) goto 904
189  nchr = nbit/8
190  ibit = mbit
191  DO j=1,nchr
192  CALL pkc(' ',1,mbay(1,lun),ibit)
193  ENDDO
194  CALL pkc(chr,nchr,mbay(1,lun),mbit)
195  CALL usrtpl(lun,1,1)
196  goto 100
197  ENDIF
198  ENDIF
199  ENDDO
200  ENDIF
201 
202  IF(iprt.GE.0) THEN
203  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
204  errstr = 'BUFRLIB: WRITLC - COULDN''T WRITE VALUE FOR ' // ctag
205  . // ' INTO SUBSET, BECAUSE IT WASN''T FOUND IN THE SUBSET'
206  . // ' DEFINITION'
207  CALL errwrt(errstr)
208  errstr = '(' // ctag // ' MAY NOT BE IN THE BUFR TABLE(?))'
209  CALL errwrt(errstr)
210  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
211  CALL errwrt(' ')
212  ENDIF
213 
214 C EXITS
215 C -----
216 
217 100 RETURN
218 900 CALL bort('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS CLOSED, IT '//
219  . 'MUST BE OPEN FOR OUTPUT')
220 901 CALL bort('BUFRLIB: WRITLC - OUTPUT BUFR FILE IS OPEN FOR '//
221  . 'INPUT, IT MUST BE OPEN FOR OUTPUT')
222 902 CALL bort('BUFRLIB: WRITLC - A MESSAGE MUST BE OPEN IN OUTPUT '//
223  . 'BUFR FILE, NONE ARE')
224 903 WRITE(bort_str,'("BUFRLIB: WRITLC - THERE CANNOT BE MORE THAN '//
225  . ' ONE MNEMONIC IN THE INPUT STRING (",A,") (HERE THERE ARE",I4'//
226  . ',")")') str,ntg
227  CALL bort(bort_str)
228 904 WRITE(bort_str,'("BUFRLIB: WRITLC - MNEMONIC ",A," DOES NOT '//
229  . 'REPRESENT A CHARACTER ELEMENT (TYP=",A,")")') ctag,typ(node)
230  CALL bort(bort_str)
231 905 WRITE(bort_str,'("BUFRLIB: WRITLC - THE MOST RECENTLY WRITTEN '//
232  . .NE.' SUBSET NO. (",I3,") IN MSG THE STORED VALUE FOR THE NO.'//
233  . ' OF SUBSETS (",I3,") IN MSG")') nsubs,nsub(lun)
234  CALL bort(bort_str)
235  END
subroutine upbb(NVAL, NBITS, IBIT, IBAY)
THIS SUBROUTINE UNPACKS AND RETURNS A BINARY INTEGER CONTAINED WITHIN NBITS BITS OF IBAY...
Definition: upbb.f:42
function iupbs3(MBAY, S3MNEM)
This function returns a specified value from within Section 3 of a BUFR message.
Definition: iupbs3.f:34
subroutine upb(NVAL, NBITS, IBAY, IBIT)
THIS SUBROUTINE UNPACKS AND RETURNS A BINARY INTEGER CONTAINED WITHIN NBITS BITS OF IBAY...
Definition: upb.f:49
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 pkc(CHR, NCHR, IBAY, IBIT)
This subroutine encodes a character string within a specified number of bits of an integer array...
Definition: pkc.f:40
subroutine usrtpl(LUN, INVN, NBMP)
THIS SUBROUTINE STORES THE SUBSET TEMPLATE INTO INTERNAL SUBSET ARRAYS IN MODULE USRINT FOR CASES OF ...
Definition: usrtpl.f:51
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:39
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 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 writlc(LUNIT, CHR, STR)
This subroutine writes a long character string (greater than 8 bytes) to a data subset.
Definition: writlc.f:59