bring over last remaining WCOSS src updates, and add new test_OUT_5 program

.github/workflows/main.yml

@@ -21,7 +21,7 @@ jobs:
         cd bufr
         mkdir build
         cd build
-        cmake .. -DENABLE_TESTS=ON
+        cmake ..
         make -j2
 
     - name: test

README.md

@@ -19,7 +19,7 @@ Code manager: Jeff Ator
 <pre>
 git clone https://github.com/noaa-emc/nceplibs-bufr
 mkdir build && cd build
-cmake -DCMAKE_INSTALL_PREFIX=./install -DENABLE_TESTS=ON ../nceplibs-bufr
+cmake -DCMAKE_INSTALL_PREFIX=./install ../nceplibs-bufr
 make -j4
 ctest
 make install

src/bvers.f.in

@@ -1,7 +1,7 @@
 C> @file
 C> @author J. Ator
 C> @date 2020-10-21
-C>	
+
 C> @brief This subroutine returns a character string containing
 C> the version number of the BUFR archive library software.
 C>

src/closbf.F

@@ -2,7 +2,7 @@
 C> @authors Jack Woollen
 C> @authors Jeff Ator
 C> @date 2020-07-16
-C>      
+
 C> @brief This subroutine closes the connection between logical unit
 C> LUNIT and the BUFRLIB software.
 C>

src/icbfms.f

@@ -26,14 +26,12 @@
 C>                1 - STR IS "MISSING"
 C>
 C> REMARKS:
-C>    THIS ROUTINE CALLS:        IUPM
-C>    THIS ROUTINE IS CALLED BY: RDCMPS   RDTREE   UFDUMP
+C>    THIS ROUTINE CALLS:        iupm()
+C>    THIS ROUTINE IS CALLED BY: rdcmps()  rdtree()  ufbdmp()  ufdump()
 C>                               Also called by application programs.
 C>
 	INTEGER FUNCTION ICBFMS ( STR, LSTR )
 
-
-
 	INCLUDE	'bufrlib.inc'
 
 	CHARACTER*(*)	STR

src/ireadmg.f

@@ -1,7 +1,7 @@
 C> @file
 C> @author Jack Woollen
 C> @date 2003-11-04
-C>      
+
 C> @brief This function calls BUFRLIB subroutine readmg() and passes
 C> back its return code as the function value.
 C>

src/openbf.F

@@ -3,7 +3,7 @@
 C> @authors Jeff Ator
 C> @authors Dennis Keyser
 C> @date 2015-03-03
-C>
+
 C> @brief This subroutine identifies a new file to the BUFRLIB software for
 C> input or output operations.
 C>

src/readmg.f

@@ -2,7 +2,7 @@
 C> @authors Jack Woollen
 C> @authors Jeff Ator
 C> @date 2020-07-16
-C>
+
 C> @brief This subroutine reads the next BUFR message from logical unit
 C> ABS(LUNXX) into internal arrays.
 C>

src/ufbdmp.f

@@ -1,6 +1,6 @@
 C> @file
 C> @author WOOLLEN @date 1994-01-06
-      
+
 C> THIS SUBROUTINE DUMPS A DETAILED PRINT LISTING OF THE
 C>   CONTENTS OF THE UNPACKED DATA SUBSET CURRENTLY RESIDING IN THE
 C>   INTERNAL ARRAYS ASSOCIATED WITH THE BUFR FILE IN LOGICAL UNIT
@@ -62,6 +62,7 @@
 C>                           ACTUAL BITS THAT WERE SET TO GENERATE VALUE
 C> 2007-01-19  J. ATOR    -- USE FUNCTION IBFMS
 C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
+C> 2020-09-09  J. ATOR    -- FIX MISSING CHECK FOR LONG CHARACTER STRINGS
 C>
 C> USAGE:    CALL UFBDMP (LUNIN, LUPRT)
 C>   INPUT ARGUMENT LIST:
@@ -108,24 +109,23 @@
 C>    THIS SUBROUTINE STOPS THE SCROLL AND RETURNS TO THE CALLING
 C>    PROGRAM (PRESUMABLY TO READ IN THE NEXT SUBSET IN THE BUFR FILE).
 C>
-C>    THIS ROUTINE CALLS:        BORT     IBFMS    ISIZE    READLC
-C>                               RJUST    STATUS   UPFTBV
+C>    THIS ROUTINE CALLS:   bort()   ibfms()   icbfms()  isize()
+C>                         readlc() rjust()  status()  upftbv()
 C>    THIS ROUTINE IS CALLED BY: None
 C>                               Normally called only by application
 C>                               programs.
 C>
       SUBROUTINE UFBDMP(LUNIN,LUPRT)
 
