dxdump.f

Go to the documentation of this file.

C> @file
C> @brief Print the contents of a DX BUFR table.
C>
C> @author J. Ator @date 2004-08-18
 
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> @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> 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> @author J. Ator @date 2004-08-18
      RECURSIVE SUBROUTINE dxdump(LUNIT,LDXOT)
 
      USE moda_tababd
      USE moda_nmikrp
      USE modv_im8b
 
      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     CHECK FOR I8 INTEGERS.
 
      IF(im8b) THEN
         im8b=.false.
 
         CALL x84(lunit,my_lunit,1)
         CALL x84(ldxot,my_ldxot,1)
         CALL dxdump(my_lunit,my_ldxot)
 
         im8b=.true.
         RETURN
      ENDIF
 
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