Merge pull request #613 from NOAA-EMC/jba_issue611

add logic to encode Table C marker operators

.github/workflows/MacOS.yml

@@ -16,8 +16,8 @@ jobs:
   MacOS:
     runs-on: macos-latest
     env:
-      FC: gfortran-11
-      F90: gfortran-11
+      FC: gfortran-12
+      F90: gfortran-12
 
     steps:
 
@@ -33,7 +33,7 @@ jobs:
         pip3 install ninja
         pip3 install netCDF4
         pip3 install protobuf
-        sudo ln -sf /usr/local/bin/gfortran-11 /usr/local/bin/gfortran
+        sudo ln -sf /usr/local/bin/gfortran-12 /usr/local/bin/gfortran
           
     - name: checkout-bufr
       uses: actions/checkout@v4

VERSION

@@ -1 +1 @@
-12.1.0
+12.2.0

docs/dx_tables.md

@@ -6,7 +6,7 @@
 Every BUFR file must have DX BUFR tables associated with it, unless
 the 'SEC3' decoding option is specified during the call to
 openbf(). For all other cases, DX table information must be
-pre-defined and made available to the software via call argument LUNDX
+pre-defined and made available to the software via call argument lundx
 during the call to openbf(). The DX tables information may be embedded
 within the first few BUFR messages of the file itself. Otherwise, a
 separate ASCII text file containing the necessary DX tables
@@ -18,6 +18,10 @@ that all necessary mnemonics must exist and be fully-defined.
 
 A <i>mnemonic</i> is a
 descriptive, alphanumeric name for a data value.
+A mnemonic may contain any
+combination of uppercase letters and numbers (or, in certain special
+cases, a "." character), up to a maximum of 8 characters in length.
+There are 3 basic types of mnemonics:
 * "Table A mnemonics", refer to particular data subset (i.e. report ) types,
 * "Table B mnemonics", refer directly to basic data values,
 * "Table D mnemonics" are
@@ -40,6 +44,10 @@ software by providing descriptive names to represent individual data
 values. They are more intuitive than FXY numbers (described below),
 which are the prescribed method within actual BUFR messages.
 
+Of note, there is one special 4-letter mnemonic "DPRI" which is reserved
+for exclusive use with FXY number 031031, and which must always be used
+when reading or writing bitmaps within the software.
+
 ## DX BUFR Tables File
 
 A DX BUFR tables file consists of three distinct sections.  Each
@@ -64,9 +72,7 @@ bit width, and units.
 
 The first section of a BUFR tables file is where all Table A, B and D
 mnemonics are initially declared, assigned a unique FXY number, and
-given a short free-form text description. Mnemonics may contain any
-combination of uppercase letters and numbers (or, in certain special
-cases, a "." character), up to a maximum of 8 characters in length. A
+given a short free-form text description.  Each
 mnemonic may be declared only once, and each one must correspond to a
 unique FXY number, which itself consists of 6 characters, and where
 the first character (i.e. the "F" component) is an "A" if the mnemonic

src/bitmaps.F90

@@ -5,11 +5,18 @@
 
 !> Store internal information in module @ref moda_bitmaps if the input element is part of a bitmap.
 !>
+!> This subroutine first determines whether the input element is part of a bitmap.  If so, then information about the
+!> element is stored internally for later use.
+!>
 !> @param n - Subset element
 !> @param lun - File ID
+!> @param ival - Value associated with n:
+!>   - If n is determined to be part of a bitmap, then a value of 0 means that n is a "set" entry in the bitmap, and
+!>     any other (i.e. non-zero) value means that n is not a "set" entry in the bitmap
+!>   - If n is determined to not be part of a bitmap, then this value is ignored
 !>
 !> @author J. Ator @date 2016-05-27
-subroutine strbtm ( n, lun )
+subroutine strbtm ( n, lun, ival )
 
   use modv_vars, only: mxbtm, mxbtmse
 
@@ -20,8 +27,8 @@ subroutine strbtm ( n, lun )
 
   implicit none
 
-  integer, intent(in) :: n, lun
-  integer node, nodtam, ii, jj, ibfms, lstjpb
+  integer, intent(in) :: n, lun, ival
+  integer node, nodtam, ii, jj, lstjpb
 
   logical isbtme
 
@@ -62,7 +69,7 @@ subroutine strbtm ( n, lun )
       linbtm = .true.
     end if
     iszbtm(nbtm) = iszbtm(nbtm) + 1
