NCEPLIBS-bufr  11.6.0
 All Data Structures Files Functions Variables Pages
msgini.f
Go to the documentation of this file.
1 C> @file
2 C> @author WOOLLEN @date 1994-01-06
3 
4 C> THIS SUBROUTINE INITIALIZES, WITHIN THE INTERNAL ARRAYS, A
5 C> NEW BUFR MESSAGE FOR OUTPUT. ARRAYS ARE FILLED IN COMMON BLOCKS
6 C> /MSGPTR/ AND MODULES MSGCWD AND BITBUF.
7 C>
8 C> PROGRAM HISTORY LOG:
9 C> 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR
10 C> 1996-12-11 J. WOOLLEN -- MODIFIED TO ALLOW INCLUSION OF MINUTES IN
11 C> WRITING THE MESSAGE DATE INTO A BUFR
12 C> MESSAGE
13 C> 1997-07-29 J. WOOLLEN -- MODIFIED TO UPDATE THE CURRENT BUFR VERSION
14 C> WRITTEN IN SECTION 0 FROM 2 TO 3
15 C> 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
16 C> "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
17 C> ROUTINE "BORT"; MODIFIED TO MAKE Y2K
18 C> COMPLIANT
19 C> 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE
20 C> OPENED AT ONE TIME INCREASED FROM 10 TO 32
21 C> (NECESSARY IN ORDER TO PROCESS MULTIPLE
22 C> BUFR FILES UNDER THE MPI)
23 C> 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM
24 C> 10,000 TO 20,000 BYTES
25 C> 2002-05-14 J. WOOLLEN -- REMOVED ENTRY POINT MINIMG (IT BECAME A
26 C> SEPARATE ROUTINE IN THE BUFRLIB TO
27 C> INCREASE PORTABILITY TO OTHER PLATFORMS)
28 C> 2003-11-04 J. ATOR -- ADDED DOCUMENTATION
29 C> 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE
30 C> INTERDEPENDENCIES
31 C> 2003-11-04 D. KEYSER -- MAXJL (MAXIMUM NUMBER OF JUMP/LINK ENTRIES)
32 C> INCREASED FROM 15000 TO 16000 (WAS IN
33 C> VERIFICATION VERSION); UNIFIED/PORTABLE FOR
34 C> WRF; ADDED HISTORY DOCUMENTATION; OUTPUTS
35 C> MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE
36 C> TERMINATES ABNORMALLY
37 C> 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM
38 C> 20,000 TO 50,000 BYTES
39 C> 2005-11-29 J. ATOR -- CHANGED DEFAULT MASTER TABLE VERSION TO 12
40 C> 2009-05-07 J. ATOR -- CHANGED DEFAULT MASTER TABLE VERSION TO 13
41 C> 2009-08-11 J. WOOLLEN -- ADD COMMON UFBCPL TO INITIALIZE LUNCPY
42 C> 2014-12-10 J. ATOR -- USE MODULES INSTEAD OF COMMON BLOCKS
43 C> 2019-05-21 J. ATOR -- CHANGED DEFAULT MASTER TABLE VERSION TO 29
44 C> 2021-05-14 J. ATOR -- CHANGED DEFAULT MASTER TABLE VERSION TO 36
45 C>
46 C> USAGE: CALL MSGINI (LUN)
47 C> INPUT ARGUMENT LIST:
48 C> LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
49 C>
50 C> REMARKS:
51 C> THIS ROUTINE CALLS: BORT NEMTAB NEMTBA PKB
52 C> PKC
53 C> THIS ROUTINE IS CALLED BY: CPYUPD MSGUPD OPENMB OPENMG
54 C> Normally not called by any application
55 C> programs.
56 C>
57  SUBROUTINE msgini(LUN)
58 
59  USE moda_msgcwd
60  USE moda_ufbcpl
61  USE moda_bitbuf
62  USE moda_tables
63 
64  COMMON /padesc/ ibct,ipd1,ipd2,ipd3,ipd4
65  COMMON /msgptr/ nby0,nby1,nby2,nby3,nby4,nby5
66 
67  CHARACTER*128 bort_str
68  CHARACTER*8 subtag
69  CHARACTER*4 bufr,sevn
70  CHARACTER*1 tab
71 
72  DATA bufr/'BUFR'/
73  DATA sevn/'7777'/
74 
75 C-----------------------------------------------------------------------
76 C-----------------------------------------------------------------------
77 
78 C GET THE MESSAGE TAG AND TYPE, AND BREAK UP THE DATE
79 C ---------------------------------------------------
80 
81  subtag = tag(inode(lun))
82 c .... Given SUBSET, NEMTBA returns MTYP,MSBT,INOD
83  CALL nemtba(lun,subtag,mtyp,msbt,inod)
84  IF(inode(lun).NE.inod) goto 900
85  CALL nemtab(lun,subtag,isub,tab,iret)
86  IF(iret.EQ.0) goto 901
87 
88 C DATE CAN BE YYMMDDHH OR YYYYMMDDHH
89 C ----------------------------------
90 
91  mcen = mod(idate(lun)/10**8,100)+1
92  mear = mod(idate(lun)/10**6,100)
93  mmon = mod(idate(lun)/10**4,100)
94  mday = mod(idate(lun)/10**2,100)
95  mour = mod(idate(lun) ,100)
96  mmin = 0
97 
98 c .... DK: Can this happen?? (investigate)
99  IF(mcen.EQ.1) goto 902
100 
101  IF(mear.EQ.0) mcen = mcen-1
102  IF(mear.EQ.0) mear = 100
103 
104 C INITIALIZE THE MESSAGE
105 C ----------------------
106 
107  mbit = 0
108  nby0 = 8
109  nby1 = 18
110  nby2 = 0
111  nby3 = 20
112  nby4 = 4
113  nby5 = 4
114  nbyt = nby0+nby1+nby2+nby3+nby4+nby5
115 
116 C SECTION 0
117 C ---------
118 
119  CALL pkc(bufr , 4 , mbay(1,lun),mbit)
120  CALL pkb(nbyt , 24 , mbay(1,lun),mbit)
121  CALL pkb( 3 , 8 , mbay(1,lun),mbit)
122 
123 C SECTION 1
124 C ---------
125 
126  CALL pkb(nby1 , 24 , mbay(1,lun),mbit)
127  CALL pkb( 0 , 8 , mbay(1,lun),mbit)
128  CALL pkb( 3 , 8 , mbay(1,lun),mbit)
129  CALL pkb( 7 , 8 , mbay(1,lun),mbit)
130  CALL pkb( 0 , 8 , mbay(1,lun),mbit)
131  CALL pkb( 0 , 8 , mbay(1,lun),mbit)
132  CALL pkb(mtyp , 8 , mbay(1,lun),mbit)
133  CALL pkb(msbt , 8 , mbay(1,lun),mbit)
134  CALL pkb( 36 , 8 , mbay(1,lun),mbit)
135  CALL pkb( 0 , 8 , mbay(1,lun),mbit)
136  CALL pkb(mear , 8 , mbay(1,lun),mbit)
137  CALL pkb(mmon , 8 , mbay(1,lun),mbit)
138  CALL pkb(mday , 8 , mbay(1,lun),mbit)
139  CALL pkb(mour , 8 , mbay(1,lun),mbit)
140  CALL pkb(mmin , 8 , mbay(1,lun),mbit)
141  CALL pkb(mcen , 8 , mbay(1,lun),mbit)
142 
143 C SECTION 3
144 C ---------
145 
146  CALL pkb(nby3 , 24 , mbay(1,lun),mbit)
147  CALL pkb( 0 , 8 , mbay(1,lun),mbit)
148  CALL pkb( 0 , 16 , mbay(1,lun),mbit)
149  CALL pkb(2**7 , 8 , mbay(1,lun),mbit)
150  CALL pkb(ibct , 16 , mbay(1,lun),mbit)
151  CALL pkb(isub , 16 , mbay(1,lun),mbit)
152  CALL pkb(ipd1 , 16 , mbay(1,lun),mbit)
153  CALL pkb(ipd2 , 16 , mbay(1,lun),mbit)
154  CALL pkb(ipd3 , 16 , mbay(1,lun),mbit)
155  CALL pkb(ipd4 , 16 , mbay(1,lun),mbit)
156  CALL pkb( 0 , 8 , mbay(1,lun),mbit)
157 
158 C SECTION 4
159 C ---------
160 
161  CALL pkb(nby4 , 24 , mbay(1,lun),mbit)
162  CALL pkb( 0 , 8 , mbay(1,lun),mbit)
163 
164 C SECTION 5
165 C ---------
166 
167  CALL pkc(sevn , 4 , mbay(1,lun),mbit)
168 
169 C DOUBLE CHECK INITIAL MESSAGE LENGTH
170 C -----------------------------------
171 
172  IF(mod(mbit,8).NE.0) goto 903
173  IF(mbit/8.NE.nbyt ) goto 904
174 
175  nmsg(lun) = nmsg(lun)+1
176  nsub(lun) = 0
177  mbyt(lun) = nbyt
178 
179  luncpy(lun)=0
180 
181 C EXITS
182 C -----
183 
184  RETURN
185 900 WRITE(bort_str,'("BUFRLIB: MSGINI - MISMATCH BETWEEN INODE (=",'//
186  . 'I7,") & POSITIONAL INDEX, INOD (",I7,") OF SUBTAG (",A,") IN '//
187  . 'DICTIONARY")') inode(lun),inod,subtag
188  CALL bort(bort_str)
189 901 WRITE(bort_str,'("BUFRLIB: MSGINI - TABLE A MESSAGE TYPE '//
190  . 'MNEMONIC ",A," NOT FOUND IN INTERNAL TABLE D ARRAYS")') subtag
191  CALL bort(bort_str)
192 902 CALL bort
193  . ('BUFRLIB: MSGINI - BUFR MESSAGE DATE (IDATE) is 0000000000')
194 903 CALL bort('BUFRLIB: MSGINI - INITIALIZED MESSAGE DOES NOT END '//
195  . 'ON A BYTE BOUNDARY')
196 904 WRITE(bort_str,'("BUFRLIB: MSGINI - NUMBER OF BYTES STORED FOR '//
197  . 'INITIALIZED MESSAGE (",I6,") IS NOT THE SAME AS FIRST '//
198  . 'CALCULATED, NBYT (",I6)') mbit/8,nbyt
199  CALL bort(bort_str)
200  END
moda_ufbcpl
Definition: moda_ufbcpl.F:1
pkc
subroutine pkc(CHR, NCHR, IBAY, IBIT)
This subroutine encodes a character string within a specified number of bits of an integer array...
Definition: pkc.f:40
moda_tables
This module contains array and variable declarations used to store the internal jump/link table...
Definition: moda_tables.F:13
msgini
subroutine msgini(LUN)
THIS SUBROUTINE INITIALIZES, WITHIN THE INTERNAL ARRAYS, A NEW BUFR MESSAGE FOR OUTPUT.
Definition: msgini.f:57
nemtab
subroutine nemtab(LUN, NEMO, IDN, TAB, IRET)
This subroutine returns information about a descriptor from the internal DX BUFR tables, based on the mnemonic associated with that descriptor.
Definition: nemtab.f:44
bort
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:22
pkb
subroutine pkb(NVAL, NBITS, IBAY, IBIT)
This subroutine encodes an integer value within a specified number of bits of an integer array...
Definition: pkb.f:38
moda_bitbuf
This module contains array and variable declarations used to store BUFR messages internally for multi...
Definition: moda_bitbuf.F:10
moda_msgcwd
Definition: moda_msgcwd.F:1
nemtba
subroutine nemtba(LUN, NEMO, MTYP, MSBT, INOD)
This subroutine searches for a descriptor within Table A of the internal DX BUFR tables.
Definition: nemtba.f:35