      SUBROUTINE UFDUMP(LUNIT,LUPRT)

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    UFDUMP
C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 2002-05-14
C
C ABSTRACT: 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.
C   LUNIT MUST HAVE BEEN OPENED FOR INPUT VIA A PREVIOUS CALL TO BUFR
C   ARCHIVE LIBRARY SUBROUTINE OPENBF.  THE DATA SUBSET MUST HAVE BEEN
C   SUBSEQUENTLY READ INTO THE INTERNAL BUFR ARCHIVE LIBRARY ARRAYS VIA
C   A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE READMG OR READERME,
C   FOLLOWED BY A CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE READSB (OR VIA
C   A SINGLE CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE READNS!).  FOR A
C   PARTICULAR SUBSET, THE PRINT LISTING CONTAINS EACH MNEMONIC
C   ACCOMPANIED BY ITS CORRESPONDING DATA VALUE (INCLUDING THE ACTUAL
C   BITS THAT WERE SET FOR FLAG TABLE VALUES!) AS WELL AS OTHER USEFUL
C   IDENTIFICATION INFORMATION.  THIS SUBROUTINE IS SIMILAR TO BUFR
C   ARCHIVE LIBRARY SUBROUTINE UFBDMP EXCEPT THAT IT DOES NOT PRINT
C   POINTERS, COUNTERS AND OTHER MORE ESOTERIC INFORMATION DESCRIBING
C   THE INTERNAL SUBSET STRUCTURES.  EACH SUBROUTINE, UFBDMP AND UFDUMP,
C   IS USEFUL FOR DIFFERENT DIAGNOSTIC PURPOSES, BUT IN GENERAL UFDUMP
C   IS MORE USEFUL FOR JUST LOOKING AT THE DATA ELEMENTS.
C
C PROGRAM HISTORY LOG:
C 2002-05-14  J. WOOLLEN -- ORIGINAL AUTHOR
C 2003-11-04  J. WOOLLEN -- MODIFIED TO HANDLE PRINT OF CHARACTER
C                           VALUES GREATER THAN EIGHT BYTES
C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C                           INTERDEPENDENCIES
C 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
C                           INCREASED FROM 15000 TO 16000 (WAS IN
C                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
C                           WRF; ADDED DOCUMENTATION (INCLUDING
C                           HISTORY); OUTPUTS MORE COMPLETE DIAGNOSTIC
C                           INFO WHEN ROUTINE TERMINATES ABNORMALLY
C 2004-08-18  J. ATOR    -- ADDED FUZZINESS TEST AND THRESHOLD FOR
C                           MISSING VALUE; ADDED INTERACTIVE AND
C                           SCROLLING CAPABILITY SIMILAR TO UFBDMP
C 2006-04-14  J. ATOR    -- ADD CALL TO UPFTBV FOR FLAG TABLES TO GET
C                           ACTUAL BITS THAT WERE SET TO GENERATE VALUE
C 2007-01-19  J. ATOR    -- USE FUNCTION IBFMS
C 2009-03-23  J. ATOR    -- ADD LEVEL MARKERS TO OUTPUT FOR SEQUENCES
C                           WHERE THE REPLICATION COUNT IS > 1; OUTPUT
C                           ALL OCCURRENCES OF LONG CHARACTER STRINGS
C 2012-02-24  J. ATOR    -- FIX MISSING CHECK FOR LONG CHARACTER STRINGS
C 2012-03-02  J. ATOR    -- LABEL REDEFINED REFERENCE VALUES
C
C USAGE:    CALL UFDUMP (LUNIT, LUPRT)
C   INPUT ARGUMENT LIST:
C     LUNIT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
C     LUPRT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR PRINT OUTPUT
C                FILE
C                       0 = LUPRT is set to 06
C
C   OUTPUT FILES:
C     IF LUPRT > 0: UNIT "LUPRT" - PRINT (IF LUPRT=6, STANDARD OUTPUT)
C     IF LUPRT = 0: UNIT 06      - STANDARD OUTPUT PRINT
C
C REMARKS:
C    THIS ROUTINE WILL SCROLL THROUGH THE DATA SUBSET, TWENTY ELEMENTS
C    AT A TIME WHEN LUPRT IS INPUT AS "0".  IN THIS CASE, THE EXECUTING
C    SHELL SCRIPT SHOULD USE THE TERMINAL AS BOTH STANDARD INPUT AND
C    STANDARD OUTPUT.  INITIALLY, THE FIRST TWENTY ELEMENTS OF THE
C    CURRENT UNPACKED SUBSET WILL BE DISPLAYED ON THE TERMIMAL,
C    FOLLOWED BY THE PROMPT "(<enter> for MORE, q <enter> to QUIT)".
C    IF THE TERMINAL ENTERS ANYTHING OTHER THAN "q" FOLLOWED BY
C    "<enter>" (e.g., "<enter>"), THE NEXT TWENTY ELEMENTS WILL BE
C    DISPLAYED, AGAIN FOLLOWED BY THE SAME PROMPT.  THIS CONTINUES
C    UNTIL EITHER THE ENTIRE SUBSET HAS BEEN DISPLAYED, OR THE TERMINAL
C    ENTERS "q" FOLLOWED BY "<enter>" AFTER THE PROMPT, IN WHICH CASE
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     ICBFMS   IBFMS    ISIZE
C                               NEMTAB   READLC   RJUST    STATUS
C                               STRSUC   UPFTBV
C    THIS ROUTINE IS CALLED BY: None
C                               Normally called only by application
C                               programs.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  PORTABLE TO ALL PLATFORMS
C
C$$$

      INCLUDE 'bufrlib.prm'

      COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
     .                INODE(NFILES),IDATE(NFILES)
      COMMON /TABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
     .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
     .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
     .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
     .                ISEQ(MAXJL,2),JSEQ(MAXJL)
      COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
      COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES),
     .                MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2),
     .                IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES),
     .                TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES),
     .                TABD(MAXTBD,NFILES)
      COMMON /NRV203/ NNRV,INODNRV(MXNRV),NRV(MXNRV),TAGNRV(MXNRV),
     .                ISNRV(MXNRV),IENRV(MXNRV),IBTNRV,IPFNRV


      CHARACTER*600 TABD
      CHARACTER*128 TABB
      CHARACTER*128 TABA

      CHARACTER*80 FMT
      CHARACTER*64 DESC
      CHARACTER*24 UNIT
      CHARACTER*120 LCHR2
      CHARACTER*20  LCHR,PMISS
      CHARACTER*15 NEMO3
      CHARACTER*10 TAG,NEMO,NEMO2
      CHARACTER*6  NUMB
      CHARACTER*7  FMTF
      CHARACTER*8  CVAL,TAGNRV
      CHARACTER*3  TYP,TYPE
      CHARACTER*1  TAB,YOU
      EQUIVALENCE  (RVAL,CVAL)
      REAL*8       VAL,RVAL
      LOGICAL      TRACK,FOUND,RDRV

      PARAMETER (MXFV=31)
      INTEGER	IFV(MXFV)

      PARAMETER (MXSEQ=10)
      INTEGER   IDXREP(MXSEQ)
      INTEGER   NUMREP(MXSEQ)
      CHARACTER*10 SEQNAM(MXSEQ)

      PARAMETER (MXLS=10)
      CHARACTER*10 LSNEMO(MXLS)
      INTEGER   LSCT(MXLS)

      DATA PMISS /'             MISSING'/
      DATA YOU /'Y'/

