cmsgini.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 2002-05-14
      
C> THIS SUBROUTINE INITIALIZES A NEW BUFR MESSAGE FOR OUTPUT
C>   IN COMPRESSED BUFR.  THE ACTUAL LENGTH OF SECTION 4 (CONTAINING
C>   COMPRESSED DATA) IS ALREADY KNOWN.
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  -- UNIFIED/PORTABLE FOR WRF; ADDED
C>                           DOCUMENTATION (INCLUDING HISTORY); OUTPUTS
C>                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
C>                           TERMINATES ABNORMALLY; LEN3 INITIALIZED AS
C>                           ZERO (BEFORE WAS UNDEFINED WHEN FIRST
C>                           REFERENCED)
C> 2004-08-18  J. ATOR    -- ADDED COMMON /MSGSTD/ AND OTHER LOGIC TO
C>                           ALLOW OPTION OF CREATING A SECTION 3 THAT IS
C>                           FULLY WMO-STANDARD; IMPROVED DOCUMENTATION;
C>                           MAXIMUM MESSAGE LENGTH INCREASED FROM
C>                           20,000 TO 50,000 BYTES
C> 2005-11-29  J. ATOR    -- CHANGED DEFAULT MASTER TABLE VERSION TO 12
C> 2009-05-07  J. ATOR    -- CHANGED DEFAULT MASTER TABLE VERSION TO 13;
C>                           REMOVED STANDARDIZATION LOGIC FOR SECTION 3
C> 2019-05-21  J. ATOR    -- CHANGED DEFAULT MASTER TABLE VERSION TO 29
C> 2021-05-14  J. ATOR    -- CHANGED DEFAULT MASTER TABLE VERSION TO 36
C>
C> USAGE:    CALL CMSGINI (LUN, MESG, SUBSET, IDATE, NSUB, NBYT)
C>   INPUT ARGUMENT LIST:
C>     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C>     SUBSET   - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE
C>                BEING WRITTEN 
C>     IDATE    - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR
C>                MESSAGE BEING WRITTEN, IN FORMAT OF EITHER YYMMDDHH OR
C>                YYYYMMDDHH, DEPENDING ON DATELEN() VALUE
C>     NSUB     - INTEGER: NUMBER OF SUBSETS, STORED IN SECTION 3 OF
C>                BUFR MESSAGE BEING WRITTEN
C>     NBYT     - INTEGER: ACTUAL LENGTH (IN BYTES) OF "COMPRESSED DATA
C>                PORTION" OF SECTION 4 (I.E. ALL OF SECTION 4 EXCEPT
C>                FOR THE FIRST FOUR BYTES)
C>
C>   OUTPUT ARGUMENT LIST:
C>     MESG     - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR
C>                MESSAGE
C>     NBYT     - INTEGER: ACTUAL LENGTH OF BUFR MESSAGE (IN BYTES) UP
C>                TO THE POINT IN SECTION 4 WHERE COMPRESSED DATA ARE
C>                TO BE WRITTEN 
C>
C> REMARKS:
C>    THIS ROUTINE CALLS:        BORT     I4DY     NEMTAB   NEMTBA
C>                               PKB      PKC
C>    THIS ROUTINE IS CALLED BY: WRCMPS
C>                               Normally not called by any application
C>                               programs.
C>
      SUBROUTINE cmsgini(LUN,MESG,SUBSET,IDATE,NSUB,NBYT)
 
      CHARACTER*128 BORT_STR
      CHARACTER*8   SUBSET
      CHARACTER*4   BUFR
      CHARACTER*1   TAB
      dimension     mesg(*)
 
      DATA bufr/'BUFR'/
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
C  GET THE MESSAGE TAG AND TYPE, AND BREAK UP THE DATE
C  ---------------------------------------------------
 
c  .... Given SUBSET, NEMTBA returns MTYP,MSBT,INOD
      CALL nemtba(lun,subset,mtyp,msbt,inod)
      CALL nemtab(lun,subset,isub,tab,iret)
      IF(iret.EQ.0) GOTO 900
 
C  DATE CAN BE YYMMDDHH OR YYYYMMDDHH
C  ----------------------------------
 
      jdate = i4dy(idate)
      mcen = mod(jdate/10**8,100)+1
      mear = mod(jdate/10**6,100)
      mmon = mod(jdate/10**4,100)
      mday = mod(jdate/10**2,100)
      mour = mod(jdate      ,100)
      mmin = 0
 
c  .... DK: Don't think this can happen, because IDATE=0 is returned
c           as 2000000000 by I4DY meaning MCEN would be 21
      IF(mcen.EQ.1) GOTO 901
 
      IF(mear.EQ.0) mcen = mcen-1
      IF(mear.EQ.0) mear = 100
 
C  INITIALIZE THE MESSAGE
C  ----------------------
 
      mbit = 0
 
