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