wrfv2_fire/var/external/bufr/cmsgini.inc

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