diff --git a/.github/workflows/MacOS.yml b/.github/workflows/MacOS.yml index 9d69b311..dbc9da94 100644 --- a/.github/workflows/MacOS.yml +++ b/.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 diff --git a/VERSION b/VERSION index 77903b35..68533262 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -12.1.0 +12.2.0 diff --git a/docs/dx_tables.md b/docs/dx_tables.md index 1de9e5b9..2159944e 100644 --- a/docs/dx_tables.md +++ b/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 mnemonic 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 diff --git a/src/bitmaps.F90 b/src/bitmaps.F90 index 1018c8af..2ddd4e4c 100644 --- a/src/bitmaps.F90 +++ b/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 diff --git a/src/cidecode.F90 b/src/cidecode.F90 index 02e8a3ab..da5275ea 100644 --- a/src/cidecode.F90 +++ b/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 diff --git a/src/ciencode.F90 b/src/ciencode.F90 index 5fec6b20..32192a6b 100644 --- a/src/ciencode.F90 +++ b/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 diff --git a/src/compress.F90 b/src/compress.F90 index fbbdf363..2feaf8e9 100644 --- a/src/compress.F90 +++ b/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(ival0) 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) diff --git a/src/readwritesb.F90 b/src/readwritesb.F90 index 9c984f09..3715438c 100644 --- a/src/readwritesb.F90 +++ b/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 diff --git a/src/restd.c b/src/restd.c index 2d8e97a3..1ff42ace 100644 --- a/src/restd.c +++ b/src/restd.c @@ -141,6 +141,13 @@ restd(int lun, int tddesc, int *nctddesc, int *ctddesc) free(cdesc); } + else if ( imrkopr_f(nemo) ) { +/* +** desc is a Table C marker operator, so append it "as is" to the +** output list. +*/ + wrdesc(ifxy_f(nemo), ctddesc, nctddesc, maxnc); + } else { /* ** desc is a local Table B descriptor, so precede it with diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index 8157c0f7..c7813a74 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -8,7 +8,9 @@ list(APPEND test_kinds 4 8 d) # Fetch test data from: https://ftp.emc.ncep.noaa.gov/static_files/public set(BUFR_URL "https://ftp.emc.ncep.noaa.gov/static_files/public") -if(${PROJECT_VERSION} VERSION_GREATER_EQUAL 12.1.0) +if(${PROJECT_VERSION} VERSION_GREATER_EQUAL 12.2.0) + set(BUFR_TAR "bufr-12.2.0.tgz") +elseif(${PROJECT_VERSION} VERSION_GREATER_EQUAL 12.1.0) set(BUFR_TAR "bufr-12.1.0.tgz") elseif(${PROJECT_VERSION} VERSION_GREATER_EQUAL 11.6.0) set(BUFR_TAR "bufr-11.6.0.tgz") @@ -158,7 +160,7 @@ foreach(kind ${test_kinds}) foreach(innum RANGE 1 12) create_test(intest ${kind} ${innum}) endforeach() - foreach(outnum RANGE 1 11) + foreach(outnum RANGE 1 12) create_test(outtest ${kind} ${outnum}) endforeach() endforeach() diff --git a/test/outtest12.F90 b/test/outtest12.F90 new file mode 100644 index 00000000..ba4130a1 --- /dev/null +++ b/test/outtest12.F90 @@ -0,0 +1,90 @@ +! This is a test for NCEPLIBS-bufr. +! +! Writes test file 'testfiles/OUT_12' using a bitmap and Table C marker operators. +! +! J. Ator, 8/20/2024 +program outtest12 + implicit none + + real*8 r8bitmap(16), r8data(10,1), r8pccf(3), r8mrkr(3) + + integer nlv, ii, jj, iostat1, iostat2 + + character ptidc*16 + + print *, 'Testing writing OUT_12 using a bitmap and Table C marker operators' + +#ifdef KIND_8 + call setim8b ( .true. ) +#endif + + ! Open the BUFR table and output file. + open ( unit = 11, file = 'out12.bufr', form ='unformatted', iostat = iostat1 ) + open ( unit = 12, file = 'testfiles/OUT_12_bufrtab', iostat = iostat2 ) + if ( ( iostat1 /= 0 ) .or. ( iostat2 /= 0 ) ) stop 1 + call openbf ( 11, 'NODX', 12 ) + call stdmsg ( 'Y' ) + call pkvs01 ( 'BEN', 4 ) + + do jj = 1, 4 + ! The first 2 data subsets will be uncompressed, and the second 2 data subsets will be compressed. + if ( jj == 3 ) call cmpmsg ( 'Y' ) + + ! Open a new message for output. + call openmb ( 11, 'FN004017', 2024072412 ) + + ! Store the subset data. + r8data ( 1, 1 ) = 2024. + r8data ( 2, 1 ) = 7. + r8data ( 3, 1 ) = 24. + r8data ( 4, 1 ) = 12. + r8data ( 5, 1 ) = 55. + jj + r8data ( 6, 1 ) = 10. + r8data ( 7, 1 ) = -24.55750 + (jj * 0.001) + r8data ( 8, 1 ) = 86.23435 + (jj * 0.001) + r8data ( 9, 1 ) = 10500. + call ufbint ( 11, r8data, 10, 1, nlv, 'YEAR MNTH DAYS HOUR MINU SECO CLATH CLONH HMSL' ) + r8data ( 1, 1 ) = 283.5 - jj + r8data ( 2, 1 ) = 170. + r8data ( 3, 1 ) = 290. - (jj * 5) + r8data ( 4, 1 ) = 6.5 + (jj * 0.1) + r8data ( 5, 1 ) = 3. + r8data ( 6, 1 ) = 0. + r8data ( 7, 1 ) = 10. + call ufbint ( 11, r8data, 10, 1, nlv, 'TMDBST SMMO WDIR WSPD POAF ROLQ FOST' ) + + ! Store the bitmap. + do ii = 1, 16 + r8bitmap(ii) = 1. + end do + r8bitmap(11) = 0. + r8bitmap(13) = 0. + r8bitmap(14) = 0. + call ufbrep ( 11, r8bitmap, 1, 16, nlv, 'DPRI' ) + + ! Store the percent confidences. + r8pccf(1) = 93. - jj + r8pccf(2) = 94. - jj + r8pccf(3) = 87. - jj + call ufbrep ( 11, r8pccf, 1, 3, nlv, 'PCCF' ) + + ! Store the marker operators containing standard deviations. + r8mrkr(1) = 0.3 + (jj * 0.1) + r8mrkr(2) = 1.0 * jj ! WDIR has scale 0, so the corresponding marker operator will also be scale 0 + r8mrkr(3) = 0.1 + (jj * 0.3) + call ufbrep ( 11, r8mrkr, 1, 3, nlv, '224255' ) + + call writsb ( 11 ) + + ! Write a long character string to the message. + ptidc = 'HC888V3497074363' + call writlc ( 11, ptidc, 'PTIDC' ) + + if ( jj == 2 ) call closmg ( 11 ) + + end do + + ! Close the output file. + call closbf ( 11 ) + +end program outtest12 diff --git a/test/test_scripts/test_debufr.sh b/test/test_scripts/test_debufr.sh index 74a2619e..acf561c9 100755 --- a/test/test_scripts/test_debufr.sh +++ b/test/test_scripts/test_debufr.sh @@ -55,16 +55,16 @@ args_7="-t ../tables -o ${outfile_7}" ../utils/debufr ${args_7} testfiles/data/debufr_7 && cmp -s ${outfile_7} testfiles/testoutput/debufr_7.out [[ ${?} -ne 0 ]] && exit 7 +# Test #8, reading debufr_8 file using master tables. +outfile_8=testrun/debufr_8.out +args_8="-t ../tables -o ${outfile_8}" +../utils/debufr ${args_8} testfiles/data/debufr_8 && cmp -s ${outfile_8} testfiles/testoutput/debufr_8.out +[[ ${?} -ne 0 ]] && exit 8 + # We expect some of the following tests may return a non-zero exit code, but we don't want # to immediately exit the script when that happens. set +e -# Test #8, which should call NCEPLIBS-bufr subroutine bort from within subroutine nummtb. -outfile_8=testrun/debufr_8.out -args_8="-t ../tables" -../utils/debufr ${args_8} testfiles/data/debufr_8 > ${outfile_8} -[[ ${?} -eq 0 || `grep -c "NUMMTB - COULD NOT FIND DESCRIPTOR" ${outfile_8}` -ne 1 ]] && exit 8 - # Test #9, for wrong number of arguments. outfile_9=testrun/debufr_9.out ../utils/debufr > ${outfile_9} @@ -96,5 +96,11 @@ outfile_14=testrun/debufr_14.out ../utils/debufr -o /BUFRLIB_DUMMY_DIRECTORY/BUFRLIB_DUMMY testfiles/data/debufr_1 > ${outfile_14} [[ ${?} -eq 0 || `grep -c "ERROR: Cannot write output file" ${outfile_14}` -ne 1 ]] && exit 14 +# Test #15, which should call NCEPLIBS-bufr subroutine bort from within subroutine nummtb. +outfile_15=testrun/debufr_15.out +args_15="-t ../tables" +../utils/debufr ${args_15} testfiles/data/debufr_15 > ${outfile_15} +[[ ${?} -eq 0 || `grep -c "NUMMTB - COULD NOT FIND DESCRIPTOR" ${outfile_15}` -ne 1 ]] && exit 15 + # Success! exit 0