ufdump.f

Go to the documentation of this file.

C> @file
C> @brief Print the contents of a data subset.
 
C> This subroutine prints a verbose listing of the contents of a data
C> subset, including all data values and replicated sequences, as well
C> as the meanings of data values which are code or flag table entries.
C>
C> <p>This subroutine is similar to subroutine ufbdmp(), but it prints
C> different characteristics of each data subset, and in a slightly
C> different format.  However, both subroutines can be useful for
C> different diagnostic purposes, and both can also be run
C> interactively to scroll through the contents of a data subset.
C>
C> @authors J. Woollen
C> @authors J. Ator
C> @date 2002-05-14
C>
C> @param[in] LUNIT   -- integer: Fortran logical unit number for
C>                       BUFR file
C> @param[in] LUPRT   -- integer: Fortran logical unit number for
C>                       print output
C>                       - 0 = Run interactively, printing to
C>                             standard output
C>
C> <p>Logical unit LUNIT should have already been opened for
C> input operations via a previous call to subroutine openbf(), and a
C> BUFR data subset should have already been read into internal arrays
C> via a previous call to one of the
C> [subset-reading subroutines](@ref hierarchy).
C>
C> <p>Except when LUPRT = 0, logical unit LUPRT must already be
C> associated with a filename on the local system, typically via a
C> Fortran "OPEN" statement.  When LUPRT = 0, the subroutine will run
C> interactively and print to standard output, scrolling 20 lines at
C> a time and prompting each time whether to quit and return to the
C> application program (by typing 'q' then '<Enter>') or continue
C> scrolling (by typing anything else).
C>
C> @remarks
C> - In order for the meanings of code and flag table values to be
C> included in the output, a previous call to subroutine codflg()
C> must have been made with argument CF = 'Y'.  Otherwise, only the
C> code and flag table values themselves will be printed.
C>
C> <b>Program history log:</b>
C> | Date | Programmer | Comments |
C> | -----|------------|----------|
C> | 2002-05-14 | J. Woollen | Original author |
C> | 2003-11-04 | J. Woollen | Modified to handle print of character values greater than 8 bytes |
C> | 2003-11-04 | S. Bender  | Added remarks and routine interdependencies |
C> | 2003-11-04 | D. Keyser  | Increased MAXJL from 15000 to 16000; unified/portable for WRF; added documentation; outputs more complete diagnostic info when routine terminates abnormally |
C> | 2004-08-18 | J. Ator    | Added fuzziness test and threshold for missing value; added interactive and scrolling capability similar to ufbdmp() |
C> | 2006-04-14 | J. Ator    | Add call to upftbv() for flag tables to get 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 where the replication count is > 1; output 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> | 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> | 2021-09-30 | J. Ator    | Replace rjust with Fortran intrinsic adjustr |
C>
      SUBROUTINE ufdump(LUNIT,LUPRT)
 
      USE moda_usrint
      USE moda_msgcwd
      USE moda_tababd
      USE moda_tables
      USE moda_nrv203
 
      COMMON /tablef/ cdmf
 
      CHARACTER*120 CFMEANG
      CHARACTER*80 FMT
      CHARACTER*64 DESC
      CHARACTER*24 UNIT
      CHARACTER*120 LCHR2
      CHARACTER*20  LCHR,PMISS
      CHARACTER*15 NEMO3
      CHARACTER*10 NEMO,NEMO2,TAGRFE
      CHARACTER*8  NEMOD
      CHARACTER*6  NUMB
      CHARACTER*7  FMTF
      CHARACTER*8  CVAL
      CHARACTER*3  TYPE
      CHARACTER*1  CDMF,TAB,YOU
      equivalence(rval,cval)
      real*8       rval
      LOGICAL      TRACK,FOUND,RDRV
 
      parameter(mxcfdp=5)
      INTEGER   ICFDP(MXCFDP)
 
      parameter(mxfv=31)
      integer   ifv(mxfv)
 
      parameter(mxseq=10)
      INTEGER   IDXREP(MXSEQ)
      INTEGER   NUMREP(MXSEQ)
      CHARACTER*10 SEQNAM(MXSEQ)
      INTEGER   LSQNAM(MXSEQ)
 
      parameter(mxls=10)
      CHARACTER*10 LSNEMO(MXLS)
      INTEGER   LSCT(MXLS)
 
      DATA pmiss /'             MISSING'/
      DATA you /'Y'/
 