-
-
       USE MODA_USRINT
       USE MODA_MSGCWD
       USE MODA_TABABD
       USE MODA_TABLES
 
       INCLUDE 'bufrlib.inc'
 
-      CHARACTER*20 LCHR
+      CHARACTER*120 LCHR2
+      CHARACTER*20 LCHR,PMISS
       CHARACTER*14 BITS
       CHARACTER*10 TG,TG_RJ
       CHARACTER*8  VC
@@ -138,6 +138,7 @@ SUBROUTINE UFBDMP(LUNIN,LUPRT)
       PARAMETER (MXFV=31)
       INTEGER	IFV(MXFV)
 
+      DATA PMISS /'             MISSING'/
       DATA YOU /'Y'/
 
 C----------------------------------------------------------------------
@@ -225,9 +226,7 @@ SUBROUTINE UFBDMP(LUNIN,LUPRT)
             ENDIF
          ENDIF
          IF(IBFMS(VL).NE.0) THEN
-            LCHR = 'MISSING'
-            RJ = RJUST(LCHR)
-            WRITE(LUOUT,2) NV,TP,IT,TG_RJ,LCHR,IB,IS,IR,ND,JP,LK,JB
+            WRITE(LUOUT,2) NV,TP,IT,TG_RJ,PMISS,IB,IS,IR,ND,JP,LK,JB
          ELSE
             IF(LUNIT.EQ.LUNIN) THEN
                WRITE(LUOUT,1) NV,TP,IT,TG_RJ,VL,BITS,IB,IS,IR,ND,JP,LK,
@@ -238,23 +237,38 @@ SUBROUTINE UFBDMP(LUNIN,LUPRT)
             ENDIF
          ENDIF
       ELSE
-         IF(IB.GT.64) THEN
-            CALL READLC(LUNIT,LCHR,TG_RJ)
+         NCHR=IB/8
+         IF(NCHR.GT.8) THEN
+            CALL READLC(LUNIT,LCHR2,TG_RJ)
+            IF (ICBFMS(LCHR2,NCHR).NE.0) THEN
+               LCHR = PMISS
+            ELSE
+               LCHR = LCHR2(1:20)
+            ENDIF
+         ELSE
+            IF(IBFMS(VL).NE.0) THEN
+               LCHR = PMISS
+            ELSE
+               LCHR = VC
+            ENDIF
+         ENDIF
+         IF ( NCHR.LE.20 .OR. LCHR.EQ.PMISS ) THEN
+            RJ = RJUST(LCHR)
+            WRITE(LUOUT,2) NV,TP,IT,TG_RJ,LCHR,IB,IS,IR,ND,JP,LK,JB
          ELSE
-            LCHR = VC
+            WRITE(LUOUT,4) NV,TP,IT,TG_RJ,LCHR2(1:NCHR),IB,IS,IR,ND,JP,
+     .       LK,JB
          ENDIF
-         IF(IBFMS(VL).NE.0) LCHR = 'MISSING'
-         RJ = RJUST(LCHR)
-         WRITE(LUOUT,2) NV,TP,IT,TG_RJ,LCHR,IB,IS,IR,ND,JP,LK,JB
       ENDIF
       ENDDO
 
       WRITE(LUOUT,3)
 
 1     FORMAT(I5,1X,A3,'-',I1,1X,A10,5X,G15.6,1X,A14,7(1X,I5))
 10    FORMAT(I5,1X,A3,'-',I1,1X,A10,5X,F15.6,1X,A14,7(1X,I5))
-2     FORMAT(I5,1X,A3,'-',I1,1X,A10,   A20,  15X,   7(1X,I5))
+2     FORMAT(I5,1X,A3,'-',I1,1X,A10,1X,   A20,  14X,7(1X,I5))
 3     FORMAT(/' >>> END OF SUBSET <<< '/)
+4     FORMAT(I5,1X,A3,'-',I1,1X,A10,1X,      A,     7(1X,I5))
 
 C  EXITS
 C  -----

src/ufdump.f

@@ -1,6 +1,6 @@
 C> @file
 C> @author WOOLLEN @date 2002-05-14
-      
+
 C> THIS SUBROUTINE DUMPS A DETAILED PRINT LISTING OF THE
 C>   CONTENTS OF THE UNPACKED DATA SUBSET CURRENTLY RESIDING IN THE
 C>   INTERNAL ARRAYS ASSOCIATED WITH THE BUFR FILE IN LOGICAL UNIT LUNIT.
@@ -45,6 +45,7 @@
 C> 2012-03-02  J. ATOR    -- LABEL REDEFINED REFERENCE VALUES
 C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
 C> 2015-09-24  J. WOOLLEN -- PRINT LEVEL IDENTIFIERS FOR EVENT STACKS
