NCEPLIBS-bufr  11.6.0
 All Data Structures Files Functions Variables Pages
rdtree.f
Go to the documentation of this file.
1 C> @file
2 C> @author WOOLLEN @date 1994-01-06
3 
4 C> THIS SUBROUTINE UNPACKS THE NEXT SUBSET FROM THE INTERNAL
5 C> UNCOMPRESSED MESSAGE BUFFER (ARRAY MBAY IN MODULE BITBUF) AND
6 C> STORES THE UNPACKED SUBSET WITHIN THE INTERNAL ARRAY VAL(*,LUN)
7 C> IN MODULE USRINT.
8 C>
9 C> PROGRAM HISTORY LOG:
10 C> 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR
11 C> 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN-
12 C> LINING CODE WITH FPP DIRECTIVES
13 C> 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
14 C> OPENED AT ONE TIME INCREASED FROM 10 TO 32
15 C> (NECESSARY IN ORDER TO PROCESS MULTIPLE
16 C> BUFR FILES UNDER THE MPI)
17 C> 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
18 C> 10,000 TO 20,000 BYTES
19 C> 2003-11-04 J. WOOLLEN -- FIXED A BUG WHICH COULD ONLY OCCUR WHEN
20 C> THE LAST ELEMENT IN A SUBSET IS A CHARACTER
21 C> 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE
22 C> INTERDEPENDENCIES
23 C> 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
24 C> INCREASED FROM 15000 TO 16000 (WAS IN
25 C> VERIFICATION VERSION); UNIFIED/PORTABLE FOR
26 C> WRF; ADDED DOCUMENTATION (INCLUDING
27 C> HISTORY)
28 C> 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM
29 C> 20,000 TO 50,000 BYTES
30 C> 2007-01-19 J. ATOR -- PREVENT OVERFLOW OF CVAL FOR STRINGS LONGER
31 C> THAN 8 CHARACTERS
32 C> 2012-03-02 J. ATOR -- USE FUNCTION UPS
33 C> 2012-06-04 J. ATOR -- SET DECODED REAL*8 VALUE TO "MISSING" WHEN
34 C> CORRESPONDING CHARACTER FIELD HAS ALL BITS
35 C> SET TO 1
36 C> 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS
37 C> 2016-11-09 J. ATOR -- ADDED IRET ARGUMENT AND CHECK FOR POSSIBLY
38 C> CORRUPT SUBSETS
39 C>
40 C> USAGE: CALL RDTREE (LUN,IRET)
41 C> INPUT ARGUMENT LIST:
42 C> LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
43 C>
44 C> OUTPUT ARGUMENT LIST:
45 C> IRET - INTEGER: RETURN CODE:
46 C> 0 = NORMAL RETURN
47 C> -1 = AN ERROR OCCURRED, POSSIBLY DUE TO A
48 C> CORRUPT SUBSET IN THE INPUT MESSAGE
49 C>
50 C> REMARKS:
51 C> THIS ROUTINE CALLS: RCSTPL ICBFMS UPBB UPC
52 C> UPS
53 C> THIS ROUTINE IS CALLED BY: READSB
54 C> Normally not called by any application
55 C> programs.
56 C>
57  SUBROUTINE rdtree(LUN,IRET)
58 
59  USE modv_bmiss
60  USE moda_usrint
61  USE moda_usrbit
62  USE moda_ival
63  USE moda_bitbuf
64  USE moda_tables
65 
66  CHARACTER*8 cval
67  equivalence(cval,rval)
68  REAL*8 rval,ups
69 
70 C-----------------------------------------------------------------------
71 C Statement function to compute BUFR "missing value" for field
72 C of length IBT(NODE)) bits (all bits "on"):
73 
74  mps(node) = 2**(ibt(node))-1
75 C-----------------------------------------------------------------------
76 
77  iret = 0
78 
79 C CYCLE THROUGH A SUBSET SETTING UP THE TEMPLATE
80 C ----------------------------------------------
81 
82  mbit(1) = ibit
83  nbit(1) = 0
84  CALL rcstpl(lun,ier)
85  IF(ier.NE.0) THEN
86  iret = -1
87  RETURN
88  ENDIF
89 
90 C UNPACK A SUBSET INTO THE USER ARRAY IVAL
91 C ----------------------------------------
92 
93  DO n=1,nval(lun)
94  CALL upbb(ival(n),nbit(n),mbit(n),mbay(1,lun))
95  ENDDO
96 
97 C LOOP THROUGH EACH ELEMENT OF THE SUBSET, CONVERTING THE UNPACKED
98 C VALUES TO THE PROPER TYPES
99 C ----------------------------------------------------------------
100 
101  DO n=1,nval(lun)
102  node = inv(n,lun)
103  IF(itp(node).EQ.1) THEN
104 
105 C The unpacked value is a delayed descriptor replication factor.
106 
107  val(n,lun) = ival(n)
108  ELSEIF(itp(node).EQ.2) THEN
109 
110 C The unpacked value is a real.
111 
112  IF (ival(n).LT.mps(node)) THEN
113  val(n,lun) = ups(ival(n),node)
114  ELSE
115  val(n,lun) = bmiss
116  ENDIF
117  ELSEIF(itp(node).EQ.3) THEN
118 
119 C The value is a character string, so unpack it using an
120 C equivalenced REAL*8 value. Note that a maximum of 8 characters
121 C will be unpacked here, so a separate subsequent call to BUFR
122 C archive library subroutine READLC will be needed to fully
123 C unpack any string longer than 8 characters.
124 
125  cval = ' '
126  kbit = mbit(n)
127  nbt = min(8,nbit(n)/8)
128  CALL upc(cval,nbt,mbay(1,lun),kbit,.true.)
129  IF (nbit(n).LE.64 .AND. icbfms(cval,nbt).NE.0) THEN
130  val(n,lun) = bmiss
131  ELSE
132  val(n,lun) = rval
133  ENDIF
134  ENDIF
135  ENDDO
136 
137  ibit = nbit(nval(lun))+mbit(nval(lun))
138 
139  RETURN
140  END
subroutine upbb(NVAL, NBITS, IBIT, IBAY)
THIS SUBROUTINE UNPACKS AND RETURNS A BINARY INTEGER CONTAINED WITHIN NBITS BITS OF IBAY...
Definition: upbb.f:42
INTEGER function icbfms(STR, LSTR)
This function provides a handy way to check whether a character string returned from a previous call ...
Definition: icbfms.f:31
This module declares and initializes the BMISS variable.
Definition: modv_BMISS.f90:9
subroutine rcstpl(LUN, IRET)
THIS SUBROUTINE STORES THE SUBSET TEMPLATE INTO INTERNAL SUBSET ARRAYS IN MODULES USRINT AND USRBIT...
Definition: rcstpl.f:59
subroutine upc(CHR, NCHR, IBAY, IBIT, CNVNULL)
THIS SUBROUTINE UNPACKS AND RETURNS A CHARACTER STRING OF LENGTH NCHR CONTAINED WITHIN NCHR BYTES OF ...
Definition: upc.f:49
subroutine rdtree(LUN, IRET)
THIS SUBROUTINE UNPACKS THE NEXT SUBSET FROM THE INTERNAL UNCOMPRESSED MESSAGE BUFFER (ARRAY MBAY IN ...
Definition: rdtree.f:57
This module contains array and variable declarations used to store the internal jump/link table...
Definition: moda_tables.F:13
This module contains array and variable declarations used to store BUFR messages internally for multi...
Definition: moda_bitbuf.F:10
REAL *8 function ups(IVAL, NODE)
THIS FUNCTION UNPACKS A REAL*8 USER VALUE FROM A PACKED BUFR INTEGER BY APPLYING THE PROPER SCALE AND...
Definition: ups.f:31