NCEPLIBS-bufr  11.5.0
 All Data Structures Files Functions Variables Pages
wrdxtb.f
Go to the documentation of this file.
1 C> @file
2 C> @author J @date 2009-03-23
3 
4 C> THIS SUBROUTINE WRITES BUFR TABLE (DICTIONARY) MESSAGES
5 C> ASSOCIATED WITH THE BUFR FILE IN LUNDX TO THE BUFR FILE IN LUNOT.
6 C> BOTH UNITS MUST BE OPENED VIA PREVIOUS CALLS TO BUFR ARCHIVE
7 C> LIBRARY SUBROUTINE OPENBF, AND IN PARTICULAR LUNOT MUST HAVE
8 C> BEEN OPENED FOR OUTPUT. THE TABLE MESSAGES ARE GENERATED FROM
9 C> ARRAYS IN INTERNAL MEMORY (MODULE TABABD). LUNDX CAN BE THE
10 C> SAME AS LUNOT IF IT IS DESIRED TO APPEND TO LUNOT WITH BUFR
11 C> MESSAGES GENERATED FROM ITS OWN INTERNAL TABLES.
12 C>
13 C> PROGRAM HISTORY LOG:
14 C> 2009-03-23 J. ATOR -- ORIGINAL AUTHOR, USING LOGIC FROM WRITDX
15 C> 2012-04-06 J. ATOR -- PREVENT STORING OF MORE THAN 255 TABLE A,
16 C> TABLE B OR TABLE D DESCRIPTORS IN ANY
17 C> SINGLE DX MESSAGE
18 C> 2014-11-14 J. ATOR -- REPLACE IPKM CALLS WITH PKB CALLS
19 C> 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS
20 C>
21 C> USAGE: CALL WRDXTB (LUNDX,LUNOT)
22 C> INPUT ARGUMENT LIST:
23 C> LUNDX - INTEGER: FORTRAN LOGICAL UNIT NUMBER ASSOCIATED
24 C> WITH DX (DICTIONARY) TABLES TO BE WRITTEN OUT;
25 C> CAN BE SAME AS LUNOT
26 C> LUNOT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE
27 C> TO BE APPENDED WITH TABLES ASSOCIATED WITH LUNDX
28 C>
29 C> REMARKS:
30 C> THIS ROUTINE CALLS: ADN30 BORT CPBFDX DXMINI
31 C> GETLENS IUPB IUPM MSGFULL
32 C> MSGWRT PKB PKC STATUS
33 C> THIS ROUTINE IS CALLED BY: MAKESTAB WRITDX
34 C> Also called by application programs.
35 C>
36  SUBROUTINE wrdxtb(LUNDX,LUNOT)
37 
38  USE moda_tababd
39  USE moda_mgwa
40 
41  COMMON /dxtab / maxdx,idxv,nxstr(10),ldxa(10),ldxb(10),ldxd(10),
42  . ld30(10),dxstr(10)
43 
44  CHARACTER*128 bort_str
45  CHARACTER*56 dxstr
46  CHARACTER*6 adn30
47 
48  LOGICAL msgfull
49 
50 C-----------------------------------------------------------------------
51 C-----------------------------------------------------------------------
52 
53 C CHECK FILE STATUSES
54 C -------------------
55 
56  CALL status(lunot,lot,il,im)
57  IF(il.EQ.0) goto 900
58  IF(il.LT.0) goto 901
59 
60  CALL status(lundx,ldx,il,im)
61  IF(il.EQ.0) goto 902
62 
63 C IF FILES ARE DIFFERENT, COPY INTERNAL TABLE
64 C INFORMATION FROM LUNDX TO LUNOT
65 C -------------------------------------------
66 
67  IF(lundx.NE.lunot) CALL cpbfdx(ldx,lot)
68 
69 C GENERATE AND WRITE OUT BUFR DICTIONARY MESSAGES TO LUNOT
70 C --------------------------------------------------------
71 
72  CALL dxmini(lot,mgwa,mbyt,mby4,mbya,mbyb,mbyd)
73 
74  lda = ldxa(idxv+1)
75  ldb = ldxb(idxv+1)
76  ldd = ldxd(idxv+1)
77  l30 = ld30(idxv+1)
78 
79 C Table A information
80 
81  DO i=1,ntba(lot)
82  IF(msgfull(mbyt,lda,maxdx).OR.
83  + (iupb(mgwa,mbya,8).EQ.255)) THEN
84  CALL msgwrt(lunot,mgwa,mbyt)
85  CALL dxmini(lot,mgwa,mbyt,mby4,mbya,mbyb,mbyd)
86  ENDIF
87  mbit = 8*(mby4-1)
88  CALL pkb(iupb(mgwa,mby4,24)+lda,24,mgwa,mbit)
89  mbit = 8*(mbya-1)
90  CALL pkb(iupb(mgwa,mbya, 8)+ 1, 8,mgwa,mbit)
91  mbit = 8*(mbyb-1)
92  CALL pkc(taba(i,lot),lda,mgwa,mbit)
93  CALL pkb( 0, 8,mgwa,mbit)
94  CALL pkb( 0, 8,mgwa,mbit)
95  mbyt = mbyt+lda
96  mbyb = mbyb+lda
97  mbyd = mbyd+lda
98  ENDDO
99 
100 C Table B information
101 
102  DO i=1,ntbb(lot)
103  IF(msgfull(mbyt,ldb,maxdx).OR.
104  + (iupb(mgwa,mbyb,8).EQ.255)) THEN
105  CALL msgwrt(lunot,mgwa,mbyt)
106  CALL dxmini(lot,mgwa,mbyt,mby4,mbya,mbyb,mbyd)
107  ENDIF
108  mbit = 8*(mby4-1)
109  CALL pkb(iupb(mgwa,mby4,24)+ldb,24,mgwa,mbit)
110  mbit = 8*(mbyb-1)
111  CALL pkb(iupb(mgwa,mbyb, 8)+ 1, 8,mgwa,mbit)
112  mbit = 8*(mbyd-1)
113  CALL pkc(tabb(i,lot),ldb,mgwa,mbit)
114  CALL pkb( 0, 8,mgwa,mbit)
115  mbyt = mbyt+ldb
116  mbyd = mbyd+ldb
117  ENDDO
118 
119 C Table D information
120 
121  DO i=1,ntbd(lot)
122  nseq = iupm(tabd(i,lot)(ldd+1:ldd+1),8)
123  lend = ldd+1 + l30*nseq
124  IF(msgfull(mbyt,lend,maxdx).OR.
125  + (iupb(mgwa,mbyd,8).EQ.255)) THEN
126  CALL msgwrt(lunot,mgwa,mbyt)
127  CALL dxmini(lot,mgwa,mbyt,mby4,mbya,mbyb,mbyd)
128  ENDIF
129  mbit = 8*(mby4-1)
130  CALL pkb(iupb(mgwa,mby4,24)+lend,24,mgwa,mbit)
131  mbit = 8*(mbyd-1)
132  CALL pkb(iupb(mgwa,mbyd, 8)+ 1, 8,mgwa,mbit)
133  mbit = 8*(mbyt-4)
134  CALL pkc(tabd(i,lot),ldd,mgwa,mbit)
135  CALL pkb( nseq, 8,mgwa,mbit)
136  DO j=1,nseq
137  jj = ldd+2 + (j-1)*2
138  idn = iupm(tabd(i,lot)(jj:jj),16)
139  CALL pkc(adn30(idn,l30),l30,mgwa,mbit)
140  ENDDO
141  mbyt = mbyt+lend
142  ENDDO
143 
144 C Write the unwritten (leftover) message.
145 
146  CALL msgwrt(lunot,mgwa,mbyt)
147 
148 C Write out one additional (dummy) DX message containing zero
149 C subsets. This will serve as a delimiter for this set of
150 C table messages within output unit LUNOT, just in case the
151 C next thing written to LUNOT ends up being another set of
152 C table messages.
153 
154  CALL dxmini(lot,mgwa,mbyt,mby4,mbya,mbyb,mbyd)
155  CALL getlens(mgwa,2,len0,len1,len2,l3,l4,l5)
156  mbit = (len0+len1+len2+4)*8
157  CALL pkb(0,16,mgwa,mbit)
158  CALL msgwrt(lunot,mgwa,mbyt)
159 
160 C EXITS
161 C -----
162 
163  RETURN
164 900 CALL bort('BUFRLIB: WRDXTB - OUTPUT BUFR FILE IS CLOSED, IT '//
165  . 'MUST BE OPEN FOR OUTPUT')
166 901 CALL bort('BUFRLIB: WRDXTB - OUTPUT BUFR FILE IS OPEN FOR '//
167  . 'INPUT, IT MUST BE OPEN FOR OUTPUT')
168 902 CALL bort('BUFRLIB: WRDXTB - DX TABLE FILE IS CLOSED, IT '//
169  . 'MUST BE OPEN')
170  END
subroutine msgwrt(LUNIT, MESG, MGBYT)
This subroutine performs final checks and updates on a BUFR message before writing it to a specified ...
Definition: msgwrt.f:69
subroutine cpbfdx(LUD, LUN)
THIS SUBROUTINE COPIES BUFR TABLE (DICTIONARY) MESSAGES FROM ONE LOCATION TO ANOTHER WITHIN INTERNAL ...
Definition: cpbfdx.f:35
function iupb(MBAY, NBYT, NBIT)
THIS FUNCTION UNPACKS AND RETURNS A BINARY INTEGER WORD CONTAINED WITHIN NBIT BITS OF A BUFR MESSAGE ...
Definition: iupb.f:36
subroutine pkc(CHR, NCHR, IBAY, IBIT)
This subroutine encodes a character string within a specified number of bits of an integer array...
Definition: pkc.f:42
subroutine getlens(MBAY, LL, LEN0, LEN1, LEN2, LEN3, LEN4, LEN5)
This subroutine reads the lengths of all of the individual sections of a given BUFR message...
Definition: getlens.f:37
function iupm(CBAY, NBITS)
THIS FUNCTION UNPACKS AND RETURNS A BINARY INTEGER WORD CONTAINED WITHIN NBITS BITS OF A CHARACTER ST...
Definition: iupm.f:40
This module contains array and variable declarations used to store DX BUFR tables internally for mult...
Definition: moda_tababd.F:10
subroutine dxmini(LUN, MBAY, MBYT, MB4, MBA, MBB, MBD)
THIS SUBROUTINE INITIALIZES A BUFR TABLE (DICTIONARY) MESSAGE, WRITING ALL THE PRELIMINARY INFORMATIO...
Definition: dxmini.f:55
LOGICAL function msgfull(MSIZ, ITOADD, MXSIZ)
THIS LOGICAL FUNCTION DETERMINES WHETHER THE CURRENT SUBSET (OF LENGTH ITOADD BYTES) WILL FIT WITHIN ...
Definition: msgfull.f:26
character *(*) function adn30(IDN, L30)
This function converts a descriptor from its bit-wise (integer) representation to its 5 or 6 characte...
Definition: adn30.f:27
subroutine status(LUNIT, LUN, IL, IM)
This subroutine checks whether a specified Fortran logical unit number is currently connected to the ...
Definition: status.f:61
subroutine wrdxtb(LUNDX, LUNOT)
THIS SUBROUTINE WRITES BUFR TABLE (DICTIONARY) MESSAGES ASSOCIATED WITH THE BUFR FILE IN LUNDX TO THE...
Definition: wrdxtb.f:36
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:23
subroutine pkb(NVAL, NBITS, IBAY, IBIT)
This subroutine encodes an integer value within a specified number of bits of an integer array...
Definition: pkb.f:40