+C> 2020-08-18  J. ATOR    -- IMPROVE LOGIC FOR SEQUENCE TRACKING
 C>
 C> USAGE:    CALL UFDUMP (LUNIT, LUPRT)
 C>   INPUT ARGUMENT LIST:
@@ -72,18 +73,16 @@
 C>    THIS SUBROUTINE STOPS THE SCROLL AND RETURNS TO THE CALLING
 C>    PROGRAM (PRESUMABLY TO READ IN THE NEXT SUBSET IN THE BUFR FILE).
 C>
-C>    THIS ROUTINE CALLS:        BORT     FSTAG    ICBFMS   IBFMS
-C>                               IREADMT  ISIZE    NEMTAB   NUMTBD
-C>                               READLC   RJUST    SRCHTBF  STATUS
-C>                               STRSUC   UPFTBV
+C>    THIS ROUTINE CALLS:   bort()    fstag()   icbfms()   ibfms()
+C>                          ireadmt() isize()   nemtab()   numtbd()
+C>                          readlc()   rjust()   srchtbf()  status()
+C>                          strsuc()   upftbv()
 C>    THIS ROUTINE IS CALLED BY: None
 C>                               Normally called only by application
 C>                               programs.
 C>
       SUBROUTINE UFDUMP(LUNIT,LUPRT)
 
-
-
       USE MODA_USRINT
       USE MODA_MSGCWD
       USE MODA_TABABD
@@ -122,6 +121,7 @@ SUBROUTINE UFDUMP(LUNIT,LUPRT)
       INTEGER   IDXREP(MXSEQ)
       INTEGER   NUMREP(MXSEQ)
       CHARACTER*10 SEQNAM(MXSEQ)
+      INTEGER   LSQNAM(MXSEQ)
 
       PARAMETER (MXLS=10)
       CHARACTER*10 LSNEMO(MXLS)
@@ -152,9 +152,7 @@ SUBROUTINE UFDUMP(LUNIT,LUPRT)
       IF(IM.EQ.0) GOTO 902
       IF(INODE(LUN).NE.INV(1,LUN)) GOTO 903
 
-      WRITE(LUOUT,*)
-      WRITE(LUOUT,*) 'MESSAGE TYPE ',TAG(INODE(LUN))
-      WRITE(LUOUT,*)
+      WRITE(LUOUT,FMT='(/,2A,/)') 'MESSAGE TYPE ',TAG(INODE(LUN))
 
 C  DUMP THE CONTENTS OF MODULE USRINT FOR UNIT LUNIT
 C  -------------------------------------------------
@@ -226,7 +224,8 @@ SUBROUTINE UFDUMP(LUNIT,LUPRT)
 
 C            Track the sequence
 
-             SEQNAM(NSEQ) = NEMO
+             SEQNAM(NSEQ) = NEMO2
+             LSQNAM(NSEQ) = LNM2
              IDXREP(NSEQ) = 1
            ELSE
 
@@ -243,7 +242,7 @@ SUBROUTINE UFDUMP(LUNIT,LUPRT)
            TRACK = .FALSE.
            CALL STRSUC(NEMO,NEMO2,LNM2)
            DO WHILE ((II.GE.1).AND.(.NOT.TRACK))
-             IF(INDEX(SEQNAM(II),NEMO2(1:LNM2)).GT.0) THEN
+             IF(NEMO2(1:LNM2).EQ.SEQNAM(II)(2:LSQNAM(II)-1)) THEN
                TRACK = .TRUE.
 
 C              Mark this level in the output
@@ -346,7 +345,7 @@ SUBROUTINE UFDUMP(LUNIT,LUPRT)
 
 C              Print the meanings of the code and flag values.
 
-               FMT = '(35X,I4,A,A)'
+               FMT = '(31X,I8,A,A)'
                IF(UNIT(1:4).EQ.'CODE') THEN
                   NIFV = 1
                   IFV(NIFV) = NINT(RVAL)

test/CMakeLists.txt

@@ -75,6 +75,10 @@ list(APPEND test_OUT_4_srcs
   test_OUT_4.f
 )
 
+list(APPEND test_OUT_5_srcs
+  test_OUT_5.f
+)
+
 # Install test_wrapper.sh
 execute_process( COMMAND ${CMAKE_COMMAND} -E copy
   ${CMAKE_CURRENT_SOURCE_DIR}/test_wrapper.sh
@@ -90,7 +94,6 @@ function(bufr_add_test_preAPX TESTNAME EXENAME)
            COMMAND ${CMAKE_BINARY_DIR}/bin/test_wrapper.sh ${EXENAME} "Y")
 endfunction()
 
