var/external/bufr/msgini.f

   1       SUBROUTINE MSGINI(LUN)
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    MSGINI
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE INITIALIZES, WITHIN THE INTERNAL ARRAYS, A
   9 C   NEW BUFR MESSAGE FOR OUTPUT.  ARRAYS ARE FILLED IN COMMON BLOCKS
  10 C   /MSGPTR/, /MSGCWD/ AND /BITBUF/.
  11 C
  12 C PROGRAM HISTORY LOG:
  13 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  14 C 1996-12-11  J. WOOLLEN -- MODIFIED TO ALLOW INCLUSION OF MINUTES IN
  15 C                           WRITING THE MESSAGE DATE INTO A BUFR
  16 C                           MESSAGE
  17 C 1997-07-29  J. WOOLLEN -- MODIFIED TO UPDATE THE CURRENT BUFR VERSION
  18 C                           WRITTEN IN SECTION 0 FROM 2 TO 3
  19 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  20 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  21 C                           ROUTINE "BORT"; MODIFIED TO MAKE Y2K
  22 C                           COMPLIANT
  23 C 1999-11-18  J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
  24 C                           OPENED AT ONE TIME INCREASED FROM 10 TO 32
  25 C                           (NECESSARY IN ORDER TO PROCESS MULTIPLE
  26 C                           BUFR FILES UNDER THE MPI)
  27 C 2000-09-19  J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  28 C                           10,000 TO 20,000 BYTES
  29 C 2002-05-14  J. WOOLLEN -- REMOVED ENTRY POINT MINIMG (IT BECAME A
  30 C                           SEPARATE ROUTINE IN THE BUFRLIB TO
  31 C                           INCREASE PORTABILITY TO OTHER PLATFORMS)
  32 C 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
  33 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  34 C                           INTERDEPENDENCIES
  35 C 2003-11-04  D. KEYSER  -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
  36 C                           INCREASED FROM 15000 TO 16000 (WAS IN
  37 C                           VERIFICATION VERSION); UNIFIED/PORTABLE FOR
  38 C                           WRF; ADDED HISTORY DOCUMENTATION; OUTPUTS
  39 C                           MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
  40 C                           TERMINATES ABNORMALLY
  41 C 2004-08-09  J. ATOR    -- MAXIMUM MESSAGE LENGTH INCREASED FROM
  42 C                           20,000 TO 50,000 BYTES
  43 C 2005-11-29  J. ATOR    -- CHANGED DEFAULT MASTER TABLE VERSION TO 12
  44 C 2009-05-07  J. ATOR    -- CHANGED DEFAULT MASTER TABLE VERSION TO 13
  45 C 2009-08-11  J. WOOLLEN -- ADD COMMON UFBCPL TO INITIALIZE LUNCPY
  46 C
  47 C USAGE:    CALL MSGINI (LUN)
  48 C   INPUT ARGUMENT LIST:
  49 C     LUN      - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
  50 C
  51 C REMARKS:
  52 C    THIS ROUTINE CALLS:        BORT     NEMTAB   NEMTBA   PKB
  53 C                               PKC
  54 C    THIS ROUTINE IS CALLED BY: CPYUPD   MSGUPD   OPENMB   OPENMG
  55 C                               Normally not called by any application
  56 C                               programs.
  57 C
  58 C ATTRIBUTES:
  59 C   LANGUAGE: FORTRAN 77
  60 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  61 C
  62 C$$$
  63
  64       INCLUDE 'bufrlib.prm'
  65
  66       COMMON /PADESC/ IBCT,IPD1,IPD2,IPD3,IPD4
  67       COMMON /MSGPTR/ NBY0,NBY1,NBY2,NBY3,NBY4,NBY5
  68       COMMON /MSGCWD/ NMSG(NFILES),NSUB(NFILES),MSUB(NFILES),
  69      .                INODE(NFILES),IDATE(NFILES)
  70       COMMON /BITBUF/ MAXBYT,IBIT,IBAY(MXMSGLD4),MBYT(NFILES),
  71      .                MBAY(MXMSGLD4,NFILES)
  72       COMMON /BTABLES/ MAXTAB,NTAB,TAG(MAXJL),TYP(MAXJL),KNT(MAXJL),
  73      .                JUMP(MAXJL),LINK(MAXJL),JMPB(MAXJL),
  74      .                IBT(MAXJL),IRF(MAXJL),ISC(MAXJL),
  75      .                ITP(MAXJL),VALI(MAXJL),KNTI(MAXJL),
  76      .                ISEQ(MAXJL,2),JSEQ(MAXJL)
  77       COMMON /UFBCPL/ LUNCPY(NFILES)
  78
  79       CHARACTER*128 BORT_STR
  80       CHARACTER*10  TAG
  81       CHARACTER*8   SUBTAG
  82       CHARACTER*4   BUFR,SEVN
  83       CHARACTER*3   TYP
  84       CHARACTER*1   TAB
  85
  86       DATA BUFR/'BUFR'/
  87       DATA SEVN/'7777'/
  88
  89 C-----------------------------------------------------------------------
  90 C-----------------------------------------------------------------------
  91
  92 C  GET THE MESSAGE TAG AND TYPE, AND BREAK UP THE DATE
  93 C  ---------------------------------------------------
  94
  95       SUBTAG = TAG(INODE(LUN))
  96 c  .... Given SUBSET, NEMTBA returns MTYP,MSBT,INOD
  97       CALL NEMTBA(LUN,SUBTAG,MTYP,MSBT,INOD)
  98       IF(INODE(LUN).NE.INOD) GOTO 900
  99       CALL NEMTAB(LUN,SUBTAG,ISUB,TAB,IRET)
 100       IF(IRET.EQ.0) GOTO 901
 101
 102 C  DATE CAN BE YYMMDDHH OR YYYYMMDDHH
 103 C  ----------------------------------
 104
 105       MCEN = MOD(IDATE(LUN)/10**8,100)+1
 106       MEAR = MOD(IDATE(LUN)/10**6,100)
 107       MMON = MOD(IDATE(LUN)/10**4,100)
 108       MDAY = MOD(IDATE(LUN)/10**2,100)
 109       MOUR = MOD(IDATE(LUN)      ,100)
 110       MMIN = 0
 111
 112 c  .... DK: Can this happen?? (investigate)
 113       IF(MCEN.EQ.1) GOTO 902
 114
 115       IF(MEAR.EQ.0) MCEN = MCEN-1
 116       IF(MEAR.EQ.0) MEAR = 100
 117
 118 C  INITIALIZE THE MESSAGE
 119 C  ----------------------
 120
 121       MBIT = 0
 122       NBY0 = 8
 123       NBY1 = 18
 124       NBY2 = 0
 125       NBY3 = 20
 126       NBY4 = 4
 127       NBY5 = 4
 128       NBYT = NBY0+NBY1+NBY2+NBY3+NBY4+NBY5
 129
 130 C  SECTION 0
 131 C  ---------
 132
 133       CALL PKC(BUFR ,  4 , MBAY(1,LUN),MBIT)
 134       CALL PKB(NBYT , 24 , MBAY(1,LUN),MBIT)
 135       CALL PKB(   3 ,  8 , MBAY(1,LUN),MBIT)
 136
 137 C  SECTION 1
 138 C  ---------
 139
 140       CALL PKB(NBY1 , 24 , MBAY(1,LUN),MBIT)
 141       CALL PKB(   0 ,  8 , MBAY(1,LUN),MBIT)
 142       CALL PKB(   3 ,  8 , MBAY(1,LUN),MBIT)
 143       CALL PKB(   7 ,  8 , MBAY(1,LUN),MBIT)
 144       CALL PKB(   0 ,  8 , MBAY(1,LUN),MBIT)
 145       CALL PKB(   0 ,  8 , MBAY(1,LUN),MBIT)
 146       CALL PKB(MTYP ,  8 , MBAY(1,LUN),MBIT)
 147       CALL PKB(MSBT ,  8 , MBAY(1,LUN),MBIT)
 148       CALL PKB(  13 ,  8 , MBAY(1,LUN),MBIT)
 149       CALL PKB(   0 ,  8 , MBAY(1,LUN),MBIT)
 150       CALL PKB(MEAR ,  8 , MBAY(1,LUN),MBIT)
 151       CALL PKB(MMON ,  8 , MBAY(1,LUN),MBIT)
 152       CALL PKB(MDAY ,  8 , MBAY(1,LUN),MBIT)
 153       CALL PKB(MOUR ,  8 , MBAY(1,LUN),MBIT)
 154       CALL PKB(MMIN ,  8 , MBAY(1,LUN),MBIT)
 155       CALL PKB(MCEN ,  8 , MBAY(1,LUN),MBIT)
 156
 157 C  SECTION 3
 158 C  ---------
 159
 160       CALL PKB(NBY3 , 24 , MBAY(1,LUN),MBIT)
 161       CALL PKB(   0 ,  8 , MBAY(1,LUN),MBIT)
 162       CALL PKB(   0 , 16 , MBAY(1,LUN),MBIT)
 163       CALL PKB(2**7 ,  8 , MBAY(1,LUN),MBIT)
 164       CALL PKB(IBCT , 16 , MBAY(1,LUN),MBIT)
 165       CALL PKB(ISUB , 16 , MBAY(1,LUN),MBIT)
 166       CALL PKB(IPD1 , 16 , MBAY(1,LUN),MBIT)
 167       CALL PKB(IPD2 , 16 , MBAY(1,LUN),MBIT)
 168       CALL PKB(IPD3 , 16 , MBAY(1,LUN),MBIT)
 169       CALL PKB(IPD4 , 16 , MBAY(1,LUN),MBIT)
 170       CALL PKB(   0 ,  8 , MBAY(1,LUN),MBIT)
 171
 172 C  SECTION 4
 173 C  ---------
 174
 175       CALL PKB(NBY4 , 24 , MBAY(1,LUN),MBIT)
 176       CALL PKB(   0 ,  8 , MBAY(1,LUN),MBIT)
 177
 178 C  SECTION 5
 179 C  ---------
 180
 181       CALL PKC(SEVN ,  4 , MBAY(1,LUN),MBIT)
 182
 183 C  DOUBLE CHECK INITIAL MESSAGE LENGTH
 184 C  -----------------------------------
 185
 186       IF(MOD(MBIT,8).NE.0) GOTO 903
 187       IF(MBIT/8.NE.NBYT  ) GOTO 904
 188
 189       NMSG(LUN) = NMSG(LUN)+1
 190       NSUB(LUN) = 0
 191       MBYT(LUN) = NBYT
 192
 193       LUNCPY(LUN)=0
 194
 195 C  EXITS
 196 C  -----
 197
 198       RETURN
 199 900   WRITE(BORT_STR,'("BUFRLIB: MSGINI - MISMATCH BETWEEN INODE (=",
 200      & I7,") & POSITIONAL INDEX, INOD (",I7,") OF SUBTAG (",A,") IN
 201      & DICTIONARY")') INODE(LUN),INOD,SUBTAG
 202       CALL BORT(BORT_STR)
 203 901   WRITE(BORT_STR,'("BUFRLIB: MSGINI - TABLE A MESSAGE TYPE
 204      & MNEMONIC ",A," NOT FOUND IN INTERNAL TABLE D ARRAYS")') SUBTAG
 205       CALL BORT(BORT_STR)
 206 902   CALL BORT
 207      & ('BUFRLIB: MSGINI - BUFR MESSAGE DATE (IDATE) is 0000000000')
 208 903   CALL BORT('BUFRLIB: MSGINI - INITIALIZED MESSAGE DOES NOT END
 209      & ON A BYTE BOUNDARY')
 210 904   WRITE(BORT_STR,'("BUFRLIB: MSGINI - NUMBER OF BYTES STORED FOR
 211      & INITIALIZED MESSAGE (",I6,") IS NOT THE SAME AS FIRST
 212      & CALCULATED, NBYT (",I6)') MBIT/8,NBYT
 213       CALL BORT(BORT_STR)
 214       END