ufbdmp.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 jump/link table information and other internal subset pointers.
C>
C> <p>This subroutine is similar to subroutine ufdump(), 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> @authors D. Keyser
C> @date 1994-01-06
C>
C> @param[in] LUNIN   -- integer: Absolute value is Fortran logical
C>                       unit number for BUFR file 
C>                       - If LUNIN > 0, data values are printed to
C>                         LUPRT using the format descriptor code
C>                         'G15.6', meaning that all values will be
C>                         printed (since the format adapts to the
C>                         order of magnitude of each value), but
C>                         values won't necessarily be lined up
C>                         with the decimal point in the same column
C>                       - If LUNIN < 0, data values are printed to
C>                         LUPRT using the format descriptor code
C>                         'F15.6', meaning that all values will be
C>                         lined up with the decimal point in the
C>                         same column, but values exceeding the
C>                         format width of 15 characters will print
C>                         as overflow (e.g. '***************')
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 ABS(LUNIN) 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> <b>Program history log:</b>
C> | Date | Programmer | Comments |
C> | -----|------------|----------|
C> | 1994-01-06 | J. Woollen | Original author |
C> | 1998-07-08 | J. Woollen | Replaced call to Cray library routine ABORT with call to new internal routine bort() |
C> | 1999-11-18 | J. Woollen | The number of BUFR files which can be opened at one time increased from 10 to 32 |
C> | 2002-05-14 | J. Woollen | Removed old Cray compiler directives |
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> | 2003-11-04 | D. Keyser  | Allowed fuzziness in test for missing values; added option to print using either 'G15.6' or 'F15.6'; added several jump/link table values to output |
C> | 2004-08-18 | J. Ator    | Modified fuzziness test; added readlc() option; restructured some logic for clarity |
C> | 2006-04-14 | D. Keyser  | 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> | 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> | 2021-09-30 | J. Ator    | Replace rjust with Fortran intrinsic adjustr |
C>
      SUBROUTINE ufbdmp(LUNIN,LUPRT)

      USE moda_usrint
      USE moda_msgcwd
      USE moda_tababd
      USE moda_tables

      CHARACTER*120 lchr2
      CHARACTER*20 lchr,pmiss
      CHARACTER*14 bits
      CHARACTER*10 tg,tg_rj
      CHARACTER*8  vc
      CHARACTER*7  fmtf
      CHARACTER*3  tp
      CHARACTER*1  tab,you
      equivalence(vl,vc)
      REAL*8       vl

      parameter(mxfv=31)
      integer   ifv(mxfv)

      DATA pmiss /'             MISSING'/
      DATA you /'Y'/

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

      IF(luprt.EQ.0) THEN
         luout = 6
      ELSE
         luout = luprt
      ENDIF

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

      lunit = abs(lunin)
      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

C  DUMP THE CONTENTS OF MODULE USRINT FOR UNIT ABS(LUNIN)
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
      nd = inv(nv,lun)
      vl = val(nv,lun)
      tg = tag(nd)
      tp = typ(nd)
      it = itp(nd)
      ib = ibt(nd)
      is = isc(nd)
      ir = irf(nd)
      jp = jump(nd)
      lk = link(nd)
      jb = jmpb(nd)
      tg_rj = adjustr(tg)
      IF(tp.NE.'CHR') THEN
         bits = '              '
         IF(it.EQ.2) THEN
            CALL nemtab(lun,tg,idn,tab,n)
            IF(tabb(n,lun)(71:75).EQ.'FLAG') THEN

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

               CALL upftbv(lunit,tg,vl,mxfv,ifv,nifv)
               IF(nifv.GT.0) THEN
                  bits(1:1) = '('
                  ipt = 2
                  DO ii=1,nifv
                    isz = isize(ifv(ii))
                    WRITE(fmtf,'(A2,I1,A4)') '(I', isz, ',A1)'
                    IF((ipt+isz).LE.14) THEN
                       WRITE(bits(ipt:ipt+isz),fmtf) ifv(ii), ','
                       ipt = ipt + isz + 1
                    ELSE
                       bits(2:13) = 'MANY BITS ON'
                       ipt = 15
                    ENDIF
                  ENDDO
                  bits(ipt-1:ipt-1) = ')'
               ENDIF
            ENDIF
         ENDIF
         IF(ibfms(vl).NE.0) THEN
            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,
     .          jb
            ELSE
               WRITE(luout,10) nv,tp,it,tg_rj,vl,bits,ib,is,ir,nd,jp,lk,
     .          jb
            ENDIF
         ENDIF
      ELSE
         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
            lchr = adjustr(lchr)
            WRITE(luout,2) nv,tp,it,tg_rj,lchr,ib,is,ir,nd,jp,lk,jb
         ELSE
            WRITE(luout,4) nv,tp,it,tg_rj,lchr2(1:nchr),ib,is,ir,nd,jp,
     .       lk,jb
         ENDIF
      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,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  -----

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