Merge pull request #636 from NOAA-EMC/jba_common

code improvements, including removal of some Fortran common blocks

src/CMakeLists.txt

@@ -14,12 +14,24 @@ list(APPEND c_src
   arallocc.c cpmstabs.c cread.c crwbmg.c cfe.c icvidx.c restd.c stseq.c)
 
 list(APPEND c_hdr
-  cread.h mstabs.h rpseqs.h bufr_interface.h bufrlib.h)
+  cread.h mstabs.h rpseqs.h bufr_interface.h)
 
 # Create the misc.F90 file
 configure_file(${CMAKE_CURRENT_SOURCE_DIR}/misc.F90.in ${CMAKE_CURRENT_BINARY_DIR}/misc.F90 @ONLY)
 list(APPEND fortran_src ${CMAKE_CURRENT_BINARY_DIR}/misc.F90)
 
+# Create the bufrlib.h file
+foreach(_var IN ITEMS bmostr bmcstr)
+  file(STRINGS modules_vars.F90 _${_var}_tempstr REGEX "character.*${_var}")
+  if(_${_var}_tempstr MATCHES "= '([A-Z0-9]+)")
+    set(${_var} ${CMAKE_MATCH_1})
+  else()
+    message(FATAL_ERROR "Unable to parse variable ${_var} value from file modules_vars.F90")
+  endif()
+endforeach()
+configure_file(${CMAKE_CURRENT_SOURCE_DIR}/bufrlib.h.in ${CMAKE_CURRENT_BINARY_DIR}/bufrlib.h @ONLY)
+list(APPEND c_hdr ${CMAKE_CURRENT_BINARY_DIR}/bufrlib.h)
+
 include(TestBigEndian)
 test_big_endian(IS_BIG_ENDIAN)
 if(IS_BIG_ENDIAN)

src/arallocf.F90

@@ -19,7 +19,7 @@ subroutine arallocf
 
   use modv_vars, only: maxcd, maxjl, maxmem, maxmsg, maxss, maxtba, maxtbb, maxtbd, mxbtm, mxbtmse, &
                        mxcdv, mxcsb, mxdxts, mxlcc, mxmsgl, mxmsgld4, mxmtbb, mxmtbd, mxnrv, mxrst, &
-                       mxs01v, mxtamc, mxtco, mxh4wlc, nfiles, mxcnem, maxnc, maxrcr
+                       mxs01v, mxtamc, mxtco, mxh4wlc, nfiles, mxcnem, maxnc, maxrcr, iprt
 
   use moda_usrint
   use moda_usrbit
@@ -63,9 +63,7 @@ subroutine arallocf
   character*80 errstr
   character*36 brtstr
 
-  integer iost, iprt
-
-  common /quiet/ iprt
+  integer iost
 
   if ( iprt >= 1 ) then
     call errwrt ('++++++++++++++BUFR ARCHIVE LIBRARY+++++++++++++++++')

src/bufrlib.h → src/bufrlib.h.in

