wrcmps.f

Go to the documentation of this file.

C> @file
C> @brief Write a compressed BUFR data subset.
C>
C> @author Woollen @date 2002-05-14
 
C> This subroutine packs up the current subset within memory
C> (array ibay in module @ref moda_bitbuf), storing it for compression.
C> It then tries to add it to the compressed BUFR message that is
C> currently open within memory for abs(lunix) (array mgwa). If the
C> subset will not fit into the currently open message, then that
C> compressed message is flushed to lunix and a new one is created in
C> order to hold the current subset (still stored for compression).
C> This subroutine performs functions similar to NCEPLIBS-bufr
C> subroutine msgupd() except that it acts on compressed bufr messages.
C>
C> @param[in] lunix - integer: absolute value is fortran logical unit
C> number for bufr file (if lunix is less than zero, this is a "flush"
C> call and the buffer must be cleared out)
C>
C> @author Woollen @date 2002-05-14
 
      SUBROUTINE wrcmps(LUNIX)
 
      USE modv_mxcdv
      USE modv_mxcsb
 
      USE moda_usrint
      USE moda_msgcwd
      USE moda_bitbuf
      USE moda_mgwa
      USE moda_tables
      USE moda_comprx
      USE moda_comprs
      USE moda_s01cm
 
      COMMON /maxcmp/ maxcmb,maxrow,maxcol,ncmsgs,ncsubs,ncbyts
 
      CHARACTER*128 BORT_STR
      CHARACTER*8   SUBSET
      CHARACTER*1   CZERO
 
      LOGICAL MSGFULL
 
C     NOTE THE FOLLOWING LOGICAL FLAGS:
C         FIRST - KEEPS TRACK OF WHETHER THE CURRENT SUBSET IS THE
C                 FIRST SUBSET OF A NEW MESSAGE
C         FLUSH - KEEPS TRACK OF WHETHER THIS SUBROUTINE WAS CALLED
C                 WITH LUNIX < 0 IN ORDER TO FORCIBLY FLUSH ANY
C                 PARTIALLY-COMPLETED MESSAGE WITHIN MEMORY (PRESUMABLY
C                 IMMEDIATELY PRIOR TO EXITING THE CALLING PROGRAM!)
C         WRIT1 - KEEPS TRACK OF WHETHER THE CURRENT MESSAGE NEEDS
C                 TO BE WRITTEN OUT
 
      LOGICAL       FIRST,KMISS,EDGE4
 
      DATA      first /.true./
 
      SAVE      first,ibyt,jbit,subset,edge4
 
C-----------------------------------------------------------------------
      rln2 = 1./log(2.)
C-----------------------------------------------------------------------
 
C  GET THE UNIT AND SUBSET TAG
C  ---------------------------
 
      lunit = abs(lunix)
      CALL status(lunit,lun,il,im)
 
C  IF THIS IS A "FIRST" CALL, THEN INITIALIZE SOME VALUES IN
C  ORDER TO PREPARE FOR THE CREATION OF A NEW COMPRESSED BUFR
C  MESSAGE FOR OUTPUT.
 
  1   IF(first) THEN
         kbyt = 0
         ncol = 0
         lunc = lun
         nrow = nval(lun)
         subset = tag(inode(lun))(1:8)
         first = .false.
         FLUSH = .false.
         writ1 = .false.
 
C        THIS CALL TO CMSGINI IS DONE SOLELY IN ORDER TO DETERMINE
C        HOW MANY BYTES (KBYT) WILL BE TAKEN UP IN A MESSAGE BY
C        THE INFORMATION IN SECTIONS 0, 1, 2 AND 3.  THIS WILL
C        ALLOW US TO KNOW HOW MANY COMPRESSED DATA SUBSETS WILL
C        FIT INTO SECTION 4 WITHOUT OVERFLOWING MAXCMB.  LATER ON,
C        A SEPARATE CALL TO CMSGINI WILL BE DONE TO ACTUALLY
C        INITIALIZE SECTIONS 0, 1, 2 AND 3 OF THE FINAL COMPRESSED
C        BUFR MESSAGE THAT WILL BE WRITTEN OUT.
 
         CALL cmsgini(lun,mbay(1,lun),subset,idate(lun),ncol,kbyt)
 
C        CHECK THE EDITION NUMBER OF THE BUFR MESSAGE TO BE CREATED
 
         edge4 = .false.
         IF(ns01v.GT.0) THEN
           ii = 1
           DO WHILE ( (.NOT.edge4) .AND. (ii.LE.ns01v) )
             IF( (cmnem(ii).EQ.'BEN') .AND. (ivmnem(ii).GE.4) ) THEN
               edge4 = .true.
             ELSE
               ii = ii+1
             ENDIF
           ENDDO
         ENDIF
 
      ENDIF
 
      IF(lun.NE.lunc) GOTO 900
 
