wrdxtb.f

Go to the documentation of this file.

C> @file
C> @brief Write DX BUFR tables messages to a BUFR file.
C>
C> @author J. Ator @date 2009-03-23
 
C> This subroutine generates one or more BUFR messages from the DX
C> BUFR tables information associated with a given BUFR file, and
C> it then writes the messages out to the same or possibly a
C> different BUFR file.
C>
C> Logical units LUNDX and LUNOT should have already been
C> opened via previous calls to subroutine openbf(), and in
C> particular logical unit LUNOT must have been opened for
C> output operations.  LUNDX and LUNOT may be the same if it is
C> desired to append to LUNOT with DX BUFR messages generated
C> from its own internal tables.
C>
C> @param[in] LUNDX - integer: Fortran logical unit number associated with
C> DX BUFR table information to be written out.
C> @param[in] LUNOT - integer: Fortran logical unit number of BUFR file to
C> which messages are to be written.
C>
C> @author J. Ator @date 2009-03-23
 
      RECURSIVE SUBROUTINE wrdxtb(LUNDX,LUNOT)
 
      USE modv_im8b
      USE moda_tababd
      USE moda_mgwa
 
      COMMON /dxtab / maxdx,idxv,nxstr(10),ldxa(10),ldxb(10),ldxd(10),
     .                ld30(10),dxstr(10)
 
      CHARACTER*56  dxstr
      CHARACTER*6   adn30
 
      LOGICAL msgfull
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
C  CHECK FOR I8 INTEGERS
C  ---------------------
 
      IF(im8b) THEN
         im8b=.false.
 
         CALL x84(lundx,my_lundx,1)
         CALL x84(lunot,my_lunot,1)
         CALL wrdxtb(my_lundx,my_lunot)
 
         im8b=.true.
         RETURN
      ENDIF
 
C  CHECK FILE STATUSES
C  -------------------
 
      CALL status(lunot,lot,il,im)
      IF(il.EQ.0) GOTO 900
      IF(il.LT.0) GOTO 901
 
      CALL status(lundx,ldx,il,im)
      IF(il.EQ.0) GOTO 902
 
C  IF FILES ARE DIFFERENT, COPY INTERNAL TABLE
C  INFORMATION FROM LUNDX TO LUNOT
C  -------------------------------------------
 
      IF(lundx.NE.lunot) CALL cpbfdx(ldx,lot)
 
C  GENERATE AND WRITE OUT BUFR DICTIONARY MESSAGES TO LUNOT
C  --------------------------------------------------------
 
      CALL dxmini(mgwa,mbyt,mby4,mbya,mbyb,mbyd)
 
      lda = ldxa(idxv+1)
      ldb = ldxb(idxv+1)
      ldd = ldxd(idxv+1)
      l30 = ld30(idxv+1)
 
C     Table A information
 
      DO i=1,ntba(lot)
      IF(msgfull(mbyt,lda,maxdx).OR.
     +    (iupb(mgwa,mbya,8).EQ.255)) THEN
         CALL msgwrt(lunot,mgwa,mbyt)
         CALL dxmini(mgwa,mbyt,mby4,mbya,mbyb,mbyd)
      ENDIF
      mbit = 8*(mby4-1)
      CALL pkb(iupb(mgwa,mby4,24)+lda,24,mgwa,mbit)
      mbit = 8*(mbya-1)
      CALL pkb(iupb(mgwa,mbya, 8)+  1, 8,mgwa,mbit)
      mbit = 8*(mbyb-1)
      CALL pkc(taba(i,lot),lda,mgwa,mbit)
      CALL pkb(          0,  8,mgwa,mbit)
      CALL pkb(          0,  8,mgwa,mbit)
      mbyt = mbyt+lda
      mbyb = mbyb+lda
      mbyd = mbyd+lda
      ENDDO
 
C     Table B information
 
      DO i=1,ntbb(lot)
      IF(msgfull(mbyt,ldb,maxdx).OR.
     +    (iupb(mgwa,mbyb,8).EQ.255)) THEN
         CALL msgwrt(lunot,mgwa,mbyt)
         CALL dxmini(mgwa,mbyt,mby4,mbya,mbyb,mbyd)
      ENDIF
      mbit = 8*(mby4-1)
      CALL pkb(iupb(mgwa,mby4,24)+ldb,24,mgwa,mbit)
      mbit = 8*(mbyb-1)
      CALL pkb(iupb(mgwa,mbyb, 8)+  1, 8,mgwa,mbit)
      mbit = 8*(mbyd-1)
      CALL pkc(tabb(i,lot),ldb,mgwa,mbit)
      CALL pkb(          0,  8,mgwa,mbit)
      mbyt = mbyt+ldb
      mbyd = mbyd+ldb
      ENDDO
 
C     Table D information
 
      DO i=1,ntbd(lot)
      nseq = iupm(tabd(i,lot)(ldd+1:ldd+1),8)
      lend = ldd+1 + l30*nseq
      IF(msgfull(mbyt,lend,maxdx).OR.
     +    (iupb(mgwa,mbyd,8).EQ.255)) THEN
         CALL msgwrt(lunot,mgwa,mbyt)
         CALL dxmini(mgwa,mbyt,mby4,mbya,mbyb,mbyd)
      ENDIF
      mbit = 8*(mby4-1)
      CALL pkb(iupb(mgwa,mby4,24)+lend,24,mgwa,mbit)
      mbit = 8*(mbyd-1)
      CALL pkb(iupb(mgwa,mbyd, 8)+   1, 8,mgwa,mbit)
      mbit = 8*(mbyt-4)
      CALL pkc(tabd(i,lot),ldd,mgwa,mbit)
      CALL pkb(       nseq,  8,mgwa,mbit)
         DO j=1,nseq
         jj  = ldd+2 + (j-1)*2
         idn = iupm(tabd(i,lot)(jj:jj),16)
         CALL pkc(adn30(idn,l30),l30,mgwa,mbit)
         ENDDO
      mbyt = mbyt+lend
      ENDDO
 
C     Write the unwritten (leftover) message.
 
      CALL msgwrt(lunot,mgwa,mbyt)
 
C     Write out one additional (dummy) DX message containing zero
C     subsets.  This will serve as a delimiter for this set of
C     table messages within output unit LUNOT, just in case the
C     next thing written to LUNOT ends up being another set of
C     table messages.
 
      CALL dxmini(mgwa,mbyt,mby4,mbya,mbyb,mbyd)
      CALL getlens(mgwa,2,len0,len1,len2,l3,l4,l5)
      mbit = (len0+len1+len2+4)*8
      CALL pkb(0,16,mgwa,mbit)
      CALL msgwrt(lunot,mgwa,mbyt)
 
C  EXITS
C  -----
 
      RETURN
900   CALL bort('BUFRLIB: WRDXTB - OUTPUT BUFR FILE IS CLOSED, IT '//
     . 'MUST BE OPEN FOR OUTPUT')
901   CALL bort('BUFRLIB: WRDXTB - OUTPUT BUFR FILE IS OPEN FOR '//
     . 'INPUT, IT MUST BE OPEN FOR OUTPUT')
902   CALL bort('BUFRLIB: WRDXTB - DX TABLE FILE IS CLOSED, IT '//
     . 'MUST BE OPEN')
      END