C----------------------------------------------------------------------
C----------------------------------------------------------------------
 
      nseq = 0
      nls = 0
      lcfmeang = len(cfmeang)
 
      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,fmt='(/,2A,/)') 'MESSAGE TYPE ',tag(inode(lun))
 
C  DUMP THE CONTENTS OF MODULE USRINT FOR UNIT LUNIT
C  -------------------------------------------------
 
C     If code/flag table details are being printed, and if this is the
C     first subset of a new message, then make sure the appropriate
C     master tables have been read in to memory for this message.
 
      IF(cdmf.EQ.'Y' .AND. nsub(lun).EQ.1) itmp = ireadmt(lun)
 
      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').OR.(type.EQ.'DRS')) 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) = nemo2
             lsqnam(nseq) = lnm2
             idxrep(nseq) = 1
           ELSE
 
C            Don't bother
 
             nseq = nseq-1
           ENDIF
         ELSEIF( ((type.EQ.'SEQ').OR.(type.EQ.'RPC').OR.(type.EQ.'RPS'))
     .             .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(nemo2(1:lnm2).EQ.seqnam(ii)(2:lsqnam(ii)-1)) 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 ' // nemo
               unit = ' '
            ELSE
               jj = jj + 1
            ENDIF
         ENDDO
 
C        Check if this element refers to another element via a bitmap.
C        If so, modify the DESC field to identify the referred element.
 
         nrfe = nrfelm(nv,lun)
         IF(nrfe.GT.0) THEN
            tagrfe = tag(inv(nrfe,lun))
            jj = 48
            DO WHILE((jj.GE.1).AND.(desc(jj:jj).EQ.' '))
               jj = jj - 1
            ENDDO
            IF(jj.LE.33) desc(jj+1:jj+15) = ' for ' // tagrfe
         ENDIF
 
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
 
            IF( (unit(1:4).EQ.'FLAG' .OR. unit(1:4).EQ.'CODE') .AND.
     .            (cdmf.EQ.'Y') ) THEN
 
C              Print the meanings of the code and flag values.
 
               fmt = '(31X,I8,A,A)'
               IF(unit(1:4).EQ.'CODE') THEN
                  nifv = 1
                  ifv(nifv) = nint(rval)
               ENDIF
               DO ii=1,nifv
                  icfdp(1) = (-1)
          ifvd = (-1)
                  CALL srchtbf(idn,ifv(ii),icfdp,mxcfdp,ifvd,
     .                         cfmeang,lcfmeang,lcfmg,iersf)
                  IF(iersf.EQ.0) THEN
                     WRITE(luout,fmt) ifv(ii),' = ',cfmeang(1:lcfmg)
                  ELSEIF(iersf.LT.0) THEN
                     WRITE(luout,fmt) ifv(ii),' = ',
     .                   '***THIS IS AN ILLEGAL/UNDEFINED VALUE***'
                  ELSE
 
C                    The meaning of this value is dependent on the
C                    value of another mnemonic in the report.  Look for
C                    that other mnemonic within the report and then use
C                    it and its associated value to retrieve and print
C                    the proper meaning from the code/flag tables.
 
                     ierft = (-1)
                     jj = 0
                     DO WHILE((jj.LT.iersf).AND.(ierft.LT.0))
                        jj = jj + 1
                        CALL numtbd(lun,icfdp(jj),nemod,tab,ierbd)
                        IF((ierbd.GT.0).AND.(tab.EQ.'B')) THEN
                           CALL fstag(lun,nemod,-1,nv,nout,ierft)
                        ENDIF
                     ENDDO
                     IF(ierft.EQ.0) THEN
                        ifvd = nint(val(nout,lun)) 
                        IF(jj.GT.1) icfdp(1) = icfdp(jj)
                        CALL srchtbf(idn,ifv(ii),icfdp,mxcfdp,ifvd,
     .                               cfmeang,lcfmeang,lcfmg,iersf)
                        IF(iersf.EQ.0) THEN
                           WRITE(luout,fmt) ifv(ii),' = ',
     .                            cfmeang(1:lcfmg)
                        ENDIF
                     ENDIF
                  ENDIF
               ENDDO
            ENDIF
         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
            lchr = adjustr(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