Merge pull request #638 from NOAA-EMC/jba_common2

more code improvements, including removal of more Fortran common blocks

src/CMakeLists.txt

@@ -21,7 +21,7 @@ configure_file(${CMAKE_CURRENT_SOURCE_DIR}/misc.F90.in ${CMAKE_CURRENT_BINARY_DI
 list(APPEND fortran_src ${CMAKE_CURRENT_BINARY_DIR}/misc.F90)
 
 # Create the bufrlib.h file
-foreach(_var IN ITEMS bmostr bmcstr)
+foreach(_var IN ITEMS bmostr bmcstr fxy_fbit fxy_mintd fxy_minr fxy_drp16 fxy_drp8 fxy_drp1 fxy_drf16 fxy_drf8 fxy_drf1)
   file(STRINGS modules_vars.F90 _${_var}_tempstr REGEX "character.*${_var}")
   if(_${_var}_tempstr MATCHES "= '([A-Z0-9]+)")
     set(${_var} ${CMAKE_MATCH_1})

src/bufrlib.h.in

@@ -1,6 +1,5 @@
 /** @file
- *  @brief Enable a number of NCEPLIBS-bufr subprograms to be called from within
- *  the C part of the library.
+ *  @brief Enable a number of NCEPLIBS-bufr subprograms to be called from within the C part of the library.
  *
  *  This header file defines signatures which wrap a number of native Fortran subprograms
  *  in the library.  It also contains prototypes for native C functions in the library as
@@ -35,13 +34,31 @@ void stseq(int lun, int *irepct, int idn, char *nemo, char *cseq, int *cdesc, in
 #define FXY_STR_LEN 6
 
 /** Character string containing minimum FXY value for a replication descriptor. */
-#define MIN_FXY_REPL "101000"
+#define FXY_MINR "@fxy_minr@"
 
 /** Character string containing minimum FXY value for a Table D descriptor. */
-#define MIN_FXY_TABLED "300000"
+#define FXY_MINTD "@fxy_mintd@"
 
 /** Character string containing maximum FXY value for a Table B descriptor. */
-#define MAX_FXY_TABLEB "063255"
+#define FXY_MAXTB "@fxy_fbit@"
+
+/** Character string containing FXY value for NCEP Table D local descriptor denoting 16-bit delayed replication of a sequence using ( ) notation. */
+#define FXY_DRP16 "@fxy_drp16@"
+
+/** Character string containing FXY value for NCEP Table D local descriptor denoting 8-bit delayed replication of a sequence using { } notation. */
+#define FXY_DRP8 "@fxy_drp8@"
+
+/** Character string containing FXY value for NCEP Table D local descriptor denoting 1-bit delayed replication of a sequence using < > notation. */
+#define FXY_DRP1 "@fxy_drp1@"
+
+/** Character string containing FXY value for long (16-bit) delayed replication factor. */
+#define FXY_DRF16 "@fxy_drf16@"
+
+/** Character string containing FXY value for medium (8-bit) delayed replication factor. */
+#define FXY_DRF8 "@fxy_drf8@"
+
+/** Character string containing FXY value for short (1-bit) delayed replication factor. */
+#define FXY_DRF1 "@fxy_drf1@"
 
 /** Size of a character string needed to store a mnemonic. */
 #define NEMO_STR_LEN 8

src/dumpdata.F90

@@ -583,7 +583,8 @@ end subroutine ufdump
 !> @author J. Ator @date 2004-08-18
 recursive subroutine dxdump(lunit,ldxot)
 
-  use modv_vars, only: im8b, reps
+  use modv_vars, only: im8b, reps, fxy_fbit, fxy_sbyct, fxy_drp16, fxy_drp8, fxy_drp8s, fxy_drp1, &
+    fxy_drf16, fxy_drf8, fxy_drf1
 
   use moda_tababd
   use moda_nmikrp
@@ -603,8 +604,8 @@ recursive subroutine dxdump(lunit,ldxot)
   data cardi4  /'|------------------------------------------------------------------------------|'/
 
   ! Statement functions
-  tbskip(adn) = ((adn=='063000').or.(adn=='063255').or.(adn=='031000').or.(adn=='031001').or.(adn=='031002'))
-  tdskip(adn) = ((adn=='360001').or.(adn=='360002').or.(adn=='360003').or.(adn=='360004'))
+  tbskip(adn) = ((adn==fxy_sbyct).or.(adn==fxy_fbit).or.(adn==fxy_drf16).or.(adn==fxy_drf8).or.(adn==fxy_drf1))
+  tdskip(adn) = ((adn==fxy_drp16).or.(adn==fxy_drp8).or.(adn==fxy_drp8s).or.(adn==fxy_drp1))
 
   ! Check for I8 integers.
 

src/dxtable.F90

@@ -604,25 +604,23 @@ end subroutine elemdx
 !> @author Woollen @date 1994-01-06
 subroutine dxinit(lun,ioi)
 
-  use modv_vars, only: idnr
+  use modv_vars, only: idnr, fxy_fbit, fxy_sbyct, fxy_drf16, fxy_drf8, fxy_drf1
 
   use moda_tababd
 
   implicit none
 
   integer, intent(in) :: lun, ioi
-  integer ibct, ipd1, ipd2, ipd3, ipd4, ninib, ninid, n, i, iret, ifxy
+  integer ninib, ninid, n, i, iret, ifxy
 
   character*8 inib(6,5),inid(5)
   character*6 adn30
 
-  common /padesc/ ibct, ipd1, ipd2, ipd3, ipd4
-
-  data inib  /'------','BYTCNT  ','BYTES  ','+0','+0','16', &
-              '------','BITPAD  ','NONE   ','+0','+0','1 ', &
-              '031000','DRF1BIT ','NUMERIC','+0','+0','1 ', &
-              '031001','DRF8BIT ','NUMERIC','+0','+0','8 ', &
-              '031002','DRF16BIT','NUMERIC','+0','+0','16'/
+  data inib  / '------','BYTCNT  ','BYTES  ','+0','+0','16', &
+               '------','BITPAD  ','NONE   ','+0','+0','1 ', &
+               fxy_drf1,'DRF1BIT ','NUMERIC','+0','+0','1 ', &
+               fxy_drf8,'DRF8BIT ','NUMERIC','+0','+0','8 ', &
+              fxy_drf16,'DRF16BIT','NUMERIC','+0','+0','16'/
   data ninib /5/
 
   data inid  /'        ', &
@@ -653,8 +651,8 @@ subroutine dxinit(lun,ioi)
 
   ! Initialize table with apriori Table B and D entries
 
-  inib(1,1) = adn30(ibct,6)
-  inib(1,2) = adn30(ipd4,6)
+  inib(1,1) = fxy_sbyct
+  inib(1,2) = fxy_fbit
 
   do i=1,ninib
     ntbb(lun) = ntbb(lun)+1
@@ -693,18 +691,18 @@ end subroutine dxinit
 !> @author Woollen @date 1994-01-06
 subroutine dxmini(mbay,mbyt,mb4,mba,mbb,mbd)
 
-  use modv_vars, only: mxmsgld4, mtv, nby0, nby1, nby2, nby5, bmostr
+  use modv_vars, only: mxmsgld4, mtv, nby0, nby1, nby2, nby5, bmostr, idxv
 
   implicit none
 
   integer, intent(out) :: mbay(*), mbyt, mb4, mba, mbb, mbd
-  integer maxdx, idxv, nxstr, ldxa, ldxb, ldxd, ld30, mtyp, msbt, mbit, ih, id, im, iy, i, nsub, idxs, ldxs, &
+  integer nxstr, ldxa, ldxb, ldxd, ld30, mtyp, msbt, mbit, ih, id, im, iy, i, nsub, idxs, ldxs, &
     len3, nby4, iupm
 
   character*128 bort_str
   character*56 dxstr
 
-  common /dxtab/ maxdx, idxv, nxstr(10), ldxa(10), ldxb(10), ldxd(10), ld30(10), dxstr(10)
+  common /dxtab/ nxstr(10), ldxa(10), ldxb(10), ldxd(10), ld30(10), dxstr(10)
 
   msbt = idxv
 
@@ -840,18 +838,19 @@ end subroutine writdx
 !> @author J. Ator @date 2009-03-23
 recursive subroutine wrdxtb(lundx,lunot)
 
-  use modv_vars, only: im8b
+  use modv_vars, only: im8b, idxv
 
   use moda_tababd
   use moda_mgwa
+  use moda_bitbuf, only: maxbyt
 
   implicit none
 
   integer, intent(in) :: lundx, lunot
-  integer maxdx, idxv, nxstr, ldxa, ldxb, ldxd, ld30, my_lundx, my_lunot, ldx, lot, il, im, lda, ldb, ldd, l30, nseq, &
+  integer nxstr, ldxa, ldxb, ldxd, ld30, my_lundx, my_lunot, ldx, lot, il, im, lda, ldb, ldd, l30, nseq, &
     mbit, mbyt, mby4, mbya, mbyb, mbyd, i, j, jj, idn, lend, len0, len1, len2, l3, l4, l5, iupb, iupm
 
-  common /dxtab/ maxdx, idxv, nxstr(10), ldxa(10), ldxb(10), ldxd(10), ld30(10), dxstr(10)
+  common /dxtab/ nxstr(10), ldxa(10), ldxb(10), ldxd(10), ld30(10), dxstr(10)
 
   character*56 dxstr
   character*6 adn30
@@ -896,7 +895,7 @@ recursive subroutine wrdxtb(lundx,lunot)
   ! Table A information
 
   do i=1,ntba(lot)
-    if(msgfull(mbyt,lda,maxdx).or.(iupb(mgwa,mbya,8)==255)) then
+    if(msgfull(mbyt,lda,maxbyt).or.(iupb(mgwa,mbya,8)==255)) then
       call msgwrt(lunot,mgwa,mbyt)
       call dxmini(mgwa,mbyt,mby4,mbya,mbyb,mbyd)
     endif
@@ -916,7 +915,7 @@ recursive subroutine wrdxtb(lundx,lunot)
   ! Table B information
 
   do i=1,ntbb(lot)
-    if(msgfull(mbyt,ldb,maxdx).or.(iupb(mgwa,mbyb,8)==255)) then
+    if(msgfull(mbyt,ldb,maxbyt).or.(iupb(mgwa,mbyb,8)==255)) then
       call msgwrt(lunot,mgwa,mbyt)
       call dxmini(mgwa,mbyt,mby4,mbya,mbyb,mbyd)
     endif
@@ -936,7 +935,7 @@ recursive subroutine wrdxtb(lundx,lunot)
   do i=1,ntbd(lot)
     nseq = iupm(tabd(i,lot)(ldd+1:ldd+1),8)
     lend = ldd+1 + l30*nseq
-    if(msgfull(mbyt,lend,maxdx).or.(iupb(mgwa,mbyd,8)==255)) then
+    if(msgfull(mbyt,lend,maxbyt).or.(iupb(mgwa,mbyd,8)==255)) then
       call msgwrt(lunot,mgwa,mbyt)
       call dxmini(mgwa,mbyt,mby4,mbya,mbyb,mbyd)
     endif
@@ -980,14 +979,14 @@ end subroutine wrdxtb
 !> @author J. Ator @date 2009-03-23
 subroutine stbfdx(lun,mesg)
 
-  use modv_vars, only: maxcd
+  use modv_vars, only: maxcd, idxv
 
   use moda_tababd
 
   implicit none
 
   integer, intent(in) :: lun, mesg(*)
-  integer maxdx, idxv, nxstr, ldxa, ldxb, ldxd, ld30, ldxbd(10), ldxbe(10), ja, jb, idxs, i3, i, j, n, nd, ndd, idn, &
+  integer nxstr, ldxa, ldxb, ldxd, ld30, ldxbd(10), ldxbe(10), ja, jb, idxs, i3, i, j, n, nd, ndd, idn, &
     jbit, len0, len1, len2, len3, l4, l5, lda, ldb, ldd, ldbd, ldbe, l30, ia, la, ib, lb, id, ld, iret, &
     ifxy, iupb, iupbs01, igetntbi, idn30
 
@@ -1000,7 +999,7 @@ subroutine stbfdx(lun,mesg)
   character*8 nemo
   character*6 numb, cidn
 
-  common /dxtab/ maxdx, idxv, nxstr(10), ldxa(10), ldxb(10), ldxd(10), ld30(10), dxstr(10)
+  common /dxtab/ nxstr(10), ldxa(10), ldxb(10), ldxd(10), ld30(10), dxstr(10)
 
   data ldxbd /38, 70, 8*0/
   data ldxbe /42, 42, 8*0/
@@ -1656,20 +1655,20 @@ end subroutine stntbi
 !> @author Woollen @date 1994-01-06
 subroutine pktdd(id,lun,idn,iret)
 
-  use modv_vars, only: maxcd, iprt
+  use modv_vars, only: maxcd, iprt, idxv
 
   use moda_tababd
 
   implicit none
 
   integer, intent(in) :: id, lun, idn
   integer, intent(out) :: iret
-  integer maxdx, idxv, nxstr, ldxa, ldxb, ldxd, ld30, ldd, nd, idm, iupm
+  integer nxstr, ldxa, ldxb, ldxd, ld30, ldd, nd, idm, iupm
 
   character*128 errstr
   character*56 dxstr
 
-  common /dxtab/ maxdx, idxv, nxstr(10), ldxa(10), ldxb(10), ldxd(10), ld30(10), dxstr(10)
+  common /dxtab/ nxstr(10), ldxa(10), ldxb(10), ldxd(10), ld30(10), dxstr(10)
 
   ! ldd points to the byte within tabd(id,lun) which contains (in packed integer format) a count of the number of child
   ! mnemonics stored thus far for this parent mnemonic.
@@ -1730,18 +1729,20 @@ end subroutine pktdd
 !> @author J. Woollen @date 1994-01-06
 subroutine uptdd(id,lun,ient,iret)
 
+  use modv_vars, only: idxv
+
   use moda_tababd
 
   implicit none
 
   integer, intent(in) :: id, lun, ient
   integer, intent(out) :: iret
-  integer maxdx, idxv, nxstr, ldxa, ldxb, ldxd, ld30, ldd, ndsc, idsc, iupm
+  integer nxstr, ldxa, ldxb, ldxd, ld30, ldd, ndsc, idsc, iupm
 
   character*128 bort_str
   character*56 dxstr
 
-  common /dxtab/ maxdx, idxv, nxstr(10), ldxa(10), ldxb(10), ldxd(10), ld30(10), dxstr(10)
+  common /dxtab/ nxstr(10), ldxa(10), ldxb(10), ldxd(10), ld30(10), dxstr(10)
 
   ! Check if ient is in bounds
 

src/fxy.F90

@@ -288,6 +288,8 @@ end function numbck
 !> @author J. Woollen @date 2002-05-14
 subroutine numtbd(lun,idn,nemo,tab,iret)
 
+  use modv_vars, only: fxy_mintd
+
   use moda_tababd
 
   implicit none
@@ -303,7 +305,7 @@ subroutine numtbd(lun,idn,nemo,tab,iret)
   iret = 0
   tab = ' '
 
-  if(idn>=ifxy('300000')) then
+  if(idn>=ifxy(fxy_mintd)) then
     ! Look for idn in Table D
     do i=1,ntbd(lun)
       if(idn==idnd(i,lun)) then

src/mastertable.F90

@@ -566,7 +566,8 @@ subroutine sntbbe ( ifxyn, line, mxmtbb, nmtbb, imfxyn, cmscl, cmsref, cmbw, cmu
   implicit none
 
   integer, intent(in) :: ifxyn, mxmtbb
-  integer, intent(out) :: nmtbb, imfxyn(*)
+  integer, intent(inout) :: nmtbb
+  integer, intent(out) :: imfxyn(*)
   integer ntag, ii, nemock
 
   character, intent(out) :: cmelem(120,*), cmunit(24,*), cmsref(12,*), cmmnem(8,*), cmscl(4,*), cmbw(4,*), cmdsc(*)*4
@@ -710,7 +711,8 @@ subroutine sntbde ( lunt, ifxyn, line, mxmtbd, mxelem, nmtbd, imfxyn, cmmnem, cm
   implicit none
 
   integer, intent(in) :: lunt, ifxyn, mxmtbd, mxelem
-  integer, intent(out) :: nmtbd, imfxyn(*), nmelem(*), iefxyn(mxmtbd,mxelem)
+  integer, intent(inout) :: nmtbd
+  integer, intent(out) :: imfxyn(*), nmelem(*), iefxyn(mxmtbd,mxelem)
   integer ii, ipt, ntag, nelem, nemock, ifxy, igetfxy, igetntbl
 
   character*(*), intent(in) :: line

src/misc.F90.in

@@ -28,16 +28,14 @@ subroutine bfrini
 
   implicit none
 
-  integer ndndx(10), nldxa(10), nldxb(10), nldxd(10), nld30(10), ibct, ipd1, ipd2, ipd3, ipd4, nrpl, nmrg, namb, ntot, &
-    maxdx, idxv, nxstr, ldxa, ldxb, ldxd, ld30, i, j, i1, ifxy
+  integer ndndx(10), nldxa(10), nldxb(10), nldxd(10), nld30(10), nxstr, ldxa, ldxb, ldxd, ld30, &
+    i, j, i1, ifxy
 
   character*240 cmtdir
   character*56 dxstr
   character*6 dndx(25,10)
 
-  common /padesc/ ibct, ipd1, ipd2, ipd3, ipd4
-  common /dxtab/ maxdx, idxv, nxstr(10), ldxa(10), ldxb(10), ldxd(10), ld30(10), dxstr(10)
-  common /mrgcom/ nrpl,nmrg,namb,ntot
+  common /dxtab/ nxstr(10), ldxa(10), ldxb(10), ldxd(10), ld30(10), dxstr(10)
 
   data (dndx(i,1),i=1,25)/ &
     '102000','031001','000001','000002', &
@@ -59,14 +57,6 @@ subroutine bfrini
 
   maxbyt = min(10000,mxmsgl)
 
-  ! Initialize common /padesc/
-
-  ibct = ifxy('063000')
-  ipd1 = ifxy('102000')
-  ipd2 = ifxy('031001')
-  ipd3 = ifxy('206001')
-  ipd4 = ifxy('063255')
-
   ! Initialize module @ref moda_stbfr
 
   do i=1,nfiles
@@ -109,10 +99,6 @@ subroutine bfrini
 
   ! Initialize common /dxtab/
 
-  maxdx = maxbyt
-  ! idxv is the version number of the local tables
-  idxv = 1
-
   do j=1,10
     ldxa(j) = nldxa(j)
     ldxb(j) = nldxb(j)
@@ -132,13 +118,6 @@ subroutine bfrini
     msglen(i) = 0
   enddo
 
-  ! Initialize common /mrgcom/
-
-  nrpl = 0
-  nmrg = 0
-  namb = 0
-  ntot = 0
-
   ! Initialize module @ref moda_bufrsr
 
   do i=1,nfiles
@@ -511,14 +490,12 @@ subroutine mrginv
 
   use modv_vars, only: iprt
 
-  implicit none
+  use moda_mrgcom
 
-  integer nrpl, nmrg, namb, ntot
+  implicit none
 
   character*128 errstr
 
-  common /mrgcom/ nrpl, nmrg, namb, ntot
-
   if(iprt>=0) then
     call errwrt('+++++++++++++++++++++BUFRLIB+++++++++++++++++++++++')
     call errwrt('---------------------------------------------------')

src/missing.F90

@@ -68,6 +68,7 @@ recursive integer function icbfms ( str, lstr ) result ( iret )
 
   integer, intent(in) :: lstr
   integer my_lstr, numchr, ii, iupm
+  integer*8 il8z
 
   equivalence(strz,rl8z)
 
@@ -96,7 +97,7 @@ recursive integer function icbfms ( str, lstr ) result ( iret )
     do ii = 1, numchr
       strz(ii:ii) = str(ii:ii)
     end do
-    write (zz,'(z16.16)') rl8z
+    write (zz,'(z16.16)') transfer(rl8z,il8z)
     ii = 2*(8-numchr)+1
     if ( zz(ii:16)==zm_be(ii:16) .or. zz(ii:16)==zm_le(ii:16) ) then
       iret = 1