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 BUENS4(KSEC3,KSEC4,KELEM,KVALS,VALUES,CVALS, 12 1 KBUFL,KBUFF,KERR) 13C 14C**** *BUENS4* 15C 16C 17C PURPOSE. 18C -------- 19C PACK PRELIMINARY ITEMS AND DATA OF SECTION 4 OF BUFR MESSAGE. 20C 21C 22C** INTERFACE. 23C ---------- 24C 25C *CALL* *BUENS4(KSEC3,KSEC4,KELEM,KVALS,VALUES,CVALS, 26C KBUFL,KBUFF,KERR)* 27C 28C INPUT : 29C *KSEC3* - ARRAY CONTAINING SECTION 3 INFORMATION 30C KSEC3( 1)-- LENGTH OF SECTION 3 (BYTES) 31C KSEC3( 2)-- RESERVED 32C KSEC3( 3)-- NUMBER OF SUBSETS 33C KSEC3( 4)-- FLAG (DATA TYPE,DATA COMPRESSION) 34C *KSEC4* - ARRAY CONTAINING SECTION 4 INFORMATION 35C KSEC4( 1)-- LENGTH OF SECTION 4 (BYTES) 36C KSEC4( 2)-- RESERVED 37C *KELEM* - NUMBER OF ELEMENTS IN BUFR TEMPLATE 38C *KVALS* - DIMENSION OF VALUES ARRAY 39C *VALUES* - REAL ARRAY (EXPANDED DATA VALUES) 40C 41C OUTPUT : 42C *KBUFL* - LENGTH OF BUFR MESSAGE (WORDS) 43C *KBUFF* - ARRAY CONTAINING BUFR MESSAGE 44C *KERR* - RETURNED ERROR CODE 45C 46C METHOD. 47C ------- 48C 49C NONE. 50C 51C 52C EXTERNALS. 53C ---------- 54C 55C BUPCK - PACK BIT PATHERN 56C BUPKS - PACK BIT PATHERN IN REPEATED WAY, 57C POINTER ADJUSTMENT 58C BUOCTN - SET LENGTH OF SECTION 59C 60C 61C REFERENCE. 62C ---------- 63C 64C NONE. 65C 66C AUTHOR. 67C ------- 68C 69C M. DRAGOSAVAC *ECMWF* 17/01/91. 70C 71C 72C MODIFICATIONS. 73C -------------- 74C 75C NONE. 76C 77C 78 IMPLICIT LOGICAL(L,O,G), CHARACTER*8(C,H,Y) 79C 80C 81# include "parameter.F" 82# include "bcomunit.F" 83# include "bcmwork.F" 84# include "bcmwt.F" 85# include "bcmwtc.F" 86# include "bcmbef.F" 87# include "bcprq.F" 88# include "bcmoff.F" 89C 90 CHARACTER*64 CWTEN 91 CHARACTER*24 CWTU 92C 93 DIMENSION KBUFF(KBUFL) 94C 95 DIMENSION KSEC3(JSEC3),KSEC4(JSEC4) 96#ifndef R_4 97 REAL*8 VALUES(KVALS) 98 REAL*8 RVIND 99 REAL*8 EPS 100 REAL*8 VAL,VAL8S 101 REAL*8 VCHECK 102 REAL*8 RVALS(JWORK) 103#else 104 REAL VALUES(KVALS) 105 REAL RVIND 106 REAL EPS 107 REAL VAL 108 REAL VCHECK 109 REAL RVALS(JWORK) 110#endif 111C 112 REAL*4 RVALS4(JWORK) 113 REAL*4 VAL4,VAL4S 114 INTEGER*4 I4 115 REAL*8 R8 116 REAL*4 R4 117 LOGICAL OBIG, OEQUAL 118 LOGICAL BIG_ENDIAN 119C 120 DIMENSION IVALS(JWORK),INC(JELEM),ILOCVAL(JELEM) 121 DIMENSION IIVALS(JELEM) 122C 123 CHARACTER*80 CVALS(KVALS) 124 CHARACTER*80 YVAL 125C 126 DIMENSION IMASK(8),IMAXV(32) 127 DATA IMASK/1,2,4,8,16,32,64,128/ 128C DATA ILOCVAL/JELEM*0/ 129C 130 DATA IMAXV/1,3,7,15,31,63,127,255,511,1023,2047,4095,8191, 131 1 16383,32767,65535,131071,262143,524287,1048575,2097151, 132 2 4194305,8388607,16777215,33554431,671108863,134217727, 133 3 268435455,536870911,1073741823,2147483647,2147483647/ 134C 135 SAVE IWPTB,IBPTB 136C ------------------------------------------------------------------ 137C* 1. PACK PRELIMINARY ITEMS OF SECTION 4. 138C ------------------------------------ 139 100 CONTINUE 140C 141 IF(KERR.GT.0) RETURN 142C 143#if defined(gfortran) 144 R4=HUGE(R4) 145 R8=HUGE(R8) 146#else 147 R4=3.4028235e+38 148 R8=1.7976931348623157D+308 149#endif 150C 151C* 1.1 KEEP POINTERS TO THE BEGINING OF THE SECTION. 152C --------------------------------------------- 153 110 CONTINUE 154C 155 IF(OMULTI) THEN 156 IF(NSUBSET.EQ.1) THEN 157 IWPTB = NWPT 158 IBPTB = NBPT 159 END IF 160 ELSE 161 IWPTB = NWPT 162 IBPTB = NBPT 163 END IF 164 165c IF(OMULTI.AND.NSUBSET.EQ.1) THEN 166 IF(NSUBSET.EQ.1) THEN 167C 168C* 1.2 PACK LENGTH OF SECTION 4. 169C ------------------------- 170 120 CONTINUE 171C 172 CALL BUPCK(NBPW,KBUFF(NWPT),0,NWPT,NBPT,24,KERR) 173 IF(KERR.GT.0) THEN 174 WRITE(KNTN,*) 'ERROR PACKING LENGTH OF SECTION 4.' 175 RETURN 176 END IF 177C 178C* 1.4 PACK RESERVED BYTE. 179C ------------------- 180 140 CONTINUE 181C 182 CALL BUPCK(NBPW,KBUFF(NWPT),0,NWPT,NBPT, 8,KERR) 183 IF(KERR.GT.0) THEN 184 WRITE(KNTN,*)'ERROR PACKING RESERVED BYTE IN SECTION 4.' 185 RETURN 186 END IF 187C 188 END IF 189C ----------------------------------------------------------------- 190C* 2. PACK DATA. 191C ---------- 192 200 CONTINUE 193C 194C IKK=KELEM*KSEC3(3) 195C IF(IKK.GT.JWORK) THEN 196C KERR=17 197C CALL BUERR(KERR) 198C WRITE(KNTN,*)'CHECK VALUES OF KELEM AND NUMBER OF SUBSETS KSEC3(3).' 199C RETURN 200C END IF 201C IF(IKK.GT.KVALS) THEN 202C KERR=14 203C CALL BUERR(KERR) 204C WRITE(KNTN,*)'KVALS MUST BE GREATER THAN KELEM*KSEC3(3).' 205C RETURN 206C END IF 207C 208C* 2.1 CHECK IF DATA HAS TO BE COMRESSED. 209C ---------------------------------- 210 210 CONTINUE 211C 212 IB=0 213 IF(IAND(KSEC3(4),IMASK(7)).NE.0) IB=1 214C 215C 216C ------------------------------------------------------------------ 217C 218C* 3. UNCOMPRESSED DATA. 219C ------------------ 220 300 CONTINUE 221C 222 IF(IB.EQ.0) THEN 223C 224 N=KSEC3(3) 225 IF(OMULTI) N=1 226 227 DO 301 I=1,N 228C 229 IF(OMULTI) THEN 230 IM1K=(NSUBSET-1)*KELEM 231 ELSE 232 IM1K=(I-1)*KELEM 233 END IF 234C 235 DO 302 J=1,M 236C 237 238C IF(NWTR(J).EQ.31011.OR.NWTR(J).EQ.31012) THEN 239C IRP=VALUES(J+IM1K) 240C DO III=J+2,J+IRP 241C NWTDW(iii)=0 242C END DO 243C END IF 244C 245 IF(NWTDW(J).EQ.0) GO TO 302 246C 247 248 IREF =NWTRV(J) 249 ISCALE=NWTS (J) 250 IBDW =NWTDW(J) 251C 252 JI=J+IM1K 253C 254 VAL=VALUES(JI) 255 IF(NWTEN(J).EQ.-999) THEN 256 IBYTES=NWTDW(J)/8 257 IF(ABS(VAL-RVIND)/RVIND.LE.EPS) THEN 258 IF(IBYTES.EQ.4) VAL=R4 259 IF(IBYTES.EQ.8) VAL=R8 260 END IF 261 IF(IBYTES.EQ.4) THEN 262 VAL4=VAL 263 OBIG=BIG_ENDIAN() 264 IF(.NOT.OBIG) THEN 265 CALL SWAP_BYTES4(VAL4,VAL4S) 266 VAL4=VAL4S 267 END IF 268 CALL BUGBYTESR4(VAL4,ILOCVAL,0,8,0,IBYTES) 269 ELSE 270 OBIG=BIG_ENDIAN() 271 IF(.NOT.OBIG) THEN 272 CALL SWAP_BYTES8(VAL,VAL8S) 273 VAL=VAL8S 274 END IF 275 CALL BUGBYTESR8(VAL,ILOCVAL,0,8,0,IBYTES) 276 END IF 277 ISKIP=0 278 CALL BUPKS(NBPW,KBUFF(NWPT),ILOCVAL,NWPT,NBPT,8, 279 1 ISKIP,IBYTES,KERR) 280 IF(KERR.GT.0) THEN 281 WRITE(KNTN,*)'BUENS4 :' 282 WRITE(KNTN,*)'ERROR PACKING REAL IEEE' 283 CALL BUERR(KERR) 284 RETURN 285 END IF 286 GO TO 302 287 END IF 288C 289 IF(NWTEN(J).EQ.836970) THEN 290 IF(VAL.LT.0) THEN 291 IPACK=ABS(NINT(VAL)) 292 IBDW1=1 293 CALL BUPCK(NBPW,KBUFF(NWPT),1,NWPT,NBPT,IBDW1,KERR) 294 IBDWM1=IBDW-1 295 CALL BUPCK(NBPW,KBUFF(NWPT),IPACK,NWPT,NBPT,IBDWM1,KERR) 296 ELSE 297 IPACK=NINT(VAL) 298 CALL BUPCK(NBPW,KBUFF(NWPT),IPACK,NWPT,NBPT,IBDW,KERR) 299 END IF 300 GO TO 302 301 END IF 302C 303 IF(NWTEN(J).EQ.658367) THEN 304 IF(ABS(VAL-RVIND)/RVIND.LE.EPS) THEN 305 YVAL=' ' 306 NCHAR=NWTDW(J) 307 DO 3031 II=1,NCHAR/8 308C IPACK=ICHAR(YVAL(II:II)) 309 IPACK=255 310 IF(IPACK.GT.IMAXV(8)) IPACK=IMAXV(8) 311 CALL BUPCK(NBPW,KBUFF(NWPT),IPACK,NWPT,NBPT,8,KERR) 312 IF(KERR.GT.0) THEN 313 WRITE(KNTN,*)'ERROR PACKING ',JI,' VALUE FOR ',J, 314 1 ' ELEMENT.' 315 RETURN 316 END IF 317 3031 CONTINUE 318 GO TO 302 319 320 ELSE 321 IST=NINT(VAL)/1000 322 YVAL=CVALS(IST) 323 NCHAR=NWTDW(J)/8 324 DO 303 II=1,NCHAR 325 IPACK=ICHAR(YVAL(II:II)) 326 IF(IPACK.GT.IMAXV(8)) IPACK=IMAXV(8) 327 CALL BUPCK(NBPW,KBUFF(NWPT),IPACK,NWPT,NBPT,8,KERR) 328 IF(KERR.GT.0) THEN 329 WRITE(KNTN,*)'ERROR PACKING ',JI,' VALUE FOR ',J, 330 1 ' ELEMENT.' 331 RETURN 332 END IF 333 303 CONTINUE 334 GO TO 302 335 END IF 336 END IF 337C 338 IF(ABS(VAL-RVIND)/RVIND.LE.EPS) THEN 339 CALL BUPCK(NBPW,KBUFF(NWPT),NMASK(IBDW),NWPT,NBPT,IBDW,KERR) 340 IF(KERR.GT.0) THEN 341 WRITE(KNTN,*)'ERROR PACKING ',JI,' VALUE FOR ',J, 342 1 ' ELEMENT.' 343 RETURN 344 END IF 345 ELSE 346C 347C CHECK VAL VALUE FOR POSSIBLE OVERFLOW 348C 349 350 IF(NOFL.EQ.1) THEN 351 IF(ABS(VAL).LT.EPS) VAL = 0.0 352 IF(VAL.GE.0) THEN 353 ICHECK=IMAXV(IBDW) 354 ICHECK=ICHECK+IREF 355 VCHECK=ICHECK*10.**(-ISCALE) 356C 357 IF(VAL .GT. VCHECK) THEN 358 WRITE(KNTN,*) 'VALUE=',VAL,'TOO BIG FOR ', 359 1 J,' ELEMENT ',I,' SUBSET.' 360 VAL=VCHECK+1. 361 END IF 362 ELSE 363 VCHECK=IREF/10.**ISCALE 364 IF(VAL.LT.VCHECK) THEN 365 WRITE(KNTN,*)'VALUE=',VAL,'TOO BIG NEGATIVE FOR ', 366 1 J,' ELEMENT ',I,' SUBSET.' 367 VAL=IREF/10.**ISCALE-1. 368 END IF 369 END IF 370 END IF 371 372 IF(ISCALE.LT.0) THEN 373 ISCALE=IABS(ISCALE) 374 IPACK=NINT(VAL/10.**ISCALE) - IREF 375 ELSE 376 IPACK=NINT(VAL*10.**ISCALE) - IREF 377 END IF 378C 379C CHECK IF VALUE TO BE PACKED NEGATIVE 380C 381 IF(IPACK.LT.0) THEN 382 KERR=-33 383 WRITE(KNTN,*)'BUENS4:' 384 WRITE(KNTN,*)'VALUE ',IPACK,' IS NEGATIVE' 385 WRITE(KNTN,*)'PROBABLY REFERENCE VALUE TOO BIG.' 386 WRITE(KNTN,*)J,' ELEMENT = ',NWTR(J), 387 1 ' REFERENCE VALUE = ',IREF 388 IPACK=0 389 WRITE(KNTN,*)'ELEMENT VALUE PACKED AS',IREF 390 END IF 391C 392C* CHECK IF VALUE TO BE PACKED TOO BIG. 393C 394 IF(IPACK.GT.IMAXV(IBDW)) THEN 395C 396 IF(NPMISS.EQ.0) THEN 397 KERR=-28 398 WRITE(KNTN,*)'VALUE ',IPACK,' TOO BIG.' 399 WRITE(KNTN,*)'VALUE FOR ',J,' ELEMENT AND ',I, 400 1 ' SUBSET' 401 WRITE(KNTN,*)'PACKED AS MISSING VALUE FOR', 402 1 ' DATA WIDTH -1.' 403 IPACK=IMAXV(IBDW)-1 404 ELSE 405C 406C ALL ELEMENTS IN CLASS 1 TO 9 MUST BE CORRECT 407C 408 IF(NWTR(J).GE.31000.AND.NWTR(J).LE.31012) THEN 409 WRITE(KNTN,*)'VALUE ',IPACK,' TOO BIG.' 410 WRITE(KNTN,*)'VALUE FOR ',J,' ELEMENT AND ',I, 411 1 ' SUBSET' 412 KERR=28 413 CALL BUERR(KERR) 414 RETURN 415 END IF 416C 417 KERR=-28 418 WRITE(KNTN,*)'VALUE ',IPACK,' TOO BIG.' 419 WRITE(KNTN,*)'VALUE FOR ',J,' ELEMENT AND ',I, 420 1 ' SUBSET' 421 WRITE(KNTN,*)'PACKED AS MISSING VALUE FOR', 422 1 ' DATA WIDTH.' 423 IPACK=IMAXV(IBDW) 424 END IF 425 END IF 426 CALL BUPCK(NBPW,KBUFF(NWPT),IPACK,NWPT,NBPT,IBDW,KERR) 427 IF(KERR.GT.0) THEN 428 WRITE(KNTN,*)'ERROR PACKING ',JI,' VALUE FOR ',J, 429 1 ' ELEMENT.' 430 WRITE(KNTN,*)'VALUE ',IPACK,' DATA WIDTH ',IBDW, 431 1 ' BITS' 432 RETURN 433 END IF 434 END IF 435C 436 302 CONTINUE 437 301 CONTINUE 438C 439 NWP=NWPT 440 NBP=NBPT 441 END IF 442C 443C* 4. COMPRESS DATA. 444C -------------- 445 400 CONTINUE 446C 447 IF(IB.EQ.1) THEN 448 DO 402 J=1,M 449C 450 IF(NWTDW(J).EQ.0) GO TO 402 451C 452 IREF =NWTRV(J) 453 ISCALE=NWTS (J) 454 IBDW =NWTDW(J) 455C 456 DO 401 I=1,KSEC3(3) 457C 458 JI=J+(I-1)*KELEM 459C 460 IF(NWTEN(J).EQ.658367) THEN 461 IVALS(JI)=VALUES(JI) 462 GO TO 401 463 END IF 464C 465 IF(NWTEN(J).EQ.-999) THEN 466 IF(NWTDW(J).EQ.32) THEN 467 IF(ABS(VALUES(JI)-RVIND)/RVIND.LT.EPS) THEN 468 RVALS4(JI)=R4 469 ELSE 470 RVALS4(JI)=VALUES(JI) 471 END IF 472 ELSE 473 IF(ABS(VALUES(JI)-RVIND)/RVIND.LT.EPS) THEN 474 RVALS(JI)=R8 475 ELSE 476 RVALS(JI)=VALUES(JI) 477 END IF 478 END IF 479 GO TO 401 480 END IF 481C 482 IF(NWTEN(J).EQ.836970) THEN 483 ISG_REF=0 484 IF(VALUES(JI).LT.0) ISG_REF=1 485 IVALS(JI)=IABS(NINT(VALUES(JI))) 486 GO TO 401 487 END IF 488C 489 IF(ABS(VALUES(JI)-RVIND)/RVIND.LE.EPS) THEN 490 IVALS(JI)=NMASK(IBDW) 491 ELSE 492 IF(NOFL.EQ.1) THEN 493 IF(VALUES(JI).GE.0) THEN 494 ICHECK=IMAXV(IBDW) 495 ICHECK=ICHECK+IREF 496 VCHECK=ICHECK*10.**(-ISCALE) 497C 498 IF(VALUES(JI) .GT. VCHECK) THEN 499 WRITE(KNTN,*) 'VALUE=',VALUES(JI),'TOO BIG FOR ', 500 1 J,' ELEMENT AND ',I,' SUBSET.' 501 VALUES(JI)=VCHECK+1. 502 END IF 503 ELSE 504 VCHECK=IREF/10.**ISCALE 505 IF(VALUES(JI).LT.VCHECK) THEN 506 WRITE(KNTN,*) 'VALUE=',VALUES(JI), 507 1 'TOO BIG NEGATIVE FOR ', 508 1 J,' ELEMENT AND ',I,' SUBSET.' 509 VALUES(JI)=IREF/10.**ISCALE-1. 510 END IF 511 END IF 512 END IF 513C 514 IF(ISCALE.LT.0) THEN 515 ISCAL=IABS(ISCALE) 516 IPACK=NINT(VALUES(JI)/10.**ISCAL ) - IREF 517 ELSE 518 IPACK=NINT(VALUES(JI)*10.**ISCALE) - IREF 519 END IF 520C 521 IF(IPACK.LT.0) THEN 522 WRITE(KNTN,*)'BUENS4 :' 523 KERR=-33 524 WRITE(KNTN,*)'VALUE ',IPACK,' IS NEGATIVE' 525 WRITE(KNTN,*)'PROBABLY REFERENCE VALUE TOO BIG.' 526 WRITE(KNTN,*)J,'ELEMENT = ',NWTR(J), 527 1 ' REFERENCE VALUE = ',IREF 528 IPACK=0 529 WRITE(KNTN,*)'ELEMENT PACKED AS',IREF 530 END IF 531C 532C REPLACE IPACK VALUE WITH MISSING VALUE FOR IBDW -1 533C IF GREATER THEN MAXIMUM ALLOWED. 534C 535 IF(IPACK.GT.IMAXV(IBDW)) THEN 536C 537 IF(NPMISS.EQ.0) THEN 538 KERR=-28 539 WRITE(KNTN,*)'VALUE ',IPACK,' TOO BIG.' 540 WRITE(KNTN,*)'VALUE FOR ',J,' ELEMENT AND ',I, 541 1 ' SUBSET' 542 WRITE(KNTN,*)'PACKED AS MISSING VALUE FOR DATA ', 543 1 'WIDTH -1.' 544 IPACK=IMAXV(IBDW)-1 545 ELSE 546C 547C ALL ELEMENTS IN CLASS 1 TO 9 MUST BE CORRECT 548C 549 IF(NWTR(J).GE.31000.AND.NWTR(J).LE.31012) THEN 550 KERR=28 551 CALL BUERR(KERR) 552 WRITE(KNTN,*)'VALUE ',IPACK,' TOO BIG.' 553 WRITE(KNTN,*)'VALUE FOR ',J,' ELEMENT AND ',I, 554 1 ' SUBSET' 555 RETURN 556 END IF 557C 558 KERR=-28 559 WRITE(KNTN,*)'VALUE ',IPACK,' TOO BIG.' 560 WRITE(KNTN,*)'VALUE FOR ',J,' ELEMENT AND ',I, 561 1 ' SUBSET' 562 WRITE(KNTN,*)'PACKED AS MISSING VALUE.' 563 IPACK=IMAXV(IBDW) 564 END IF 565 END IF 566 IVALS(JI)=IPACK 567C 568 END IF 569C 570 401 CONTINUE 571 402 CONTINUE 572C 573C* 4.1 CHECK IF ALL VALUES ARE MISSING. 574C 575 410 CONTINUE 576C 577 DO 411 I=1,M 578C 579 IF(NWTDW(I).EQ.0) GO TO 411 580 IBDW =NWTDW(I) 581C 582 OMIS=.TRUE. 583 IF(NWTEN(I).EQ.658367) THEN 584 OMIS=.FALSE. 585 ELSEIF(NWTEN(I).EQ.-999) THEN 586 OMIS=.FALSE. 587 ELSE 588 DO 412 J=1,KSEC3(3) 589 IJ=I+(J-1)*KELEM 590 IF(IVALS(IJ).NE.NMASK(IBDW)) THEN 591 OMIS=.FALSE. 592 END IF 593 412 CONTINUE 594 END IF 595C 596 IF(.NOT.OMIS) THEN 597C 598 IF(NWTEN(I).NE.658367.AND.NWTEN(I).NE.-999) THEN 599C 600C FIND MINIMUM VALUE FOR ELEMENT 601C 602 MIN=IVALS(I) 603 DO 413 J=1,KSEC3(3) 604 IJ=I+(J-1)*KELEM 605 IF(IVALS(IJ).LT.MIN) MIN=IVALS(IJ) 606 413 CONTINUE 607C 608C FIND INCREMENTS 609C 610 DO 414 J=1,KSEC3(3) 611 IJ=I+(J-1)*KELEM 612 INC(J)=IVALS(IJ)-MIN 613 IF(IVALS(IJ).EQ.NMASK(IBDW)) INC(J)=NVIND 614 414 CONTINUE 615C 616C FIND NUMBER OF BITS NEEDED FOR MAX VALUE OF INCREMENT 617C 618 MAX=0 619 DO 415 J=1,KSEC3(3) 620 IF(INC(J).NE.NVIND.AND.INC(J).GT.MAX) MAX=INC(J) 621 415 CONTINUE 622C 623C CHECK IF ALL INCREMENTS ARE ZERO 624C 625 INC0=0 626 DO 419 J=1,KSEC3(3) 627 IF(INC(J).NE.0) INC0=1 628 419 CONTINUE 629C 630C FIND NUMBER OF BITS NEEDED 631C 632 IF(INC0.NE.0) THEN 633 MAX=MAX+1 634 DO 416 J=1,32 635 IR=MAX/2 636 IF(IR.EQ.0) GO TO 417 637 MAX=IR 638 416 CONTINUE 639C 640 END IF 641C 642 417 CONTINUE 643C 644 INCBIT=0 645 IF(INC0.NE.0) INCBIT=J 646C 647C REPLACE MISSING VALUES FOR INCREMENT BY ALL BITS SET TO 1. 648C 649 DO 418 J=1,KSEC3(3) 650 IF(INC(J).EQ.NVIND) INC(J)=NMASK(INCBIT) 651 418 CONTINUE 652 END IF 653 END IF 654C 655C* 4.2 PACK DATA IN COMPRESSED FORM. 656C ----------------------------- 657 420 CONTINUE 658C 659 IF(NWTEN(I).EQ.658367) THEN 660C 661 OSTRING=.TRUE. 662 JI1=I 663 IST1=IVALS(JI1)/1000 664 ICS=NWTDW(I)/8 665C ICS=NINT(VALUES(JI1))-IST1*1000 666 NCSMAX=ICS 667 DO IX=ICS,1,-1 668 IF(CVALS(IST1)(IX:IX).NE.' ') THEN 669 NCS=IX 670 GO TO 522 671 END IF 672 END DO 673 674 522 NCSMAX=NCS 675 DO J=2,KSEC3(3) 676 JI=I+(J-1)*KELEM 677 IST=VALUES(JI)/1000 678 IF(CVALS(IST1).NE.CVALS(IST)) OSTRING=.FALSE. 679C FIND MAX SIZE OF STRINGS 680 ICS=NWTDW(I)/8 681C ICS=NINT(VALUES(JI))-IST*1000 682 DO IX=ICS,1,-1 683 IF(CVALS(IST)(IX:IX).NE.' ') THEN 684 NCS=IX 685 GO TO 521 686 END IF 687 END DO 688 521 CONTINUE 689 IF(NCS.GT.NCSMAX) NCSMAX=NCS 690 END DO 691 692C 693 IF(OSTRING) THEN 694C 695 INCHAR=NWTDW(I)/8 696 ISKIP=0 697 DO II=1,INCHAR 698 IPACK=ICHAR(CVALS(IST1)(II:II)) 699 CALL BUPCK(NBPW,KBUFF(NWPT),IPACK,NWPT,NBPT,8,KERR) 700 IF(KERR.GT.0) THEN 701 WRITE(KNTN,*)'BUENS4 :' 702 CALL BUERR(KERR) 703 RETURN 704 END IF 705 END DO 706 IPACK=0 707 CALL BUPCK(NBPW,KBUFF(NWPT),IPACK,NWPT,NBPT,6,KERR) 708 IF(KERR.GT.0) THEN 709 WRITE(KNTN,*)'BUENS4 :' 710 CALL BUERR(KERR) 711 RETURN 712 END IF 713 ELSE 714C 715C PACK LOCAL REFERENCE VALUE FOR ELEMENT 716C 717 INCHAR=NWTDW(I)/8 718 ISKIP=0 719 CALL BUPKS(NBPW,KBUFF(NWPT),ILOCVAL,NWPT,NBPT,8, 720 1 ISKIP,INCHAR,KERR) 721 IF(KERR.GT.0) THEN 722 WRITE(KNTN,*)'BUENS4 :' 723 WRITE(KNTN,*)'ERROR PACKING LOCAL REFERENCE VALUE' 724 CALL BUERR(KERR) 725 RETURN 726 END IF 727C 728C PACK NUMBER OF BITS FOR INCREMENTS/NUMBER OF CHARACTERS 729C 730C CALL BUPCK(NBPW,KBUFF(NWPT),INCHAR,NWPT,NBPT,6,KERR) 731 CALL BUPCK(NBPW,KBUFF(NWPT),NCSMAX,NWPT,NBPT,6,KERR) 732 IF(KERR.GT.0) THEN 733 WRITE(KNTN,*)'BUENS4 :' 734 WRITE(KNTN,*)'ERROR PACKING NUMBER OF BITS FOR INCREMENTS' 735 CALL BUERR(KERR) 736 RETURN 737 END IF 738C 739C PACK INCREMENTS 740C 741 DO 421 J=1,KSEC3(3) 742C 743 JI=I+(J-1)*KELEM 744C 745 IST=IVALS(JI)/1000 746 YVAL=CVALS(IST) 747C 748 DO 423 II=1,NCSMAX 749 IPACK=ICHAR(YVAL(II:II)) 750 CALL BUPCK(NBPW,KBUFF(NWPT),IPACK,NWPT,NBPT,8,KERR) 751 IF(KERR.GT.0) THEN 752 WRITE(KNTN,*)'BUENS4 :' 753 CALL BUERR(KERR) 754 RETURN 755 END IF 756 423 CONTINUE 757C 758 421 CONTINUE 759C 760 END IF 761 ELSEIF(NWTEN(I).EQ.-999) THEN 762C 763 OEQUAL=.TRUE. 764 DO J=1,KSEC3(3)-1 765 JI=I+(J-1)*KELEM 766 JII=I+J*KELEM 767 IF(NWTDW(I).EQ.32) THEN 768 IF(ABS(RVALS4(JI)-RVALS4(JII))/RVALS4(JII).GT.EPS) THEN 769 OEQUAL=.FALSE. 770 GO TO 4444 771 END IF 772 773 ELSE 774 IF(ABS(RVALS(JI)-RVALS(JII))/RVALS(JII).GT.EPS) THEN 775 OEQUAL=.FALSE. 776 GO TO 4444 777 END IF 778 END IF 779 END DO 780C 781C PACK LOCAL REFERENCE VALUE FOR ELEMENT 782C 7834444 INCHAR=NWTDW(I)/8 784 ISKIP=0 785 786 IF(.NOT.OEQUAL) THEN 787C 788 CALL BUPKS(NBPW,KBUFF(NWPT),ILOCVAL,NWPT,NBPT,8, 789 1 ISKIP,INCHAR,KERR) 790 IF(KERR.GT.0) THEN 791 WRITE(KNTN,*)'BUENS4 :' 792 WRITE(KNTN,*)'ERROR PACKING LOCAL REFERENCE VALUE' 793 CALL BUERR(KERR) 794 RETURN 795 END IF 796C 797C PACK NUMBER OF BITS FOR INCREMENTS/NUMBER OF CHARACTERS 798C 799 CALL BUPCK(NBPW,KBUFF(NWPT),INCHAR,NWPT,NBPT,6,KERR) 800 IF(KERR.GT.0) THEN 801 WRITE(KNTN,*)'BUENS4 :' 802 WRITE(KNTN,*)'ERROR PACKING NUMBER OF BITS 803 1 FOR INCREMENTS' 804 CALL BUERR(KERR) 805 RETURN 806 END IF 807C 808C PACK INCREMENTS 809C 810 DO J=1,KSEC3(3) 811C 812 JI=I+(J-1)*KELEM 813C 814 IF(NWTDW(I).EQ.32) THEN 815 VAL4=RVALS4(JI) 816 CALL BUGBYTESR4(VAL4,IIVALS,0,8,0,INCHAR) 817 ELSE 818 VAL=RVALS(JI) 819 CALL BUGBYTESR8(VAL,IIVALS,0,8,0,INCHAR) 820 END IF 821C 822 DO IZ=1,INCHAR 823 IPACK=IIVALS(IZ) 824 CALL BUPCK(NBPW,KBUFF(NWPT),IPACK,NWPT,NBPT,8,KERR) 825 END DO 826C 827 END DO 828 829 ELSE 830 831 IBYTES=NWTDW(I)/8 832 IF(IBYTES.EQ.4) THEN 833 VAL4=RVALS4(I) 834 OBIG=BIG_ENDIAN() 835 IF(.NOT.OBIG) THEN 836 CALL SWAP_BYTES4(VAL4,VAL4S) 837 VAL4=VAL4S 838 END IF 839 CALL BUGBYTESR4(VAL4,ILOCVAL,0,8,0,IBYTES) 840 ELSE 841 VAL=RVALS(I) 842 OBIG=BIG_ENDIAN() 843 IF(.NOT.OBIG) THEN 844 CALL SWAP_BYTES8(VAL,VAL8S) 845 VAL=VAL8S 846 END IF 847 CALL BUGBYTESR8(VAL,ILOCVAL,0,8,0,IBYTES) 848 END IF 849 ISKIP=0 850 CALL BUPKS(NBPW,KBUFF(NWPT),ILOCVAL,NWPT,NBPT,8, 851 1 ISKIP,IBYTES,KERR) 852 IF(KERR.GT.0) THEN 853 WRITE(KNTN,*)'BUENS4 :' 854 WRITE(KNTN,*)'ERROR PACKING REAL IEEE' 855 CALL BUERR(KERR) 856 RETURN 857 END IF 858C 859 CALL BUPCK(NBPW,KBUFF(NWPT),0,NWPT,NBPT,6,KERR) 860 IF(KERR.GT.0) THEN 861 WRITE(KNTN,*)'BUENS4 :' 862 WRITE(KNTN,*)'ERROR PACKING NUMBER OF BITS FOR' 863 WRITE(KNTN,*)'INCREMENTS FOR ',I,' ELEMENT.' 864 RETURN 865 END IF 866 867 END IF 868C 869 4211 CONTINUE 870C 871 ELSE 872 IF(OMIS) THEN 873C 874C PACK LOCAL REFERENCE VALUE FOR ELEMENT SET TO MISSING VALUE. 875C 876 CALL BUPCK(NBPW,KBUFF(NWPT),NMASK(IBDW),NWPT,NBPT, 877 1 IBDW,KERR) 878 IF(KERR.GT.0) THEN 879 WRITE(KNTN,*)'BUENS4 :' 880 WRITE(KNTN,*)'ERROR PACKING LOCAL REFERENCE VALUE ' 881 WRITE(KNTN,*)I,' ELEMENT.' 882 RETURN 883 END IF 884C 885C PACK NUMBER OF BITS FOR INCREMENTS (SET TO ZERO) 886C 887 CALL BUPCK(NBPW,KBUFF(NWPT),0,NWPT,NBPT,6,KERR) 888 IF(KERR.GT.0) THEN 889 WRITE(KNTN,*)'BUENS4 :' 890 WRITE(KNTN,*)'ERROR PACKING NUMBER OF BITS FOR' 891 WRITE(KNTN,*)'INCREMENTS FOR ',I,' ELEMENT.' 892 RETURN 893 END IF 894C 895 ELSE 896C 897 IF(INCBIT.EQ.0) THEN 898C 899C 900C PACK LOCAL REFERENCE VALUE FOR ELEMENT 901C 902 IF(NWTEN(I).EQ.836970) THEN 903 IF(ISG_REF.EQ.1) THEN 904 CALL BUPCK(NBPW,KBUFF(NWPT),1,NWPT,NBPT,1,KERR) 905 CALL BUPCK(NBPW,KBUFF(NWPT),MIN,NWPT,NBPT,IBDW-1, 906 1 KERR) 907 ELSE 908 CALL BUPCK(NBPW,KBUFF(NWPT),MIN,NWPT,NBPT,IBDW, 909 1 KERR) 910 IF(KERR.GT.0) THEN 911 WRITE(KNTN,*)'BUENS4 :' 912 WRITE(KNTN,*)'ERROR PACKING LOCAL REFERENCE VALUE' 913 WRITE(KNTN,*)'FOR ',I,' ELEMENT IN ',IBDW,' BITS.' 914 RETURN 915 END IF 916 END IF 917 ELSE 918 CALL BUPCK(NBPW,KBUFF(NWPT),MIN,NWPT,NBPT,IBDW,KERR) 919 IF(KERR.GT.0) THEN 920 WRITE(KNTN,*)'BUENS4 :' 921 WRITE(KNTN,*)'ERROR PACKING LOCAL REFERENCE VALUE' 922 WRITE(KNTN,*)'FOR ',I,' ELEMENT IN ',IBDW,' BITS.' 923 RETURN 924 END IF 925 ENDIF 926C 927C PACK NUMBER OF BITS FOR INCREMENTS 928C 929 CALL BUPCK(NBPW,KBUFF(NWPT),INCBIT,NWPT,NBPT,6,KERR) 930 IF(KERR.GT.0) THEN 931 WRITE(KNTN,*)'BUENS4 :' 932 WRITE(KNTN,*)'ERROR PACKING NUMBER OF BITS FOR' 933 WRITE(KNTN,*)'INCREMENTS FOR ',I,' ELEMENT.' 934 RETURN 935 END IF 936C 937 ELSE 938C 939C PACK LOCAL REFERENCE VALUE FOR ELEMENT 940C 941 IF(NWTEN(I).EQ.836970) THEN 942 IF(ISG_REF.EQ.1) THEN 943 CALL BUPCK(NBPW,KBUFF(NWPT),1,NWPT,NBPT,1,KERR) 944 CALL BUPCK(NBPW,KBUFF(NWPT),MIN,NWPT,NBPT, 945 1 IBDW-1,KERR) 946 ELSE 947 CALL BUPCK(NBPW,KBUFF(NWPT),MIN,NWPT,NBPT,IBDW, 948 1 KERR) 949 IF(KERR.GT.0) THEN 950 WRITE(KNTN,*)'BUENS4 :' 951 WRITE(KNTN,*)'ERROR PACKING LOCAL REFERENCE VALUE' 952 WRITE(KNTN,*)'FOR ',I,' ELEMENT IN ',IBDW,' BITS.' 953 RETURN 954 END IF 955 END IF 956 ELSE 957 CALL BUPCK(NBPW,KBUFF(NWPT),MIN,NWPT,NBPT,IBDW, 958 1 KERR) 959 IF(KERR.GT.0) THEN 960 WRITE(KNTN,*)'BUENS4 :' 961 WRITE(KNTN,*)'ERROR PACKING LOCAL REFERENCE VALUE' 962 WRITE(KNTN,*)'FOR ',I,' ELEMENT IN ',IBDW,' BITS.' 963 RETURN 964 END IF 965 ENDIF 966 967C 968C PACK NUMBER OF BITS FOR INCREMENTS 969C 970 CALL BUPCK(NBPW,KBUFF(NWPT),INCBIT,NWPT,NBPT,6,KERR) 971 IF(KERR.GT.0) THEN 972 WRITE(KNTN,*)'BUENS4 :' 973 WRITE(KNTN,*)'ERROR PACKING NUMBER OF BITS FOR' 974 WRITE(KNTN,*) 'INCREMENTS FOR ',I,' ELEMENT.' 975 RETURN 976 END IF 977C 978C PACK INCREMENTS 979C 980 CALL BUPKS(NBPW,KBUFF(NWPT),INC,NWPT,NBPT, 981 1 INCBIT,0,KSEC3(3),KERR) 982 IF(KERR.GT.0) THEN 983 WRITE(KNTN,*) 'BUENS4 :' 984 WRITE(KNTN,*) 'ERROR PACKING INCREMENTS FOR',I, 985 1 ' ELEMENT' 986 RETURN 987 END IF 988C 989 END IF 990 END IF 991 END IF 992C 993 411 CONTINUE 994C 995 END IF 996C 997C* 5. SET UP LENGTH OF THE SECTION 4. 998C -------------------------------- 999 500 CONTINUE 1000C 1001 IF(OMULTI) THEN 1002 IF(NSUBSET.EQ.KSEC3(3)) THEN 1003 CALL BUOCTN(IWPTB,IBPTB,KBUFL,KBUFF,KERR) 1004 IF(KERR.GT.0) THEN 1005 CALL BUERR(KERR) 1006 RETURN 1007 END IF 1008 END IF 1009 ELSE 1010 CALL BUOCTN(IWPTB,IBPTB,KBUFL,KBUFF,KERR) 1011 IF(KERR.GT.0) THEN 1012 CALL BUERR(KERR) 1013 RETURN 1014 END IF 1015 END IF 1016C 1017C ------------------------------------------------------------------ 1018 RETURN 1019 END 1020