90 COMMON /maxcmp/ maxcmb,maxrow,maxcol,ncmsgs,ncsubs,ncbyts
92 CHARACTER*128 bort_str
108 LOGICAL first,kmiss,edge4
112 SAVE first,ibyt,jbit,subset,edge4
122 CALL
status(lunit,lun,il,im)
133 subset = tag(inode(lun))
147 CALL
cmsgini(lun,mbay(1,lun),subset,idate(lun),ncol,kbyt)
154 DO WHILE ( (.NOT.edge4) .AND. (ii.LE.ns01v) )
155 IF( (cmnem(ii).EQ.
'BEN') .AND. (ivmnem(ii).GE.4) )
THEN
165 IF(lun.NE.lunc) goto 900
172 IF(ncol.EQ.0) goto 100
184 IF(ncol+1.GT.mxcsb)
THEN
186 ELSEIF(nval(lun).NE.nrow)
THEN
190 ELSEIF(nval(lun).GT.mxcdv)
THEN
209 IF(ityp(i).EQ.1.OR.ityp(i).EQ.2)
THEN
210 CALL
upb(matx(i,ncol),ibt(node),ibay,ibit)
211 ELSEIF(ityp(i).EQ.3)
THEN
212 CALL
upc(catx(i,ncol),ibt(node)/8,ibay,ibit,.true.)
224 IF(ncol.LE.0) goto 902
226 IF(ityp(i).EQ.1 .OR. ityp(i).EQ.2)
THEN
240 IF(matx(i,j).LT.imiss)
THEN
241 kmin(i) = min(kmin(i),matx(i,j))
242 kmax(i) = max(kmax(i),matx(i,j))
247 kmiss = kmis(i).AND.kmin(i).LT.imiss
248 range = max(1,kmax(i)-kmin(i)+1)
249 IF(ityp(i).EQ.1.AND.range.GT.1)
THEN
264 ELSEIF(ityp(i).EQ.2.AND.(range.GT.1..OR.kmiss))
THEN
271 kbit(i) = nint(log(range)*rln2)
272 IF(2**kbit(i)-1.LE.range) kbit(i) = kbit(i)+1
278 IF(kbit(i).GT.iwid(i)) kbit(i) = iwid(i)
287 ldata = ldata + iwid(i) + 6 + ncol*kbit(i)
288 ELSEIF(ityp(i).EQ.3)
THEN
300 IF ( (.NOT.kmis(i)) .AND. (cstr(i).NE.catx(i,j)) )
THEN
318 ldata = ldata + iwid(i) + 6 + ncol*kbit(i)
325 ibyt = (ldata+8-mod(ldata,8))/8
330 IF( (.NOT.edge4) .AND. (mod(ibyt,2).NE.0) ) ibyt = ibyt+1
337 IF(
msgfull(ibyt,kbyt,maxcmb))
THEN
350 ELSEIF(.NOT.writ1)
THEN
366 50 CALL
cmsgini(lun,mgwa,subset,idate(lun),ncol,ibyt)
372 IF(ityp(i).EQ.1.OR.ityp(i).EQ.2)
THEN
373 CALL
pkb(kmin(i),iwid(i),mgwa,ibit)
374 CALL
pkb(kbit(i), 6,mgwa,ibit)
375 IF(kbit(i).GT.0)
THEN
377 IF(matx(i,j).LT.2**iwid(i)-1)
THEN
378 incr = matx(i,j)-kmin(i)
382 CALL
pkb(incr,kbit(i),mgwa,ibit)
385 ELSEIF(ityp(i).EQ.3)
THEN
387 IF(kbit(i).GT.0)
THEN
390 CALL
pkc(czero,1,mgwa,ibit)
392 CALL
pkb(nchr, 6,mgwa,ibit)
394 CALL
pkc(catx(i,j),nchr,mgwa,ibit)
397 CALL
pkc(cstr(i),nchr,mgwa,ibit)
398 CALL
pkb( 0, 6,mgwa,ibit)
409 CALL
pkb( 0,jbit,mgwa,ibit)
413 CALL
pkc(
'7777', 4,mgwa,ibit)
418 IF(mod(ibit,8).NE.0) goto 904
421 IF(nbyt.NE.lbyt) goto 905
423 CALL
msgwrt(lunit,mgwa,nbyt)
425 maxrow = max(maxrow,nrow)
426 maxcol = max(maxcol,ncol)
439 IF(.NOT.flush) goto 1
445 900
WRITE(bort_str,
'("BUFRLIB: WRCMPS - I/O STREAM INDEX FOR THIS '//
446 . .NE.
'CALL (",I3,") I/O STREAM INDEX FOR INITIAL CALL (",I3,")'//
447 .
' - UNIT NUMBER NOW IS",I4)') lun,lunc,lunix
449 901
WRITE(bort_str,
'("BUFRLIB: WRCMPS - NO. OF ELEMENTS IN THE '//
450 . .GT.
'SUBSET (",I6,") THE NO. OF ROWS ALLOCATED FOR THE '//
451 .
'COMPRESSION MATRIX (",I6,")")') nval(lun),mxcdv
453 902
WRITE(bort_str,
'("BUFRLIB: WRCMPS - NO. OF COLUMNS CALCULATED '//
454 . .LE.
'FOR COMPRESSION MAXRIX IS 0 (=",I6,")")') ncol
456 903 CALL
bort(
'BUFRLIB: WRCMPS - MISSING DELAYED REPLICATION FACTOR')
457 904 CALL
bort(
'BUFRLIB: WRCMPS - THE NUMBER OF BITS IN THE '//
458 .
'COMPRESSED BUFR MSG IS NOT A MULTIPLE OF 8 - MSG MUST END ON '//
459 .
' A BYTE BOUNDARY')
460 905
WRITE(bort_str,
'("BUFRLIB: WRCMPS - OUTPUT MESSAGE LENGTH FROM '//
461 .
'SECTION 0",I6," DOES NOT EQUAL FINAL PACKED MESSAGE LENGTH ("'//
462 .
',I6,")")') lbyt,nbyt
subroutine msgwrt(LUNIT, MESG, MGBYT)
This subroutine performs final checks and updates on a BUFR message before writing it to a specified ...
subroutine upb(NVAL, NBITS, IBAY, IBIT)
THIS SUBROUTINE UNPACKS AND RETURNS A BINARY INTEGER CONTAINED WITHIN NBITS BITS OF IBAY...
subroutine pkc(CHR, NCHR, IBAY, IBIT)
This subroutine encodes a character string within a specified number of bits of an integer array...
subroutine usrtpl(LUN, INVN, NBMP)
THIS SUBROUTINE STORES THE SUBSET TEMPLATE INTO INTERNAL SUBSET ARRAYS IN MODULE USRINT FOR CASES OF ...
subroutine wrcmps(LUNIX)
THIS SUBROUTINE PACKS UP THE CURRENT SUBSET WITHIN MEMORY (ARRAY IBAY IN MODULE BITBUF), STORING IT FOR COMPRESSION.
subroutine cmsgini(LUN, MESG, SUBSET, IDATE, NSUB, NBYT)
THIS SUBROUTINE INITIALIZES A NEW BUFR MESSAGE FOR OUTPUT IN COMPRESSED BUFR.
LOGICAL function msgfull(MSIZ, ITOADD, MXSIZ)
This function determines whether the current data subset in the internal arrays will fit within the c...
subroutine upc(CHR, NCHR, IBAY, IBIT, CNVNULL)
THIS SUBROUTINE UNPACKS AND RETURNS A CHARACTER STRING OF LENGTH NCHR CONTAINED WITHIN NCHR BYTES OF ...
This module contains array and variable declarations used to store the internal jump/link table...
subroutine status(LUNIT, LUN, IL, IM)
This subroutine checks whether a specified Fortran logical unit number is currently connected to the ...
subroutine ipkm(CBAY, NBYT, N)
This subroutine encodes an integer value within a specified number of bytes of a character string...
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
subroutine pkb(NVAL, NBITS, IBAY, IBIT)
This subroutine encodes an integer value within a specified number of bits of an integer array...
This module contains array and variable declarations used to store BUFR messages internally for multi...
function iupbs01(MBAY, S01MNEM)
This function returns a specified value from within Section 0 or Section 1 of a BUFR message...