C----------------------------------------------------------------------
C----------------------------------------------------------------------

      NSEQ = 0
      NLS = 0

      IF(LUPRT.EQ.0) THEN
         LUOUT = 6
      ELSE
         LUOUT = LUPRT
      ENDIF

C  CHECK THE FILE STATUS AND I-NODE
C  --------------------------------

      CALL STATUS(LUNIT,LUN,IL,IM)
      IF(IL.EQ.0) GOTO 900
      IF(IL.GT.0) GOTO 901
      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,*)

C  DUMP THE CONTENTS OF COMMON /USRINT/ FOR UNIT LUNIT
C  ---------------------------------------------------

      DO NV=1,NVAL(LUN)
      IF(LUPRT.EQ.0 .AND. MOD(NV,20).EQ.0) THEN

C  When LUPRT=0, the output will be scrolled, 20 elements at a time
C  ----------------------------------------------------------------

         PRINT*,'(<enter> for MORE, q <enter> to QUIT)'
         READ(5,'(A1)') YOU

C  If the terminal enters "q" followed by "<enter>" after the prompt
C  "(<enter> for MORE, q <enter> to QUIT)", scrolling will end and the
C  subroutine will return to the calling program
C  -------------------------------------------------------------------

         IF(YOU.EQ.'q') THEN
         PRINT*
         PRINT*,'==> You have chosen to stop the dumping of this subset'
         PRINT*
            GOTO 100
         ENDIF
      ENDIF

      NODE = INV (NV,LUN)
      NEMO = TAG (NODE)
      ITYP = ITP (NODE)
      TYPE = TYP (NODE)

      IF(ITYP.GE.1.AND.ITYP.LE.3) THEN
         CALL NEMTAB(LUN,NEMO,IDN,TAB,N)
         NUMB = TABB(N,LUN)(1:6)
         DESC = TABB(N,LUN)(16:70)
         UNIT = TABB(N,LUN)(71:94)
         RVAL = VAL(NV,LUN)
      ENDIF
      
      IF((ITYP.EQ.0).OR.(ITYP.EQ.1)) THEN

