var/external/bufr/cmsgini.f

   1       SUBROUTINE CMSGINI(LUN,MESG,SUBSET,IDATE,NSUB,NBYT)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    CMSGINI
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 2002-05-14
   7 C
   8 C ABSTRACT: THIS SUBROUTINE INITIALIZES A NEW BUFR MESSAGE FOR OUTPUT
   9 C   IN COMPRESSED BUFR.  THE ACTUAL LENGTH OF SECTION 4 (CONTAINING
  10 C   COMPRESSED DATA) IS ALREADY KNOWN.
  11 C
  12 C PROGRAM HISTORY LOG:
  13 C 2002-05-14  J. WOOLLEN -- ORIGINAL AUTHOR
  14 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  15 C                           INTERDEPENDENCIES
  16 C 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED
  17 C                           DOCUMENTATION (INCLUDING HISTORY); OUTPUTS
  18 C                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
  19 C                           TERMINATES ABNORMALLY; LEN3 INITIALIZED AS
  20 C                           ZERO (BEFORE WAS UNDEFINED WHEN FIRST
  21 C                           REFERENCED)
  22 C 2004-08-18  J. ATOR    -- ADDED COMMON /MSGSTD/ AND OTHER LOGIC TO
  23 C                           ALLOW OPTION OF CREATING A SECTION 3 THAT IS
  24 C                           FULLY WMO-STANDARD; IMPROVED DOCUMENTATION;
  25 C                           MAXIMUM MESSAGE LENGTH INCREASED FROM
  26 C                           20,000 TO 50,000 BYTES
  27 C 2005-11-29  J. ATOR    -- CHANGED DEFAULT MASTER TABLE VERSION TO 12
  28 C 2009-05-07  J. ATOR    -- CHANGED DEFAULT MASTER TABLE VERSION TO 13;
  29 C                           REMOVED STANDARDIZATION LOGIC FOR SECTION 3
  30 C
  31 C USAGE:    CALL CMSGINI (LUN, MESG, SUBSET, IDATE, NSUB, NBYT)
  32 C   INPUT ARGUMENT LIST:
  33 C     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  34 C     SUBSET   - CHARACTER*8: TABLE A MNEMONIC FOR TYPE OF BUFR MESSAGE
  35 C                BEING WRITTEN
  36 C     IDATE    - INTEGER: DATE-TIME STORED WITHIN SECTION 1 OF BUFR
  37 C                MESSAGE BEING WRITTEN, IN FORMAT OF EITHER YYMMDDHH OR
  38 C                YYYYMMDDHH, DEPENDING ON DATELEN() VALUE
  39 C     NSUB     - INTEGER: NUMBER OF SUBSETS, STORED IN SECTION 3 OF
  40 C                BUFR MESSAGE BEING WRITTEN
  41 C     NBYT     - INTEGER: ACTUAL LENGTH (IN BYTES) OF "COMPRESSED DATA
  42 C                PORTION" OF SECTION 4 (I.E. ALL OF SECTION 4 EXCEPT
  43 C                FOR THE FIRST FOUR BYTES)
  44 C
  45 C   OUTPUT ARGUMENT LIST:
  46 C     MESG     - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING BUFR
  47 C                MESSAGE
  48 C     NBYT     - INTEGER: ACTUAL LENGTH OF BUFR MESSAGE (IN BYTES) UP
  49 C                TO THE POINT IN SECTION 4 WHERE COMPRESSED DATA ARE
  50 C                TO BE WRITTEN
  51 C
  52 C REMARKS:
  53 C    THIS ROUTINE CALLS:        BORT     I4DY     NEMTAB   NEMTBA
  54 C                               PKB      PKC
  55 C    THIS ROUTINE IS CALLED BY: WRCMPS
  56 C                               Normally not called by any application
  57 C                               programs.
  58 C
  59 C ATTRIBUTES:
  60 C   LANGUAGE: FORTRAN 77
  61 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  62 C
  63 C$$$
  64
  65       INCLUDE 'bufrlib.prm'
  66
  67       CHARACTER*128 BORT_STR
  68       CHARACTER*8   SUBSET
  69       CHARACTER*4   BUFR
  70       CHARACTER*1   TAB
  71       DIMENSION     MESG(*)
  72
  73       DATA BUFR/'BUFR'/
  74
  75 C-----------------------------------------------------------------------
  76 C-----------------------------------------------------------------------
  77
  78 C  GET THE MESSAGE TAG AND TYPE, AND BREAK UP THE DATE
  79 C  ---------------------------------------------------
  80
  81 c  .... Given SUBSET, NEMTBA returns MTYP,MSBT,INOD
  82       CALL NEMTBA(LUN,SUBSET,MTYP,MSBT,INOD)
  83       CALL NEMTAB(LUN,SUBSET,ISUB,TAB,IRET)
  84       IF(IRET.EQ.0) GOTO 900
  85
  86 C  DATE CAN BE YYMMDDHH OR YYYYMMDDHH
  87 C  ----------------------------------
  88
  89       JDATE = I4DY(IDATE)
  90       MCEN = MOD(JDATE/10**8,100)+1
  91       MEAR = MOD(JDATE/10**6,100)
  92       MMON = MOD(JDATE/10**4,100)
  93       MDAY = MOD(JDATE/10**2,100)
  94       MOUR = MOD(JDATE      ,100)
  95       MMIN = 0
  96
  97 c  .... DK: Don't think this can happen, because IDATE=0 is returned
  98 c           as 2000000000 by I4DY meaning MCEN would be 21
  99       IF(MCEN.EQ.1) GOTO 901
 100
 101       IF(MEAR.EQ.0) MCEN = MCEN-1
 102       IF(MEAR.EQ.0) MEAR = 100
 103
 104 C  INITIALIZE THE MESSAGE
 105 C  ----------------------
 106
 107       MBIT = 0
 108
 109 C  SECTION 0
 110 C  ---------
 111
 112       CALL PKC(BUFR ,  4 , MESG,MBIT)
 113
 114 C     NOTE THAT THE ACTUAL SECTION 0 LENGTH WILL BE COMPUTED AND
 115 C     STORED BELOW; FOR NOW, WE ARE REALLY ONLY INTERESTED IN
 116 C     ADVANCING MBIT BY THE CORRECT AMOUNT, SO WE'LL JUST STORE
 117 C     A DEFAULT VALUE OF 0.
 118
 119       CALL PKB(   0 , 24 , MESG,MBIT)
 120       CALL PKB(   3 ,  8 , MESG,MBIT)
 121
 122 C  SECTION 1
 123 C  ---------
 124
 125       LEN1 = 18
 126
 127       CALL PKB(LEN1 , 24 , MESG,MBIT)
 128       CALL PKB(   0 ,  8 , MESG,MBIT)
 129       CALL PKB(   3 ,  8 , MESG,MBIT)
 130       CALL PKB(   7 ,  8 , MESG,MBIT)
 131       CALL PKB(   0 ,  8 , MESG,MBIT)
 132       CALL PKB(   0 ,  8 , MESG,MBIT)
 133       CALL PKB(MTYP ,  8 , MESG,MBIT)
 134       CALL PKB(MSBT ,  8 , MESG,MBIT)
 135       CALL PKB(  13 ,  8 , MESG,MBIT)
 136       CALL PKB(   0 ,  8 , MESG,MBIT)
 137       CALL PKB(MEAR ,  8 , MESG,MBIT)
 138       CALL PKB(MMON ,  8 , MESG,MBIT)
 139       CALL PKB(MDAY ,  8 , MESG,MBIT)
 140       CALL PKB(MOUR ,  8 , MESG,MBIT)
 141       CALL PKB(MMIN ,  8 , MESG,MBIT)
 142       CALL PKB(MCEN ,  8 , MESG,MBIT)
 143
 144 C  SECTION 3
 145 C  ---------
 146
 147       LEN3 = 10
 148
 149       CALL PKB(LEN3 , 24 , MESG,MBIT)
 150       CALL PKB(   0 ,  8 , MESG,MBIT)
 151       CALL PKB(NSUB , 16 , MESG,MBIT)
 152       CALL PKB( 192 ,  8 , MESG,MBIT)
 153       CALL PKB(ISUB , 16 , MESG,MBIT)
 154       CALL PKB(   0 ,  8 , MESG,MBIT)
 155
 156 C  SECTION 4
 157 C  ---------
 158
 159 C     STORE THE TOTAL LENGTH OF SECTION 4.
 160
 161 C     REMEMBER THAT THE INPUT VALUE OF NBYT ONLY CONTAINS THE
 162 C     LENGTH OF THE "COMPRESSED DATA PORTION" OF SECTION 4, SO
 163 C     WE NEED TO ADD FOUR BYTES TO THIS NUMBER IN ORDER TO
 164 C     ACCOUNT FOR THE TOTAL LENGTH OF SECTION 4.
 165
 166       CALL PKB((NBYT+4) , 24 , MESG,MBIT)
 167       CALL PKB(       0 ,  8 , MESG,MBIT)
 168
 169 C     THE ACTUAL "COMPRESSED DATA PORTION" OF SECTION 4 WILL
 170 C     BE FILLED IN LATER BY SUBROUTINE WRCMPS.
 171
 172 C  SECTION 5
 173 C  ---------
 174
 175 C     THIS SECTION WILL BE FILLED IN LATER BY SUBROUTINE WRCMPS.
 176
 177 C  RETURN WITH THE CORRECT NEW MESSAGE BYTE COUNT
 178 C  ----------------------------------------------
 179
 180 C     NOW, NOTING THAT MBIT CURRENTLY POINTS TO THE LAST BIT OF
 181 C     THE FOURTH BYTE OF SECTION 4, THEN WE HAVE:
 182 C     (TOTAL LENGTH OF BUFR MESSAGE (IN SECTION 0)) =
 183 C            (LENGTH OF MESSAGE UP THROUGH FOURTH BYTE OF SECTION 4)
 184 C         +  (LENGTH OF "COMPRESSED DATA PORTION" OF SECTION 4)
 185 C         +  (LENGTH OF SECTION 5)
 186       MBYT =
 187      .       MBIT/8
 188      .    +  NBYT
 189      .    +  4
 190
 191 C     NOW, MAKE NBYT POINT TO THE CURRENT LOCATION OF MBIT
 192 C     (I.E. THE BYTE AFTER WHICH TO ACTUALLY BEGIN WRITING THE
 193 C     COMPRESSED DATA INTO SECTION 4).
 194
 195       NBYT = MBIT/8
 196
 197 C     NOW, STORE THE TOTAL LENGTH OF THE BUFR MESSAGE (IN SECTION 0).
 198
 199       MBIT = 32
 200       CALL PKB(MBYT,24,MESG,MBIT)
 201
 202 C  EXITS
 203 C  -----
 204
 205       RETURN
 206 900   WRITE(BORT_STR,'("BUFRLIB: CMSGINI - TABLE A MESSAGE TYPE '//
 207      . 'MNEMONIC ",A," NOT FOUND IN INTERNAL TABLE D ARRAYS")') SUBSET
 208       CALL BORT(BORT_STR)
 209 901   CALL BORT
 210      . ('BUFRLIB: CMSGINI - BUFR MESSAGE DATE (IDATE) is 0000000000')
 211       END