wrtree.f

Go to the documentation of this file.

C> @file
C> @brief Pack a BUFR data subset.
C>
C> @author J. Woollen @date 1994-01-06
 
C> Pack a BUFR data subset.
C>
C> This subroutine converts user numbers from the val array into scaled
C> integers and packs them into bit strings in the ibay array.
C>
C> @param[in] lun - integer: file ID.
C>
C> @author J. Woollen @date 1994-01-06
 
      SUBROUTINE wrtree(LUN)
 
      USE moda_usrint
      USE moda_ival
      USE moda_ufbcpl
      USE moda_bitbuf
      USE moda_tables
 
      CHARACTER*120 LSTR
      CHARACTER*8   CVAL
      equivalence(cval,rval)
      integer(8)    ipks
      real*8        rval
 
C-----------------------------------------------------------------------
 
C  CONVERT USER NUMBERS INTO SCALED INTEGERS
C  -----------------------------------------
 
      DO n=1,nval(lun)
      node = inv(n,lun)
      IF(itp(node).EQ.1) THEN
         ival(n) = nint(val(n,lun))
      ELSEIF(typ(node).EQ.'NUM') THEN
         IF(ibfms(val(n,lun)).EQ.0) THEN
            ival(n) = ipks(val(n,lun),node)
         ELSE
            ival(n) = -1
         ENDIF
      ENDIF
      ENDDO
 
C  PACK THE USER ARRAY INTO THE SUBSET BUFFER
C  ------------------------------------------
 
      ibit = 16
 
      DO n=1,nval(lun)
      node = inv(n,lun)
      IF(itp(node).LT.3) THEN
 
C        The value to be packed is numeric.
 
         CALL pkb8(ival(n),ibt(node),ibay,ibit)
      ELSE
 
C        The value to be packed is a character string.
 
         ncr=ibt(node)/8
         IF ( ncr.GT.8 .AND. luncpy(lun).NE.0 ) THEN
 
C           The string is longer than 8 characters and there was a
C           preceeding call to UFBCPY involving this output unit, so
C           read the long string with READLC and write it into the
C           output buffer using PKC.
 
            CALL readlc(luncpy(lun),lstr,tag(node))
            CALL pkc(lstr,ncr,ibay,ibit)
         ELSE
            rval = val(n,lun)
            IF(ibfms(rval).NE.0) THEN
 
C              The value is "missing", so set all bits to 1 before
C              packing the field as a character string.
 
               numchr = min(ncr,len(lstr))
               DO jj = 1, numchr
                  CALL ipkm(lstr(jj:jj),1,255)
               ENDDO
               CALL pkc(lstr,numchr,ibay,ibit)
            ELSE
 
C              The value is not "missing", so pack the equivalenced
C              character string.  Note that a maximum of 8 characters
C              will be packed here, so a separate subsequent call to
C              BUFR archive library subroutine WRITLC will be needed to
C              fully encode any string longer than 8 characters.
 
               CALL pkc(cval,ncr,ibay,ibit)
            ENDIF
         ENDIF
 
      ENDIF
      ENDDO
 
C  RESET UFBCPY FILE POINTER
C  -------------------------
 
      luncpy(lun)=0
 
      RETURN
      END