NCEPLIBS-bufr  11.5.0
 All Data Structures Files Functions Variables Pages
rcstpl.f
Go to the documentation of this file.
1 C> @file
2 C> @author WOOLLEN @date 1994-01-06
3 
4 C> THIS SUBROUTINE STORES THE SUBSET TEMPLATE INTO INTERNAL
5 C> SUBSET ARRAYS IN MODULES USRINT AND USRBIT. THIS IS IN
6 C> PREPARATION FOR THE ACTUAL UNPACKING OF THE SUBSET IN BUFR ARCHIVE
7 C> LIBRARY SUBROUTINE RDTREE.
8 C>
9 C> PROGRAM HISTORY LOG:
10 C> 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR
11 C> 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
12 C> "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
13 C> ROUTINE "BORT"
14 C> 1998-10-27 J. WOOLLEN -- MODIFIED TO CORRECT PROBLEMS CAUSED BY IN-
15 C> LINING CODE WITH FPP DIRECTIVES
16 C> 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
17 C> OPENED AT ONE TIME INCREASED FROM 10 TO 32
18 C> (NECESSARY IN ORDER TO PROCESS MULTIPLE
19 C> BUFR FILES UNDER THE MPI)
20 C> 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
21 C> 10,000 TO 20,000 BYTES
22 C> 2002-05-14 J. WOOLLEN -- REMOVED OLD CRAY COMPILER DIRECTIVES
23 C> 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE
24 C> INTERDEPENDENCIES
25 C> 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
26 C> INCREASED FROM 15000 TO 16000 (WAS IN
27 C> VERIFICATION VERSION); MAXRCR (MAXIMUM
28 C> NUMBER OF RECURSION LEVELS) INCREASED FROM
29 C> 50 TO 100 (WAS IN VERIFICATION VERSION);
30 C> UNIFIED/PORTABLE FOR WRF; ADDED
31 C> DOCUMENTATION (INCLUDING HISTORY); OUTPUTS
32 C> MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
33 C> TERMINATES ABNORMALLY; COMMENTED OUT
34 C> HARDWIRE OF VTMP TO "BMISS" (10E10) WHEN IT
35 C> IS > 10E9 (CAUSED PROBLEMS ON SOME FOREIGN
36 C> MACHINES)
37 C> 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM
38 C> 20,000 TO 50,000 BYTES
39 C> 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS
40 C> 2016-11-09 J. ATOR -- ADDED IRET ARGUMENT AND CHECK FOR POSSIBLY
41 C> CORRUPT SUBSETS
42 C>
43 C> USAGE: CALL RCSTPL (LUN,IRET)
44 C> INPUT ARGUMENT LIST:
45 C> LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
46 C>
47 C> OUTPUT ARGUMENT LIST:
48 C> IRET - INTEGER: RETURN CODE:
49 C> 0 = NORMAL RETURN
50 C> -1 = AN ERROR OCCURRED, POSSIBLY DUE TO A
51 C> CORRUPT SUBSET IN THE INPUT MESSAGE
52 C>
53 C> REMARKS:
54 C> THIS ROUTINE CALLS: BORT IGETRFEL STRBTM UPBB
55 C> THIS ROUTINE IS CALLED BY: RDTREE
56 C> Normally not called by any application
57 C> programs.
58 C>
59  SUBROUTINE rcstpl(LUN,IRET)
60 
61  USE modv_bmiss
62  USE moda_usrint
63  USE moda_usrbit
64  USE moda_msgcwd
65  USE moda_bitbuf
66  USE moda_tables
67  USE moda_usrtmp
68 
69  COMMON /quiet / iprt
70 
71  CHARACTER*128 bort_str
72  dimension nbmp(2,maxrcr),newn(2,maxrcr)
73  dimension knx(maxrcr)
74 
75 C-----------------------------------------------------------------------
76 C-----------------------------------------------------------------------
77 
78  iret = 0
79 
80 C SET THE INITIAL VALUES FOR THE TEMPLATE
81 C ---------------------------------------
82 
83 c .... Positional index of Table A mnem.
84  inv(1,lun) = inode(lun)
85  val(1,lun) = 0
86  nbmp(1,1) = 1
87  nbmp(2,1) = 1
88  nodi = inode(lun)
89  node = inode(lun)
90  mbmp = 1
91  knvn = 1
92  nr = 0
93 
94  DO i=1,maxrcr
95  knx(i) = 0
96  ENDDO
97 
98 C SET UP THE PARAMETERS FOR A LEVEL OF RECURSION
99 C ----------------------------------------------
100 
101 10 CONTINUE
102 
103  nr = nr+1
104  IF(nr.GT.maxrcr) goto 900
105  nbmp(1,nr) = 1
106  nbmp(2,nr) = mbmp
107 
108  n1 = iseq(node,1)
109  n2 = iseq(node,2)
110  IF(n1.EQ.0 ) goto 901
111  IF(n2-n1+1.GT.maxjl) THEN
112  IF(iprt.GE.0) THEN
113  CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
114  CALL errwrt('BUFRLIB: RCSTPL - MAXJL OVERFLOW; SUBSET SKIPPED')
115  CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
116  ENDIF
117  iret = -1
118  RETURN
119  ENDIF
120  newn(1,nr) = 1
121  newn(2,nr) = n2-n1+1
122 
123  DO n=1,newn(2,nr)
124  nn = jseq(n+n1-1)
125  iutmp(n,nr) = nn
126  vutmp(n,nr) = vali(nn)
127  ENDDO
128 
129 C STORE NODES AT SOME RECURSION LEVEL
130 C -----------------------------------
131 
132 20 DO i=nbmp(1,nr),nbmp(2,nr)
133  IF(knx(nr).EQ.0000) knx(nr) = knvn
134  IF(i.GT.nbmp(1,nr)) newn(1,nr) = 1
135  DO j=newn(1,nr),newn(2,nr)
136  IF(knvn+1.GT.maxss) THEN
137  IF(iprt.GE.0) THEN
138  CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
139  CALL errwrt('BUFRLIB: RCSTPL - MAXSS OVERFLOW; SUBSET SKIPPED')
140  CALL errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
141  ENDIF
142  iret = -1
143  RETURN
144  ENDIF
145  knvn = knvn+1
146  node = iutmp(j,nr)
147 c .... INV is positional index in internal jump/link table for packed
148 c subset element KNVN in MBAY
149  inv(knvn,lun) = node
150 c .... MBIT is the bit in MBAY pointing to where the packed subset
151 c element KNVN begins
152  mbit(knvn) = mbit(knvn-1)+nbit(knvn-1)
153 c .... NBIT is the number of bits in MBAY occupied by packed subset
154 c element KNVN
155  nrfelm(knvn,lun) = igetrfel(knvn,lun)
156  nbit(knvn) = ibt(node)
157  IF(tag(node)(1:5).EQ.'DPRI ') THEN
158 c .... This is a bitmap entry, so get and store the corresponding value
159  CALL upbb(idpri,nbit(knvn),mbit(knvn),mbay(1,lun))
160  IF(idpri.EQ.0) THEN
161  val(knvn,lun) = 0.0
162  ELSE
163  val(knvn,lun) = bmiss
164  ENDIF
165  CALL strbtm(knvn,lun)
166  ENDIF
167 c .... Actual unpacked subset values (VAL) are initialized here
168 c (numbers as BMISS)
169  val(knvn,lun) = vutmp(j,nr)
170  IF(itp(node).EQ.1) THEN
171  CALL upbb(mbmp,nbit(knvn),mbit(knvn),mbay(1,lun))
172  newn(1,nr) = j+1
173  nbmp(1,nr) = i
174  goto 10
175  ENDIF
176  ENDDO
177  new = knvn-knx(nr)
178  val(knx(nr)+1,lun) = val(knx(nr)+1,lun) + new
179  knx(nr) = 0
180  ENDDO
181 
182 C CONTINUE AT ONE RECURSION LEVEL BACK
183 C ------------------------------------
184 
185  IF(nr-1.NE.0) THEN
186  nr = nr-1
187  goto 20
188  ENDIF
189 
190 C FINALLY STORE THE LENGTH OF (NUMBER OF ELEMENTS IN) SUBSET TEMPLATE
191 C -------------------------------------------------------------------
192 
193  nval(lun) = knvn
194 
195 C EXITS
196 C -----
197 
198  RETURN
199 900 WRITE(bort_str,'("BUFRLIB: RCSTPL - THE NUMBER OF RECURSION '//
200  . 'LEVELS EXCEEDS THE LIMIT (",I3,")")') maxrcr
201  CALL bort(bort_str)
202 901 WRITE(bort_str,'("BUFRLIB: RCSTPL - UNSET EXPANSION SEGMENT ",A)')
203  . tag(nodi)
204  CALL bort(bort_str)
205  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
subroutine strbtm(N, LUN)
THIS SUBROUTINE STORES INTERNAL INFORMATION IN MODULE BITMAPS IF THE INPUT ELEMENT IS PART OF A BITMA...
Definition: strbtm.f:21
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
This module contains array and variable declarations used to store the internal jump/link table...
Definition: moda_tables.F:13
subroutine errwrt(STR)
This subroutine allows the user to specify a custom location for the logging of error and diagnostic ...
Definition: errwrt.f:39
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:23
INTEGER function igetrfel(N, LUN)
THIS FUNCTION CHECKS WHETHER THE INPUT ELEMENT REFERS TO A PREVIOUS ELEMENT WITHIN THE SAME SUBSET VI...
Definition: igetrfel.f:35
This module contains array and variable declarations used to store BUFR messages internally for multi...
Definition: moda_bitbuf.F:10