NCEPLIBS-bufr  11.6.0
 All Data Structures Files Functions Variables Pages
hold4wlc.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>Normally, subroutine writlc() is used to write a long character
9 C> string to a data subset. However, subroutine writlc() can only be
10 C> called <b>after</b> a call to one of the
11 C> [subset-writing subroutines](@ref hierarchy), so it will not work
12 C> for cases when one of those subroutines flushes the message
13 C> containing the data subset in question to logical unit LUNIT during
14 C> the same call to that subroutine, such as when the data subset
15 C> contains more than 65530 bytes. When this happens, there is no
16 C> longer any way for a subsequent writlc() call to write a long
17 C> character string into that data subset, because the data subset has
18 C> already been flushed from internal memory. This subroutine solves
19 C> that problem, by allowing a long character string to be specified
20 C> <b>before</b> calling one of the
21 C> [subset-writing subroutines](@ref hierarchy), and the string value
22 C> will be held and stored automatically (via an internal call to
23 C> subroutine writlc()) at the proper time during the subsequent call
24 C> to the [subset-writing subroutines](@ref hierarchy).
25 C>
26 C> @author J. Ator
27 C> @date 2014-02-05
28 C>
29 C> @param[in] LUNIT -- integer: Fortran logical unit number for BUFR file
30 C> @param[in] CHR -- character*(*): Value corresponding to STR
31 C> @param[in] STR -- character*(*): Table B mnemonic of long character
32 C> string to be written, possibly supplemented
33 C> with an ordinal occurrence notation
34 C>
35 C> <p>If there is more than one occurrence of STR within the data subset
36 C> definition, then each occurrence can be written via a separate call
37 C> to this subroutine, and by appending the ordinal number of the
38 C> occurrence to STR in each case. For example, if there are 5
39 C> occurrences of mnemonic LSTID within a given data subset definition,
40 C> then 5 separate calls should be made to this subroutine, once each
41 C> with STR set to 'LSTID#1', 'LSTID#2', 'LSTID#3', 'LSTID#4' and
42 C> 'LSTID#5'. However, the first notation is superfluous, because
43 C> omitting the ordinal number always defaults to the first occurrence
44 C> of a particular string, so a user could just specify 'LSTID'
45 C> instead of 'LSTID#1'.
46 C>
47 C> @remarks
48 C> - Character strings which are 8 bytes or less in length can be
49 C> written by converting the string into a real*8 value within the
50 C> application program, and then using the real*8 USR array within a
51 C> call to one of the BUFRLIB
52 C> [values-writing subroutines](@ref hierarchy)
53 C> prior to calling one of the
54 C> [subset-writing subroutines](@ref hierarchy)
55 C> for the data subset.
56 C>
57 C> <b>Program history log:</b>
58 C> | Date | Programmer | Comments |
59 C> | -----|------------|----------|
60 C> | 2014-02-05 | J. Ator | Original author |
61 C>
62  SUBROUTINE hold4wlc(LUNIT,CHR,STR)
63 
64  USE moda_h4wlc
65 
66  COMMON /quiet/ iprt
67 
68  CHARACTER*(*) chr,str
69 
70  CHARACTER*128 errstr
71  CHARACTER*14 mystr
72 
73 C-----------------------------------------------------------------------
74 C-----------------------------------------------------------------------
75 
76  CALL strsuc( str, mystr, lens )
77  IF ( lens .EQ. -1 ) RETURN
78 
79  lenc = min( len( chr ), 120 )
80 
81 C IF THIS SUBROUTINE HAS ALREADY BEEN CALLED WITH THIS MNEMONIC FOR
82 C THIS PARTICULAR SUBSET, THEN OVERWRITE THE CORRESPONDING ENTRY IN
83 C THE INTERNAL HOLDING AREA.
84 
85  IF ( nh4wlc .GT. 0 ) THEN
86  DO i = 1, nh4wlc
87  IF ( ( lunit .EQ. luh4wlc(i) ) .AND.
88  . ( mystr(1:lens) .EQ. sth4wlc(i)(1:lens) ) ) THEN
89  chh4wlc(i) = ''
90  chh4wlc(i)(1:lenc) = chr(1:lenc)
91  RETURN
92  ENDIF
93  ENDDO
94  ENDIF
95 
96 C OTHERWISE, USE THE NEXT AVAILABLE UNUSED ENTRY IN THE HOLDING AREA.
97 
98  IF ( nh4wlc .GE. mxh4wlc ) THEN
99  IF(iprt.GE.0) THEN
100  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
101  WRITE ( unit=errstr, fmt='(A,A,I3)' )
102  . 'BUFRLIB: HOLD4WLC - THE MAXIMUM NUMBER OF LONG CHARACTER ',
103  . 'STRINGS THAT CAN BE HELD INTERNALLY IS ', mxh4wlc
104  CALL errwrt(errstr)
105  CALL errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
106  ENDIF
107  ELSE
108  nh4wlc = nh4wlc + 1
109  luh4wlc(nh4wlc) = lunit
110  sth4wlc(nh4wlc) = ''
111  sth4wlc(nh4wlc)(1:lens) = mystr(1:lens)
112  chh4wlc(nh4wlc) = ''
113  chh4wlc(nh4wlc)(1:lenc) = chr(1:lenc)
114  ENDIF
115 
116  RETURN
117  END
subroutine strsuc(STR1, STR2, LENS)
This subroutine removes leading and trailing blanks from a character string.
Definition: strsuc.f:23
subroutine hold4wlc(LUNIT, CHR, STR)
This subroutine writes a long character string (greater than 8 bytes) to a data subset.
Definition: hold4wlc.f:62
subroutine errwrt(STR)
This subroutine allows the user to specify a custom location for the logging of error and diagnostic ...
Definition: errwrt.f:41