<HTML> <BODY BGCOLOR=#ccccdd LINK=#0000aa VLINK=#0000ff ALINK=#ff0000 ><BASE TARGET="bottom_target"><PRE>
<A NAME='WRDXTB'><A href='../../html_code/bufr/wrdxtb.f.html#WRDXTB' TARGET='top_target'><IMG SRC="../../gif/bar_red.gif" border=0></A>
SUBROUTINE WRDXTB(LUNDX,LUNOT) 3,35
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: WRDXTB
C PRGMMR: J. ATOR ORG: NP12 DATE: 2009-03-23
C
C ABSTRACT: 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 (COMMON BLOCK /TABABD/). LUNDX CAN BE
C THE 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
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 IPKM IUPM MSGFULL
C MSGWRT PKB PKC STATUS
C THIS ROUTINE IS CALLED BY: MAKESTAB WRITDX
C Also called by application programs.
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: PORTABLE TO ALL PLATFORMS
C
C$$$
INCLUDE 'bufrlib.prm'
COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES),
. MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2),
. IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES),
. TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES),
. TABD(MAXTBD,NFILES)
COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10),
. LD30(10),DXSTR(10)
CHARACTER*600 TABD
CHARACTER*128 BORT_STR
CHARACTER*128 TABB
CHARACTER*128 TABA
CHARACTER*56 DXSTR
CHARACTER*6 ADN30
CHARACTER*1 MOCT(MXMSGL)
LOGICAL MSGFULL
DIMENSION MBAY(MXMSGLD4)
EQUIVALENCE (MOCT(1),MBAY(1))
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,MBAY,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.
+ (IUPM(MOCT(MBYA),8).EQ.255)) THEN
CALL MSGWRT(LUNOT,MBAY,MBYT)
CALL DXMINI(LOT,MBAY,MBYT,MBY4,MBYA,MBYB,MBYD)
ENDIF
CALL IPKM(MOCT(MBY4),3,IUPM(MOCT(MBY4),24)+LDA)
CALL IPKM(MOCT(MBYA),1,IUPM(MOCT(MBYA), 8)+ 1)
MBIT = 8*(MBYB-1)
CALL PKC(TABA(I,LOT),LDA,MBAY,MBIT)
CALL PKB( 0, 8,MBAY,MBIT)
CALL PKB( 0, 8,MBAY,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.
+ (IUPM(MOCT(MBYB),8).EQ.255)) THEN
CALL MSGWRT(LUNOT,MBAY,MBYT)
CALL DXMINI(LOT,MBAY,MBYT,MBY4,MBYA,MBYB,MBYD)
ENDIF
CALL IPKM(MOCT(MBY4),3,IUPM(MOCT(MBY4),24)+LDB)
CALL IPKM(MOCT(MBYB),1,IUPM(MOCT(MBYB), 8)+ 1)
MBIT = 8*(MBYD-1)
CALL PKC(TABB(I,LOT),LDB,MBAY,MBIT)
CALL PKB( 0, 8,MBAY,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.
+ (IUPM(MOCT(MBYD),8).EQ.255)) THEN
CALL MSGWRT(LUNOT,MBAY,MBYT)
CALL DXMINI(LOT,MBAY,MBYT,MBY4,MBYA,MBYB,MBYD)
ENDIF
CALL IPKM(MOCT(MBY4),3,IUPM(MOCT(MBY4),24)+LEND)
CALL IPKM(MOCT(MBYD),1,IUPM(MOCT(MBYD), 8)+ 1)
MBIT = 8*(MBYT-4)
CALL PKC(TABD(I,LOT),LDD,MBAY,MBIT)
CALL PKB( NSEQ, 8,MBAY,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,MBAY,MBIT)
ENDDO
MBYT = MBYT+LEND
ENDDO
C Write the unwritten (leftover) message.
CALL MSGWRT(LUNOT,MBAY,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,MBAY,MBYT,MBY4,MBYA,MBYB,MBYD)
CALL GETLENS(MBAY,2,LEN0,LEN1,LEN2,L3,L4,L5)
MBIT = (LEN0+LEN1+LEN2+4)*8
CALL PKB(0,16,MBAY,MBIT)
CALL MSGWRT(LUNOT,MBAY,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