-# Tests are only guarenteed to work for _4 libraries.
 # Both GNU and Intel support DYNAMIC_ALLOCATION
 list(APPEND test_kinds "4_DA")
 # Only Intel supports STATIC_ALLOCATION
@@ -113,8 +116,8 @@ foreach(test_src ${test_IN_srcs})
   endforeach()
 endforeach()
 
-# OUT_1 tests
-foreach(test_src ${test_OUT_1_srcs})
+# OUT_1 and OUT_5 tests
+foreach(test_src IN ITEMS ${test_OUT_1_srcs} ${test_OUT_5_srcs})
   string(REPLACE ".f" "" testPref ${test_src})
   foreach(kind ${test_kinds})
     set(test     ${testPref}_${kind})

test/test_OUT_5.f

@@ -0,0 +1,80 @@
+        INTEGER         jdate(5), jdump(5)
+
+	CHARACTER	cmgtag*8, tabdb(1000)*128
+
+C*----------------------------------------------------------------------
+
+	print *, '----------------------------------------------------'
+	print *, 'testing BUFRLIB: writing OUT_5'
+	print *, '  using DUMPBF and GETABDB'
+	print *, '  using UFDUMP, UFBDMP and DXDUMP'
+	print *, '----------------------------------------------------'
+
+C*	Open the output log (ASCII) file.
+
+	OPEN ( UNIT = 13, FILE = 'out5.bufr' )
+
+C*      Make a "FIRST" call to subroutine OPENBF to dynamically
+C*      allocate internal arrays, in case this code is being run to
+C*      test a DA build.  Otherwise, the below call to subroutine
+C*      DUMPBF will fail when trying to call subroutine STATUS,
+C*      because subroutine OPENBF won't yet have been called.
+
+        CALL OPENBF ( 13, 'FIRST', 13 )
+
+C*	Open the input (BUFR) file.  Note that since we're about to
+C*      call subroutine DUMPBF for this file, then we don't need to
+C*      first call subroutine OPENBF for this file, because subroutine
+C*      DUMPBF will do that internally.
+
+	OPEN ( UNIT = 11, FILE = 'testfiles/OUT_5_infile' )
+
+        CALL DATELEN ( 10 )
+	print *, '        DATELEN'
+
+        WRITE ( 13, FMT = '(///,A)' ) '------------ DUMPBF ------------'
+        CALL DUMPBF ( 11, jdate, jdump )
+	print *, '        DUMPBF'
+        WRITE ( 13, FMT = '(A,5I5)' ) 'jdate =', (jdate(ii), ii=1,5)
+        WRITE ( 13, FMT = '(A,5I5)' ) 'jdump =', (jdump(ii), ii=1,5)
+
+C*      Subroutine DUMPBF will have just closed the input (BUFR) file
+C*      with an internal call to subroutine CLOSBF (which also does an
+C*      internal Fortran CLOSE on the logical unit number), so we now
+C*      need to reopen the file with a new call to subroutine OPENBF.
+
+	OPEN ( UNIT = 11, FILE = 'testfiles/OUT_5_infile' )
+        CALL OPENBF ( 11, 'IN', 11 )
+	print *, '        OPENBF'
+
+        WRITE ( 13, FMT = '(///,A)' ) '------------ GETABDB -----------'
+        CALL GETABDB ( 11, tabdb, 1000, jtab )
+	print *, '        GETABDB'
+        DO ii = 1, jtab
+          WRITE ( 13, FMT = '(A,I4,2A)' )
+     +      'tabdb entry #', ii, ":", tabdb(ii)
+        END DO
+
+        WRITE ( 13, FMT = '(///,A,/)' ) '----------- DXDUMP -----------'
+        CALL DXDUMP ( 11, 13 )
+	print *, '        DXDUMP'
+
+	print *, '        IREADNS'
+	print *, '        UFDUMP'
+	print *, '        UFBDMP'
+        nsub = 0
+        DO WHILE ( IREADNS ( 11, cmgtag, imgdt ) .eq. 0 )
+          nsub = nsub + 1
+          WRITE ( 13, FMT = '(///,A,I1,A)' )
+     +      '------------------------------ SUBSET #', nsub,
+     +      '------------------------------'
+          WRITE ( 13, FMT = '(//,A)' )
+     +      '------------ UFDUMP ------------'
+          CALL UFDUMP ( 11, 13 )
+          WRITE ( 13, FMT = '(//,A)' )
+     +      '------------ UFBDMP ------------'
+          CALL UFBDMP ( 11, 13 )
+        END DO
+
+        STOP
+        END