| blob | a93714274be92c205e4d64c993543fe587d3e9cd |
1 C-----------------------------------------------------------------------
2 SUBROUTINE PUTGB2(LUGB,GFLD,IRET)
3 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
4 C
5 C SUBPROGRAM: PUTGB2 PACKS AND WRITES A GRIB2 MESSAGE
6 C PRGMMR: GILBERT ORG: W/NP11 DATE: 2002-04-22
7 C
8 C ABSTRACT: PACKS A SINGLE FIELD INTO A GRIB2 MESSAGE
9 C AND WRITES OUT THAT MESSAGE TO THE FILE ASSOCIATED WITH UNIT LUGB.
10 C NOTE THAT FILE/UNIT LUGB SHOULD BE OPENED WOTH A CALL TO
11 C SUBROUTINE BAOPENW BEFORE THIS ROUTINE IS CALLED.
12 C
13 C The information to be packed into the GRIB field
14 C is stored in a derived type variable, gfld.
15 C Gfld is of type gribfield, which is defined
16 C in module grib_mod, so users of this routine will need to include
17 C the line "USE GRIB_MOD" in their calling routine. Each component of the
18 C gribfield type is described in the INPUT ARGUMENT LIST section below.
19 C
20 C PROGRAM HISTORY LOG:
21 C 2002-04-22 GILBERT
22 C 2005-02-28 GILBERT - Changed dimension of array cgrib to be a multiple
23 C of gfld%ngrdpts instead of gfld%ndpts.
24 C
25 C USAGE: CALL PUTGB2(LUGB,GFLD,IRET)
26 C INPUT ARGUMENTS:
27 C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE.
28 C FILE MUST BE OPENED WITH BAOPEN OR BAOPENW BEFORE CALLING
29 C THIS ROUTINE.
30 C gfld - derived type gribfield ( defined in module grib_mod )
31 C ( NOTE: See Remarks Section )
32 C gfld%version = GRIB edition number ( currently 2 )
33 C gfld%discipline = Message Discipline ( see Code Table 0.0 )
34 C gfld%idsect() = Contains the entries in the Identification
35 C Section ( Section 1 )
36 C This element is actually a pointer to an array
37 C that holds the data.
38 C gfld%idsect(1) = Identification of originating Centre
39 C ( see Common Code Table C-1 )
40 C 7 - US National Weather Service
41 C gfld%idsect(2) = Identification of originating Sub-centre
42 C gfld%idsect(3) = GRIB Master Tables Version Number
43 C ( see Code Table 1.0 )
44 C 0 - Experimental
45 C 1 - Initial operational version number
46 C gfld%idsect(4) = GRIB Local Tables Version Number
47 C ( see Code Table 1.1 )
48 C 0 - Local tables not used
49 C 1-254 - Number of local tables version used
50 C gfld%idsect(5) = Significance of Reference Time (Code Table 1.2)
51 C 0 - Analysis
52 C 1 - Start of forecast
53 C 2 - Verifying time of forecast
54 C 3 - Observation time
55 C gfld%idsect(6) = Year ( 4 digits )
56 C gfld%idsect(7) = Month
57 C gfld%idsect(8) = Day
58 C gfld%idsect(9) = Hour
59 C gfld%idsect(10) = Minute
60 C gfld%idsect(11) = Second
61 C gfld%idsect(12) = Production status of processed data
62 C ( see Code Table 1.3 )
63 C 0 - Operational products
64 C 1 - Operational test products
65 C 2 - Research products
66 C 3 - Re-analysis products
67 C gfld%idsect(13) = Type of processed data ( see Code Table 1.4 )
68 C 0 - Analysis products
69 C 1 - Forecast products
70 C 2 - Analysis and forecast products
71 C 3 - Control forecast products
72 C 4 - Perturbed forecast products
73 C 5 - Control and perturbed forecast products
74 C 6 - Processed satellite observations
75 C 7 - Processed radar observations
76 C gfld%idsectlen = Number of elements in gfld%idsect().
77 C gfld%local() = Pointer to character array containing contents
78 C of Local Section 2, if included
79 C gfld%locallen = length of array gfld%local()
80 C gfld%ifldnum = field number within GRIB message
81 C gfld%griddef = Source of grid definition (see Code Table 3.0)
82 C 0 - Specified in Code table 3.1
83 C 1 - Predetermined grid Defined by originating centre
84 C gfld%ngrdpts = Number of grid points in the defined grid.
85 C gfld%numoct_opt = Number of octets needed for each
86 C additional grid points definition.
87 C Used to define number of
88 C points in each row ( or column ) for
89 C non-regular grids.
90 C = 0, if using regular grid.
91 C gfld%interp_opt = Interpretation of list for optional points
92 C definition. (Code Table 3.11)
93 C gfld%igdtnum = Grid Definition Template Number (Code Table 3.1)
94 C gfld%igdtmpl() = Contains the data values for the specified Grid
95 C Definition Template ( NN=gfld%igdtnum ). Each
96 C element of this integer array contains an entry (in
97 C the order specified) of Grid Defintion Template 3.NN
98 C This element is actually a pointer to an array
99 C that holds the data.
100 C gfld%igdtlen = Number of elements in gfld%igdtmpl(). i.e. number of
101 C entries in Grid Defintion Template 3.NN
102 C ( NN=gfld%igdtnum ).
103 C gfld%list_opt() = (Used if gfld%numoct_opt .ne. 0) This array
104 C contains the number of grid points contained in
105 C each row ( or column ). (part of Section 3)
106 C This element is actually a pointer to an array
107 C that holds the data. This pointer is nullified
108 C if gfld%numoct_opt=0.
109 C gfld%num_opt = (Used if gfld%numoct_opt .ne. 0) The number of entries
110 C in array ideflist. i.e. number of rows ( or columns )
111 C for which optional grid points are defined. This value
112 C is set to zero, if gfld%numoct_opt=0.
113 C gfdl%ipdtnum = Product Definition Template Number (see Code Table 4.0)
114 C gfld%ipdtmpl() = Contains the data values for the specified Product
115 C Definition Template ( N=gfdl%ipdtnum ). Each element
116 C of this integer array contains an entry (in the
117 C order specified) of Product Defintion Template 4.N.
118 C This element is actually a pointer to an array
119 C that holds the data.
120 C gfld%ipdtlen = Number of elements in gfld%ipdtmpl(). i.e. number of
121 C entries in Product Defintion Template 4.N
122 C ( N=gfdl%ipdtnum ).
123 C gfld%coord_list() = Real array containing floating point values
124 C intended to document the vertical discretisation
125 C associated to model data on hybrid coordinate
126 C vertical levels. (part of Section 4)
127 C This element is actually a pointer to an array
128 C that holds the data.
129 C gfld%num_coord = number of values in array gfld%coord_list().
130 C gfld%ndpts = Number of data points unpacked and returned.
131 C gfld%idrtnum = Data Representation Template Number
132 C ( see Code Table 5.0)
133 C gfld%idrtmpl() = Contains the data values for the specified Data
134 C Representation Template ( N=gfld%idrtnum ). Each
135 C element of this integer array contains an entry
136 C (in the order specified) of Product Defintion
137 C Template 5.N.
138 C This element is actually a pointer to an array
139 C that holds the data.
140 C gfld%idrtlen = Number of elements in gfld%idrtmpl(). i.e. number
141 C of entries in Data Representation Template 5.N
142 C ( N=gfld%idrtnum ).
143 C gfld%unpacked = logical value indicating whether the bitmap and
144 C data values were unpacked. If false,
145 C gfld%bmap and gfld%fld pointers are nullified.
146 C gfld%ibmap = Bitmap indicator ( see Code Table 6.0 )
147 C 0 = bitmap applies and is included in Section 6.
148 C 1-253 = Predefined bitmap applies
149 C 254 = Previously defined bitmap applies to this field
150 C 255 = Bit map does not apply to this product.
151 C gfld%bmap() = Logical*1 array containing decoded bitmap,
152 C if ibmap=0 or ibap=254. Otherwise nullified.
153 C This element is actually a pointer to an array
154 C that holds the data.
155 C gfld%fld() = Array of gfld%ndpts unpacked data points.
156 C This element is actually a pointer to an array
157 C that holds the data.
158 C
159 C OUTPUT ARGUMENTS:
160 C IRET INTEGER RETURN CODE
161 C 0 ALL OK
162 C 2 MEMORY ALLOCATION ERROR
163 C 10 No Section 1 info available
164 C 11 No Grid Definition Template info available
165 C 12 Missing some required data field info
166 C
167 C SUBPROGRAMS CALLED:
168 C gribcreate Start a new grib2 message
169 C addlocal Add local section to a GRIB2 message
170 C addgrid Add grid info to a GRIB2 message
171 C addfield Add data field to a GRIB2 message
172 C gribend End GRIB2 message
173 C
174 C REMARKS:
175 C
176 C Note that derived type gribfield contains pointers to many
177 C arrays of data. The memory for these arrays is allocated
178 C when the values in the arrays are set, to help minimize
179 C problems with array overloading. Because of this users
180 C are encouraged to free up this memory, when it is no longer
181 C needed, by an explicit call to subroutine gf_free.
182 C ( i.e. CALL GF_FREE(GFLD) )
183 C
184 C ATTRIBUTES:
185 C LANGUAGE: FORTRAN 90
186 C
187 C$$$
188 USE GRIB_MOD
190 INTEGER,INTENT(IN) :: LUGB
191 TYPE(GRIBFIELD),INTENT(IN) :: GFLD
192 INTEGER,INTENT(OUT) :: IRET
194 CHARACTER(LEN=1),ALLOCATABLE,DIMENSION(:) :: CGRIB
195 integer :: listsec0(2)=(/0,2/)
196 integer :: igds(5)=(/0,0,0,0,0/)
197 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
198 C ALLOCATE ARRAY FOR GRIB2 FIELD
199 lcgrib=gfld%ngrdpts*4
200 allocate(cgrib(lcgrib),stat=is)
201 if ( is.ne.0 ) then
202 print *,'putgb2: cannot allocate memory. ',is
203 iret=2
204 endif
205 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
206 C CREATE NEW MESSAGE
207 listsec0(1)=gfld%discipline
208 listsec0(2)=gfld%version
209 if ( associated(gfld%idsect) ) then
210 call gribcreate(cgrib,lcgrib,listsec0,gfld%idsect,ierr)
211 if (ierr.ne.0) then
212 write(6,*) 'putgb2: ERROR creating new GRIB2 field = ',ierr
213 endif
214 else
215 print *,'putgb2: No Section 1 info available. '
216 iret=10
217 deallocate(cgrib)
218 return
219 endif
220 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
221 C ADD LOCAL USE SECTION TO GRIB2 MESSAGE
222 if ( associated(gfld%local).AND.gfld%locallen.gt.0 ) then
223 call addlocal(cgrib,lcgrib,gfld%local,gfld%locallen,ierr)
224 if (ierr.ne.0) then
225 write(6,*) 'putgb2: ERROR adding local info = ',ierr
226 endif
227 endif
228 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
229 C ADD GRID TO GRIB2 MESSAGE
230 igds(1)=gfld%griddef
231 igds(2)=gfld%ngrdpts
232 igds(3)=gfld%numoct_opt
233 igds(4)=gfld%interp_opt
234 igds(5)=gfld%igdtnum
235 if ( associated(gfld%igdtmpl) ) then
236 call addgrid(cgrib,lcgrib,igds,gfld%igdtmpl,gfld%igdtlen,
237 & gfld%list_opt,gfld%num_opt,ierr)
238 if (ierr.ne.0) then
239 write(6,*) 'putgb2: ERROR adding grid info = ',ierr
240 endif
241 else
242 print *,'putgb2: No GDT info available. '
243 iret=11
244 deallocate(cgrib)
245 return
246 endif
247 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
248 C ADD DATA FIELD TO GRIB2 MESSAGE
249 if ( associated(gfld%ipdtmpl).AND.
250 & associated(gfld%idrtmpl).AND.
251 & associated(gfld%fld) ) then
252 call addfield(cgrib,lcgrib,gfld%ipdtnum,gfld%ipdtmpl,
253 & gfld%ipdtlen,gfld%coord_list,gfld%num_coord,
254 & gfld%idrtnum,gfld%idrtmpl,gfld%idrtlen,
255 & gfld%fld,gfld%ngrdpts,gfld%ibmap,gfld%bmap,
256 & ierr)
257 if (ierr.ne.0) then
258 write(6,*) 'putgb2: ERROR adding data field = ',ierr
259 endif
260 else
261 print *,'putgb2: Missing some field info. '
262 iret=12
263 deallocate(cgrib)
264 return
265 endif
266 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
267 C CLOSE GRIB2 MESSAGE AND WRITE TO FILE
268 call gribend(cgrib,lcgrib,lengrib,ierr)
269 call wryte(lugb,lengrib,cgrib)
270 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
271 deallocate(cgrib)
272 RETURN
273 END