80 SUBROUTINE ufbtab(LUNIN,TAB,I1,I2,IRET,STR)
88 COMMON /usrstr/ nnod,ncon,nods(20),nodc(10),ivls(10),kons(10)
93 CHARACTER*128 bort_str,errstr
96 CHARACTER*8 subset,cval
97 equivalence(cval,rval)
98 LOGICAL openit,just_count
99 REAL*8 tab(i1,i2),rval,
ups
104 mps(node) = 2**(ibt(node))-1
105 lps(lbit) = max(2**(lbit)-1,1)
121 just_count = lunin.LT.lunit
128 CALL
status(lunit,lun,il,im)
136 CALL
openbf(lunit,
'INX',lunit)
162 DO WHILE(
ireadmg(-lunit,subset,idate).GE.0)
163 iret = iret+
nmsub(lunit)
171 CALL
parstr(str,tgs,maxtg,ntg,
' ',.true.)
173 IF(tgs(i).EQ.
'IREC') irec = i
174 IF(tgs(i).EQ.
'ISUB') isub = i
180 10
IF(
ireadmg(-lunit,subset,jdate).LT.0) goto 25
182 IF(irec.GT.0) nods(irec) = 0
183 IF(isub.GT.0) nods(isub) = 0
188 CALL
mesgbc(-lunit,mtyp,icmp)
191 ELSEIF(icmp.EQ.1)
then
203 15
IF(nsub(lun).EQ.msub(lun)) goto 10
204 IF(iret+1.GT.i2) goto 99
208 nods(i) = abs(nods(i))
214 mbit = mbyt(lun)*8 + 16
218 20
IF(n+1.LE.nval(lun))
THEN
223 IF(itp(node).EQ.1)
THEN
224 CALL
upbb(ival,nbit,mbit,mbay(1,lun))
228 IF(nods(i).EQ.node)
THEN
229 IF(itp(node).EQ.1)
THEN
230 CALL
upbb(ival,nbit,mbit,mbay(1,lun))
232 ELSEIF(itp(node).EQ.2)
THEN
233 CALL
upbb(ival,nbit,mbit,mbay(1,lun))
234 IF(ival.LT.mps(node)) tab(i,iret) =
ups(ival,node)
235 ELSEIF(itp(node).EQ.3)
THEN
238 CALL
upc(cval,nbit/8,mbay(1,lun),kbit,.true.)
246 IF(nods(i).GT.0) goto 20
254 CALL
upb(nbyt,16,mbay(1,lun),ibit)
255 mbyt(lun) = mbyt(lun) + nbyt
256 nsub(lun) = nsub(lun) + 1
257 IF(irec.GT.0) tab(irec,iret) = nmsg(lun)
258 IF(isub.GT.0) tab(isub,iret) = nsub(lun)
270 115
IF(iret+msub(lun).GT.i2) goto 99
275 IF(irec.GT.0.OR.isub.GT.0)
THEN
277 IF(irec.GT.0) tab(irec,iret+nsb) = nmsg(lun)
278 IF(isub.GT.0) tab(isub,iret+nsb) = nsb
295 120
DO n=n+1,nval(lun)
305 nods(i) = abs(nods(i))
309 IF(nods(i).GT.0) goto 125
317 125
IF(ityp.EQ.1.OR.ityp.EQ.2)
THEN
318 CALL
upb(lref,nbit,mbay(1,lun),ibit)
319 CALL
upb(linc, 6,mbay(1,lun),ibit)
320 nibit = ibit + linc*msub(lun)
321 ELSEIF(ityp.EQ.3)
THEN
323 CALL
upc(cref,nbit/8,mbay(1,lun),ibit,.true.)
324 CALL
upb(linc, 6,mbay(1,lun),ibit)
325 nibit = ibit + 8*linc*msub(lun)
335 CALL
upb(ninc,linc,mbay(1,lun),jbit)
349 IF(node.NE.nods(i)) goto 130
356 IF(ityp.EQ.1.OR.ityp.EQ.2)
THEN
358 jbit = ibit + linc*(nsb-1)
359 CALL
upb(ninc,linc,mbay(1,lun),jbit)
362 IF(ninc.LT.lps(linc)) tab(i,lret) =
ups(ival,node)
364 ELSEIF(ityp.EQ.3)
THEN
369 jbit = ibit + linc*(nsb-1)*8
371 CALL
upc(cval,linc,mbay(1,lun),jbit,.true.)
377 CALL
bort(
'UFBTAB - INVALID ELEMENT TYPE SPECIFIED')
391 135 iret = iret+msub(lun)
408 DO WHILE(
ireadmg(-lunit,subset,jdate).GE.0)
409 nrep = nrep+
nmsub(lunit)
412 CALL
errwrt(
'+++++++++++++++++++++WARNING+++++++++++++++++++++++')
413 WRITE ( unit=errstr, fmt=
'(A,A,I8,A,A)' )
414 .
'BUFRLIB: UFBTAB - THE NO. OF DATA SUBSETS IN THE BUFR FILE ',
415 . .GT.
'IS LIMIT OF ', i2,
' IN THE 4TH ARG. (INPUT) - ',
418 WRITE ( unit=errstr, fmt=
'(A,I8,A,I8,A)' )
419 .
'>>>UFBTAB STORED ', iret,
' REPORTS OUT OF ', nrep,
'<<<'
421 CALL
errwrt(
'+++++++++++++++++++++WARNING+++++++++++++++++++++++')
446 900
WRITE(bort_str,
'("BUFRLIB: UFBTAB - INVALID COMPRESSION '//
447 .
'INDICATOR (ICMP=",I3," RETURNED FROM BUFR ARCHIVE LIBRARY '//
448 .
'ROUTINE MESGBC")') icmp
subroutine upbb(NVAL, NBITS, IBIT, IBAY)
THIS SUBROUTINE UNPACKS AND RETURNS A BINARY INTEGER CONTAINED WITHIN NBITS BITS OF IBAY...
function ireadmg(LUNIT, SUBSET, IDATE)
This function calls BUFRLIB subroutine readmg() and passes back its return code as the function value...
subroutine upb(NVAL, NBITS, IBAY, IBIT)
THIS SUBROUTINE UNPACKS AND RETURNS A BINARY INTEGER CONTAINED WITHIN NBITS BITS OF IBAY...
function ireadsb(LUNIT)
This function calls BUFRLIB subroutine readsb() and passes back its return code as the function value...
subroutine parstr(STR, TAGS, MTAG, NTAG, SEP, LIMIT80)
THIS SUBROUTINE PARSES A STRING CONTAINING ONE OR MORE SUBSTRINGS INTO AN ARRAY OF SUBSTRINGS...
subroutine usrtpl(LUN, INVN, NBMP)
THIS SUBROUTINE STORES THE SUBSET TEMPLATE INTO INTERNAL SUBSET ARRAYS IN MODULE USRINT FOR CASES OF ...
This module declares and initializes the BMISS variable.
subroutine closbf(LUNIT)
This subroutine closes the connection between logical unit LUNIT and the BUFRLIB software.
subroutine upc(CHR, NCHR, IBAY, IBIT, CNVNULL)
THIS SUBROUTINE UNPACKS AND RETURNS A CHARACTER STRING OF LENGTH NCHR CONTAINED WITHIN NCHR BYTES OF ...
subroutine mesgbc(LUNIN, MESGTYP, ICOMP)
THIS SUBROUTINE EXAMINES A BUFR MESSAGE AND RETURNS BOTH THE MESSAGE TYPE FROM SECTION 1 AND A MESSAG...
subroutine string(STR, LUN, I1, IO)
THIS SUBROUTINE CHECKS TO SEE IF A USER-SPECIFIED CHARACTER STRING IS IN THE STRING CACHE (ARRAYS IN ...
This module contains array and variable declarations used to store the internal jump/link table...
subroutine status(LUNIT, LUN, IL, IM)
This subroutine checks whether a specified Fortran logical unit number is currently connected to the ...
subroutine openbf(LUNIT, IO, LUNDX)
This subroutine connects a new file to the BUFRLIB software for input or output operations.
subroutine errwrt(STR)
This subroutine allows the user to specify a custom location for the logging of error and diagnostic ...
function nmsub(LUNIT)
This function returns the total number of data subsets available within the BUFR message that was mos...
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
This module contains array and variable declarations used to store BUFR messages internally for multi...
subroutine ufbtab(LUNIN, TAB, I1, I2, IRET, STR)
This subroutine reads through every data subset in a BUFR file and returns one or more specified data...
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...
subroutine rewnbf(LUNIT, ISR)
THIS SUBROUTINE, DEPENDING ON THE VALUE OF ISR, WILL EITHER: 1) STORE THE CURRENT PARAMETERS ASSOCIAT...