C        Sequence descriptor or delayed descriptor replication factor

         IF((TYPE.EQ.'REP').OR.(TYPE.EQ.'DRP').OR.(TYPE.EQ.'DRB')) THEN

C	   Print the number of replications

           NSEQ = NSEQ+1
           IF(NSEQ.GT.MXSEQ) GOTO 904
           IF(TYPE.EQ.'REP') THEN
             NUMREP(NSEQ) = IRF(NODE)
           ELSE
             NUMREP(NSEQ) = NINT(RVAL)
           ENDIF
           CALL STRSUC(NEMO,NEMO2,LNM2)
           FMT = '(11X,A,I6,1X,A)'
           WRITE(LUOUT,FMT) NEMO2(1:LNM2), NUMREP(NSEQ), 'REPLICATIONS'

C          How many times is this sequence replicated?

           IF(NUMREP(NSEQ).GT.1) THEN

C            Track the sequence

             SEQNAM(NSEQ) = NEMO
             IDXREP(NSEQ) = 1
           ELSE

C            Don't bother

             NSEQ = NSEQ-1
           ENDIF
         ELSEIF( ((TYPE.EQ.'SEQ').OR.(TYPE.EQ.'RPC'))
     .             .AND. (NSEQ.GT.0) ) THEN

C          Is this one of the sequences being tracked?

           II = NSEQ
           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
               TRACK = .TRUE.

C              Mark this level in the output

               FMT = '(4X,A,2X,A,2X,A,I6,2X,A)'
               WRITE(LUOUT,FMT) '++++++', NEMO2(1:LNM2),
     .                 'REPLICATION #', IDXREP(II), '++++++'
               IF(IDXREP(II).LT.NUMREP(II)) THEN

C                There are more levels to come

                 IDXREP(II) = IDXREP(II)+1
               ELSE

C                This was the last level for this sequence, so stop
C                tracking it

                 NSEQ = NSEQ-1
               ENDIF
             ELSE
               II = II-1
             ENDIF
           ENDDO
         ENDIF
      ELSEIF(ITYP.EQ.2) THEN

C        Other numeric value

C        First check if this node contains a redefined reference
C        value.  If so, modify the DESC field to label it as such.

         JJ = 1
         RDRV = .FALSE.
         DO WHILE ((JJ.LE.NNRV).AND.(.NOT.RDRV))
            IF (NODE.EQ.INODNRV(JJ)) THEN
               RDRV = .TRUE.
               DESC = 'NEW REFERENCE VALUE FOR ' // NUMB
               UNIT = ' '
            ELSE
               JJ = JJ+1
            ENDIF
         ENDDO

C        Now print the value

         IF(IBFMS(RVAL).NE.0) THEN

C           The value is "missing".

            FMT = '(A6,2X,A10,2X,A20,2X,A24,6X,A48)'
            WRITE(LUOUT,FMT) NUMB,NEMO,PMISS,UNIT,DESC
         ELSE
            FMT = '(A6,2X,A10,2X,F20.00,2X,A24,6X,A48)'

C           Based upon the corresponding scale factor, select an
C           appropriate format for the printing of this value. 

            WRITE(FMT(19:20),'(I2)') MAX(1,ISC(NODE))
            IF(UNIT(1:4).EQ.'FLAG') THEN

