38 character,
intent(in) :: cf
39 character*128 bort_str
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
73 use modv_vars,
only: im8b
77 integer,
intent(in) :: lunit
85 call x84(lunit,my_lunit,1)
111 use modv_vars,
only: bmiss, mxrst
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
128 character*128 bort_str
129 character*8 cref, cval
131 equivalence(cval,rval)
134 lps(lbit) = max(2_8**(lbit)-1,1)
153 11
do n=n+1,
nval(lun)
155 nrfelm(n,lun) = igetrfel(n,lun)
167 if(ityp==1.or.ityp==2)
then
172 jbit =
ibit + linc*(nsbs-1)
173 call upb(nin4,linc,
mbay(1,lun),jbit)
176 elseif(nbit<=64)
then
179 jbit =
ibit + linc*(nsbs-1)
180 call up8(ninc,linc,
mbay(1,lun),jbit)
182 if(ninc==lps(linc))
then
193 if(ival<lps(nbit))
val(n,lun) =
ups(ival,node)
209 write(bort_str,
'("BUFRLIB: RDCMPS - NUMBER OF LONG CHARACTER STRINGS EXCEEDS THE LIMIT (",I4,")")') mxrst
223 jbit =
ibit + linc*(nsbs-1)*8
230 call upc(cval,nchr,
mbay(1,lun),jbit,.true.)
232 if (lelm<=8 .and. icbfms(cval,nchr)/=0)
then
258 subroutine cmsgini(lun,mesg,subset,idate,nsub,nbyt)
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
267 character*128 bort_str
268 character*8,
intent(in) :: subset
276 call nemtba(lun,subset,mtyp,msbt,inod)
277 call nemtab(lun,subset,isub,tab,iret)
279 write(bort_str,
'("BUFRLIB: CMSGINI - TABLE A MESSAGE TYPE MNEMONIC ",A," NOT FOUND IN INTERNAL TABLE D ARRAYS")') subset
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)
302 call pkc(bufr , 4 , mesg,mbit)
305 call pkb( 0 , 24 , mesg,mbit)
306 call pkb( 3 , 8 , mesg,mbit)
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)
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)
345 call pkb((nbyt+4) , 24 , mesg,mbit)
346 call pkb( 0 , 8 , mesg,mbit)
356 mbyt = mbit/8 + nbyt + 4
364 call pkb(mbyt,24,mesg,mbit)
388 use modv_vars,
only: mxcdv, mxcsb
401 integer,
intent(in) :: lunix
402 integer ibyt, jbit, lunit, lun, il, im, icol, i, j, node, lbyt, nbyt, nchr, ldata, iupbs01
404 character*128 bort_str
408 logical first, kmiss, edge4, msgfull, cmpres
410 real,
parameter :: rln2 = 1./log(2.)
415 save first, ibyt, jbit, subset, edge4
420 call status(lunit,lun,il,im)
443 do while ( (.not.edge4) .and. (i<=
ns01v) )
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
467 elseif(
ncol+1>mxcsb)
then
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
504 elseif(
ityp(i)==3)
then
517 write(bort_str,
'("BUFRLIB: WRCMPS - NO. OF COLUMNS CALCULATED '// &
518 .LE.
'FOR COMPRESSION MAXRIX IS 0 (=",I6,")")')
ncol
543 range = real(max(1,
kmax(i)-
kmin(i)+1))
544 if(
ityp(i)==2 .and. (range>1. .or. kmiss))
then
547 kbit(i) = nint(log(range)*rln2)
557 elseif(
ityp(i)==3)
then
581 ibyt = (ldata+8-mod(ldata,8))/8
583 if( (.not.edge4) .and. (mod(ibyt,2)/=0) ) ibyt = ibyt+1
592 elseif(.not.
writ1)
then
625 elseif(
ityp(i)==3)
then
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')
658 write(bort_str,
'("BUFRLIB: WRCMPS - OUTPUT MESSAGE LENGTH FROM '// &
659 'SECTION 0",I6," DOES NOT EQUAL FINAL PACKED MESSAGE LENGTH (",I6,")")') lbyt,nbyt
subroutine strbtm(n, lun)
Store internal information in module moda_bitmaps if the input element is part of a bitmap.
subroutine bort(str)
Log an error message, then abort the application program.
subroutine upb(nval, nbits, ibay, ibit)
Decode an integer value from within a specified number of bits of an integer array,...
real *8 function ups(ival, node)
Unpack a real*8 value from an integer by applying the proper scale and reference values.
subroutine up8(nval, nbits, ibay, ibit)
Decode an 8-byte integer value from within a specified number of bits of an integer array,...
subroutine upc(chr, nchr, ibay, ibit, cnvnull)
Decode a character string from within a specified number of bytes of an integer array,...
subroutine pkc(chr, nchr, ibay, ibit)
Encode a character string within a specified number of bytes of an integer array, starting at the bit...
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 ...
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...
subroutine pkb8(nval, nbits, ibay, ibit)
Encode an 8-byte integer value within a specified number of bits of an integer array,...
subroutine rdcmps(lun)
Read the next compressed BUFR data subset into internal arrays.
subroutine cmsgini(lun, mesg, subset, idate, nsub, nbyt)
Initialize a new BUFR message for output in compressed format.
recursive subroutine writcp(lunit)
Write a data subset into a BUFR message using compression.
subroutine wrcmps(lunix)
Write a compressed BUFR data subset.
subroutine cmpmsg(cf)
Specify whether BUFR messages output by future calls to message-writing subroutines and subset-writin...
subroutine nemtba(lun, nemo, mtyp, msbt, inod)
Get information about a Table A descriptor from the internal DX BUFR tables.
subroutine nemtab(lun, nemo, idn, tab, iret)
Get information about a descriptor, based on a mnemonic.
subroutine capit(str)
Capitalize all of the alphabetic characters in a string.
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.
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.