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