SUBROUTINE WRCMPS(LUNIX) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: WRCMPS C PRGMMR: WOOLLEN ORG: NP20 DATE: 2002-05-14 C C ABSTRACT: THIS SUBROUTINE PACKS UP THE CURRENT SUBSET WITHIN MEMORY C (ARRAY IBAY IN COMMON BLOCK /BITBUF/), STORING IT FOR COMPRESSION. C IT THEN TRIES TO ADD IT TO THE COMPRESSED BUFR MESSAGE THAT IS C CURRENTLY OPEN WITHIN MEMORY FOR ABS(LUNIX) (ARRAY MESG). IF THE C SUBSET WILL NOT FIT INTO THE CURRENTLY OPEN MESSAGE, THEN THAT C COMPRESSED MESSAGE IS FLUSHED TO LUNIX AND A NEW ONE IS CREATED IN C ORDER TO HOLD THE CURRENT SUBSET (STILL STORED FOR COMPRESSION). C THIS SUBROUTINE PERFORMS FUNCTIONS SIMILAR TO BUFR ARCHIVE LIBRARY C SUBROUTINE MSGUPD EXCEPT THAT IT ACTS ON COMPRESSED BUFR MESSAGES. C C PROGRAM HISTORY LOG: C 2002-05-14 J. WOOLLEN -- ORIGINAL AUTHOR C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES) C INCREASED FROM 15000 TO 16000 (WAS IN C VERIFICATION VERSION); LOGICAL VARIABLES C "WRIT1" AND "FLUSH" NOW SAVED IN GLOBAL C MEMORY (IN COMMON BLOCK /COMPRS/), THIS C FIXED A BUG IN THIS ROUTINE WHICH CAN LEAD C TO MESSAGES BEING WRITTEN OUT BEFORE THEY C ARE FULL; UNIFIED/PORTABLE FOR WRF; ADDED C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE C TERMINATES ABNORMALLY C 2004-08-18 J. ATOR -- REMOVE CALL TO XMSGINI (CMSGINI NOW HAS C SAME CAPABILITY); IMPROVE DOCUMENTATION; C CORRECT LOGIC FOR WHEN A CHARACTER VALUE IS C THE SAME FOR ALL SUBSETS IN A MESSAGE; C MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C 2004-08-18 J. WOOLLEN -- 1) ADDED SAVE FOR LOGICAL 'FIRST' C 2) ADDED 'KMISS' TO FIX BUG WHICH WOULD C OCCASIONALLY SKIP OVER SUBSETS C 3) ADDED LOGIC TO MAKE SURE MISSING VALUES C ARE REPRESENTED BY INCREMENTS WITH ALL C BITS ON C 4) REMOVED TWO UNECESSARY REFERENCES TO C 'WRIT1' C 2005-11-29 J. ATOR -- FIX INITIALIZATION BUG FOR CHARACTER C COMPRESSION; INCREASE MXCSB TO 4000; C USE IUPBS01; CHECK EDITION NUMBER OF BUFR C MESSAGE BEFORE PADDING TO AN EVEN BYTE COUNT C 2009-03-23 J. ATOR -- ADDED SAVE FOR IBYT AND JBIT; USE MSGFULL C 2009-08-11 J. WOOLLEN -- MADE CATX AND CSTR BIGGER TO HANDLE LONGER C STRINGS. ALSO SEPARATED MATX,CATX,NCOL FROM C OTHER VARS IN COMMON COMPRS FOR USE IN C SUBROUTINE WRITLC. ALSO PASSED MBAY(1,LUN) C AS ARRAY TO INITIAL CALL TO CMSGINI IN ORDER C FOR USE BY WRITLC. C 2012-02-17 J. ATOR -- FIXED A BUG INVOLVING COMPRESSED FILES WITH C EMBEDDED DICTIONARY MESSAGES C C USAGE: CALL WRCMPS (LUNIX) C INPUT ARGUMENT LIST: C LUNIX - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER C FOR BUFR FILE (IF LUNIX IS LESS THAN ZERO, THIS IS A C "FLUSH" CALL AND THE BUFFER MUST BE CLEARED OUT) C C REMARKS: C THIS ROUTINE CALLS: BORT CMSGINI IUPBS01 MSGFULL C MSGWRT PKB PKC STATUS C UPB UPC USRTPL C THIS ROUTINE IS CALLED BY: CLOSMG WRITSA WRITSB C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ INCLUDE 'bufrlib.prm' COMMON /MAXCMP/ MAXCMB,MAXROW,MAXCOL,NCMSGS,NCSUBS,NCBYTS COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES), . INODE(NFILES),IDATE(NFILES) COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES), . MBAY(MXMSGLD4,NFILES) COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL), . JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL), . IBT(MAXJL),IRF(MAXJL),ISC(MAXJL), . ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL), . ISEQ(MAXJL,2),JSEQ(MAXJL) COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES) COMMON /COMPRS/ NCOL,MATX(MXCDV,MXCSB),CATX(MXCDV,MXCSB) COMMON /COMPRX/ KMIN(MXCDV),KMAX(MXCDV),KMIS(MXCDV),KBIT(MXCDV), . ITYP(MXCDV),IWID(MXCDV),NROW,LUNC,KBYT,WRIT1, . FLUSH,CSTR(MXCDV) COMMON /S01CM/ NS01V,CMNEM(MXS01V),IVMNEM(MXS01V) CHARACTER*(MXLCC) CATX,CSTR CHARACTER*128 BORT_STR CHARACTER*10 TAG CHARACTER*8 SUBSET,CMNEM CHARACTER*3 TYP LOGICAL MSGFULL DIMENSION MESG(MXMSGLD4) C NOTE THE FOLLOWING LOGICAL FLAGS: C FIRST - KEEPS TRACK OF WHETHER THE CURRENT SUBSET IS THE C FIRST SUBSET OF A NEW MESSAGE C FLUSH - KEEPS TRACK OF WHETHER THIS SUBROUTINE WAS CALLED C WITH LUNIX < 0 IN ORDER TO FORCIBLY FLUSH ANY C PARTIALLY-COMPLETED MESSAGE WITHIN MEMORY (PRESUMABLY C IMMEDIATELY PRIOR TO EXITING THE CALLING PROGRAM!) C WRIT1 - KEEPS TRACK OF WHETHER THE CURRENT MESSAGE NEEDS C TO BE WRITTEN OUT LOGICAL FIRST,FLUSH,WRIT1,KMIS,KMISS,EDGE4 REAL*8 VAL DATA FIRST /.TRUE./ SAVE FIRST,IBYT,JBIT,SUBSET C----------------------------------------------------------------------- RLN2 = 1./LOG(2.) C----------------------------------------------------------------------- C GET THE UNIT AND SUBSET TAG C --------------------------- LUNIT = ABS(LUNIX) CALL STATUS(LUNIT,LUN,IL,IM) C IF THIS IS A "FIRST" CALL, THEN INITIALIZE SOME VALUES IN C ORDER TO PREPARE FOR THE CREATION OF A NEW COMPRESSED BUFR C MESSAGE FOR OUTPUT. 1 IF(FIRST) THEN KBYT = 0 NCOL = 0 LUNC = LUN NROW = NVAL(LUN) SUBSET = TAG(INODE(LUN)) FIRST = .FALSE. FLUSH = .FALSE. WRIT1 = .FALSE. C THIS CALL TO CMSGINI IS DONE SOLELY IN ORDER TO DETERMINE C HOW MANY BYTES (KBYT) WILL BE TAKEN UP IN A MESSAGE BY C THE INFORMATION IN SECTIONS 0, 1, 2 AND 3. THIS WILL C ALLOW US TO KNOW HOW MANY COMPRESSED DATA SUBSETS WILL C FIT INTO SECTION 4 WITHOUT OVERFLOWING MAXCMB. LATER ON, C A SEPARATE CALL TO CMSGINI WILL BE DONE TO ACTUALLY C INITIALIZE SECTIONS 0, 1, 2 AND 3 OF THE FINAL COMPRESSED C BUFR MESSAGE THAT WILL BE WRITTEN OUT. CALL CMSGINI(LUN,MBAY(1,LUN),SUBSET,IDATE(LUN),NCOL,KBYT) C CHECK THE EDITION NUMBER OF THE BUFR MESSAGE TO BE CREATED EDGE4 = .FALSE. IF(NS01V.GT.0) THEN II = 1 DO WHILE ( (.NOT.EDGE4) .AND. (II.LE.NS01V) ) IF( (CMNEM(II).EQ.'BEN') .AND. (IVMNEM(II).GE.4) ) THEN EDGE4 = .TRUE. ELSE II = II+1 ENDIF ENDDO ENDIF ENDIF IF(LUN.NE.LUNC) GOTO 900 C IF THIS IS A "FLUSH" CALL, THEN CLEAR OUT THE BUFFER (NOTE THAT C THERE IS NO CURRENT SUBSET TO BE STORED!) AND PREPARE TO WRITE C THE FINAL COMPRESSED BUFR MESSAGE. IF(LUNIX.LT.0) THEN IF(NCOL.EQ.0) GOTO 100 IF(NCOL.GT.0) THEN FLUSH = .TRUE. WRIT1 = .TRUE. ICOL = 1 GOTO 20 ENDIF ENDIF C CHECK ON SOME OTHER POSSIBLY PROBLEMATIC SITUATIONS C --------------------------------------------------- IF(NCOL+1.GT.MXCSB) THEN GOTO 50 ELSEIF(NVAL(LUN).NE.NROW) THEN GOTO 50 ELSEIF(NVAL(LUN).GT.MXCDV) THEN GOTO 901 ENDIF C STORE THE NEXT SUBSET FOR COMPRESSION C ------------------------------------- C WILL THE CURRENT SUBSET FIT INTO THE CURRENT MESSAGE? C (UNFORTUNATELY, THE ONLY WAY TO FIND OUT IS TO ACTUALLY C RE-DO THE COMPRESSION BY RE-COMPUTING ALL OF THE LOCAL C REFERENCE VALUES, INCREMENTS, ETC.) 10 NCOL = NCOL+1 ICOL = NCOL IBIT = 16 DO I=1,NVAL(LUN) NODE = INV(I,LUN) ITYP(I) = ITP(NODE) IWID(I) = IBT(NODE) IF(ITYP(I).EQ.1.OR.ITYP(I).EQ.2) THEN CALL UPB(MATX(I,NCOL),IBT(NODE),IBAY,IBIT) ELSEIF(ITYP(I).EQ.3) THEN CALL UPC(CATX(I,NCOL),IBT(NODE)/8,IBAY,IBIT) ENDIF ENDDO C COMPUTE THE MIN,MAX,WIDTH FOR EACH ROW - ACCUMULATE LENGTH C ---------------------------------------------------------- C LDATA WILL HOLD THE LENGTH IN BITS OF THE COMPRESSED DATA C (I.E. THE SUM TOTAL FOR ALL DATA VALUES FOR ALL SUBSETS C IN THE MESSAGE) 20 LDATA = 0 IF(NCOL.LE.0) GOTO 902 DO I=1,NROW IF(ITYP(I).EQ.1 .OR. ITYP(I).EQ.2) THEN C ROW I OF THE COMPRESSION MATRIX CONTAINS NUMERIC VALUES, C SO KMIS(I) WILL STORE: C .FALSE. IF ALL SUCH VALUES ARE NON-"MISSING" C .TRUE. OTHERWISE IMISS = 2**IWID(I)-1 IF(ICOL.EQ.1) THEN KMIN(I) = IMISS KMAX(I) = 0 KMIS(I) = .FALSE. ENDIF DO J=ICOL,NCOL IF(MATX(I,J).LT.IMISS) THEN KMIN(I) = MIN(KMIN(I),MATX(I,J)) KMAX(I) = MAX(KMAX(I),MATX(I,J)) ELSE KMIS(I) = .TRUE. ENDIF ENDDO KMISS = KMIS(I).AND.KMIN(I).LT.IMISS RANGE = MAX(1,KMAX(I)-KMIN(I)+1) IF(ITYP(I).EQ.1.AND.RANGE.GT.1) THEN C THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX C ARE DELAYED DESCRIPTOR REPLICATION FACTORS AND ARE C NOT ALL IDENTICAL (I.E. RANGE.GT.1), SO WE CANNOT C COMPRESS ALL OF THESE SUBSETS INTO THE SAME MESSAGE. C ASSUMING THAT NONE OF THE VALUES ARE "MISSING", C EXCLUDE THE LAST SUBSET (I.E. THE LAST COLUMN C OF THE MATRIX) AND TRY RE-COMPRESSING AGAIN. IF(KMISS) GOTO 903 WRIT1 = .TRUE. NCOL = NCOL-1 ICOL = 1 GOTO 20 ELSEIF(ITYP(I).EQ.2.AND.(RANGE.GT.1..OR.KMISS)) THEN C THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX C ARE NUMERIC VALUES THAT ARE NOT ALL IDENTICAL. C COMPUTE THE NUMBER OF BITS NEEDED TO HOLD THE C LARGEST OF THE INCREMENTS. KBIT(I) = NINT(LOG(RANGE)*RLN2) IF(2**KBIT(I)-1.LE.RANGE) KBIT(I) = KBIT(I)+1 C HOWEVER, UNDER NO CIRCUMSTANCES SHOULD THIS NUMBER C EVER EXCEED THE WIDTH OF THE ORIGINAL UNDERLYING C DESCRIPTOR! IF(KBIT(I).GT.IWID(I)) KBIT(I) = IWID(I) ELSE C THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX C ARE NUMERIC VALUES THAT ARE ALL IDENTICAL, SO THE C INCREMENTS WILL BE OMITTED FROM THE MESSAGE. KBIT(I) = 0 ENDIF LDATA = LDATA + IWID(I) + 6 + NCOL*KBIT(I) ELSEIF(ITYP(I).EQ.3) THEN C ROW I OF THE COMPRESSION MATRIX CONTAINS CHARACTER VALUES, C SO KMIS(I) WILL STORE: C .FALSE. IF ALL SUCH VALUES ARE IDENTICAL C .TRUE. OTHERWISE IF(ICOL.EQ.1) THEN CSTR(I) = CATX(I,1) KMIS(I) = .FALSE. ENDIF DO J=ICOL,NCOL IF ( (.NOT.KMIS(I)) .AND. (CSTR(I).NE.CATX(I,J)) ) THEN KMIS(I) = .TRUE. ENDIF ENDDO IF (KMIS(I)) THEN C THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX C ARE CHARACTER VALUES THAT ARE NOT ALL IDENTICAL. KBIT(I) = IWID(I) ELSE C THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX C ARE CHARACTER VALUES THAT ARE ALL IDENTICAL, SO THE C INCREMENTS WILL BE OMITTED FROM THE MESSAGE. KBIT(I) = 0 ENDIF LDATA = LDATA + IWID(I) + 6 + NCOL*KBIT(I) ENDIF ENDDO C ROUND DATA LENGTH UP TO A WHOLE BYTE COUNT C ------------------------------------------ IBYT = (LDATA+8-MOD(LDATA,8))/8 C DEPENDING ON THE EDITION NUMBER OF THE MESSAGE, WE NEED TO ENSURE C THAT WE ROUND TO AN EVEN BYTE COUNT IF( (.NOT.EDGE4) .AND. (MOD(IBYT,2).NE.0) ) IBYT = IBYT+1 JBIT = IBYT*8-LDATA C CHECK ON COMPRESSED MESSAGE LENGTH, EITHER WRITE/RESTORE OR RETURN C ------------------------------------------------------------------ IF(MSGFULL(IBYT,KBYT,MAXCMB)) THEN C THE CURRENT SUBSET WILL NOT FIT INTO THE CURRENT MESSAGE. C SET THE FLAG TO INDICATE THAT A MESSAGE WRITE IS NEEDED, C THEN GO BACK AND RE-COMPRESS THE SECTION 4 DATA FOR THIS C MESSAGE WHILE *EXCLUDING* THE DATA FOR THE CURRENT SUBSET C (WHICH WILL BE HELD AND STORED AS THE FIRST SUBSET OF A C NEW MESSAGE AFTER WRITING THE CURRENT MESSAGE!). WRIT1 = .TRUE. NCOL = NCOL-1 ICOL = 1 GOTO 20 ELSEIF(.NOT.WRIT1) THEN C ADD THE CURRENT SUBSET TO THE CURRENT MESSAGE AND RETURN. CALL USRTPL(LUN,1,1) NSUB(LUN) = -NCOL GOTO 100 ENDIF C WRITE THE COMPLETE COMPRESSED MESSAGE C ------------------------------------- C NOW IT IS TIME TO DO THE "REAL" CALL TO CMSGINI TO ACTUALLY C INITIALIZE SECTIONS 0, 1, 2 AND 3 OF THE FINAL COMPRESSED C BUFR MESSAGE THAT WILL BE WRITTEN OUT. 50 CALL CMSGINI(LUN,MESG,SUBSET,IDATE(LUN),NCOL,IBYT) C NOW ADD THE SECTION 4 DATA. IBIT = IBYT*8 DO I=1,NROW IF(ITYP(I).EQ.1.OR.ITYP(I).EQ.2) THEN CALL PKB(KMIN(I),IWID(I),MESG,IBIT) CALL PKB(KBIT(I), 6,MESG,IBIT) IF(KBIT(I).GT.0) THEN DO J=1,NCOL IF(MATX(I,J).LT.2**IWID(I)-1) THEN INCR = MATX(I,J)-KMIN(I) ELSE INCR = 2**KBIT(I)-1 ENDIF CALL PKB(INCR,KBIT(I),MESG,IBIT) ENDDO ENDIF ELSEIF(ITYP(I).EQ.3) THEN NCHR = IWID(I)/8 IF(KBIT(I).GT.0) THEN CALL PKB( 0,IWID(I),MESG,IBIT) CALL PKB(NCHR, 6,MESG,IBIT) DO J=1,NCOL CALL PKC(CATX(I,J),NCHR,MESG,IBIT) ENDDO ELSE CALL PKC(CSTR(I),NCHR,MESG,IBIT) CALL PKB( 0, 6,MESG,IBIT) ENDIF ENDIF ENDDO C FILL IN THE END OF THE MESSAGE C ------------------------------ C PAD THE END OF SECTION 4 WITH ZEROES UP TO THE NECESSARY C BYTE COUNT. CALL PKB( 0,JBIT,MESG,IBIT) C ADD SECTION 5. CALL PKC('7777', 4,MESG,IBIT) C SEE THAT THE MESSAGE BYTE COUNTERS AGREE THEN WRITE A MESSAGE C ------------------------------------------------------------- IF(MOD(IBIT,8).NE.0) GOTO 904 LBYT = IUPBS01(MESG,'LENM') NBYT = IBIT/8 IF(NBYT.NE.LBYT) GOTO 905 CALL MSGWRT(LUNIT,MESG,NBYT) MAXROW = MAX(MAXROW,NROW) MAXCOL = MAX(MAXCOL,NCOL) NCMSGS = NCMSGS+1 NCSUBS = NCSUBS+NCOL NCBYTS = NCBYTS+NBYT C RESET C ----- C NOW, UNLESS THIS WAS A "FLUSH" CALL TO THIS SUBROUTINE, GO BACK C AND INITIALIZE A NEW MESSAGE TO HOLD THE CURRENT SUBSET THAT WE C WERE NOT ABLE TO FIT INTO THE MESSAGE THAT WAS JUST WRITTEN OUT. FIRST = .TRUE. IF(.NOT.FLUSH) GOTO 1 C EXITS C ----- 100 RETURN 900 WRITE(BORT_STR,'("BUFRLIB: WRCMPS - I/O STREAM INDEX FOR THIS '// . 'CALL (",I3,") .NE. I/O STREAM INDEX FOR INITIAL CALL (",I3,")'// . ' - UNIT NUMBER NOW IS",I4)') LUN,LUNC,LUNIX CALL BORT(BORT_STR) 901 WRITE(BORT_STR,'("BUFRLIB: WRCMPS - NO. OF ELEMENTS IN THE '// . 'SUBSET (",I6,") .GT. THE NO. OF ROWS ALLOCATED FOR THE '// . 'COMPRESSION MATRIX (",I6,")")') NVAL(LUN),MXCDV CALL BORT(BORT_STR) 902 WRITE(BORT_STR,'("BUFRLIB: WRCMPS - NO. OF COLUMNS CALCULATED '// . 'FOR COMPRESSION MAXRIX IS .LE. 0 (=",I6,")")') NCOL CALL BORT(BORT_STR) 903 CALL BORT('BUFRLIB: WRCMPS - MISSING DELAYED REPLICATION FACTOR') 904 CALL BORT('BUFRLIB: WRCMPS - THE NUMBER OF BITS IN THE '// . 'COMPRESSED BUFR MSG IS NOT A MULTIPLE OF 8 - MSG MUST END ON '// . ' A BYTE BOUNDARY') 905 WRITE(BORT_STR,'("BUFRLIB: WRCMPS - OUTPUT MESSAGE LENGTH FROM '// . 'SECTION 0",I6," DOES NOT EQUAL FINAL PACKED MESSAGE LENGTH ("'// .',I6,")")') LBYT,NBYT CALL BORT(BORT_STR) END