wrfv2_fire/var/external/bufr/wrcmps.inc

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