dxdump.f

Go to the documentation of this file.

C> @file
C> @brief Print the contents of a DX BUFR table.

C> This subroutine prints a copy of the DX BUFR table associated
C> with a specified Fortran logical unit.
C>
C> This subroutine is especially useful for learning the structure
C> of existing BUFR files which contain DX BUFR table information
C> embedded as BUFR messages within those files.
C> The DX BUFR table is printed using the same ASCII format 
C> described in the documentation for
C> [DX BUFR Tables](@ref dfbftab), so the output file is suitable
C> for use as Fortran logical unit LUNDX in subsequent calls to
C> subroutine openbf() for reading or writing additional BUFR
C> files with the same structure.
C>
C> @author J. Ator
C> @date 2004-08-18
C>
C> @param[in] LUNIT    - integer: Fortran logical unit number for
C>                       BUFR file
C> @param[in] LDXOT    - integer: Fortran logical unit number for
C>                       print output
C>
C> <p>Logical unit LUNIT must be open for either input or output
C> operations via a previous call to subroutine openbf().
C> Logical unit LDXOT must already be associated with a filename
C> on the local system, typically via a Fortran "OPEN" statement.
C>
C> @remarks
C> - This subroutine only prints the DX BUFR table that is currently
C> in scope for logical unit LUNIT.  Therefore, if logical unit LUNIT
C> contains multiple embedded DX BUFR tables, then multiple calls to 
C> this subroutine must be made to print out all of the tables,
C> once while each table is in scope for a data subset defined
C> within that particular table.
C>
C> <b>Program history log:</b>
C> - 2004-08-18  J. Ator    -- Original author
C> - 2007-01-19  J. Ator    -- Corrected output for reference values
C>                             longer than 8 digits
C> - 2014-12-10  J. Ator    -- Use modules instead of COMMON blocks
C>
      SUBROUTINE dxdump(LUNIT,LDXOT)

      USE moda_tababd
      USE moda_nmikrp

      COMMON /reptab/ idnr(5,2),typs(5,2),reps(5,2),lens(5)

      CHARACTER*80  card,cardi1,cardi2,cardi3,cardi4
      CHARACTER*20  cmstr
      CHARACTER*10  wrk3
      CHARACTER*8   wrk1,wrk2
      CHARACTER*6   adn
      CHARACTER*3   typs
      CHARACTER*1   reps

      LOGICAL       tbskip, tdskip, xtrci1

      DATA          cardi1( 1:40)
     .              /'|          |        |                   '/
      DATA          cardi1(41:80)
     .              /'                                       |'/
      DATA          cardi2( 1:40)
     .              /'|          |                            '/
      DATA          cardi2(41:80)
     .              /'                                       |'/
      DATA          cardi3( 1:40)
     .              /'|          |      |             |     | '/
      DATA          cardi3(41:80)
     .              /'                         |-------------|'/
      DATA          cardi4( 1:40)
     .              /'|---------------------------------------'/
      DATA          cardi4(41:80)
     .              /'---------------------------------------|'/

C-----------------------------------------------------------------------
      tbskip(adn) = ((adn.EQ.'063000').OR.(adn.EQ.'063255').OR.
     .               (adn.EQ.'031000').OR.(adn.EQ.'031001').OR.
     .               (adn.EQ.'031002'))
      tdskip(adn) = ((adn.EQ.'360001').OR.(adn.EQ.'360002').OR.
     .               (adn.EQ.'360003').OR.(adn.EQ.'360004'))
C-----------------------------------------------------------------------

C     DETERMINE LUN FROM LUNIT.

      CALL status(lunit,lun,il,im)
      IF(il.EQ.0) goto 900

C     CREATE AND WRITE OUT (TO LDXOT) THE HEADER CARDS FOR THE
C     DESCRIPTOR DEFINITION SECTION.

      card=cardi4
      card( 1: 1)='.'
      card(80:80)='.'
      WRITE (ldxot,'(A)') card

      card=cardi4
      card( 2: 2)=' '
      card(79:79)=' '
      card(15:64)='   USER DEFINITIONS FOR TABLE-A TABLE-B TABLE D   '
      WRITE (ldxot,'(A)') card

      WRITE (ldxot,'(A)') cardi4

      card=cardi1
      card( 3:10)='MNEMONIC' 
      card(14:19)='NUMBER' 
      card(23:33)='DESCRIPTION'
      WRITE (ldxot,'(A)') card

      card=cardi4
      card(12:12)='|'
      card(21:21)='|'
      WRITE (ldxot,'(A)') card

