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> | Date | Programmer | Comments |
C> | -----|------------|----------|
C> | 2004-08-18 | J. Ator | Original author |
C> | 2007-01-19 | J. Ator | Corrected output for reference values 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