1C Copyright 1981-2016 ECMWF.
2C
3C This software is licensed under the terms of the Apache Licence
4C Version 2.0 which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
5C
6C In applying this licence, ECMWF does not waive the privileges and immunities
7C granted to it by virtue of its status as an intergovernmental organisation
8C nor does it submit to any jurisdiction.
9C
10
11      SUBROUTINE BUEXS3(KBUFL,KBUFF,KSUP,KSEC3,KELEM,CNAMES,CUNITS,KERR)
12C
13C**** *BUEXS3*
14C
15C
16C     PURPOSE.
17C     --------
18C
19C          EXPAND SECTION 3 OF BUFR MESSAGE.
20C
21C
22C**   INTERFACE.
23C     ----------
24C
25C          *CALL* *BUEXS3( KBUFL,KBUFF,KSUP,KSEC3,KELEM,CNAMES,CUNITS,KERR)*
26C
27C        INPUT :
28C               *KBUFL*   -  LENGTH OF BUFR MESSAGE (WORDS)
29C               *KBUFF*   -  ARRAY CONTAINING BUFR MESSAGE
30C               *KELEM*   -  DIMENSION OF CNAMES, CUNITS ARRAY
31C        OUTPUT:
32C               *KSUP*    -  ARRAY CONTAINING SUPLEMENTARY INFORMATION
33C                         -  KSUP( 1) -- IDIM1, DIMENSION OF KSEC1
34C                         -  KSUP( 2) -- IDIM2, DIMENSION OF KSEC2
35C                         -  KSUP( 3) -- IDIM3, DIMENSION OF KSEC3
36C                         -  KSUP( 4) -- IDIM4, DIMENSION OF KSEC4
37C                         -  KSUP( 5) -- M (NUMBER OF ELEMENTS IN VALUES ARRAY,
38C                                           FIRST INDEX)
39C                         -  KSUP( 6) -- N (NUMBER OF SUBSETS,SECOND INDEX OF
40C                                           VALUES ARRAY)
41C                         -  KSUP( 7) -- JVC (NUMBER OF ELEMENTS IN CVAL ARRAY)
42C                         -  KSUP( 8) -- TOTAL BUFR MESSAGE LENGTH IN BYTES
43C                         -  KSUP( 9) -- IDIM0, DIMENSION OF KSEC0
44C               *KSEC3*   -  ARRAY CONTAINING SECTION 3 INFORMATION
45C                            KSEC3( 1)-- LENGTH OF SECTION 3 (BYTES)
46C                            KSEC3( 2)-- RESERVED
47C                            KSEC3( 3)-- NUMBER OF SUBSETS
48C                            KSEC3( 4)-- FLAG (DATA TYPE,DATA COMPRESSION)
49C               *CNAMES*  -  CHARACTER ARRAY CONTAINING ELEMENT NAMES
50C               *CUNITS*  -  CHARACTER ARRAY CONTAINIG UNITS
51C               *KERR*    -  RETURNED ERROR CODE
52C
53C     METHOD.
54C      -------
55C
56C          EXPANDS LIST OF DATA DESCRIPTORS PACKED IN SECTION 3
57C     OF BUFR MESSAGE. WORKING TABLES FOR FURTHER DATA DECODING ARE SET,
58C     LIST OF PACKED BUFR DATA DESCRIPTORS AND LIST OF BUFR DATA DESCRIPTORS
59C     EXPANDED ACCORDING TO TABLE D REFERENCE ARE RETURNED RESPECTIVELY.
60C
61C
62C
63C     EXTERNALS.
64C     ----------
65C
66C          BUNEXS        - SET WORD AND BIT POINTERS AT THE BEGINING OF
67C                          NEXT SECTION
68C          BUNPCK        - UNPACKS BIT PATTERN
69C          BUSRP         - SOLVES REPLICATION PROBLEM
70C          BUSTDR        - SOLVES TABLE D REFERENCE
71C          BUPRCO        - PROCESS OPERATOR
72C          BUUPWT        - UPDATES WORKING TABLE
73C
74C     REFERENCE.
75C     ----------
76C
77C          NONE.
78C
79C     AUTHOR.
80C     -------
81C
82C          M. DRAGOSAVAC    *ECMWF*       01/02/91.
83C
84C
85C     MODIFICATIONS.
86C     --------------
87C
88C          NONE.
89C
90C
91      IMPLICIT LOGICAL(L,O,G), CHARACTER*8(C,H,Y)
92C
93C
94#     include "parameter.F"
95#     include "bcomunit.F"
96#     include "bcomwork.F"
97#     include "bcombef.F"
98#     include "bcomwt.F"
99#     include "bcomp.F"
100#     include "bcomwtc.F"
101#     include "bcomrq.F"
102#     include "bcomreq.F"
103#     include "bcomel.F"
104#     include "bcprq.F"
105#     include "bcomoff.F"
106#     include "bcomcom.F"
107C
108      CHARACTER*64 CWTEN
109      CHARACTER*24 CWTU
110      CHARACTER*64 CNAMES(KELEM)
111      CHARACTER*24 CUNITS(KELEM)
112C
113      DIMENSION ISTACK(JELEM),IISTACK(JELEM)
114      DIMENSION KBUFF(KBUFL)
115      DIMENSION IMASK(8)
116C
117#ifndef R_4
118      REAL*8 RQVAL
119      REAL*8 RVIND
120      REAL*8 EPS
121#else
122      REAL   RQVAL
123      REAL   RVIND
124      REAL   EPS
125#endif
126C
127      DIMENSION KSUP(JSUP),KSEC3(JSEC3)
128C
129      DATA IMASK/1,2,4,8,16,32,64,128/
130C
131      SAVE NOLD,KELEMOLD
132C     ------------------------------------------------------------------
133C
134C*          1.   EXPAND PRELIMINARY ITEMS OF SECTION 3.
135C                --------------------------------------
136 100  CONTINUE
137C
138      IF( KERR.NE.0 ) RETURN
139C
140C
141C*          1.1   SET THE POINTERS NWPT AND NBPT TO THE
142C                 -------------------------------------
143C                 BEGINING OF THE SECTION 3.
144C                 --------------------------
145 110  CONTINUE
146C
147      NWPT = NWPTB
148      NBPT = NBPTB
149C
150C*          1.2   UNPACK LENGTH OF SECTION 3.
151C                 ---------------------------
152 120  CONTINUE
153C
154      CALL BUNPCK(NBPW,KBUFF,KSEC3(1),NWPT,NBPT,24,KERR)
155      IF(KERR.GT.0) THEN
156         WRITE(KNTN,*)  'ERROR UNPACKING KSEC3(1).'
157         RETURN
158      END IF
159C
160C*          1.2.1  SET THE POINTERS NWPTB AND NBPTB TO
161C                  -----------------------------------
162C                  THE BEGINNING OF THE NEXT SECTION.
163C                  ----------------------------------
164      CALL BUNEXS(KSEC3(1))
165C
166C*          1.3    UNPACK ZERO BYTE AND PUT IT IN KSEC3(2).
167C                  ----------------------------------------
168 130  CONTINUE
169C
170      CALL BUNPCK(NBPW,KBUFF,KSEC3(2),NWPT,NBPT,8,KERR)
171      IF(KERR.GT.0) THEN
172         WRITE(KNTN,*)  'ERROR UNPACKING KSEC3(2).'
173         RETURN
174      END IF
175C
176C*          1.4    UNPACK NUMBER OF DATA SUB-SETS.
177C                  -------------------------------
178 140  CONTINUE
179C
180      CALL BUNPCK(NBPW,KBUFF,KSEC3(3),NWPT,NBPT,16,KERR)
181      IF(KERR.GT.0) THEN
182         WRITE(KNTN,*)  'ERROR UNPACKING KSEC3(3).'
183         RETURN
184      END IF
185      IF(KSEC3(3).LE.0) THEN
186         KERR=32
187         WRITE(KNTN,*)  ' BUEXS3 :'
188         CALL BUERR(KERR)
189         RETURN
190      END IF
191C
192      N = KSEC3(3)
193C
194C
195C*          1.5    UNPACK INTEGER VALUE OF THE OCTET
196C                  ---------------------------------
197C                  CONTAINING FLAG BITS.
198C                  --------------------
199 150  CONTINUE
200C
201      CALL BUNPCK(NBPW,KBUFF,KSEC3(4),NWPT,NBPT,8,KERR)
202      IF(KERR.GT.0) THEN
203         WRITE(KNTN,*)  'ERROR UNPACKING KSEC3(4).'
204         RETURN
205      END IF
206C
207      ICOMP=KSEC3(4)
208C     -----------------------------------------------------------------
209C
210C*          2.   EXPAND DATA DESCRIPTORS.
211C                ------------------------
212 200  CONTINUE
213C
214C
215C*          2.1  CALCULATE EXPECTED NUMBER OF DATA DESCRIPTORS.
216C                ----------------------------------------------
217C                AND INITIALIZE NUMBER OF DATA VALUES PER SUB-SET.
218C                -------------------------------------------------
219 210  CONTINUE
220C
221      J      = 0
222      NWT    = 0
223      JMAX   = ( KSEC3(1) - 7)/2
224      JMAXNEW=JMAX
225C
226      IF(JMAX.GT.JELEM) THEN
227         WRITE(KNTN,*)  'NUMBER OF ELEMENTS IN SECTION3 TOO BIG.'
228         WRITE(KNTN,*)  'PROGRAM CAN NOT HANDLE',JMAX
229         WRITE(KNTN,*)  'DATA DESCRIPTORS IN SECTION3.'
230         WRITE(KNTN,*)  'MAXIMUM NUMBER OF ELEMENTS IS ',JELEM
231         KERR=200
232         RETURN
233      END IF
234C
235C*          2.2  UNPACK AND PUT DATA DESCRIPTORS IN STACK.
236C                -----------------------------------------
237 220  CONTINUE
238C
239      DO 221 JJ=1,JMAX
240C
241      CALL BUNPCK(NBPW,KBUFF,IF,NWPT,NBPT,2,KERR)
242      IF(KERR.GT.0) THEN
243         WRITE(KNTN,*)  'ERROR UNPACKING F PART OF DESCRIPTOR.'
244         RETURN
245      END IF
246      CALL BUNPCK(NBPW,KBUFF,IX,NWPT,NBPT,6,KERR)
247      IF(KERR.GT.0) THEN
248         WRITE(KNTN,*)  'ERROR UNPACKING X PART OF DESCRIPTOR.'
249         RETURN
250      END IF
251      CALL BUNPCK(NBPW,KBUFF,IY,NWPT,NBPT,8,KERR)
252      IF(KERR.GT.0) THEN
253         WRITE(KNTN,*)  'ERROR UNPACKING Y PART OF DESCRIPTOR.'
254         RETURN
255      END IF
256C
257      ISTACK(JJ)=IF*100000+IX*1000+IY
258      IISTACK(JJ)=ISTACK(JJ)
259C
260 221  CONTINUE
261C
262C*          2.2.1 CHECK IF IT IS SAME DATA DESCRIPTOR DESCRIPTION.
263C                 ------------------------------------------------
264C                 TO MAKE MORE EFFICIENT DATA DESCRIPTOR DESCRIPTION
265C                 EXPANSION, IN CASE THAT DELAYED REPLICATION FACTOR
266C                 IS NOT PRESENT AND DATA DESCRIPTORS ARE THE SAME,
267C                 PREVIOUS WORKING TABLE SHOULD BE USED. IT IS POSIBLE
268C                 AT THIS PLACE IN THE FUTURE TO MAKE MORE SOPHISTICATED
269C                 CONTROL.
270C
271C
272      DO 222 JC=1,JMAX
273C
274      IF(ISTACK(JC).NE.NSTACK(JC)) THEN
275C
276         ODREPF=.FALSE.
277C
278C        SWAP CONTENT OF THE STACKS.
279C
280         DO 223 JJC=1,JMAX
281         NSTACK(JJC)=ISTACK(JJC)
282 223     CONTINUE
283C
284         NTDLEN = JMAX
285         M=0
286         M0=1
287         NOLD=N
288         KELEMOLD=KELEM
289         NFCM=0
290         NFUCM=0
291         MREL=0
292         OMARKER=.FALSE.
293         MBMP=0
294         MBMPL=0
295C
296         GO TO 230
297C
298      END IF
299C
300 222  CONTINUE
301C
302C*    IF MARKER OPERATOR PRESENT EXPAND DESCRIPTORS AGAIN
303C
304      IF(OMARKER) THEN
305         M=0
306         M0=1
307         NOLD=N
308         KELEMOLD=KELEM
309         NFCM=0
310         NFUCM=0
311         MREL=0
312         OMARKER=.FALSE.
313         NTDLEN=JMAX
314         MBMP=0
315         MBMPL=0
316         GO TO 230
317      END IF
318C
319C*    CHECK IF THE SAME NUMBER OF DESCRIPTORS
320C     AS IN A PREVIOUS MESSAGE
321C
322      IF(JMAX.NE.NTDLEN) THEN
323         M=0
324         M0=1
325         NOLD=N
326         KELEMOLD=KELEM
327         NFCM=0
328         NFUCM=0
329         MREL=0
330         OMARKER=.FALSE.
331         NTDLEN=JMAX
332         MBMP=0
333         MBMPL=0
334         GO TO 230
335      END IF
336C
337C*    RETURN IF DELAYED REPLICATION FACTOR IS NOT PRESENT.
338C
339      IF(NPRUS.EQ.1) GO TO 229
340C
341      OB=.FALSE.
342      IF(IAND(KSEC3(4),IMASK(7)).NE.0) OB=.TRUE.
343C
344C     CHECK FOR DELAYED REPLICATION FACTOR
345C
346      IF(ODREPF) GO TO 229
347C
348C     CHECK FOR COMPRESSION
349C
350      IF(OB) THEN
351C
352C        DATA COMPRESSED =/ PREVIOUS  --> RECALCULATE POINTERS
353C
354         GO TO 229
355      END IF
356C
357 229  CONTINUE
358C
359      M=0
360      M0=1
361      NOLD=N
362      KELEMOLD=KELEM
363      NFCM=0
364      NFUCM=0
365      MREL=0
366      OMARKER=.FALSE.
367      NTDLEN=JMAX
368      MBMP=0
369      MBMPL=0
370C
371C     ------------------------------------------------------------------
372C*          2.3  GET NEXT DESCRIPTOR FROM THE STACK.
373C                -----------------------------------
374 230  CONTINUE
375C
376      J   = J + 1
377      IF(J.GT.JMAX) GO TO 270
378C
379      IDD = ISTACK(J)
380      IF(IDD.EQ.0)  GO TO 230
381C
382      IF = IDD/100000
383C
384      IF(NWT.GT.NSTOP) GO TO 270
385C     ------------------------------------------------------------------
386C*          2.4  CHECK IF IT IS REPLICATION DESCRIPTOR.
387C                --------------------------------------
388 240  CONTINUE
389C
390      IF( IF.EQ.0) THEN
391C
392C*          2.6  ELEMENT DESCRIPTOR, SO UPDATE WORKING TABLE.
393C                --------------------------------------------
394 260     CONTINUE
395C
396            CALL BUUPWT(IDD,KELEM,KERR)
397            IF(KERR.GT.0) RETURN
398C
399      ELSEIF( IF.EQ.1) THEN
400C
401C*          2.4.1     SOLVE REPLICATION PROBLEM.
402C                     --------------------------
403C
404C
405         CALL BUSRP(KBUFL,KBUFF,KSEC3,J,JMAX,IDD,ISTACK,KELEM,KERR)
406         IF(KERR.GT.0) RETURN
407C
408      ELSEIF( IF.EQ.2) THEN
409C
410C*          2.5.3 PROCESS OPERATOR.
411C                 -----------------
412            CALL BUPRCO(KBUFL,KBUFF,J,IDD,ISTACK,KELEM,KERR)
413            IF(KERR.GT.0) RETURN
414C
415      ELSEIF( IF.EQ.3) THEN
416C
417C*          2.5.2 REPLACE BY LIST OF DESCRIPTORS FROM TABLE *D.
418C                 ---------------------------------------------
419            CALL BUSTDR(J,JMAX,IDD,ISTACK,KERR)
420            IF(KERR.GT.0) THEN
421               DO 252 IQ=1,JELEM
422               NSTACK(IQ)=0.
423 252           CONTINUE
424               RETURN
425            END IF
426      ELSE
427         KERR=37
428         CALL BUERR(KERR)
429         RETURN
430      END IF
431C
432      GO TO 230
433C
434C     ------------------------------------------------------------------
435C*          2.7 RESOLVE MARKER OPERATOR.
436C               ------------------------
437 270  CONTINUE
438C
439      IF(OMARKER) THEN
440         CALL BUPMRK(KBUFL,KBUFF,KSEC3,KELEM,KERR)
441         IF(KERR.GT.0) RETURN
442      END IF
443C
444C*          2.8 CHECK IF IT IS CORRESPONDING DATA.
445C               ----------------------------------
446 280  CONTINUE
447C
448C     CHECK FOR WORKING SPACE.
449C
450      IF(JWORK/N.LT.KELEM) THEN
451         KERR=17
452         WRITE(KNTN,*)  'BUEXS3:'
453         CALL BUERR(KERR)
454         MN=KELEM*N
455         WRITE(KNTN,*)  ' SUGGESTED VALUE FOR JWORK ',MN
456         WRITE(KNTN,*)  ' CHECK IF TOO BIG KELEM USED.'
457         RETURN
458      END IF
459C
460      IF(IAND(KSEC3(4),IMASK(7)).NE.0) THEN
461C
462C        COMPRESSED DATA
463C
464         CALL BURQC(KBUFL,KBUFF,KELEM,CNAMES,CUNITS,KSUP ,KSEC3,KERR)
465         IF(KERR.GT.0) RETURN
466      ELSE
467C
468C        UNCOMPRESSED DATA
469C
470         CALL BURQUC(KBUFL,KBUFF,KELEM,CNAMES,CUNITS,KSUP ,KSEC3,KERR)
471         IF(KERR.GT.0) RETURN
472C
473      END IF
474C
475C     ------------------------------------------------------------------
476C
477C*          3. COLLECT  SUPPLEMENTARY ITEMS.
478C              -----------------------------
479 300  CONTINUE
480C
481      NTDEXL =M
482      DO 301 I=1,NTDEXL
483      NTDEXP(I)=INWTR(I)
484 301  CONTINUE
485C
486      NTDLEN=JMAXNEW
487      DO 302 I=1,NTDLEN
488      NTDLST (I)=IISTACK(I)
489 302  CONTINUE
490C
491      DO 303 I=1,NTDEXL
492      IJ=I+(NSUBSET-1)*KELEM
493      NWTRG(IJ)=INWTR(I)
494      NWTDWG(IJ)=INWTDW(I)
495 303  CONTINUE
496C
497      NSIZE(NSUBSET)  =M
498C
499      KSUP(3)= 4
500      KSUP(5)= NSIZE(1)
501      KSUP(6)= KSEC3(3)
502C
503      N07=0
504      N08=0
505      N40=0
506      NDWINC=0
507      NSCAM=0
508      NSCAM07=0
509      NDWINC07=0
510      NFD=0
511
512      do i=1,100
513      NAFDWA(i)=0
514      end do
515      RETURN
516      END
517