-    if ( ibfms(val(n,lun)) == 0 ) then
+    if ( ival == 0 ) then
       ! This is a "set" (value=0) entry in the bitmap.
       if ( nbtmse(nbtm) >= mxbtmse ) call bort('BUFRLIB: STRBTM - MXBTMSE OVERFLOW')
       nbtmse(nbtm) = nbtmse(nbtm) + 1

src/cidecode.F90

@@ -99,7 +99,7 @@ subroutine upb8(nval,nbits,ibit,ibay)
   elseif(nbits<=64) then
      jbit=ibit; nvals=0
      call upb(nvals(2),max(nbits-nbitw,0),ibay,jbit)
-     call upb(nvals(1),min(nbitw,nbits  ),ibay,jbit)
+     call upb(nvals(1),min(nbitw,nbits),ibay,jbit)
      nval=nval8
   else
      nval=0

src/ciencode.F90

@@ -116,7 +116,7 @@ subroutine pkb8(nval,nbits,ibay,ibit)
   nval4=nvals(2)
   call pkb(nval4,max(nbits-nbitw,0),ibay,ibit)
   nval4=nvals(1)
-  call pkb(nval4,min(nbits,nbitw  ),ibay,ibit)
+  call pkb(nval4,min(nbits,nbitw),ibay,ibit)
 
   return
 end subroutine pkb8

src/compress.F90

@@ -121,7 +121,7 @@ subroutine rdcmps(lun)
 
   integer, intent(in) :: lun
   integer*8 :: ival, lref, ninc, lps
-  integer nsbs, jbit, lbit, nbit, n, node, ityp, linc, lre4, nin4, nbmp, nchr, lelm, ibsv, igetrfel, icbfms
+  integer nsbs, jbit, lbit, nbit, n, node, ityp, linc, lre4, nin4, nbmp, nchr, lelm, ibsv, igetrfel, ibfms, icbfms
 
   real*8 rval, ups
 
@@ -191,7 +191,7 @@ subroutine rdcmps(lun)
         goto 11
       endif
       if(ival<lps(nbit)) val(n,lun) = ups(ival,node)
-      call strbtm(n,lun)
+      call strbtm(n,lun,ibfms(val(n,lun)))
       ibit = ibit + linc*msub(lun)
     elseif(ityp==3) then
       ! This is a character element.  If there are more than 8 characters, then only the first 8 will be unpacked by this
@@ -399,7 +399,7 @@ subroutine wrcmps(lunix)
   implicit none
 
   integer, intent(in) :: lunix
-  integer ibyt, jbit, lunit, lun, il, im, icol, i, j, node, lbyt, nbyt, nchr, ldata, iupbs01
+  integer ibyt, jbit, lunit, lun, il, im, icol, i, j, node, lbyt, nbyt, nchr, ldata, iupbs01, imrkopr
 
   character*128 bort_str
   character*8 subset
@@ -498,12 +498,16 @@ subroutine wrcmps(lunix)
           node = inv(i,lun)
           jlnode(i) = node
           ityp(i) = itp(node)
-          iwid(i) = ibt(node)
+          if(imrkopr(tag(node))==1) then
+            iwid(i) = ibt(inv(nrfelm(i,lun),lun))
+          else
+            iwid(i) = ibt(node)
+          endif
           if(ityp(i)==1.or.ityp(i)==2) then
-            call up8(matx(i,ncol),ibt(node),ibay,ibit)
+            call up8(matx(i,ncol),iwid(i),ibay,ibit)
           elseif(ityp(i)==3) then
             catx(i,ncol) = ' '
-            call upc(catx(i,ncol),ibt(node)/8,ibay,ibit,.true.)
+            call upc(catx(i,ncol),iwid(i)/8,ibay,ibit,.true.)
           endif
         enddo
       endif

src/dumpdata.F90

@@ -243,7 +243,7 @@ recursive subroutine ufdump(lunit,luprt)
   integer, parameter :: mxfv = 31 , mxcfdp = 5, mxseq = 10, mxls = 10
   integer ifv(mxfv), icfdp(mxcfdp), idxrep(mxseq), numrep(mxseq), lsqnam(mxseq), lsct(mxls), my_lunit, my_luprt, &
     nseq, nls, lcfmeang, luout, lun, il, im, node, lnm2, lnm3, itmp, ityp, ii, jj, nifv, nv, n, nchr, idn, ipt, &
-    nrfe, nout, lcfmg, ifvd, iersf, ierbd, ierft, isz, isize, ireadmt, ibfms, icbfms
+    nrfe, nout, lcfmg, ifvd, iersf, ierbd, ierft, isz, isize, iscl, ireadmt, ibfms, icbfms, imrkopr
   integer*8 ival
 
   real*8 rval
