1 PROGRAM BUCOMPRESS 2C 3C**** *BUFR* 4C 5C 6C PURPOSE. 7C -------- 8C 9C PACKS BUFR MULTI SUBSET DATA IN THE COMPRESSED FORM 10C THE NUMBER OF SUBSETS TO BE COMPRESSED IS DEFINED IN 11C THE NAMLIST FILE. 12C 13C 14C** INTERFACE. 15C ---------- 16C 17C BUCOMPRESS OUTFILE NAMELIST_FILENAME 18C 19C METHOD. 20C ------- 21C 22C NONE. 23C 24C 25C EXTERNALS. 26C ---------- 27C 28C CALL BUSEL 29C CALL BUFREX 30C CALL BUFREN 31C CALL BUPRS0 32C CALL BUPRS1 33C CALL BUPRS2 34C CALL BUPRS3 35C CALL BUPRT 36C CALL BUUKEY 37C 38C REFERENCE. 39C ---------- 40C 41C NONE. 42C 43C AUTHOR. 44C ------- 45C 46C M. DRAGOSAVAC *ECMWF* 15/09/87. 47C 48C 49C MODIFICATIONS. 50C -------------- 51C 52C NONE. 53C 54C 55 IMPLICIT LOGICAL(L,O,G), CHARACTER*8(C,H,Y) 56C 57 PARAMETER(JSUP = 9,JSEC0= 3,JSEC1= 40,JSEC2=4096 ,JSEC3= 4, 58 1 JSEC4= 2,JELEM=160000,JSUBS=400,JCVAL=150 ,JBUFL=512000, 59 2 JBPW = 32,JTAB =3000,JCTAB=120,JCTST=1800,JCTEXT=1200, 60 3 JWORK=4096000,JKEY=46,JBYTE=512000) 61C 62 PARAMETER (JTYPE=256) 63 PARAMETER (KELEM=20000) 64 PARAMETER (KVALS=80000) 65C 66 DIMENSION KBUFF(JBUFL) 67 DIMENSION KBUFR(JBUFL) 68 DIMENSION KSUP(JSUP) ,KSEC0(JSEC0),KSEC1(JSEC1) 69 DIMENSION KSEC2(JSEC2),KSEC3(JSEC3),KSEC4(JSEC4) 70 DIMENSION KEY (JKEY),KREQ(2) 71C 72 REAL*8 VALUES(KVALS),VALUE(KVALS),VALS(KVALS) 73 REAL*8 RVIND,EPS 74C 75 DIMENSION KTDLST(KELEM),KTDEXP(KELEM) 76 DIMENSION KDATA(200) 77 DIMENSION ICOMP(JTYPE) 78C 79 CHARACTER*256 CARG(4),COUT,CFIN 80 CHARACTER*64 CNAMES(KELEM) 81 CHARACTER*24 CUNITS(KELEM) 82 CHARACTER*80 CVALS(KVALS) 83 CHARACTER*80 CVAL(KVALS) 84 CHARACTER*80 YENC 85C 86 CHARACTER*5 CFNAME(JTYPE) 87C 88C DATA CFNAME/'st001','st002','st003','st004','st005', 89C 1 'st009','st011','st012','st013','st014', 90C 2 'st019','st021','st022','st023','st051', 91C 2 'st061','st062','st063','st071','st072', 92C 3 'st073','st082','st083','st084','st085', 93C 4 'st091','st092','st095','st101','st102', 94C 5 'st103','st104','st105','st106','st121', 95C 6 'st122','st123','st124','st125','st127', 96C 7 'st128','st131','st132','st133','st142', 97C 8 'st144','st145','st164'/ 98C 99C DATA ICOMP/200,200,200,200,200, 100C 1 200,200,200,200,200, 101C 2 200,200,200,200,052, 102C 2 052,052,052,052,052, 103C 3 052,050,050,050,050, 104C 4 001,001,001,001,001, 105C 5 001,001,001,001,001, 106C 5 361,001,001,001,001, 107C 7 -1,001,200,200,200, 108C 8 100/ 109C 110 DATA CFNAME/JTYPE*' '/ 111 NAMELIST /COMPRESS/ CFNAME,ICOMP 112cs EXTERNAL GETARG 113C 114C ------------------------------------------------------------------ 115C* 1. INITIALIZE CONSTANTS AND VARIABLES. 116C ----------------------------------- 117 100 CONTINUE 118C 119C MISSING VALUE INDICATOR 120C 121 RVIND=1.7E38 122 NVIND=2147483647 123 NREAD=0 124 NSUBS=0 125 NW=0 126 ITOTAL=0 127 NBYTES=JBPW/8 128C 129C 130C GET INPUT AND OUTPUT FILE NAME. 131C 132 NARG=IARGC() 133C 134 IF(NARG.LT.4) THEN 135 PRINT*,'USAGE -- bufr_compress -i namelist -o outfile' 136 STOP 137 END IF 138C 139 DO 101 J=1,NARG 140 CALL GETARG(J,CARG(J)) 141 101 CONTINUE 142C 143 DO 102 J=1,NARG,2 144 IF(CARG(J).EQ.'-i') THEN 145 CFIN=CARG(J+1) 146 ELSEIF(CARG(J).EQ.'-o') THEN 147 COUT=CARG(J+1) 148 ELSE 149 PRINT*,'USAGE -- bufr_compress -i namelist -o outfile' 150 STOP 151 END IF 152102 CONTINUE 153C 154 KRQL=0 155 NR=0 156 KREQ(1)=0 157 KREQ(2)=0 158C 159C* 1.2 OPEN NAMELIST AND OUTPUT FILE 160C ----------------------------- 161 120 CONTINUE 162C 163C OPEN NAMELIST 164C 165 OPEN(UNIT=60,FILE=CFIN,ERR=125,IOSTAT=IOS, 166 1 STATUS='OLD', 167 2 FORM='FORMATTED') 168C 169 GO TO 126 170C 171 125 CONTINUE 172C 173 PRINT*,'OPEN ERRO ON NAMELIST FILE.' 174 CALL MY_EXIT(2) 175C 176 126 CONTINUE 177C 178 READ(60,COMPRESS) 179 CLOSE(60) 180C 181C CHECK HOW MANY FILES IN THE NAMELIST 182C 183 NFILES=256 184C DO 127 I=1,JTYPE 185C IF(CFNAME(I).EQ.' ') THEN 186C NFILES=I-1 187C GO TO 128 188C END IF 189C127 CONTINUE 190C 191 128 CONTINUE 192C 193C OPEN OUTPUT FILE 194C 195 PRINT*,'NUMBER OF FILES TO PROCESS=',NFILES 196 II=INDEX(COUT,' ') 197 II=II-1 198 CALL PBOPEN(IUNIT1,COUT(1:II),'A',IRET) 199 IF(IRET.EQ.-1) STOP 'OPEN FAILED ON OUTPUT FILE' 200 IF(IRET.EQ.-2) STOP 'INVALID FILE NAME' 201 IF(IRET.EQ.-3) STOP 'INVALID OPEN MODE SPECIFIED' 202C 203C OPEN INPUT FILES 204C 205 DO 121 IO=1,NFILES 206C 207 IRET=0 208 CALL PBOPEN(IUNIT,CFNAME(IO),'R',IRET) 209 IF(IRET.EQ.-1) THEN 210 GO TO 121 211 END IF 212 IF(IRET.EQ.-2) STOP 'INVALID FILE NAME' 213 IF(IRET.EQ.-3) STOP 'INVALID OPEN MODE SPECIFIED' 214C 215C 216C ----------------------------------------------------------------- 217C* 2. SET REQUEST FOR EXPANSION. 218C -------------------------- 219 200 CONTINUE 220C 221 ICODE=0 222 NCOM=ICOMP(IO) 223 OCOMP=.TRUE. 224C 225C 226C ----------------------------------------------------------------- 227C* 3. READ BUFR MESSAGE. 228C ------------------ 229 300 CONTINUE 230C 231 IERR=0 232 KBUFL=0 233C 234 IRET=0 235 CALL PBBUFR(IUNIT,KBUFF,JBYTE,KBUFL,IRET) 236 IF(IRET.EQ.-1) THEN 237 IF(N.NE.0) GO TO 600 238 GO TO 122 239 END IF 240 IF(IRET.EQ.-2) STOP 'FILE HANDLING PROBLEM' 241 IF(IRET.EQ.-3) STOP 'ARRAY TOO SMALL FOR PRODUCT' 242C 243 NREAD=NREAD+1 244 KBUFL=KBUFL/NBYTES+1 245C 246C ----------------------------------------------------------------- 247C* 4. EXPAND BUFR MESSAGE. 248C -------------------- 249 400 CONTINUE 250C 251 CALL BUS012(KBUFL,KBUFF,KSUP,KSEC0,KSEC1,KSEC2,KERR) 252 IF(KERR.NE.0) THEN 253 PRINT*,'ERROR IN BUS012: ',KERR 254 PRINT*,' BUFR MESSAGE NUMBER ',N,' CORRUPTED.' 255 KERR=0 256 GO TO 300 257 END IF 258C 259 KEL=KELEM 260 IF(KSUP(6).GT.1) KEL=JWORK/KSUP(6) 261C 262 CALL BUFREX(KBUFL,KBUFF,KSUP,KSEC0 ,KSEC1,KSEC2 ,KSEC3 ,KSEC4, 263 1 KEL,CNAMES,CUNITS,KVALS,VALUES,CVALS,IERR) 264C 265 IF(IERR.NE.0) THEN 266 IF(IERR.EQ.2) THEN 267 IERR=0 268 ELSE 269 CALL MY_EXIT(2) 270 END IF 271 END IF 272C 273 NSUBS=NSUBS+KSEC3(3) 274C 275C ----------------------------------------------------------------- 276C* 5. COLLECT DATA FOR REPACKING. 277C --------------------------- 278 500 CONTINUE 279C 280C FIRST GET DATA DESCRIPTORS 281C 282 CALL BUSEL(KTDLEN,KTDLST,KTDEXL,KTDEXP,KERR) 283 IF(KERR.NE.0) CALL MY_EXIT(2) 284C 285C CHECK IF ANOUGH SPACE FOR COMPRESSION 286C 287C 288C CHECK FOR MAXIMUM NUMBER OF SUBSETS TO BE PACKED 289C 290 IF(NCOM.LT.0) THEN 291 NCOM=JWORK/KTDEXL 292 WRITE(*,'(I4,A,I3)') 293 1 NCOM,' SUB-SETS COMPRESSED FOR SUB-TYPE ',KSEC1(7) 294 ELSE 295 IF(NCOM*KTDEXL.GT.JWORK) THEN 296 PRINT*,'TOO MANY SUBSETS TO BE PACKED.' 297 PRINT*,'MAXIMUM NUMBER OF SUBSETS TO BE PACKED =',JWORK/KTDEXL 298 CALL MY_EXIT(2) 299 END IF 300 END IF 301C 302 DO 503 J=1,KSUP(6) 303 N=N+1 304C 305 DO 502 I=1,KSUP(5) 306 IV=I+(J-1)*KEL 307 IN=I+(N-1)*KSUP(5) 308C 309 IF(CUNITS(I).EQ.'CCITTIA5') THEN 310 IPOS =VALUES(IV)/1000. 311 ICHAR=NINT(VALUES(IV)-IPOS*1000) 312 KKK=KKK+1 313 VALUE(IN)=KKK*1000+ICHAR 314 CVAL(KKK)=CVALS(IPOS) 315 ELSE 316 VALUE(IN)=VALUES(IV) 317 END IF 318 502 CONTINUE 319 IF(N.EQ.NCOM) THEN 320 JLAST=J 321 GO TO 600 322 END IF 323 503 CONTINUE 324C 325 IF(N.EQ.NCOM) GO TO 600 326C 327 GO TO 300 328C ----------------------------------------------------------------- 329C* 6. PACK BUFR MESSAGE BACK INTO BUFR. 330C --------------------------------- 331 600 CONTINUE 332C 333 334 KKK=0 335 KSEC3(3)=N 336 KSEC1(8)=1 337 KSEC3(4)=128 ! NO COMPRESSION 338 IF(KSEC3(3).GT.1) KSEC3(4)=192 ! COMPRESSION 339 N=0 340 KBUFL=JBUFL 341C 342C GET REPLICATION FACTORS 343C 344 KK=0 345 DO 601 K=1,KSUP(5) 346 IF(KTDEXP(K).EQ.31001.OR.KTDEXP(K).EQ.31002.OR. 347 1 KTDEXP(K).EQ.31011.OR.KTDEXP(K).EQ.31012) THEN 348 KK=KK+1 349 KDATA(KK)=NINT(VALUES(K)) 350 END IF 351 601 CONTINUE 352C 353 KDLEN=2 354 IF(KK.NE.0) KDLEN=KK 355C 356C* 6.2 ENCODE DATA INTO BUFR MESSAGE. 357C ------------------------------ 358 620 CONTINUE 359C 360C CALL BUUKEY(KSEC1,KSEC2,KEY,KSUP,KERR) 361C 362C PACK RDB KEY 363C 364C 365 KLM=KSUP(5) 366C 367 CALL SETLALO(KSEC1(7),KLA,KLO,KERR) 368 IF(KERR.NE.0) CALL MY_EXIT(2) 369C 370 CALL FMMH( KLA,KLO,KLM,VALUE,KSEC3,RMINLAT,RMINLON, 371 1 RMAXLAT,RMAXLON) 372C CALL BUUKEY(KSEC1,KSEC2,KEY,KSUP,KERR) 373C IF(KERR.NE.0) THEN 374C CALL MY_EXIT(2) 375C END IF 376C 377 MINLAT=NINT(RMINLAT*100000)+9000000 378 MAXLAT=NINT(RMAXLAT*100000)+9000000 379 MINLON=NINT(RMINLON*100000)+18000000 380 MAXLON=NINT(RMAXLON*100000)+18000000 381C 382 KEY(10)=MINLON 383 KEY(11)=MINLAT 384 KEY(12)=MAXLON 385 KEY(13)=MAXLAT 386 KEY(14)=KSEC3(3) 387C 388C CALL BUPKEY(KEY,KSEC1,KSEC2,KERR) 389C IF(KERR.NE.0) THEN 390C PRINT*,'FILE IN PROCESS IS ',CFNAME(IO) 391C CALL MY_EXIT(2) 392C END IF 393C 394 CALL BUFREN( KSEC0,KSEC1,KSEC2,KSEC3,KSEC4, 395 1 KTDLEN,KTDLST,KDLEN,KDATA,KSUP(5), 396 2 KVALS,VALUE,CVAL,KBUFL,KBUFR,KERR) 397C 398 IF(KERR.NE.0) THEN 399 PRINT*,'ERROR DURING ENCODING.' 400 CALL MY_EXIT(2) 401 END IF 402C 403C 6.3 WRITE PACKED BUFR MESSAGE INTO FILE. 404C ------------------------------------ 405 630 CONTINUE 406C 407 ILEN=KBUFL*NBYTES 408C 409 IERR=0 410 CALL PBWRITE(IUNIT1,KBUFR,ILEN,IERR) 411 IF(IERR.LT.0) THEN 412 PRINT*,'PBWRITE: WRITE ERROR ',IERR 413 CALL MY_EXIT(2) 414 END IF 415C 416 ITOTAL=ITOTAL+KSEC3(3) 417C 418 IF(IRET.EQ.-1) THEN 419 NW=NW+1 420 GO TO 122 421 END IF 422C 423 NW=NW+1 424C 425 N=0 426 IF(JLAST.LT.KSUP(6)) THEN 427C 428C MOVE THE REST OF DATA INTO VALUE ARRAY 429C 430 DO 505 J=JLAST+1,KSUP(6) 431 N=N+1 432 DO 504 I=1,KSUP(5) 433 IV=I+(J-1)*KEL 434 IN=I+(N-1)*KSUP(5) 435C 436 IF(CUNITS(I).EQ.'CCITTIA5') THEN 437 IPOS =VALUES(I)/1000. 438 ICHAR=NINT(VALUES(IV)-IPOS*1000) 439 KKK=KKK+1 440 VALUE(IN)=KKK*1000+ICHAR 441 CVAL(KKK)=CVALS(IPOS) 442 ELSE 443 VALUE(IN)=VALUES(IV) 444 END IF 445 504 CONTINUE 446 505 CONTINUE 447 END IF 448C 449 IF(NCOM.LE.KSUP(6)-JLAST) THEN 450 KSUP(6)=KSUP(6)-JLAST 451 N=0 452 GO TO 500 453 END IF 454C 455 GO TO 300 456C 457 122 CONTINUE 458C 459 IRET=0 460 CALL PBCLOSE(IUNIT,IRET) 461C 462 121 CONTINUE 463C 464C ----------------------------------------------------------------- 465 900 CONTINUE 466C 467 PRINT*,'NUMBER OF MESSAGES READ ',NREAD 468 PRINT*,'NUMBER OF MESSAGES WRITTEN ',NW 469 PRINT*,'NUMBER OF SUBSETS ',NSUBS 470 PRINT*,'NUMBER OF OBSERVATIONS WRITTEN ',ITOTAL 471C 472 CALL PBCLOSE(IUNIT1,IRET) 473C 474 END 475