NCEPLIBS-bufr  12.0.0
stbfdx.f
Go to the documentation of this file.
1 C> @file
2 C> @brief Store a DX BUFR tables message into internal arrays.
3 C>
4 C> @author J Ator @date 2009-03-23
5 
6 C> This subroutine copies a DX BUFR tables message
7 C> from the input array mesg into the internal memory arrays in
8 C> module @ref moda_tababd.
9 C>
10 C> @param[in] LUN - integer: I/O stream index into internal memory arrays.
11 C> @param[in] MESG - integer(*): DX BUFR tables message
12 C>
13 C> @author J. Ator @date 2009-03-23
14  SUBROUTINE stbfdx(LUN,MESG)
15 
16  USE modv_maxcd
17  USE moda_tababd
18 
19  COMMON /dxtab / maxdx,idxv,nxstr(10),ldxa(10),ldxb(10),ldxd(10),
20  . ld30(10),dxstr(10)
21 
22  CHARACTER*128 BORT_STR
23  CHARACTER*128 TABB1,TABB2
24  CHARACTER*56 DXSTR
25  CHARACTER*55 CSEQ
26  CHARACTER*50 DXCMP
27  CHARACTER*24 UNIT
28  CHARACTER*8 NEMO
29  CHARACTER*6 NUMB,CIDN
30  dimension ldxbd(10),ldxbe(10)
31 
32  dimension mesg(*)
33 
34  DATA ldxbd /38,70,8*0/
35  DATA ldxbe /42,42,8*0/
36 
37 C-----------------------------------------------------------------------
38  ja(i) = ia+1+lda*(i-1)
39  jb(i) = ib+1+ldb*(i-1)
40 C-----------------------------------------------------------------------
41 
42 C GET SOME PRELIMINARY INFORMATION FROM THE MESSAGE
43 C -------------------------------------------------
44 
45  idxs = iupbs01(mesg,'MSBT')+1
46  IF(idxs.GT.idxv+1) idxs = iupbs01(mesg,'MTVL')+1
47  IF(ldxa(idxs).EQ.0) GOTO 901
48  IF(ldxb(idxs).EQ.0) GOTO 901
49  IF(ldxd(idxs).EQ.0) GOTO 901
50 
51  CALL getlens(mesg,3,len0,len1,len2,len3,l4,l5)
52  i3 = len0+len1+len2
53  dxcmp = ' '
54  jbit = 8*(i3+7)
55  CALL upc(dxcmp,nxstr(idxs),mesg,jbit,.false.)
56  IF(dxcmp.NE.dxstr(idxs)) GOTO 902
57 
58 C SECTION 4 - READ DEFINITIONS FOR TABLES A, B AND D
59 C --------------------------------------------------
60 
61  lda = ldxa(idxs)
62  ldb = ldxb(idxs)
63  ldd = ldxd(idxs)
64  ldbd = ldxbd(idxs)
65  ldbe = ldxbe(idxs)
66  l30 = ld30(idxs)
67 
68  ia = i3+len3+5
69  la = iupb(mesg,ia,8)
70  ib = ja(la+1)
71  lb = iupb(mesg,ib,8)
72  id = jb(lb+1)
73  ld = iupb(mesg,id,8)
74 
75 C TABLE A
76 C -------
77 
78  DO i=1,la
79  n = igetntbi(lun,'A')
80  jbit = 8*(ja(i)-1)
81  CALL upc(taba(n,lun),lda,mesg,jbit,.true.)
82  numb = ' '//taba(n,lun)(1:3)
83  nemo = taba(n,lun)(4:11)
84  cseq = taba(n,lun)(13:67)
85  CALL stntbia(n,lun,numb,nemo,cseq)
86  ENDDO
87 
88 C TABLE B
89 C -------
90 
91  DO i=1,lb
92  n = igetntbi(lun,'B')
93  jbit = 8*(jb(i)-1)
94  CALL upc(tabb1,ldbd,mesg,jbit,.true.)
95  jbit = 8*(jb(i)+ldbd-1)
96  CALL upc(tabb2,ldbe,mesg,jbit,.true.)
97  tabb(n,lun) = tabb1(1:ldxbd(idxv+1))//tabb2(1:ldxbe(idxv+1))
98  numb = tabb(n,lun)(1:6)
99  nemo = tabb(n,lun)(7:14)
100  CALL nenubd(nemo,numb,lun)
101  idnb(n,lun) = ifxy(numb)
102  unit = tabb(n,lun)(71:94)
103  CALL capit(unit)
104  tabb(n,lun)(71:94) = unit
105  ntbb(lun) = n
106  ENDDO
107 
108 C TABLE D
109 C -------
110 
111  DO i=1,ld
112  n = igetntbi(lun,'D')
113  jbit = 8*id
114  CALL upc(tabd(n,lun),ldd,mesg,jbit,.true.)
115  numb = tabd(n,lun)(1:6)
116  nemo = tabd(n,lun)(7:14)
117  CALL nenubd(nemo,numb,lun)
118  idnd(n,lun) = ifxy(numb)
119  nd = iupb(mesg,id+ldd+1,8)
120  IF(nd.GT.maxcd) GOTO 903
121  DO j=1,nd
122  ndd = id+ldd+2 + (j-1)*l30
123  jbit = 8*(ndd-1)
124  CALL upc(cidn,l30,mesg,jbit,.true.)
125  idn = idn30(cidn,l30)
126  CALL pktdd(n,lun,idn,iret)
127  IF(iret.LT.0) GOTO 904
128  ENDDO
129  id = id+ldd+1 + nd*l30
130  IF(iupb(mesg,id+1,8).EQ.0) id = id+1
131  ntbd(lun) = n
132  ENDDO
133 
134 C EXITS
135 C -----
136 
137  RETURN
138 901 CALL bort('BUFRLIB: STBFDX - UNEXPECTED DICTIONARY MESSAGE '//
139  . 'SUBTYPE OR LOCAL VERSION NUMBER (E.G., L.V.N. HIGHER THAN '//
140  . 'KNOWN)')
141 902 CALL bort('BUFRLIB: STBFDX - UNEXPECTED DICTIONARY MESSAGE '//
142  . 'CONTENTS')
143 903 WRITE(bort_str,'("BUFRLIB: STBFDX - NUMBER OF DESCRIPTORS IN '//
144  . 'TABLE D ENTRY ",A," IN BUFR TABLE (",I4,") EXCEEDS THE LIMIT '//
145  . ' (",I4,")")') nemo,nd,maxcd
146  CALL bort(bort_str)
147 904 CALL bort('BUFRLIB: STBFDX - BAD RETURN FROM BUFRLIB ROUTINE '//
148  . 'PKTDD, SEE PREVIOUS WARNING MESSAGE')
149  END
subroutine bort(STR)
Log one error message and abort application program.
Definition: bort.f:18
subroutine capit(STR)
This subroutine capitalizes all of the alphabetic characters in a string.
Definition: capit.f:13
recursive 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:36
function idn30(ADN30, L30)
Convert an FXY value from a character string to the WMO bit-wise representation.
Definition: idn30.f:22
function ifxy(ADSC)
Convert an FXY value from its 6 character representation to its WMO bit-wise representation.
Definition: ifxy.f:34
function igetntbi(LUN, CTB)
This function returns the next available index for storing an entry within a specified internal DX BU...
Definition: igetntbi.f:22
recursive function iupb(MBAY, NBYT, NBIT)
Decode an integer value from an integer array.
Definition: iupb.f:21
recursive function iupbs01(MBAY, S01MNEM)
Read a data value from Section 0 or Section 1 of a BUFR message.
Definition: iupbs01.f:69
This module contains array and variable declarations used to store DX BUFR tables internally for mult...
character *600, dimension(:,:), allocatable tabd
Table D entries for each internal I/O stream.
character *128, dimension(:,:), allocatable taba
Table A entries for each internal I/O stream.
integer, dimension(:), allocatable ntbd
Number of Table D entries for each internal I/O stream (up to a maximum of MAXTBD,...
integer, dimension(:), allocatable ntbb
Number of Table B entries for each internal I/O stream (up to a maximum of MAXTBB,...
integer, dimension(:,:), allocatable idnd
Bit-wise representations of the FXY values corresponding to tabd.
integer, dimension(:,:), allocatable idnb
Bit-wise representations of the FXY values corresponding to tabb.
character *128, dimension(:,:), allocatable tabb
Table B entries for each internal I/O stream.
This module declares and initializes the MAXCD variable.
integer, public maxcd
Maximum number of child descriptors that can be included within the sequence definition of a Table D ...
subroutine nenubd(NEMO, NUMB, LUN)
Confirm that a mnemonic and FXY value haven't already been defined.
Definition: nenubd.f:22
subroutine pktdd(ID, LUN, IDN, IRET)
Store information about a child mnemonic within the internal arrays.
Definition: pktdd.f:26
subroutine stbfdx(LUN, MESG)
This subroutine copies a DX BUFR tables message from the input array mesg into the internal memory ar...
Definition: stbfdx.f:15
subroutine stntbia(N, LUN, NUMB, NEMO, CELSQ)
This subroutine stores a new entry within internal BUFR Table A.
Definition: stntbia.f:15
subroutine upc(CHR, NCHR, IBAY, IBIT, CNVNULL)
Decode a character string from an integer array.
Definition: upc.f:32