C              Print a listing of the bits corresponding to
C              this value.

               CALL UPFTBV(LUNIT,NEMO,RVAL,MXFV,IFV,NIFV)
               IF(NIFV.GT.0) THEN
                  UNIT(11:11) = '('
                  IPT = 12
                  DO II=1,NIFV
                    ISZ = ISIZE(IFV(II))
                    WRITE(FMTF,'(A2,I1,A4)') '(I', ISZ, ',A1)'
                    IF((IPT+ISZ).LE.24) THEN
                       WRITE(UNIT(IPT:IPT+ISZ),FMTF) IFV(II), ','
                       IPT = IPT + ISZ + 1
                    ELSE
                       UNIT(12:23) = 'MANY BITS ON'
                       IPT = 25
                    ENDIF
                  ENDDO
                  UNIT(IPT-1:IPT-1) = ')'
               ENDIF
            ENDIF         
            WRITE(LUOUT,FMT) NUMB,NEMO,RVAL,UNIT,DESC
         ENDIF
      ELSEIF(ITYP.EQ.3) THEN

C        Character (CCITT IA5) value

         NCHR = IBT(NODE)/8

         IF(IBFMS(RVAL).NE.0) THEN
            LCHR = PMISS
         ELSE IF(NCHR.LE.8) THEN
            LCHR = CVAL
         ELSE

C           Track the number of occurrences of this long character string, so
C           that we can properly output each one.

            II = 1
            FOUND = .FALSE.
            DO WHILE((II.LE.NLS).AND.(.NOT.FOUND))
               IF(NEMO.EQ.LSNEMO(II)) THEN
                 FOUND = .TRUE.
               ELSE
                 II = II + 1
               ENDIF
            ENDDO

            IF(.NOT.FOUND) THEN
               NLS = NLS+1
               IF(NLS.GT.MXLS) GOTO 905
               LSNEMO(NLS) = NEMO
               LSCT(NLS) = 1
               NEMO3 = NEMO
            ELSE
               CALL STRSUC(NEMO,NEMO3,LNM3)
               LSCT(II) = LSCT(II) + 1
               WRITE(FMTF,'(A,I1,A)') '(2A,I', ISIZE(LSCT(II)), ')'
               WRITE(NEMO3,FMTF) NEMO(1:LNM3), '#', LSCT(II)
            ENDIF

            CALL READLC(LUNIT,LCHR2,NEMO3)
            IF (ICBFMS(LCHR2,NCHR).NE.0) THEN
               LCHR = PMISS
            ELSE
               LCHR = LCHR2(1:20)
            ENDIF
         ENDIF

         IF ( NCHR.LE.20 .OR. LCHR.EQ.PMISS ) THEN
            IRET = RJUST(LCHR)
            FMT = '(A6,2X,A10,2X,A20,2X,"(",I2,")",A24,2X,A48)'
            WRITE(LUOUT,FMT) NUMB,NEMO,LCHR,NCHR,UNIT,DESC
         ELSE
            FMT = '(A6,2X,A10,2X,A,2X,"(",I3,")",A23,2X,A48)'
            WRITE(LUOUT,FMT) NUMB,NEMO,LCHR2(1:NCHR),NCHR,UNIT,DESC
         ENDIF
      ENDIF

      ENDDO

      WRITE(LUOUT,3)
3     FORMAT(/' >>> END OF SUBSET <<< '/)

C  EXITS
C  -----

100   RETURN
900   CALL BORT('BUFRLIB: UFDUMP - INPUT BUFR FILE IS CLOSED, IT '//
     . 'MUST BE OPEN FOR INPUT')
901   CALL BORT('BUFRLIB: UFDUMP - INPUT BUFR FILE IS OPEN FOR '//
     . 'OUTPUT, IT MUST BE OPEN FOR INPUT')
902   CALL BORT('BUFRLIB: UFDUMP - A MESSAGE MUST BE OPEN IN INPUT '//
     . 'BUFR FILE, NONE ARE')
903   CALL BORT('BUFRLIB: UFDUMP - LOCATION OF INTERNAL TABLE FOR '//
     . 'INPUT BUFR FILE DOES NOT AGREE WITH EXPECTED LOCATION IN '//
     . 'INTERNAL SUBSET ARRAY')
904   CALL BORT('BUFRLIB: UFDUMP - MXSEQ OVERFLOW')
905   CALL BORT('BUFRLIB: UFDUMP - MXLS OVERFLOW')
      END
