NCEPLIBS-bufr  12.1.0
compress.F90
Go to the documentation of this file.
1 
5 
32 subroutine cmpmsg(cf)
33 
34  use moda_msgcmp
35 
36  implicit none
37 
38  character, intent(in) :: cf
39  character*128 bort_str
40 
41  call capit(cf)
42  if(cf/='Y'.and. cf/='N') then
43  write(bort_str,'("BUFRLIB: CMPMSG - INPUT ARGUMENT IS ",A1,", IT MUST BE EITHER Y OR N")') cf
44  call bort(bort_str)
45  endif
46  ccmf = cf
47 
48  return
49 end subroutine cmpmsg
50 
71 recursive subroutine writcp(lunit)
72 
73  use modv_vars, only: im8b
74 
75  implicit none
76 
77  integer, intent(in) :: lunit
78  integer my_lunit
79 
80  ! Check for I8 integers.
81 
82  if(im8b) then
83  im8b=.false.
84 
85  call x84(lunit,my_lunit,1)
86  call writcp(my_lunit)
87 
88  im8b=.true.
89  return
90  endif
91 
92  call cmpmsg('Y')
93  call writsb(lunit)
94  call cmpmsg('N')
95 
96  return
97 end subroutine writcp
98 
109 subroutine rdcmps(lun)
110 
111  use modv_vars, only: bmiss, mxrst
112 
113  use moda_usrint
114  use moda_msgcwd
115  use moda_bitbuf
116  use moda_tables
117  use moda_rlccmn
118  use moda_stcode
119 
120  implicit none
121 
122  integer, intent(in) :: lun
123  integer*8 :: ival, lref, ninc, lps
124  integer nsbs, jbit, lbit, nbit, n, node, ityp, linc, lre4, nin4, nbmp, nchr, lelm, ibsv, igetrfel, icbfms
125 
126  real*8 rval, ups
127 
128  character*128 bort_str
129  character*8 cref, cval
130 
131  equivalence(cval,rval)
132 
133  ! Statement function to compute BUFR "missing value" for field of length lbit bits (all bits "on")
134  lps(lbit) = max(2_8**(lbit)-1,1)
135 
136  ! Setup the subset template
137 
138  call usrtpl(lun,1,1)
139 
140  ! Uncompress a subset into the val array according to Table B
141 
142  nsbs = nsub(lun)
143 
144  ! Note that we are going to unpack the (nsbs)th subset from within the current BUFR message.
145 
146  ibit = mbyt(lun)
147  nrst = 0
148 
149  ! Loop through each element of the subset, including immediately resolving any replication sequences by emulating recursion
150  ! via an explicit goto statement.
151 
152  n = 0
153  11 do n=n+1,nval(lun)
154  node = inv(n,lun)
155  nrfelm(n,lun) = igetrfel(n,lun)
156  nbit = ibt(node)
157  ityp = itp(node)
158 
159  ! In each of the following code blocks, the "local reference value" for the element is determined first, followed by the
160  ! 6-bit value which indicates how many bits are used to store the increment (i.e. offset) from this "local reference value".
161  ! Then, we jump ahead to where this increment is stored for this particular subset, unpack it, and add it to the
162  ! "local reference value" to determine the final uncompressed value for this element from this subset. Note that, if an
163  ! element has the same final uncompressed value for each subset in the message, then the encoding rules for BUFR compression
164  ! dictate that the "local reference value" will be equal to this value, the 6-bit increment length indicator will have a
165  ! value of zero, and the actual increments themselves will be omitted from the message.
166 
167  if(ityp==1.or.ityp==2) then
168  ! This is a numeric element.
169  if(nbit<=32) then
170  call upb(lre4,nbit,mbay(1,lun),ibit)
171  call upb(linc,6,mbay(1,lun),ibit)
172  jbit = ibit + linc*(nsbs-1)
173  call upb(nin4,linc,mbay(1,lun),jbit)
174  lref = lre4
175  ninc = nin4
176  elseif(nbit<=64) then
177  call up8(lref,nbit,mbay(1,lun),ibit)
178  call upb(linc,6,mbay(1,lun),ibit)
179  jbit = ibit + linc*(nsbs-1)
180  call up8(ninc,linc,mbay(1,lun),jbit)
181  endif
182  if(ninc==lps(linc)) then
183  ival = lps(nbit)
184  else
185  ival = lref + ninc
186  endif
187  if(ityp==1) then
188  nbmp = int(ival)
189  call usrtpl(lun,n,nbmp)
190  if (iscodes(lun) /= 0) return
191  goto 11
192  endif
193  if(ival<lps(nbit)) val(n,lun) = ups(ival,node)
194  call strbtm(n,lun)
195  ibit = ibit + linc*msub(lun)
196  elseif(ityp==3) then
197  ! This is a character element. If there are more than 8 characters, then only the first 8 will be unpacked by this
198  ! routine, and a separate subsequent call to subroutine readlc() will be required to unpack the remainder of the string.
199  ! In this case, pointers will be saved within common /rlccmn/ for later use within readlc().
200  lelm = nbit/8
201  nchr = min(8,lelm)
202  ibsv = ibit
203  cref = ' '
204  call upc(cref,nchr,mbay(1,lun),ibit,.true.)
205  if(lelm>8) then
206  ibit = ibit + (lelm-8)*8
207  nrst = nrst + 1
208  if(nrst>mxrst) then
209  write(bort_str,'("BUFRLIB: RDCMPS - NUMBER OF LONG CHARACTER STRINGS EXCEEDS THE LIMIT (",I4,")")') mxrst
210  call bort(bort_str)
211  endif
212  crtag(nrst) = tag(node)
213  endif
214  ! Unpack the increment length indicator. For character elements, this length is in bytes rather than bits.
215  call upb(linc,6,mbay(1,lun),ibit)
216  if(linc==0) then
217  if(lelm>8) then
218  irnch(nrst) = lelm
219  irbit(nrst) = ibsv
220  endif
221  cval = cref
222  else
223  jbit = ibit + linc*(nsbs-1)*8
224  if(lelm>8) then
225  irnch(nrst) = linc
226  irbit(nrst) = jbit
227  endif
228  nchr = min(8,linc)
229  cval = ' '
230  call upc(cval,nchr,mbay(1,lun),jbit,.true.)
231  endif
232  if (lelm<=8 .and. icbfms(cval,nchr)/=0) then
233  val(n,lun) = bmiss
234  else
235  val(n,lun) = rval
236  endif
237  ibit = ibit + 8*linc*msub(lun)
238  endif
239  enddo
240 
241  return
242 end subroutine rdcmps
243 
258 subroutine cmsgini(lun,mesg,subset,idate,nsub,nbyt)
259 
260  implicit none
261 
262  integer, intent(in) :: lun, idate, nsub
263  integer, intent(inout) :: nbyt
264  integer, intent(out) :: mesg(*)
265  integer mtyp, msbt, inod, isub, iret, jdate, mcen, mear, mmon, mday, mour, mmin, mbit, mbyt, len1, len3, i4dy
266 
267  character*128 bort_str
268  character*8, intent(in) :: subset
269  character*4 bufr
270  character tab
271 
272  data bufr/'BUFR'/
273 
274  ! Get the message tag and type, and break up the date which can be either YYMMDDHH or YYYYMMDDHH
275 
276  call nemtba(lun,subset,mtyp,msbt,inod)
277  call nemtab(lun,subset,isub,tab,iret)
278  if(iret==0) then
279  write(bort_str,'("BUFRLIB: CMSGINI - TABLE A MESSAGE TYPE MNEMONIC ",A," NOT FOUND IN INTERNAL TABLE D ARRAYS")') subset
280  call bort(bort_str)
281  endif
282 
283  jdate = i4dy(idate)
284  mcen = mod(jdate/10**8,100)+1
285  mear = mod(jdate/10**6,100)
286  mmon = mod(jdate/10**4,100)
287  mday = mod(jdate/10**2,100)
288  mour = mod(jdate ,100)
289  mmin = 0
290 
291  if(mear==0) then
292  mcen = mcen-1
293  mear = 100
294  endif
295 
296  ! Initialize the message
297 
298  mbit = 0
299 
300  ! Section 0
301 
302  call pkc(bufr , 4 , mesg,mbit)
303  ! Note that the actual Section 0 length will be computed and stored below; for now, we're really only interested in
304  ! advancing mbit by the correct amount, so we'll just store a default value of 0.
305  call pkb( 0 , 24 , mesg,mbit)
306  call pkb( 3 , 8 , mesg,mbit)
307 
308  ! Section 1
309 
310  len1 = 18
311 
312  call pkb(len1 , 24 , mesg,mbit)
313  call pkb( 0 , 8 , mesg,mbit)
314  call pkb( 3 , 8 , mesg,mbit)
315  call pkb( 7 , 8 , mesg,mbit)
316  call pkb( 0 , 8 , mesg,mbit)
317  call pkb( 0 , 8 , mesg,mbit)
318  call pkb(mtyp , 8 , mesg,mbit)
319  call pkb(msbt , 8 , mesg,mbit)
320  call pkb( 36 , 8 , mesg,mbit)
321  call pkb( 0 , 8 , mesg,mbit)
322  call pkb(mear , 8 , mesg,mbit)
323  call pkb(mmon , 8 , mesg,mbit)
324  call pkb(mday , 8 , mesg,mbit)
325  call pkb(mour , 8 , mesg,mbit)
326  call pkb(mmin , 8 , mesg,mbit)
327  call pkb(mcen , 8 , mesg,mbit)
328 
329  ! Section 3
330 
331  len3 = 10
332 
333  call pkb(len3 , 24 , mesg,mbit)
334  call pkb( 0 , 8 , mesg,mbit)
335  call pkb(nsub , 16 , mesg,mbit)
336  call pkb( 192 , 8 , mesg,mbit)
337  call pkb(isub , 16 , mesg,mbit)
338  call pkb( 0 , 8 , mesg,mbit)
339 
340  ! Section 4
341 
342  ! Store the total length of Section 4. Remember that the input value of nbyt only contains the length of the compressed
343  ! data portion of Section 4, so we need to add four bytes to this number in order to account for the total length of
344  ! Section 4. The actual compressed data portion will be filled in later by subroutine wrcmps().
345  call pkb((nbyt+4) , 24 , mesg,mbit)
346  call pkb( 0 , 8 , mesg,mbit)
347 
348  ! Section 5
349 
350  ! This section will be filled in later by subroutine wrcmps(). However, for now, and noting that mbit currently points
351  ! to the last bit of the fourth byte of Section 4, then we have:
352  ! (total length of BUFR message (in Section 0)) =
353  ! (length of message up through fourth byte of Section 4)
354  ! + (length of compressed data portion of Section 4)
355  ! + (length of Section 5)
356  mbyt = mbit/8 + nbyt + 4
357 
358  ! For output, make nbyt point to the current location of mbit, which is the byte after which to actually begin writing the
359  ! compressed data into Section 4.
360  nbyt = mbit/8
361 
362  ! Now, store the total length of the BUFR message in Section 0.
363  mbit = 32
364  call pkb(mbyt,24,mesg,mbit)
365 
366  return
367 end subroutine cmsgini
368 
386 subroutine wrcmps(lunix)
387 
388  use modv_vars, only: mxcdv, mxcsb
389 
390  use moda_usrint
391  use moda_msgcwd
392  use moda_bitbuf
393  use moda_mgwa
394  use moda_tables
395  use moda_comprx
396  use moda_comprs
397  use moda_s01cm
398 
399  implicit none
400 
401  integer, intent(in) :: lunix
402  integer ibyt, jbit, lunit, lun, il, im, icol, i, j, node, lbyt, nbyt, nchr, ldata, iupbs01
403 
404  character*128 bort_str
405  character*8 subset
406  character czero
407 
408  logical first, kmiss, edge4, msgfull, cmpres
409 
410  real, parameter :: rln2 = 1./log(2.)
411  real range
412 
413  data first /.true./
414 
415  save first, ibyt, jbit, subset, edge4
416 
417  ! Get the unit and subset tag
418 
419  lunit = abs(lunix)
420  call status(lunit,lun,il,im)
421 
422  do while (.true.)
423 
424  if(first) then
425  ! Initialize some values in order to prepare for the creation of a new compressed BUFR message for output.
426  kbyt = 0
427  ncol = 0
428  lunc = lun
429  nrow = nval(lun)
430  subset = tag(inode(lun))(1:8)
431  first = .false.
432  flush = .false.
433  writ1 = .false.
434  ! The following call to cmsgini() is just being done to determine how many bytes (kbyt) will be taken up in a message
435  ! by the information in Sections 0, 1, 2 and 3. This in turn will allow us to determine how many compressed data subsets
436  ! will fit into Section 4 without overflowing maxbyt. Then, later on, another separate call to cmsgini() will be done to
437  ! actually initialize Sections 0, 1, 2 and 3 of the final compressed BUFR message that will be written out.
438  call cmsgini(lun,mbay(1,lun),subset,idate(lun),ncol,kbyt)
439  ! Check the edition number of the BUFR message to be created
440  edge4 = .false.
441  if(ns01v>0) then
442  i = 1
443  do while ( (.not.edge4) .and. (i<=ns01v) )
444  if( (cmnem(i)=='BEN') .and. (ivmnem(i)>=4) ) then
445  edge4 = .true.
446  else
447  i = i+1
448  endif
449  enddo
450  endif
451  endif
452 
453  if(lun/=lunc) then
454  write(bort_str,.NE.'("BUFRLIB: WRCMPS - FILE ID FOR THIS CALL (",I3,") FILE ID FOR INITIAL CALL (",I3,")'// &
455  ' - UNIT NUMBER NOW IS",I4)') lun,lunc,lunix
456  call bort(bort_str)
457  endif
458 
459  cmpres = .true.
460  if(lunix<0) then
461  ! This is a "flush" call, so clear out the buffer (note that there is no current subset to be stored!) and prepare
462  ! to write the final compressed BUFR message.
463  if(ncol<=0) return
464  flush = .true.
465  writ1 = .true.
466  icol = 1
467  elseif(ncol+1>mxcsb) then
468  ! There's no more room in the internal compression arrays for another subset, so we'll need to write out a message
469  ! containing all of the data in those arrays, then initialize a new message to hold the current subset.
470  cmpres = .false.
471  else
472  ! Check on some other possibly problematic situations
473  if(nval(lun)/=nrow) then
474  writ1 = .true.
475  icol = 1
476  elseif(nval(lun)>mxcdv) then
477  write(bort_str,'("BUFRLIB: WRCMPS - NO. OF ELEMENTS IN THE '// &
478  .GT.'SUBSET (",I6,") THE NO. OF ROWS ALLOCATED FOR THE COMPRESSION MATRIX (",I6,")")') nval(lun),mxcdv
479  call bort(bort_str)
480  elseif(ncol>0) then
481  ! Confirm that all of the nodes are the same as in the previous subset for this same BUFR message. If not, then
482  ! there may be different nested replication sequences activated in the current subset vs. in the previous subset,
483  ! even though the total number of nodes is the same.
484  do i = 1, nval(lun)
485  if ( inv(i,lun) /= jlnode(i) ) then
486  writ1 = .true.
487  icol = 1
488  exit
489  endif
490  enddo
491  endif
492  if(.not.writ1) then
493  ! Store the next subset for compression
494  ncol = ncol+1
495  icol = ncol
496  ibit = 16
497  do i=1,nval(lun)
498  node = inv(i,lun)
499  jlnode(i) = node
500  ityp(i) = itp(node)
501  iwid(i) = ibt(node)
502  if(ityp(i)==1.or.ityp(i)==2) then
503  call up8(matx(i,ncol),ibt(node),ibay,ibit)
504  elseif(ityp(i)==3) then
505  catx(i,ncol) = ' '
506  call upc(catx(i,ncol),ibt(node)/8,ibay,ibit,.true.)
507  endif
508  enddo
509  endif
510  endif
511 
512  ! Will the next subset fit into the current message? The only way to find out is to actually re-do the compression
513  ! by re-computing all of the local reference values, increments, etc. to determine the new Section 4 length.
514 
515  do while (cmpres)
516  if(ncol<=0) then
517  write(bort_str,'("BUFRLIB: WRCMPS - NO. OF COLUMNS CALCULATED '// &
518  .LE.'FOR COMPRESSION MAXRIX IS 0 (=",I6,")")') ncol
519  call bort(bort_str)
520  endif
521  ! ldata will hold the length (in bits) of the compressed data, i.e. the sum total for all data values for all data
522  ! subsets in the message
523  ldata = 0
524  do i=1,nrow
525  if(ityp(i)==1 .or. ityp(i)==2) then
526  ! Row i of the compression matrix contains numeric values, so kmis(i) will store .true. if any such values are
527  ! "missing", or .false. otherwise
528  imiss = 2_8**iwid(i)-1
529  if(icol==1) then
530  kmin(i) = imiss
531  kmax(i) = 0
532  kmis(i) = .false.
533  endif
534  do j=icol,ncol
535  if(matx(i,j)<imiss) then
536  kmin(i) = min(kmin(i),matx(i,j))
537  kmax(i) = max(kmax(i),matx(i,j))
538  else
539  kmis(i) = .true.
540  endif
541  enddo
542  kmiss = kmis(i) .and. kmin(i)<imiss
543  range = real(max(1,kmax(i)-kmin(i)+1))
544  if(ityp(i)==2 .and. (range>1. .or. kmiss)) then
545  ! The data values in row i of the compression matrix are numeric values that aren't all identical. Compute the
546  ! number of bits needed to hold the largest of the increments.
547  kbit(i) = nint(log(range)*rln2)
548  if(2**kbit(i)-1<=range) kbit(i) = kbit(i)+1
549  ! However, under no circumstances should this number ever exceed the width of the original underlying descriptor!
550  if(kbit(i)>iwid(i)) kbit(i) = iwid(i)
551  else
552  ! The data values in row i of the compression matrix are numeric values that are all identical, so the increments
553  ! will be omitted from the message.
554  kbit(i) = 0
555  endif
556  ldata = ldata + iwid(i) + 6 + ncol*kbit(i)
557  elseif(ityp(i)==3) then
558  ! Row i of the compression matrix contains character values, so kmis(i) will store .false. if all such values are
559  ! identical, OR .true. otherwise
560  if(icol==1) then
561  cstr(i) = catx(i,1)
562  kmis(i) = .false.
563  endif
564  do j=icol,ncol
565  if ( (.not.kmis(i)) .and. (cstr(i)/=catx(i,j)) ) then
566  kmis(i) = .true.
567  endif
568  enddo
569  if (kmis(i)) then
570  ! The data values in row i of the compression matrix are character values that are not all identical
571  kbit(i) = iwid(i)
572  else
573  ! The data values in row i of the compression matrix are character values that are all identical, so the
574  ! increments will be omitted from the message
575  kbit(i) = 0
576  endif
577  ldata = ldata + iwid(i) + 6 + ncol*kbit(i)
578  endif
579  enddo
580  ! Round data length up to a whole byte count
581  ibyt = (ldata+8-mod(ldata,8))/8
582  ! Depending on the edition number of the message, we need to ensure that we round to an even byte count
583  if( (.not.edge4) .and. (mod(ibyt,2)/=0) ) ibyt = ibyt+1
584  jbit = ibyt*8-ldata
585  if(msgfull(ibyt,kbyt,maxbyt)) then
586  ! The current subset will not fit into the current message. Set the flag to indicate that a message write is needed,
587  ! then go back and re-compress the Section 4 data for this message while excluding the data for the current subset,
588  ! which will be held and stored as the first subset of a new message after writing the current message.
589  writ1 = .true.
590  ncol = ncol-1
591  icol = 1
592  elseif(.not.writ1) then
593  ! Add the current subset to the current message and return
594  call usrtpl(lun,1,1)
595  nsub(lun) = -ncol
596  return
597  else
598  ! Exit the loop and proceed to write out the current message
599  cmpres = .false.
600  endif
601  enddo
602 
603  ! Write the complete compressed message. First, we need to do another call to cmsgini() to initialize Sections 0, 1, 2,
604  ! and 3 of the final compressed BUFR message that will be written out.
605 
606  call cmsgini(lun,mgwa,subset,idate(lun),ncol,ibyt)
607 
608  ! Now add the Section 4 data
609 
610  ibit = ibyt*8
611  do i=1,nrow
612  if(ityp(i)==1.or.ityp(i)==2) then
613  call pkb8(kmin(i),iwid(i),mgwa,ibit)
614  call pkb(kbit(i),6,mgwa,ibit)
615  if(kbit(i)>0) then
616  do j=1,ncol
617  if(matx(i,j)<2_8**iwid(i)-1) then
618  incr = matx(i,j)-kmin(i)
619  else
620  incr = 2_8**kbit(i)-1
621  endif
622  call pkb8(incr,kbit(i),mgwa,ibit)
623  enddo
624  endif
625  elseif(ityp(i)==3) then
626  nchr = iwid(i)/8
627  if(kbit(i)>0) then
628  call ipkm(czero,1,0)
629  do j=1,nchr
630  call pkc(czero,1,mgwa,ibit)
631  enddo
632  call pkb(nchr,6,mgwa,ibit)
633  do j=1,ncol
634  call pkc(catx(i,j),nchr,mgwa,ibit)
635  enddo
636  else
637  call pkc(cstr(i),nchr,mgwa,ibit)
638  call pkb(0,6,mgwa,ibit)
639  endif
640  endif
641  enddo
642 
643  ! Pad the end of Section 4 with zeroes up to the necessary byte count
644 
645  call pkb(0,jbit,mgwa,ibit)
646 
647  ! Add Section 5
648 
649  call pkc('7777',4,mgwa,ibit)
650 
651  ! Check that the message byte counters agree, then write the message
652 
653  if(mod(ibit,8)/=0) call bort('BUFRLIB: WRCMPS - THE NUMBER OF BITS IN THE '// &
654  'COMPRESSED BUFR MSG IS NOT A MULTIPLE OF 8 - MSG MUST END ON A BYTE BOUNDARY')
655  lbyt = iupbs01(mgwa,'LENM')
656  nbyt = ibit/8
657  if(nbyt/=lbyt) then
658  write(bort_str,'("BUFRLIB: WRCMPS - OUTPUT MESSAGE LENGTH FROM '// &
659  'SECTION 0",I6," DOES NOT EQUAL FINAL PACKED MESSAGE LENGTH (",I6,")")') lbyt,nbyt
660  call bort(bort_str)
661  endif
662 
663  call msgwrt(lunit,mgwa,nbyt)
664 
665  ! Now, unless this was a "flush" call to this subroutine, go back and initialize a new message to hold the current subset
666  ! that we weren't able to fit into the message that was just written out.
667 
668  first = .true.
669  if(flush) return
670  end do
671 
672 end subroutine wrcmps
subroutine strbtm(n, lun)
Store internal information in module moda_bitmaps if the input element is part of a bitmap.
Definition: bitmaps.F90:13
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
real *8 function ups(ival, node)
Unpack a real*8 value from an integer by applying the proper scale and reference values.
Definition: cidecode.F90:319
subroutine up8(nval, nbits, ibay, ibit)
Decode an 8-byte integer value from within a specified number of bits of an integer array,...
Definition: cidecode.F90:128
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
recursive subroutine ipkm(cbay, nbyt, n)
Encode an integer value within a specified number of bytes of a character string, up to a maximum of ...
Definition: ciencode.F90:194
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 pkb8(nval, nbits, ibay, ibit)
Encode an 8-byte integer value within a specified number of bits of an integer array,...
Definition: ciencode.F90:97
subroutine rdcmps(lun)
Read the next compressed BUFR data subset into internal arrays.
Definition: compress.F90:110
subroutine cmsgini(lun, mesg, subset, idate, nsub, nbyt)
Initialize a new BUFR message for output in compressed format.
Definition: compress.F90:259
recursive subroutine writcp(lunit)
Write a data subset into a BUFR message using compression.
Definition: compress.F90:72
subroutine wrcmps(lunix)
Write a compressed BUFR data subset.
Definition: compress.F90:387
subroutine cmpmsg(cf)
Specify whether BUFR messages output by future calls to message-writing subroutines and subset-writin...
Definition: compress.F90:33
subroutine nemtba(lun, nemo, mtyp, msbt, inod)
Get information about a Table A descriptor from the internal DX BUFR tables.
Definition: dxtable.F90:1247
subroutine nemtab(lun, nemo, idn, tab, iret)
Get information about a descriptor, based on a mnemonic.
Definition: fxy.F90:432
subroutine capit(str)
Capitalize all of the alphabetic characters in a string.
Definition: misc.F90:355
Declare arrays and variables used to store BUFR messages internally for multiple file IDs.
integer, dimension(:), allocatable ibay
Current data subset.
integer ibit
Bit pointer within ibay.
integer, dimension(:,:), allocatable mbay
Current BUFR message for each file ID.
integer, dimension(:), allocatable mbyt
Length (in bytes) of current BUFR message for each file ID.
integer maxbyt
Maximum length of an output BUFR message.
Declare arrays and variables needed for the storage of data values needed when writing compressed dat...
integer ncol
Number of data subsets in message.
integer *8 incr
Increment used when compressing non-character data values.
character *(:), dimension(:,:), allocatable catx
Character data values for all data subsets in message.
integer *8, dimension(:,:), allocatable matx
Non-character data values for all data subsets in message.
Declare arrays and variable needed for the storage of data values needed when writing compressed data...
character *(:), dimension(:), allocatable cstr
Character data value, if corresponding ityp value is set to 3.
integer kbyt
Number of bytes required to store Sections 0, 1, 2, and 3 of message.
logical flush
Flush flag.
integer nrow
Number of data values for each data subset in message.
integer *8 imiss
"Missing" value used when compressing non-character data values.
integer *8, dimension(:), allocatable kmax
Maximum of each data value across all data subsets in message.
integer, dimension(:), allocatable jlnode
Jump/link table node corresponding to each data value.
logical writ1
Write-out flag.
integer, dimension(:), allocatable ityp
Type of each data value:
integer, dimension(:), allocatable iwid
Bit width of underlying data descriptor as defined within Table B for each data value.
integer lunc
File ID for output file.
integer, dimension(:), allocatable kbit
Number of bits needed to hold the increments for this data value within each data subset of the messa...
logical, dimension(:), allocatable kmis
"Missing" values flag.
integer *8, dimension(:), allocatable kmin
Minimum of each data value across all data subsets in message.
Declare an array used by various subroutines and functions to hold a temporary working copy of a BUFR...
integer, dimension(:), allocatable mgwa
Temporary working copy of BUFR message.
Declare a variable used to indicate whether output BUFR messages should be compressed.
character ccmf
Flag indicating whether BUFR output messages are to be compressed; this variable is initialized to a ...
Declare arrays used to store information about the current BUFR message that is in the process of bei...
integer, dimension(:), allocatable inode
Table A mnemonic for type of BUFR message.
integer, dimension(:), allocatable idate
Section 1 date-time of message.
integer, dimension(:), allocatable msub
Total number of data subsets in message.
integer, dimension(:), allocatable nsub
Current subset pointer within message.
Declare arrays and variables needed to store information about long character strings (greater than 8...
integer nrst
Number of long character strings in data subset.
integer, dimension(:), allocatable irnch
Lengths (in bytes) of long character strings.
integer, dimension(:), allocatable irbit
Pointers in data subset to first bits of long character strings.
character *10, dimension(:), allocatable crtag
Table B mnemonics associated with long character strings.
Declare arrays and variables used to store custom values for certain mnemonics within Sections 0 and ...
integer, dimension(:), allocatable ivmnem
Custom values for use within Sections 0 and 1 of all future output BUFR messages written to all Fortr...
integer ns01v
Number of custom values stored.
character *8, dimension(:), allocatable cmnem
Section 0 and 1 mnemonics corresponding to ivmnem.
Declare an array used to store a status code for each file ID if an error or other abnormal result oc...
integer, dimension(:), allocatable iscodes
Abnormal status codes.
Declare arrays and variables used to store the internal jump/link table.
integer, dimension(:), allocatable ibt
Bit widths corresponding to tag and typ:
character *10, dimension(:), allocatable tag
Mnemonics in the jump/link table.
integer, dimension(:), allocatable itp
Integer type values corresponding to typ:
Declare arrays used to store data values and associated metadata for the current BUFR data subset in ...
integer, dimension(:), allocatable nval
Number of data values in BUFR data subset.
real *8, dimension(:,:), allocatable, target val
Data values.
integer, dimension(:,:), allocatable, target inv
Inventory pointer which links each data value to its corresponding node in the internal jump/link tab...
integer, dimension(:,:), allocatable nrfelm
Referenced data value, for data values which refer to a previous data value in the BUFR data subset v...
recursive subroutine status(lunit, lun, il, im)
Check whether a specified Fortran logical unit number is currently connected to the NCEPLIBS-bufr sof...
subroutine msgwrt(lunit, mesg, mgbyt)
Perform final checks and updates on a BUFR message before writing it to a specified Fortran logical u...
subroutine usrtpl(lun, invn, nbmp)
Expand a subset template within internal arrays.
recursive subroutine writsb(lunit)
Write a complete data subset into a BUFR message, for eventual output to logical unit lunit.
subroutine x84(iin8, iout4, nval)
Encode one or more 8-byte integer values as 4-byte integer values.
Definition: x4884.F90:65