rdcmps.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 2000-09-19
      
C> THIS SUBROUTINE UNCOMPRESSES AND UNPACKS THE NEXT SUBSET
C>   FROM THE INTERNAL COMPRESSED MESSAGE BUFFER (ARRAY MBAY IN MODULE
C>   BITBUF) AND STORES THE UNPACKED SUBSET WITHIN THE INTERNAL
C>   ARRAY VAL(*,LUN) IN MODULE USRINT.
C>
C> PROGRAM HISTORY LOG:
C> 2000-09-19  J. WOOLLEN -- ORIGINAL AUTHOR
C> 2002-05-14  J. WOOLLEN -- IMPROVED GENERALITY, PREVIOUSLY RDCMPS
C>                           WOULD NOT RECOGNIZE COMPRESSED DELAYED
C>                           REPLICATION AS A LEGITIMATE DATA STRUCTURE
C> 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
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); UNIFIED/PORTABLE FOR
C>                           WRF; ADDED HISTORY DOCUMENTATION
C> 2004-08-18  J. ATOR    -- INITIALIZE CVAL TO EMPTY BEFORE CALLING UPC;
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> 2009-03-23  J. ATOR    -- PREVENT OVERFLOW OF CVAL AND CREF FOR
C>                           STRINGS LONGER THAN 8 CHARACTERS
C> 2012-03-02  J. ATOR    -- USE FUNCTION UPS
C> 2012-06-04  J. ATOR    -- SET DECODED REAL*8 VALUE TO "MISSING" WHEN
C>                           CORRESPONDING CHARACTER FIELD HAS ALL BITS
C>                           SET TO 1
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C>
C> USAGE:    CALL RDCMPS (LUN)
C>   INPUT ARGUMENT LIST:
C>     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C>
C> REMARKS:
C>    THIS ROUTINE CALLS:        BORT     ICBFMS   IGETRFEL STRBTM
C>                               UPB      UPC      UPS      USRTPL
C>    THIS ROUTINE IS CALLED BY: READSB
C>                               Normally not called by any application
C>                               programs.
C>
      SUBROUTINE rdcmps(LUN)

      USE modv_bmiss

      USE moda_usrint
      USE moda_msgcwd
      USE moda_bitbuf
      USE moda_tables
      USE moda_rlccmn

      CHARACTER*128 bort_str
      CHARACTER*8   cref,cval
      equivalence(cval,rval)
      REAL*8        rval,ups

C-----------------------------------------------------------------------
C     Statement function to compute BUFR "missing value" for field
C     of length LBIT bits (all bits "on"):

      lps(lbit) = max(2**(lbit)-1,1)
C-----------------------------------------------------------------------

C  SETUP THE SUBSET TEMPLATE
C  -------------------------

      CALL usrtpl(lun,1,1)

C  UNCOMPRESS A SUBSET INTO THE VAL ARRAY ACCORDING TO TABLE B
C  -----------------------------------------------------------

      nsbs = nsub(lun)

C     Note that we are going to unpack the (NSBS)th subset from within
C     the current BUFR message.

      ibit = mbyt(lun)
      nrst = 0

C     Loop through each element of the subset.

      n = 0

1     DO n=n+1,nval(lun)
      node = inv(n,lun)
      nrfelm(n,lun) = igetrfel(n,lun)
      nbit = ibt(node)
      ityp = itp(node)

C     In each of the following code blocks, the "local reference value"
C     for the element is determined first, followed by the 6-bit value
C     which indicates how many bits are used to store the increment
C     (i.e. offset) from this "local reference value".  Then, we jump
C     ahead to where this increment is stored for this particular subset,
C     unpack it, and add it to the "local reference value" to determine
C     the final uncompressed value for this element from this subset.

C     Note that, if an element has the same final uncompressed value
C     for each subset in the message, then the encoding rules for BUFR
C     compression dictate that the "local reference value" will be equal
C     to this value, the 6-bit increment length indicator will have
C     a value of zero, and the actual increments themselves will be
C     omitted from the message.

      IF(ityp.EQ.1.OR.ityp.EQ.2) THEN

C        This is a numeric element.

         CALL upb(lref,nbit,mbay(1,lun),ibit)
         CALL upb(linc,   6,mbay(1,lun),ibit)
         jbit = ibit + linc*(nsbs-1)
         CALL upb(ninc,linc,mbay(1,lun),jbit)
         IF(ninc.EQ.lps(linc)) THEN
            ival = lps(nbit)
         ELSE
            ival = lref+ninc
         ENDIF
         IF(ityp.EQ.1) THEN
            CALL usrtpl(lun,n,ival)
            goto 1
         ENDIF
         IF(ival.LT.lps(nbit)) val(n,lun) = ups(ival,node)
         CALL strbtm(n,lun)
         ibit = ibit + linc*msub(lun)
      ELSEIF(ityp.EQ.3) THEN

C        This is a character element.  If there are more than 8
C        characters, then only the first 8 will be unpacked by this
C        routine, and a separate subsequent call to BUFR archive library
C        subroutine READLC will be required to unpack the remainder of
C        the string.  In this case, pointers will be saved within
C        COMMON /RLCCMN/ for later use within READLC.

C        Unpack the local reference value.

         lelm = nbit/8
         nchr = min(8,lelm)
         ibsv = ibit
         cref = ' '
         CALL upc(cref,nchr,mbay(1,lun),ibit,.true.)
         IF(lelm.GT.8) THEN
            ibit = ibit + (lelm-8)*8
            nrst = nrst + 1
            IF(nrst.GT.mxrst) goto 900
            crtag(nrst) = tag(node)
         ENDIF

C        Unpack the increment length indicator.  For character elements,
C        this length is in bytes rather than bits.

         CALL upb(linc,   6,mbay(1,lun),ibit)
         IF(linc.EQ.0) THEN
            IF(lelm.GT.8) THEN
               irnch(nrst) = lelm
               irbit(nrst) = ibsv
            ENDIF
            cval = cref
         ELSE
            jbit = ibit + linc*(nsbs-1)*8
            IF(lelm.GT.8) THEN
               irnch(nrst) = linc
               irbit(nrst) = jbit
            ENDIF
            nchr = min(8,linc)
            cval = ' '
            CALL upc(cval,nchr,mbay(1,lun),jbit,.true.)
         ENDIF
         IF (lelm.LE.8 .AND. icbfms(cval,nchr).NE.0) THEN
            val(n,lun) = bmiss
         ELSE
            val(n,lun) = rval
         ENDIF
         ibit = ibit + 8*linc*msub(lun)
      ENDIF
      ENDDO

      RETURN
900   WRITE(bort_str,'("BUFRLIB: RDCMPS - NUMBER OF LONG CHARACTER ' //
     .   'STRINGS EXCEEDS THE LIMIT (",I4,")")') mxrst
      CALL bort(bort_str)
      END