@@ -49,6 +49,12 @@ void stseq(int lun, int *irepct, int idn, char *nemo, char *cseq, int *cdesc, in
 /** Size of a character string needed to store the units of a Table B descriptor. */
 #define UNIT_STR_LEN 24
 
+/** Opening string of a BUFR message. */
+#define BMOSTR "@bmostr@"
+
+/** Closing string of a BUFR message. */
+#define BMCSTR "@bmcstr@"
+
 /**
  * Convert an FXY value from its WMO bit-wise representation to its
  * six-character representation.

src/compress.F90

@@ -196,7 +196,7 @@ subroutine rdcmps(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
       ! routine, and a separate subsequent call to subroutine readlc() will be required to unpack the remainder of the string.
-      ! In this case, pointers will be saved within common /rlccmn/ for later use within readlc().
+      ! In this case, pointers will be saved within module @ref moda_rlccmn for later use within readlc().
       lelm = nbit/8
       nchr = min(8,lelm)
       ibsv = ibit
@@ -257,20 +257,19 @@ end subroutine rdcmps
 !> @author Woollen @date 2002-05-14
 subroutine cmsgini(lun,mesg,subset,idate,nsub,nbyt)
 
+  use modv_vars, only: mtv, nby1, nby5, bmostr
+
   implicit none
 
   integer, intent(in) :: lun, idate, nsub
   integer, intent(inout) :: nbyt
   integer, intent(out) :: mesg(*)
-  integer mtyp, msbt, inod, isub, iret, jdate, mcen, mear, mmon, mday, mour, mmin, mbit, mbyt, len1, len3, i4dy
+  integer mtyp, msbt, inod, isub, iret, jdate, mcen, mear, mmon, mday, mour, mmin, mbit, mbyt, len3, i4dy
 
   character*128 bort_str
   character*8, intent(in) :: subset
-  character*4 bufr
   character tab
 
-  data bufr/'BUFR'/
-
   ! Get the message tag and type, and break up the date which can be either YYMMDDHH or YYYYMMDDHH
 
   call nemtba(lun,subset,mtyp,msbt,inod)
@@ -299,25 +298,23 @@ subroutine cmsgini(lun,mesg,subset,idate,nsub,nbyt)
 
   ! Section 0
 
-  call pkc(bufr ,  4 , mesg,mbit)
+  call pkc(bmostr,  4 , mesg,mbit)
   ! Note that the actual Section 0 length will be computed and stored below; for now, we're really only interested in
   ! advancing mbit by the correct amount, so we'll just store a default value of 0.
   call pkb(   0 , 24 , mesg,mbit)
   call pkb(   3 ,  8 , mesg,mbit)
 
   ! Section 1
 
-  len1 = 18
-
-  call pkb(len1 , 24 , mesg,mbit)
+  call pkb(nby1 , 24 , mesg,mbit)
   call pkb(   0 ,  8 , mesg,mbit)
   call pkb(   3 ,  8 , mesg,mbit)
   call pkb(   7 ,  8 , mesg,mbit)
   call pkb(   0 ,  8 , mesg,mbit)
   call pkb(   0 ,  8 , mesg,mbit)
   call pkb(mtyp ,  8 , mesg,mbit)
   call pkb(msbt ,  8 , mesg,mbit)
-  call pkb(  36 ,  8 , mesg,mbit)
+  call pkb( mtv ,  8 , mesg,mbit)
   call pkb(   0 ,  8 , mesg,mbit)
   call pkb(mear ,  8 , mesg,mbit)
   call pkb(mmon ,  8 , mesg,mbit)
@@ -353,7 +350,7 @@ subroutine cmsgini(lun,mesg,subset,idate,nsub,nbyt)
   !         (length of message up through fourth byte of Section 4)
   !      +  (length of compressed data portion of Section 4)
   !      +  (length of Section 5)
-  mbyt = mbit/8 + nbyt + 4
+  mbyt = mbit/8 + nbyt + nby5
 
   ! For output, make nbyt point to the current location of mbit, which is the byte after which to actually begin writing the
   ! compressed data into Section 4.
@@ -377,15 +374,15 @@ end subroutine cmsgini
 !> order to hold the current subset (still stored for compression).
 !>
 !> This subroutine performs functions similar to NCEPLIBS-bufr
-!> subroutine msgupd() except that it acts on compressed bufr messages.
+!> subroutine msgupd() except that it acts on compressed BUFR messages.
 !>
 !> @param lunix - Absolute value is Fortran logical unit number for BUFR file
 !> - if lunix is less than zero, then this is a "flush" call and the buffer must be cleared out
 !>
 !> @author Woollen @date 2002-05-14
 subroutine wrcmps(lunix)
 
-  use modv_vars, only: mxcdv, mxcsb
+  use modv_vars, only: mxcdv, mxcsb, nby5, bmcstr
 
   use moda_usrint
   use moda_msgcwd
@@ -650,7 +647,7 @@ subroutine wrcmps(lunix)
 
     ! Add Section 5
 
-    call pkc('7777',4,mgwa,ibit)
+    call pkc(bmcstr,nby5,mgwa,ibit)
 
     ! Check that the message byte counters agree, then write the message
 

src/copydata.F90

@@ -511,17 +511,15 @@ end subroutine cpymem
 !> @author Woollen @date 1994-01-06
 subroutine cpyupd(lunit,lin,lun,ibyt)
 
+  use modv_vars, only: iprt, nby0, nby1, nby2, nby3
+
   use moda_msgcwd
   use moda_bitbuf
 
   implicit none
 
   integer, intent(in) :: lunit, lin, lun, ibyt
-  integer nby0, nby1, nby2, nby3, nby4, nby5, iprt, lbit, lbyt, nbyt, iupb
-
-  common /msgptr/ nby0,nby1,nby2,nby3,nby4,nby5
-
-  common /quiet/ iprt
+  integer lbit, lbyt, nbyt, iupb
 
   character*128 bort_str, errstr
 

src/cread.c

@@ -120,7 +120,7 @@ crdbufr(int nfile, int *bufr, int mxwrd) {
 
     /* Find the start of the next BUFR message within the file. */
     fgetpos(pb[nfile], &lstpos[nfile]);
-    while (strncmp(wkchr, "BUFR", 4) != 0) {
+    while (strncmp(wkchr, BMOSTR, 4) != 0) {
         memmove(wkchr, &wkchr[1], 3);
         if (fread(wkchr + 3, 1, 1, pb[nfile]) != 1)
             return -1;
@@ -173,7 +173,7 @@ crdbufr(int nfile, int *bufr, int mxwrd) {
         fsetpos(pb[nfile], &nxtpos);
         return -2;
     }
-    if (strncmp(&wkchr[nbytrem-4], "7777", 4) != 0) {
+    if (strncmp(&wkchr[nbytrem-4], BMCSTR, 4) != 0) {
         fsetpos(pb[nfile], &nxtpos);
         return -2;
     }

src/crwbmg.c

@@ -218,7 +218,7 @@ crbmg(char *bmg, int mxmb, int *nmb, int *iret)
     /*
     ** Look for the start of the next BUFR message.
     */
-    while (strncmp("BUFR", bmg, 4) != 0) {
+    while (strncmp(BMOSTR, bmg, 4) != 0) {
         memmove(bmg, &bmg[1], 3);
         if ((*iret = rbytes(bmg, mxmb, 3, 1)) != 0) return;
     }
@@ -238,7 +238,7 @@ crbmg(char *bmg, int mxmb, int *nmb, int *iret)
     /*
     ** Check that the "7777" is in the expected location.
     */
-    *iret = ((strncmp("7777", &bmg[*nmb-4], 4) == 0) ? 0 : 2);
+    *iret = ((strncmp(BMCSTR, &bmg[*nmb-4], 4) == 0) ? 0 : 2);
 
     return;
 }

src/dxtable.F90

@@ -27,15 +27,15 @@
 !> @author Woollen @date 1994-01-06
 subroutine readdx(lunit,lun,lundx)
 
+  use modv_vars, only: iprt
+
   implicit none
 
   integer, intent(in) :: lunit, lun, lundx
-  integer iprt, lud, ildx, imdx
+  integer lud, ildx, imdx
 
   character*128 errstr
 
-  common /quiet/ iprt
-
   ! Get the status of unit lundx
 
   call status(lundx,lud,ildx,imdx)
@@ -121,19 +121,19 @@ subroutine rdbfdx(lunit,lun)
 
   use bufrlib
 
+  use modv_vars, only: iprt
+
   use moda_mgwa
 
   implicit none
 
   integer, intent(in) :: lunit, lun
-  integer iprt, ict, ier, idxmsg, iupbs3
+  integer ict, ier, idxmsg, iupbs3
 
   character*128 errstr
 
   logical done
 
-  common /quiet/ iprt
-
   call dxinit(lun,0)
 
   ict = 0
@@ -693,13 +693,13 @@ end subroutine dxinit
 !> @author Woollen @date 1994-01-06
 subroutine dxmini(mbay,mbyt,mb4,mba,mbb,mbd)
 
-  use modv_vars, only: mxmsgld4
+  use modv_vars, only: mxmsgld4, mtv, nby0, nby1, nby2, nby5, bmostr
 
   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, &
-    nby0, nby1, nby2, nby3, nby4, nby5, iupm
+    len3, nby4, iupm
 
   character*128 bort_str
   character*56 dxstr
@@ -726,19 +726,15 @@ subroutine dxmini(mbay,mbyt,mb4,mba,mbb,mbd)
   idxs = idxv+1
   ldxs = nxstr(idxs)
 
-  nby0 = 8
-  nby1 = 18
-  nby2 = 0
-  nby3 = 7 + nxstr(idxs) + 1
+  len3 = 7 + nxstr(idxs) + 1
   nby4 = 7
-  nby5 = 4
-  mbyt = nby0+nby1+nby2+nby3+nby4+nby5
+  mbyt = nby0+nby1+nby2+len3+nby4+nby5
 
-  if(mod(nby3,2)/=0) call bort ('BUFRLIB: DXMINI - LENGTH OF SECTION 3 IS NOT A MULTIPLE OF 2')
+  if(mod(len3,2)/=0) call bort ('BUFRLIB: DXMINI - LENGTH OF SECTION 3 IS NOT A MULTIPLE OF 2')
 
   ! Section 0
 
-  call pkc('BUFR' ,  4 , mbay,mbit)
+  call pkc(bmostr ,  4 , mbay,mbit)
   call pkb(  mbyt , 24 , mbay,mbit)
   call pkb(     3 ,  8 , mbay,mbit)
 
@@ -752,7 +748,7 @@ subroutine dxmini(mbay,mbyt,mb4,mba,mbb,mbd)
   call pkb(     0 ,  8 , mbay,mbit)
   call pkb(  mtyp ,  8 , mbay,mbit)
   call pkb(  msbt ,  8 , mbay,mbit)
-  call pkb(    36 ,  8 , mbay,mbit)
+  call pkb(   mtv ,  8 , mbay,mbit)
   call pkb(  idxv ,  8 , mbay,mbit)
   call pkb(    iy ,  8 , mbay,mbit)
   call pkb(    im ,  8 , mbay,mbit)
@@ -763,7 +759,7 @@ subroutine dxmini(mbay,mbyt,mb4,mba,mbb,mbd)
 
   ! Section 3
 
-  call pkb(  nby3 , 24 , mbay,mbit)
+  call pkb(  len3 , 24 , mbay,mbit)
   call pkb(     0 ,  8 , mbay,mbit)
   call pkb(     1 , 16 , mbay,mbit)
   call pkb(  2**7 ,  8 , mbay,mbit)
@@ -1660,21 +1656,20 @@ end subroutine stntbi
 !> @author Woollen @date 1994-01-06
 subroutine pktdd(id,lun,idn,iret)
 
-  use modv_vars, only: maxcd
+  use modv_vars, only: maxcd, iprt
 
   use moda_tababd
 
   implicit none
 
   integer, intent(in) :: id, lun, idn
   integer, intent(out) :: iret
-  integer maxdx, idxv, nxstr, ldxa, ldxb, ldxd, ld30, iprt, ldd, nd, idm, iupm
+  integer maxdx, idxv, 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 /quiet/ iprt
 
   ! 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.