NCEPLIBS-bufr  12.1.0
standard.F90
Go to the documentation of this file.
1 
5 
35 subroutine stdmsg(cf)
36 
37  use moda_msgstd
38 
39  implicit none
40 
41  character*1, intent(in) :: cf
42  character*128 bort_str
43 
44  call capit(cf)
45  if(cf/='Y'.and. cf/='N') then
46  write(bort_str,'("BUFRLIB: STDMSG - INPUT ARGUMENT IS ",A1,", IT MUST BE EITHER Y OR N")') cf
47  call bort(bort_str)
48  endif
49  csmf = cf
50 
51  return
52 end subroutine stdmsg
53 
72 recursive subroutine stndrd(lunit,msgin,lmsgot,msgot)
73 
74  use bufrlib
75 
76  use modv_vars, only: im8b, nbytw
77 
78  use moda_s3list
79 
80  implicit none
81 
82  integer, intent(in) :: msgin(*), lunit, lmsgot
83  integer, intent(out) :: msgot(*)
84  integer my_lunit, my_lmsgot, lun, il, im, len0, len1, len2, len3, len4, len5
85  integer iad3, iad4, lenn, lenm, iupbs01, iupbs3, iupb, mxbyto, lbyto, ii, isub, itab, mtyp, msbt, inod
86  integer istdesc, ncd, iben, ibit, jbit, kbit, mbit, nad4, lsub, nsub, islen, kval, nval, i, k, l, n
87 
88  character*128 bort_str
89  character*8 subset
90  character*4 sevn
91  character*1 tab
92  character*(*), parameter :: bort_arrayoverflow = &
93  'BUFRLIB: STNDRD - OVERFLOW OF OUTPUT (STANDARD) MESSAGE ARRAY; TRY A LARGER DIMENSION FOR THIS ARRAY'
94 
95  logical found
96 
97  ! Check for I8 integers.
98 
99  if(im8b) then
100  im8b=.false.
101 
102  call x84 ( lunit, my_lunit, 1 )
103  call x84 ( lmsgot, my_lmsgot, 1 )
104  call stndrd ( my_lunit, msgin, my_lmsgot*2, msgot )
105 
106  im8b=.true.
107  return
108  endif
109 
110  ! lunit must point to an open bufr file.
111 
112  call status(lunit,lun,il,im)
113  if(il==0) call bort('BUFRLIB: STNDRD - BUFR FILE IS CLOSED, IT MUST BE OPEN')
114 
115  ! Identify the section lengths and addresses in msgin.
116 
117  call getlens(msgin,5,len0,len1,len2,len3,len4,len5)
118 
119  iad3 = len0+len1+len2
120  iad4 = iad3+len3
121 
122  lenn = len0+len1+len2+len3+len4+len5
123 
124  lenm = iupbs01(msgin,'LENM')
125 
126  if(lenn/=lenm) then
127  write(bort_str,'("BUFRLIB: STNDRD - INPUT MESSAGE LENGTH FROM SECTION 0",I6," DOES NOT EQUAL SUM OF ALL INDIVIDUAL '// &
128  'SECTION LENGTHS (",I6,")")') lenm,lenn
129  call bort(bort_str)
130  endif
131 
132  mbit = (lenn-4)*8
133  call upc(sevn,4,msgin,mbit,.true.)
134  if(sevn/='7777') then
135  write(bort_str,'("BUFRLIB: STNDRD - INPUT MESSAGE DOES NOT END WITH ""7777"" (ENDS WITH ",A)') sevn
136  call bort(bort_str)
137  endif
138 
139  ! Copy Sections 0 through part of Section 3 into msgot.
140 
141  mxbyto = (lmsgot*nbytw) - 8
142 
143  lbyto = iad3+7
144  if(lbyto>mxbyto) call bort(bort_arrayoverflow)
145  call mvb(msgin,1,msgot,1,lbyto)
146 
147  ! Rewrite new Section 3 in a standard form. First, locate the top-level Table A descriptor.
148 
149  found = .false.
150  ii = 10
151  do while ((.not.found).and.(ii>=8))
152  isub = iupb(msgin,iad3+ii,16)
153  call numtab(lun,isub,subset,tab,itab)
154  if((itab/=0).and.(tab=='D')) then
155  call nemtbax(lun,subset,mtyp,msbt,inod)
156  if(inod/=0) found = .true.
157  endif
158  ii = ii - 2
159  enddo
160  if(.not.found) call bort('BUFRLIB: STNDRD - TABLE A SUBSET DESCRIPTOR NOT FOUND')
161 
162  if (istdesc(isub)==0) then
163  ! isub is a non-standard Table A descriptor and needs to be expanded into an equivalent standard sequence
164  call restd_c(lun,isub,ncd,ids3)
165  else
166  ! isub is already a standard descriptor, so just copy it "as is" into the new Section 3 (i.e. no expansion is necessary)
167  ncd = 1
168  ids3(ncd) = isub
169  endif
170 
171  ! Use the edition number to determine the length of the new Section 3.
172 
173  len3 = 7+(ncd*2)
174  iben = iupbs01(msgin,'BEN')
175  if(iben<4) then
176  len3 = len3+1
177  endif
178  lbyto = lbyto + len3 - 7
179  if(lbyto>mxbyto) call bort(bort_arrayoverflow)
180 
181  ! Store the descriptors into the new Section 3.
182 
183  ibit = (iad3+7)*8
184  do n=1,ncd
185  call pkb(ids3(n),16,msgot,ibit)
186  enddo
187 
188  ! Depending on the edition number, pad out the new Section 3 with an additional zeroed-out byte to ensure an even byte count.
189 
190  if(iben<4) then
191  call pkb(0,8,msgot,ibit)
192  endif
193 
194  ! Store the length of the new Section 3.
195 
196  ibit = iad3*8
197  call pkb(len3,24,msgot,ibit)
198 
199  ! Now the tricky part - new Section 4.
200 
201  if(iupbs3(msgin,'ICMP')==1) then
202 
203  ! The data in Section 4 is compressed and is therefore already standardized, so copy it "as is" into the new Section 4.
204 
205  if((lbyto+len4+4)>mxbyto) call bort(bort_arrayoverflow)
206 
207  call mvb(msgin,iad4+1,msgot,lbyto+1,len4)
208  jbit = (lbyto+len4)*8
209 
210  else
211 
212  nad4 = iad3+len3
213 
214  ibit = (iad4+4)*8
215  jbit = (nad4+4)*8
216 
217  lbyto = lbyto + 4
218 
219  ! Copy the subsets, minus the byte counters and bit pads, into the new Section 4.
220 
221  nsub = iupbs3(msgin,'NSUB')
222 
223  subset_copy: do i=1,nsub
224  call upb(lsub,16,msgin,ibit)
225  if(nsub>1) then
226  ! Use the byte counter to copy this subset.
227  islen = lsub-2
228  else
229  ! This is the only subset in the message, and it could possibly be an overlarge (> 65530 bytes) subset, in
230  ! which case we can't rely on the value stored in the byte counter. either way, we don't really need it.
231  islen = iad4+len4-(ibit/8)
232  if (mod(len4,2)==0) islen = islen - 1
233  endif
234  do l=1,islen
235  call upb(nval,8,msgin,ibit)
236  lbyto = lbyto + 1
237  if(lbyto>mxbyto) call bort(bort_arrayoverflow)
238  call pkb(nval,8,msgot,jbit)
239  enddo
240  do k=1,8
241  kbit = ibit-k-8
242  call upb(kval,8,msgin,kbit)
243  if(kval==k) then
244  jbit = jbit-k-8
245  cycle subset_copy
246  endif
247  enddo
248  call bort('BUFRLIB: STNDRD - BIT MISMATCH COPYING SECTION 4 FROM INPUT TO OUTPUT (STANDARD) MESSAGE')
249  enddo subset_copy
250 
251  ! From this point on, we will need (at most) 6 more bytes of space within msgot in order to be able to store the entire
252  ! standardized message (i.e. we will need (at most) 2 more zeroed-out bytes in Section 4, plus the 4 bytes '7777' in
253  ! Section 5), so do a final msgot overflow check now.
254 
255  if(lbyto+6>mxbyto) call bort(bort_arrayoverflow)
256 
257  ! Pad the new Section 4 with zeroes up to the next whole byte boundary.
258 
259  do while(.not.(mod(jbit,8)==0))
260  call pkb(0,1,msgot,jbit)
261  enddo
262 
263  ! Depending on the edition number, we may need to further pad the new Section 4 with an additional zeroed-out byte in
264  ! order to ensure that the padding is up to an even byte boundary.
265 
266  if( (iben<4) .and. (mod(jbit/8,2)/=0) ) then
267  call pkb(0,8,msgot,jbit)
268  endif
269 
270  ibit = nad4*8
271  len4 = jbit/8 - nad4
272  call pkb(len4,24,msgot,ibit)
273  call pkb(0,8,msgot,ibit)
274  endif
275 
276  ! Finish the new message with an updated section 0 byte count.
277 
278  ibit = 32
279  lenn = len0+len1+len2+len3+len4+len5
280  call pkb(lenn,24,msgot,ibit)
281 
282  call pkc('7777',4,msgot,jbit)
283 
284  return
285 end subroutine stndrd
286 
297 integer function istdesc( idn ) result( iret )
298 
299  implicit none
300 
301  integer, intent(in) :: idn
302  integer if, ix, iy, iokoper
303 
304  character*6 adsc, adn30
305 
306  adsc = adn30( idn, 6 )
307 
308  read(adsc,'(I1,I2,I3)') if,ix,iy
309  if ( if == 1 ) then
310  ! adsc is a replication descriptor and therefore standard by default
311  iret = 1
312  else if ( if == 2 ) then
313  ! adsc is an operator descriptor
314  iret = iokoper( adsc )
315  else if ( ( ix < 48 ) .and. ( iy < 192 ) ) then
316  iret = 1
317  else
318  iret = 0
319  end if
320 
321  return
322 end function istdesc
subroutine bort(str)
Log an error message, then abort the application program.
Definition: borts.F90:15
subroutine upb(nval, nbits, ibay, ibit)
Decode an integer value from within a specified number of bits of an integer array,...
Definition: cidecode.F90:202
recursive integer function iupb(mbay, nbyt, nbit)
Decode an integer value from within a specified number of bits of an integer array,...
Definition: cidecode.F90:226
subroutine upc(chr, nchr, ibay, ibit, cnvnull)
Decode a character string from within a specified number of bytes of an integer array,...
Definition: cidecode.F90:26
subroutine pkc(chr, nchr, ibay, ibit)
Encode a character string within a specified number of bytes of an integer array, starting at the bit...
Definition: ciencode.F90:25
subroutine pkb(nval, nbits, ibay, ibit)
Encode an integer value within a specified number of bits of an integer array, starting at the bit im...
Definition: ciencode.F90:140
subroutine mvb(ib1, nb1, ib2, nb2, nbm)
Copy a specified number of bytes from one packed binary array to another.
Definition: copydata.F90:731
subroutine nemtbax(lun, nemo, mtyp, msbt, inod)
Get information about a Table A descriptor from the internal DX BUFR tables.
Definition: dxtable.F90:1197
subroutine numtab(lun, idn, nemo, tab, iret)
Get information about a descriptor, based on the WMO bit-wise representation of an FXY value.
Definition: fxy.F90:357
character *(*) function adn30(idn, ldn)
Convert an FXY value from its WMO bit-wise representation to a character string of length 5 or 6.
Definition: fxy.F90:18
integer function iokoper(nemo)
Check whether a specified mnemonic is a Table C operator supported by the NCEPLIBS-bufr software.
Definition: misc.F90:484
subroutine capit(str)
Capitalize all of the alphabetic characters in a string.
Definition: misc.F90:355
Wrap C NCEPLIBS-bufr functions so they can be called from within the Fortran part of the library.
Definition: bufrlib.F90:11
Declare a variable used to indicate whether output BUFR messages should be standardized.
character csmf
Flag indicating whether BUFR output messages are to be standardized; this variable is initialized to ...
Declare arrays used by various subroutines and functions to hold a temporary working copy of a Sectio...
integer, dimension(:), allocatable ids3
Temporary working copy of Section 3 descriptor list in integer form.
recursive subroutine status(lunit, lun, il, im)
Check whether a specified Fortran logical unit number is currently connected to the NCEPLIBS-bufr sof...
recursive subroutine getlens(mbay, ll, len0, len1, len2, len3, len4, len5)
Read the section lengths of a BUFR message, up to a specified point in the message.
recursive integer function iupbs01(mbay, s01mnem)
Read a specified value from within Section 0 or Section 1 of a BUFR message.
Definition: s013vals.F90:247
recursive integer function iupbs3(mbay, s3mnem)
Read a specified value from within Section 3 of a BUFR message.
Definition: s013vals.F90:349
subroutine stdmsg(cf)
Specify whether BUFR messages output by future calls to message-writing subroutines and subset-writin...
Definition: standard.F90:36
recursive subroutine stndrd(lunit, msgin, lmsgot, msgot)
Standardize a BUFR message.
Definition: standard.F90:73
integer function istdesc(idn)
Given the WMO bit-wise representation of an FXY value for a descriptor, check whether the descriptor ...
Definition: standard.F90:298
subroutine x84(iin8, iout4, nval)
Encode one or more 8-byte integer values as 4-byte integer values.
Definition: x4884.F90:65