C     CREATE AND WRITE OUT (TO LDXOT) THE TABLE D DESCRIPTOR
C     DEFINITION CARDS.

      WRITE (ldxot,'(A)') cardi1

      xtrci1=.false.
      DO n=1,ntbd(lun)
        IF(.NOT.tdskip(tabd(n,lun)(1:6))) THEN
          card=cardi1
          card( 3:10)=tabd(n,lun)( 7:14) 
          card(14:19)=tabd(n,lun)( 1: 6) 
          card(23:77)=tabd(n,lun)(16:70)

C         CHECK IF THIS TABLE D MNEMONIC IS ALSO A TABLE A MNEMONIC.
C         IF SO, THEN LABEL IT AS SUCH AND ALSO CHECK IF IT IS THE
C         LAST OF THE TABLE A MNEMONICS, IN WHICH CASE AN EXTRA
C         CARDI1 LINE WILL BE WRITTEN TO LDXOT IN ORDER TO SEPARATE
C         THE TABLE A MNEMONICS FROM THE OTHER TABLE D MNEMONICS.

          DO na=1,ntba(lun)
            IF(taba(na,lun)(4:11).EQ.tabd(n,lun)(7:14)) THEN
              card(14:14)='A'
              IF(na.EQ.ntba(lun)) xtrci1=.true.
              goto 10
            END IF
          END DO
   10     WRITE (ldxot,'(A)') card
          IF(xtrci1) THEN
            WRITE (ldxot,'(A)') cardi1
            xtrci1=.false.
          END IF
        END IF
      END DO

C     CREATE AND WRITE OUT (TO LDXOT) THE TABLE B DESCRIPTOR
C     DEFINITION CARDS.

      WRITE (ldxot,'(A)') cardi1

      DO n=1,ntbb(lun)
        IF(.NOT.tbskip(tabb(n,lun)(1:6))) THEN
          card=cardi1
          card( 3:10)=tabb(n,lun)( 7:14) 
          card(14:19)=tabb(n,lun)( 1: 6) 
          card(23:77)=tabb(n,lun)(16:70)
          WRITE (ldxot,'(A)') card
        END IF
      END DO

      WRITE (ldxot,'(A)') cardi1

C     CREATE AND WRITE OUT (TO LDXOT) THE HEADER CARDS FOR THE
C     SEQUENCE DEFINITION SECTION.

      WRITE (ldxot,'(A)') cardi4

      card=cardi2
      card( 3:10)='MNEMONIC' 
      card(14:21)='SEQUENCE' 
      WRITE (ldxot,'(A)') card

      card=cardi4
      card(12:12)='|'
      WRITE (ldxot,'(A)') card

C     CREATE AND WRITE OUT (TO LDXOT) THE TABLE D SEQUENCE
C     DEFINITION CARDS.

      WRITE (ldxot,'(A)') cardi2

      DO n=1,ntbd(lun)
        IF(.NOT.tdskip(tabd(n,lun)(1:6))) THEN
          card=cardi2
          card( 3:10)=tabd(n,lun)( 7:14) 
          ic = 14

C         GET THE LIST OF CHILD MNEMONICS FOR THIS TABLE D DESCRIPTOR,
C         AND THEN ADD EACH ONE (INCLUDING ANY REPLICATION TAGS) TO
C         THE SEQUENCE DEFINITION CARD FOR THIS TABLE D DESCRIPTOR.
 
          CALL nemtbd(lun,n,nseq,nem(1,1),irp(1,1),krp(1,1))
          IF(nseq.GT.0) THEN
            DO nc=1,nseq
              cmstr=' '
              icms=0
              CALL strsuc(nem(nc,1),wrk2,nch)
              IF(irp(nc,1).NE.0) THEN