@@ -422,8 +422,13 @@ recursive subroutine ufdump(lunit,luprt)
       else
         fmt = '(A6,2X,A10,2X,      ,2X,A24,6X,A48)'
         ! Based upon the corresponding scale factor, select an appropriate format for the printing of this value.
-        if(isc(node)>0) then
-          write(fmt(15:20),'(A,I2)') 'F20.', isc(node)
+        if(imrkopr(nemo)==1) then
+          iscl = isc(inv(nrfe,lun))
+        else
+          iscl = isc(node)
+        endif
+        if(iscl>0) then
+          write(fmt(15:20),'(A,I2)') 'F20.', iscl
         else
           write(fmt(18:20),'(A)') 'I20'
         endif
@@ -447,7 +452,7 @@ recursive subroutine ufdump(lunit,luprt)
              unit(ipt-1:ipt-1) = ')'
            endif
         endif
-        if(isc(node)>0) then
+        if(iscl>0) then
           write(luout,fmt) numb,nemo,rval,unit,desc
         else
           ival = nint(rval,8)

src/readwritesb.F90

@@ -985,7 +985,7 @@ subroutine rdtree(lun,iret)
 
   integer, intent(in) :: lun
   integer, intent(out) :: iret
-  integer ier, n, node, kbit, nbt, icbfms
+  integer ier, n, node, kbit, nbt, icbfms, igetrfel
 
   character*8 cval
 
@@ -1005,36 +1005,26 @@ subroutine rdtree(lun,iret)
     return
   endif
 
-  ! Unpack a subset into the user array ival
+  ! Loop through each element of the subset, unpacking each value and then converting it to the proper type
 
   do n=1,nval(lun)
     call upb8(ival(n),nbit(n),mbit(n),mbay(1,lun))
-  enddo
-
-  ! Loop through each element of the subset, converting the unpacked values to the proper types
-
-  do n=1,nval(lun)
     node = inv(n,lun)
     if(itp(node)==1) then
-
       ! The unpacked value is a delayed descriptor replication factor.
-
       val(n,lun) = ival(n)
     elseif(itp(node)==2) then
-
       ! The unpacked value is a real.
-
+      nrfelm(n,lun) = igetrfel(n,lun)
       if (ival(n)<2_8**ibt(node)-1) then
         val(n,lun) = ups(ival(n),node)
       else
         val(n,lun) = bmiss
       endif
     elseif(itp(node)==3) then
-
       ! The value is a character string, so unpack it using an equivalenced real*8 value.  Note that a maximum of 8 characters
       ! will be unpacked here, so a separate subsequent call to subroutine readlc() will be needed to fully unpack any string
       ! longer than 8 characters.
-
       cval = ' '
       kbit = mbit(n)
       nbt = min(8,nbit(n)/8)
@@ -1072,7 +1062,7 @@ subroutine wrtree(lun)
 
   integer, intent(in) :: lun
   integer*8 ipks
-  integer n, node, ncr, numchr, jj, ibfms
+  integer n, node, nbit, ncr, numchr, jj, ibfms, igetrfel, imrkopr
 
   character*120 lstr
   character*8 cval
@@ -1085,6 +1075,7 @@ subroutine wrtree(lun)
 
   do n=1,nval(lun)
     node = inv(n,lun)
+    nrfelm(n,lun) = igetrfel(n,lun)
     if(itp(node)==1) then
       ival(n) = nint(val(n,lun))
     elseif(typ(node)=='NUM') then
@@ -1094,6 +1085,7 @@ subroutine wrtree(lun)
       else
         ival(n) = ipks(val(n,lun),node)
       endif
+      call strbtm(n,lun,int(ival(n)))
     endif
   enddo
 
@@ -1105,7 +1097,12 @@ subroutine wrtree(lun)
     node = inv(n,lun)
     if(itp(node)<3) then
       ! The value to be packed is numeric.
-      call pkb8(ival(n),ibt(node),ibay,ibit)
+      if ( imrkopr(tag(node)) == 1 ) then
+        nbit = ibt(inv(nrfelm(n,lun),lun))
+      else
+        nbit = ibt(node)
+      endif
+      call pkb8(ival(n),nbit,ibay,ibit)
     else
       ! The value to be packed is a character string.
       ncr=ibt(node)/8
@@ -1154,7 +1151,7 @@ end subroutine wrtree
 !> @author Woollen @date 1994-01-06
 subroutine rcstpl(lun,iret)
 
-  use modv_vars, only: bmiss, maxjl, maxss, maxrcr
+  use modv_vars, only: maxjl, maxss, maxrcr
 
   use moda_usrint
   use moda_usrbit
