rdtree.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 1994-01-06
      
C> THIS SUBROUTINE UNPACKS THE NEXT SUBSET FROM THE INTERNAL
C>   UNCOMPRESSED MESSAGE BUFFER (ARRAY MBAY IN MODULE BITBUF) AND
C>   STORES THE UNPACKED SUBSET WITHIN THE INTERNAL ARRAY VAL(*,LUN)
C>   IN MODULE USRINT.
C>
C> PROGRAM HISTORY LOG:
C> 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C> 1998-10-27  J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN-
C>                           LINING CODE WITH FPP DIRECTIVES
C> 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
C>                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
C>                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
C>                           BUFR FILES UNDER THE MPI)
C> 2000-09-19  J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
C>                           10,000 TO 20,000 BYTES
C> 2003-11-04  J. WOOLLEN -- FIXED A BUG WHICH COULD ONLY OCCUR WHEN
C>                           THE LAST ELEMENT IN A SUBSET IS A CHARACTER
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 DOCUMENTATION (INCLUDING
C>                           HISTORY)
C> 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
C>                           20,000 TO 50,000 BYTES
C> 2007-01-19  J. ATOR    -- PREVENT OVERFLOW OF CVAL FOR STRINGS LONGER
C>                           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> 2016-11-09  J. ATOR    -- ADDED IRET ARGUMENT AND CHECK FOR POSSIBLY
C>                           CORRUPT SUBSETS
C>
C> USAGE:    CALL RDTREE (LUN,IRET)
C>   INPUT ARGUMENT LIST:
C>     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C>
C>   OUTPUT ARGUMENT LIST:
C>     IRET     - INTEGER: RETURN CODE:
C>                       0 = NORMAL RETURN
C>                      -1 = AN ERROR OCCURRED, POSSIBLY DUE TO A
C>                           CORRUPT SUBSET IN THE INPUT MESSAGE
C>
C> REMARKS:
C>    THIS ROUTINE CALLS:        RCSTPL   ICBFMS   UPBB     UPC
C>                               UPS
C>    THIS ROUTINE IS CALLED BY: READSB
C>                               Normally not called by any application
C>                               programs.
C>
      SUBROUTINE rdtree(LUN,IRET)

      USE modv_bmiss
      USE moda_usrint
      USE moda_usrbit
      USE moda_ival
      USE moda_bitbuf
      USE moda_tables

      CHARACTER*8  cval
      equivalence(cval,rval)
      REAL*8       rval,ups

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

      mps(node) = 2**(ibt(node))-1
C-----------------------------------------------------------------------

      iret = 0

C  CYCLE THROUGH A SUBSET SETTING UP THE TEMPLATE
C  ----------------------------------------------

      mbit(1) = ibit
      nbit(1) = 0
      CALL rcstpl(lun,ier)
      IF(ier.NE.0) THEN
        iret = -1
        RETURN
      ENDIF

C  UNPACK A SUBSET INTO THE USER ARRAY IVAL
C  ----------------------------------------

      DO n=1,nval(lun)
      CALL upbb(ival(n),nbit(n),mbit(n),mbay(1,lun))
      ENDDO

C  LOOP THROUGH EACH ELEMENT OF THE SUBSET, CONVERTING THE UNPACKED
C  VALUES TO THE PROPER TYPES
C  ----------------------------------------------------------------

      DO n=1,nval(lun)
      node = inv(n,lun)
      IF(itp(node).EQ.1) THEN

C    The unpacked value is a delayed descriptor replication factor.

         val(n,lun) = ival(n)
      ELSEIF(itp(node).EQ.2) THEN

C    The unpacked value is a real.

         IF (ival(n).LT.mps(node)) THEN
            val(n,lun) = ups(ival(n),node)
         ELSE
            val(n,lun) = bmiss
         ENDIF
      ELSEIF(itp(node).EQ.3) THEN

C        The value is a character string, so unpack it using an
C        equivalenced REAL*8 value.  Note that a maximum of 8 characters
C        will be unpacked here, so a separate subsequent call to BUFR
C        archive library subroutine READLC will be needed to fully
C        unpack any string longer than 8 characters.

         cval = ' '
         kbit = mbit(n)
         nbt = min(8,nbit(n)/8)
         CALL upc(cval,nbt,mbay(1,lun),kbit,.true.)
         IF (nbit(n).LE.64 .AND. icbfms(cval,nbt).NE.0) THEN
            val(n,lun) = bmiss
         ELSE
            val(n,lun) = rval
         ENDIF
      ENDIF
      ENDDO

      ibit = nbit(nval(lun))+mbit(nval(lun))

      RETURN
      END