NCEPLIBS-bufr  12.1.0
jumplink.F90
Go to the documentation of this file.
1 
5 
22 subroutine makestab
23 
24  use modv_vars, only: bmiss, maxjl, nfiles
25 
26  use moda_usrint
27  use moda_stbfr
28  use moda_lushr
29  use moda_xtab
30  use moda_tababd
31  use moda_tables
32  use moda_nrv203
33  use moda_bitmaps
34 
35  implicit none
36 
37  integer iprt, lunit, lundx, lun, lum, k, n, itba, inc, newn, noda, node, inod, icmpdx, ishrdx
38 
39  character*128 bort_str, errstr
40  character*8 nemo
41 
42  logical expand
43 
44  common /quiet/ iprt
45 
46  ! Reset pointer table and string cache.
47 
48  ntab = 0
49  nnrv = 0
50  ntamc = 0
51  call strcln
52 
53  ! Figure out which units share tables.
54 
55  ! The lus array is static between calls to this subroutine, and it keeps track of which logical units share dictionary
56  ! table information:
57  ! if lus(i) = 0, then iolun(i) does not share dictionary table information with any other logical unit
58  ! if lus(i) > 0, then iolun(i) shares dictionary table information with logical unit iolun(lus(i))
59  ! if lus(i) < 0, then iolun(i) does not now, but at one point in the past, shared dictionary table information
60  ! with logical unit iolun(abs(lus(i)))
61 
62  ! The xtab array is non-static and is recomputed within the below loop during each call to this subroutine:
63  ! if xtab(i) = .true., then the dictionary table information has changed for iolun(i) since the last call to this subroutine
64  ! if xtab(i) = .false., then the dictionary table information has not changed for iolun(i) since the last call to this subroutine
65 
66  do lun=1,nfiles
67  xtab(lun) = .false.
68  if(iolun(lun)==0) then
69  ! Logical unit iolun(lun) is not defined to NCEPLIBS-bufr.
70  lus(lun) = 0
71  else if(mtab(1,lun)==0) then
72  ! New dictionary table information has been read for logical unit iolun(lun) since the last call to this subroutine.
73  xtab(lun) = .true.
74  if(lus(lun)/=0) then
75  if(iolun(abs(lus(lun)))==0) then
76  lus(lun) = 0
77  else if(lus(lun)>0) then
78  ! iolun(lun) was sharing table information with logical unit iolun(lus(lun)), so check whether the table information
79  ! has really changed. If not, then iolun(lun) just re-read a copy of the exact same table information as before,
80  ! and therefore it can continue to share with logical unit iolun(lus(lun)).
81  if(icmpdx(lus(lun),lun)==1) then
82  xtab(lun) = .false.
83  call cpbfdx(lus(lun),lun)
84  else
85  lus(lun) = (-1)*lus(lun)
86  endif
87  else if(icmpdx(abs(lus(lun)),lun)==1) then
88  ! iolun(lun) was not sharing table information with logical unit iolun(lus(lun)), but it did at one point in the past
89  ! and now once again has the same table information as that logical unit. Since the two units shared table
90  ! information at one point in the past, allow them to do so again.
91  xtab(lun) = .false.
92  lus(lun) = abs(lus(lun))
93  call cpbfdx(lus(lun),lun)
94  endif
95  endif
96  else if(lus(lun)>0) then
97  ! Logical unit iolun(lun) is sharing table information with logical unit iolun(lus(lun)), so make sure that the latter
98  ! unit is still defined to NCEPLIBS-bufr.
99  if(iolun(lus(lun))==0) then
100  lus(lun) = 0
101  else if( xtab(lus(lun)) .and. (icmpdx(lus(lun),lun)==0) ) then
102  ! The table information for logical unit iolun(lus(lun)) just changed (in midstream). If iolun(lun) is an output
103  ! file, then we will have to update it with the new table information later on in this subroutine. Otherwise,
104  ! iolun(lun) is an input file and is no longer sharing tables with iolun(lus(lun)).
105  if(iolun(lun)<0) lus(lun) = (-1)*lus(lun)
106  endif
107  else
108  ! Determine whether logical unit iolun(lun) is sharing table information with any other logical units.
109  lum = 1
110  do while ((lum<lun).and.(lus(lun)==0))
111  if(ishrdx(lum,lun)==1) then
112  lus(lun) = lum
113  else
114  lum = lum+1
115  endif
116  enddo
117  endif
118  enddo
119 
120  ! Initialize jump/link tables with subsets/sequences/elements.
121 
122  do lun=1,nfiles
123  if(iolun(lun)/=0 .and. ntba(lun)>0) then
124  ! Reset any existing inventory pointers.
125  if(iomsg(lun)/=0) then
126  if(lus(lun)<=0) then
127  inc = (ntab+1)-mtab(1,lun)
128  else
129  inc = mtab(1,lus(lun))-mtab(1,lun)
130  endif
131  do n=1,nval(lun)
132  inv(n,lun) = inv(n,lun)+inc
133  enddo
134  endif
135  if(lus(lun)<=0) then
136  ! The dictionary table information corresponding to logical unit iolun(lun) has not yet been written into the internal
137  ! jump/link table, so add it in now.
138  call chekstab(lun)
139  do itba=1,ntba(lun)
140  inod = ntab+1
141  nemo = taba(itba,lun)(4:11)
142  call tabsub(lun,nemo)
143  mtab(itba,lun) = inod
144  isc(inod) = ntab
145  enddo
146  else if( xtab(lus(lun)) .and. (icmpdx(lus(lun),lun)==0) ) then
147  ! Logical unit iolun(lun) is an output file that is sharing table information with logical unit iolun(lus(lun)) whose
148  ! table just changed (in midstream). Flush any existing data messages from iolun(lun), then update the table information
149  ! for this logical unit with the corresponding new table information from iolun(lus(lun)), then update iolun(lun) itself
150  ! with a copy of the new table information.
151  lunit = abs(iolun(lun))
152  if(iomsg(lun)/=0) call closmg(lunit)
153  call cpbfdx(lus(lun),lun)
154  lundx = abs(iolun(lus(lun)))
155  call wrdxtb(lundx,lunit)
156  endif
157  endif
158  enddo
159 
160  ! Store types and initial values and counts
161 
162  do node=1,ntab
163  if(typ(node)=='SUB') then
164  vali(node) = 0
165  knti(node) = 1
166  itp(node) = 0
167  elseif(typ(node)=='SEQ') then
168  vali(node) = 0
169  knti(node) = 1
170  itp(node) = 0
171  elseif(typ(node)=='RPC') then
172  vali(node) = 0
173  knti(node) = 0
174  itp(node) = 0
175  elseif(typ(node)=='RPS') then
176  vali(node) = 0
177  knti(node) = 0
178  itp(node) = 0
179  elseif(typ(node)=='REP') then
180  vali(node) = bmiss
181  knti(node) = irf(node)
182  itp(node) = 0
183  elseif(typ(node)=='DRS') then
184  vali(node) = 0
185  knti(node) = 1
186  itp(node) = 1
187  elseif(typ(node)=='DRP') then
188  vali(node) = 0
189  knti(node) = 1
190  itp(node) = 1
191  elseif(typ(node)=='DRB') then
192  vali(node) = 0
193  knti(node) = 0
194  itp(node) = 1
195  elseif(typ(node)=='NUM') then
196  vali(node) = bmiss
197  knti(node) = 1
198  itp(node) = 2
199  else ! typ(node)=='CHR'
200  vali(node) = bmiss
201  knti(node) = 1
202  itp(node) = 3
203  endif
204  enddo
205 
206  ! Set up expansion segments for type 'SUB', 'DRP', and 'DRS' nodes.
207 
208  newn = 0
209 
210  do n=1,ntab
211  iseq(n,1) = 0
212  iseq(n,2) = 0
213  expand = typ(n)=='SUB' .or. typ(n)=='DRP' .or. typ(n)=='DRS' .or. typ(n)=='REP' .or. typ(n)=='DRB'
214  if(expand) then
215  iseq(n,1) = newn+1
216  noda = n
217  node = n+1
218  do k=1,maxjl
219  knt(k) = 0
220  enddo
221  if(typ(noda)=='REP') then
222  knt(node) = knti(noda)
223  else
224  knt(node) = 1
225  endif
226 
227  outer: do while (.true.)
228  newn = newn+1
229  if(newn>maxjl) then
230  write(bort_str,'("BUFRLIB: MAKESTAB - NUMBER OF JSEQ ENTRIES IN JUMP/LINK TABLE EXCEEDS THE LIMIT (",I6,")")') maxjl
231  call bort(bort_str)
232  endif
233  jseq(newn) = node
234  knt(node) = max(knti(node),knt(node))
235  inner: do while (.true.)
236  if(jump(node)*knt(node)>0) then
237  node = jump(node)
238  cycle outer
239  else if(link(node)>0) then
240  node = link(node)
241  cycle outer
242  else
243  node = jmpb(node)
244  if(node==noda) exit outer
245  if(node==0) then
246  write(bort_str,'("BUFRLIB: MAKESTAB - NODE IS ZERO, FAILED TO CIRCULATE (TAG IS ",A,")")') tag(n)
247  call bort(bort_str)
248  endif
249  knt(node) = max(knt(node)-1,0)
250  endif
251  enddo inner
252  enddo outer
253  iseq(n,2) = newn
254  endif
255  enddo
256 
257  ! Print the sequence tables
258 
259  if(iprt>=2) then
260  call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
261  do n=1,ntab
262  write ( unit=errstr, fmt='(A,I5,2X,A10,A5,6I8)' ) &
263  'BUFRLIB: MAKESTAB ', n, tag(n), typ(n), jmpb(n), jump(n), link(n), ibt(n), irf(n), isc(n)
264  call errwrt(errstr)
265  enddo
266  call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
267  call errwrt(' ')
268  endif
269 
270  return
271 end subroutine makestab
272 
279 subroutine chekstab(lun)
280 
281  use moda_tababd
282  use moda_nmikrp
283 
284  implicit none
285 
286  integer, intent(in) :: lun
287  integer itab, idn, iret, iscl, iref, ibit, nseq
288 
289  character*128 bort_str
290  character*24 unit
291  character*8 nemo
292  character*1 tab
293 
294  ! There must be entries in Tables A, B, and D
295 
296  if(ntba(lun)==0) call bort ('BUFRLIB: CHEKSTAB - EMPTY TABLE A IN INTERNAL BUFR TABLES')
297  if(ntbb(lun)==0) call bort ('BUFRLIB: CHEKSTAB - EMPTY TABLE B IN INTERNAL BUFR TABLES')
298  if(ntbd(lun)==0) call bort ('BUFRLIB: CHEKSTAB - EMPTY TABLE D IN INTERNAL BUFR TABLES')
299 
300  ! Make sure each Table A entry is defined as a sequence
301 
302  do itab=1,ntba(lun)
303  nemo = taba(itab,lun)(4:11)
304  call nemtab(lun,nemo,idn,tab,iret)
305  if(tab/='D') then
306  write(bort_str,'("BUFRLIB: CHEKSTAB - TABLE A ENTRY: ",A," NOT DEFINED AS A SEQUENCE")') nemo
307  call bort(bort_str)
308  endif
309  enddo
310 
311  ! Check Table B contents
312 
313  do itab=1,ntbb(lun)
314  call nemtbb(lun,itab,unit,iscl,iref,ibit)
315  enddo
316 
317  ! Check Table D contents
318 
319  do itab=1,ntbd(lun)
320  call nemtbd(lun,itab,nseq,nem(1,1),irp(1,1),krp(1,1))
321  enddo
322 
323  return
324 end subroutine chekstab
325 
333 subroutine tabsub(lun,nemo)
334 
335  use modv_vars, only: mxtamc, mxtco
336 
337  use moda_tables
338  use moda_nmikrp
339  use moda_nrv203
340  use moda_bitmaps
341 
342  implicit none
343 
344  integer, intent(in) :: lun
345  integer jmp0(10), nodl(10), ntag(10,2), icdw, icsc, icrv, incw, maxlim, node, idn, itab, nseq, limb, n, jj, iyyy, &
346  irep, iknt, jum0, iokoper
347 
348  character*128 bort_str
349  character*8, intent(in) :: nemo
350  character*8 nems
351  character*1 tab
352 
353  logical drop(10), ltamc
354 
355  common /tabccc/ icdw, icsc, icrv, incw
356 
357  data maxlim /10/
358 
359  ! Check the mnemonic
360 
361  ! Note that Table A mnemonics, in addition to being stored within internal BUFR Table A array taba(*,lun), are also stored as
362  ! Table D mnemonics within internal BUFR Table D array tabd(*,lun). So the following test is valid.
363 
364  call nemtab(lun,nemo,idn,tab,itab)
365  if(tab/='D') then
366  write(bort_str,'("BUFRLIB: TABSUB - SUBSET NODE NOT IN TABLE D (TAB=",A,") FOR INPUT MNEMONIC ",A)') tab,nemo
367  call bort(bort_str)
368  endif
369 
370  ! Store a subset node and jump/link the tree
371 
372  call inctab(nemo,'SUB',node)
373  jump(node) = node+1
374  jmpb(node) = 0
375  link(node) = 0
376  ibt(node) = 0
377  irf(node) = 0
378  isc(node) = 0
379 
380  call nemtbd(lun,itab,nseq,nem(1,1),irp(1,1),krp(1,1))
381  ntag(1,1) = 1
382  ntag(1,2) = nseq
383  jmp0(1) = node
384  nodl(1) = node
385  limb = 1
386 
387  icdw = 0
388  icsc = 0
389  icrv = 1
390  incw = 0
391 
392  ibtnrv = 0
393  ipfnrv = 0
394 
395  if(ntamc+1>mxtamc) call bort('BUFRLIB: TABSUB - MXTAMC OVERFLOW')
396  inodtamc(ntamc+1) = node
397  ntco(ntamc+1) = 0
398  ltamc = .false.
399 
400  ! The following loop resolves all entities in the subset by emulating recursion via explicit goto statements.
401 
402  11 do n=ntag(limb,1),ntag(limb,2)
403 
404  ntag(limb,1) = n+1
405  drop(limb) = n==ntag(limb,2)
406 
407  call nemtab(lun,nem(n,limb),idn,tab,itab)
408  nems = nem(n,limb)
409 
410  if(tab=='C') then
411  ! Special treatment for certain operator descriptors.
412  read(nems,'(3X,I3)') iyyy
413  if(itab==1) then
414  if(iyyy/=0) then
415  if(icdw/=0) then
416  write(bort_str,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '// &
417  'CHANGE DATA WIDTH OPERATIONS IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo
418  call bort(bort_str)
419  endif
420  icdw = iyyy-128
421  else
422  icdw = 0
423  endif
424  elseif(itab==2) then
425  if(iyyy/=0) then
426  if(icsc/=0) then
427  write(bort_str,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '// &
428  'CHANGE DATA SCALE OPERATIONS IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo
429  call bort(bort_str)
430  endif
431  icsc = iyyy-128
432  else
433  icsc = 0
434  endif
435  elseif(itab==3) then
436  if(iyyy==0) then
437  ! Stop applying new reference values to subset nodes. Instead, revert to the use of standard Table B values.
438  if(ipfnrv==0) then
439  write(bort_str,'("BUFRLIB: TABSUB - A 2-03-000 OPERATOR WAS '// &
440  'ENCOUNTERED WITHOUT ANY PRIOR 2-03-YYY OPERATOR FOR INPUT MNEMONIC ",A)') nemo
441  call bort(bort_str)
442  endif
443  do jj=ipfnrv,nnrv
444  ienrv(jj) = ntab
445  enddo
446  ipfnrv = 0
447  elseif(iyyy==255) then
448  ! End the definition of new reference values.
449  ibtnrv = 0
450  else
451  ! Begin the definition of new reference values.
452  if(ibtnrv/=0) then
453  write(bort_str,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '// &
454  'CHANGE REF VALUE OPERATIONS IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo
455  call bort(bort_str)
456  endif
457  ibtnrv = iyyy
458  endif
459  elseif(itab==7) then
460  if(iyyy>0) then
461  if(icdw/=0) then
462  write(bort_str,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '// &
463  'CHANGE DATA WIDTH OPERATIONS IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo
464  call bort(bort_str)
465  endif
466  if(icsc/=0) then
467  write(bort_str,'("BUFRLIB: TABSUB - THERE ARE TWO SIMULTANEOUS '// &
468  'CHANGE DATA SCALE OPERATIONS IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo
469  call bort(bort_str)
470  endif
471  icdw = ((10*iyyy)+2)/3
472  icsc = iyyy
473  icrv = 10**iyyy
474  else
475  icsc = 0
476  icdw = 0
477  icrv = 1
478  endif
479  elseif(itab==8) then
480  incw = iyyy
481  elseif((itab>=21).and.(iokoper(nems)==1)) then
482  ! Save the location of this operator within the jump/link table, for possible later use.
483  if(.not.ltamc) then
484  ltamc = .true.
485  ntamc = ntamc+1
486  end if
487  if(ntco(ntamc)+1>mxtco) call bort('BUFRLIB: TABSUB - MXTCO OVERFLOW')
488  ntco(ntamc) = ntco(ntamc)+1
489  ctco(ntamc,ntco(ntamc)) = nems(1:6)
491  endif
492  else
493  nodl(limb) = ntab+1
494  irep = irp(n,limb)
495  iknt = krp(n,limb)
496  jum0 = jmp0(limb)
497  call tabent(lun,nems,tab,itab,irep,iknt,jum0)
498  endif
499 
500  if(tab=='D') then
501  ! Note here how a new tree "limb" is created (and is then immediately recursively resolved) whenever a Table D mnemonic
502  ! contains another Table D mnemonic as one of its children.
503  limb = limb+1
504  if(limb>maxlim) then
505  write(bort_str,'("BUFRLIB: TABSUB - THERE ARE TOO MANY NESTED '// &
506  'TABLE D SEQUENCES (TREES) WITHIN INPUT MNEMONIC ",A," - THE LIMIT IS",I4)') nemo,maxlim
507  call bort(bort_str)
508  endif
509  call nemtbd(lun,itab,nseq,nem(1,limb),irp(1,limb),krp(1,limb))
510  ntag(limb,1) = 1
511  ntag(limb,2) = nseq
512  jmp0(limb) = ntab
513  goto 11
514  elseif(drop(limb)) then
515  do while (.true.)
516  link(nodl(limb)) = 0
517  limb = limb-1
518  if(limb==0) then
519  if(icrv/=1) then
520  write(bort_str,'("BUFRLIB: TABSUB - A 2-07-YYY OPERATOR WAS '// &
521  'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo
522  call bort(bort_str)
523  endif
524  if(icdw/=0) then
525  write(bort_str,'("BUFRLIB: TABSUB - A 2-01-YYY OPERATOR WAS '// &
526  'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo
527  call bort(bort_str)
528  endif
529  if(icsc/=0) then
530  write(bort_str,'("BUFRLIB: TABSUB - A 2-02-YYY OPERATOR WAS '// &
531  'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo
532  call bort(bort_str)
533  endif
534  if(incw/=0) then
535  write(bort_str,'("BUFRLIB: TABSUB - A 2-08-YYY OPERATOR WAS '// &
536  'NOT CANCELLED IN THE TREE BUILT FROM INPUT MNEMONIC ",A)') nemo
537  call bort(bort_str)
538  endif
539  if(ibtnrv/=0) then
540  write(bort_str,'("BUFRLIB: TABSUB - A 2-03-YYY OPERATOR WAS '// &
541  'APPLIED WITHOUT ANY SUBSEQUENT 2-03-255 OPERATOR FOR INPUT MNEMONIC ",A)') nemo
542  call bort(bort_str)
543  endif
544  if(ipfnrv/=0) then
545  ! One or more new reference values were defined for this subset, but there was no subsequent 2-03-000 operator,
546  ! so set all IENRV(*) values for this subset to point to the last element of the subset within the jump/link table.
547  ! Note that, if there had been a subsequent 2-03-000 operator, then these IENRV(*) values would have already been
548  ! properly set above.
549  do jj=ipfnrv,nnrv
550  ienrv(jj) = ntab
551  enddo
552  endif
553  return
554  endif
555  if(.not.drop(limb)) exit
556  enddo
557  link(nodl(limb)) = ntab+1
558  goto 11
559  elseif(tab/='C') then
560  link(nodl(limb)) = ntab+1
561  endif
562 
563  enddo
564 
565  write(bort_str,'("BUFRLIB: TABSUB - ENTITIES WERE NOT SUCCESSFULLY RESOLVED (BY EMULATING RESURSION) FOR SUBSET '// &
566  'DEFINED BY TBL A MNEM. ",A)') nemo
567  call bort(bort_str)
568 
569  return
570 end subroutine tabsub
571 
585 subroutine tabent(lun,nemo,tab,itab,irep,iknt,jum0)
586 
587  use modv_vars, only: mxnrv, typs, reps, lens
588 
589  use moda_tables
590  use moda_nrv203
591 
592  implicit none
593 
594  integer, intent(in) :: lun, itab, irep, iknt, jum0
595  integer icdw, icsc, icrv, incw, i, jm0, node, iscl, iref, ibit
596 
597  character*24 unit
598  character*10 rtag
599  character*8, intent(in) :: nemo
600  character, intent(in) :: tab
601  character*3 typt
602 
603  common /tabccc/ icdw, icsc, icrv, incw
604 
605  jm0 = jum0
606 
607  ! Make a jump/link table entry for a replicator
608 
609  if(irep/=0) then
610  rtag = reps(irep)//nemo
611  do i=1,10
612  if(rtag(i:i)==' ') then
613  rtag(i:i) = reps(irep+5)
614  call inctab(rtag,typs(irep),node)
615  jump(node) = node+1
616  jmpb(node) = jm0
617  link(node) = 0
618  ibt(node) = lens(irep)
619  irf(node) = 0
620  isc(node) = 0
621  if(irep==1) irf(node) = iknt
622  jm0 = node
623  exit
624  endif
625  enddo
626  endif
627 
628  ! Make a jump/link entry for an element or a sequence
629 
630  if(tab=='B') then
631  call nemtbb(lun,itab,unit,iscl,iref,ibit)
632  if(unit(1:5)=='CCITT') then
633  typt = 'CHR'
634  else
635  typt = 'NUM'
636  endif
637  call inctab(nemo,typt,node)
638  jump(node) = 0
639  jmpb(node) = jm0
640  link(node) = 0
641  ibt(node) = ibit
642  irf(node) = iref
643  isc(node) = iscl
644  if(unit(1:4)=='CODE') then
645  typt = 'COD'
646  elseif(unit(1:4)=='FLAG') then
647  typt = 'FLG'
648  endif
649  if( (typt=='NUM') .and. (ibtnrv/=0) ) then
650  ! This node contains a new (redefined) reference value.
651  if(nnrv+1>mxnrv) call bort('BUFRLIB: TABENT - MXNRV OVERFLOW')
652  nnrv = nnrv+1
653  tagnrv(nnrv) = nemo
654  inodnrv(nnrv) = node
655  isnrv(nnrv) = node+1
656  ibt(node) = ibtnrv
657  if(ipfnrv==0) ipfnrv = nnrv
658  elseif( (typt=='NUM') .and. (nemo(1:3)/='204') ) then
659  ibt(node) = ibt(node) + icdw
660  isc(node) = isc(node) + icsc
661  irf(node) = irf(node) * icrv
662  elseif( (typt=='CHR') .and. (incw>0) ) then
663  ibt(node) = incw * 8
664  endif
665  else ! tab=='D'
666  if(irep==0) then
667  typt = 'SEQ'
668  else
669  typt = typs(irep+5)
670  endif
671  call inctab(nemo,typt,node)
672  jump(node) = node+1
673  jmpb(node) = jm0
674  link(node) = 0
675  ibt(node) = 0
676  irf(node) = 0
677  isc(node) = 0
678  endif
679 
680  return
681 end subroutine tabent
682 
695 subroutine inctab(atag,atyp,node)
696 
697  use modv_vars, only: maxjl
698 
699  use moda_tables
700 
701  implicit none
702 
703  integer, intent(out) :: node
704 
705  character*(*), intent(in) :: atag, atyp
706  character*128 bort_str
707 
708  ntab = ntab+1
709  if(ntab>maxjl) then
710  write(bort_str,'("BUFRLIB: INCTAB - THE NUMBER OF JUMP/LINK TABLE ENTRIES EXCEEDS THE LIMIT, MAXJL (",I7,")")') maxjl
711  call bort(bort_str)
712  endif
713  tag(ntab) = atag
714  typ(ntab) = atyp
715  node = ntab
716 
717  return
718 end subroutine inctab
719 
740 integer function lstjpb(node,lun,jbtyp) result(iret)
741 
742  use moda_msgcwd
743  use moda_tables
744 
745  implicit none
746 
747  integer, intent(in) :: node, lun
748  integer nod
749 
750  character*(*), intent(in) :: jbtyp
751  character*128 bort_str
752 
753  if(node<inode(lun)) then
754  write(bort_str,'("BUFRLIB: LSTJPB - TABLE NODE (",I7,") IS OUT OF BOUNDS, < LOWER BOUNDS (",I7,")")') node,inode(lun)
755  call bort(bort_str)
756  endif
757  if(node>isc(inode(lun))) then
758  write(bort_str,'("BUFRLIB: LSTJPB - TABLE NODE (",I7,") IS OUT OF BOUNDS, > UPPER BOUNDS (",I7,")")') node,isc(inode(lun))
759  call bort(bort_str)
760  endif
761 
762  nod = node
763 
764  ! Find this or the previous node of type jbtyp
765 
766  do while (nod/=0)
767  if(typ(nod)==jbtyp) exit
768  nod = jmpb(nod)
769  enddo
770 
771  iret = nod
772 
773  return
774 end function lstjpb
775 
786 integer function ishrdx(lud,lun) result(iret)
787 
788  use moda_tababd
789 
790  implicit none
791 
792  integer, intent(in) :: lud, lun
793  integer ii
794 
795  ! Note that, for any file ID luX, the mtab(*,luX) array contains pointer indices into the internal jump/link table
796  ! for each of the Table A mnemonics that is currently defined for that luX value. Thus, if all of these indices are
797  ! identical for two different luX values, then the associated logical units are sharing table information.
798 
799  if ( ( ntba(lud) >= 1 ) .and. ( ntba(lud) == ntba(lun) ) ) then
800  ii = 1
801  iret = 1
802  do while ( ( ii <= ntba(lud) ) .and. ( iret == 1 ) )
803  if ( ( mtab(ii,lud) /= 0 ) .and. ( mtab(ii,lud) == mtab(ii,lun) ) ) then
804  ii = ii + 1
805  else
806  iret = 0
807  endif
808  enddo
809  else
810  iret = 0
811  endif
812 
813  return
814 end function ishrdx
815 
831 integer function icmpdx(lud,lun) result(iret)
832 
833  use moda_tababd
834 
835  implicit none
836 
837  integer, intent(in) :: lud, lun
838  integer ishrdx, i
839 
840  ! First, check whether the two units are actually sharing tables.
841  ! If so, then they obviously have the same table information.
842 
843  iret = ishrdx(lud,lun)
844  if ( iret == 1 ) return
845 
846  ! Otherwise, check whether the internal Table A, B and D entries are all identical between the two units.
847 
848  if ( ( ntba(lud) == 0 ) .or. ( ntba(lun) /= ntba(lud) ) ) return
849  do i = 1, ntba(lud)
850  if ( idna(i,lun,1) /= idna(i,lud,1) ) return
851  if ( idna(i,lun,2) /= idna(i,lud,2) ) return
852  if ( taba(i,lun) /= taba(i,lud) ) return
853  enddo
854 
855  if ( ( ntbb(lud) == 0 ) .or. ( ntbb(lun) /= ntbb(lud) ) ) return
856  do i = 1, ntbb(lud)
857  if ( idnb(i,lun) /= idnb(i,lud) ) return
858  if ( tabb(i,lun) /= tabb(i,lud) ) return
859  enddo
860 
861  if ( ( ntbd(lud) == 0 ) .or. ( ntbd(lun) /= ntbd(lud) ) ) return
862  do i = 1, ntbd(lud)
863  if ( idnd(i,lun) /= idnd(i,lud) ) return
864  if ( tabd(i,lun) /= tabd(i,lud) ) return
865  enddo
866 
867  iret = 1
868 
869  return
870 end function icmpdx
871 
897 subroutine drstpl(inod,lun,inv1,inv2,invn)
898 
899  use moda_tables
900 
901  implicit none
902 
903  integer, intent(in) :: inod, lun, inv1
904  integer, intent(inout) :: inv2
905  integer, intent(out) :: invn
906  integer node, invwin
907 
908  do while (.true.)
909  node = inod
910  do while (.true.)
911  node = jmpb(node)
912  if(node==0) return
913  if(typ(node)=='DRS' .or. typ(node)=='DRB') then
914  invn = invwin(node,lun,inv1,inv2)
915  if(invn>0) then
916  call usrtpl(lun,invn,1)
917  call newwin(lun,inv1,inv2)
918  invn = invwin(inod,lun,invn,inv2)
919  if(invn>0) return
920  exit
921  endif
922  endif
923  enddo
924  enddo
925 
926  return
927 end subroutine drstpl
928 
961 recursive subroutine nemspecs ( lunit, nemo, nnemo, nscl, nref, nbts, iret )
962 
963  use modv_vars, only: im8b
964 
965  use moda_usrint
966  use moda_msgcwd
967  use moda_tables
968  use moda_nrv203
969 
970  implicit none
971 
972  integer, intent(in) :: lunit, nnemo
973  integer, intent(out) :: nscl, nref, nbts, iret
974  integer my_lunit, my_nnemo, lun, il, im, nidx, ierfst, node, ltn, jj
975 
976  character*(*), intent(in) :: nemo
977  character*10 tagn
978 
979  ! Check for I8 integers.
980 
981  if(im8b) then
982  im8b=.false.
983 
984  call x84(lunit,my_lunit,1)
985  call x84(nnemo,my_nnemo,1)
986  call nemspecs(my_lunit,nemo,my_nnemo,nscl,nref,nbts,iret)
987  call x48(nscl,nscl,1)
988  call x48(nref,nref,1)
989  call x48(nbts,nbts,1)
990  call x48(iret,iret,1)
991 
992  im8b=.true.
993  return
994  endif
995 
996  iret = -1
997 
998  ! Get lun from lunit.
999 
1000  call status( lunit, lun, il, im )
1001  if ( il == 0 ) return
1002  if ( inode(lun) /= inv(1,lun) ) return
1003 
1004  ! Starting from the beginning of the subset, locate the (nnemo)th occurrence of nemo.
1005 
1006  call fstag( lun, nemo, nnemo, 1, nidx, ierfst )
1007  if ( ierfst /= 0 ) return
1008 
1009  ! Confirm that nemo is a Table B mnemonic.
1010 
1011  node = inv(nidx,lun)
1012  if ( ( typ(node) /= 'NUM' ) .and. ( typ(node) /= 'CHR' ) ) return
1013 
1014  ! Get the scale factor, reference value and bit width, including accounting for any Table C operators which may be in
1015  ! scope for this particular occurrence of nemo.
1016 
1017  iret = 0
1018 
1019  nscl = isc(node)
1020  nbts = ibt(node)
1021  nref = irf(node)
1022 
1023  if ( nnrv > 0 ) then
1024 
1025  ! There are nodes containing redefined reference values (from one or more 2-03-YYY operators) in the jump/link table,
1026  ! so we need to check if this node is one of them.
1027 
1028  tagn = ' '
1029  call strsuc( nemo, tagn, ltn )
1030  if ( ( ltn <= 0 ) .or. ( ltn > 8 ) ) return
1031 
1032  do jj = 1, nnrv
1033  if ( ( node /= inodnrv(jj) ) .and. ( tagn(1:8) == tagnrv(jj) ) .and. &
1034  ( node >= isnrv(jj) ) .and. ( node <= ienrv(jj) ) ) then
1035  nref = int(nrv(jj))
1036  return
1037  end if
1038  end do
1039 
1040  end if
1041 
1042  return
1043 end subroutine nemspecs
1044 
1064 subroutine fstag ( lun, utag, nutag, nin, nout, iret )
1065 
1066  use moda_usrint
1067  use moda_tables
1068 
1069  implicit none
1070 
1071  integer, intent(in) :: lun, nutag, nin
1072  integer, intent(out) :: nout, iret
1073  integer, parameter :: maxtg = 15
1074  integer ntg, istep, itagct
1075 
1076  character*(*), intent(in) :: utag
1077  character*10 tgs(maxtg)
1078 
1079  iret = -1
1080 
1081  ! Confirm that there's only one mnemonic in the input string.
1082 
1083  call parstr( utag, tgs, maxtg, ntg, ' ', .true. )
1084  if ( ntg /= 1 ) return
1085 
1086  ! Starting from nin, search either forward or backward for the (nutag)th occurrence of utag.
1087 
1088  if ( nutag == 0 ) return
1089  istep = isign( 1, nutag )
1090  itagct = 0
1091  nout = nin + istep
1092  do while ( ( nout >= 1 ) .and. ( nout <= nval(lun) ) )
1093  if ( tgs(1) == tag(inv(nout,lun)) ) then
1094  itagct = itagct + 1
1095  if ( itagct == iabs(nutag) ) then
1096  iret = 0
1097  return
1098  endif
1099  endif
1100  nout = nout + istep
1101  enddo
1102 
1103  return
1104 end subroutine fstag
1105 
1125 recursive subroutine gettagpr ( lunit, tagch, ntagch, tagpr, iret )
1126 
1127  use modv_vars, only: im8b
1128 
1129  use moda_usrint
1130  use moda_msgcwd
1131  use moda_tables
1132 
1133  implicit none
1134 
1135  integer, intent(in) :: lunit, ntagch
1136  integer, intent(out) :: iret
1137  integer my_lunit, my_ntagch, lun, il, im, nch
1138 
1139  character*(*), intent(in) :: tagch
1140  character*(*), intent(out) :: tagpr
1141 
1142  ! Check for I8 integers.
1143 
1144  if(im8b) then
1145  im8b=.false.
1146 
1147  call x84 ( lunit, my_lunit, 1 )
1148  call x84 ( ntagch, my_ntagch, 1 )
1149  call gettagpr ( my_lunit, tagch, my_ntagch, tagpr, iret )
1150  call x48 ( iret, iret, 1 )
1151 
1152  im8b=.true.
1153  return
1154  endif
1155 
1156  iret = -1
1157 
1158  ! Get lun from lunit.
1159 
1160  call status( lunit, lun, il, im )
1161  if ( il == 0 ) return
1162  if ( inode(lun) /= inv(1,lun) ) return
1163 
1164  ! Get tagpr from the (ntagch)th occurrence of tagch.
1165 
1166  call fstag( lun, tagch, ntagch, 1, nch, iret )
1167  if ( iret /= 0 ) return
1168 
1169  tagpr = tag(jmpb(inv(nch,lun)))
1170 
1171  return
1172 end subroutine gettagpr
1173 
1190 integer function invtag(node,lun,inv1,inv2) result(iret)
1191 
1192  use moda_usrint
1193  use moda_tables
1194 
1195  implicit none
1196 
1197  integer, intent(in) :: node, lun, inv1, inv2
1198  integer iprt
1199 
1200  character*10 tagn
1201 
1202  common /quiet/ iprt
1203 
1204  if(node/=0) then
1205  tagn = tag(node)
1206  ! Search between inv1 and inv2
1207  do iret=inv1,inv2
1208  if(tag(inv(iret,lun))==tagn) return
1209  enddo
1210  endif
1211 
1212  iret = 0
1213 
1214  if(iprt>=2) then
1215  call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
1216  call errwrt('BUFRLIB: INVTAG - RETURNING WITH A VALUE OF 0')
1217  call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
1218  call errwrt(' ')
1219  endif
1220 
1221  return
1222 end function invtag
1223 
1238 integer function invwin(node,lun,inv1,inv2) result(iret)
1239 
1240  use moda_usrint
1241 
1242  implicit none
1243 
1244  integer, intent(in) :: node, lun, inv1, inv2
1245  integer iprt, idx
1246 
1247  character*80 errstr
1248 
1249  common /quiet/ iprt
1250 
1251  iret = 0
1252  if(node/=0) then
1253  ! Search between inv1 and inv2
1254  do idx=inv1,inv2
1255  if(inv(idx,lun)==node) then
1256  iret = idx
1257  exit
1258  endif
1259  enddo
1260  endif
1261 
1262  if(iprt>=3) then
1263  write(errstr,'(a,3i8)') 'invwin i1,i2,in ', inv1, inv2, iret
1264  call errwrt(errstr)
1265  endif
1266 
1267  return
1268 end function invwin
1269 
1313 subroutine getwin(node,lun,iwin,jwin)
1314 
1315  use moda_usrint
1316 
1317  implicit none
1318 
1319  integer, intent(in) :: node, lun
1320  integer, intent(out) :: iwin, jwin
1321  integer irpc, lstjpb, invwin
1322 
1323  character*128 bort_str
1324 
1325  irpc = lstjpb(node,lun,'RPC')
1326 
1327  if(irpc==0) then
1328  iwin = invwin(node,lun,jwin,nval(lun))
1329  if(iwin==0 .and. jwin>1) return
1330  iwin = 1
1331  jwin = nval(lun)
1332  return
1333  else
1334  iwin = invwin(irpc,lun,jwin,nval(lun))
1335  if(iwin==0) return
1336  if(val(iwin,lun)==0.) then
1337  iwin = 0
1338  return
1339  endif
1340  endif
1341 
1342  jwin = invwin(irpc,lun,iwin+1,nval(lun))
1343  if(jwin==0) then
1344  write(bort_str,'("BUFRLIB: GETWIN - SEARCHED BETWEEN",I5," AND",I5,", MISSING BRACKET")') iwin+1, nval(lun)
1345  call bort(bort_str)
1346  endif
1347 
1348  return
1349 end subroutine getwin
1350 
1382 subroutine conwin(lun,inc1,inc2)
1383 
1384  use moda_usrint
1385 
1386  implicit none
1387 
1388  integer, intent(in) :: lun
1389  integer, intent(out) :: inc1, inc2
1390  integer nnod, ncon, nods, nodc, ivls, kons, nc, invcon
1391 
1392  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
1393 
1394  if(ncon==0) then
1395  ! There are no condition nodes in the string
1396  inc1 = 1
1397  inc2 = nval(lun)
1398  return
1399  endif
1400 
1401  outer: do while (.true.)
1402  call getwin(nodc(1),lun,inc1,inc2)
1403  if(inc1>0) then
1404  do nc=1,ncon
1405  if(invcon(nc,lun,inc1,inc2)==0) cycle outer
1406  enddo
1407  endif
1408  exit
1409  enddo outer
1410 
1411  return
1412 end subroutine conwin
1413 
1440 integer function invcon(nc,lun,inv1,inv2) result(iret)
1441 
1442  use moda_usrint
1443 
1444  implicit none
1445 
1446  integer, intent(in) :: nc, lun, inv1, inv2
1447  integer nnod, ncon, nods, nodc, ivls, kons, iprt
1448 
1449  common /usrstr/ nnod, ncon, nods(20), nodc(10), ivls(10), kons(10)
1450  common /quiet/ iprt
1451 
1452  if(inv1>0 .and. inv1<=nval(lun) .and. inv2>0 .and. inv2<=nval(lun)) then
1453  do iret=inv1,inv2
1454  if(inv(iret,lun)==nodc(nc)) then
1455  if(kons(nc)==1 .and. val(iret,lun)==ivls(nc)) return
1456  if(kons(nc)==2 .and. val(iret,lun)/=ivls(nc)) return
1457  if(kons(nc)==3 .and. val(iret,lun)<ivls(nc)) return
1458  if(kons(nc)==4 .and. val(iret,lun)>ivls(nc)) return
1459  endif
1460  enddo
1461  endif
1462 
1463  iret = 0
1464  if(iprt>=2) then
1465  call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
1466  call errwrt('BUFRLIB: INVCON - RETURNING WITH A VALUE OF 0')
1467  call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
1468  call errwrt(' ')
1469  endif
1470 
1471  return
1472 end function invcon
1473 
1490 subroutine newwin(lun,iwin,jwin)
1491 
1492  use moda_usrint
1493 
1494  implicit none
1495 
1496  integer, intent(in) :: lun, iwin
1497  integer, intent(out) :: jwin
1498  integer node, lstjpb
1499 
1500  character*128 bort_str
1501 
1502  if(iwin==1) then
1503  ! This is a "SUB" (subset) node, so return jwin as pointing to the last value of the entire subset.
1504  jwin = nval(lun)
1505  return
1506  endif
1507 
1508  ! Confirm that iwin points to an "RPC" node and then compute jwin.
1509  node = inv(iwin,lun)
1510  if(lstjpb(node,lun,'RPC')/=node) then
1511  write(bort_str,'("BUFRLIB: NEWWIN - LSTJPB FOR NODE",I6,'// &
1512  '" (LSTJPB=",I5,") DOES NOT EQUAL VALUE OF NODE, NOT RPC (IWIN =",I8,")")') node, lstjpb(node,lun,'RPC'), iwin
1513  call bort(bort_str)
1514  endif
1515  jwin = iwin+nint(val(iwin,lun))
1516 
1517  return
1518 end subroutine newwin
1519 
1538 subroutine nxtwin(lun,iwin,jwin)
1539 
1540  use moda_usrint
1541 
1542  implicit none
1543 
1544  integer, intent(in) :: lun
1545  integer, intent(inout) :: iwin, jwin
1546  integer node, lstjpb
1547 
1548  character*128 bort_str
1549 
1550  if(jwin==nval(lun)) then
1551  iwin = 0
1552  return
1553  endif
1554 
1555  node = inv(iwin,lun)
1556  if(lstjpb(node,lun,'RPC')/=node) then
1557  write(bort_str,'("BUFRLIB: NXTWIN - LSTJPB FOR NODE",I6," '// &
1558  '(LSTJPB=",I5,") DOES NOT EQUAL VALUE OF NODE, NOT RPC (IWIN =",I8,")")') node, lstjpb(node,lun,'RPC'), iwin
1559  call bort(bort_str)
1560  endif
1561  if(val(jwin,lun)==0) then
1562  iwin = 0
1563  else
1564  iwin = jwin
1565  jwin = iwin+nint(val(iwin,lun))
1566  endif
1567 
1568  return
1569 end subroutine nxtwin
1570 
1588 integer function nvnwin(node,lun,inv1,inv2,invn,nmax) result(iret)
1589 
1590  use moda_usrint
1591 
1592  implicit none
1593 
1594  integer, intent(in) :: node, lun, inv1, inv2, nmax
1595  integer, intent(out) :: invn(*)
1596  integer iprt, i, n
1597 
1598  character*128 bort_str
1599 
1600  common /quiet/ iprt
1601 
1602  iret = 0
1603 
1604  if(node==0) then
1605  if(iprt>=1) then
1606  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1607  call errwrt('BUFRLIB: NVNWIN - NODE=0, IMMEDIATE RETURN')
1608  call errwrt('+++++++++++++++++++++WARNING+++++++++++++++++++++++')
1609  call errwrt(' ')
1610  endif
1611  return
1612  endif
1613 
1614  do i=1,nmax
1615  invn(i) = 1e9
1616  enddo
1617 
1618  ! Search between inv1 and inv2
1619 
1620  do n=inv1,inv2
1621  if(inv(n,lun)==node) then
1622  if(iret+1>nmax) then
1623  write(bort_str,'("BUFRLIB: NVNWIN - THE NUMBER OF EVENTS EXCEEDS THE LIMIT NMAX (",I5,")")') nmax
1624  call bort(bort_str)
1625  endif
1626  iret = iret+1
1627  invn(iret) = n
1628  endif
1629  enddo
1630 
1631  return
1632 end function nvnwin
subroutine bort(str)
Log an error message, then abort the application program.
Definition: borts.F90:15
subroutine cpbfdx(lud, lun)
Copy all of the DX BUFR table information from one unit to another within internal memory.
Definition: copydata.F90:678
subroutine nemtbb(lun, itab, unit, iscl, iref, ibit)
Get information about a Table B descriptor from the internal DX BUFR tables.
Definition: dxtable.F90:1278
recursive subroutine wrdxtb(lundx, lunot)
Generate one or more BUFR messages from the DX BUFR tables information associated with a given BUFR f...
Definition: dxtable.F90:850
subroutine nemtbd(lun, itab, nseq, nems, irps, knts)
Get information about a Table D descriptor from the internal DX BUFR tables.
Definition: dxtable.F90:1346
subroutine errwrt(str)
Specify a custom location for the logging of error and diagnostic messages generated by the NCEPLIBS-...
Definition: errwrt.F90:32
subroutine nemtab(lun, nemo, idn, tab, iret)
Get information about a descriptor, based on a mnemonic.
Definition: fxy.F90:432
subroutine strsuc(str1, str2, lens)
Remove leading and trailing blanks from a character string.
Definition: misc.F90:220
Declare arrays and variables used to store bitmaps internally within a data subset definition.
integer, dimension(:,:), allocatable inodtco
Entries within jump/link table which contain Table C operators.
integer ntamc
Number of Table A mnemonics in jump/link table (up to a maximum of mxtamc) which contain at least one...
integer, dimension(:), allocatable inodtamc
Entries within jump/link table which contain Table A mnemonics.
character *6, dimension(:,:), allocatable ctco
Table C operators corresponding to inodtco.
integer, dimension(:), allocatable ntco
Number of Table C operators (with an XX value of 21 or greater) within the data subset definition of ...
Declare an array used by subroutine makestab() to keep track of which logical units share DX BUFR tab...
integer, dimension(:), allocatable lus
Tracking index for each file ID.
Declare arrays used to store information about the current BUFR message that is in the process of bei...
integer, dimension(:), allocatable inode
Table A mnemonic for type of BUFR message.
Declare arrays used by various subroutines to hold information about Table D sequences.
integer, dimension(:,:), allocatable krp
Replication counts corresponding to nem:
integer, dimension(:,:), allocatable irp
Replication indicators corresponding to nem:
character *8, dimension(:,:), allocatable nem
Child mnemonics within Table D sequences.
Declare arrays and variables for use with any 2-03-YYY (change reference value) operators present wit...
integer, dimension(:), allocatable ienrv
End of entry range in jump/link table, within which the corresponding new reference value in nrv will...
character *8, dimension(:), allocatable tagnrv
Table B mnemonic to which the corresponding new reference value in nrv applies.
integer, dimension(:), allocatable isnrv
Start of entry range in jump/link table, within which the corresponding new reference value in nrv wi...
integer nnrv
Number of entries in the jump/link table which contain new reference values (up to a maximum of mxnrv...
integer *8, dimension(:), allocatable nrv
New reference values corresponding to inodnrv.
integer ipfnrv
A number between 1 and nnrv, denoting the first entry within the module arrays which applies to the c...
integer, dimension(:), allocatable inodnrv
Entries within jump/link table which contain new reference values.
integer ibtnrv
Number of bits in Section 4 occupied by each new reference value for the current 2-03-YYY operator in...
Declare arrays used to store file and message status indicators for all logical units that have been ...
integer, dimension(:), allocatable iolun
File status indicators.
integer, dimension(:), allocatable iomsg
Message status indicator corresponding to iolun, denoting whether a BUFR message is currently open wi...
Declare arrays and variables used to store DX BUFR tables internally for multiple file IDs.
integer, dimension(:), allocatable ntba
Number of Table A entries for each file ID (up to a maximum of maxtba, whose value is stored in array...
character *600, dimension(:,:), allocatable tabd
Table D entries for each file ID.
character *128, dimension(:,:), allocatable taba
Table A entries for each file ID.
integer, dimension(:,:), allocatable mtab
Entries within jump/link table corresponding to taba.
integer, dimension(:,:,:), allocatable idna
Message types (in array element 1) and subtypes (in array element 2) corresponding to taba.
integer, dimension(:), allocatable ntbd
Number of Table D entries for each file ID (up to a maximum of maxtbd, whose value is stored in array...
integer, dimension(:), allocatable ntbb
Number of Table B entries for each file ID (up to a maximum of maxtbb, whose value is stored in array...
integer, dimension(:,:), allocatable idnd
WMO bit-wise representations of the FXY values corresponding to tabd.
integer, dimension(:,:), allocatable idnb
WMO bit-wise representations of the FXY values corresponding to tabb.
character *128, dimension(:,:), allocatable tabb
Table B entries for each file ID.
Declare arrays and variables used to store the internal jump/link table.
integer, dimension(:), allocatable jseq
Temporary storage used in expanding sequences.
integer, dimension(:), allocatable irf
Reference values corresponding to tag and typ:
integer, dimension(:,:), allocatable iseq
Temporary storage used in expanding sequences.
integer, dimension(:), allocatable isc
Scale factors corresponding to tag and typ:
integer, dimension(:), allocatable ibt
Bit widths corresponding to tag and typ:
integer, dimension(:), allocatable knt
Temporary storage used in calculating delayed replication counts.
real *8, dimension(:), allocatable vali
Initialized data values corresponding to typ:
character *3, dimension(:), allocatable typ
Type indicators corresponding to tag:
integer, dimension(:), allocatable jmpb
Jump backward indices corresponding to tag and typ:
character *10, dimension(:), allocatable tag
Mnemonics in the jump/link table.
integer ntab
Number of entries in the jump/link table.
integer, dimension(:), allocatable jump
Jump forward indices corresponding to tag and typ:
integer, dimension(:), allocatable itp
Integer type values corresponding to typ:
integer, dimension(:), allocatable link
Link indices corresponding to tag, typ and jmpb:
integer, dimension(:), allocatable knti
Initialized replication counts corresponding to typ and jump:
Declare arrays used to store data values and associated metadata for the current BUFR data subset in ...
integer, dimension(:), allocatable nval
Number of data values in BUFR data subset.
real *8, dimension(:,:), allocatable, target val
Data values.
integer, dimension(:,:), allocatable, target inv
Inventory pointer which links each data value to its corresponding node in the internal jump/link tab...
Declare an array used to track, for each file ID, whether the DX BUFR table associated with the corre...
logical, dimension(:), allocatable xtab
Tracking index for each file ID.
recursive subroutine status(lunit, lun, il, im)
Check whether a specified Fortran logical unit number is currently connected to the NCEPLIBS-bufr sof...
recursive subroutine closmg(lunin)
Close the BUFR message that is currently open for writing within internal arrays associated with logi...
subroutine usrtpl(lun, invn, nbmp)
Expand a subset template within internal arrays.
subroutine strcln
Reset the internal mnemonic string cache.
Definition: strings.F90:116
subroutine parstr(str, tags, mtag, ntag, sep, limit80)
Parse a string containing one or more substrings into an array of substrings.
Definition: strings.F90:473
subroutine x48(iin4, iout8, nval)
Encode one or more 4-byte integer values as 8-byte integer values.
Definition: x4884.F90:18
subroutine x84(iin8, iout4, nval)
Encode one or more 8-byte integer values as 4-byte integer values.
Definition: x4884.F90:65