C  IF THIS IS A "FLUSH" CALL, THEN CLEAR OUT THE BUFFER (NOTE THAT
C  THERE IS NO CURRENT SUBSET TO BE STORED!) AND PREPARE TO WRITE
C  THE FINAL COMPRESSED BUFR MESSAGE.
 
      IF(lunix.LT.0) THEN
         IF(ncol.EQ.0) GOTO 100
         IF(ncol.GT.0) THEN
            FLUSH = .true.
            writ1 = .true.
            icol = 1
            GOTO 20
         ENDIF
      ENDIF
 
C  CHECK ON SOME OTHER POSSIBLY PROBLEMATIC SITUATIONS
C  ---------------------------------------------------
 
      IF(ncol+1.GT.mxcsb) THEN
         GOTO 50
      ELSEIF(nval(lun).NE.nrow) THEN
         writ1 = .true.
         icol = 1
         GOTO 20
      ELSEIF(nval(lun).GT.mxcdv) THEN
         GOTO 901
      ENDIF
 
C  STORE THE NEXT SUBSET FOR COMPRESSION
C  -------------------------------------
 
C     WILL THE CURRENT SUBSET FIT INTO THE CURRENT MESSAGE?
C     (UNFORTUNATELY, THE ONLY WAY TO FIND OUT IS TO ACTUALLY
C     RE-DO THE COMPRESSION BY RE-COMPUTING ALL OF THE LOCAL
C     REFERENCE VALUES, INCREMENTS, ETC.)
 
      ncol = ncol+1
      icol = ncol
      ibit = 16
      DO i=1,nval(lun)
      node = inv(i,lun)
      ityp(i) = itp(node)
      iwid(i) = ibt(node)
      IF(ityp(i).EQ.1.OR.ityp(i).EQ.2) THEN
         CALL up8(matx(i,ncol),ibt(node),ibay,ibit)
      ELSEIF(ityp(i).EQ.3) THEN
         CALL upc(catx(i,ncol),ibt(node)/8,ibay,ibit,.true.)
      ENDIF
      ENDDO
 
C  COMPUTE THE MIN,MAX,WIDTH FOR EACH ROW - ACCUMULATE LENGTH
C  ----------------------------------------------------------
 
C     LDATA WILL HOLD THE LENGTH IN BITS OF THE COMPRESSED DATA
C     (I.E. THE SUM TOTAL FOR ALL DATA VALUES FOR ALL SUBSETS
C     IN THE MESSAGE)
 
 20   ldata = 0
      IF(ncol.LE.0) GOTO 902
      DO i=1,nrow
      IF(ityp(i).EQ.1 .OR. ityp(i).EQ.2) THEN
 
C        ROW I OF THE COMPRESSION MATRIX CONTAINS NUMERIC VALUES,
C        SO KMIS(I) WILL STORE:
C          .FALSE. IF ALL SUCH VALUES ARE NON-"MISSING"
C          .TRUE. OTHERWISE
 
         imiss = 2**iwid(i)-1
         IF(icol.EQ.1) THEN
            kmin(i) = imiss
            kmax(i) = 0
            kmis(i) = .false.
         ENDIF
         DO j=icol,ncol
         IF(matx(i,j).LT.imiss) THEN
            kmin(i) = min(kmin(i),matx(i,j))
            kmax(i) = max(kmax(i),matx(i,j))
         ELSE
            kmis(i) = .true.
         ENDIF
         ENDDO
         kmiss = kmis(i).AND.kmin(i).LT.imiss
         range = real(max(1,kmax(i)-kmin(i)+1))
         IF(ityp(i).EQ.1.AND.range.GT.1) THEN
 
C           THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX
C           ARE DELAYED DESCRIPTOR REPLICATION FACTORS AND ARE
C           NOT ALL IDENTICAL (I.E. RANGE.GT.1), SO WE CANNOT
C           COMPRESS ALL OF THESE SUBSETS INTO THE SAME MESSAGE.
C           ASSUMING THAT NONE OF THE VALUES ARE "MISSING",
C           EXCLUDE THE LAST SUBSET (I.E. THE LAST COLUMN
C           OF THE MATRIX) AND TRY RE-COMPRESSING AGAIN.
 
            IF(kmiss) GOTO 903
            writ1 = .true.
            ncol = ncol-1
            icol = 1
            GOTO 20
         ELSEIF(ityp(i).EQ.2.AND.(range.GT.1..OR.kmiss)) THEN
 
