wrcmps.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 2002-05-14
      
C> THIS SUBROUTINE PACKS UP THE CURRENT SUBSET WITHIN MEMORY
C>   (ARRAY IBAY IN MODULE 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 BUFR ARCHIVE LIBRARY
C>   SUBROUTINE MSGUPD EXCEPT THAT IT ACTS ON COMPRESSED BUFR MESSAGES.
C>
C> PROGRAM HISTORY LOG:
C> 2002-05-14  J. WOOLLEN -- ORIGINAL AUTHOR
C> 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C>                           INTERDEPENDENCIES
C> 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
C>                           INCREASED FROM 15000 TO 16000 (WAS IN
C>                           VERIFICATION VERSION); LOGICAL VARIABLES
C>                           "WRIT1" AND "FLUSH" NOW SAVED IN GLOBAL
C>                           MEMORY (IN COMMON BLOCK /COMPRS/), THIS
C>                           FIXED A BUG IN THIS ROUTINE WHICH CAN LEAD
C>                           TO MESSAGES BEING WRITTEN OUT BEFORE THEY
C>                           ARE FULL; UNIFIED/PORTABLE FOR WRF; ADDED
C>                           DOCUMENTATION (INCLUDING HISTORY); OUTPUTS
C>                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
C>                           TERMINATES ABNORMALLY
C> 2004-08-18  J. ATOR    -- REMOVE CALL TO XMSGINI (CMSGINI NOW HAS
C>                           SAME CAPABILITY); IMPROVE DOCUMENTATION;
C>                           CORRECT LOGIC FOR WHEN A CHARACTER VALUE IS
C>                           THE SAME FOR ALL SUBSETS IN A MESSAGE;
C>                           MAXIMUM MESSAGE LENGTH INCREASED FROM
C>                           20,000 TO 50,000 BYTES
C> 2004-08-18  J. WOOLLEN -- 1) ADDED SAVE FOR LOGICAL 'FIRST'
C>                           2) ADDED 'KMISS' TO FIX BUG WHICH WOULD
C>                              OCCASIONALLY SKIP OVER SUBSETS
C>                           3) ADDED LOGIC TO MAKE SURE MISSING VALUES
C>                              ARE REPRESENTED BY INCREMENTS WITH ALL
C>                              BITS ON
C>                           4) REMOVED TWO UNECESSARY REFERENCES TO
C>                              'WRIT1'
C> 2005-11-29  J. ATOR    -- FIX INITIALIZATION BUG FOR CHARACTER
C>                           COMPRESSION; INCREASE MXCSB TO 4000;
C>                           USE IUPBS01; CHECK EDITION NUMBER OF BUFR
C>                           MESSAGE BEFORE PADDING TO AN EVEN BYTE COUNT
C> 2009-03-23  J. ATOR    -- ADDED SAVE FOR IBYT AND JBIT; USE MSGFULL
C> 2009-08-11  J. WOOLLEN -- MADE CATX AND CSTR BIGGER TO HANDLE LONGER
C>                           STRINGS.  ALSO SEPARATED MATX,CATX,NCOL FROM
C>                           OTHER VARS IN COMMON COMPRS FOR USE IN
C>                           SUBROUTINE WRITLC.  ALSO PASSED MBAY(1,LUN)
C>                           AS ARRAY TO INITIAL CALL TO CMSGINI IN ORDER
C>                           FOR USE BY WRITLC.
C> 2012-02-17  J. ATOR    -- FIXED A BUG INVOLVING COMPRESSED FILES WITH
C>                           EMBEDDED DICTIONARY MESSAGES
C> 2014-12-03  J. ATOR    -- USE PKX TO PACK LOCAL REFERENCE VALUE FOR
C>                           CHARACTER STRINGS
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C> 2015-09-24  D. STOKES  -- INCLUDE EDGE4 IN SAVE LIST
C> 2016-03-18  J. ATOR    -- FIX BUG INVOLVING ENCODING OF LONG CHARACTER
C>                           STRINGS (VIA WRITLC) INTO MESSAGES WHICH
C>                           ALSO CONTAIN DELAYED REPLICATION SEQUENCES
C> 2021-02-24  J. ATOR    -- USE IPKM AND PKC INSTEAD OF PKX
C>
C> USAGE:    CALL WRCMPS (LUNIX)
C>   INPUT ARGUMENT LIST:
C>     LUNIX    - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER
C>                FOR BUFR FILE (IF LUNIX IS LESS THAN ZERO, THIS IS A
C>                "FLUSH" CALL AND THE BUFFER MUST BE CLEARED OUT)
C>
C> REMARKS:
C>    THIS ROUTINE CALLS:        BORT     CMSGINI  IUPBS01  MSGFULL
C>                               MSGWRT   PKB      PKC      PKX
C>                               STATUS   UPB      UPC      USRTPL
C>    THIS ROUTINE IS CALLED BY: CLOSMG   WRITSA   WRITSB
C>                               Normally not called by any application
C>                               programs.
C>
      SUBROUTINE wrcmps(LUNIX)
 
      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))
         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.)
 
 10   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 upb(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 = 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 pkb(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**iwid(i)-1) THEN
               incr = matx(i,j)-kmin(i) 
            ELSE 
               incr = 2**kbit(i)-1
            ENDIF
            CALL pkb(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