NCEPLIBS-bufr  11.6.0
 All Data Structures Files Functions Variables Pages
stbfdx.f
Go to the documentation of this file.
1 C> @file
2 C> @author J @date 2009-03-23
3 
4 C> THIS SUBROUTINE COPIES A BUFR TABLE (DICTIONARY) MESSAGE
5 C> FROM THE INPUT ARRAY MESG INTO THE INTERNAL MEMORY ARRAYS IN
6 C> MODULE TABABD.
7 C>
8 C> PROGRAM HISTORY LOG:
9 C> 2009-03-23 J. ATOR -- ORIGINAL AUTHOR, USING LOGIC COPIED
10 C> FROM PREVIOUS VERSION OF RDBFDX
11 C> 2014-11-14 J. ATOR -- REPLACE CHRTRNA CALLS WITH UPC CALLS
12 C> 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS
13 C>
14 C> USAGE: CALL STBFDX (LUN,MESG)
15 C> INPUT ARGUMENT LIST:
16 C> LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
17 C> MESG - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING
18 C> BUFR TABLE (DICTIONARY) MESSAGE
19 C>
20 C> REMARKS:
21 C> THIS ROUTINE CALLS: BORT CAPIT GETLENS IGETNTBI
22 C> IDN30 IFXY IUPB IUPBS01
23 C> NENUBD PKTDD STNTBIA UPC
24 C> THIS ROUTINE IS CALLED BY: RDBFDX RDMEMM READERME
25 C> Normally not called by any application
26 C> programs.
27 C>
28  SUBROUTINE stbfdx(LUN,MESG)
29 
30  USE modv_maxcd
31  USE moda_tababd
32 
33  COMMON /dxtab / maxdx,idxv,nxstr(10),ldxa(10),ldxb(10),ldxd(10),
34  . ld30(10),dxstr(10)
35 
36  CHARACTER*128 bort_str
37  CHARACTER*128 tabb1,tabb2
38  CHARACTER*56 dxstr
39  CHARACTER*55 cseq
40  CHARACTER*50 dxcmp
41  CHARACTER*24 unit
42  CHARACTER*8 nemo
43  CHARACTER*6 numb,cidn
44  dimension ldxbd(10),ldxbe(10)
45 
46  dimension mesg(*)
47 
48  DATA ldxbd /38,70,8*0/
49  DATA ldxbe /42,42,8*0/
50 
51 C-----------------------------------------------------------------------
52  ja(i) = ia+1+lda*(i-1)
53  jb(i) = ib+1+ldb*(i-1)
54 C-----------------------------------------------------------------------
55 
56 C GET SOME PRELIMINARY INFORMATION FROM THE MESSAGE
57 C -------------------------------------------------
58 
59  idxs = iupbs01(mesg,'MSBT')+1
60  IF(idxs.GT.idxv+1) idxs = iupbs01(mesg,'MTVL')+1
61  IF(ldxa(idxs).EQ.0) goto 901
62  IF(ldxb(idxs).EQ.0) goto 901
63  IF(ldxd(idxs).EQ.0) goto 901
64 
65  CALL getlens(mesg,3,len0,len1,len2,len3,l4,l5)
66  i3 = len0+len1+len2
67  dxcmp = ' '
68  jbit = 8*(i3+7)
69  CALL upc(dxcmp,nxstr(idxs),mesg,jbit,.false.)
70  IF(dxcmp.NE.dxstr(idxs)) goto 902
71 
72 C SECTION 4 - READ DEFINITIONS FOR TABLES A, B AND D
73 C --------------------------------------------------
74 
75  lda = ldxa(idxs)
76  ldb = ldxb(idxs)
77  ldd = ldxd(idxs)
78  ldbd = ldxbd(idxs)
79  ldbe = ldxbe(idxs)
80  l30 = ld30(idxs)
81 
82  ia = i3+len3+5
83  la = iupb(mesg,ia,8)
84  ib = ja(la+1)
85  lb = iupb(mesg,ib,8)
86  id = jb(lb+1)
87  ld = iupb(mesg,id,8)
88 
89 C TABLE A
90 C -------
91 
92  DO i=1,la
93  n = igetntbi(lun,'A')
94  jbit = 8*(ja(i)-1)
95  CALL upc(taba(n,lun),lda,mesg,jbit,.true.)
96  numb = ' '//taba(n,lun)(1:3)
97  nemo = taba(n,lun)(4:11)
98  cseq = taba(n,lun)(13:67)
99  CALL stntbia(n,lun,numb,nemo,cseq)
100  ENDDO
101 
102 C TABLE B
103 C -------
104 
105  DO i=1,lb
106  n = igetntbi(lun,'B')
107  jbit = 8*(jb(i)-1)
108  CALL upc(tabb1,ldbd,mesg,jbit,.true.)
109  jbit = 8*(jb(i)+ldbd-1)
110  CALL upc(tabb2,ldbe,mesg,jbit,.true.)
111  tabb(n,lun) = tabb1(1:ldxbd(idxv+1))//tabb2(1:ldxbe(idxv+1))
112  numb = tabb(n,lun)(1:6)
113  nemo = tabb(n,lun)(7:14)
114  CALL nenubd(nemo,numb,lun)
115  idnb(n,lun) = ifxy(numb)
116  unit = tabb(n,lun)(71:94)
117  CALL capit(unit)
118  tabb(n,lun)(71:94) = unit
119  ntbb(lun) = n
120  ENDDO
121 
122 C TABLE D
123 C -------
124 
125  DO i=1,ld
126  n = igetntbi(lun,'D')
127  jbit = 8*id
128  CALL upc(tabd(n,lun),ldd,mesg,jbit,.true.)
129  numb = tabd(n,lun)(1:6)
130  nemo = tabd(n,lun)(7:14)
131  CALL nenubd(nemo,numb,lun)
132  idnd(n,lun) = ifxy(numb)
133  nd = iupb(mesg,id+ldd+1,8)
134  IF(nd.GT.maxcd) goto 903
135  DO j=1,nd
136  ndd = id+ldd+2 + (j-1)*l30
137  jbit = 8*(ndd-1)
138  CALL upc(cidn,l30,mesg,jbit,.true.)
139  idn = idn30(cidn,l30)
140  CALL pktdd(n,lun,idn,iret)
141  IF(iret.LT.0) goto 904
142  ENDDO
143  id = id+ldd+1 + nd*l30
144  IF(iupb(mesg,id+1,8).EQ.0) id = id+1
145  ntbd(lun) = n
146  ENDDO
147 
148 C EXITS
149 C -----
150 
151  RETURN
152 901 CALL bort('BUFRLIB: STBFDX - UNEXPECTED DICTIONARY MESSAGE '//
153  . 'SUBTYPE OR LOCAL VERSION NUMBER (E.G., L.V.N. HIGHER THAN '//
154  . 'KNOWN)')
155 902 CALL bort('BUFRLIB: STBFDX - UNEXPECTED DICTIONARY MESSAGE '//
156  . 'CONTENTS')
157 903 WRITE(bort_str,'("BUFRLIB: STBFDX - NUMBER OF DESCRIPTORS IN '//
158  . 'TABLE D ENTRY ",A," IN BUFR TABLE (",I4,") EXCEEDS THE LIMIT '//
159  . ' (",I4,")")') nemo,nd,maxcd
160  CALL bort(bort_str)
161 904 CALL bort('BUFRLIB: STBFDX - BAD RETURN FROM BUFRLIB ROUTINE '//
162  . 'PKTDD, SEE PREVIOUS WARNING MESSAGE')
163  END
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 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:39
This module contains array and variable declarations used to store DX BUFR tables internally for mult...
Definition: moda_tababd.F:10
function idn30(ADN30, L30)
This function converts an FXY value from its 5 or 6 character representation to its bit-wise (integer...
Definition: idn30.f:27
subroutine upc(CHR, NCHR, IBAY, IBIT, CNVNULL)
THIS SUBROUTINE UNPACKS AND RETURNS A CHARACTER STRING OF LENGTH NCHR CONTAINED WITHIN NCHR BYTES OF ...
Definition: upc.f:49
subroutine nenubd(NEMO, NUMB, LUN)
THIS SUBROUTINE CHECKS A MNEMONIC AND FXY VALUE PAIR THAT WERE READ FROM A USER-SUPPLIED BUFR DICTION...
Definition: nenubd.f:48
function ifxy(ADSC)
This function converts an FXY value from its 6 character representation to its bit-wise (integer) rep...
Definition: ifxy.f:42
function igetntbi(LUN, CTB)
This function returns the next available index for storing an entry within a specified internal DX BU...
Definition: igetntbi.f:27
subroutine stbfdx(LUN, MESG)
THIS SUBROUTINE COPIES A BUFR TABLE (DICTIONARY) MESSAGE FROM THE INPUT ARRAY MESG INTO THE INTERNAL ...
Definition: stbfdx.f:28
subroutine pktdd(ID, LUN, IDN, IRET)
THIS SUBROUTINE STORES INFORMATION ABOUT A "CHILD" MNEMONIC WITHIN THE INTERNAL BUFR TABLE D ENTRY (I...
Definition: pktdd.f:54
This module declares and initializes the MAXCD variable.
Definition: modv_MAXCD.f90:13
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:22
function iupbs01(MBAY, S01MNEM)
This function returns a specified value from within Section 0 or Section 1 of a BUFR message...
Definition: iupbs01.f:73
subroutine capit(STR)
This subroutine capitalizes all of the alphabetic characters in a string.
Definition: capit.f:18
subroutine stntbia(N, LUN, NUMB, NEMO, CELSQ)
THIS SUBROUTINE STORES A NEW ENTRY WITHIN INTERNAL BUFR TABLE A.
Definition: stntbia.f:27