C               ADD THE OPENING REPLICATION TAG.

                icms=icms+1
                cmstr(icms:icms)=reps(irp(nc,1),1)
              END IF
              cmstr(icms+1:icms+nch)=wrk2(1:nch)
              icms=icms+nch
              IF(irp(nc,1).NE.0) THEN

C               ADD THE CLOSING REPLICATION TAG.

                icms=icms+1
                cmstr(icms:icms)=reps(irp(nc,1),2)
              END IF
              IF(krp(nc,1).NE.0) THEN

C               ADD THE FIXED REPLICATION COUNT.

                wrk1=' '
                WRITE (wrk1,'(I3)') krp(nc,1)
                CALL strsuc(wrk1,wrk2,nch)
                cmstr(icms+1:icms+nch)=wrk2(1:nch)
                icms=icms+nch
              END IF

C             WILL THIS CHILD (AND ITS REPLICATION TAGS, IF ANY) FIT
C             INTO THE CURRENT SEQUENCE DEFINITION CARD?  IF NOT, THEN
C             WRITE OUT (TO LDXOT) THE CURRENT CARD AND INITIALIZE A
C             NEW ONE TO HOLD THIS CHILD.

              IF(ic.GT.(79-icms)) THEN
                WRITE (ldxot,'(A)') card
                card=cardi2
                card( 3:10)=tabd(n,lun)( 7:14) 
                ic = 14
              END IF
              card(ic:ic+icms-1)=cmstr(1:icms)

C             NOTE THAT WE WANT TO LEAVE 2 BLANK SPACES BETWEEN EACH
C             CHILD WITHIN THE SEQUENCE DEFINITION CARD (TO IMPROVE
C             READABILITY).

              ic=ic+icms+2
            END DO
            WRITE (ldxot,'(A)') card
            WRITE (ldxot,'(A)') cardi2
          END IF
        END IF
      END DO

C     CREATE AND WRITE OUT (TO LDXOT) THE HEADER CARDS FOR THE
C     ELEMENT DEFINITION SECTION.

      WRITE (ldxot,'(A)') cardi4

      card=cardi3
      card( 3:10)='MNEMONIC' 
      card(14:17)='SCAL' 
      card(21:29)='REFERENCE' 
      card(35:37)='BIT' 
      card(41:45)='UNITS' 
      WRITE (ldxot,'(A)') card

      card=cardi4
      card(12:12)='|'
      card(19:19)='|'
      card(33:33)='|'
      card(39:39)='|'
      card(66:66)='|'
      WRITE (ldxot,'(A)') card

C     CREATE AND WRITE OUT (TO LDXOT) THE TABLE B ELEMENT
C     DEFINITION CARDS.

      WRITE (ldxot,'(A)') cardi3

      DO n=1,ntbb(lun)
        IF(.NOT.tbskip(tabb(n,lun)(1:6))) THEN
          card=cardi3
          card( 3:10)=tabb(n,lun)( 7:14) 
          card(41:64)=tabb(n,lun)(71:94) 

C         ADD THE SCALE FACTOR.

          CALL strsuc(tabb(n,lun)(96:98),wrk2,nch)
          card(17-nch+1:17)=wrk2 
          IF(tabb(n,lun)(95:95).EQ.'-') card(17-nch:17-nch)='-'

C         ADD THE REFERENCE VALUE.

          CALL strsuc(tabb(n,lun)(100:109),wrk3,nch)
          card(31-nch+1:31)=wrk3 
          IF(tabb(n,lun)(99:99).EQ.'-') card(31-nch:31-nch)='-'

C         ADD THE BIT WIDTH.

          CALL strsuc(tabb(n,lun)(110:112),wrk2,nch)
          card(37-nch+1:37)=wrk2 
          WRITE (ldxot,'(A)') card
        END IF
      END DO

      WRITE (ldxot,'(A)') cardi3

C     CREATE AND WRITE OUT (TO LDXOT) THE CLOSING CARD.

      card=cardi4
      card( 1: 1)='`'
      card(80:80)=''''
      WRITE (ldxot,'(A)') card

      RETURN
900   CALL bort('BUFRLIB: DXDUMP - BUFR FILE IS CLOSED, IT MUST BE'//
     . ' OPEN')

      END