ufbdmp.f

Go to the documentation of this file.

C> @file
C> @brief Print the contents of a data subset.
C>
C> @authors J. Woollen, J. Ator, D. Keyser @date 1994-01-06
 
C> Print the contents of a data subset.
C>
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> 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> 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> 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> @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 standard output
C>
C> @authors J. Woollen, J. Ator, D. Keyser @date 1994-01-06
      RECURSIVE SUBROUTINE ufbdmp(LUNIN,LUPRT)
 
      USE modv_im8b
 
      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----------------------------------------------------------------------
 
C  CHECK FOR I8 INTEGERS
C  ---------------------
 
      IF(im8b) THEN
         im8b=.false.
 
         CALL x84(lunin,my_lunin,1)
         CALL x84(luprt,my_luprt,1)
         CALL ufbdmp(my_lunin,my_luprt)
 
         im8b=.true.
         RETURN
      ENDIF
 
      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