NCEPLIBS-bufr  11.7.0
 All Data Structures Files Functions Variables Pages
msgwrt.f
Go to the documentation of this file.
1 C> @file
2 C> @brief Finalize a BUFR message for output and write the message to
3 C> a BUFR file.
4 
5 C> This subroutine performs final checks and updates on a BUFR message
6 C> before writing it to a specified Fortran logical unit.
7 C>
8 C> <p>These final checks and updates include:
9 C> - Standardizing the BUFR message, if requested via a previous call
10 C> subroutine stdmsg()
11 C> - Converting the BUFR message from edition 3 to edition 4, if
12 C> requested via a previous call to subroutine pkvs01()
13 C> - Storing any customized values into Section 0 or Section 1 of the
14 C> BUFR message, if requested via one or more previous calls to
15 C> subroutine pkvs01()
16 C> - Storing a tank receipt time into Section 1 of the BUFR message,
17 C> if requested via a previous call to subroutine strcpt()
18 C> - For edition 3 BUFR messages, ensuring each section of the message
19 C> contains an even number of bytes
20 C> - Storing '7777' into the last four bytes of the BUFR message, and
21 C> storing the final message length in Section 0
22 C> - Appending zeroed-out bytes after the end of the BUFR message, up
23 C> to the next machine word boundary
24 C> - Encapsulating the BUFR message with IEEE Fortran control words,
25 C> if requested via a previous call to subroutine setblock()
26 C> - Storing a copy of the final message into internal arrays for
27 C> possible later retrival via subroutine writsa()
28 C>
29 C> @author J. Woollen
30 C> @date 1994-01-06
31 C>
32 C> @param[in] LUNIT -- integer: Fortran logical unit number for BUFR
33 C> file
34 C> @param[in] MESG -- integer(*): BUFR message
35 C> @param[in] MGBYT -- integer: Size (in bytes) of BUFR message
36 C>
37 C> <b>Program history log:</b>
38 C> | Date | Programmer | Comments |
39 C> | -----|------------|----------|
40 C> | 1994-01-06 | J. Woollen | Original author |
41 C> | 1997-07-29 | J. Woollen | Modified to update the current BUFR version written in Section 0 from 2 to 3 |
42 C> | 1998-07-08 | J. Woollen | Replaced call to Cray library routine ABORT with call to new internal routine bort() |
43 C> | 1998-11-24 | J. Woollen | Modified to zero out the padding bytes written at the end of Section 4 |
44 C> | 2000-09-19 | J. Woollen | Maximum message length increased from 10,000 to 20,000 bytes |
45 C> | 2003-11-04 | J. Ator | Don't write to LUNIT if opened by openbf() using IO = 'NUL' |
46 C> | 2003-11-04 | S. Bender | Added remarks and routine interdependencies |
47 C> | 2003-11-04 | D. Keyser | Unified/portable for WRF; added documentation; outputs more complete diagnostic info when routine terminates abnormally |
48 C> | 2005-11-29 | J. Ator | Use getlens(), iupbs01(), padmsg(), pkbs1() and nmwrd(); added logic to call pkbs1() and/or cnved4() when necessary |
49 C> | 2009-03-23 | J. Ator | Use idxmsg() and errwrt(); add call to atrcpt(); allow standardizing even if data is compressed; work on local copy of input message |
50 C> | 2012-09-15 | J. Woollen | Modified for C/I/O/BUFR interface; call new routine blocks() for file blocking and new C routine cwrbufr() to write BUFR message to disk file |
51 C> | 2014-12-10 | J. Ator | Use modules instead of COMMON blocks |
52 C> | 2019-05-09 | J. Ator | Added dimensions for MSGLEN and MSGTXT |
53 C>
54  SUBROUTINE msgwrt(LUNIT,MESG,MGBYT)
55 
56  USE moda_nulbfr
57  USE moda_bufrmg
58  USE moda_mgwa
59  USE moda_mgwb
60  USE moda_s01cm
61 
62  COMMON /quiet / iprt
63  COMMON /msgstd/ csmf
64  COMMON /tnkrcp/ itryr,itrmo,itrdy,itrhr,itrmi,ctrt
65 
66  CHARACTER*128 errstr
67 
68  CHARACTER*4 bufr,sevn
69  CHARACTER*1 csmf
70  CHARACTER*1 ctrt
71  dimension mesg(*)
72  dimension iec0(2)
73 
74  DATA bufr/'BUFR'/
75  DATA sevn/'7777'/
76 
77 C-----------------------------------------------------------------------
78 C-----------------------------------------------------------------------
79 
80 C MAKE A LOCAL COPY OF THE INPUT MESSAGE FOR USE WITHIN THIS
81 C SUBROUTINE, SINCE CALLS TO ANY OR ALL OF THE SUBROUTINES STNDRD,
82 C CNVED4, PKBS1, ATRCPT, ETC. MAY END UP MODIFYING THE MESSAGE
83 C BEFORE IT FINALLY GETS WRITTEN OUT TO LUNIT.
84 
85  mbyt = mgbyt
86 
87  iec0(1) = mesg(1)
88  iec0(2) = mesg(2)
89  ibit = 32
90  CALL pkb(mbyt,24,iec0,ibit)
91 
92  DO ii = 1, nmwrd(iec0)
93  mgwa(ii) = mesg(ii)
94  ENDDO
95 
96 C OVERWRITE ANY VALUES WITHIN SECTION 0 OR SECTION 1 THAT WERE
97 C REQUESTED VIA PREVIOUS CALLS TO BUFR ARCHIVE LIBRARY SUBROUTINE
98 C PKVS01. IF A REQUEST WAS MADE TO CHANGE THE BUFR EDITION NUMBER
99 C TO 4, THEN ACTUALLY CONVERT THE MESSAGE AS WELL.
100 
101  IF(ns01v.GT.0) THEN
102  DO i=1,ns01v
103  IF(cmnem(i).EQ.'BEN') THEN
104  IF(ivmnem(i).EQ.4) THEN
105 
106 C INSTALL SECTION 0 BYTE COUNT FOR USE BY SUBROUTINE CNVED4.
107 
108  ibit = 32
109  CALL pkb(mbyt,24,mgwa,ibit)
110 
111  CALL cnved4(mgwa,mxmsgld4,mgwb)
112 
113 C COMPUTE MBYT FOR THE NEW EDITION 4 MESSAGE.
114 
115  mbyt = iupbs01(mgwb,'LENM')
116 
117 C COPY THE MGWB ARRAY BACK INTO MGWA.
118 
119  DO ii = 1, nmwrd(mgwb)
120  mgwa(ii) = mgwb(ii)
121  ENDDO
122  ENDIF
123  ELSE
124 
125 C OVERWRITE THE REQUESTED VALUE.
126 
127  CALL pkbs1(ivmnem(i),mgwa,cmnem(i))
128  ENDIF
129  ENDDO
130  ENDIF
131 
132 C "STANDARDIZE" THE MESSAGE IF REQUESTED VIA COMMON /MSGSTD/.
133 C HOWEVER, WE DO NOT WANT TO DO THIS IF THE MESSAGE CONTAINS BUFR
134 C TABLE (DX) INFORMATION, IN WHICH CASE IT IS ALREADY "STANDARD".
135 
136  IF ( ( csmf.EQ.'Y' ) .AND. ( idxmsg(mgwa).NE.1 ) ) THEN
137 
138 C INSTALL SECTION 0 BYTE COUNT AND SECTION 5 '7777' INTO THE
139 C ORIGINAL MESSAGE. THIS IS NECESSARY BECAUSE SUBROUTINE STNDRD
140 C REQUIRES A COMPLETE AND WELL-FORMED BUFR MESSAGE AS ITS INPUT.
141 
142  ibit = 32
143  CALL pkb(mbyt,24,mgwa,ibit)
144  ibit = (mbyt-4)*8
145  CALL pkc(sevn,4,mgwa,ibit)
146 
147  CALL stndrd(lunit,mgwa,mxmsgld4,mgwb)
148 
149 C COMPUTE MBYT FOR THE NEW "STANDARDIZED" MESSAGE.
150 
151  mbyt = iupbs01(mgwb,'LENM')
152 
153 C COPY THE MGWB ARRAY BACK INTO MGWA.
154 
155  DO ii = 1, nmwrd(mgwb)
156  mgwa(ii) = mgwb(ii)
157  ENDDO
158  ENDIF
159 
160 C APPEND THE TANK RECEIPT TIME TO SECTION 1 IF REQUESTED VIA
161 C COMMON /TNKRCP/, UNLESS THE MESSAGE CONTAINS BUFR TABLE (DX)
162 C INFORMATION.
163 
164  IF ( ( ctrt.EQ.'Y' ) .AND. ( idxmsg(mgwa).NE.1 ) ) THEN
165 
166 C INSTALL SECTION 0 BYTE COUNT FOR USE BY SUBROUTINE ATRCPT.
167 
168  ibit = 32
169  CALL pkb(mbyt,24,mgwa,ibit)
170 
171  CALL atrcpt(mgwa,mxmsgld4,mgwb)
172 
173 C COMPUTE MBYT FOR THE REVISED MESSAGE.
174 
175  mbyt = iupbs01(mgwb,'LENM')
176 
177 C COPY THE MGWB ARRAY BACK INTO MGWA.
178 
179  DO ii = 1, nmwrd(mgwb)
180  mgwa(ii) = mgwb(ii)
181  ENDDO
182  ENDIF
183 
184 C GET THE SECTION LENGTHS.
185 
186  CALL getlens(mgwa,4,len0,len1,len2,len3,len4,l5)
187 
188 C DEPENDING ON THE EDITION NUMBER OF THE MESSAGE, WE NEED TO ENSURE
189 C THAT EACH SECTION WITHIN THE MESSAGE HAS AN EVEN NUMBER OF BYTES.
190 
191  IF(iupbs01(mgwa,'BEN').LT.4) THEN
192  IF(mod(len1,2).NE.0) goto 901
193  IF(mod(len2,2).NE.0) goto 902
194  IF(mod(len3,2).NE.0) goto 903
195  IF(mod(len4,2).NE.0) THEN
196 
197 C PAD SECTION 4 WITH AN ADDITIONAL BYTE
198 C THAT IS ZEROED OUT.
199 
200  iad4 = len0+len1+len2+len3
201  iad5 = iad4+len4
202  ibit = iad4*8
203  len4 = len4+1
204  CALL pkb(len4,24,mgwa,ibit)
205  ibit = iad5*8
206  CALL pkb(0,8,mgwa,ibit)
207  mbyt = mbyt+1
208  ENDIF
209  ENDIF
210 
211 C WRITE SECTION 0 BYTE COUNT AND SECTION 5
212 C ----------------------------------------
213 
214  ibit = 0
215  CALL pkc(bufr, 4,mgwa,ibit)
216  CALL pkb(mbyt,24,mgwa,ibit)
217 
218  kbit = (mbyt-4)*8
219  CALL pkc(sevn, 4,mgwa,kbit)
220 
221 C ZERO OUT THE EXTRA BYTES WHICH WILL BE WRITTEN
222 C ----------------------------------------------
223 
224 C I.E. SINCE THE BUFR MESSAGE IS STORED WITHIN THE INTEGER ARRAY
225 C MGWA(*) (RATHER THAN WITHIN A CHARACTER ARRAY), WE NEED TO MAKE
226 C SURE THAT THE "7777" IS FOLLOWED BY ZEROED-OUT BYTES UP TO THE
227 C BOUNDARY OF THE LAST MACHINE WORD THAT WILL BE WRITTEN OUT.
228 
229  CALL padmsg(mgwa,mxmsgld4,npbyt)
230 
231 C WRITE THE MESSAGE PLUS PADDING TO A WORD BOUNDARY IF NULL(LUN) = 0
232 C ------------------------------------------------------------------
233 
234  mwrd = nmwrd(mgwa)
235  CALL status(lunit,lun,il,im)
236  IF(null(lun).EQ.0) THEN
237  CALL blocks(mgwa,mwrd)
238  CALL cwrbufr(lun,mgwa,mwrd)
239  ENDIF
240 
241  IF(iprt.GE.2) THEN
242  CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
243  WRITE ( unit=errstr, fmt='(A,I4,A,I7)')
244  . 'BUFRLIB: MSGWRT: LUNIT =', lunit, ', BYTES =', mbyt+npbyt
245  CALL errwrt(errstr)
246  CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
247  CALL errwrt(' ')
248  ENDIF
249 
250 C SAVE A MEMORY COPY OF THIS MESSAGE, UNLESS IT'S A DX MESSAGE
251 C ------------------------------------------------------------
252 
253  IF(idxmsg(mgwa).NE.1) THEN
254 
255 C STORE A COPY OF THIS MESSAGE WITHIN MODULE BUFRMG,
256 C FOR POSSIBLE LATER RETRIEVAL DURING A FUTURE CALL TO
257 C SUBROUTINE WRITSA.
258 
259  msglen(lun) = mwrd
260  DO i=1,msglen(lun)
261  msgtxt(i,lun) = mgwa(i)
262  ENDDO
263  ENDIF
264 
265 C EXITS
266 C -----
267 
268  RETURN
269 901 CALL bort
270  . ('BUFRLIB: MSGWRT - LENGTH OF SECTION 1 IS NOT A MULTIPLE OF 2')
271 902 CALL bort
272  . ('BUFRLIB: MSGWRT - LENGTH OF SECTION 2 IS NOT A MULTIPLE OF 2')
273 903 CALL bort
274  . ('BUFRLIB: MSGWRT - LENGTH OF SECTION 3 IS NOT A MULTIPLE OF 2')
275  END
subroutine msgwrt(LUNIT, MESG, MGBYT)
This subroutine performs final checks and updates on a BUFR message before writing it to a specified ...
Definition: msgwrt.f:54
function nmwrd(MBAY)
GIVEN AN INTEGER ARRAY CONTAINING SECTION ZERO FROM A BUFR MESSAGE, THIS FUNCTION DETERMINES A COUNT ...
Definition: nmwrd.f:27
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 stndrd(LUNIT, MSGIN, LMSGOT, MSGOT)
This subroutine performs the same function as subroutine stdmsg(), except that it operates on a BUFR ...
Definition: stndrd.f:36
subroutine cnved4(MSGIN, LMSGOT, MSGOT)
This subroutine reads an input BUFR message encoded using BUFR edition 3 and outputs an equivalent BU...
Definition: cnved4.f:36
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
void cwrbufr(f77int *nfile, f77int *bufr, f77int *nwrd)
This subroutine writes a BUFR message into a file that was previously opened for writing.
Definition: cread.c:173
function idxmsg(MESG)
This function determines whether a given BUFR message contains DX BUFR tables information that was ge...
Definition: idxmsg.f:23
subroutine pkbs1(IVAL, MBAY, S1MNEM)
This subroutines writes a specified value into a specified location within Section 1 of a BUFR messag...
Definition: pkbs1.f:57
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 errwrt(STR)
This subroutine allows the user to specify a custom location for the logging of error and diagnostic ...
Definition: errwrt.f:41
subroutine padmsg(MESG, LMESG, NPBYT)
THIS SUBROUTINE PADS A BUFR MESSAGE WITH ZEROED-OUT BYTES FROM THE END OF THE MESSAGE UP TO THE NEXT ...
Definition: padmsg.f:28
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:22
subroutine pkb(NVAL, NBITS, IBAY, IBIT)
This subroutine encodes an integer value within a specified number of bits of an integer array...
Definition: pkb.f:38
subroutine atrcpt(MSGIN, LMSGOT, MSGOT)
This subroutine reads an input message and outputs an equivalent BUFR message with a tank receipt tim...
Definition: atrcpt.f:34
subroutine blocks(MBAY, MWRD)
This subroutine encapsulates a BUFR message with IEEE Fortran control words as specified via the most...
Definition: blocks.f:45
function iupbs01(MBAY, S01MNEM)
This function returns a specified value from within Section 0 or Section 1 of a BUFR message...
Definition: iupbs01.f:73