C           THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX
C           ARE NUMERIC VALUES THAT ARE NOT ALL IDENTICAL.
C           COMPUTE THE NUMBER OF BITS NEEDED TO HOLD THE
C           LARGEST OF THE INCREMENTS.
 
            kbit(i) = nint(log(range)*rln2)
            IF(2**kbit(i)-1.LE.range) kbit(i) = kbit(i)+1
 
C           HOWEVER, UNDER NO CIRCUMSTANCES SHOULD THIS NUMBER
C           EVER EXCEED THE WIDTH OF THE ORIGINAL UNDERLYING
C           DESCRIPTOR!
 
            IF(kbit(i).GT.iwid(i)) kbit(i) = iwid(i)
         ELSE
 
C           THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX
C           ARE NUMERIC VALUES THAT ARE ALL IDENTICAL, SO THE
C           INCREMENTS WILL BE OMITTED FROM THE MESSAGE.
 
            kbit(i) = 0
         ENDIF
         ldata = ldata + iwid(i) + 6 + ncol*kbit(i)
      ELSEIF(ityp(i).EQ.3) THEN
 
C        ROW I OF THE COMPRESSION MATRIX CONTAINS CHARACTER VALUES,
C        SO KMIS(I) WILL STORE:
C          .FALSE. IF ALL SUCH VALUES ARE IDENTICAL
C          .TRUE. OTHERWISE
 
         IF(icol.EQ.1) THEN
            cstr(i) = catx(i,1)
            kmis(i) = .false.
         ENDIF
         DO j=icol,ncol
            IF ( (.NOT.kmis(i)) .AND. (cstr(i).NE.catx(i,j)) ) THEN
               kmis(i) = .true.
            ENDIF
         ENDDO
         IF (kmis(i)) THEN
 
C           THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX
C           ARE CHARACTER VALUES THAT ARE NOT ALL IDENTICAL.
 
            kbit(i) = iwid(i)
         ELSE
 
C           THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX
C           ARE CHARACTER VALUES THAT ARE ALL IDENTICAL, SO THE
C           INCREMENTS WILL BE OMITTED FROM THE MESSAGE.
 
            kbit(i) = 0
         ENDIF
         ldata = ldata + iwid(i) + 6 + ncol*kbit(i)
      ENDIF
      ENDDO
 
C  ROUND DATA LENGTH UP TO A WHOLE BYTE COUNT
C  ------------------------------------------
 
      ibyt = (ldata+8-mod(ldata,8))/8
 
C     DEPENDING ON THE EDITION NUMBER OF THE MESSAGE, WE NEED TO ENSURE
C     THAT WE ROUND TO AN EVEN BYTE COUNT
 
      IF( (.NOT.edge4) .AND. (mod(ibyt,2).NE.0) ) ibyt = ibyt+1
 
      jbit = ibyt*8-ldata
 
C  CHECK ON COMPRESSED MESSAGE LENGTH, EITHER WRITE/RESTORE OR RETURN
C  ------------------------------------------------------------------
 
      IF(msgfull(ibyt,kbyt,maxcmb)) THEN
 
C        THE CURRENT SUBSET WILL NOT FIT INTO THE CURRENT MESSAGE.
C        SET THE FLAG TO INDICATE THAT A MESSAGE WRITE IS NEEDED,
C        THEN GO BACK AND RE-COMPRESS THE SECTION 4 DATA FOR THIS
C        MESSAGE WHILE *EXCLUDING* THE DATA FOR THE CURRENT SUBSET
C        (WHICH WILL BE HELD AND STORED AS THE FIRST SUBSET OF A
C        NEW MESSAGE AFTER WRITING THE CURRENT MESSAGE!).
 
         writ1 = .true.
         ncol = ncol-1
         icol = 1
         GOTO 20
      ELSEIF(.NOT.writ1) THEN
 
C        ADD THE CURRENT SUBSET TO THE CURRENT MESSAGE AND RETURN.
 
         CALL usrtpl(lun,1,1)
         nsub(lun) = -ncol
         GOTO 100
      ENDIF
 
C  WRITE THE COMPLETE COMPRESSED MESSAGE
C  -------------------------------------
 
C     NOW IT IS TIME TO DO THE "REAL" CALL TO CMSGINI TO ACTUALLY
C     INITIALIZE SECTIONS 0, 1, 2 AND 3 OF THE FINAL COMPRESSED
C     BUFR MESSAGE THAT WILL BE WRITTEN OUT.
 
 50   CALL cmsgini(lun,mgwa,subset,idate(lun),ncol,ibyt)
 