@@ -1169,8 +1166,7 @@ subroutine rcstpl(lun,iret)
 
   integer, intent(in) :: lun
   integer, intent(out) :: iret
-  integer nbmp(2,maxrcr), newn(2,maxrcr), knx(maxrcr), iprt, nodi, node, mbmp, knvn, nr, i, j, n, nn, n1, n2, new, &
-    idpri, igetrfel
+  integer nbmp(2,maxrcr), newn(2,maxrcr), knx(maxrcr), iprt, nodi, node, mbmp, nr, i, j, n, nn, n1, n2, new, ivob, igetrfel
 
   common /quiet/ iprt
 
@@ -1185,7 +1181,7 @@ subroutine rcstpl(lun,iret)
   nodi = inode(lun)
   node = inode(lun)
   mbmp = 1
-  knvn = 1
+  nval(lun) = 1
   nr = 0
 
   do i=1,maxrcr
@@ -1233,10 +1229,10 @@ subroutine rcstpl(lun,iret)
       ! Store nodes at some recursion level
 
       do i=nbmp(1,nr),nbmp(2,nr)
-        if(knx(nr)==0) knx(nr) = knvn
+        if(knx(nr)==0) knx(nr) = nval(lun)
         if(i>nbmp(1,nr)) newn(1,nr) = 1
         do j=newn(1,nr),newn(2,nr)
-          if(knvn+1>maxss) then
+          if(nval(lun)+1>maxss) then
             if(iprt>=0) then
               call errwrt('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')
               call errwrt('BUFRLIB: RCSTPL - MAXSS OVERFLOW; SUBSET SKIPPED')
@@ -1245,35 +1241,30 @@ subroutine rcstpl(lun,iret)
             iret = -1
             return
           endif
-          knvn = knvn+1
+          nval(lun) = nval(lun)+1
           node = iutmp(j,nr)
-          ! inv is positional index in internal jump/link table for packed subset element knvn in mbay
-          inv(knvn,lun) = node
-          ! mbit is the bit in mbay pointing to where the packed subset element knvn begins
-          mbit(knvn) = mbit(knvn-1)+nbit(knvn-1)
-          ! nbit is the number of bits in mbay occupied by packed subset element knvn
-          nrfelm(knvn,lun) = igetrfel(knvn,lun)
-          nbit(knvn) = ibt(node)
-          if(tag(node)(1:5)=='DPRI ') then
-            ! This is a bitmap entry, so get and store the corresponding value
-            call upbb(idpri,nbit(knvn),mbit(knvn),mbay(1,lun))
-            if(idpri==0) then
-              val(knvn,lun) = 0.0
-            else
-              val(knvn,lun) = bmiss
-            endif
-            call strbtm(knvn,lun)
+          ! inv is positional index in internal jump/link table for packed subset element nval(lun) in mbay
+          inv(nval(lun),lun) = node
+          ! mbit is the bit in mbay pointing to where the packed subset element nval(lun) begins
+          mbit(nval(lun)) = mbit(nval(lun)-1)+nbit(nval(lun)-1)
+          ! nbit is the number of bits in mbay occupied by packed subset element nval(lun)
+          nrfelm(nval(lun),lun) = igetrfel(nval(lun),lun)
+          nbit(nval(lun)) = ibt(node)
+          if(nbit(nval(lun))==1) then
+            ! Check whether this is a bitmap entry
+            call upbb(ivob,nbit(nval(lun)),mbit(nval(lun)),mbay(1,lun))
+            call strbtm(nval(lun),lun,ivob)
           endif
           ! Actual unpacked subset values are initialized here
-          val(knvn,lun) = vutmp(j,nr)
+          val(nval(lun),lun) = vutmp(j,nr)
           if(itp(node)==1) then
-            call upbb(mbmp,nbit(knvn),mbit(knvn),mbay(1,lun))
+            call upbb(mbmp,nbit(nval(lun)),mbit(nval(lun)),mbay(1,lun))
             newn(1,nr) = j+1
             nbmp(1,nr) = i
             cycle outer
           endif
         enddo
-        new = knvn-knx(nr)
+        new = nval(lun)-knx(nr)
         val(knx(nr)+1,lun) = val(knx(nr)+1,lun) + new
         knx(nr) = 0
       enddo
@@ -1286,10 +1277,6 @@ subroutine rcstpl(lun,iret)
 
   enddo outer
 
-  ! Finally store the length of (i.e. the number of elements in) the subset template
-
-  nval(lun) = knvn
-
   return
 end subroutine rcstpl