NCEPLIBS-bufr  11.6.0
 All Data Structures Files Functions Variables Pages
wrtree.f
Go to the documentation of this file.
1 C> @file
2 C> @author WOOLLEN @date 1994-01-06
3 
4 C> THIS SUBROUTINE CONVERTS USER NUMBERS INTO SCALED INTEGERS
5 C> AND PACKS THE USER ARRAY INTO THE SUBSET BUFFER.
6 C>
7 C> PROGRAM HISTORY LOG:
8 C> 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR
9 C> 1998-07-08 J. WOOLLEN -- CORRECTED SOME MINOR ERRORS
10 C> 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
11 C> OPENED AT ONE TIME INCREASED FROM 10 TO 32
12 C> (NECESSARY IN ORDER TO PROCESS MULTIPLE
13 C> BUFR FILES UNDER THE MPI)
14 C> 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
15 C> 10,000 TO 20,000 BYTES
16 C> 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE
17 C> INTERDEPENDENCIES
18 C> 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
19 C> INCREASED FROM 15000 TO 16000 (WAS IN
20 C> VERIFICATION VERSION); UNIFIED/PORTABLE FOR
21 C> WRF; ADDED DOCUMENTATION (INCLUDING
22 C> HISTORY); REPL. "IVAL(N)=ANINT(PKS(NODE))"
23 C> WITH "IVAL(N)=NINT(PKS(NODE))" (FORMER
24 C> CAUSED PROBLEMS ON SOME FOREIGN MACHINES)
25 C> 2004-03-10 J. WOOLLEN -- CONVERTED PACKING FUNCTION 'PKS' TO REAL*8
26 C> 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM
27 C> 20,000 TO 50,000 BYTES
28 C> 2007-01-19 J. ATOR -- PREVENT OVERFLOW OF CVAL FOR STRINGS LONGER
29 C> THAN 8 CHARACTERS; USE FUNCTION IBFMS
30 C> 2009-08-03 J. WOOLLEN -- ADDED CAPABILITY TO COPY LONG STRINGS VIA
31 C> UFBCPY USING FILE POINTER STORED IN NEW
32 C> COMMON UFBCPL
33 C> 2012-03-02 J. ATOR -- USE IPKS TO HANDLE 2-03 OPERATOR CASES
34 C> 2012-06-04 J. ATOR -- ENSURE "MISSING" CHARACTER FIELDS ARE
35 C> PROPERLY ENCODED WITH ALL BITS SET TO 1
36 C> 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS
37 C>
38 C> USAGE: CALL WRTREE (LUN)
39 C> INPUT ARGUMENT LIST:
40 C> LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
41 C>
42 C> REMARKS:
43 C> THIS ROUTINE CALLS: IBFMS IPKM PKB PKC
44 C> IPKS READLC
45 C> THIS ROUTINE IS CALLED BY: WRITSA WRITSB
46 C> Normally not called by any application
47 C> programs.
48 C>
49  SUBROUTINE wrtree(LUN)
50 
51  USE moda_usrint
52  USE moda_ival
53  USE moda_ufbcpl
54  USE moda_bitbuf
55  USE moda_tables
56 
57  CHARACTER*120 lstr
58  CHARACTER*8 cval
59  equivalence(cval,rval)
60  REAL*8 rval
61 
62 C-----------------------------------------------------------------------
63 
64 C CONVERT USER NUMBERS INTO SCALED INTEGERS
65 C -----------------------------------------
66 
67  DO n=1,nval(lun)
68  node = inv(n,lun)
69  IF(itp(node).EQ.1) THEN
70  ival(n) = val(n,lun)
71  ELSEIF(typ(node).EQ.'NUM') THEN
72  IF(ibfms(val(n,lun)).EQ.0) THEN
73  ival(n) = ipks(val(n,lun),node)
74  ELSE
75  ival(n) = -1
76  ENDIF
77  ENDIF
78  ENDDO
79 
80 C PACK THE USER ARRAY INTO THE SUBSET BUFFER
81 C ------------------------------------------
82 
83  ibit = 16
84 
85  DO n=1,nval(lun)
86  node = inv(n,lun)
87  IF(itp(node).LT.3) THEN
88 
89 C The value to be packed is numeric.
90 
91  CALL pkb(ival(n),ibt(node),ibay,ibit)
92  ELSE
93 
94 C The value to be packed is a character string.
95 
96  ncr=ibt(node)/8
97  IF ( ncr.GT.8 .AND. luncpy(lun).NE.0 ) THEN
98 
99 C The string is longer than 8 characters and there was a
100 C preceeding call to UFBCPY involving this output unit, so
101 C read the long string with READLC and write it into the
102 C output buffer using PKC.
103 
104  CALL readlc(luncpy(lun),lstr,tag(node))
105  CALL pkc(lstr,ncr,ibay,ibit)
106  ELSE
107  rval = val(n,lun)
108  IF(ibfms(rval).NE.0) THEN
109 
110 C The value is "missing", so set all bits to 1 before
111 C packing the field as a character string.
112 
113  numchr = min(ncr,len(lstr))
114  DO jj = 1, numchr
115  CALL ipkm(lstr(jj:jj),1,255)
116  ENDDO
117  CALL pkc(lstr,numchr,ibay,ibit)
118  ELSE
119 
120 C The value is not "missing", so pack the equivalenced
121 C character string. Note that a maximum of 8 characters
122 C will be packed here, so a separate subsequent call to
123 C BUFR archive library subroutine WRITLC will be needed to
124 C fully encode any string longer than 8 characters.
125 
126  CALL pkc(cval,ncr,ibay,ibit)
127  ENDIF
128  ENDIF
129 
130  ENDIF
131  ENDDO
132 
133 C RESET UFBCPY FILE POINTER
134 C -------------------------
135 
136  luncpy(lun)=0
137 
138  RETURN
139  END
subroutine pkc(CHR, NCHR, IBAY, IBIT)
This subroutine encodes a character string within a specified number of bits of an integer array...
Definition: pkc.f:40
INTEGER function ipks(VAL, NODE)
THIS FUNCTION PACKS A REAL*8 USER VALUE INTO A BUFR INTEGER BY APPLYING THE PROPER SCALE AND REFERENC...
Definition: ipks.f:30
INTEGER function ibfms(R8VAL)
This function provides a handy way to check whether a real*8 data value returned from a previous call...
Definition: ibfms.f:38
This module contains array and variable declarations used to store the internal jump/link table...
Definition: moda_tables.F:13
subroutine ipkm(CBAY, NBYT, N)
This subroutine encodes an integer value within a specified number of bytes of a character string...
Definition: ipkm.f:27
subroutine pkb(NVAL, NBITS, IBAY, IBIT)
This subroutine encodes an integer value within a specified number of bits of an integer array...
Definition: pkb.f:38
This module contains array and variable declarations used to store BUFR messages internally for multi...
Definition: moda_bitbuf.F:10
subroutine wrtree(LUN)
THIS SUBROUTINE CONVERTS USER NUMBERS INTO SCALED INTEGERS AND PACKS THE USER ARRAY INTO THE SUBSET B...
Definition: wrtree.f:49
subroutine readlc(LUNIT, CHR, STR)
This subroutine reads a long character string (greater than 8 bytes) from a data subset.
Definition: readlc.f:58