msgini.f

Go to the documentation of this file.

C> @file
C> @brief Initialize a new uncompressed BUFR message for output.
C>
C> @author Woollen @date 1994-01-06
 
C> This subroutine initializes, within the internal arrays, a new
C> uncompressed BUFR message for output. Arrays are filled in common blocks
C> msgptr and modules @ref moda_msgcwd and @ref moda_bitbuf.
C>
C> @param[in] LUN - integer: I/O stream index into internal memory arrays.
C>
C> @author Woollen @date 1994-01-06
      SUBROUTINE msgini(LUN)
 
      USE moda_msgcwd
      USE moda_ufbcpl
      USE moda_bitbuf
      USE moda_tables
 
      COMMON /padesc/ ibct,ipd1,ipd2,ipd3,ipd4
      COMMON /msgptr/ nby0,nby1,nby2,nby3,nby4,nby5
 
      CHARACTER*128 BORT_STR
      CHARACTER*8   SUBTAG
      CHARACTER*4   BUFR,SEVN
      CHARACTER*1   TAB
 
      DATA bufr/'BUFR'/
      DATA sevn/'7777'/
 
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
 
C  GET THE MESSAGE TAG AND TYPE, AND BREAK UP THE DATE
C  ---------------------------------------------------
 
      subtag = tag(inode(lun))(1:8)
c  .... Given SUBSET, NEMTBA returns MTYP,MSBT,INOD
      CALL nemtba(lun,subtag,mtyp,msbt,inod)
      IF(inode(lun).NE.inod) GOTO 900
      CALL nemtab(lun,subtag,isub,tab,iret)
      IF(iret.EQ.0) GOTO 901
 
C  DATE CAN BE YYMMDDHH OR YYYYMMDDHH
C  ----------------------------------
 
      mcen = mod(idate(lun)/10**8,100)+1
      mear = mod(idate(lun)/10**6,100)
      mmon = mod(idate(lun)/10**4,100)
      mday = mod(idate(lun)/10**2,100)
      mour = mod(idate(lun)      ,100)
      mmin = 0
 
c  .... DK: Can this happen?? (investigate)
      IF(mcen.EQ.1) GOTO 902
 
      IF(mear.EQ.0) mcen = mcen-1
      IF(mear.EQ.0) mear = 100
 
C  INITIALIZE THE MESSAGE
C  ----------------------
 
      mbit = 0
      nby0 = 8
      nby1 = 18
      nby2 = 0
      nby3 = 20
      nby4 = 4
      nby5 = 4
      nbyt = nby0+nby1+nby2+nby3+nby4+nby5
 
C  SECTION 0
C  ---------
 
      CALL pkc(bufr ,  4 , mbay(1,lun),mbit)
      CALL pkb(nbyt , 24 , mbay(1,lun),mbit)
      CALL pkb(   3 ,  8 , mbay(1,lun),mbit)
 
C  SECTION 1
C  ---------
 
      CALL pkb(nby1 , 24 , mbay(1,lun),mbit)
      CALL pkb(   0 ,  8 , mbay(1,lun),mbit)
      CALL pkb(   3 ,  8 , mbay(1,lun),mbit)
      CALL pkb(   7 ,  8 , mbay(1,lun),mbit)
      CALL pkb(   0 ,  8 , mbay(1,lun),mbit)
      CALL pkb(   0 ,  8 , mbay(1,lun),mbit)
      CALL pkb(mtyp ,  8 , mbay(1,lun),mbit)
      CALL pkb(msbt ,  8 , mbay(1,lun),mbit)
      CALL pkb(  36 ,  8 , mbay(1,lun),mbit)
      CALL pkb(   0 ,  8 , mbay(1,lun),mbit)
      CALL pkb(mear ,  8 , mbay(1,lun),mbit)
      CALL pkb(mmon ,  8 , mbay(1,lun),mbit)
      CALL pkb(mday ,  8 , mbay(1,lun),mbit)
      CALL pkb(mour ,  8 , mbay(1,lun),mbit)
      CALL pkb(mmin ,  8 , mbay(1,lun),mbit)
      CALL pkb(mcen ,  8 , mbay(1,lun),mbit)
 
C  SECTION 3
C  ---------
 
      CALL pkb(nby3 , 24 , mbay(1,lun),mbit)
      CALL pkb(   0 ,  8 , mbay(1,lun),mbit)
      CALL pkb(   0 , 16 , mbay(1,lun),mbit)
      CALL pkb(2**7 ,  8 , mbay(1,lun),mbit)
      CALL pkb(ibct , 16 , mbay(1,lun),mbit)
      CALL pkb(isub , 16 , mbay(1,lun),mbit)
      CALL pkb(ipd1 , 16 , mbay(1,lun),mbit)
      CALL pkb(ipd2 , 16 , mbay(1,lun),mbit)
      CALL pkb(ipd3 , 16 , mbay(1,lun),mbit)
      CALL pkb(ipd4 , 16 , mbay(1,lun),mbit)
      CALL pkb(   0 ,  8 , mbay(1,lun),mbit)
 
C  SECTION 4
C  ---------
 
      CALL pkb(nby4 , 24 , mbay(1,lun),mbit)
      CALL pkb(   0 ,  8 , mbay(1,lun),mbit)
 
C  SECTION 5
C  ---------
 
      CALL pkc(sevn ,  4 , mbay(1,lun),mbit)
 
C  DOUBLE CHECK INITIAL MESSAGE LENGTH
C  -----------------------------------
 
      IF(mod(mbit,8).NE.0) GOTO 903
      IF(mbit/8.NE.nbyt  ) GOTO 904
 
      nmsg(lun) = nmsg(lun)+1
      nsub(lun) = 0
      mbyt(lun) = nbyt
 
      luncpy(lun)=0
 
C  EXITS
C  -----
 
      RETURN
900   WRITE(bort_str,'("BUFRLIB: MSGINI - MISMATCH BETWEEN INODE (=",'//
     . 'I7,") & POSITIONAL INDEX, INOD (",I7,") OF SUBTAG (",A,") IN '//
     . 'DICTIONARY")') inode(lun),inod,subtag
      CALL bort(bort_str)
901   WRITE(bort_str,'("BUFRLIB: MSGINI - TABLE A MESSAGE TYPE '//
     . 'MNEMONIC ",A," NOT FOUND IN INTERNAL TABLE D ARRAYS")') subtag
      CALL bort(bort_str)
902   CALL bort
     . ('BUFRLIB: MSGINI - BUFR MESSAGE DATE (IDATE) is 0000000000')
903   CALL bort('BUFRLIB: MSGINI - INITIALIZED MESSAGE DOES NOT END '//
     . 'ON A BYTE BOUNDARY')
904   WRITE(bort_str,'("BUFRLIB: MSGINI - NUMBER OF BYTES STORED FOR '//
     . 'INITIALIZED MESSAGE (",I6,") IS NOT THE SAME AS FIRST '//
     . 'CALCULATED, NBYT (",I6)') mbit/8,nbyt
      CALL bort(bort_str)
      END