var/external/bufr/wrcmps.f

   1       SUBROUTINE WRCMPS(LUNIX)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    WRCMPS
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 2002-05-14
   7 C
   8 C ABSTRACT: THIS SUBROUTINE PACKS UP THE CURRENT SUBSET WITHIN MEMORY
   9 C   (ARRAY IBAY IN COMMON BLOCK /BITBUF/), STORING IT FOR COMPRESSION.
  10 C   IT THEN TRIES TO ADD IT TO THE COMPRESSED BUFR MESSAGE THAT IS
  11 C   CURRENTLY OPEN WITHIN MEMORY FOR ABS(LUNIX) (ARRAY MESG).  IF THE
  12 C   SUBSET WILL NOT FIT INTO THE CURRENTLY OPEN MESSAGE, THEN THAT
  13 C   COMPRESSED MESSAGE IS FLUSHED TO LUNIX AND A NEW ONE IS CREATED IN
  14 C   ORDER TO HOLD THE CURRENT SUBSET (STILL STORED FOR COMPRESSION).
  15 C   THIS SUBROUTINE PERFORMS FUNCTIONS SIMILAR TO BUFR ARCHIVE LIBRARY
  16 C   SUBROUTINE MSGUPD EXCEPT THAT IT ACTS ON COMPRESSED BUFR MESSAGES.
  17 C
  18 C PROGRAM HISTORY LOG:
  19 C 2002-05-14  J. WOOLLEN -- ORIGINAL AUTHOR
  20 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  21 C                           INTERDEPENDENCIES
  22 C 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
  23 C                           INCREASED FROM 15000 TO 16000 (WAS IN
  24 C                           VERIFICATION VERSION); LOGICAL VARIABLES
  25 C                           "WRIT1" AND "FLUSH" NOW SAVED IN GLOBAL
  26 C                           MEMORY (IN COMMON BLOCK /COMPRS/), THIS
  27 C                           FIXED A BUG IN THIS ROUTINE WHICH CAN LEAD
  28 C                           TO MESSAGES BEING WRITTEN OUT BEFORE THEY
  29 C                           ARE FULL; UNIFIED/PORTABLE FOR WRF; ADDED
  30 C                           DOCUMENTATION (INCLUDING HISTORY); OUTPUTS
  31 C                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
  32 C                           TERMINATES ABNORMALLY
  33 C 2004-08-18  J. ATOR    -- REMOVE CALL TO XMSGINI (CMSGINI NOW HAS
  34 C                           SAME CAPABILITY); IMPROVE DOCUMENTATION;
  35 C                           CORRECT LOGIC FOR WHEN A CHARACTER VALUE IS
  36 C                           THE SAME FOR ALL SUBSETS IN A MESSAGE;
  37 C                           MAXIMUM MESSAGE LENGTH INCREASED FROM
  38 C                           20,000 TO 50,000 BYTES
  39 C 2004-08-18  J. WOOLLEN -- 1) ADDED SAVE FOR LOGICAL 'FIRST'
  40 C                           2) ADDED 'KMISS' TO FIX BUG WHICH WOULD
  41 C                              OCCASIONALLY SKIP OVER SUBSETS
  42 C                           3) ADDED LOGIC TO MAKE SURE MISSING VALUES
  43 C                              ARE REPRESENTED BY INCREMENTS WITH ALL
  44 C                              BITS ON
  45 C                           4) REMOVED TWO UNECESSARY REFERENCES TO
  46 C                              'WRIT1'
  47 C 2005-11-29  J. ATOR    -- FIX INITIALIZATION BUG FOR CHARACTER
  48 C                           COMPRESSION; INCREASE MXCSB TO 4000;
  49 C                           USE IUPBS01; CHECK EDITION NUMBER OF BUFR
  50 C                           MESSAGE BEFORE PADDING TO AN EVEN BYTE COUNT
  51 C 2009-03-23  J. ATOR    -- ADDED SAVE FOR IBYT AND JBIT; USE MSGFULL
  52 C 2009-08-11  J. WOOLLEN -- MADE CATX AND CSTR BIGGER TO HANDLE LONGER
  53 C                           STRINGS.  ALSO SEPARATED MATX,CATX,NCOL FROM
  54 C                           OTHER VARS IN COMMON COMPRS FOR USE IN
  55 C                           SUBROUTINE WRITLC.  ALSO PASSED MBAY(1,LUN)
  56 C                           AS ARRAY TO INITIAL CALL TO CMSGINI IN ORDER
  57 C                           FOR USE BY WRITLC.
  58 C 2012-02-17  J. ATOR    -- FIXED A BUG INVOLVING COMPRESSED FILES WITH
  59 C                           EMBEDDED DICTIONARY MESSAGES
  60 C
  61 C USAGE:    CALL WRCMPS (LUNIX)
  62 C   INPUT ARGUMENT LIST:
  63 C     LUNIX    - INTEGER: ABSOLUTE VALUE IS FORTRAN LOGICAL UNIT NUMBER
  64 C                FOR BUFR FILE (IF LUNIX IS LESS THAN ZERO, THIS IS A
  65 C                "FLUSH" CALL AND THE BUFFER MUST BE CLEARED OUT)
  66 C
  67 C REMARKS:
  68 C    THIS ROUTINE CALLS:        BORT     CMSGINI  IUPBS01  MSGFULL
  69 C                               MSGWRT   PKB      PKC      STATUS
  70 C                               UPB      UPC      USRTPL
  71 C    THIS ROUTINE IS CALLED BY: CLOSMG   WRITSA   WRITSB
  72 C                               Normally not called by any application
  73 C                               programs.
  74 C
  75 C ATTRIBUTES:
  76 C   LANGUAGE: FORTRAN 77
  77 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  78 C
  79 C$$$
  80
  81       INCLUDE 'bufrlib.prm'
  82
  83       COMMON /MAXCMP/ MAXCMB,MAXROW,MAXCOL,NCMSGS,NCSUBS,NCBYTS
  84       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
  85      .                INODE(NFILES),IDATE(NFILES)
  86       COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES),
  87      .                MBAY(MXMSGLD4,NFILES)
  88       COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
  89      .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
  90      .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
  91      .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
  92      .                ISEQ(MAXJL,2),JSEQ(MAXJL)
  93       COMMON /USRINT/ NVAL(NFILES),INV(MAXSS,NFILES),VAL(MAXSS,NFILES)
  94       COMMON /COMPRS/ NCOL,MATX(MXCDV,MXCSB),CATX(MXCDV,MXCSB)
  95       COMMON /COMPRX/ KMIN(MXCDV),KMAX(MXCDV),KMIS(MXCDV),KBIT(MXCDV),
  96      .                ITYP(MXCDV),IWID(MXCDV),NROW,LUNC,KBYT,WRIT1,
  97      .                FLUSH,CSTR(MXCDV)
  98       COMMON /S01CM/  NS01V,CMNEM(MXS01V),IVMNEM(MXS01V)
  99
 100       CHARACTER*(MXLCC)  CATX,CSTR
 101       CHARACTER*128 BORT_STR
 102       CHARACTER*10  TAG
 103       CHARACTER*8   SUBSET,CMNEM
 104       CHARACTER*3   TYP
 105
 106       LOGICAL MSGFULL
 107
 108       DIMENSION     MESG(MXMSGLD4)
 109
 110 C     NOTE THE FOLLOWING LOGICAL FLAGS:
 111 C         FIRST - KEEPS TRACK OF WHETHER THE CURRENT SUBSET IS THE
 112 C                 FIRST SUBSET OF A NEW MESSAGE
 113 C         FLUSH - KEEPS TRACK OF WHETHER THIS SUBROUTINE WAS CALLED
 114 C                 WITH LUNIX < 0 IN ORDER TO FORCIBLY FLUSH ANY
 115 C                 PARTIALLY-COMPLETED MESSAGE WITHIN MEMORY (PRESUMABLY
 116 C                 IMMEDIATELY PRIOR TO EXITING THE CALLING PROGRAM!)
 117 C         WRIT1 - KEEPS TRACK OF WHETHER THE CURRENT MESSAGE NEEDS
 118 C                 TO BE WRITTEN OUT
 119
 120       LOGICAL       FIRST,FLUSH,WRIT1,KMIS,KMISS,EDGE4
 121       REAL*8        VAL
 122
 123       DATA      FIRST /.TRUE./
 124
 125       SAVE      FIRST,IBYT,JBIT,SUBSET
 126
 127 C-----------------------------------------------------------------------
 128       RLN2 = 1./LOG(2.)
 129 C-----------------------------------------------------------------------
 130
 131 C  GET THE UNIT AND SUBSET TAG
 132 C  ---------------------------
 133
 134       LUNIT = ABS(LUNIX)
 135       CALL STATUS(LUNIT,LUN,IL,IM)
 136
 137 C  IF THIS IS A "FIRST" CALL, THEN INITIALIZE SOME VALUES IN
 138 C  ORDER TO PREPARE FOR THE CREATION OF A NEW COMPRESSED BUFR
 139 C  MESSAGE FOR OUTPUT.
 140
 141   1   IF(FIRST) THEN
 142          KBYT = 0
 143          NCOL = 0
 144          LUNC = LUN
 145          NROW = NVAL(LUN)
 146          SUBSET = TAG(INODE(LUN))
 147          FIRST = .FALSE.
 148          FLUSH = .FALSE.
 149          WRIT1 = .FALSE.
 150
 151 C        THIS CALL TO CMSGINI IS DONE SOLELY IN ORDER TO DETERMINE
 152 C        HOW MANY BYTES (KBYT) WILL BE TAKEN UP IN A MESSAGE BY
 153 C        THE INFORMATION IN SECTIONS 0, 1, 2 AND 3.  THIS WILL
 154 C        ALLOW US TO KNOW HOW MANY COMPRESSED DATA SUBSETS WILL
 155 C        FIT INTO SECTION 4 WITHOUT OVERFLOWING MAXCMB.  LATER ON,
 156 C        A SEPARATE CALL TO CMSGINI WILL BE DONE TO ACTUALLY
 157 C        INITIALIZE SECTIONS 0, 1, 2 AND 3 OF THE FINAL COMPRESSED
 158 C        BUFR MESSAGE THAT WILL BE WRITTEN OUT.
 159
 160          CALL CMSGINI(LUN,MBAY(1,LUN),SUBSET,IDATE(LUN),NCOL,KBYT)
 161
 162 C        CHECK THE EDITION NUMBER OF THE BUFR MESSAGE TO BE CREATED
 163
 164          EDGE4 = .FALSE.
 165          IF(NS01V.GT.0) THEN
 166            II = 1
 167            DO WHILE ( (.NOT.EDGE4) .AND. (II.LE.NS01V) )
 168              IF( (CMNEM(II).EQ.'BEN') .AND. (IVMNEM(II).GE.4) ) THEN
 169                EDGE4 = .TRUE.
 170              ELSE
 171                II = II+1
 172              ENDIF
 173            ENDDO
 174          ENDIF
 175
 176       ENDIF
 177
 178       IF(LUN.NE.LUNC) GOTO 900
 179
 180 C  IF THIS IS A "FLUSH" CALL, THEN CLEAR OUT THE BUFFER (NOTE THAT
 181 C  THERE IS NO CURRENT SUBSET TO BE STORED!) AND PREPARE TO WRITE
 182 C  THE FINAL COMPRESSED BUFR MESSAGE.
 183
 184       IF(LUNIX.LT.0) THEN
 185          IF(NCOL.EQ.0) GOTO 100
 186          IF(NCOL.GT.0) THEN
 187             FLUSH = .TRUE.
 188             WRIT1 = .TRUE.
 189             ICOL = 1
 190             GOTO 20
 191          ENDIF
 192       ENDIF
 193
 194 C  CHECK ON SOME OTHER POSSIBLY PROBLEMATIC SITUATIONS
 195 C  ---------------------------------------------------
 196
 197       IF(NCOL+1.GT.MXCSB) THEN
 198          GOTO 50
 199       ELSEIF(NVAL(LUN).NE.NROW) THEN
 200          GOTO 50
 201       ELSEIF(NVAL(LUN).GT.MXCDV) THEN
 202          GOTO 901
 203       ENDIF
 204
 205 C  STORE THE NEXT SUBSET FOR COMPRESSION
 206 C  -------------------------------------
 207
 208 C     WILL THE CURRENT SUBSET FIT INTO THE CURRENT MESSAGE?
 209 C     (UNFORTUNATELY, THE ONLY WAY TO FIND OUT IS TO ACTUALLY
 210 C     RE-DO THE COMPRESSION BY RE-COMPUTING ALL OF THE LOCAL
 211 C     REFERENCE VALUES, INCREMENTS, ETC.)
 212
 213  10   NCOL = NCOL+1
 214       ICOL = NCOL
 215       IBIT = 16
 216       DO I=1,NVAL(LUN)
 217       NODE = INV(I,LUN)
 218       ITYP(I) = ITP(NODE)
 219       IWID(I) = IBT(NODE)
 220       IF(ITYP(I).EQ.1.OR.ITYP(I).EQ.2) THEN
 221          CALL UPB(MATX(I,NCOL),IBT(NODE),IBAY,IBIT)
 222       ELSEIF(ITYP(I).EQ.3) THEN
 223          CALL UPC(CATX(I,NCOL),IBT(NODE)/8,IBAY,IBIT)
 224       ENDIF
 225       ENDDO
 226
 227 C  COMPUTE THE MIN,MAX,WIDTH FOR EACH ROW - ACCUMULATE LENGTH
 228 C  ----------------------------------------------------------
 229
 230 C     LDATA WILL HOLD THE LENGTH IN BITS OF THE COMPRESSED DATA
 231 C     (I.E. THE SUM TOTAL FOR ALL DATA VALUES FOR ALL SUBSETS
 232 C     IN THE MESSAGE)
 233
 234  20   LDATA = 0
 235       IF(NCOL.LE.0) GOTO 902
 236       DO I=1,NROW
 237       IF(ITYP(I).EQ.1 .OR. ITYP(I).EQ.2) THEN
 238
 239 C        ROW I OF THE COMPRESSION MATRIX CONTAINS NUMERIC VALUES,
 240 C        SO KMIS(I) WILL STORE:
 241 C          .FALSE. IF ALL SUCH VALUES ARE NON-"MISSING"
 242 C          .TRUE. OTHERWISE
 243
 244          IMISS = 2**IWID(I)-1
 245          IF(ICOL.EQ.1) THEN
 246             KMIN(I) = IMISS
 247             KMAX(I) = 0
 248             KMIS(I) = .FALSE.
 249          ENDIF
 250          DO J=ICOL,NCOL
 251          IF(MATX(I,J).LT.IMISS) THEN
 252             KMIN(I) = MIN(KMIN(I),MATX(I,J))
 253             KMAX(I) = MAX(KMAX(I),MATX(I,J))
 254          ELSE
 255             KMIS(I) = .TRUE.
 256          ENDIF
 257          ENDDO
 258          KMISS = KMIS(I).AND.KMIN(I).LT.IMISS
 259          RANGE = MAX(1,KMAX(I)-KMIN(I)+1)
 260          IF(ITYP(I).EQ.1.AND.RANGE.GT.1) THEN
 261
 262 C           THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX
 263 C           ARE DELAYED DESCRIPTOR REPLICATION FACTORS AND ARE
 264 C           NOT ALL IDENTICAL (I.E. RANGE.GT.1), SO WE CANNOT
 265 C           COMPRESS ALL OF THESE SUBSETS INTO THE SAME MESSAGE.
 266 C           ASSUMING THAT NONE OF THE VALUES ARE "MISSING",
 267 C           EXCLUDE THE LAST SUBSET (I.E. THE LAST COLUMN
 268 C           OF THE MATRIX) AND TRY RE-COMPRESSING AGAIN.
 269
 270             IF(KMISS) GOTO 903
 271             WRIT1 = .TRUE.
 272             NCOL = NCOL-1
 273             ICOL = 1
 274             GOTO 20
 275          ELSEIF(ITYP(I).EQ.2.AND.(RANGE.GT.1..OR.KMISS)) THEN
 276
 277 C           THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX
 278 C           ARE NUMERIC VALUES THAT ARE NOT ALL IDENTICAL.
 279 C           COMPUTE THE NUMBER OF BITS NEEDED TO HOLD THE
 280 C           LARGEST OF THE INCREMENTS.
 281
 282             KBIT(I) = NINT(LOG(RANGE)*RLN2)
 283             IF(2**KBIT(I)-1.LE.RANGE) KBIT(I) = KBIT(I)+1
 284
 285 C           HOWEVER, UNDER NO CIRCUMSTANCES SHOULD THIS NUMBER
 286 C           EVER EXCEED THE WIDTH OF THE ORIGINAL UNDERLYING
 287 C           DESCRIPTOR!
 288
 289             IF(KBIT(I).GT.IWID(I)) KBIT(I) = IWID(I)
 290          ELSE
 291
 292 C           THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX
 293 C           ARE NUMERIC VALUES THAT ARE ALL IDENTICAL, SO THE
 294 C           INCREMENTS WILL BE OMITTED FROM THE MESSAGE.
 295
 296             KBIT(I) = 0
 297          ENDIF
 298          LDATA = LDATA + IWID(I) + 6 + NCOL*KBIT(I)
 299       ELSEIF(ITYP(I).EQ.3) THEN
 300
 301 C        ROW I OF THE COMPRESSION MATRIX CONTAINS CHARACTER VALUES,
 302 C        SO KMIS(I) WILL STORE:
 303 C          .FALSE. IF ALL SUCH VALUES ARE IDENTICAL
 304 C          .TRUE. OTHERWISE
 305
 306          IF(ICOL.EQ.1) THEN
 307             CSTR(I) = CATX(I,1)
 308             KMIS(I) = .FALSE.
 309          ENDIF
 310          DO J=ICOL,NCOL
 311             IF ( (.NOT.KMIS(I)) .AND. (CSTR(I).NE.CATX(I,J)) ) THEN
 312                KMIS(I) = .TRUE.
 313             ENDIF
 314          ENDDO
 315          IF (KMIS(I)) THEN
 316
 317 C           THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX
 318 C           ARE CHARACTER VALUES THAT ARE NOT ALL IDENTICAL.
 319
 320             KBIT(I) = IWID(I)
 321          ELSE
 322
 323 C           THE DATA VALUES IN ROW I OF THE COMPRESSION MATRIX
 324 C           ARE CHARACTER VALUES THAT ARE ALL IDENTICAL, SO THE
 325 C           INCREMENTS WILL BE OMITTED FROM THE MESSAGE.
 326
 327             KBIT(I) = 0
 328          ENDIF
 329          LDATA = LDATA + IWID(I) + 6 + NCOL*KBIT(I)
 330       ENDIF
 331       ENDDO
 332
 333 C  ROUND DATA LENGTH UP TO A WHOLE BYTE COUNT
 334 C  ------------------------------------------
 335
 336       IBYT = (LDATA+8-MOD(LDATA,8))/8
 337
 338 C     DEPENDING ON THE EDITION NUMBER OF THE MESSAGE, WE NEED TO ENSURE
 339 C     THAT WE ROUND TO AN EVEN BYTE COUNT
 340
 341       IF( (.NOT.EDGE4) .AND. (MOD(IBYT,2).NE.0) ) IBYT = IBYT+1
 342
 343       JBIT = IBYT*8-LDATA
 344
 345 C  CHECK ON COMPRESSED MESSAGE LENGTH, EITHER WRITE/RESTORE OR RETURN
 346 C  ------------------------------------------------------------------
 347
 348       IF(MSGFULL(IBYT,KBYT,MAXCMB)) THEN
 349
 350 C        THE CURRENT SUBSET WILL NOT FIT INTO THE CURRENT MESSAGE.
 351 C        SET THE FLAG TO INDICATE THAT A MESSAGE WRITE IS NEEDED,
 352 C        THEN GO BACK AND RE-COMPRESS THE SECTION 4 DATA FOR THIS
 353 C        MESSAGE WHILE *EXCLUDING* THE DATA FOR THE CURRENT SUBSET
 354 C        (WHICH WILL BE HELD AND STORED AS THE FIRST SUBSET OF A
 355 C        NEW MESSAGE AFTER WRITING THE CURRENT MESSAGE!).
 356
 357          WRIT1 = .TRUE.
 358          NCOL = NCOL-1
 359          ICOL = 1
 360          GOTO 20
 361       ELSEIF(.NOT.WRIT1) THEN
 362
 363 C        ADD THE CURRENT SUBSET TO THE CURRENT MESSAGE AND RETURN.
 364
 365          CALL USRTPL(LUN,1,1)
 366          NSUB(LUN) = -NCOL
 367          GOTO 100
 368       ENDIF
 369
 370 C  WRITE THE COMPLETE COMPRESSED MESSAGE
 371 C  -------------------------------------
 372
 373 C     NOW IT IS TIME TO DO THE "REAL" CALL TO CMSGINI TO ACTUALLY
 374 C     INITIALIZE SECTIONS 0, 1, 2 AND 3 OF THE FINAL COMPRESSED
 375 C     BUFR MESSAGE THAT WILL BE WRITTEN OUT.
 376
 377  50   CALL CMSGINI(LUN,MESG,SUBSET,IDATE(LUN),NCOL,IBYT)
 378
 379 C     NOW ADD THE SECTION 4 DATA.
 380
 381       IBIT = IBYT*8
 382       DO I=1,NROW
 383       IF(ITYP(I).EQ.1.OR.ITYP(I).EQ.2) THEN
 384          CALL PKB(KMIN(I),IWID(I),MESG,IBIT)
 385          CALL PKB(KBIT(I),      6,MESG,IBIT)
 386          IF(KBIT(I).GT.0) THEN
 387             DO J=1,NCOL
 388             IF(MATX(I,J).LT.2**IWID(I)-1) THEN
 389                INCR = MATX(I,J)-KMIN(I)
 390             ELSE
 391                INCR = 2**KBIT(I)-1
 392             ENDIF
 393             CALL PKB(INCR,KBIT(I),MESG,IBIT)
 394             ENDDO
 395          ENDIF
 396       ELSEIF(ITYP(I).EQ.3) THEN
 397          NCHR = IWID(I)/8
 398          IF(KBIT(I).GT.0) THEN
 399             CALL PKB(   0,IWID(I),MESG,IBIT)
 400             CALL PKB(NCHR,      6,MESG,IBIT)
 401             DO J=1,NCOL
 402                CALL PKC(CATX(I,J),NCHR,MESG,IBIT)
 403             ENDDO
 404          ELSE
 405             CALL PKC(CSTR(I),NCHR,MESG,IBIT)
 406             CALL PKB(      0,   6,MESG,IBIT)
 407          ENDIF
 408       ENDIF
 409       ENDDO
 410
 411 C  FILL IN THE END OF THE MESSAGE
 412 C  ------------------------------
 413
 414 C     PAD THE END OF SECTION 4 WITH ZEROES UP TO THE NECESSARY
 415 C     BYTE COUNT.
 416
 417       CALL PKB(     0,JBIT,MESG,IBIT)
 418
 419 C     ADD SECTION 5.
 420
 421       CALL PKC('7777',   4,MESG,IBIT)
 422
 423 C  SEE THAT THE MESSAGE BYTE COUNTERS AGREE THEN WRITE A MESSAGE
 424 C  -------------------------------------------------------------
 425
 426       IF(MOD(IBIT,8).NE.0) GOTO 904
 427       LBYT = IUPBS01(MESG,'LENM')
 428       NBYT = IBIT/8
 429       IF(NBYT.NE.LBYT) GOTO 905
 430
 431       CALL MSGWRT(LUNIT,MESG,NBYT)
 432
 433       MAXROW = MAX(MAXROW,NROW)
 434       MAXCOL = MAX(MAXCOL,NCOL)
 435       NCMSGS = NCMSGS+1
 436       NCSUBS = NCSUBS+NCOL
 437       NCBYTS = NCBYTS+NBYT
 438
 439 C  RESET
 440 C  -----
 441
 442 C     NOW, UNLESS THIS WAS A "FLUSH" CALL TO THIS SUBROUTINE, GO BACK
 443 C     AND INITIALIZE A NEW MESSAGE TO HOLD THE CURRENT SUBSET THAT WE
 444 C     WERE NOT ABLE TO FIT INTO THE MESSAGE THAT WAS JUST WRITTEN OUT.
 445
 446       FIRST = .TRUE.
 447       IF(.NOT.FLUSH) GOTO 1
 448
 449 C  EXITS
 450 C  -----
 451
 452 100   RETURN
 453 900   WRITE(BORT_STR,'("BUFRLIB: WRCMPS - I/O STREAM INDEX FOR THIS '//
 454      . 'CALL (",I3,") .NE. I/O STREAM INDEX FOR INITIAL CALL (",I3,")'//
 455      . ' - UNIT NUMBER NOW IS",I4)') LUN,LUNC,LUNIX
 456       CALL BORT(BORT_STR)
 457 901   WRITE(BORT_STR,'("BUFRLIB: WRCMPS - NO. OF ELEMENTS IN THE '//
 458      . 'SUBSET (",I6,") .GT. THE NO. OF ROWS ALLOCATED FOR THE '//
 459      . 'COMPRESSION MATRIX (",I6,")")') NVAL(LUN),MXCDV
 460       CALL BORT(BORT_STR)
 461 902   WRITE(BORT_STR,'("BUFRLIB: WRCMPS - NO. OF COLUMNS CALCULATED '//
 462      . 'FOR COMPRESSION MAXRIX IS .LE. 0 (=",I6,")")') NCOL
 463       CALL BORT(BORT_STR)
 464 903   CALL BORT('BUFRLIB: WRCMPS - MISSING DELAYED REPLICATION FACTOR')
 465 904   CALL BORT('BUFRLIB: WRCMPS - THE NUMBER OF BITS IN THE '//
 466      . 'COMPRESSED BUFR MSG IS NOT A MULTIPLE OF 8 - MSG MUST END ON '//
 467      . ' A BYTE BOUNDARY')
 468 905   WRITE(BORT_STR,'("BUFRLIB: WRCMPS - OUTPUT MESSAGE LENGTH FROM '//
 469      . 'SECTION 0",I6," DOES NOT EQUAL FINAL PACKED MESSAGE LENGTH ("'//
 470      .',I6,")")') LBYT,NBYT
 471       CALL BORT(BORT_STR)
 472       END