C  SECTION 0
C  ---------
 
      CALL pkc(bufr ,  4 , mesg,mbit)
 
C     NOTE THAT THE ACTUAL SECTION 0 LENGTH WILL BE COMPUTED AND
C     STORED BELOW; FOR NOW, WE ARE REALLY ONLY INTERESTED IN
C     ADVANCING MBIT BY THE CORRECT AMOUNT, SO WE'LL JUST STORE
C     A DEFAULT VALUE OF 0.
 
      CALL pkb(   0 , 24 , mesg,mbit)
      CALL pkb(   3 ,  8 , mesg,mbit)
 
C  SECTION 1
C  ---------
 
      len1 = 18
 
      CALL pkb(len1 , 24 , mesg,mbit)
      CALL pkb(   0 ,  8 , mesg,mbit)
      CALL pkb(   3 ,  8 , mesg,mbit)
      CALL pkb(   7 ,  8 , mesg,mbit)
      CALL pkb(   0 ,  8 , mesg,mbit)
      CALL pkb(   0 ,  8 , mesg,mbit)
      CALL pkb(mtyp ,  8 , mesg,mbit)
      CALL pkb(msbt ,  8 , mesg,mbit)
      CALL pkb(  36 ,  8 , mesg,mbit)
      CALL pkb(   0 ,  8 , mesg,mbit)
      CALL pkb(mear ,  8 , mesg,mbit)
      CALL pkb(mmon ,  8 , mesg,mbit)
      CALL pkb(mday ,  8 , mesg,mbit)
      CALL pkb(mour ,  8 , mesg,mbit)
      CALL pkb(mmin ,  8 , mesg,mbit)
      CALL pkb(mcen ,  8 , mesg,mbit)
 
C  SECTION 3
C  ---------
 
      len3 = 10
 
      CALL pkb(len3 , 24 , mesg,mbit)
      CALL pkb(   0 ,  8 , mesg,mbit)
      CALL pkb(nsub , 16 , mesg,mbit)
      CALL pkb( 192 ,  8 , mesg,mbit)
      CALL pkb(isub , 16 , mesg,mbit)
      CALL pkb(   0 ,  8 , mesg,mbit)
 
C  SECTION 4
C  ---------
 
C     STORE THE TOTAL LENGTH OF SECTION 4.
 
C     REMEMBER THAT THE INPUT VALUE OF NBYT ONLY CONTAINS THE
C     LENGTH OF THE "COMPRESSED DATA PORTION" OF SECTION 4, SO
C     WE NEED TO ADD FOUR BYTES TO THIS NUMBER IN ORDER TO
C     ACCOUNT FOR THE TOTAL LENGTH OF SECTION 4.
 
      CALL pkb((nbyt+4) , 24 , mesg,mbit)
      CALL pkb(       0 ,  8 , mesg,mbit)
 
C     THE ACTUAL "COMPRESSED DATA PORTION" OF SECTION 4 WILL
C     BE FILLED IN LATER BY SUBROUTINE WRCMPS.
 
C  SECTION 5
C  ---------
 
C     THIS SECTION WILL BE FILLED IN LATER BY SUBROUTINE WRCMPS.
 
C  RETURN WITH THE CORRECT NEW MESSAGE BYTE COUNT
C  ----------------------------------------------
 
C     NOW, NOTING THAT MBIT CURRENTLY POINTS TO THE LAST BIT OF
C     THE FOURTH BYTE OF SECTION 4, THEN WE HAVE:
C     (TOTAL LENGTH OF BUFR MESSAGE (IN SECTION 0)) =
C            (LENGTH OF MESSAGE UP THROUGH FOURTH BYTE OF SECTION 4)
C         +  (LENGTH OF "COMPRESSED DATA PORTION" OF SECTION 4)
C         +  (LENGTH OF SECTION 5)
      mbyt =
     .       mbit/8
     .    +  nbyt
     .    +  4
 
C     NOW, MAKE NBYT POINT TO THE CURRENT LOCATION OF MBIT
C     (I.E. THE BYTE AFTER WHICH TO ACTUALLY BEGIN WRITING THE
C     COMPRESSED DATA INTO SECTION 4).
 
      nbyt = mbit/8
 
C     NOW, STORE THE TOTAL LENGTH OF THE BUFR MESSAGE (IN SECTION 0).
 
      mbit = 32
      CALL pkb(mbyt,24,mesg,mbit)
 
C  EXITS
C  -----
 
      RETURN
900   WRITE(bort_str,'("BUFRLIB: CMSGINI - TABLE A MESSAGE TYPE '//
     . 'MNEMONIC ",A," NOT FOUND IN INTERNAL TABLE D ARRAYS")') subset
      CALL bort(bort_str)
901   CALL bort
     . ('BUFRLIB: CMSGINI - BUFR MESSAGE DATE (IDATE) is 0000000000')
      END