wrtree.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 1994-01-06
      
C> THIS SUBROUTINE CONVERTS USER NUMBERS INTO SCALED INTEGERS
C>   AND PACKS THE USER ARRAY INTO THE SUBSET BUFFER.
C>
C> PROGRAM HISTORY LOG:
C> 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C> 1998-07-08  J. WOOLLEN -- CORRECTED SOME MINOR ERRORS
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  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); REPL. "IVAL(N)=ANINT(PKS(NODE))"
C>                           WITH "IVAL(N)=NINT(PKS(NODE))" (FORMER
C>                           CAUSED PROBLEMS ON SOME FOREIGN MACHINES)
C> 2004-03-10  J. WOOLLEN -- CONVERTED PACKING FUNCTION 'PKS' TO REAL*8 
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; USE FUNCTION IBFMS
C> 2009-08-03  J. WOOLLEN -- ADDED CAPABILITY TO COPY LONG STRINGS VIA
C>                           UFBCPY USING FILE POINTER STORED IN NEW
C>                           COMMON UFBCPL
C> 2012-03-02  J. ATOR    -- USE IPKS TO HANDLE 2-03 OPERATOR CASES
C> 2012-06-04  J. ATOR    -- ENSURE "MISSING" CHARACTER FIELDS ARE
C>                           PROPERLY ENCODED WITH ALL BITS SET TO 1 
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C> 2022-05-06  J. WOOLLEN -- REPLACE PKB WITH PKB8 FOR 8BYTE INTEGERS
C>
C> USAGE:    CALL WRTREE (LUN)
C>   INPUT ARGUMENT LIST:
C>     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C>
C> REMARKS:
C>    THIS ROUTINE CALLS:        IBFMS    IPKM     PKB8     PKC
C>                               IPKS     READLC
C>    THIS ROUTINE IS CALLED BY: WRITSA   WRITSB
C>                               Normally not called by any application
C>                               programs.
C>
      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) = 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