wrdxtb.f

Go to the documentation of this file.

C> @file
C> @author J @date 2009-03-23
      
C> THIS SUBROUTINE WRITES BUFR TABLE (DICTIONARY) MESSAGES
C>   ASSOCIATED WITH THE BUFR FILE IN LUNDX TO THE BUFR FILE IN LUNOT.
C>   BOTH UNITS MUST BE OPENED VIA PREVIOUS CALLS TO BUFR ARCHIVE
C>   LIBRARY SUBROUTINE OPENBF, AND IN PARTICULAR LUNOT MUST HAVE
C>   BEEN OPENED FOR OUTPUT.  THE TABLE MESSAGES ARE GENERATED FROM
C>   ARRAYS IN INTERNAL MEMORY (MODULE TABABD).  LUNDX CAN BE THE
C>   SAME AS LUNOT IF IT IS DESIRED TO APPEND TO LUNOT WITH BUFR
C>   MESSAGES GENERATED FROM ITS OWN INTERNAL TABLES.
C>
C> PROGRAM HISTORY LOG:
C> 2009-03-23  J. ATOR    -- ORIGINAL AUTHOR, USING LOGIC FROM WRITDX
C> 2012-04-06  J. ATOR    -- PREVENT STORING OF MORE THAN 255 TABLE A,
C>                           TABLE B OR TABLE D DESCRIPTORS IN ANY
C>                           SINGLE DX MESSAGE
C> 2014-11-14  J. ATOR    -- REPLACE IPKM CALLS WITH PKB CALLS
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
C>
C> USAGE:    CALL WRDXTB (LUNDX,LUNOT)
C>   INPUT ARGUMENT LIST:
C>     LUNDX    - INTEGER: FORTRAN LOGICAL UNIT NUMBER ASSOCIATED
C>                WITH DX (DICTIONARY) TABLES TO BE WRITTEN OUT;
C>                CAN BE SAME AS LUNOT
C>     LUNOT    - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
C>                TO BE APPENDED WITH TABLES ASSOCIATED WITH LUNDX
C>
C> REMARKS:
C>    THIS ROUTINE CALLS:        ADN30    BORT     CPBFDX   DXMINI
C>                               GETLENS  IUPB     IUPM     MSGFULL
C>                               MSGWRT   PKB      PKC      STATUS
C>    THIS ROUTINE IS CALLED BY: MAKESTAB WRITDX
C>                               Also called by application programs.
C>
      SUBROUTINE wrdxtb(LUNDX,LUNOT)
 
      USE moda_tababd
      USE moda_mgwa
 
      COMMON /dxtab / maxdx,idxv,nxstr(10),ldxa(10),ldxb(10),ldxd(10),
     .                ld30(10),dxstr(10)
 
      CHARACTER*128 BORT_STR
      CHARACTER*56  DXSTR
      CHARACTER*6   ADN30
 
      LOGICAL MSGFULL
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
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(lot,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(lot,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(lot,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(lot,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(lot,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