C     NOW ADD THE SECTION 4 DATA.
 
      ibit = ibyt*8
      DO i=1,nrow
      IF(ityp(i).EQ.1.OR.ityp(i).EQ.2) THEN
         CALL pkb8(kmin(i),iwid(i),mgwa,ibit)
         CALL pkb(kbit(i),      6,mgwa,ibit)
         IF(kbit(i).GT.0) THEN
            DO j=1,ncol
            IF(matx(i,j).LT.2_8**iwid(i)-1) THEN
               incr = matx(i,j)-kmin(i)
            ELSE
               incr = 2_8**kbit(i)-1
            ENDIF
            CALL pkb8(incr,kbit(i),mgwa,ibit)
            ENDDO
         ENDIF
      ELSEIF(ityp(i).EQ.3) THEN
         nchr = iwid(i)/8
         IF(kbit(i).GT.0) THEN
            CALL ipkm(czero,1,0)
            DO j=1,nchr
               CALL pkc(czero,1,mgwa,ibit)
            ENDDO
            CALL pkb(nchr,      6,mgwa,ibit)
            DO j=1,ncol
               CALL pkc(catx(i,j),nchr,mgwa,ibit)
            ENDDO
         ELSE
            CALL pkc(cstr(i),nchr,mgwa,ibit)
            CALL pkb(      0,   6,mgwa,ibit)
         ENDIF
      ENDIF
      ENDDO
 
C  FILL IN THE END OF THE MESSAGE
C  ------------------------------
 
C     PAD THE END OF SECTION 4 WITH ZEROES UP TO THE NECESSARY
C     BYTE COUNT.
 
      CALL pkb(     0,jbit,mgwa,ibit)
 
C     ADD SECTION 5.
 
      CALL pkc('7777',   4,mgwa,ibit)
 
C  SEE THAT THE MESSAGE BYTE COUNTERS AGREE THEN WRITE A MESSAGE
C  -------------------------------------------------------------
 
      IF(mod(ibit,8).NE.0) GOTO 904
      lbyt = iupbs01(mgwa,'LENM')
      nbyt = ibit/8
      IF(nbyt.NE.lbyt) GOTO 905
 
      CALL msgwrt(lunit,mgwa,nbyt)
 
      maxrow = max(maxrow,nrow)
      maxcol = max(maxcol,ncol)
      ncmsgs = ncmsgs+1
      ncsubs = ncsubs+ncol
      ncbyts = ncbyts+nbyt
 
C  RESET
C  -----
 
C     NOW, UNLESS THIS WAS A "FLUSH" CALL TO THIS SUBROUTINE, GO BACK
C     AND INITIALIZE A NEW MESSAGE TO HOLD THE CURRENT SUBSET THAT WE
C     WERE NOT ABLE TO FIT INTO THE MESSAGE THAT WAS JUST WRITTEN OUT.
 
      first = .true.
      IF(.NOT.flush) GOTO 1
 
C  EXITS
C  -----
 
100   RETURN
900   WRITE(bort_str,'("BUFRLIB: WRCMPS - I/O STREAM INDEX FOR THIS '//
     . .NE.'CALL (",I3,")  I/O STREAM INDEX FOR INITIAL CALL (",I3,")'//
     . ' - UNIT NUMBER NOW IS",I4)') lun,lunc,lunix
      CALL bort(bort_str)
901   WRITE(bort_str,'("BUFRLIB: WRCMPS - NO. OF ELEMENTS IN THE '//
     . .GT.'SUBSET (",I6,")  THE NO. OF ROWS ALLOCATED FOR THE '//
     . 'COMPRESSION MATRIX (",I6,")")') nval(lun),mxcdv
      CALL bort(bort_str)
902   WRITE(bort_str,'("BUFRLIB: WRCMPS - NO. OF COLUMNS CALCULATED '//
     . .LE.'FOR COMPRESSION MAXRIX IS  0 (=",I6,")")') ncol
      CALL bort(bort_str)
903   CALL bort('BUFRLIB: WRCMPS - MISSING DELAYED REPLICATION FACTOR')
904   CALL bort('BUFRLIB: WRCMPS - THE NUMBER OF BITS IN THE '//
     . 'COMPRESSED BUFR MSG IS NOT A MULTIPLE OF 8 - MSG MUST END ON '//
     . ' A BYTE BOUNDARY')
905   WRITE(bort_str,'("BUFRLIB: WRCMPS - OUTPUT MESSAGE LENGTH FROM '//
     . 'SECTION 0",I6," DOES NOT EQUAL FINAL PACKED MESSAGE LENGTH ("'//
     .',I6,")")') lbyt,nbyt
      CALL bort(bort_str)
      END