msgini.f

Go to the documentation of this file.

C> @file
C> @author WOOLLEN @date 1994-01-06
      
C> THIS SUBROUTINE INITIALIZES, WITHIN THE INTERNAL ARRAYS, A
C>   NEW BUFR MESSAGE FOR OUTPUT.  ARRAYS ARE FILLED IN COMMON BLOCKS
C>   /MSGPTR/ AND MODULES MSGCWD AND BITBUF.
C>
C> PROGRAM HISTORY LOG:
C> 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C> 1996-12-11  J. WOOLLEN -- MODIFIED TO ALLOW INCLUSION OF MINUTES IN
C>                           WRITING THE MESSAGE DATE INTO A BUFR
C>                           MESSAGE
C> 1997-07-29  J. WOOLLEN -- MODIFIED TO UPDATE THE CURRENT BUFR VERSION
C>                           WRITTEN IN SECTION 0 FROM 2 TO 3
C> 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
C>                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
C>                           ROUTINE "BORT"; MODIFIED TO MAKE Y2K
C>                           COMPLIANT
C> 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
C>                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
C>                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
C>                           BUFR FILES UNDER THE MPI)
C> 2000-09-19  J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
C>                           10,000 TO 20,000 BYTES
C> 2002-05-14  J. WOOLLEN -- REMOVED ENTRY POINT MINIMG (IT BECAME A
C>                           SEPARATE ROUTINE IN THE BUFRLIB TO
C>                           INCREASE PORTABILITY TO OTHER PLATFORMS)
C> 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
C> 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C>                           INTERDEPENDENCIES
C> 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
C>                           INCREASED FROM 15000 TO 16000 (WAS IN
C>                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
C>                           WRF; ADDED HISTORY DOCUMENTATION; OUTPUTS
C>                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
C>                           TERMINATES ABNORMALLY
C> 2004-08-09  J. ATOR    -- 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> 2009-08-11  J. WOOLLEN -- ADD COMMON UFBCPL TO INITIALIZE LUNCPY
C> 2014-12-10  J. ATOR    -- USE MODULES INSTEAD OF COMMON BLOCKS
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 MSGINI (LUN)
C>   INPUT ARGUMENT LIST:
C>     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
C>
C> REMARKS:
C>    THIS ROUTINE CALLS:        BORT     NEMTAB   NEMTBA   PKB
C>                               PKC
C>    THIS ROUTINE IS CALLED BY: CPYUPD   MSGUPD   OPENMB   OPENMG
C>                               Normally not called by any application
C>                               programs.
C>
      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))
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