wrfv2_fire/var/external/bufr/msgini.inc

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