NCEPLIBS-bufr  11.5.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>
44 C> USAGE: CALL MSGINI (LUN)
45 C> INPUT ARGUMENT LIST:
46 C> LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS
47 C>
48 C> REMARKS:
49 C> THIS ROUTINE CALLS: BORT NEMTAB NEMTBA PKB
50 C> PKC
51 C> THIS ROUTINE IS CALLED BY: CPYUPD MSGUPD OPENMB OPENMG
52 C> Normally not called by any application
53 C> programs.
54 C>
55  SUBROUTINE msgini(LUN)
56 
57  USE moda_msgcwd
58  USE moda_ufbcpl
59  USE moda_bitbuf
60  USE moda_tables
61 
62  COMMON /padesc/ ibct,ipd1,ipd2,ipd3,ipd4
63  COMMON /msgptr/ nby0,nby1,nby2,nby3,nby4,nby5
64 
65  CHARACTER*128 bort_str
66  CHARACTER*8 subtag
67  CHARACTER*4 bufr,sevn
68  CHARACTER*1 tab
69 
70  DATA bufr/'BUFR'/
71  DATA sevn/'7777'/
72 
73 C-----------------------------------------------------------------------
74 C-----------------------------------------------------------------------
75 
76 C GET THE MESSAGE TAG AND TYPE, AND BREAK UP THE DATE
77 C ---------------------------------------------------
78 
79  subtag = tag(inode(lun))
80 c .... Given SUBSET, NEMTBA returns MTYP,MSBT,INOD
81  CALL nemtba(lun,subtag,mtyp,msbt,inod)
82  IF(inode(lun).NE.inod) goto 900
83  CALL nemtab(lun,subtag,isub,tab,iret)
84  IF(iret.EQ.0) goto 901
85 
86 C DATE CAN BE YYMMDDHH OR YYYYMMDDHH
87 C ----------------------------------
88 
89  mcen = mod(idate(lun)/10**8,100)+1
90  mear = mod(idate(lun)/10**6,100)
91  mmon = mod(idate(lun)/10**4,100)
92  mday = mod(idate(lun)/10**2,100)
93  mour = mod(idate(lun) ,100)
94  mmin = 0
95 
96 c .... DK: Can this happen?? (investigate)
97  IF(mcen.EQ.1) goto 902
98 
99  IF(mear.EQ.0) mcen = mcen-1
100  IF(mear.EQ.0) mear = 100
101 
102 C INITIALIZE THE MESSAGE
103 C ----------------------
104 
105  mbit = 0
106  nby0 = 8
107  nby1 = 18
108  nby2 = 0
109  nby3 = 20
110  nby4 = 4
111  nby5 = 4
112  nbyt = nby0+nby1+nby2+nby3+nby4+nby5
113 
114 C SECTION 0
115 C ---------
116 
117  CALL pkc(bufr , 4 , mbay(1,lun),mbit)
118  CALL pkb(nbyt , 24 , mbay(1,lun),mbit)
119  CALL pkb( 3 , 8 , mbay(1,lun),mbit)
120 
121 C SECTION 1
122 C ---------
123 
124  CALL pkb(nby1 , 24 , mbay(1,lun),mbit)
125  CALL pkb( 0 , 8 , mbay(1,lun),mbit)
126  CALL pkb( 3 , 8 , mbay(1,lun),mbit)
127  CALL pkb( 7 , 8 , mbay(1,lun),mbit)
128  CALL pkb( 0 , 8 , mbay(1,lun),mbit)
129  CALL pkb( 0 , 8 , mbay(1,lun),mbit)
130  CALL pkb(mtyp , 8 , mbay(1,lun),mbit)
131  CALL pkb(msbt , 8 , mbay(1,lun),mbit)
132  CALL pkb( 29 , 8 , mbay(1,lun),mbit)
133  CALL pkb( 0 , 8 , mbay(1,lun),mbit)
134  CALL pkb(mear , 8 , mbay(1,lun),mbit)
135  CALL pkb(mmon , 8 , mbay(1,lun),mbit)
136  CALL pkb(mday , 8 , mbay(1,lun),mbit)
137  CALL pkb(mour , 8 , mbay(1,lun),mbit)
138  CALL pkb(mmin , 8 , mbay(1,lun),mbit)
139  CALL pkb(mcen , 8 , mbay(1,lun),mbit)
140 
141 C SECTION 3
142 C ---------
143 
144  CALL pkb(nby3 , 24 , mbay(1,lun),mbit)
145  CALL pkb( 0 , 8 , mbay(1,lun),mbit)
146  CALL pkb( 0 , 16 , mbay(1,lun),mbit)
147  CALL pkb(2**7 , 8 , mbay(1,lun),mbit)
148  CALL pkb(ibct , 16 , mbay(1,lun),mbit)
149  CALL pkb(isub , 16 , mbay(1,lun),mbit)
150  CALL pkb(ipd1 , 16 , mbay(1,lun),mbit)
151  CALL pkb(ipd2 , 16 , mbay(1,lun),mbit)
152  CALL pkb(ipd3 , 16 , mbay(1,lun),mbit)
153  CALL pkb(ipd4 , 16 , mbay(1,lun),mbit)
154  CALL pkb( 0 , 8 , mbay(1,lun),mbit)
155 
156 C SECTION 4
157 C ---------
158 
159  CALL pkb(nby4 , 24 , mbay(1,lun),mbit)
160  CALL pkb( 0 , 8 , mbay(1,lun),mbit)
161 
162 C SECTION 5
163 C ---------
164 
165  CALL pkc(sevn , 4 , mbay(1,lun),mbit)
166 
167 C DOUBLE CHECK INITIAL MESSAGE LENGTH
168 C -----------------------------------
169 
170  IF(mod(mbit,8).NE.0) goto 903
171  IF(mbit/8.NE.nbyt ) goto 904
172 
173  nmsg(lun) = nmsg(lun)+1
174  nsub(lun) = 0
175  mbyt(lun) = nbyt
176 
177  luncpy(lun)=0
178 
179 C EXITS
180 C -----
181 
182  RETURN
183 900 WRITE(bort_str,'("BUFRLIB: MSGINI - MISMATCH BETWEEN INODE (=",'//
184  . 'I7,") & POSITIONAL INDEX, INOD (",I7,") OF SUBTAG (",A,") IN '//
185  . 'DICTIONARY")') inode(lun),inod,subtag
186  CALL bort(bort_str)
187 901 WRITE(bort_str,'("BUFRLIB: MSGINI - TABLE A MESSAGE TYPE '//
188  . 'MNEMONIC ",A," NOT FOUND IN INTERNAL TABLE D ARRAYS")') subtag
189  CALL bort(bort_str)
190 902 CALL bort
191  . ('BUFRLIB: MSGINI - BUFR MESSAGE DATE (IDATE) is 0000000000')
192 903 CALL bort('BUFRLIB: MSGINI - INITIALIZED MESSAGE DOES NOT END '//
193  . 'ON A BYTE BOUNDARY')
194 904 WRITE(bort_str,'("BUFRLIB: MSGINI - NUMBER OF BYTES STORED FOR '//
195  . 'INITIALIZED MESSAGE (",I6,") IS NOT THE SAME AS FIRST '//
196  . 'CALCULATED, NBYT (",I6)') mbit/8,nbyt
197  CALL bort(bort_str)
198  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:42
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:55
nemtab
subroutine nemtab(LUN, NEMO, IDN, TAB, IRET)
THIS SUBROUTINE SEARCHES FOR MNEMONIC NEMO WITHIN THE INTERNAL TABLE B AND D ARRAYS HOLDING THE DICTI...
Definition: nemtab.f:66
bort
subroutine bort(STR)
This subroutine calls subroutine errwrt() to log an error message, then calls subroutine bort_exit() ...
Definition: bort.f:23
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:40
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 MNEMONIC NEMO WITHIN THE INTERNAL TABLE A ARRAYS HOLDING THE DICTIONARY ...
Definition: nemtba.f:50