<HTML> <BODY BGCOLOR=#ccccdd LINK=#0000aa VLINK=#0000ff ALINK=#ff0000 ><BASE TARGET="bottom_target"><PRE>
<A NAME='WRTREE'><A href='../../html_code/bufr/wrtree.f.html#WRTREE' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE WRTREE(LUN) 3
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: WRTREE
C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06
C
C ABSTRACT: 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
<A NAME='IBFMS'><A href='../../html_code/bufr/wrtree.f.html#IBFMS' TARGET='top_target'><IMG SRC="../../gif/bar_green.gif" border=0></A>
C THAN 8 CHARACTERS; USE FUNCTION IBFMS 2,53
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
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 PKB PKC
C IPKS READLC
C THIS ROUTINE IS CALLED BY: WRITSA WRITSB
C Normally not called by any application
C programs.
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: PORTABLE TO ALL PLATFORMS
C
C$$$
INCLUDE 'bufrlib.prm'
COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES),
. MBAY(MXMSGLD4,NFILES)
COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
. JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
. IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
. ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
. ISEQ(MAXJL,2),JSEQ(MAXJL)
COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
COMMON /UFBCPL/ LUNCPY(NFILES)
CHARACTER*120 LSTR
CHARACTER*10 TAG
CHARACTER*8 CVAL
CHARACTER*3 TYP
DIMENSION IVAL(MAXSS)
EQUIVALENCE (CVAL,RVAL)
REAL*8 VAL,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 PKB(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