NCEPLIBS-w3emc  2.9.3
w3fi63.f
Go to the documentation of this file.
1 C> @file
2 C> @brief Unpk grib field to grib grid.
3 C> @author Bill Cavanaugh @date 1991-09-13
4 
5 C> Unpack a grib (edition 1) field to the exact grid
6 C> specified in the grib message, isolate the bit map, and make
7 C> the values of the product descripton section (pds) and the
8 C> grid description section (gds) available in return arrays.
9 C>
10 C> When decoding is completed, data at each grid point has been
11 C> returned in the units specified in the grib manual.
12 C>
13 C> PROGRAM HISTORY LOG:
14 C> - Bill Cavanaugh 1991-09-13
15 C> - Bill Cavanaugh 1991-11-12 Modified size of ecmwf grids 5-8
16 C> - Bill Cavanaugh 1991-12-22 Corrected processing of mercator projections
17 C> in grid definition section (gds) in
18 C> routine fi633
19 C> - Bill Cavanaugh 1992-08-05 Corrected maximum grid size to allow for
20 C> one degree by one degree global grids
21 C> - Bill Cavanaugh 1992-08-27 Corrected typo error, added code to compare
22 C> total byte size from section 0 with sum of
23 C> section sizes.
24 C> - Bill Cavanaugh 1992-10-21 Corrections were made (in fi634) to reduce
25 C> processing time for international grids.
26 C> removed a typographical error in fi635.
27 C> - Bill Cavanaugh 1993-01-07 Corrections were made (in fi635) to
28 C> facilitate use of these routines on a pc.
29 C> a typographical error was also corrected
30 C> - Bill Cavanaugh 1993-01-13 Corrections were made (in fi632) to
31 C> properly handle condition when
32 C> time range indicator = 10.
33 C> added u.s.grid 87.
34 C> - Bill Cavanaugh 1993-02-04 Added u.s.grids 85 and 86
35 C> - Bill Cavanaugh 1993-02-26 Added grids 2, 3, 37 thru 44,and
36 C> grids 55, 56, 90, 91, 92, and 93 to
37 C> list of u.s. grids.
38 C> - Bill Cavanaugh 1993-04-07 Added grids 67 thru 77 to
39 C> list of u.s. grids.
40 C> - Bill Cavanaugh 1993-04-20 Increased max size to accomodate
41 C> gaussian grids.
42 C> - Bill Cavanaugh 1993-05-26 Corrected grid range selection in fi634
43 C> for ranges 67-71 & 75-77
44 C> - Bill Cavanaugh 1993-06-08 Corrected fi635 to accept grib messages
45 C> with second order packing. added routine fi636
46 C> to process messages with second order packing.
47 C> - Bill Cavanaugh 1993-09-22 Modified to extract sub-center number from
48 C> pds byte 26
49 C> - Bill Cavanaugh 1993-10-13 Modified fi634 to correct grid sizes for
50 C> grids 204 and 208
51 C> - Bill Cavanaugh 1993-10-14 Increased size of kgds to include entries for
52 C> number of points in grid and number of words
53 C> in each row
54 C> - Bill Cavanaugh 1993-12-08 Corrected test for edition number instead
55 C> of version number
56 C> - Bill Cavanaugh 1993-12-15 Modified second order pointers to first order
57 C> values and second order values correctly
58 C> in routine fi636
59 C> - Bill Cavanaugh 1994-03-02 Added call to w3fi83 within decoder. user
60 C> no longer needs to make call to this routine
61 C> - Bill Cavanaugh 1994-04-22 Modified fi635, fi636 to process row by row
62 C> second order packing, added scaling correction
63 C> to fi635, and corrected typographical errors
64 C> in comment fields in fi634
65 C> - Bill Cavanaugh 1994-05-17 COrrected error in fi633 to extract resolution
66 C> for lambert-conformal grids. added clarifying
67 C> information to docblock entries
68 C> - Bill Cavanaugh 1994-05-25 Added code to process column by column as well
69 C> as row by row ordering of second order data
70 C> - Bill Cavanaugh 1994-06-27 Added processing for grids 45, 94 and 95.
71 C> includes construction of second order bit maps
72 C> for thinned grids in fi636.
73 C> - Bill Cavanaugh 1994-07-08 Commented out print outs used for debugging
74 C> - Bill Cavanaugh 1994-09-08 Added grids 220, 221, 223 for fnoc
75 C> - Farley 1994-11-10 Increased mxsize from 72960 to 260000
76 C> for .5 degree sst analysis fields
77 C> - Ralph Jones 1994-12-06 Changes in fi632 for pds greater than 28
78 C> - Ralph Jones 1995-02-14 Correct in fi633 for navy wafs grib
79 C> - M Baldwin 1995-03-20 Fi633 modification to get
80 C> data rep types [kgds(1)] 201 and 202 to work.
81 C> - M. Baldwin 1995-04-10 Added grids 96 and 97 for eta model in fi634.
82 C> - Ralph Jones 1995-04-26 Fi636 corection for 2nd order complex
83 C> unpacking. r
84 C> - Ralph Jones 1995-05-19 Added grid 215, 20 km awips grid
85 C> - Ralph Jones 1995-07-06 Added gaussian t62, t126 grid 98, 126
86 C> - Ralph Jones 1995-10-19 Added grid 216, 45 km eta awips alaska grid
87 C> - Mark Iredell 1995-10-31 Removed saves and prints
88 C> - Ralph Jones 1996-03-07 Continue unpack with kret error 9 in fi631.
89 C> - Ralph Jones 1996-08-19 Added mercator grids 8 and 53, and grid 196
90 C> - W. Bostelman 1997-02-12 Corrects ecmwf us grid 2 processing
91 C> - Mark Iredell 1998-06-17 Removed alternate return in fi637
92 C> - Mark Iredell 1998-08-31 Eliminated need for mxsize
93 C> - Stephen Gilbert 1998-09-02 Corrected error in map size for U.S. Grid 92
94 C> - M. Baldwin 1998-09-08 Add data rep type [kgds(1)] 203
95 C> - Eric Rogers 2001-03-08 Changed eta grids 90-97, added eta grids
96 C> 194, 198. added awips grids 241,242,243,
97 C> 245, 246, 247, 248, and 250
98 C> - Boi Vuong 2001-03-19 Added awips grids 238,239,240, and 244
99 C> - Stephen Gilbert 2001-06-06 Changed gbyte/sbyte calls to refer to
100 C> Wesley Ebisuzaki's endian independent
101 C> versions gbytec/sbytec.
102 C> Removed equivalences.
103 C> - Eric Rogers 2001-05-03 Added grid 249 (12km for alaska)
104 C> - Eric Rogers 2001-10-10 Redefined grid 218 for 12 km eta
105 C> redefined grid 192 for new 32-km eta grid
106 C> - Boi Vuong 2002-03-27 VUONG Added rsas grid 88 and awips grids 219, 220,
107 C> 223, 224, 225, 226, 227, 228, 229, 230, 231,
108 C> 232, 233, 234, 235, 251, and 252
109 C> - Eric Rogers 2002-08-06 Redefined grids 90-93,97,194,245-250 for the
110 C> 8km hi-res-window model and add awips grid 253
111 C> - Stephen Gilbert 2003-06-30 Set new values in array kptr to pass back additional
112 C> packing info.
113 C> kptr(19) - binary scale factor
114 C> kptr(20) - num bits used to pack each datum
115 C> - Stephen Gilbert 2003-06-30 Added grids 145 and 146 for cmaq
116 C> and grid 175 for awips over guam.
117 C> - Boi Vuong 2003-07-08 Added grids 110, 127, 171, 172 and modified grid 170
118 C> - Boi Vuong 2004-09-02 Added awips grids 147, 148, 173 and 254
119 C> 2005-01-04 COOKE Added awips grids 160 and 161
120 C> - Boi Vuong 2005-03-03 Moved grid 170 to grid 174 and add grid 170
121 C> - Boi Vuong 2005-03-21 Added awips grid 130
122 C> - Boi Vuong 2005-10-11 Added awips grid 163
123 C> - Boi Vuong 2006-12-12 Added awips grid 120
124 C> - Boi Vuong 2007-04-12 Added awips 176 and data rep type kgds(1) 204
125 C> - Boi Vuong 2007-06-11 Added new grids 11 to 18 and 122 to 125 and 138
126 C> and 180 to 183
127 C> - Boi Vuong 2007-11-06 Changed grid 198 from arakawa staggered e-grid to polar
128 C> stereograpgic grid added new grid 10, 99, 150, 151, 197
129 C> - Boi Vuong 2008-01-17 Added new grid 195 and changed grid 196 (arakawa-e to mercator)
130 C> - Boi Vuong 2009-05-21 Modified to handle grid 45
131 C> - Boi Vuong 2010-05-11 Data rep type kgds(1) 205
132 C> - Boi Vuong 2010-02-18 Added grid 128, 139 and 140
133 C> 2010-07-20 Added rotated lat/lon "a,b,c,d" staggers -> kgds(1) 205
134 C> - Boi Vuong 2010-08-05 Added new grid 184, 199, 83 and
135 C> redefined grid 90 for new rtma conus 1.27-km
136 C> redefined grid 91 for new rtma alaska 2.976-km
137 C> redefined grid 92 for new rtma alaska 1.488-km
138 C> - Eric Rogers 2010-09-08 Changed grid 94 to alaska 6km staggered b-grid
139 C> changed grid 95 to puerto rico 3km staggered b-grid
140 C> changed grid 96 to hawaii 3km staggered b-grid
141 C> changed grid 96 to hawaii 3km staggered b-grid
142 C> changed grid 97 to conus 4km staggered b-grid
143 C> changed grid 99 to nam 12km staggered b-grid
144 C> added grid 179 (12 km polar stereographic over north america)
145 C> changed grid 194 to 3km mercator grid over puerto rico
146 C> corrected latitude of sw corner point of grid 151
147 C> - Boi Vuong 2011-10-12 Added grid 129, 187, 188, 189 and 193
148 C> - Boi Vuong 2012-04-16 Added new grid 132, 200
149 C> - Boi Vuong 2017-07-17 Correct grid 161 number of point nj from 102 to 103
150 C> and map size from 13974 to 14111
151 C>
152 C> @param[in] MSGA Grib field - "grib" thru "7777" char*1
153 C> (message can be preceded by junk chars)
154 C> @param[out] DATA Array containing data elements
155 C> @param[out] KPDS Array containing pds elements. (edition 1)
156 C> - 1 Id of center
157 C> - 2 Generating process id number
158 C> - 3 Grid definition
159 C> - 4 Gds/bms flag (right adj copy of octet 8)
160 C> - 5 Indicator of parameter
161 C> - 6 Type of level
162 C> - 7 Height/pressure , etc of level
163 C> - 8 Year including (century-1)
164 C> - 9 Month of year
165 C> - 10 Day of month
166 C> - 11 Hour of day
167 C> - 12 Minute of hour
168 C> - 13 Indicator of forecast time unit
169 C> - 14 Time range 1
170 C> - 15 Time range 2
171 C> - 16 Time range flag
172 C> - 17 Number included in average
173 C> - 18 Version nr of grib specification
174 C> - 19 Version nr of parameter table
175 C> - 20 Nr missing from average/accumulation
176 C> - 21 Century of reference time of data
177 C> - 22 Units decimal scale factor
178 C> - 23 Subcenter number
179 C> - 24 Pds byte 29, for nmc ensemble products
180 C> - 128 If forecast field error
181 C> - 64 If bias corrected fcst field
182 C> - 32 If smoothed field
183 C> - Warning: can be combination of more than 1
184 C> - 25 Pds byte 30, not used
185 C> - 26-35 Reserved
186 C> - 36-N Consecutive bytes extracted from program
187 C> Definition section (pds) of grib message
188 C> @param[out] KGDS ARRAY CONTAINING GDS ELEMENTS.
189 C> - 1) Data representation type
190 C> - 19 Number of vertical coordinate parameters
191 C> - 20 Octet number of the list of vertical coordinate
192 C> Parameters Or Octet number of the list of numbers of points
193 C> In each row Or 255 if neither are present
194 C> - 21 For grids with pl, number of points in grid
195 C> - 22 Number of words in each row
196 C> - LATITUDE/LONGITUDE GRIDS
197 C> - 2 N(i) nr points on latitude circle
198 C> - 3 N(j) nr points on longitude meridian
199 C> - 4 La(1) latitude of origin
200 C> - 5 Lo(1) longitude of origin
201 C> - 6 Resolution flag (right adj copy of octet 17)
202 C> - 7 La(2) latitude of extreme point
203 C> - 8 Lo(2) longitude of extreme point
204 C> - 9 Di longitudinal direction of increment
205 C> - 10 Dj latitudinal direction increment
206 C> - 11 Scanning mode flag (right adj copy of octet 28)
207 C> - GAUSSIAN GRIDS
208 C> - 2 N(i) nr points on latitude circle
209 C> - 3 N(j) nr points on longitude meridian
210 C> - 4 La(1) latitude of origin
211 C> - 5 Lo(1) longitude of origin
212 C> - 6 Resolution flag (right adj copy of octet 17)
213 C> - 7 La(2) latitude of extreme point
214 C> - 8 Lo(2) longitude of extreme point
215 C> - 9 Di longitudinal direction of increment
216 C> - 10 N - nr of circles pole to equator
217 C> - 11 Scanning mode flag (right adj copy of octet 28)
218 C> - 12 Nv - nr of vert coord parameters
219 C> - 13 Pv - octet nr of list of vert coord parameters or
220 C> Pl - location of the list of numbers of points in
221 C> each row (if no vert coord parameters are present or
222 C> 255 if neither are present
223 C> - POLAR STEREOGRAPHIC GRIDS
224 C> - 2 N(i) nr points along lat circle
225 C> - 3 N(j) nr points along lon circle
226 C> - 4 La(1) latitude of origin
227 C> - 5 Lo(1) longitude of origin
228 C> - 6 Resolution flag (right adj copy of octet 17)
229 C> - 7 Lov grid orientation
230 C> - 8 Dx - x direction increment
231 C> - 9 Dy - y direction increment
232 C> - 10 Projection center flag
233 C> - 11 Scanning mode (right adj copy of octet 28)
234 C> - SPHERICAL HARMONIC COEFFICIENTS
235 C> - 2) J pentagonal resolution parameter
236 C> - 3) K pentagonal resolution parameter
237 C> - 4) M pentagonal resolution parameter
238 C> - 5) Representation type
239 C> - 6) Coefficient storage mode
240 C> - MERCATOR GRIDS
241 C> - 2 N(i) nr points on latitude circle
242 C> - 3 N(j) nr points on longitude meridian
243 C> - 4 La(1) latitude of origin
244 C> - 5 Lo(1) longitude of origin
245 C> - 6 Resolution flag (right adj copy of octet 17)
246 C> - 7 La(2) latitude of last grid point
247 C> - 8 Lo(2) longitude of last grid point
248 C> - 9 Latit - latitude of projection intersection
249 C> - 10 Reserved
250 C> - 11 Scanning mode flag (right adj copy of octet 28)
251 C> - 12 Longitudinal dir grid length
252 C> - 13 Latitudinal dir grid length
253 C> - LAMBERT CONFORMAL GRIDS
254 C> - 2 Nx nr points along x-axis
255 C> - 3 Ny nr points along y-axis
256 C> - 4 La1 lat of origin (lower left)
257 C> - 5 Lo1 lon of origin (lower left)
258 C> - 6 Resolution (right adj copy of octet 17)
259 C> - 7 Lov - orientation of grid
260 C> - 8 Dx - x-dir increment
261 C> - 9 Dy - y-dir increment
262 C> - 10 Projection center flag
263 C> - 11 Scanning mode flag (right adj copy of octet 28)
264 C> - 12 Latin 1 - first lat from pole of secant cone inter
265 C> - 13 Latin 2 - second lat from pole of secant cone inter
266 C> - E-STAGGERED ARAKAWA ROTATED LAT/LON GRIDS (TYPE 203)
267 C> - 2 N(i) nr points on latitude circle
268 C> - 3 N(j) nr points on longitude meridian
269 C> - 4 La(1) latitude of origin
270 C> - 5 Lo(1) longitude of origin
271 C> - 6 Resolution flag (right adj copy of octet 17)
272 C> - 7 La(2) latitude of center
273 C> - 8 Lo(2) longitude of center
274 C> - 9 Di longitudinal direction of increment
275 C> - 10 Dj latitudinal direction increment
276 C> - 11 Scanning mode flag (right adj copy of octet 28)
277 C> - CURVILINEAR ORTHIGINAL GRID (TYPE 204)
278 C> - 2 N(i) nr points on latitude circle
279 C> - 3 N(j) nr points on longitude meridian
280 C> - 4 Reserved set to 0
281 C> - 5 Reserved set to 0
282 C> - 6 Resolution flag (right adj copy of octet 17)
283 C> - 7 Reserved set to 0
284 C> - 8 Reserved set to 0
285 C> - 9 Reserved set to 0
286 C> - 10 Reserved set to 0
287 C> - 11 Scanning mode flag (right adj copy of octet 28)
288 C> - ROTATED LAT/LON A,B,C,D-STAGGERED (TYPE 205)
289 C> - 2 N(i) nr points on latitude circle
290 C> - 3 N(j) nr points on longitude meridian
291 C> - 4 La(1) latitude of first point
292 C> - 5 Lo(1) longitude of first point
293 C> - 6 Resolution flag (right adj copy of octet 17)
294 C> - 7 La(2) latitude of center
295 C> - 8 Lo(2) longitude of center
296 C> - 9 Di longitudinal direction of increment
297 C> - 10 Dj latitudinal direction increment
298 C> - 11 Scanning mode flag (right adj copy of octet 28)
299 C> - 12 Latitude of last point
300 C> - 13 Longitude of last point
301 C> @param[out] KBMS Bitmap describing location of output elements.
302 C> (always constructed)
303 C> @param[out] KPTR Array containing storage for following parameters
304 C> - 1 Total length of grib message
305 C> - 2 Length of indicator (section 0)
306 C> - 3 Length of pds (section 1)
307 C> - 4 Length of gds (section 2)
308 C> - 5 Length of bms (section 3)
309 C> - 6 Length of bds (section 4)
310 C> - 7 Value of current byte
311 C> - 8 Bit pointer
312 C> - 9 Grib start bit nr
313 C> - 10 Grib/grid element count
314 C> - 11 Nr unused bits at end of section 3
315 C> - 12 Bit map flag (copy of bms octets 5,6)
316 C> - 13 Nr unused bits at end of section 2
317 C> - 14 Bds flags (right adj copy of octet 4)
318 C> - 15 Nr unused bits at end of section 4
319 C> - 16 Reserved
320 C> - 17 Reserved
321 C> - 18 Reserved
322 C> - 19 Binary scale factor
323 C> - 20 Num bits used to pack each datum
324 C> @param[out] KRET Flag indicating quality of completion
325 C>
326 C> @note When decoding is completed, data at each grid point has been
327 C> returned in the units specified in the grib manual.
328 C>
329 C> - Values for return flag (kret)
330 C> - 0 - Normal return, no errors
331 C> - 1 - 'grib' not found in first 100 chars
332 C> - 2 - '7777' not in correct location
333 C> - 3 - Unpacked field is larger than 260000
334 C> - 4 - Gds/ grid not one of currently accepted values
335 C> - 5 - Grid not currently avail for center indicated
336 C> - 8 - Temp gds indicated, but gds flag is off
337 C> - 9 - Gds indicates size mismatch with std grid
338 C> - 10 - Incorrect center indicator
339 C> - 11 - Binary data section (bds) not completely processed.
340 C> program is not set to process flag combinations
341 C> shown in octets 4 and 14.
342 C> - 12 - Binary data section (bds) not completely processed.
343 C> program is not set to process flag combinations
344 C>
345 C> @author Bill Cavanaugh @date 1991-09-13
346  SUBROUTINE w3fi63(MSGA,KPDS,KGDS,KBMS,DATA,KPTR,KRET)
347 C 4 AUG 1988
348 C W3FI63
349 C
350 C
351 C GRIB UNPACKING ROUTINE
352 C
353 C
354 C THIS ROUTINE WILL UNPACK A 'GRIB' FIELD TO THE EXACT GRID
355 C TYPE SPECIFIED IN THE MESSAGE, RETURN A BIT MAP AND MAKE THE
356 C VALUES OF THE PRODUCT DEFINITION SEC (PDS) AND THE GRID
357 C DESCRIPTION SEC (GDS) AVAILABLE IN RETURN ARRAYS.
358 C SEE "GRIB - THE WMO FORMAT FOR THE STORAGE OF WEATHER PRODUCT
359 C INFORMATION AND THE EXCHANGE OF WEATHER PRODUCT MESSAGES IN
360 C GRIDDED BINARY FORM" DATED JULY 1, 1988 BY JOHN D. STACKPOLE
361 C DOC, NOAA, NWS, NATIONAL METEOROLOGICAL CENTER.
362 C
363 C THE CALL TO THE GRIB UNPACKING ROUTINE IS AS FOLLOWS:
364 C
365 C CALL W3FI63(MSGA,KPDS,KGDS,LBMS,DATA,KPTR,KRET)
366 C
367 C INPUT:
368 C
369 C MSGA = CONTAINS THE GRIB MESSAGE TO BE UNPACKED. CHARACTERS
370 C "GRIB" MAY BEGIN ANYWHERE WITHIN FIRST 100 BYTES.
371 C
372 C OUTPUT:
373 C
374 C KPDS(100) INTEGER*4
375 C ARRAY TO CONTAIN THE ELEMENTS OF THE PRODUCT
376 C DEFINITION SEC .
377 C (VERSION 1)
378 C KPDS(1) - ID OF CENTER
379 C KPDS(2) - MODEL IDENTIFICATION (SEE "GRIB" TABLE 1)
380 C KPDS(3) - GRID IDENTIFICATION (SEE "GRIB" TABLE 2)
381 C KPDS(4) - GDS/BMS FLAG
382 C BIT DEFINITION
383 C 25 0 - GDS OMITTED
384 C 1 - GDS INCLUDED
385 C 26 0 - BMS OMITTED
386 C 1 - BMS INCLUDED
387 C NOTE:- LEFTMOST BIT = 1,
388 C RIGHTMOST BIT = 32
389 C KPDS(5) - INDICATOR OF PARAMETER (SEE "GRIB" TABLE 5)
390 C KPDS(6) - TYPE OF LEVEL (SEE "GRIB" TABLES 6 & 7)
391 C KPDS(7) - HEIGHT,PRESSURE,ETC OF LEVEL
392 C KPDS(8) - YEAR INCLUDING CENTURY
393 C KPDS(9) - MONTH OF YEAR
394 C KPDS(10) - DAY OF MONTH
395 C KPDS(11) - HOUR OF DAY
396 C KPDS(12) - MINUTE OF HOUR
397 C KPDS(13) - INDICATOR OF FORECAST TIME UNIT (SEE "GRIB"
398 C TABLE 8)
399 C KPDS(14) - TIME 1 (SEE "GRIB" TABLE 8A)
400 C KPDS(15) - TIME 2 (SEE "GRIB" TABLE 8A)
401 C KPDS(16) - TIME RANGE INDICATOR (SEE "GRIB" TABLE 8A)
402 C KPDS(17) - NUMBER INCLUDED IN AVERAGE
403 C KPDS(18) - EDITION NR OF GRIB SPECIFICATION
404 C KPDS(19) - VERSION NR OF PARAMETER TABLE
405 C
406 C KGDS(13) INTEGER*4
407 C ARRAY CONTAINING GDS ELEMENTS.
408 C
409 C KGDS(1) - DATA REPRESENTATION TYPE
410 C
411 C LATITUDE/LONGITUDE GRIDS (SEE "GRIB" TABLE 10)
412 C KGDS(2) - N(I) NUMBER OF POINTS ON LATITUDE
413 C CIRCLE
414 C KGDS(3) - N(J) NUMBER OF POINTS ON LONGITUDE
415 C CIRCLE
416 C KGDS(4) - LA(1) LATITUDE OF ORIGIN
417 C KGDS(5) - LO(1) LONGITUDE OF ORIGIN
418 C KGDS(6) - RESOLUTION FLAG
419 C BIT MEANING
420 C 25 0 - DIRECTION INCREMENTS NOT
421 C GIVEN
422 C 1 - DIRECTION INCREMENTS GIVEN
423 C KGDS(7) - LA(2) LATITUDE OF EXTREME POINT
424 C KGDS(8) - LO(2) LONGITUDE OF EXTREME POINT
425 C KGDS(9) - DI LONGITUDINAL DIRECTION INCREMENT
426 C KGDS(10) - REGULAR LAT/LON GRID
427 C DJ - LATITUDINAL DIRECTION
428 C INCREMENT
429 C GAUSSIAN GRID
430 C N - NUMBER OF LATITUDE CIRCLES
431 C BETWEEN A POLE AND THE EQUATOR
432 C KGDS(11) - SCANNING MODE FLAG
433 C BIT MEANING
434 C 25 0 - POINTS ALONG A LATITUDE
435 C SCAN FROM WEST TO EAST
436 C 1 - POINTS ALONG A LATITUDE
437 C SCAN FROM EAST TO WEST
438 C 26 0 - POINTS ALONG A MERIDIAN
439 C SCAN FROM NORTH TO SOUTH
440 C 1 - POINTS ALONG A MERIDIAN
441 C SCAN FROM SOUTH TO NORTH
442 C 27 0 - POINTS SCAN FIRST ALONG
443 C CIRCLES OF LATITUDE, THEN
444 C ALONG MERIDIANS
445 C (FORTRAN: (I,J))
446 C 1 - POINTS SCAN FIRST ALONG
447 C MERIDIANS THEN ALONG
448 C CIRCLES OF LATITUDE
449 C (FORTRAN: (J,I))
450 C
451 C POLAR STEREOGRAPHIC GRIDS (SEE GRIB TABLE 12)
452 C KGDS(2) - N(I) NR POINTS ALONG LAT CIRCLE
453 C KGDS(3) - N(J) NR POINTS ALONG LON CIRCLE
454 C KGDS(4) - LA(1) LATITUDE OF ORIGIN
455 C KGDS(5) - LO(1) LONGITUDE OF ORIGIN
456 C KGDS(6) - RESERVED
457 C KGDS(7) - LOV GRID ORIENTATION
458 C KGDS(8) - DX - X DIRECTION INCREMENT
459 C KGDS(9) - DY - Y DIRECTION INCREMENT
460 C KGDS(10) - PROJECTION CENTER FLAG
461 C KGDS(11) - SCANNING MODE
462 C
463 C SPHERICAL HARMONIC COEFFICIENTS (SEE "GRIB" TABLE 14)
464 C KGDS(2) - J PENTAGONAL RESOLUTION PARAMETER
465 C KGDS(3) - K PENTAGONAL RESOLUTION PARAMETER
466 C KGDS(4) - M PENTAGONAL RESOLUTION PARAMETER
467 C KGDS(5) - REPRESENTATION TYPE
468 C KGDS(6) - COEFFICIENT STORAGE MODE
469 C
470 C MERCATOR GRIDS
471 C KGDS(2) - N(I) NR POINTS ON LATITUDE CIRCLE
472 C KGDS(3) - N(J) NR POINTS ON LONGITUDE MERIDIAN
473 C KGDS(4) - LA(1) LATITUDE OF ORIGIN
474 C KGDS(5) - LO(1) LONGITUDE OF ORIGIN
475 C KGDS(6) - RESOLUTION FLAG
476 C KGDS(7) - LA(2) LATITUDE OF LAST GRID POINT
477 C KGDS(8) - LO(2) LONGITUDE OF LAST GRID POINT
478 C KGDS(9) - LATIN - LATITUDE OF PROJECTION INTERSECTION
479 C KGDS(10) - RESERVED
480 C KGDS(11) - SCANNING MODE FLAG
481 C KGDS(12) - LONGITUDINAL DIR GRID LENGTH
482 C KGDS(13) - LATITUDINAL DIR GRID LENGTH
483 C LAMBERT CONFORMAL GRIDS
484 C KGDS(2) - NX NR POINTS ALONG X-AXIS
485 C KGDS(3) - NY NR POINTS ALONG Y-AXIS
486 C KGDS(4) - LA1 LAT OF ORIGIN (LOWER LEFT)
487 C KGDS(5) - LO1 LON OF ORIGIN (LOWER LEFT)
488 C KGDS(6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17)
489 C KGDS(7) - LOV - ORIENTATION OF GRID
490 C KGDS(8) - DX - X-DIR INCREMENT
491 C KGDS(9) - DY - Y-DIR INCREMENT
492 C KGDS(10) - PROJECTION CENTER FLAG
493 C KGDS(11) - SCANNING MODE FLAG
494 C KGDS(12) - LATIN 1 - FIRST LAT FROM POLE OF
495 C SECANT CONE INTERSECTION
496 C KGDS(13) - LATIN 2 - SECOND LAT FROM POLE OF
497 C SECANT CONE INTERSECTION
498 C
499 C LBMS(*) LOGICAL
500 C ARRAY TO CONTAIN THE BIT MAP DESCRIBING THE
501 C PLACEMENT OF DATA IN THE OUTPUT ARRAY. IF A
502 C BIT MAP IS NOT INCLUDED IN THE SOURCE MESSAGE,
503 C ONE WILL BE GENERATED AUTOMATICALLY BY THE
504 C UNPACKING ROUTINE.
505 C
506 C
507 C DATA(*) REAL*4
508 C THIS ARRAY WILL CONTAIN THE UNPACKED DATA POINTS.
509 C
510 C NOTE:- 65160 IS MAXIMUN FIELD SIZE ALLOWABLE
511 C
512 C KPTR(10) INTEGER*4
513 C ARRAY CONTAINING STORAGE FOR THE FOLLOWING
514 C PARAMETERS.
515 C
516 C (1) - UNUSED
517 C (2) - UNUSED
518 C (3) - LENGTH OF PDS (IN BYTES)
519 C (4) - LENGTH OF GDS (IN BYTES)
520 C (5) - LENGTH OF BMS (IN BYTES)
521 C (6) - LENGTH OF BDS (IN BYTES)
522 C (7) - USED BY UNPACKING ROUTINE
523 C (8) - NUMBER OF DATA POINTS FOR GRID
524 C (9) - "GRIB" CHARACTERS START IN BYTE NUMBER
525 C (10) - USED BY UNPACKING ROUTINE
526 C
527 C
528 C KRET INTEGER*4
529 C THIS VARIABLE WILL CONTAIN THE RETURN INDICATOR.
530 C
531 C 0 - NO ERRORS DETECTED.
532 C
533 C 1 - 'GRIB' NOT FOUND IN FIRST 100
534 C CHARACTERS.
535 C
536 C 2 - '7777' NOT FOUND, EITHER MISSING OR
537 C TOTAL OF SEC COUNTS OF INDIVIDUAL
538 C SECTIONS IS INCORRECT.
539 C
540 C 3 - UNPACKED FIELD IS LARGER THAN 65160.
541 C
542 C 4 - IN GDS, DATA REPRESENTATION TYPE
543 C NOT ONE OF THE CURRENTLY ACCEPTABLE
544 C VALUES. SEE "GRIB" TABLE 9. VALUE
545 C OF INCORRECT TYPE RETURNED IN KGDS(1).
546 C
547 C 5 - GRID INDICATED IN KPDS(3) IS NOT
548 C AVAILABLE FOR THE CENTER INDICATED IN
549 C KPDS(1) AND NO GDS SENT.
550 C
551 C 7 - EDITION INDICATED IN KPDS(18) HAS NOT
552 C YET BEEN INCLUDED IN THE DECODER.
553 C
554 C 8 - GRID IDENTIFICATION = 255 (NOT STANDARD
555 C GRID) BUT FLAG INDICATING PRESENCE OF
556 C GDS IS TURNED OFF. NO METHOD OF
557 C GENERATING PROPER GRID.
558 C
559 C 9 - PRODUCT OF KGDS(2) AND KGDS(3) DOES NOT
560 C MATCH STANDARD NUMBER OF POINTS FOR THIS
561 C GRID (FOR OTHER THAN SPECTRALS). THIS
562 C WILL OCCUR ONLY IF THE GRID.
563 C IDENTIFICATION, KPDS(3), AND A
564 C TRANSMITTED GDS ARE INCONSISTENT.
565 C
566 C 10 - CENTER INDICATOR WAS NOT ONE INDICATED
567 C IN "GRIB" TABLE 1. PLEASE CONTACT AD
568 C PRODUCTION MANAGEMENT BRANCH (W/NMC42)
569 C IF THIS ERROR IS ENCOUNTERED.
570 C
571 C 11 - BINARY DATA SECTION (BDS) NOT COMPLETELY
572 C PROCESSED. PROGRAM IS NOT SET TO PROCESS
573 C FLAG COMBINATIONS AS SHOWN IN
574 C OCTETS 4 AND 14.
575 C
576 C
577 C LIST OF TEXT MESSAGES FROM CODE
578 C
579 C
580 C W3FI63/FI632
581 C
582 C 'HAVE ENCOUNTERED A NEW GRID FOR NMC, PLEASE NOTIFY
583 C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
584 C (W/NMC42)'
585 C
586 C 'HAVE ENCOUNTERED A NEW GRID FOR ECMWF, PLEASE NOTIFY
587 C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
588 C (W/NMC42)'
589 C
590 C 'HAVE ENCOUNTERED A NEW GRID FOR U.K. METEOROLOGICAL
591 C OFFICE, BRACKNELL. PLEASE NOTIFY AUTOMATION DIVISION,
592 C PRODUCTION MANAGEMENT BRANCH (W/NMC42)'
593 C
594 C 'HAVE ENCOUNTERED A NEW GRID FOR FNOC, PLEASE NOTIFY
595 C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
596 C (W/NMC42)'
597 C
598 C
599 C W3FI63/FI633
600 C
601 C 'POLAR STEREO PROCESSING NOT AVAILABLE' *
602 C
603 C W3FI63/FI634
604 C
605 C 'WARNING - BIT MAP MAY NOT BE ASSOCIATED WITH SPHERICAL
606 C COEFFICIENTS'
607 C
608 C
609 C W3FI63/FI637
610 C
611 C 'NO CURRENT LISTING OF FNOC GRIDS' *
612 C
613 C
614 C * WILL BE AVAILABLE IN NEXT UPDATE
615 C ***************************************************************
616 C
617 C INCOMING MESSAGE HOLDER
618  CHARACTER*1 MSGA(*)
619 C BIT MAP
620  LOGICAL*1 KBMS(*)
621 C
622 C ELEMENTS OF PRODUCT DESCRIPTION SEC (PDS)
623  INTEGER KPDS(*)
624 C ELEMENTS OF GRID DESCRIPTION SEC (PDS)
625  INTEGER KGDS(*)
626 C
627 C CONTAINER FOR GRIB GRID
628  REAL DATA(*)
629 C
630 C ARRAY OF POINTERS AND COUNTERS
631  INTEGER KPTR(*)
632 C
633 C *****************************************************************
634  INTEGER JSGN,JEXP,IFR,NPTS
635  REAL REALKK,FVAL1,FDIFF1
636 C *****************************************************************
637 C 1.0 LOCATE BEGINNING OF 'GRIB' MESSAGE
638 C FIND 'GRIB' CHARACTERS
639 C 2.0 USE COUNTS IN EACH DESCRIPTION SEC TO DETERMINE
640 C IF '7777' IS IN PROPER PLACE.
641 C 3.0 PARSE PRODUCT DEFINITION SECTION.
642 C 4.0 PARSE GRID DESCRIPTION SEC (IF INCLUDED)
643 C 5.0 PARSE BIT MAP SEC (IF INCLUDED)
644 C 6.0 USING INFORMATION FROM PRODUCT DEFINITION, GRID
645 C DESCRIPTION, AND BIT MAP SECTIONS.. EXTRACT
646 C DATA AND PLACE INTO PROPER ARRAY.
647 C *******************************************************************
648 C
649 C MAIN DRIVER
650 C
651 C *******************************************************************
652  kptr(10) = 0
653 C SEE IF PROPER 'GRIB' KEY EXISTS, THEN
654 C USING SEC COUNTS, DETERMINE IF '7777'
655 C IS IN THE PROPER LOCATION
656 C
657  CALL fi631(msga,kptr,kpds,kret)
658  IF(kret.NE.0) THEN
659  GO TO 900
660  END IF
661 C PRINT *,'FI631 KPTR',(KPTR(I),I=1,16)
662 C
663 C PARSE PARAMETERS FROM PRODUCT DESCRIPTION SECTION
664 C
665  CALL fi632(msga,kptr,kpds,kret)
666  IF(kret.NE.0) THEN
667  GO TO 900
668  END IF
669 C PRINT *,'FI632 KPTR',(KPTR(I),I=1,16)
670 C
671 C IF AVAILABLE, EXTRACT NEW GRID DESCRIPTION
672 C
673  IF (iand(kpds(4),128).NE.0) THEN
674  CALL fi633(msga,kptr,kgds,kret)
675  IF(kret.NE.0) THEN
676  GO TO 900
677  END IF
678 C PRINT *,'FI633 KPTR',(KPTR(I),I=1,16)
679  END IF
680 C
681 C EXTRACT OR GENERATE BIT MAP
682 C
683  CALL fi634(msga,kptr,kpds,kgds,kbms,kret)
684  IF (kret.NE.0) THEN
685  IF (kret.NE.9) THEN
686  GO TO 900
687  END IF
688  END IF
689 C PRINT *,'FI634 KPTR',(KPTR(I),I=1,16)
690 C
691 C USING INFORMATION FROM PDS, BMS AND BIT DATA SEC ,
692 C EXTRACT AND SAVE IN GRIB GRID, ALL DATA ENTRIES.
693 C
694  IF (kpds(18).EQ.1) THEN
695  CALL fi635(msga,kptr,kpds,kgds,kbms,DATA,kret)
696  IF (kptr(3).EQ.50) THEN
697 C
698 C PDS EQUAL 50 BYTES
699 C THEREFORE SOMETHING SPECIAL IS GOING ON
700 C
701 C IN THIS CASE 2ND DIFFERENCE PACKING
702 C NEEDS TO BE UNDONE.
703 C
704 C EXTRACT FIRST VALUE FROM BYTE 41-44 PDS
705 C KPTR(9) CONTAINS OFFSET TO START OF
706 C GRIB MESSAGE.
707 C EXTRACT FIRST FIRST-DIFFERENCE FROM BYTES 45-48 PDS
708 C
709 C AND EXTRACT SCALE FACTOR (E) TO UNDO 2**E
710 C THAT WAS APPLIED PRIOR TO 2ND ORDER PACKING
711 C AND PLACED IN PDS BYTES 49-51
712 C FACTOR IS A SIGNED TWO BYTE INTEGER
713 C
714 C ALSO NEED THE DECIMAL SCALING FROM PDS(27-28)
715 C (AVAILABLE IN KPDS(22) FROM UNPACKER)
716 C TO UNDO THE DECIMAL SCALING APPLIED TO THE
717 C SECOND DIFFERENCES DURING UNPACKING.
718 C SECOND DIFFS ALWAYS PACKED WITH 0 DECIMAL SCALE
719 C BUT UNPACKER DOESNT KNOW THAT.
720 C
721 C CALL GBYTE (MSGA,FVAL1,KPTR(9)+384,32)
722 C
723 C NOTE INTEGERS, CHARACTERS AND EQUIVALENCES
724 C DEFINED ABOVE TO MAKE THIS KKK EXTRACTION
725 C WORK AND LINE UP ON WORD BOUNDARIES
726 C
727 C THE NEXT CODE WILL CONVERT THE IBM370 FOATING POINT
728 C TO THE FLOATING POINT USED ON YOUR MACHINE.
729 C
730  call gbytec(msga,jsgn,kptr(9)+384,1)
731  call gbytec(msga,jexp,kptr(9)+385,7)
732  call gbytec(msga,ifr,kptr(9)+392,24)
733 C
734  IF (ifr.EQ.0) THEN
735  realkk = 0.0
736  ELSE IF (jexp.EQ.0.AND.ifr.EQ.0) THEN
737  realkk = 0.0
738  ELSE
739  realkk = float(ifr) * 16.0 ** (jexp - 64 - 6)
740  IF (jsgn.NE.0) realkk = -realkk
741  END IF
742  fval1 = realkk
743 C
744 C CALL GBYTE (MSGA,FDIFF1,KPTR(9)+416,32)
745 C (REPLACED BY FOLLOWING EXTRACTION)
746 C
747 C THE NEXT CODE WILL CONVERT THE IBM370 FOATING POINT
748 C TO THE FLOATING POINT USED ON YOUR MACHINE.
749 C
750  call gbytec(msga,jsgn,kptr(9)+416,1)
751  call gbytec(msga,jexp,kptr(9)+417,7)
752  call gbytec(msga,ifr,kptr(9)+424,24)
753 C
754  IF (ifr.EQ.0) THEN
755  realkk = 0.0
756  ELSE IF (jexp.EQ.0.AND.ifr.EQ.0) THEN
757  realkk = 0.0
758  ELSE
759  realkk = float(ifr) * 16.0 ** (jexp - 64 - 6)
760  IF (jsgn.NE.0) realkk = -realkk
761  END IF
762  fdiff1 = realkk
763 C
764  CALL gbytec (msga,isign,kptr(9)+448,1)
765  CALL gbytec (msga,iscal2,kptr(9)+449,15)
766  IF(isign.GT.0) THEN
767  iscal2 = - iscal2
768  ENDIF
769 C PRINT *,'DELTA POINT 1-',FVAL1
770 C PRINT *,'DELTA POINT 2-',FDIFF1
771 C PRINT *,'DELTA POINT 3-',ISCAL2
772  npts = kptr(10)
773 C WRITE (6,FMT='('' 2ND DIFF POINTS IN FIELD = '',/,
774 C & 10(3X,10F12.2,/))') (DATA(I),I=1,NPTS)
775 C PRINT *,'DELTA POINT 4-',KPDS(22)
776  CALL w3fi83 (DATA,npts,fval1,fdiff1,
777  & iscal2,kpds(22),kpds,kgds)
778 C WRITE (6,FMT='('' 2ND DIFF EXPANDED POINTS IN FIELD = '',
779 C & /,10(3X,10F12.2,/))') (DATA(I),I=1,NPTS)
780 C WRITE (6,FMT='('' END OF ARRAY IN FIELD = '',/,
781 C & 10(3X,10F12.2,/))') (DATA(I),I=NPTS-5,NPTS)
782  END IF
783  ELSE
784 C PRINT *,'FI635 NOT PROGRAMMED FOR EDITION NR',KPDS(18)
785  kret = 7
786  END IF
787 C
788  900 RETURN
789  END
790 
791 C> @brief Find 'grib' chars & reset pointers
792 C> @author Bill Cavanaugh @date 1991-09-13
793 
794 C> Find 'grib; characters and set pointers to the next
795 C> byte following 'grib'. If they exist extract counts from gds and
796 C> bms. Extract count from bds. Determine if sum of counts actually
797 C> places terminator '7777' at the correct location.
798 C>
799 C> Program history log:
800 C> - Bill Cavanaugh 1991-09-13
801 C> - Mark Iredell 1995-10-31 Removed saves and prints.
802 C>
803 C> @param[in] MSGA Grib field - "grib" thru "7777"
804 C> @param[inout] KPTR Array containing storage for following parameters
805 C> - 1 Total length of grib message
806 C> - 2 Length of indicator (section 0)
807 C> - 3 Length of pds (section 1)
808 C> - 4 Length of gds (section 2)
809 C> - 5 Length of bms (section 3)
810 C> - 6 Length of bds (section 4)
811 C> - 7 Value of current byte
812 C> - 8 Bit pointer
813 C> - 9 Grib start bit nr
814 C> - 10 Grib/grid element count
815 C> - 11 Nr unused bits at end of section 3
816 C> - 12 Bit map flag
817 C> - 13 Nr unused bits at end of section 2
818 C> - 14 Bds flags
819 C> - 15 Nr unused bits at end of section 4
820 C> @param[out] KPDS Array containing pds elements.
821 C> - 1 Id of center
822 C> - 2 Model identification
823 C> - 3 Grid identification
824 C> - 4 Gds/bms flag
825 C> - 5 Indicator of parameter
826 C> - 6 Type of level
827 C> - 7 Height/pressure , etc of level
828 C> - 8 Year of century
829 C> - 9 Month of year
830 C> - 10 Day of month
831 C> - 11 Hour of day
832 C> - 12 Minute of hour
833 C> - 13 Indicator of forecast time unit
834 C> - 14 Time range 1
835 C> - 15 Time range 2
836 C> - 16 Time range flag
837 C> - 17 Number included in average
838 C> @param[out] KRET Error return
839 C>
840 C> @note
841 C> ERROR RETURNS
842 C> KRET:
843 C> - 1 NO 'GRIB'
844 C> - 2 NO '7777' OR MISLOCATED (BY COUNTS)
845 C>
846 C> @author Bill Cavanaugh @date 1991-09-13
847  SUBROUTINE fi631(MSGA,KPTR,KPDS,KRET)
848 C
849 C INCOMING MESSAGE HOLDER
850  CHARACTER*1 MSGA(*)
851 C ARRAY OF POINTERS AND COUNTERS
852  INTEGER KPTR(*)
853 C PRODUCT DESCRIPTION SECTION DATA.
854  INTEGER KPDS(*)
855 C
856  INTEGER KRET
857 C
858 C ******************************************************************
859  kret = 0
860 C ------------------- FIND 'GRIB' KEY
861  DO 50 i = 0, 839, 8
862  CALL gbytec (msga,mgrib,i,32)
863  IF (mgrib.EQ.1196575042) THEN
864  kptr(9) = i
865  GO TO 60
866  END IF
867  50 CONTINUE
868  kret = 1
869  RETURN
870  60 CONTINUE
871 C -------------FOUND 'GRIB'
872 C SKIP GRIB CHARACTERS
873 C PRINT *,'FI631 GRIB AT',I
874  kptr(8) = kptr(9) + 32
875  CALL gbytec (msga,itotal,kptr(8),24)
876 C HAVE LIFTED WHAT MAY BE A MSG TOTAL BYTE COUNT
877  ipoint = kptr(9) + itotal * 8 - 32
878  CALL gbytec (msga,i7777,ipoint,32)
879  IF (i7777.EQ.926365495) THEN
880 C HAVE FOUND END OF MESSAGE '7777' IN PROPER LOCATION
881 C MARK AND PROCESS AS GRIB VERSION 1 OR HIGHER
882 C PRINT *,'FI631 7777 AT',IPOINT
883  kptr(8) = kptr(8) + 24
884  kptr(1) = itotal
885  kptr(2) = 8
886  CALL gbytec (msga,kpds(18),kptr(8),8)
887  kptr(8) = kptr(8) + 8
888  ELSE
889 C CANNOT FIND END OF GRIB EDITION 1 MESSAGE
890  kret = 2
891  RETURN
892  END IF
893 C ------------------- PROCESS SECTION 1
894 C EXTRACT COUNT FROM PDS
895 C PRINT *,'START OF PDS',KPTR(8)
896  CALL gbytec (msga,kptr(3),kptr(8),24)
897  look = kptr(8) + 56
898 C EXTRACT GDS/BMS FLAG
899  CALL gbytec (msga,kpds(4),look,8)
900  kptr(8) = kptr(8) + kptr(3) * 8
901 C PRINT *,'START OF GDS',KPTR(8)
902  IF (iand(kpds(4),128).NE.0) THEN
903 C EXTRACT COUNT FROM GDS
904  CALL gbytec (msga,kptr(4),kptr(8),24)
905  kptr(8) = kptr(8) + kptr(4) * 8
906  ELSE
907  kptr(4) = 0
908  END IF
909 C PRINT *,'START OF BMS',KPTR(8)
910  IF (iand(kpds(4),64).NE.0) THEN
911 C EXTRACT COUNT FROM BMS
912  CALL gbytec (msga,kptr(5),kptr(8),24)
913  ELSE
914  kptr(5) = 0
915  END IF
916  kptr(8) = kptr(8) + kptr(5) * 8
917 C PRINT *,'START OF BDS',KPTR(8)
918 C EXTRACT COUNT FROM BDS
919  CALL gbytec (msga,kptr(6),kptr(8),24)
920 C --------------- TEST FOR '7777'
921 C PRINT *,(KPTR(KJ),KJ=1,10)
922  kptr(8) = kptr(8) + kptr(6) * 8
923 C EXTRACT FOUR BYTES FROM THIS LOCATION
924 C PRINT *,'FI631 LOOKING FOR 7777 AT',KPTR(8)
925  CALL gbytec (msga,k7777,kptr(8),32)
926  match = kptr(2) + kptr(3) + kptr(4) + kptr(5) + kptr(6) + 4
927  IF (k7777.NE.926365495.OR.match.NE.kptr(1)) THEN
928  kret = 2
929  ELSE
930 C PRINT *,'FI631 7777 AT',KPTR(8)
931  IF (kpds(18).EQ.0) THEN
932  kptr(1) = kptr(2) + kptr(3) + kptr(4) + kptr(5) +
933  * kptr(6) + 4
934  END IF
935  END IF
936 C PRINT *,'KPTR',(KPTR(I),I=1,16)
937  RETURN
938  END
939 
940 
941 C> @brief Gather info from product definition sec.
942 C> @author Bill Cavanaugh @date 1991-09-13
943 
944 C> Extract information from the product description
945 C> sec , and generate label information to permit storage
946 C> in office note 84 format.
947 C>
948 C> Program history log:
949 C> - Bill Cavanaugh 1991-09-13
950 C> - Bill Cavanaugh 1993-12-08 Corrected test for edition number instead
951 C> of version number.
952 C> - Mark Iredell 1995-10-31 Removed saves and prints.
953 C> - M. Baldwin 1999-01-20 Modified to handle grid 237.
954 C>
955 C> @param[in] MSGA Array containing grib message.
956 C> @param[inout] KPTR Array containing storage for following parameters.
957 C> - 1 Total length of grib message
958 C> - 2 Length of indicator (section 0)
959 C> - 3 Length of pds (section 1)
960 C> - 4 Length of gds (section 2)
961 C> - 5 Length of bms (section 3)
962 C> - 6 Length of bds (section 4)
963 C> - 7 Value of current byte
964 C> - 8 Bit pointer
965 C> - 9 Grib start bit nr
966 C> - 10 Grib/grid element count
967 C> - 11 Nr unused bits at end of section 3
968 C> - 12 Bit map flag
969 C> - 13 Nr unused bits at end of section 2
970 C> - 14 Bds flags
971 C> - 15 Nr unused bits at end of section 4
972 C> @param[out] KPDS Array containing pds elements.
973 C> - 1 Id of center
974 C> - 2 Model identification
975 C> - 3 Grid identification
976 C> - 4 Gds/bms flag
977 C> - 5 Indicator of parameter
978 C> - 6 Type of level
979 C> - 7 Height/pressure , etc of level
980 C> - 8 Year of century
981 C> - 9 Month of year
982 C> - 10 Day of month
983 C> - 11 Hour of day
984 C> - 12 Minute of hour
985 C> - 13 Indicator of forecast time unit
986 C> - 14 Time range 1
987 C> - 15 Time range 2
988 C> - 16 Time range flag
989 C> - 17 Number included in average
990 C> - 18
991 C> - 19
992 C> - 20 Number missing from avgs/accumulations
993 C> - 21 Century
994 C> - 22 Units decimal scale factor
995 C> - 23 Subcenter
996 C> @param[out] KRET Error return.
997 C>
998 C> @note ERROR RETURN:
999 C> - 0 - NO ERRORS
1000 C> - 8 - TEMP GDS INDICATED, BUT NO GDS
1001 C>
1002 C> @author Bill Cavanaugh @date 1991-09-13
1003 
1004  SUBROUTINE fi632(MSGA,KPTR,KPDS,KRET)
1005 
1006 C
1007 C INCOMING MESSAGE HOLDER
1008  CHARACTER*1 MSGA(*)
1009 C
1010 C ARRAY OF POINTERS AND COUNTERS
1011  INTEGER KPTR(*)
1012 C PRODUCT DESCRIPTION SECTION ENTRIES
1013  INTEGER KPDS(*)
1014 C
1015  INTEGER KRET
1016  kret=0
1017 C ------------------- PROCESS SECTION 1
1018  kptr(8) = kptr(9) + kptr(2) * 8 + 24
1019 C BYTE 4
1020 C PARAMETER TABLE VERSION NR
1021  CALL gbytec (msga,kpds(19),kptr(8),8)
1022  kptr(8) = kptr(8) + 8
1023 C BYTE 5 IDENTIFICATION OF CENTER
1024  CALL gbytec (msga,kpds(1),kptr(8),8)
1025  kptr(8) = kptr(8) + 8
1026 C BYTE 6
1027 C GET GENERATING PROCESS ID NR
1028  CALL gbytec (msga,kpds(2),kptr(8),8)
1029  kptr(8) = kptr(8) + 8
1030 C BYTE 7
1031 C GRID DEFINITION
1032  CALL gbytec (msga,kpds(3),kptr(8),8)
1033  kptr(8) = kptr(8) + 8
1034 C BYTE 8
1035 C GDS/BMS FLAGS
1036 C CALL GBYTEC (MSGA,KPDS(4),KPTR(8),8)
1037  kptr(8) = kptr(8) + 8
1038 C BYTE 9
1039 C INDICATOR OF PARAMETER
1040  CALL gbytec (msga,kpds(5),kptr(8),8)
1041  kptr(8) = kptr(8) + 8
1042 C BYTE 10
1043 C TYPE OF LEVEL
1044  CALL gbytec (msga,kpds(6),kptr(8),8)
1045  kptr(8) = kptr(8) + 8
1046 C BYTE 11,12
1047 C HEIGHT/PRESSURE
1048  CALL gbytec (msga,kpds(7),kptr(8),16)
1049  kptr(8) = kptr(8) + 16
1050 C BYTE 13
1051 C YEAR OF CENTURY
1052  CALL gbytec (msga,kpds(8),kptr(8),8)
1053  kptr(8) = kptr(8) + 8
1054 C BYTE 14
1055 C MONTH OF YEAR
1056  CALL gbytec (msga,kpds(9),kptr(8),8)
1057  kptr(8) = kptr(8) + 8
1058 C BYTE 15
1059 C DAY OF MONTH
1060  CALL gbytec (msga,kpds(10),kptr(8),8)
1061  kptr(8) = kptr(8) + 8
1062 C BYTE 16
1063 C HOUR OF DAY
1064  CALL gbytec (msga,kpds(11),kptr(8),8)
1065  kptr(8) = kptr(8) + 8
1066 C BYTE 17
1067 C MINUTE
1068  CALL gbytec (msga,kpds(12),kptr(8),8)
1069  kptr(8) = kptr(8) + 8
1070 C BYTE 18
1071 C INDICATOR TIME UNIT RANGE
1072  CALL gbytec (msga,kpds(13),kptr(8),8)
1073  kptr(8) = kptr(8) + 8
1074 C BYTE 19
1075 C P1 - PERIOD OF TIME
1076  CALL gbytec (msga,kpds(14),kptr(8),8)
1077  kptr(8) = kptr(8) + 8
1078 C BYTE 20
1079 C P2 - PERIOD OF TIME
1080  CALL gbytec (msga,kpds(15),kptr(8),8)
1081  kptr(8) = kptr(8) + 8
1082 C BYTE 21
1083 C TIME RANGE INDICATOR
1084  CALL gbytec (msga,kpds(16),kptr(8),8)
1085  kptr(8) = kptr(8) + 8
1086 C
1087 C IF TIME RANGE INDICATOR IS 10, P1 IS PACKED IN
1088 C PDS BYTES 19-20
1089 C
1090  IF (kpds(16).EQ.10) THEN
1091  kpds(14) = kpds(14) * 256 + kpds(15)
1092  kpds(15) = 0
1093  END IF
1094 C BYTE 22,23
1095 C NUMBER INCLUDED IN AVERAGE
1096  CALL gbytec (msga,kpds(17),kptr(8),16)
1097  kptr(8) = kptr(8) + 16
1098 C BYTE 24
1099 C NUMBER MISSING FROM AVERAGES/ACCUMULATIONS
1100  CALL gbytec (msga,kpds(20),kptr(8),8)
1101  kptr(8) = kptr(8) + 8
1102 C BYTE 25
1103 C IDENTIFICATION OF CENTURY
1104  CALL gbytec (msga,kpds(21),kptr(8),8)
1105  kptr(8) = kptr(8) + 8
1106  IF (kptr(3).GT.25) THEN
1107 C BYTE 26 SUB CENTER NUMBER
1108  CALL gbytec (msga,kpds(23),kptr(8),8)
1109  kptr(8) = kptr(8) + 8
1110  IF (kptr(3).GE.28) THEN
1111 C BYTE 27-28
1112 C UNITS DECIMAL SCALE FACTOR
1113  CALL gbytec (msga,isign,kptr(8),1)
1114  kptr(8) = kptr(8) + 1
1115  CALL gbytec (msga,idec,kptr(8),15)
1116  kptr(8) = kptr(8) + 15
1117  IF (isign.GT.0) THEN
1118  kpds(22) = - idec
1119  ELSE
1120  kpds(22) = idec
1121  END IF
1122  isiz = kptr(3) - 28
1123  IF (isiz.LE.12) THEN
1124 C BYTE 29
1125  CALL gbytec (msga,kpds(24),kptr(8)+8,8)
1126 C BYTE 30
1127  CALL gbytec (msga,kpds(25),kptr(8)+16,8)
1128 C BYTES 31-40 CURRENTLY RESERVED FOR FUTURE USE
1129  kptr(8) = kptr(8) + isiz * 8
1130  ELSE
1131 C BYTE 29
1132  CALL gbytec (msga,kpds(24),kptr(8)+8,8)
1133 C BYTE 30
1134  CALL gbytec (msga,kpds(25),kptr(8)+16,8)
1135 C BYTES 31-40 CURRENTLY RESERVED FOR FUTURE USE
1136  kptr(8) = kptr(8) + 12 * 8
1137 C BYTES 41 - N LOCAL USE DATA
1138  CALL w3fi01(lw)
1139 C MWDBIT = LW * 8
1140  mwdbit = bit_size(kpds)
1141  isiz = kptr(3) - 40
1142  iter = isiz / lw
1143  IF (mod(isiz,lw).NE.0) iter = iter + 1
1144  CALL gbytesc (msga,kpds(36),kptr(8),mwdbit,0,iter)
1145  kptr(8) = kptr(8) + isiz * 8
1146  END IF
1147  END IF
1148  END IF
1149 C ----------- TEST FOR NEW GRID
1150  IF (iand(kpds(4),128).NE.0) THEN
1151  IF (iand(kpds(4),64).NE.0) THEN
1152  IF (kpds(3).NE.255) THEN
1153  IF (kpds(3).GE.21.AND.kpds(3).LE.26)THEN
1154  RETURN
1155  ELSE IF (kpds(3).GE.37.AND.kpds(3).LE.44)THEN
1156  RETURN
1157  ELSE IF (kpds(3).GE.61.AND.kpds(3).LE.64) THEN
1158  RETURN
1159  END IF
1160  IF (kpds(1).EQ.7) THEN
1161  IF (kpds(3).GE.2.AND.kpds(3).LE.3) THEN
1162  ELSE IF (kpds(3).GE.5.AND.kpds(3).LE.6) THEN
1163  ELSE IF (kpds(3).EQ.8) THEN
1164  ELSE IF (kpds(3).EQ.10) THEN
1165  ELSE IF (kpds(3).GE.27.AND.kpds(3).LE.34) THEN
1166  ELSE IF (kpds(3).EQ.50) THEN
1167  ELSE IF (kpds(3).EQ.53) THEN
1168  ELSE IF (kpds(3).GE.70.AND.kpds(3).LE.77) THEN
1169  ELSE IF (kpds(3).EQ.98) THEN
1170  ELSE IF (kpds(3).EQ.99) THEN
1171  ELSE IF (kpds(3).GE.100.AND.kpds(3).LE.105) THEN
1172  ELSE IF (kpds(3).EQ.126) THEN
1173  ELSE IF (kpds(3).EQ.195) THEN
1174  ELSE IF (kpds(3).EQ.196) THEN
1175  ELSE IF (kpds(3).EQ.197) THEN
1176  ELSE IF (kpds(3).EQ.198) THEN
1177  ELSE IF (kpds(3).GE.200.AND.kpds(3).LE.237) THEN
1178  ELSE
1179 C PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR',
1180 C * ' NMC WITHOUT A GRID DESCRIPTION SECTION'
1181 C PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
1182 C PRINT *,' PRODUCTION MANAGEMENT BRANCH'
1183 C PRINT *,' W/NMC42)'
1184  END IF
1185  ELSE IF (kpds(1).EQ.98) THEN
1186  IF (kpds(3).GE.1.AND.kpds(3).LE.16) THEN
1187  ELSE
1188 C PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR',
1189 C * ' ECMWF WITHOUT A GRID DESCRIPTION SECTION'
1190 C PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
1191 C PRINT *,' PRODUCTION MANAGEMENT BRANCH'
1192 C PRINT *,' W/NMC42)'
1193  END IF
1194  ELSE IF (kpds(1).EQ.74) THEN
1195  IF (kpds(3).GE.1.AND.kpds(3).LE.12) THEN
1196  ELSE IF (kpds(3).GE.21.AND.kpds(3).LE.26)THEN
1197  ELSE IF (kpds(3).GE.61.AND.kpds(3).LE.64) THEN
1198  ELSE IF (kpds(3).GE.70.AND.kpds(3).LE.77) THEN
1199  ELSE
1200 C PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR',
1201 C * ' U.K. MET OFFICE, BRACKNELL',
1202 C * ' WITHOUT A GRID DESCRIPTION SECTION'
1203 C PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
1204 C PRINT *,' PRODUCTION MANAGEMENT BRANCH'
1205 C PRINT *,' W/NMC42)'
1206  END IF
1207  ELSE IF (kpds(1).EQ.58) THEN
1208  IF (kpds(3).GE.1.AND.kpds(3).LE.12) THEN
1209  ELSE
1210 C PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR',
1211 C * ' FNOC WITHOUT A GRID DESCRIPTION SECTION'
1212 C PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
1213 C PRINT *,' PRODUCTION MANAGEMENT BRANCH'
1214 C PRINT *,' W/NMC42)'
1215  END IF
1216  END IF
1217  END IF
1218  END IF
1219  END IF
1220  RETURN
1221  END
1222 
1223 C> @brief Extract info from grib-gds
1224 C> @author Bill Cavanaugh @date 1991-09-13
1225 
1226 C> Extract information on unlisted grid to allow
1227 C> conversion to office note 84 format.
1228 C>
1229 C> Program history log:
1230 C> - Bill Cavanaugh 1991-09-13
1231 C> - M. Baldwin 1995-03-20 fi633 modification to get
1232 C> data rep types [kgds(1)] 201 and 202 to work.
1233 C> - Mark Iredell 1995-10-31 Removed saves and prints
1234 C> - M. Baldwin 1998-09-08 Add data rep type [kgds(1)] 203
1235 C> - Boi Vuong 2007-04-24 Add data rep type [kgds(1)] 204
1236 C> - George Gayno 2010-07-20 Add data rep type [kgds(1)] 205
1237 C>
1238 C> @param[in] MSGA Array containing grib message
1239 C> @param[inout] KPTR Array containing storage for following parameters
1240 C> - 1 Total length of grib message
1241 C> - 2 Length of indicator (section 0)
1242 C> - 3 Length of pds (section 1)
1243 C> - 4 Length of gds (section 2)
1244 C> - 5 Length of bms (section 3)
1245 C> - 6 Length of bds (section 4)
1246 C> - 7 Value of current byte
1247 C> - 8 Bit pointer
1248 C> - 9 Grib start bit nr
1249 C> - 10 Grib/grid element count
1250 C> - 11 Nr unused bits at end of section 3
1251 C> - 12 Bit map flag
1252 C> - 13 Nr unused bits at end of section 2
1253 C> - 14 Bds flags
1254 C> - 15 Nr unused bits at end of section 4
1255 C> @param[out] KGDS Array containing gds elements.
1256 C> - 1) Data representation type
1257 C> - 19 Number of vertical coordinate parameters
1258 C> - 20 Octet number of the list of vertical coordinate
1259 C> parameters Or Octet number of the list of numbers of points
1260 C> in each row Or 255 if neither are present.
1261 C> - 21 For grids with pl, number of points in grid
1262 C> - 22 Number of words in each row
1263 C> - Longitude grids
1264 C> - 2) N(i) nr points on latitude circle
1265 C> - 3) N(j) nr points on longitude meridian
1266 C> - 4) La(1) latitude of origin
1267 C> - 5) Lo(1) longitude of origin
1268 C> - 6) Resolution flag
1269 C> - 7) La(2) latitude of extreme point
1270 C> - 8) Lo(2) longitude of extreme point
1271 C> - 9) Di longitudinal direction of increment
1272 C> - 10 Dj latitudinal direction increment
1273 C> - 11 Scanning mode flag
1274 C> - Polar stereographic grids
1275 C> - 2) N(i) nr points along lat circle
1276 C> - 3) N(j) nr points along lon circle
1277 C> - 4) La(1) latitude of origin
1278 C> - 5) Lo(1) longitude of origin
1279 C> - 6) Reserved
1280 C> - 7) Lov grid orientation
1281 C> - 8) Dx - x direction increment
1282 C> - 9) Dy - y direction increment
1283 C> - 10 Projection center flag
1284 C> - 11 Scanning mode
1285 C> - Spherical harmonic coefficients
1286 C> - 2 J pentagonal resolution parameter
1287 C> - 3 K pentagonal resolution parameter
1288 C> - 4 M pentagonal resolution parameter
1289 C> - 5 Representation type
1290 C> - 6 Coefficient storage mode
1291 C> - Mercator grids
1292 C> - 2 N(i) nr points on latitude circle
1293 C> - 3 N(j) nr points on longitude meridian
1294 C> - 4 La(1) latitude of origin
1295 C> - 5 Lo(1) longitude of origin
1296 C> - 6 Resolution flag
1297 C> - 7 La(2) latitude of last grid point
1298 C> - 8 Lo(2) longitude of last grid point
1299 C> - 9 Latin - latitude of projection intersection
1300 C> - 10 Reserved
1301 C> - 11 Scanning mode flag
1302 C> - 12 Longitudinal dir grid length
1303 C> - 13 Latitudinal dir grid length
1304 C> - Lambert conformal grids
1305 C> - 2 Nx nr points along x-axis
1306 C> - 3 Ny nr points along y-axis
1307 C> - 4 La1 lat of origin (lower left)
1308 C> - 5 Lo1 lon of origin (lower left)
1309 C> - 6 Resolution (right adj copy of octet 17)
1310 C> - 7 Lov - orientation of grid
1311 C> - 8 Dx - x-dir increment
1312 C> - 9 Dy - y-dir increment
1313 C> - 10 Projection center flag
1314 C> - 11 Scanning mode flag
1315 C> - 12 Latin 1 - first lat from pole of secant cone inter
1316 C> - 13 Latin 2 - second lat from pole of secant cone inter
1317 C> - Staggered arakawa rotated lat/lon grids (203 e stagger)
1318 C> - 2 N(i) nr points on rotated latitude circle
1319 C> - 3 N(j) nr points on rotated longitude meridian
1320 C> - 4 La(1) latitude of origin
1321 C> - 5 Lo(1) longitude of origin
1322 C> - 6 Resolution flag
1323 C> - 7 La(2) latitude of center
1324 C> - 8 Lo(2) longitude of center
1325 C> - 9 Di longitudinal direction of increment
1326 C> - 10 Dj latitudinal direction increment
1327 C> - 11 Scanning mode flag
1328 C> - Staggered arakawa rotated lat/lon grids (205 a,b,c,d staggers)
1329 C> - 2 N(i) nr points on rotated latitude circle
1330 C> - 3 N(j) nr points on rotated longitude meridian
1331 C> - 4 La(1) latitude of origin
1332 C> - 5 Lo(1) longitude of origin
1333 C> - 6 Resolution flag
1334 C> - 7 La(2) latitude of center
1335 C> - 8 Lo(2) longitude of center
1336 C> - 9 Di longitudinal direction of increment
1337 C> - 10 Dj latitudinal direction increment
1338 C> - 11 Scanning mode flag
1339 C> - 12 Latitude of last point
1340 C> - 13 Longitude of last point
1341 C> @param[out] KRET Error return
1342 C>
1343 C> @note
1344 C> - KRET
1345 C> - 0
1346 C> - 4 - Data representation type not currently acceptable
1347 C>
1348 C> @author Bill Cavanaugh @date 1991-09-13
1349 
1350  SUBROUTINE fi633(MSGA,KPTR,KGDS,KRET)
1351 
1352 C ************************************************************
1353 C INCOMING MESSAGE HOLDER
1354  CHARACTER*1 MSGA(*)
1355 C
1356 C ARRAY GDS ELEMENTS
1357  INTEGER KGDS(*)
1358 C ARRAY OF POINTERS AND COUNTERS
1359  INTEGER KPTR(*)
1360 C
1361  INTEGER KRET
1362 C ---------------------------------------------------------------
1363  kret = 0
1364 C PROCESS GRID DEFINITION SECTION (IF PRESENT)
1365 C MAKE SURE BIT POINTER IS PROPERLY SET
1366  kptr(8) = kptr(9) + (kptr(2)*8) + (kptr(3)*8) + 24
1367  nsave = kptr(8) - 24
1368 C BYTE 4
1369 C NV - NR OF VERT COORD PARAMETERS
1370  CALL gbytec (msga,kgds(19),kptr(8),8)
1371  kptr(8) = kptr(8) + 8
1372 C BYTE 5
1373 C PV - LOCATION - SEE FM92 MANUAL
1374  CALL gbytec (msga,kgds(20),kptr(8),8)
1375  kptr(8) = kptr(8) + 8
1376 C BYTE 6
1377 C DATA REPRESENTATION TYPE
1378  CALL gbytec (msga,kgds(1),kptr(8),8)
1379  kptr(8) = kptr(8) + 8
1380 C BYTES 7-32 ARE GRID DEFINITION DEPENDING ON
1381 C DATA REPRESENTATION TYPE
1382  IF (kgds(1).EQ.0) THEN
1383  GO TO 1000
1384  ELSE IF (kgds(1).EQ.1) THEN
1385  GO TO 4000
1386  ELSE IF (kgds(1).EQ.2.OR.kgds(1).EQ.5) THEN
1387  GO TO 2000
1388  ELSE IF (kgds(1).EQ.3) THEN
1389  GO TO 5000
1390  ELSE IF (kgds(1).EQ.4) THEN
1391  GO TO 1000
1392 C ELSE IF (KGDS(1).EQ.10) THEN
1393 C ELSE IF (KGDS(1).EQ.14) THEN
1394 C ELSE IF (KGDS(1).EQ.20) THEN
1395 C ELSE IF (KGDS(1).EQ.24) THEN
1396 C ELSE IF (KGDS(1).EQ.30) THEN
1397 C ELSE IF (KGDS(1).EQ.34) THEN
1398  ELSE IF (kgds(1).EQ.50) THEN
1399  GO TO 3000
1400 C ELSE IF (KGDS(1).EQ.60) THEN
1401 C ELSE IF (KGDS(1).EQ.70) THEN
1402 C ELSE IF (KGDS(1).EQ.80) THEN
1403  ELSE IF (kgds(1).EQ.201.OR.kgds(1).EQ.202.OR.
1404  & kgds(1).EQ.203.OR.kgds(1).EQ.204.OR.kgds(1).EQ.205) THEN
1405  GO TO 1000
1406  ELSE
1407 C MARK AS GDS/ UNKNOWN DATA REPRESENTATION TYPE
1408  kret = 4
1409  RETURN
1410  END IF
1411 C BYTE 33-N VERTICAL COORDINATE PARAMETERS
1412 C -----------
1413 C BYTES 33-42 EXTENSIONS OF GRID DEFINITION FOR ROTATION
1414 C OR STRETCHING OF THE COORDINATE SYSTEM OR
1415 C LAMBERT CONFORMAL PROJECTION.
1416 C BYTE 43-N VERTICAL COORDINATE PARAMETERS
1417 C -----------
1418 C BYTES 33-52 EXTENSIONS OF GRID DEFINITION FOR STRETCHED
1419 C AND ROTATED COORDINATE SYSTEM
1420 C BYTE 53-N VERTICAL COORDINATE PARAMETERS
1421 C -----------
1422 C ************************************************************
1423 C ------------------- LATITUDE/LONGITUDE GRIDS
1424 C ------------------- ARAKAWA STAGGERED, SEMI-STAGGERED, OR FILLED
1425 C ROTATED LAT/LON GRIDS OR CURVILINEAR ORTHIGINAL GRIDS
1426 C
1427 C ------------------- BYTE 7-8 NR OF POINTS ALONG LATITUDE CIRCLE
1428  1000 CONTINUE
1429  CALL gbytec (msga,kgds(2),kptr(8),16)
1430  kptr(8) = kptr(8) + 16
1431 C ------------------- BYTE 9-10 NR OF POINTS ALONG LONG MERIDIAN
1432  CALL gbytec (msga,kgds(3),kptr(8),16)
1433  kptr(8) = kptr(8) + 16
1434 C ------------------- BYTE 11-13 LATITUDE OF ORIGIN
1435  CALL gbytec (msga,kgds(4),kptr(8),24)
1436  kptr(8) = kptr(8) + 24
1437  IF (iand(kgds(4),8388608).NE.0) THEN
1438  kgds(4) = iand(kgds(4),8388607) * (-1)
1439  END IF
1440 C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN
1441  CALL gbytec (msga,kgds(5),kptr(8),24)
1442  kptr(8) = kptr(8) + 24
1443  IF (iand(kgds(5),8388608).NE.0) THEN
1444  kgds(5) = - iand(kgds(5),8388607)
1445  END IF
1446 C ------------------- BYTE 17 RESOLUTION FLAG
1447  CALL gbytec (msga,kgds(6),kptr(8),8)
1448  kptr(8) = kptr(8) + 8
1449 C ------------------- BYTE 18-20 LATITUDE OF LAST GRID POINT
1450  CALL gbytec (msga,kgds(7),kptr(8),24)
1451  kptr(8) = kptr(8) + 24
1452  IF (iand(kgds(7),8388608).NE.0) THEN
1453  kgds(7) = - iand(kgds(7),8388607)
1454  END IF
1455 C ------------------- BYTE 21-23 LONGITUDE OF LAST GRID POINT
1456  CALL gbytec (msga,kgds(8),kptr(8),24)
1457  kptr(8) = kptr(8) + 24
1458  IF (iand(kgds(8),8388608).NE.0) THEN
1459  kgds(8) = - iand(kgds(8),8388607)
1460  END IF
1461 C ------------------- BYTE 24-25 LATITUDINAL DIR INCREMENT
1462  CALL gbytec (msga,kgds(9),kptr(8),16)
1463  kptr(8) = kptr(8) + 16
1464 C ------------------- BYTE 26-27 IF REGULAR LAT/LON GRID
1465 C HAVE LONGIT DIR INCREMENT
1466 C ELSE IF GAUSSIAN GRID
1467 C HAVE NR OF LAT CIRCLES
1468 C BETWEEN POLE AND EQUATOR
1469  CALL gbytec (msga,kgds(10),kptr(8),16)
1470  kptr(8) = kptr(8) + 16
1471 C ------------------- BYTE 28 SCANNING MODE FLAGS
1472  CALL gbytec (msga,kgds(11),kptr(8),8)
1473  kptr(8) = kptr(8) + 8
1474  IF(kgds(1).EQ.205)THEN
1475 C ------------------- BYTE 29-31 LATITUDE OF LAST GRID POINT
1476  CALL gbytec (msga,kgds(12),kptr(8),24)
1477  kptr(8) = kptr(8) + 24
1478  IF (iand(kgds(12),8388608).NE.0) THEN
1479  kgds(12) = - iand(kgds(12),8388607)
1480  END IF
1481 C ------------------- BYTE 32-34 LONGITUDE OF LAST GRID POINT
1482  CALL gbytec (msga,kgds(13),kptr(8),24)
1483  kptr(8) = kptr(8) + 24
1484  IF (iand(kgds(13),8388608).NE.0) THEN
1485  kgds(13) = - iand(kgds(13),8388607)
1486  END IF
1487  ELSE
1488 
1489 C ------------------- BYTE 29-32 RESERVED
1490 C SKIP TO START OF BYTE 33
1491  CALL gbytec (msga,kgds(12),kptr(8),32)
1492  kptr(8) = kptr(8) + 32
1493  ENDIF
1494 C -------------------
1495  GO TO 900
1496 C ******************************************************************
1497 C ' POLAR STEREO PROCESSING '
1498 C
1499 C ------------------- BYTE 7-8 NR OF POINTS ALONG X=AXIS
1500  2000 CONTINUE
1501  CALL gbytec (msga,kgds(2),kptr(8),16)
1502  kptr(8) = kptr(8) + 16
1503 C ------------------- BYTE 9-10 NR OF POINTS ALONG Y-AXIS
1504  CALL gbytec (msga,kgds(3),kptr(8),16)
1505  kptr(8) = kptr(8) + 16
1506 C ------------------- BYTE 11-13 LATITUDE OF ORIGIN
1507  CALL gbytec (msga,kgds(4),kptr(8),24)
1508  kptr(8) = kptr(8) + 24
1509  IF (iand(kgds(4),8388608).NE.0) THEN
1510  kgds(4) = - iand(kgds(4),8388607)
1511  END IF
1512 C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN
1513  CALL gbytec (msga,kgds(5),kptr(8),24)
1514  kptr(8) = kptr(8) + 24
1515  IF (iand(kgds(5),8388608).NE.0) THEN
1516  kgds(5) = - iand(kgds(5),8388607)
1517  END IF
1518 C ------------------- BYTE 17 RESERVED
1519  CALL gbytec (msga,kgds(6),kptr(8),8)
1520  kptr(8) = kptr(8) + 8
1521 C ------------------- BYTE 18-20 LOV ORIENTATION OF THE GRID
1522  CALL gbytec (msga,kgds(7),kptr(8),24)
1523  kptr(8) = kptr(8) + 24
1524  IF (iand(kgds(7),8388608).NE.0) THEN
1525  kgds(7) = - iand(kgds(7),8388607)
1526  END IF
1527 C ------------------- BYTE 21-23 DX - THE X DIRECTION INCREMENT
1528  CALL gbytec (msga,kgds(8),kptr(8),24)
1529  kptr(8) = kptr(8) + 24
1530  IF (iand(kgds(8),8388608).NE.0) THEN
1531  kgds(8) = - iand(kgds(8),8388607)
1532  END IF
1533 C ------------------- BYTE 24-26 DY - THE Y DIRECTION INCREMENT
1534  CALL gbytec (msga,kgds(9),kptr(8),24)
1535  kptr(8) = kptr(8) + 24
1536  IF (iand(kgds(9),8388608).NE.0) THEN
1537  kgds(9) = - iand(kgds(9),8388607)
1538  END IF
1539 C ------------------- BYTE 27 PROJECTION CENTER FLAG
1540  CALL gbytec (msga,kgds(10),kptr(8),8)
1541  kptr(8) = kptr(8) + 8
1542 C ------------------- BYTE 28 SCANNING MODE
1543  CALL gbytec (msga,kgds(11),kptr(8),8)
1544  kptr(8) = kptr(8) + 8
1545 C ------------------- BYTE 29-32 RESERVED
1546 C SKIP TO START OF BYTE 33
1547  CALL gbytec (msga,kgds(12),kptr(8),32)
1548  kptr(8) = kptr(8) + 32
1549 C
1550 C -------------------
1551  GO TO 900
1552 C
1553 C ******************************************************************
1554 C ------------------- GRID DESCRIPTION FOR SPHERICAL HARMONIC COEFF.
1555 C
1556 C ------------------- BYTE 7-8 J PENTAGONAL RESOLUTION PARAMETER
1557  3000 CONTINUE
1558  CALL gbytec (msga,kgds(2),kptr(8),16)
1559  kptr(8) = kptr(8) + 16
1560 C ------------------- BYTE 9-10 K PENTAGONAL RESOLUTION PARAMETER
1561  CALL gbytec (msga,kgds(3),kptr(8),16)
1562  kptr(8) = kptr(8) + 16
1563 C ------------------- BYTE 11-12 M PENTAGONAL RESOLUTION PARAMETER
1564  CALL gbytec (msga,kgds(4),kptr(8),16)
1565  kptr(8) = kptr(8) + 16
1566 C ------------------- BYTE 13 REPRESENTATION TYPE
1567  CALL gbytec (msga,kgds(5),kptr(8),8)
1568  kptr(8) = kptr(8) + 8
1569 C ------------------- BYTE 14 COEFFICIENT STORAGE MODE
1570  CALL gbytec (msga,kgds(6),kptr(8),8)
1571  kptr(8) = kptr(8) + 8
1572 C ------------------- EMPTY FIELDS - BYTES 15 - 32
1573 C SET TO START OF BYTE 33
1574  kptr(8) = kptr(8) + 18 * 8
1575  GO TO 900
1576 C ******************************************************************
1577 C PROCESS MERCATOR GRIDS
1578 C
1579 C ------------------- BYTE 7-8 NR OF POINTS ALONG LATITUDE CIRCLE
1580  4000 CONTINUE
1581  CALL gbytec (msga,kgds(2),kptr(8),16)
1582  kptr(8) = kptr(8) + 16
1583 C ------------------- BYTE 9-10 NR OF POINTS ALONG LONG MERIDIAN
1584  CALL gbytec (msga,kgds(3),kptr(8),16)
1585  kptr(8) = kptr(8) + 16
1586 C ------------------- BYTE 11-13 LATITUE OF ORIGIN
1587  CALL gbytec (msga,kgds(4),kptr(8),24)
1588  kptr(8) = kptr(8) + 24
1589  IF (iand(kgds(4),8388608).NE.0) THEN
1590  kgds(4) = - iand(kgds(4),8388607)
1591  END IF
1592 C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN
1593  CALL gbytec (msga,kgds(5),kptr(8),24)
1594  kptr(8) = kptr(8) + 24
1595  IF (iand(kgds(5),8388608).NE.0) THEN
1596  kgds(5) = - iand(kgds(5),8388607)
1597  END IF
1598 C ------------------- BYTE 17 RESOLUTION FLAG
1599  CALL gbytec (msga,kgds(6),kptr(8),8)
1600  kptr(8) = kptr(8) + 8
1601 C ------------------- BYTE 18-20 LATITUDE OF EXTREME POINT
1602  CALL gbytec (msga,kgds(7),kptr(8),24)
1603  kptr(8) = kptr(8) + 24
1604  IF (iand(kgds(7),8388608).NE.0) THEN
1605  kgds(7) = - iand(kgds(7),8388607)
1606  END IF
1607 C ------------------- BYTE 21-23 LONGITUDE OF EXTREME POINT
1608  CALL gbytec (msga,kgds(8),kptr(8),24)
1609  kptr(8) = kptr(8) + 24
1610  IF (iand(kgds(8),8388608).NE.0) THEN
1611  kgds(8) = - iand(kgds(8),8388607)
1612  END IF
1613 C ------------------- BYTE 24-26 LATITUDE OF PROJECTION INTERSECTION
1614  CALL gbytec (msga,kgds(9),kptr(8),24)
1615  kptr(8) = kptr(8) + 24
1616  IF (iand(kgds(9),8388608).NE.0) THEN
1617  kgds(9) = - iand(kgds(9),8388607)
1618  END IF
1619 C ------------------- BYTE 27 RESERVED
1620  CALL gbytec (msga,kgds(10),kptr(8),8)
1621  kptr(8) = kptr(8) + 8
1622 C ------------------- BYTE 28 SCANNING MODE
1623  CALL gbytec (msga,kgds(11),kptr(8),8)
1624  kptr(8) = kptr(8) + 8
1625 C ------------------- BYTE 29-31 LONGITUDINAL DIR INCREMENT
1626  CALL gbytec (msga,kgds(12),kptr(8),24)
1627  kptr(8) = kptr(8) + 24
1628  IF (iand(kgds(12),8388608).NE.0) THEN
1629  kgds(12) = - iand(kgds(12),8388607)
1630  END IF
1631 C ------------------- BYTE 32-34 LATITUDINAL DIR INCREMENT
1632  CALL gbytec (msga,kgds(13),kptr(8),24)
1633  kptr(8) = kptr(8) + 24
1634  IF (iand(kgds(13),8388608).NE.0) THEN
1635  kgds(13) = - iand(kgds(13),8388607)
1636  END IF
1637 C ------------------- BYTE 35-42 RESERVED
1638 C SKIP TO START OF BYTE 43
1639  kptr(8) = kptr(8) + 8 * 8
1640 C -------------------
1641  GO TO 900
1642 C ******************************************************************
1643 C PROCESS LAMBERT CONFORMAL
1644 C
1645 C ------------------- BYTE 7-8 NR OF POINTS ALONG X-AXIS
1646  5000 CONTINUE
1647  CALL gbytec (msga,kgds(2),kptr(8),16)
1648  kptr(8) = kptr(8) + 16
1649 C ------------------- BYTE 9-10 NR OF POINTS ALONG Y-AXIS
1650  CALL gbytec (msga,kgds(3),kptr(8),16)
1651  kptr(8) = kptr(8) + 16
1652 C ------------------- BYTE 11-13 LATITUDE OF ORIGIN
1653  CALL gbytec (msga,kgds(4),kptr(8),24)
1654  kptr(8) = kptr(8) + 24
1655  IF (iand(kgds(4),8388608).NE.0) THEN
1656  kgds(4) = - iand(kgds(4),8388607)
1657  END IF
1658 C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN (LOWER LEFT)
1659  CALL gbytec (msga,kgds(5),kptr(8),24)
1660  kptr(8) = kptr(8) + 24
1661  IF (iand(kgds(5),8388608).NE.0) THEN
1662  kgds(5) = - iand(kgds(5),8388607)
1663  END IF
1664 C ------------------- BYTE 17 RESOLUTION
1665  CALL gbytec (msga,kgds(6),kptr(8),8)
1666  kptr(8) = kptr(8) + 8
1667 C ------------------- BYTE 18-20 LOV -ORIENTATION OF GRID
1668  CALL gbytec (msga,kgds(7),kptr(8),24)
1669  kptr(8) = kptr(8) + 24
1670  IF (iand(kgds(7),8388608).NE.0) THEN
1671  kgds(7) = - iand(kgds(7),8388607)
1672  END IF
1673 C ------------------- BYTE 21-23 DX - X-DIR INCREMENT
1674  CALL gbytec (msga,kgds(8),kptr(8),24)
1675  kptr(8) = kptr(8) + 24
1676 C ------------------- BYTE 24-26 DY - Y-DIR INCREMENT
1677  CALL gbytec (msga,kgds(9),kptr(8),24)
1678  kptr(8) = kptr(8) + 24
1679 C ------------------- BYTE 27 PROJECTION CENTER FLAG
1680  CALL gbytec (msga,kgds(10),kptr(8),8)
1681  kptr(8) = kptr(8) + 8
1682 C ------------------- BYTE 28 SCANNING MODE
1683  CALL gbytec (msga,kgds(11),kptr(8),8)
1684  kptr(8) = kptr(8) + 8
1685 C ------------------- BYTE 29-31 LATIN1 - 1ST LAT FROM POLE
1686  CALL gbytec (msga,kgds(12),kptr(8),24)
1687  kptr(8) = kptr(8) + 24
1688  IF (iand(kgds(12),8388608).NE.0) THEN
1689  kgds(12) = - iand(kgds(12),8388607)
1690  END IF
1691 C ------------------- BYTE 32-34 LATIN2 - 2ND LAT FROM POLE
1692  CALL gbytec (msga,kgds(13),kptr(8),24)
1693  kptr(8) = kptr(8) + 24
1694  IF (iand(kgds(13),8388608).NE.0) THEN
1695  kgds(13) = - iand(kgds(13),8388607)
1696  END IF
1697 C ------------------- BYTE 35-37 LATITUDE OF SOUTHERN POLE
1698  CALL gbytec (msga,kgds(14),kptr(8),24)
1699  kptr(8) = kptr(8) + 24
1700  IF (iand(kgds(14),8388608).NE.0) THEN
1701  kgds(14) = - iand(kgds(14),8388607)
1702  END IF
1703 C ------------------- BYTE 38-40 LONGITUDE OF SOUTHERN POLE
1704  CALL gbytec (msga,kgds(15),kptr(8),24)
1705  kptr(8) = kptr(8) + 24
1706  IF (iand(kgds(15),8388608).NE.0) THEN
1707  kgds(15) = - iand(kgds(15),8388607)
1708  END IF
1709 C ------------------- BYTE 41-42 RESERVED
1710  CALL gbytec (msga,kgds(16),kptr(8),16)
1711  kptr(8) = kptr(8) + 16
1712 C -------------------
1713  900 CONTINUE
1714 C
1715 C MORE CODE FOR GRIDS WITH PL
1716 C
1717  IF (kgds(19).EQ.0.OR.kgds(19).EQ.255) THEN
1718  IF (kgds(20).NE.255) THEN
1719  isum = 0
1720  kptr(8) = nsave + (kgds(20) - 1) * 8
1721  CALL gbytesc (msga,kgds(22),kptr(8),16,0,kgds(3))
1722  DO 910 j = 1, kgds(3)
1723  isum = isum + kgds(21+j)
1724  910 CONTINUE
1725  kgds(21) = isum
1726  END IF
1727  END IF
1728  RETURN
1729  END
1730 
1731 
1732 C> @brief Extract or generate bit map for output
1733 C> @author Bill Cavanaugh @date 1991-09-13
1734 
1735 C> If bit map sec is available in grib message, extract
1736 C> for program use, otherwise generate an appropriate bit map.
1737 C>
1738 C> Program history log:
1739 C> - Bill Cavanaugh 1991-09-13
1740 C> - Bill Cavanaugh 1991-11-12 Modified size of ecmwf grids 5 - 8.
1741 C> - Mark Iredell 1995-10-31 removed saves and prints
1742 C> - W. Bostelman 1997-02-12 corrects ecmwf us grid 2 processing
1743 C> - Mark Iredell 1997-09-19 vectorized bitmap decoder
1744 C> - Stephen Gilbert 1998-09-02 corrected error in map size for u.s. grid 92
1745 C> - M. Baldwin 1998-09-08 add grids 190,192
1746 C> - M. Baldwin 1999-01-20 add grids 236,237
1747 C> - Eric Rogers 2001-10-02 redefined grid #218 for 12 km eta
1748 C> redefined grid 192 for new 32-km eta grid
1749 C> - Stephen Gilbert 2003-06-30 added grids 145 and 146 for cmaq
1750 C> and grid 175 for awips over guam.
1751 C> - Boi Vuong 2004-09-02 Added awips grids 147, 148, 173 and 254
1752 C> - Boi Vuong 2006-12-12 Added awips grids 120
1753 C> - Boi Vuong 2007-04-20 Added awips grids 176
1754 C> - Boi Vuong 2007-06-11 Added awips grids 11 to 18 and 122 to 125
1755 C> and 180 to 183
1756 C> - Boi Vuong 2010-08-05 Added new grid 184, 199, 83 and
1757 C> redefined grid 90 for new rtma conus 1.27-km
1758 C> redefined grid 91 for new rtma alaska 2.976-km
1759 C> redefined grid 92 for new rtma alaska 1.488-km
1760 C> - Boi Vuong 2012-02-28 Added new grid 200
1761 C>
1762 C> @param[in] MSGA Bufr message
1763 C> @param[inout] KPTR Array containing storage for following parameters
1764 C> - 1 Total length of grib message
1765 C> - 2 Length of indicator (section 0)
1766 C> - 3 Length of pds (section 1)
1767 C> - 4 Length of gds (section 2)
1768 C> - 5 Length of bms (section 3)
1769 C> - 6 Length of bds (section 4)
1770 C> - 7 Value of current byte
1771 C> - 8 Bit pointer
1772 C> - 9 Grib start bit nr
1773 C> - 10 Grib/grid element count
1774 C> - 11 Nr unused bits at end of section 3
1775 C> - 12 Bit map flag
1776 C> - 13 Nr unused bits at end of section 2
1777 C> - 14 Bds flags
1778 C> - 15 Nr unused bits at end of section 4
1779 C> @param[in] KPDS Array containing pds elements.
1780 C> - 1 Id of center
1781 C> - 2 Model identification
1782 C> - 3 Grid identification
1783 C> - 4 Gds/bms flag
1784 C> - 5 Indicator of parameter
1785 C> - 6 Type of level
1786 C> - 7 Height/pressure , etc of level
1787 C> - 8 Year of century
1788 C> - 9 Month of year
1789 C> - 10 Day of month
1790 C> - 11 Hour of day
1791 C> - 12 Minute of hour
1792 C> - 13 Indicator of forecast time unit
1793 C> - 14 Time range 1
1794 C> - 15 Time range 2
1795 C> - 16 Time range flag
1796 C> - 17 Number included in average
1797 C> @param[in] KGDS Array containing gds elements.
1798 C> - 1) Data representation type
1799 C> - 19 Number of vertical coordinate parameters
1800 C> - 20 Octet number of the list of vertical coordinate
1801 C> parameters Or Octet number of the list of numbers of points
1802 C> in each row Or 255 if neither are present.
1803 C> - 21 For grids with pl, number of points in grid
1804 C> - 22 Number of words in each row
1805 C> - Longitude grids
1806 C> - 2) N(i) nr points on latitude circle
1807 C> - 3) N(j) nr points on longitude meridian
1808 C> - 4) La(1) latitude of origin
1809 C> - 5) Lo(1) longitude of origin
1810 C> - 6) Resolution flag
1811 C> - 7) La(2) latitude of extreme point
1812 C> - 8) Lo(2) longitude of extreme point
1813 C> - 9) Di longitudinal direction of increment
1814 C> - 10 Dj latitudinal direction increment
1815 C> - 11 Scanning mode flag
1816 C> - Polar stereographic grids
1817 C> - 2) N(i) nr points along lat circle
1818 C> - 3) N(j) nr points along lon circle
1819 C> - 4) La(1) latitude of origin
1820 C> - 5) Lo(1) longitude of origin
1821 C> - 6) Reserved
1822 C> - 7) Lov grid orientation
1823 C> - 8) Dx - x direction increment
1824 C> - 9) Dy - y direction increment
1825 C> - 10 Projection center flag
1826 C> - 11 Scanning mode
1827 C> - Spherical harmonic coefficients
1828 C> - 2 J pentagonal resolution parameter
1829 C> - 3 K pentagonal resolution parameter
1830 C> - 4 M pentagonal resolution parameter
1831 C> - 5 Representation type
1832 C> - 6 Coefficient storage mode
1833 C> - Mercator grids
1834 C> - 2 N(i) nr points on latitude circle
1835 C> - 3 N(j) nr points on longitude meridian
1836 C> - 4 La(1) latitude of origin
1837 C> - 5 Lo(1) longitude of origin
1838 C> - 6 Resolution flag
1839 C> - 7 La(2) latitude of last grid point
1840 C> - 8 Lo(2) longitude of last grid point
1841 C> - 9 Latin - latitude of projection intersection
1842 C> - 10 Reserved
1843 C> - 11 Scanning mode flag
1844 C> - 12 Longitudinal dir grid length
1845 C> - 13 Latitudinal dir grid length
1846 C> - Lambert conformal grids
1847 C> - 2 Nx nr points along x-axis
1848 C> - 3 Ny nr points along y-axis
1849 C> - 4 La1 lat of origin (lower left)
1850 C> - 5 Lo1 lon of origin (lower left)
1851 C> - 6 Resolution (right adj copy of octet 17)
1852 C> - 7 Lov - orientation of grid
1853 C> - 8 Dx - x-dir increment
1854 C> - 9 Dy - y-dir increment
1855 C> - 10 Projection center flag
1856 C> - 11 Scanning mode flag
1857 C> - 12 Latin 1 - first lat from pole of secant cone inter
1858 C> - 13 Latin 2 - second lat from pole of secant cone inter
1859 C> - Staggered arakawa rotated lat/lon grids (203 e stagger)
1860 C> - 2 N(i) nr points on rotated latitude circle
1861 C> - 3 N(j) nr points on rotated longitude meridian
1862 C> - 4 La(1) latitude of origin
1863 C> - 5 Lo(1) longitude of origin
1864 C> - 6 Resolution flag
1865 C> - 7 La(2) latitude of center
1866 C> - 8 Lo(2) longitude of center
1867 C> - 9 Di longitudinal direction of increment
1868 C> - 10 Dj latitudinal direction increment
1869 C> - 11 Scanning mode flag
1870 C> - Staggered arakawa rotated lat/lon grids (205 a,b,c,d staggers)
1871 C> - 2 N(i) nr points on rotated latitude circle
1872 C> - 3 N(j) nr points on rotated longitude meridian
1873 C> - 4 La(1) latitude of origin
1874 C> - 5 Lo(1) longitude of origin
1875 C> - 6 Resolution flag
1876 C> - 7 La(2) latitude of center
1877 C> - 8 Lo(2) longitude of center
1878 C> - 9 Di longitudinal direction of increment
1879 C> - 10 Dj latitudinal direction increment
1880 C> - 11 Scanning mode flag
1881 C> - 12 Latitude of last point
1882 C> - 13 Longitude of last point
1883 C> @param[out] KBMS Bitmap describing location of output elements.
1884 C> @param[out] KRET Error return
1885 C>
1886 C> @note
1887 C> - KRET
1888 C> - 0 - No error
1889 C> - 5 - Grid not avail for center indicated
1890 C> - 10 - Incorrect center indicator
1891 C> - 12 - Bytes 5-6 are not zero in bms, predefined bit map
1892 C> not provided by this center
1893 C>
1894 C> @author Bill Cavanaugh @date 1991-09-13
1895 
1896  SUBROUTINE fi634(MSGA,KPTR,KPDS,KGDS,KBMS,KRET)
1897 
1898 C
1899 C INCOMING MESSAGE HOLDER
1900  CHARACTER*1 MSGA(*)
1901 C
1902 C BIT MAP
1903  LOGICAL*1 KBMS(*)
1904 C
1905 C ARRAY OF POINTERS AND COUNTERS
1906  INTEGER KPTR(*)
1907 C ARRAY OF POINTERS AND COUNTERS
1908  INTEGER KPDS(*)
1909  INTEGER KGDS(*)
1910 C
1911  INTEGER KRET
1912  INTEGER MASK(8)
1913 C ----------------------GRID 21 AND GRID 22 ARE THE SAME
1914  LOGICAL*1 GRD21( 1369)
1915 C ----------------------GRID 23 AND GRID 24 ARE THE SAME
1916  LOGICAL*1 GRD23( 1369)
1917  LOGICAL*1 GRD25( 1368)
1918  LOGICAL*1 GRD26( 1368)
1919 C ----------------------GRID 27 AND GRID 28 ARE THE SAME
1920 C ----------------------GRID 29 AND GRID 30 ARE THE SAME
1921 C ----------------------GRID 33 AND GRID 34 ARE THE SAME
1922  LOGICAL*1 GRD50( 1188)
1923 C -----------------------GRID 61 AND GRID 62 ARE THE SAME
1924  LOGICAL*1 GRD61( 4186)
1925 C -----------------------GRID 63 AND GRID 64 ARE THE SAME
1926  LOGICAL*1 GRD63( 4186)
1927 C LOGICAL*1 GRD70(16380)/16380*.TRUE./
1928 C -------------------------------------------------------------
1929  DATA grd21 /1333*.true.,36*.false./
1930  DATA grd23 /.true.,36*.false.,1332*.true./
1931  DATA grd25 /1297*.true.,71*.false./
1932  DATA grd26 /.true.,71*.false.,1296*.true./
1933  DATA grd50/
1934 C LINE 1-4
1935  & 7*.false.,22*.true.,14*.false.,22*.true.,
1936  & 14*.false.,22*.true.,14*.false.,22*.true.,7*.false.,
1937 C LINE 5-8
1938  & 6*.false.,24*.true.,12*.false.,24*.true.,
1939  & 12*.false.,24*.true.,12*.false.,24*.true.,6*.false.,
1940 C LINE 9-12
1941  & 5*.false.,26*.true.,10*.false.,26*.true.,
1942  & 10*.false.,26*.true.,10*.false.,26*.true.,5*.false.,
1943 C LINE 13-16
1944  & 4*.false.,28*.true., 8*.false.,28*.true.,
1945  & 8*.false.,28*.true., 8*.false.,28*.true.,4*.false.,
1946 C LINE 17-20
1947  & 3*.false.,30*.true., 6*.false.,30*.true.,
1948  & 6*.false.,30*.true., 6*.false.,30*.true.,3*.false.,
1949 C LINE 21-24
1950  & 2*.false.,32*.true., 4*.false.,32*.true.,
1951  & 4*.false.,32*.true., 4*.false.,32*.true.,2*.false.,
1952 C LINE 25-28
1953  & .false.,34*.true., 2*.false.,34*.true.,
1954  & 2*.false.,34*.true., 2*.false.,34*.true., .false.,
1955 C LINE 29-33
1956  & 180*.true./
1957  DATA grd61 /4096*.true.,90*.false./
1958  DATA grd63 /.true.,90*.false.,4095*.true./
1959  DATA mask /128,64,32,16,8,4,2,1/
1960 C
1961 C PRINT *,'FI634'
1962  IF (iand(kpds(4),64).EQ.64) THEN
1963 C
1964 C SET UP BIT POINTER
1965 C SECTION 0 SECTION 1 SECTION 2
1966  kptr(8) = kptr(9) + (kptr(2)*8) + (kptr(3)*8) + (kptr(4)*8) + 24
1967 C
1968 C BYTE 4 NUMBER OF UNUSED BITS AT END OF SECTION 3
1969 C
1970  CALL gbytec (msga,kptr(11),kptr(8),8)
1971  kptr(8) = kptr(8) + 8
1972 C
1973 C BYTE 5,6 TABLE REFERENCE IF 0, BIT MAP FOLLOWS
1974 C
1975  CALL gbytec (msga,kptr(12),kptr(8),16)
1976  kptr(8) = kptr(8) + 16
1977 C IF TABLE REFERENCE = 0, EXTRACT BIT MAP
1978  IF (kptr(12).EQ.0) THEN
1979 C CALCULATE NR OF BITS IN BIT MAP
1980  ibits = (kptr(5) - 6) * 8 - kptr(11)
1981  kptr(10) = ibits
1982  IF (kpds(3).EQ.21.OR.kpds(3).EQ.22.OR.kpds(3).EQ.25.
1983  * or.kpds(3).EQ.61.OR.kpds(3).EQ.62) THEN
1984 C NORTHERN HEMISPHERE 21, 22, 25, 61, 62
1985  CALL fi634x(ibits,kptr(8),msga,kbms)
1986  IF (kpds(3).EQ.25) THEN
1987  kadd = 71
1988  ELSE IF (kpds(3).EQ.61.OR.kpds(3).EQ.62) THEN
1989  kadd = 90
1990  ELSE
1991  kadd = 36
1992  END IF
1993  DO 25 i = 1, kadd
1994  kbms(i+ibits) = .false.
1995  25 CONTINUE
1996  kptr(10) = kptr(10) + kadd
1997  RETURN
1998  ELSE IF (kpds(3).EQ.23.OR.kpds(3).EQ.24.OR.kpds(3).EQ.26.
1999  * or.kpds(3).EQ.63.OR.kpds(3).EQ.64) THEN
2000 C SOUTHERN HEMISPHERE 23, 24, 26, 63, 64
2001  CALL fi634x(ibits,kptr(8),msga,kbms)
2002  IF (kpds(3).EQ.26) THEN
2003  kadd = 72
2004  ELSE IF (kpds(3).EQ.63.OR.kpds(3).EQ.64) THEN
2005  kadd = 91
2006  ELSE
2007  kadd = 37
2008  END IF
2009  DO 26 i = 1, kadd
2010  kbms(i+ibits) = .false.
2011  26 CONTINUE
2012  kptr(10) = kptr(10) + kadd - 1
2013  RETURN
2014  ELSE IF (kpds(3).EQ.50) THEN
2015  kpad = 7
2016  kin = 22
2017  kbits = 0
2018  DO 55 i = 1, 7
2019  DO 54 j = 1, 4
2020  DO 51 k = 1, kpad
2021  kbits = kbits + 1
2022  kbms(kbits) = .false.
2023  51 CONTINUE
2024  CALL fi634x(kin,kptr(8),msga,kbms(kbits+1))
2025  kptr(8)=kptr(8)+kin
2026  kbits=kbits+kin
2027  DO 53 k = 1, kpad
2028  kbits = kbits + 1
2029  kbms(kbits) = .false.
2030  53 CONTINUE
2031  54 CONTINUE
2032  kin = kin + 2
2033  kpad = kpad - 1
2034  55 CONTINUE
2035  DO 57 ii = 1, 5
2036  CALL fi634x(kin,kptr(8),msga,kbms(kbits+1))
2037  kptr(8)=kptr(8)+kin
2038  kbits=kbits+kin
2039  57 CONTINUE
2040  ELSE
2041 C EXTRACT BIT MAP FROM BMS FOR OTHER GRIDS
2042  CALL fi634x(ibits,kptr(8),msga,kbms)
2043  END IF
2044  RETURN
2045  ELSE
2046 C PRINT *,'FI634-NO PREDEFINED BIT MAP PROVIDED BY THIS CENTER'
2047  kret = 12
2048  RETURN
2049  END IF
2050 C
2051  END IF
2052  kret = 0
2053 C -------------------------------------------------------
2054 C PROCESS NON-STANDARD GRID
2055 C -------------------------------------------------------
2056  IF (kpds(3).EQ.255) THEN
2057 C PRINT *,'NON STANDARD GRID, CENTER = ',KPDS(1)
2058  j = kgds(2) * kgds(3)
2059  kptr(10) = j
2060  DO 600 i = 1, j
2061  kbms(i) = .true.
2062  600 CONTINUE
2063  RETURN
2064  END IF
2065 C -------------------------------------------------------
2066 C CHECK INTERNATIONAL SET
2067 C -------------------------------------------------------
2068  IF (kpds(3).EQ.21.OR.kpds(3).EQ.22) THEN
2069 C ----- INT'L GRIDS 21, 22 - MAP SIZE 1369
2070  j = 1369
2071  kptr(10) = j
2072  CALL fi637(j,kpds,kgds,kret)
2073  IF(kret.NE.0) GO TO 820
2074  DO 3021 i = 1, 1369
2075  kbms(i) = grd21(i)
2076  3021 CONTINUE
2077  RETURN
2078  ELSE IF (kpds(3).EQ.23.OR.kpds(3).EQ.24) THEN
2079 C ----- INT'L GRIDS 23, 24 - MAP SIZE 1369
2080  j = 1369
2081  kptr(10) = j
2082  CALL fi637(j,kpds,kgds,kret)
2083  IF(kret.NE.0) GO TO 820
2084  DO 3023 i = 1, 1369
2085  kbms(i) = grd23(i)
2086  3023 CONTINUE
2087  RETURN
2088  ELSE IF (kpds(3).EQ.25) THEN
2089 C ----- INT'L GRID 25 - MAP SIZE 1368
2090  j = 1368
2091  kptr(10) = j
2092  CALL fi637(j,kpds,kgds,kret)
2093  IF(kret.NE.0) GO TO 820
2094  DO 3025 i = 1, 1368
2095  kbms(i) = grd25(i)
2096  3025 CONTINUE
2097  RETURN
2098  ELSE IF (kpds(3).EQ.26) THEN
2099 C ----- INT'L GRID 26 - MAP SIZE 1368
2100  j = 1368
2101  kptr(10) = j
2102  CALL fi637(j,kpds,kgds,kret)
2103  IF(kret.NE.0) GO TO 820
2104  DO 3026 i = 1, 1368
2105  kbms(i) = grd26(i)
2106  3026 CONTINUE
2107  RETURN
2108  ELSE IF (kpds(3).GE.37.AND.kpds(3).LE.44) THEN
2109 C ----- INT'L GRID 37-44 - MAP SIZE 3447
2110  j = 3447
2111  GO TO 800
2112  ELSE IF (kpds(1).EQ.7.AND.kpds(3).EQ.50) THEN
2113 C ----- INT'L GRIDS 50 - MAP SIZE 964
2114  j = 1188
2115  kptr(10) = j
2116  CALL fi637(j,kpds,kgds,kret)
2117  IF(kret.NE.0) GO TO 890
2118  DO 3050 i = 1, j
2119  kbms(i) = grd50(i)
2120  3050 CONTINUE
2121  RETURN
2122  ELSE IF (kpds(3).EQ.61.OR.kpds(3).EQ.62) THEN
2123 C ----- INT'L GRIDS 61, 62 - MAP SIZE 4186
2124  j = 4186
2125  kptr(10) = j
2126  CALL fi637(j,kpds,kgds,kret)
2127  IF(kret.NE.0) GO TO 820
2128  DO 3061 i = 1, 4186
2129  kbms(i) = grd61(i)
2130  3061 CONTINUE
2131  RETURN
2132  ELSE IF (kpds(3).EQ.63.OR.kpds(3).EQ.64) THEN
2133 C ----- INT'L GRIDS 63, 64 - MAP SIZE 4186
2134  j = 4186
2135  kptr(10) = j
2136  CALL fi637(j,kpds,kgds,kret)
2137  IF(kret.NE.0) GO TO 820
2138  DO 3063 i = 1, 4186
2139  kbms(i) = grd63(i)
2140  3063 CONTINUE
2141  RETURN
2142  END IF
2143 C -------------------------------------------------------
2144 C CHECK UNITED STATES SET
2145 C -------------------------------------------------------
2146  IF (kpds(1).EQ.7) THEN
2147  IF (kpds(3).LT.100) THEN
2148  IF (kpds(3).EQ.1) THEN
2149 C ----- U.S. GRID 1 - MAP SIZE 1679
2150  j = 1679
2151  GO TO 800
2152  END IF
2153  IF (kpds(3).EQ.2) THEN
2154 C ----- U.S. GRID 2 - MAP SIZE 10512
2155  j = 10512
2156  GO TO 800
2157  ELSE IF (kpds(3).EQ.3) THEN
2158 C ----- U.S. GRID 3 - MAP SIZE 65160
2159  j = 65160
2160  GO TO 800
2161  ELSE IF (kpds(3).EQ.4) THEN
2162 C ----- U.S. GRID 4 - MAP SIZE 259920
2163  j = 259920
2164  GO TO 800
2165  ELSE IF (kpds(3).EQ.5) THEN
2166 C ----- U.S. GRID 5 - MAP SIZE 3021
2167  j = 3021
2168  GO TO 800
2169  ELSE IF (kpds(3).EQ.6) THEN
2170 C ----- U.S. GRID 6 - MAP SIZE 2385
2171  j = 2385
2172  GO TO 800
2173  ELSE IF (kpds(3).EQ.8) THEN
2174 C ----- U.S. GRID 8 - MAP SIZE 5104
2175  j = 5104
2176  GO TO 800
2177  ELSE IF (kpds(3).EQ.10) THEN
2178 C ----- U.S. GRID 10 - MAP SIZE 25020
2179  j = 25020
2180  GO TO 800
2181  ELSE IF (kpds(3).EQ.11) THEN
2182 C ----- U.S. GRID 11 - MAP SIZE 223920
2183  j = 223920
2184  GO TO 800
2185  ELSE IF (kpds(3).EQ.12) THEN
2186 C ----- U.S. GRID 12 - MAP SIZE 99631
2187  j = 99631
2188  GO TO 800
2189  ELSE IF (kpds(3).EQ.13) THEN
2190 C ----- U.S. GRID 13 - MAP SIZE 36391
2191  j = 36391
2192  GO TO 800
2193  ELSE IF (kpds(3).EQ.14) THEN
2194 C ----- U.S. GRID 14 - MAP SIZE 153811
2195  j = 153811
2196  GO TO 800
2197  ELSE IF (kpds(3).EQ.15) THEN
2198 C ----- U.S. GRID 15 - MAP SIZE 74987
2199  j = 74987
2200  GO TO 800
2201  ELSE IF (kpds(3).EQ.16) THEN
2202 C ----- U.S. GRID 16 - MAP SIZE 214268
2203  j = 214268
2204  GO TO 800
2205  ELSE IF (kpds(3).EQ.17) THEN
2206 C ----- U.S. GRID 17 - MAP SIZE 387136
2207  j = 387136
2208  GO TO 800
2209  ELSE IF (kpds(3).EQ.18) THEN
2210 C ----- U.S. GRID 18 - MAP SIZE 281866
2211  j = 281866
2212  GO TO 800
2213  ELSE IF (kpds(3).EQ.27.OR.kpds(3).EQ.28) THEN
2214 C ----- U.S. GRIDS 27, 28 - MAP SIZE 4225
2215  j = 4225
2216  GO TO 800
2217  ELSE IF (kpds(3).EQ.29.OR.kpds(3).EQ.30) THEN
2218 C ----- U.S. GRIDS 29,30 - MAP SIZE 5365
2219  j = 5365
2220  GO TO 800
2221  ELSE IF (kpds(3).EQ.33.OR.kpds(3).EQ.34) THEN
2222 C ----- U.S GRID 33, 34 - MAP SIZE 8326
2223  j = 8326
2224  GO TO 800
2225  ELSE IF (kpds(3).GE.37.AND.kpds(3).LE.44) THEN
2226 C ----- U.S. GRID 37-44 - MAP SIZE 3447
2227  j = 3447
2228  GO TO 800
2229  ELSE IF (kpds(3).EQ.45) THEN
2230 C ----- U.S. GRID 45 - MAP SIZE 41760
2231  j = 41760
2232  GO TO 800
2233  ELSE IF (kpds(3).EQ.53) THEN
2234 C ----- U.S. GRID 53 - MAP SIZE 5967
2235  j = 5967
2236  GO TO 800
2237  ELSE IF (kpds(3).EQ.55.OR.kpds(3).EQ.56) THEN
2238 C ----- U.S GRID 55, 56 - MAP SIZE 6177
2239  j = 6177
2240  GO TO 800
2241  ELSE IF (kpds(3).GE.67.AND.kpds(3).LE.71) THEN
2242 C ----- U.S GRID 67-71 - MAP SIZE 13689
2243  j = 13689
2244  GO TO 800
2245  ELSE IF (kpds(3).EQ.72) THEN
2246 C ----- U.S GRID 72 - MAP SIZE 406
2247  j = 406
2248  GO TO 800
2249  ELSE IF (kpds(3).EQ.73) THEN
2250 C ----- U.S GRID 73 - MAP SIZE 13056
2251  j = 13056
2252  GO TO 800
2253  ELSE IF (kpds(3).EQ.74) THEN
2254 C ----- U.S GRID 74 - MAP SIZE 10800
2255  j = 10800
2256  GO TO 800
2257  ELSE IF (kpds(3).GE.75.AND.kpds(3).LE.77) THEN
2258 C ----- U.S GRID 75-77 - MAP SIZE 12321
2259  j = 12321
2260  GO TO 800
2261  ELSE IF (kpds(3).EQ.83) THEN
2262 C ----- U.S GRID 83 - MAP SIZE 429786
2263  j = 429786
2264  GO TO 800
2265  ELSE IF (kpds(3).EQ.85.OR.kpds(3).EQ.86) THEN
2266 C ----- U.S GRID 85,86 - MAP SIZE 32400
2267  j = 32400
2268  GO TO 800
2269  ELSE IF (kpds(3).EQ.87) THEN
2270 C ----- U.S GRID 87 - MAP SIZE 5022
2271  j = 5022
2272  GO TO 800
2273  ELSE IF (kpds(3).EQ.88) THEN
2274 C ----- U.S GRID 88 - MAP SIZE 317840
2275  j = 317840
2276  GO TO 800
2277  ELSE IF (kpds(3).EQ.90) THEN
2278 C ----- U.S GRID 90 - MAP SIZE 11807617
2279  j = 11807617
2280  GO TO 800
2281  ELSE IF (kpds(3).EQ.91) THEN
2282 C ----- U.S GRID 91 - MAP SIZE 1822145
2283  j = 1822145
2284  GO TO 800
2285  ELSE IF (kpds(3).EQ.92) THEN
2286 C ----- U.S GRID 92 - MAP SIZE 7283073
2287  j = 7283073
2288  GO TO 800
2289  ELSE IF (kpds(3).EQ.93) THEN
2290 C ----- U.S GRID 93 - MAP SIZE 111723
2291  j = 111723
2292  GO TO 800
2293  ELSE IF (kpds(3).EQ.94) THEN
2294 C ----- U.S GRID 94 - MAP SIZE 371875
2295  j = 371875
2296  GO TO 800
2297  ELSE IF (kpds(3).EQ.95) THEN
2298 C ----- U.S GRID 95 - MAP SIZE 130325
2299  j = 130325
2300  GO TO 800
2301  ELSE IF (kpds(3).EQ.96) THEN
2302 C ----- U.S GRID 96 - MAP SIZE 209253
2303  j = 209253
2304  GO TO 800
2305  ELSE IF (kpds(3).EQ.97) THEN
2306 C ----- U.S GRID 97 - MAP SIZE 1508100
2307  j = 1508100
2308  GO TO 800
2309  ELSE IF (kpds(3).EQ.98) THEN
2310 C ----- U.S GRID 98 - MAP SIZE 18048
2311  j = 18048
2312  GO TO 800
2313  ELSE IF (kpds(3).EQ.99) THEN
2314 C ----- U.S GRID 99 - MAP SIZE 779385
2315  j = 779385
2316  GO TO 800
2317  END IF
2318  ELSE IF (kpds(3).GE.100.AND.kpds(3).LT.200) THEN
2319  IF (kpds(3).EQ.100) THEN
2320 C ----- U.S. GRID 100 - MAP SIZE 6889
2321  j = 6889
2322  GO TO 800
2323  ELSE IF (kpds(3).EQ.101) THEN
2324 C ----- U.S. GRID 101 - MAP SIZE 10283
2325  j = 10283
2326  GO TO 800
2327  ELSE IF (kpds(3).EQ.103) THEN
2328 C ----- U.S. GRID 103 - MAP SIZE 3640
2329  j = 3640
2330  GO TO 800
2331  ELSE IF (kpds(3).EQ.104) THEN
2332 C ----- U.S. GRID 104 - MAP SIZE 16170
2333  j = 16170
2334  GO TO 800
2335  ELSE IF (kpds(3).EQ.105) THEN
2336 C ----- U.S. GRID 105 - MAP SIZE 6889
2337  j = 6889
2338  GO TO 800
2339  ELSE IF (kpds(3).EQ.106) THEN
2340 C ----- U.S. GRID 106 - MAP SIZE 19305
2341  j = 19305
2342  GO TO 800
2343  ELSE IF (kpds(3).EQ.107) THEN
2344 C ----- U.S. GRID 107 - MAP SIZE 11040
2345  j = 11040
2346  GO TO 800
2347  ELSE IF (kpds(3).EQ.110) THEN
2348 C ----- U.S. GRID 110 - MAP SIZE 103936
2349  j = 103936
2350  GO TO 800
2351  ELSE IF (kpds(3).EQ.120) THEN
2352 C ----- U.S. GRID 120 - MAP SIZE 2020800
2353  j = 2020800
2354  GO TO 800
2355  ELSE IF (kpds(3).EQ.122) THEN
2356 C ----- U.S. GRID 122 - MAP SIZE 162750
2357  j = 162750
2358  GO TO 800
2359  ELSE IF (kpds(3).EQ.123) THEN
2360 C ----- U.S. GRID 123 - MAP SIZE 100800
2361  j = 100800
2362  GO TO 800
2363  ELSE IF (kpds(3).EQ.124) THEN
2364 C ----- U.S. GRID 124 - MAP SIZE 75360
2365  j = 75360
2366  GO TO 800
2367  ELSE IF (kpds(3).EQ.125) THEN
2368 C ----- U.S. GRID 125 - MAP SIZE 102000
2369  j = 102000
2370  GO TO 800
2371  ELSE IF (kpds(3).EQ.126) THEN
2372 C ----- U.S. GRID 126 - MAP SIZE 72960
2373  j = 72960
2374  GO TO 800
2375  ELSE IF (kpds(3).EQ.127) THEN
2376 C ----- U.S. GRID 127 - MAP SIZE 294912
2377  j = 294912
2378  GO TO 800
2379  ELSE IF (kpds(3).EQ.128) THEN
2380 C ----- U.S. GRID 128 - MAP SIZE 663552
2381  j = 663552
2382  GO TO 800
2383  ELSE IF (kpds(3).EQ.129) THEN
2384 C ----- U.S. GRID 129 - MAP SIZE 1548800
2385  j = 1548800
2386  GO TO 800
2387  ELSE IF (kpds(3).EQ.130) THEN
2388 C ----- U.S. GRID 130 - MAP SIZE 151987
2389  j = 151987
2390  GO TO 800
2391  ELSE IF (kpds(3).EQ.132) THEN
2392 C ----- U.S. GRID 132 - MAP SIZE 385441
2393  j = 385441
2394  GO TO 800
2395  ELSE IF (kpds(3).EQ.138) THEN
2396 C ----- U.S. GRID 138 - MAP SIZE 134784
2397  j = 134784
2398  GO TO 800
2399  ELSE IF (kpds(3).EQ.139) THEN
2400 C ----- U.S. GRID 139 - MAP SIZE 4160
2401  j = 4160
2402  GO TO 800
2403  ELSE IF (kpds(3).EQ.140) THEN
2404 C ----- U.S. GRID 140 - MAP SIZE 32437
2405  j = 32437
2406  GO TO 800
2407 C
2408  ELSE IF (kpds(3).EQ.145) THEN
2409 C ----- U.S. GRID 145 - MAP SIZE 24505
2410  j = 24505
2411  GO TO 800
2412  ELSE IF (kpds(3).EQ.146) THEN
2413 C ----- U.S. GRID 146 - MAP SIZE 23572
2414  j = 23572
2415  GO TO 800
2416  ELSE IF (kpds(3).EQ.147) THEN
2417 C ----- U.S. GRID 147 - MAP SIZE 69412
2418  j = 69412
2419  GO TO 800
2420  ELSE IF (kpds(3).EQ.148) THEN
2421 C ----- U.S. GRID 148 - MAP SIZE 117130
2422  j = 117130
2423  GO TO 800
2424  ELSE IF (kpds(3).EQ.150) THEN
2425 C ----- U.S. GRID 150 - MAP SIZE 806010
2426  j = 806010
2427  GO TO 800
2428  ELSE IF (kpds(3).EQ.151) THEN
2429 C ----- U.S. GRID 151 - MAP SIZE 205062
2430  j = 205062
2431  GO TO 800
2432  ELSE IF (kpds(3).EQ.160) THEN
2433 C ----- U.S. GRID 160 - MAP SIZE 28080
2434  j = 28080
2435  GO TO 800
2436  ELSE IF (kpds(3).EQ.161) THEN
2437 C ----- U.S. GRID 161 - MAP SIZE 14111
2438  j = 14111
2439  GO TO 800
2440  ELSE IF (kpds(3).EQ.163) THEN
2441 C ----- U.S. GRID 163 - MAP SIZE 727776
2442  j = 727776
2443  GO TO 800
2444  ELSE IF (kpds(3).EQ.170) THEN
2445 C ----- U.S. GRID 170 - MAP SIZE 131072
2446  j = 131072
2447  GO TO 800
2448  ELSE IF (kpds(3).EQ.171) THEN
2449 C ----- U.S. GRID 171 - MAP SIZE 716100
2450  j = 716100
2451  GO TO 800
2452  ELSE IF (kpds(3).EQ.172) THEN
2453 C ----- U.S. GRID 172 - MAP SIZE 489900
2454  j = 489900
2455  GO TO 800
2456  ELSE IF (kpds(3).EQ.173) THEN
2457 C ----- U.S. GRID 173 - MAP SIZE 9331200
2458  j = 9331200
2459  GO TO 800
2460  ELSE IF (kpds(3).EQ.174) THEN
2461 C ----- U.S. GRID 174 - MAP SIZE 4147200
2462  j = 4147200
2463  GO TO 800
2464  ELSE IF (kpds(3).EQ.175) THEN
2465 C ----- U.S. GRID 175 - MAP SIZE 185704
2466  j = 185704
2467  GO TO 800
2468  ELSE IF (kpds(3).EQ.176) THEN
2469 C ----- U.S. GRID 176 - MAP SIZE 76845
2470  j = 76845
2471  GO TO 800
2472  ELSE IF (kpds(3).EQ.179) THEN
2473 C ----- U.S. GRID 179 - MAP SIZE 977132
2474  j = 977132
2475  GO TO 800
2476  ELSE IF (kpds(3).EQ.180) THEN
2477 C ----- U.S. GRID 180 - MAP SIZE 267168
2478  j = 267168
2479  GO TO 800
2480  ELSE IF (kpds(3).EQ.181) THEN
2481 C ----- U.S. GRID 181 - MAP SIZE 102860
2482  j = 102860
2483  GO TO 800
2484  ELSE IF (kpds(3).EQ.182) THEN
2485 C ----- U.S. GRID 182 - MAP SIZE 64218
2486  j = 64218
2487  GO TO 800
2488  ELSE IF (kpds(3).EQ.183) THEN
2489 C ----- U.S. GRID 183 - MAP SIZE 180144
2490  j = 180144
2491  GO TO 800
2492  ELSE IF (kpds(3).EQ.184) THEN
2493 C ----- U.S. GRID 184 - MAP SIZE 2953665
2494  j = 2953665
2495  GO TO 800
2496  ELSE IF (kpds(3).EQ.187) THEN
2497 C ----- U.S. GRID 187 - MAP SIZE 3425565
2498  j = 3425565
2499  GO TO 800
2500  ELSE IF (kpds(3).EQ.188) THEN
2501 C ----- U.S. GRID 188 - MAP SIZE 563655
2502  j = 563655
2503  GO TO 800
2504  ELSE IF (kpds(3).EQ.189) THEN
2505 C ----- U.S. GRID 189 - MAP SIZE 560025
2506  j = 560025
2507  GO TO 800
2508  ELSE IF (kpds(3).EQ.190) THEN
2509 C ----- U.S GRID 190 - MAP SIZE 796590
2510  j = 796590
2511  GO TO 800
2512  ELSE IF (kpds(3).EQ.192) THEN
2513 C ----- U.S GRID 192 - MAP SIZE 91719
2514  j = 91719
2515  GO TO 800
2516  ELSE IF (kpds(3).EQ.193) THEN
2517 C ----- U.S GRID 193 - MAP SIZE 1038240
2518  j = 1038240
2519  GO TO 800
2520  ELSE IF (kpds(3).EQ.194) THEN
2521 C ----- U.S GRID 194 - MAP SIZE 168640
2522  j = 168640
2523  GO TO 800
2524  ELSE IF (kpds(3).EQ.195) THEN
2525 C ----- U.S. GRID 195 - MAP SIZE 22833
2526  j = 22833
2527  GO TO 800
2528  ELSE IF (kpds(3).EQ.196) THEN
2529 C ----- U.S. GRID 196 - MAP SIZE 72225
2530  j = 72225
2531  GO TO 800
2532  ELSE IF (kpds(3).EQ.197) THEN
2533 C ----- U.S. GRID 197 - MAP SIZE 739297
2534  j = 739297
2535  GO TO 800
2536  ELSE IF (kpds(3).EQ.198) THEN
2537 C ----- U.S. GRID 198 - MAP SIZE 456225
2538  j = 456225
2539  GO TO 800
2540  ELSE IF (kpds(3).EQ.199) THEN
2541 C ----- U.S. GRID 199 - MAP SIZE 37249
2542  j = 37249
2543  GO TO 800
2544  ELSE IF (iand(kpds(4),128).EQ.128) THEN
2545 C ----- U.S. NON-STANDARD GRID
2546  GO TO 895
2547  END IF
2548  ELSE IF (kpds(3).GE.200) THEN
2549  IF (kpds(3).EQ.200) THEN
2550  j = 10152
2551  GO TO 800
2552  ELSE IF (kpds(3).EQ.201) THEN
2553  j = 4225
2554  GO TO 800
2555  ELSE IF (kpds(3).EQ.202) THEN
2556  j = 2795
2557  GO TO 800
2558  ELSE IF (kpds(3).EQ.203.OR.kpds(3).EQ.205) THEN
2559  j = 1755
2560  GO TO 800
2561  ELSE IF (kpds(3).EQ.204) THEN
2562  j = 6324
2563  GO TO 800
2564  ELSE IF (kpds(3).EQ.206) THEN
2565  j = 2091
2566  GO TO 800
2567  ELSE IF (kpds(3).EQ.207) THEN
2568  j = 1715
2569  GO TO 800
2570  ELSE IF (kpds(3).EQ.208) THEN
2571  j = 783
2572  GO TO 800
2573  ELSE IF (kpds(3).EQ.209) THEN
2574  j = 61325
2575  GO TO 800
2576  ELSE IF (kpds(3).EQ.210) THEN
2577  j = 625
2578  GO TO 800
2579  ELSE IF (kpds(3).EQ.211) THEN
2580  j = 6045
2581  GO TO 800
2582  ELSE IF (kpds(3).EQ.212) THEN
2583  j = 23865
2584  GO TO 800
2585  ELSE IF (kpds(3).EQ.213) THEN
2586  j = 10965
2587  GO TO 800
2588  ELSE IF (kpds(3).EQ.214) THEN
2589  j = 6693
2590  GO TO 800
2591  ELSE IF (kpds(3).EQ.215) THEN
2592  j = 94833
2593  GO TO 800
2594  ELSE IF (kpds(3).EQ.216) THEN
2595  j = 14873
2596  GO TO 800
2597  ELSE IF (kpds(3).EQ.217) THEN
2598  j = 59001
2599  GO TO 800
2600  ELSE IF (kpds(3).EQ.218) THEN
2601  j = 262792
2602  GO TO 800
2603  ELSE IF (kpds(3).EQ.219) THEN
2604  j = 179025
2605  GO TO 800
2606  ELSE IF (kpds(3).EQ.220) THEN
2607  j = 122475
2608  GO TO 800
2609  ELSE IF (kpds(3).EQ.221) THEN
2610  j = 96673
2611  GO TO 800
2612  ELSE IF (kpds(3).EQ.222) THEN
2613  j = 15456
2614  GO TO 800
2615  ELSE IF (kpds(3).EQ.223) THEN
2616  j = 16641
2617  GO TO 800
2618  ELSE IF (kpds(3).EQ.224) THEN
2619  j = 4225
2620  GO TO 800
2621  ELSE IF (kpds(3).EQ.225) THEN
2622  j = 24975
2623  GO TO 800
2624  ELSE IF (kpds(3).EQ.226) THEN
2625  j = 381029
2626  GO TO 800
2627  ELSE IF (kpds(3).EQ.227) THEN
2628  j = 1509825
2629  GO TO 800
2630  ELSE IF (kpds(3).EQ.228) THEN
2631  j = 10512
2632  GO TO 800
2633  ELSE IF (kpds(3).EQ.229) THEN
2634  j = 65160
2635  GO TO 800
2636  ELSE IF (kpds(3).EQ.230) THEN
2637  j = 259920
2638  GO TO 800
2639  ELSE IF (kpds(3).EQ.231) THEN
2640  j = 130320
2641  GO TO 800
2642  ELSE IF (kpds(3).EQ.232) THEN
2643  j = 32760
2644  GO TO 800
2645  ELSE IF (kpds(3).EQ.233) THEN
2646  j = 45216
2647  GO TO 800
2648  ELSE IF (kpds(3).EQ.234) THEN
2649  j = 16093
2650  GO TO 800
2651  ELSE IF (kpds(3).EQ.235) THEN
2652  j = 259200
2653  GO TO 800
2654  ELSE IF (kpds(3).EQ.236) THEN
2655  j = 17063
2656  GO TO 800
2657  ELSE IF (kpds(3).EQ.237) THEN
2658  j = 2538
2659  GO TO 800
2660  ELSE IF (kpds(3).EQ.238) THEN
2661  j = 55825
2662  GO TO 800
2663  ELSE IF (kpds(3).EQ.239) THEN
2664  j = 19065
2665  GO TO 800
2666  ELSE IF (kpds(3).EQ.240) THEN
2667  j = 987601
2668  GO TO 800
2669  ELSE IF (kpds(3).EQ.241) THEN
2670  j = 244305
2671  GO TO 800
2672  ELSE IF (kpds(3).EQ.242) THEN
2673  j = 235025
2674  GO TO 800
2675  ELSE IF (kpds(3).EQ.243) THEN
2676  j = 12726
2677  GO TO 800
2678  ELSE IF (kpds(3).EQ.244) THEN
2679  j = 55825
2680  GO TO 800
2681  ELSE IF (kpds(3).EQ.245) THEN
2682  j = 124992
2683  GO TO 800
2684  ELSE IF (kpds(3).EQ.246) THEN
2685  j = 123172
2686  GO TO 800
2687  ELSE IF (kpds(3).EQ.247) THEN
2688  j = 124992
2689  GO TO 800
2690  ELSE IF (kpds(3).EQ.248) THEN
2691  j = 13635
2692  GO TO 800
2693  ELSE IF (kpds(3).EQ.249) THEN
2694  j = 125881
2695  GO TO 800
2696  ELSE IF (kpds(3).EQ.250) THEN
2697  j = 13635
2698  GO TO 800
2699  ELSE IF (kpds(3).EQ.251) THEN
2700  j = 69720
2701  GO TO 800
2702  ELSE IF (kpds(3).EQ.252) THEN
2703  j = 67725
2704  GO TO 800
2705  ELSE IF (kpds(3).EQ.253) THEN
2706  j = 83552
2707  GO TO 800
2708  ELSE IF (kpds(3).EQ.254) THEN
2709  j = 110700
2710  GO TO 800
2711  ELSE IF (iand(kpds(4),128).EQ.128) THEN
2712  GO TO 895
2713  END IF
2714  kret = 5
2715  RETURN
2716  END IF
2717  END IF
2718 C -------------------------------------------------------
2719 C CHECK JAPAN METEOROLOGICAL AGENCY SET
2720 C -------------------------------------------------------
2721  IF (kpds(1).EQ.34) THEN
2722  IF (iand(kpds(4),128).EQ.128) THEN
2723 C PRINT *,'JMA MAP IS NOT PREDEFINED, THE GDS WILL'
2724 C PRINT *,'BE USED TO UNPACK THE DATA, MAP = ',KPDS(3)
2725  GO TO 900
2726  END IF
2727  END IF
2728 C -------------------------------------------------------
2729 C CHECK CANADIAN SET
2730 C -------------------------------------------------------
2731  IF (kpds(1).EQ.54) THEN
2732  IF (iand(kpds(4),128).EQ.128) THEN
2733 C PRINT *,'CANADIAN MAP IS NOT PREDEFINED, THE GDS WILL'
2734 C PRINT *,'BE USED TO UNPACK THE DATA, MAP = ',KPDS(3)
2735  GO TO 900
2736  END IF
2737  END IF
2738 C -------------------------------------------------------
2739 C CHECK FNOC SET
2740 C -------------------------------------------------------
2741  IF (kpds(1).EQ.58) THEN
2742  IF (kpds(3).EQ.220.OR.kpds(3).EQ.221) THEN
2743 C FNOC GRID 220, 221 - MAPSIZE 3969 (63 * 63)
2744  j = 3969
2745  kptr(10) = j
2746  DO i = 1, j
2747  kbms(i) = .true.
2748  END DO
2749  RETURN
2750  END IF
2751  IF (kpds(3).EQ.223) THEN
2752 C FNOC GRID 223 - MAPSIZE 10512 (73 * 144)
2753  j = 10512
2754  kptr(10) = j
2755  DO i = 1, j
2756  kbms(i) = .true.
2757  END DO
2758  RETURN
2759  END IF
2760  IF (iand(kpds(4),128).EQ.128) THEN
2761 C PRINT *,'FNOC MAP IS NOT PREDEFINED, THE GDS WILL'
2762 C PRINT *,'BE USED TO UNPACK THE DATA, MAP = ',KPDS(3)
2763  GO TO 900
2764  END IF
2765  END IF
2766 C -------------------------------------------------------
2767 C CHECK UKMET SET
2768 C -------------------------------------------------------
2769  IF (kpds(1).EQ.74) THEN
2770  IF (iand(kpds(4),128).EQ.128) THEN
2771  GO TO 820
2772  END IF
2773  END IF
2774 C -------------------------------------------------------
2775 C CHECK ECMWF SET
2776 C -------------------------------------------------------
2777  IF (kpds(1).EQ.98) THEN
2778  IF (kpds(3).GE.1.AND.kpds(3).LE.12) THEN
2779  IF (kpds(3).GE.5.AND.kpds(3).LE.8) THEN
2780  j = 1073
2781  ELSE
2782  j = 1369
2783  END IF
2784  kptr(10) = j
2785  CALL fi637(j,kpds,kgds,kret)
2786  IF(kret.NE.0) GO TO 810
2787  kptr(10) = j ! Reset For Modified J
2788  DO 1000 i = 1, j
2789  kbms(i) = .true.
2790  1000 CONTINUE
2791  RETURN
2792  ELSE IF (kpds(3).GE.13.AND.kpds(3).LE.16) THEN
2793  j = 361
2794  kptr(10) = j
2795  CALL fi637(j,kpds,kgds,kret)
2796  IF(kret.NE.0) GO TO 810
2797  DO 1013 i = 1, j
2798  kbms(i) = .true.
2799  1013 CONTINUE
2800  RETURN
2801  ELSE IF (iand(kpds(4),128).EQ.128) THEN
2802  GO TO 810
2803  ELSE
2804  kret = 5
2805  RETURN
2806  END IF
2807  ELSE
2808 C PRINT *,'CENTER ',KPDS(1),' IS NOT DEFINED'
2809  IF (iand(kpds(4),128).EQ.128) THEN
2810 C PRINT *,'GDS WILL BE USED TO UNPACK THE DATA',
2811 C * ' MAP = ',KPDS(3)
2812  GO TO 900
2813  ELSE
2814  kret = 10
2815  RETURN
2816  END IF
2817  END IF
2818 C =======================================
2819 C
2820  800 CONTINUE
2821  kptr(10) = j
2822  CALL fi637 (j,kpds,kgds,kret)
2823  IF(kret.NE.0) GO TO 801
2824  DO 2201 i = 1, j
2825  kbms(i) = .true.
2826  2201 CONTINUE
2827  RETURN
2828  801 CONTINUE
2829 C
2830 C ----- THE MAP HAS A GDS, BYTE 7 OF THE (PDS) THE GRID IDENTIFICATION
2831 C ----- IS NOT 255, THE SIZE OF THE GRID IS NOT THE SAME AS THE
2832 C ----- PREDEFINED SIZES OF THE U.S. GRIDS, OR KNOWN GRIDS OF THE
2833 C ----- OF THE OTHER CENTERS. THE GRID CAN BE UNKNOWN, OR FROM AN
2834 C ----- UNKNOWN CENTER, WE WILL USE THE INFORMATION IN THE GDS TO MAKE
2835 C ----- A BIT MAP.
2836 C
2837  810 CONTINUE
2838 C PRINT *,'ECMWF PREDEFINED MAP SIZE DOES NOT MATCH, I WILL USE'
2839  GO TO 895
2840 C
2841  820 CONTINUE
2842 C PRINT *,'U.K. MET PREDEFINED MAP SIZE DOES NOT MATCH, I WILL USE'
2843  GO TO 895
2844 C
2845  890 CONTINUE
2846 C PRINT *,'PREDEFINED MAP SIZE DOES NOT MATCH, I WILL USE'
2847  895 CONTINUE
2848 C PRINT *,'THE GDS TO UNPACK THE DATA, MAP TYPE = ',KPDS(3)
2849 C
2850  900 CONTINUE
2851  j = kgds(2) * kgds(3)
2852 C AFOS AFOS AFOS SPECIAL CASE
2853 C INVOLVES NEXT SINGLE STATEMENT ONLY
2854  IF (kpds(3).EQ.211) kret = 0
2855  kptr(10) = j
2856  DO 2203 i = 1, j
2857  kbms(i) = .true.
2858  2203 CONTINUE
2859 C PRINT *,'EXIT FI634'
2860  RETURN
2861  END
2862 C-----------------------------------------------------------------------
2863 
2864 C> @brief Extract bit map.
2865 C> @author Mark Iredell @date 1997-09-19
2866 
2867 C> Extract the packed bitmap into a logical array.
2868 C>
2869 C> Program history log:
2870 C> 97-09-19 Vectorized bitmap decoder.
2871 C>
2872 C> @param[in] NPTS XInteger number of points in the bitmap field
2873 C> @param[in] NSKP Integer number of bits to skip in grib message
2874 C> @param[in] MSGA Character*1 grib message
2875 C> @param[out] KBMS Logical*1 bitmap
2876 C>
2877 C> @note Subprogram can be called from a multiprocessing environment.
2878 C>
2879 C> @author Mark Iredell @date 1997-09-19
2880 
2881  SUBROUTINE fi634x(NPTS,NSKP,MSGA,KBMS)
2882 
2883  CHARACTER*1 MSGA(*)
2884  LOGICAL*1 KBMS(NPTS)
2885  INTEGER ICHK(NPTS)
2886 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2887  CALL gbytesc(msga,ichk,nskp,1,0,npts)
2888  kbms=ichk.NE.0
2889 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2890  END
2891 
2892 
2893 C> @brief Extract grib data elements from bds
2894 C> @author Bill Cavanaugh @date 1991-09-13
2895 
2896 C> Extract grib data from binary data section and place
2897 C> into output array in proper position.
2898 C>
2899 C> Program history log:
2900 C> - Bill Cavanaugh 1991-09-13
2901 C> - Bill Cavanaugh 1994-04-01 Modified code to include decimal scaling when
2902 C> calculating the value of data points specified
2903 C> as being equal to the reference value
2904 C> - Farley 1994-11-10 Increased mxsize from 72960 to 260000
2905 C> for .5 degree sst analysis fields.
2906 C> - Mark Iredell 1995-10-31 Removed saves and prints
2907 C> - Mark Iredell 1998-08-31 Eliminated need for mxsize
2908 C>
2909 C> @param[in] MSGA Array containing grib message
2910 C> @param[inout] KPTR Array containing storage for following parameters
2911 C> - 1 Total length of grib message
2912 C> - 2 Length of indicator (section 0)
2913 C> - 3 Length of pds (section 1)
2914 C> - 4 Length of gds (section 2)
2915 C> - 5 Length of bms (section 3)
2916 C> - 6 Length of bds (section 4)
2917 C> - 7 Value of current byte
2918 C> - 8 Bit pointer
2919 C> - 9 Grib start bit nr
2920 C> - 10 Grib/grid element count
2921 C> - 11 Nr unused bits at end of section 3
2922 C> - 12 Bit map flag
2923 C> - 13 Nr unused bits at end of section 2
2924 C> - 14 Bds flags
2925 C> - 15 Nr unused bits at end of section 4
2926 C> - 16 Reserved
2927 C> - 17 Reserved
2928 C> - 18 Reserved
2929 C> - 19 Binary scale factor
2930 C> - 20 Num bits used to pack each datum
2931 C> @param[in] KPDS Array containing pds elements.
2932 C> See initial routine
2933 C> @param[in] KGDS Array containing gds elements.
2934 C> - 1) Data representation type
2935 C> - 19 Number of vertical coordinate parameters
2936 C> - 20 Octet number of the list of vertical coordinate
2937 C> parameters Or Octet number of the list of numbers of points
2938 C> in each row Or 255 if neither are present.
2939 C> - 21 For grids with pl, number of points in grid
2940 C> - 22 Number of words in each row
2941 C> - Longitude grids
2942 C> - 2) N(i) nr points on latitude circle
2943 C> - 3) N(j) nr points on longitude meridian
2944 C> - 4) La(1) latitude of origin
2945 C> - 5) Lo(1) longitude of origin
2946 C> - 6) Resolution flag
2947 C> - 7) La(2) latitude of extreme point
2948 C> - 8) Lo(2) longitude of extreme point
2949 C> - 9) Di longitudinal direction of increment
2950 C> - 10 Dj latitudinal direction increment
2951 C> - 11 Scanning mode flag
2952 C> - Polar stereographic grids
2953 C> - 2) N(i) nr points along lat circle
2954 C> - 3) N(j) nr points along lon circle
2955 C> - 4) La(1) latitude of origin
2956 C> - 5) Lo(1) longitude of origin
2957 C> - 6) Reserved
2958 C> - 7) Lov grid orientation
2959 C> - 8) Dx - x direction increment
2960 C> - 9) Dy - y direction increment
2961 C> - 10 Projection center flag
2962 C> - 11 Scanning mode
2963 C> - Spherical harmonic coefficients
2964 C> - 2 J pentagonal resolution parameter
2965 C> - 3 K pentagonal resolution parameter
2966 C> - 4 M pentagonal resolution parameter
2967 C> - 5 Representation type
2968 C> - 6 Coefficient storage mode
2969 C> - Mercator grids
2970 C> - 2 N(i) nr points on latitude circle
2971 C> - 3 N(j) nr points on longitude meridian
2972 C> - 4 La(1) latitude of origin
2973 C> - 5 Lo(1) longitude of origin
2974 C> - 6 Resolution flag
2975 C> - 7 La(2) latitude of last grid point
2976 C> - 8 Lo(2) longitude of last grid point
2977 C> - 9 Latin - latitude of projection intersection
2978 C> - 10 Reserved
2979 C> - 11 Scanning mode flag
2980 C> - 12 Longitudinal dir grid length
2981 C> - 13 Latitudinal dir grid length
2982 C> - Lambert conformal grids
2983 C> - 2 Nx nr points along x-axis
2984 C> - 3 Ny nr points along y-axis
2985 C> - 4 La1 lat of origin (lower left)
2986 C> - 5 Lo1 lon of origin (lower left)
2987 C> - 6 Resolution (right adj copy of octet 17)
2988 C> - 7 Lov - orientation of grid
2989 C> - 8 Dx - x-dir increment
2990 C> - 9 Dy - y-dir increment
2991 C> - 10 Projection center flag
2992 C> - 11 Scanning mode flag
2993 C> - 12 Latin 1 - first lat from pole of secant cone inter
2994 C> - 13 Latin 2 - second lat from pole of secant cone inter
2995 C> - Staggered arakawa rotated lat/lon grids (203 e stagger)
2996 C> - 2 N(i) nr points on rotated latitude circle
2997 C> - 3 N(j) nr points on rotated longitude meridian
2998 C> - 4 La(1) latitude of origin
2999 C> - 5 Lo(1) longitude of origin
3000 C> - 6 Resolution flag
3001 C> - 7 La(2) latitude of center
3002 C> - 8 Lo(2) longitude of center
3003 C> - 9 Di longitudinal direction of increment
3004 C> - 10 Dj latitudinal direction increment
3005 C> - 11 Scanning mode flag
3006 C> - Staggered arakawa rotated lat/lon grids (205 a,b,c,d staggers)
3007 C> - 2 N(i) nr points on rotated latitude circle
3008 C> - 3 N(j) nr points on rotated longitude meridian
3009 C> - 4 La(1) latitude of origin
3010 C> - 5 Lo(1) longitude of origin
3011 C> - 6 Resolution flag
3012 C> - 7 La(2) latitude of center
3013 C> - 8 Lo(2) longitude of center
3014 C> - 9 Di longitudinal direction of increment
3015 C> - 10 Dj latitudinal direction increment
3016 C> - 11 Scanning mode flag
3017 C> - 12 Latitude of last point
3018 C> - 13 Longitude of last point
3019 C> @param[in] KBMS Bitmap describing location of output elements.
3020 C> -KBDS Information extracted from binary data section
3021 C> - KBDS(1) - N1
3022 C> - KBDS(2) - N2
3023 C> - KBDS(3) - P1
3024 C> - KBDS(4) - P2
3025 C> - KBDS(5) - Bit pointer to 2nd order widths
3026 C> - KBDS(6) - Bit pointer to 2nd order bit maps
3027 C> - KBDS(7) - Bit pointer to first order values
3028 C> - KBDS(8) - Bit pointer to second order values
3029 C> - KBDS(9) - Bit pointer start of bds
3030 C> - KBDS(10) - Bit pointer main bit map
3031 C> - KBDS(11) - Binary scaling
3032 C> - KBDS(12) - Decimal scaling
3033 C> - KBDS(13) - Bit width of first order values
3034 C> - KBDS(14) - Bit map flag
3035 C> 0 = no second order bit map
3036 C> 1 = second order bit map present
3037 C> - KBDS(15) - Second order bit width
3038 C> - KBDS(16) - Constant / different widths
3039 C> 0 = constant widths
3040 C> 1 = different widths
3041 C> - KBDS(17) - Single datum / matrix
3042 C> - 0 = single datum at each grid point
3043 C> - 1 = matrix of values at each grid point
3044 C> - (18-20) - Unused
3045 C> @param[out] DATA Real*4 array of gridded elements in grib message.
3046 C> @param[out] KRET Error return
3047 C>
3048 C> @note
3049 C> - Error return
3050 C> - 3 = Unpacked field is larger than 65160
3051 C> - 6 = Does not match nr of entries for this grib/grid
3052 C> - 7 = Number of bits in fill too large
3053 C>
3054 C> @author Bill Cavanaugh @date 1991-09-13
3055  SUBROUTINE fi635(MSGA,KPTR,KPDS,KGDS,KBMS,DATA,KRET)
3056 
3057 C
3058  CHARACTER*1 MSGA(*)
3059 C
3060  LOGICAL*1 KBMS(*)
3061 C
3062  INTEGER KPDS(*)
3063  INTEGER KGDS(*)
3064  INTEGER KBDS(20)
3065  INTEGER KPTR(*)
3066  INTEGER NRBITS
3067  INTEGER,ALLOCATABLE:: KSAVE(:)
3068  INTEGER KSCALE
3069 C
3070  REAL DATA(*)
3071  REAL REFNCE
3072  REAL SCALE
3073  REAL REALKK
3074 C
3075 C
3076 C CHANGED HEX VALUES TO DECIMAL TO MAKE CODE MORE PORTABLE
3077 C
3078 C *************************************************************
3079 C PRINT *,'ENTER FI635'
3080 C SET UP BIT POINTER
3081  kptr(8) = kptr(9) + (kptr(2)*8) + (kptr(3)*8) + (kptr(4)*8)
3082  * + (kptr(5)*8) + 24
3083 C ------------- EXTRACT FLAGS
3084 C BYTE 4
3085  CALL gbytec(msga,kptr(14),kptr(8),4)
3086  kptr(8) = kptr(8) + 4
3087 C --------- NR OF UNUSED BITS IN SECTION 4
3088  CALL gbytec(msga,kptr(15),kptr(8),4)
3089  kptr(8) = kptr(8) + 4
3090  kend = kptr(9) + (kptr(2)*8) + (kptr(3)*8) + (kptr(4)*8)
3091  * + (kptr(5)*8) + kptr(6) * 8 - kptr(15)
3092 C ------------- GET SCALE FACTOR
3093 C BYTES 5,6
3094 C CHECK SIGN
3095  CALL gbytec (msga,ksign,kptr(8),1)
3096  kptr(8) = kptr(8) + 1
3097 C GET ABSOLUTE SCALE VALUE
3098  CALL gbytec (msga,kscale,kptr(8),15)
3099  kptr(8) = kptr(8) + 15
3100  IF (ksign.GT.0) THEN
3101  kscale = - kscale
3102  END IF
3103  scale = 2.0**kscale
3104  kptr(19)=kscale
3105 C ------------ GET REFERENCE VALUE
3106 C BYTES 7,10
3107 C CALL GBYTE (MSGA,KREF,KPTR(8),32)
3108  call gbytec(msga,jsgn,kptr(8),1)
3109  call gbytec(msga,jexp,kptr(8)+1,7)
3110  call gbytec(msga,ifr,kptr(8)+8,24)
3111  kptr(8) = kptr(8) + 32
3112 C
3113 C THE NEXT CODE WILL CONVERT THE IBM370 FLOATING POINT
3114 C TO THE FLOATING POINT USED ON YOUR COMPUTER.
3115 C
3116 C
3117 C PRINT *,109,JSGN,JEXP,IFR
3118 C 109 FORMAT (' JSGN,JEXP,IFR = ',3(1X,Z8))
3119  IF (ifr.EQ.0) THEN
3120  refnce = 0.0
3121  ELSE IF (jexp.EQ.0.AND.ifr.EQ.0) THEN
3122  refnce = 0.0
3123  ELSE
3124  refnce = float(ifr) * 16.0 ** (jexp - 64 - 6)
3125  IF (jsgn.NE.0) refnce = - refnce
3126  END IF
3127 C PRINT *,'SCALE ',SCALE,' REF VAL ',REFNCE
3128 C ------------- NUMBER OF BITS SPECIFIED FOR EACH ENTRY
3129 C BYTE 11
3130  CALL gbytec (msga,kbits,kptr(8),8)
3131  kptr(8) = kptr(8) + 8
3132  kbds(4) = kbits
3133 C KBDS(13) = KBITS
3134  kptr(20) = kbits
3135  ibyt12 = kptr(8)
3136 C ------------------ IF THERE ARE NO EXTENDED FLAGS PRESENT
3137 C THIS IS WHERE DATA BEGINS AND AND THE PROCESSING
3138 C INCLUDED IN THE FOLLOWING IF...END IF
3139 C WILL BE SKIPPED
3140 C PRINT *,'BASIC FLAGS =',KPTR(14) ,IAND(KPTR(14),1)
3141  IF (iand(kptr(14),1).EQ.0) THEN
3142 C PRINT *,'NO EXTENDED FLAGS'
3143  ELSE
3144 C BYTES 12,13
3145  CALL gbytec (msga,koctet,kptr(8),16)
3146  kptr(8) = kptr(8) + 16
3147 C --------------------------- EXTENDED FLAGS
3148 C BYTE 14
3149  CALL gbytec (msga,kxflag,kptr(8),8)
3150 C PRINT *,'HAVE EXTENDED FLAGS',KXFLAG
3151  kptr(8) = kptr(8) + 8
3152  IF (iand(kxflag,16).EQ.0) THEN
3153 C SECOND ORDER VALUES CONSTANT WIDTHS
3154  kbds(16) = 0
3155  ELSE
3156 C SECOND ORDER VALUES DIFFERENT WIDTHS
3157  kbds(16) = 1
3158  END IF
3159  IF (iand(kxflag,32).EQ.0) THEN
3160 C NO SECONDARY BIT MAP
3161  kbds(14) = 0
3162  ELSE
3163 C HAVE SECONDARY BIT MAP
3164  kbds(14) = 1
3165  END IF
3166  IF (iand(kxflag,64).EQ.0) THEN
3167 C SINGLE DATUM AT GRID POINT
3168  kbds(17) = 0
3169  ELSE
3170 C MATRIX OF VALUES AT GRID POINT
3171  kbds(17) = 1
3172  END IF
3173 C ---------------------- NR - FIRST DIMENSION (ROWS) OF EACH MATRIX
3174 C BYTES 15,16
3175  CALL gbytec (msga,nr,kptr(8),16)
3176  kptr(8) = kptr(8) + 16
3177 C ---------------------- NC - SECOND DIMENSION (COLS) OF EACH MATRIX
3178 C BYTES 17,18
3179  CALL gbytec (msga,nc,kptr(8),16)
3180  kptr(8) = kptr(8) + 16
3181 C ---------------------- NRV - FIRST DIM COORD VALS
3182 C BYTE 19
3183  CALL gbytec (msga,nrv,kptr(8),8)
3184  kptr(8) = kptr(8) + 8
3185 C ---------------------- NC1 - NR COEFF'S OR VALUES
3186 C BYTE 20
3187  CALL gbytec (msga,nc1,kptr(8),8)
3188  kptr(8) = kptr(8) + 8
3189 C ---------------------- NCV - SECOND DIM COORD OR VALUE
3190 C BYTE 21
3191  CALL gbytec (msga,ncv,kptr(8),8)
3192  kptr(8) = kptr(8) + 8
3193 C ---------------------- NC2 - NR COEFF'S OR VALS
3194 C BYTE 22
3195  CALL gbytec (msga,nc2,kptr(8),8)
3196  kptr(8) = kptr(8) + 8
3197 C ---------------------- KPHYS1 - FIRST DIM PHYSICAL SIGNIF
3198 C BYTE 23
3199  CALL gbytec (msga,kphys1,kptr(8),8)
3200  kptr(8) = kptr(8) + 8
3201 C ---------------------- KPHYS2 - SECOND DIM PHYSICAL SIGNIF
3202 C BYTE 24
3203  CALL gbytec (msga,kphys2,kptr(8),8)
3204  kptr(8) = kptr(8) + 8
3205 C BYTES 25-N
3206  END IF
3207  IF (kbits.EQ.0) THEN
3208 C HAVE NO BDS ENTRIES, ALL ENTRIES = REFNCE
3209  scal10 = 10.0 ** kpds(22)
3210  scal10 = 1.0 / scal10
3211  refn10 = refnce * scal10
3212  kentry = kptr(10)
3213  DO 210 i = 1, kentry
3214  DATA(i) = 0.0
3215  IF (kbms(i)) THEN
3216  DATA(i) = refn10
3217  END IF
3218  210 CONTINUE
3219  GO TO 900
3220  END IF
3221 C PRINT *,'KEND ',KEND,' KPTR(8) ',KPTR(8),'KBITS ',KBITS
3222  knr = (kend - kptr(8)) / kbits
3223 C PRINT *,'NUMBER OF ENTRIES IN DATA ARRAY',KNR
3224 C --------------------
3225 C CYCLE THRU BDS UNTIL HAVE USED ALL (SPECIFIED NUMBER)
3226 C ENTRIES.
3227 C ------------- UNUSED BITS IN DATA AREA
3228 C NUMBER OF BYTES IN DATA AREA
3229  nrbyte = kptr(6) - 11
3230 C ------------- TOTAL NR OF USABLE BITS
3231  nrbits = nrbyte * 8 - kptr(15)
3232 C ------------- TOTAL NR OF ENTRIES
3233  kentry = nrbits / kbits
3234 C ALLOCATE KSAVE
3235  ALLOCATE(ksave(kentry))
3236 C
3237 C IF (IAND(KPTR(14),2).EQ.0) THEN
3238 C PRINT *,'SOURCE VALUES IN FLOATING POINT'
3239 C ELSE
3240 C PRINT *,'SOURCE VALUES IN INTEGER'
3241 C END IF
3242 C
3243  IF (iand(kptr(14),8).EQ.0) THEN
3244 C PRINT *,'PROCESSING GRID POINT DATA'
3245  IF (iand(kptr(14),4).EQ.0) THEN
3246 C PRINT *,' WITH SIMPLE PACKING'
3247  IF (iand(kptr(14),1).EQ.0) THEN
3248 C PRINT *,' WITH NO ADDITIONAL FLAGS'
3249  GO TO 4000
3250  ELSE IF (iand(kptr(14),1).NE.0) THEN
3251 C PRINT *,' WITH ADDITIONAL FLAGS',KXFLAG
3252  IF (kbds(17).EQ.0) THEN
3253 C PRINT *,' SINGLE DATUM EACH GRID PT'
3254  IF (kbds(14).EQ.0) THEN
3255 C PRINT *,' NO SEC BIT MAP'
3256  IF (kbds(16).EQ.0) THEN
3257 C PRINT *,' SECOND ORDER',
3258 C * ' VALUES CONSTANT WIDTH'
3259  ELSE IF (kbds(16).NE.0) THEN
3260 C PRINT *,' SECOND ORDER',
3261 C * ' VALUES DIFFERENT WIDTHS'
3262  END IF
3263  ELSE IF (kbds(14).NE.0) THEN
3264 C PRINT *,' SEC BIT MAP'
3265  IF (kbds(16).EQ.0) THEN
3266 C PRINT *,' SECOND ORDER',
3267 C * ' VALUES CONSTANT WIDTH'
3268  ELSE IF (kbds(16).NE.0) THEN
3269 C PRINT *,' SECOND ORDER',
3270 C * ' VALUES DIFFERENT WIDTHS'
3271  END IF
3272  END IF
3273  ELSE IF (kbds(17).NE.0) THEN
3274 C PRINT *,' MATRIX OF VALS EACH PT'
3275  IF (kbds(14).EQ.0) THEN
3276 C PRINT *,' NO SEC BIT MAP'
3277  IF (kbds(16).EQ.0) THEN
3278 C PRINT *,' SECOND ORDER',
3279 C * ' VALUES CONSTANT WIDTH'
3280  ELSE IF (kbds(16).NE.0) THEN
3281 C PRINT *,' SECOND ORDER',
3282 C * ' VALUES DIFFERENT WIDTHS'
3283  END IF
3284  ELSE IF (kbds(14).NE.0) THEN
3285 C PRINT *,' SEC BIT MAP'
3286  IF (kbds(16).EQ.0) THEN
3287 C PRINT *,' SECOND ORDER',
3288 C * ' VALUES CONSTANT WIDTH'
3289  ELSE IF (kbds(16).NE.0) THEN
3290 C PRINT *,' SECOND ORDER',
3291 C * ' VALUES DIFFERENT WIDTHS'
3292  END IF
3293  END IF
3294  END IF
3295  END IF
3296  ELSE IF (iand(kptr(14),4).NE.0) THEN
3297 C PRINT *,' WITH COMPLEX/SECOND ORDER PACKING'
3298  IF (iand(kptr(14),1).EQ.0) THEN
3299 C PRINT *,' WITH NO ADDITIONAL FLAGS'
3300  ELSE IF (iand(kptr(14),1).NE.0) THEN
3301 C PRINT *,' WITH ADDITIONAL FLAGS'
3302  IF (kbds(17).EQ.0) THEN
3303 C PRINT *,' SINGLE DATUM AT EACH PT'
3304  IF (kbds(14).EQ.0) THEN
3305 C PRINT *,' NO SEC BIT MAP'
3306  IF (kbds(16).EQ.0) THEN
3307 C PRINT *,' SECOND ORDER',
3308 C * ' VALUES CONSTANT WIDTH'
3309  ELSE IF (kbds(16).NE.0) THEN
3310 C PRINT *,' SECOND ORDER',
3311 C * ' VALUES DIFFERENT WIDTHS'
3312  END IF
3313 C ROW BY ROW - COL BY COL
3314  CALL fi636 (DATA,msga,kbms,
3315  * refnce,kptr,kpds,kgds)
3316  GO TO 900
3317  ELSE IF (kbds(14).NE.0) THEN
3318 C PRINT *,' SEC BIT MAP'
3319  IF (kbds(16).EQ.0) THEN
3320 C PRINT *,' SECOND ORDER',
3321 C * ' VALUES CONSTANT WIDTH'
3322  ELSE IF (kbds(16).NE.0) THEN
3323 C PRINT *,' SECOND ORDER',
3324 C * ' VALUES DIFFERENT WIDTHS'
3325  END IF
3326  CALL fi636 (DATA,msga,kbms,
3327  * refnce,kptr,kpds,kgds)
3328  GO TO 900
3329  END IF
3330  ELSE IF (kbds(17).NE.0) THEN
3331 C PRINT *,' MATRIX OF VALS EACH PT'
3332  IF (kbds(14).EQ.0) THEN
3333 C PRINT *,' NO SEC BIT MAP'
3334  IF (kbds(16).EQ.0) THEN
3335 C PRINT *,' SECOND ORDER',
3336 C * ' VALUES CONSTANT WIDTH'
3337  ELSE IF (kbds(16).NE.0) THEN
3338 C PRINT *,' SECOND ORDER',
3339 C * ' VALUES DIFFERENT WIDTHS'
3340  END IF
3341  ELSE IF (kbds(14).NE.0) THEN
3342 C PRINT *,' SEC BIT MAP'
3343  IF (kbds(16).EQ.0) THEN
3344 C PRINT *,' SECOND ORDER',
3345 C * ' VALUES CONSTANT WIDTH'
3346  ELSE IF (kbds(16).NE.0) THEN
3347 C PRINT *,' SECOND ORDER',
3348 C * ' VALUES DIFFERENT WIDTHS'
3349  END IF
3350  END IF
3351  END IF
3352  END IF
3353  END IF
3354  ELSE IF (iand(kptr(14),8).NE.0) THEN
3355 C PRINT *,'PROCESSING SPHERICAL HARMONIC COEFFICIENTS'
3356  IF (iand(kptr(14),4).EQ.0) THEN
3357 C PRINT *,' WITH SIMPLE PACKING'
3358  IF (iand(kptr(14),1).EQ.0) THEN
3359 C PRINT *,' WITH NO ADDITIONAL FLAGS'
3360  GO TO 5000
3361  ELSE IF (iand(kptr(14),1).NE.0) THEN
3362 C PRINT *,' WITH ADDITIONAL FLAGS'
3363  IF (kbds(17).EQ.0) THEN
3364 C PRINT *,' SINGLE DATUM EACH GRID PT'
3365  IF (kbds(14).EQ.0) THEN
3366 C PRINT *,' NO SEC BIT MAP'
3367  IF (kbds(16).EQ.0) THEN
3368 C PRINT *,' SECOND ORDER',
3369 C * ' VALUES CONSTANT WIDTH'
3370  ELSE IF (kbds(16).NE.0) THEN
3371 C PRINT *,' SECOND ORDER',
3372 C * ' VALUES DIFFERENT WIDTHS'
3373  END IF
3374  ELSE IF (kbds(14).NE.0) THEN
3375 C PRINT *,' SEC BIT MAP'
3376  IF (kbds(16).EQ.0) THEN
3377 C PRINT *,' SECOND ORDER',
3378 C * ' VALUES CONSTANT WIDTH'
3379  ELSE IF (kbds(16).NE.0) THEN
3380 C PRINT *,' SECOND ORDER',
3381 C * ' VALUES DIFFERENT WIDTHS'
3382  END IF
3383  END IF
3384  ELSE IF (kbds(17).NE.0) THEN
3385 C PRINT *,' MATRIX OF VALS EACH PT'
3386  IF (kbds(14).EQ.0) THEN
3387 C PRINT *,' NO SEC BIT MAP'
3388  IF (kbds(16).EQ.0) THEN
3389 C PRINT *,' SECOND ORDER',
3390 C * ' VALUES CONSTANT WIDTH'
3391  ELSE IF (kbds(16).NE.0) THEN
3392 C PRINT *,' SECOND ORDER',
3393 C * ' VALUES DIFFERENT WIDTHS'
3394  END IF
3395  ELSE IF (kbds(14).NE.0) THEN
3396 C PRINT *,' SEC BIT MAP'
3397  IF (kbds(16).EQ.0) THEN
3398 C PRINT *,' SECOND ORDER',
3399 C * ' VALUES CONSTANT WIDTH'
3400  ELSE IF (kbds(16).NE.0) THEN
3401 C PRINT *,' SECOND ORDER',
3402 C * ' VALUES DIFFERENT WIDTHS'
3403  END IF
3404  END IF
3405  END IF
3406  END IF
3407  ELSE IF (iand(kptr(14),4).NE.0) THEN
3408 C COMPLEX/SECOND ORDER PACKING
3409 C PRINT *,' WITH COMPLEX/SECOND ORDER PACKING'
3410  IF (iand(kptr(14),1).EQ.0) THEN
3411 C PRINT *,' WITH NO ADDITIONAL FLAGS'
3412  ELSE IF (iand(kptr(14),1).NE.0) THEN
3413 C PRINT *,' WITH ADDITIONAL FLAGS'
3414  IF (kbds(17).EQ.0) THEN
3415 C PRINT *,' SINGLE DATUM EACH GRID PT'
3416  IF (kbds(14).EQ.0) THEN
3417 C PRINT *,' NO SEC BIT MAP'
3418  IF (kbds(16).EQ.0) THEN
3419 C PRINT *,' SECOND ORDER',
3420 C * ' VALUES CONSTANT WIDTH'
3421  ELSE IF (kbds(16).NE.0) THEN
3422 C PRINT *,' SECOND ORDER',
3423 C * ' VALUES DIFFERENT WIDTHS'
3424  END IF
3425  ELSE IF (kbds(14).NE.0) THEN
3426 C PRINT *,' SEC BIT MAP'
3427  IF (kbds(16).EQ.0) THEN
3428 C PRINT *,' SECOND ORDER',
3429 C * ' VALUES CONSTANT WIDTH'
3430  ELSE IF (kbds(16).NE.0) THEN
3431 C PRINT *,' SECOND ORDER',
3432 C * ' VALUES DIFFERENT WIDTHS'
3433  END IF
3434  END IF
3435  ELSE IF (kbds(17).NE.0) THEN
3436 C PRINT *,' MATRIX OF VALS EACH PT'
3437  IF (kbds(14).EQ.0) THEN
3438 C PRINT *,' NO SEC BIT MAP'
3439  IF (kbds(16).EQ.0) THEN
3440 C PRINT *,' SECOND ORDER',
3441 C * ' VALUES CONSTANT WIDTH'
3442  ELSE IF (kbds(16).NE.0) THEN
3443 C PRINT *,' SECOND ORDER',
3444 C * ' VALUES DIFFERENT WIDTHS'
3445  END IF
3446  ELSE IF (kbds(14).NE.0) THEN
3447 C PRINT *,' SEC BIT MAP'
3448  IF (kbds(16).EQ.0) THEN
3449 C PRINT *,' SECOND ORDER',
3450 C * ' VALUES CONSTANT WIDTH'
3451  ELSE IF (kbds(16).NE.0) THEN
3452 C PRINT *,' SECOND ORDER',
3453 C * ' VALUES DIFFERENT WIDTHS'
3454  END IF
3455  END IF
3456  END IF
3457  END IF
3458  END IF
3459  END IF
3460  IF(ALLOCATED(ksave)) DEALLOCATE(ksave)
3461 C PRINT *,' NOT PROCESSED - NOT PROCESSED - NOT PROCESSED'
3462  kret = 11
3463  RETURN
3464  4000 CONTINUE
3465 C ****************************************************************
3466 C
3467 C GRID POINT DATA, SIMPLE PACKING, FLOATING POINT, NO ADDN'L FLAGS
3468 C
3469  scal10 = 10.0 ** kpds(22)
3470  scal10 = 1.0 / scal10
3471  IF (kpds(3).EQ.23.OR.kpds(3).EQ.24.OR.kpds(3).EQ.26.
3472  * or.kpds(3).EQ.63.OR.kpds(3).EQ.64) THEN
3473  IF (kpds(3).EQ.26) THEN
3474  kadd = 72
3475  ELSE IF (kpds(3).EQ.63.OR.kpds(3).EQ.64) THEN
3476  kadd = 91
3477  ELSE
3478  kadd = 37
3479  END IF
3480  CALL gbytesc (msga,ksave,kptr(8),kbits,0,knr)
3481  kptr(8) = kptr(8) + kbits * knr
3482  ii = 1
3483  kentry = kptr(10)
3484  DO 4001 i = 1, kentry
3485  IF (kbms(i)) THEN
3486  DATA(i) = (refnce+float(ksave(ii))*scale)*scal10
3487  ii = ii + 1
3488  ELSE
3489  DATA(i) = 0.0
3490  END IF
3491  4001 CONTINUE
3492  DO 4002 i = 2, kadd
3493  DATA(i) = DATA(1)
3494  4002 CONTINUE
3495  ELSE IF (kpds(3).EQ.21.OR.kpds(3).EQ.22.OR.kpds(3).EQ.25.
3496  * or.kpds(3).EQ.61.OR.kpds(3).EQ.62) THEN
3497  CALL gbytesc (msga,ksave,kptr(8),kbits,0,knr)
3498  ii = 1
3499  kentry = kptr(10)
3500  DO 4011 i = 1, kentry
3501  IF (kbms(i)) THEN
3502  DATA(i) = (refnce + float(ksave(ii)) * scale) * scal10
3503  ii = ii + 1
3504  ELSE
3505  DATA(i) = 0.0
3506  END IF
3507  4011 CONTINUE
3508  IF (kpds(3).EQ.25) THEN
3509  kadd = 71
3510  ELSE IF (kpds(3).EQ.61.OR.kpds(3).EQ.62) THEN
3511  kadd = 90
3512  ELSE
3513  kadd = 36
3514  END IF
3515  lastp = kentry - kadd
3516  DO 4012 i = lastp+1, kentry
3517  DATA(i) = DATA(lastp)
3518  4012 CONTINUE
3519  ELSE
3520  CALL gbytesc (msga,ksave,kptr(8),kbits,0,knr)
3521  ii = 1
3522  kentry = kptr(10)
3523  DO 500 i = 1, kentry
3524  IF (kbms(i)) THEN
3525  DATA(i) = (refnce + float(ksave(ii)) * scale) * scal10
3526  ii = ii + 1
3527  ELSE
3528  DATA(i) = 0.0
3529  END IF
3530  500 CONTINUE
3531  END IF
3532  GO TO 900
3533 C ------------- PROCESS SPHERICAL HARMONIC COEFFICIENTS,
3534 C SIMPLE PACKING, FLOATING POINT, NO ADDN'L FLAGS
3535  5000 CONTINUE
3536 C PRINT *,'CHECK POINT SPECTRAL COEFF'
3537  kptr(8) = ibyt12
3538 C CALL GBYTE (MSGA,KKK,KPTR(8),32)
3539  call gbytec(msga,jsgn,kptr(8),1)
3540  call gbytec(msga,jexp,kptr(8)+1,7)
3541  call gbytec(msga,ifr,kptr(8)+8,24)
3542  kptr(8) = kptr(8) + 32
3543 C
3544 C THE NEXT CODE WILL CONVERT THE IBM370 FOATING POINT
3545 C TO THE FLOATING POINT USED ON YOUR MACHINE.
3546 C
3547  IF (ifr.EQ.0) THEN
3548  realkk = 0.0
3549  ELSE IF (jexp.EQ.0.AND.ifr.EQ.0) THEN
3550  realkk = 0.0
3551  ELSE
3552  realkk = float(ifr) * 16.0 ** (jexp - 64 - 6)
3553  IF (jsgn.NE.0) realkk = -realkk
3554  END IF
3555  DATA(1) = realkk
3556  CALL gbytesc (msga,ksave,kptr(8),kbits,0,knr)
3557 C --------------
3558  DO 6000 i = 1, kentry
3559  DATA(i+1) = refnce + float(ksave(i)) * scale
3560  6000 CONTINUE
3561  900 CONTINUE
3562  IF(ALLOCATED(ksave)) DEALLOCATE(ksave)
3563 C PRINT *,'EXIT FI635'
3564  RETURN
3565  END
3566 
3567 C> @brief Process second order packing.
3568 C> @author Bill Cavanaugh @date 1992-09-22
3569 
3570 C> Process second order packing from the binary data section
3571 C> (bds) for single data items grid point data.
3572 C>
3573 C> Program history log:
3574 C> - Bill Cavanaugh 1993-06-08
3575 C> - Bill Cavanaugh 1993-12-15 Modified second order pointers to first order
3576 C> values and second order values correctly.
3577 C> - Ralph Jones 1995-04-26 Fi636 corection for 2nd order complex
3578 C> Unpacking.
3579 C> - Mark Iredell 1995-10-31 Saves and prints.
3580 C>
3581 C> @param[in] MSGA Array containing grib message
3582 C> @param[in] REFNCE Reference value
3583 C> @param[in] KPTR Work array
3584 C> @param[out] DATA Location of output array
3585 C> - KBDS Working array
3586 C> - KBDS(1) N1
3587 C> - KBDS(2) N2
3588 C> - KBDS(3) P1
3589 C> - KBDS(4) P2
3590 C> - KBDS(5) Bit pointer to 2nd order widths
3591 C> - KBDS(6) Bit pointer to 2nd order bit maps
3592 C> - KBDS(7) Bit pointer to first order values
3593 C> - KBDS(8) Bit pointer to second order values
3594 C> - KBDS(9) Bit pointer start of bds
3595 C> - KBDS(10) Bit pointer main bit map
3596 C> - KBDS(11) Binary scaling
3597 C> - KBDS(12) Decimal scaling
3598 C> - KBDS(13) Bit width of first order values
3599 C> - KBDS(14) Bit map flag
3600 C> - 0 = No second order bit map
3601 C> - 1 = Second order bit map present
3602 C> - KBDS(15) Second order bit width
3603 C> - KBDS(16) Constant / different widths
3604 C> - 0 = Constant widths
3605 C> - 1 = Different widths
3606 C> - KBDS(17) Single datum / matrix
3607 C> - 0 = Single datum at each grid point
3608 C> - 1 = Matrix of values at each grid point
3609 C> - KBDS(18-20) Unused
3610 C> @param[in] KBMS
3611 C> @param[in] KPDS
3612 C> @param[in] KGDS Array containing gds elements.
3613 C> - 1) Data representation type
3614 C> - 19 Number of vertical coordinate parameters
3615 C> - 20 Octet number of the list of vertical coordinate
3616 C> parameters Or Octet number of the list of numbers of points
3617 C> in each row Or 255 if neither are present.
3618 C> - 21 For grids with pl, number of points in grid
3619 C> - 22 Number of words in each row
3620 C> - Longitude grids
3621 C> - 2) N(i) nr points on latitude circle
3622 C> - 3) N(j) nr points on longitude meridian
3623 C> - 4) La(1) latitude of origin
3624 C> - 5) Lo(1) longitude of origin
3625 C> - 6) Resolution flag
3626 C> - 7) La(2) latitude of extreme point
3627 C> - 8) Lo(2) longitude of extreme point
3628 C> - 9) Di longitudinal direction of increment
3629 C> - 10 Dj latitudinal direction increment
3630 C> - 11 Scanning mode flag
3631 C> - Polar stereographic grids
3632 C> - 2) N(i) nr points along lat circle
3633 C> - 3) N(j) nr points along lon circle
3634 C> - 4) La(1) latitude of origin
3635 C> - 5) Lo(1) longitude of origin
3636 C> - 6) Reserved
3637 C> - 7) Lov grid orientation
3638 C> - 8) Dx - x direction increment
3639 C> - 9) Dy - y direction increment
3640 C> - 10 Projection center flag
3641 C> - 11 Scanning mode
3642 C> - Spherical harmonic coefficients
3643 C> - 2 J pentagonal resolution parameter
3644 C> - 3 K pentagonal resolution parameter
3645 C> - 4 M pentagonal resolution parameter
3646 C> - 5 Representation type
3647 C> - 6 Coefficient storage mode
3648 C> - Mercator grids
3649 C> - 2 N(i) nr points on latitude circle
3650 C> - 3 N(j) nr points on longitude meridian
3651 C> - 4 La(1) latitude of origin
3652 C> - 5 Lo(1) longitude of origin
3653 C> - 6 Resolution flag
3654 C> - 7 La(2) latitude of last grid point
3655 C> - 8 Lo(2) longitude of last grid point
3656 C> - 9 Latin - latitude of projection intersection
3657 C> - 10 Reserved
3658 C> - 11 Scanning mode flag
3659 C> - 12 Longitudinal dir grid length
3660 C> - 13 Latitudinal dir grid length
3661 C> - Lambert conformal grids
3662 C> - 2 Nx nr points along x-axis
3663 C> - 3 Ny nr points along y-axis
3664 C> - 4 La1 lat of origin (lower left)
3665 C> - 5 Lo1 lon of origin (lower left)
3666 C> - 6 Resolution (right adj copy of octet 17)
3667 C> - 7 Lov - orientation of grid
3668 C> - 8 Dx - x-dir increment
3669 C> - 9 Dy - y-dir increment
3670 C> - 10 Projection center flag
3671 C> - 11 Scanning mode flag
3672 C> - 12 Latin 1 - first lat from pole of secant cone inter
3673 C> - 13 Latin 2 - second lat from pole of secant cone inter
3674 C> - Staggered arakawa rotated lat/lon grids (203 e stagger)
3675 C> - 2 N(i) nr points on rotated latitude circle
3676 C> - 3 N(j) nr points on rotated longitude meridian
3677 C> - 4 La(1) latitude of origin
3678 C> - 5 Lo(1) longitude of origin
3679 C> - 6 Resolution flag
3680 C> - 7 La(2) latitude of center
3681 C> - 8 Lo(2) longitude of center
3682 C> - 9 Di longitudinal direction of increment
3683 C> - 10 Dj latitudinal direction increment
3684 C> - 11 Scanning mode flag
3685 C> - Staggered arakawa rotated lat/lon grids (205 a,b,c,d staggers)
3686 C> - 2 N(i) nr points on rotated latitude circle
3687 C> - 3 N(j) nr points on rotated longitude meridian
3688 C> - 4 La(1) latitude of origin
3689 C> - 5 Lo(1) longitude of origin
3690 C> - 6 Resolution flag
3691 C> - 7 La(2) latitude of center
3692 C> - 8 Lo(2) longitude of center
3693 C> - 9 Di longitudinal direction of increment
3694 C> - 10 Dj latitudinal direction increment
3695 C> - 11 Scanning mode flag
3696 C> - 12 Latitude of last point
3697 C> - 13 Longitude of last point
3698 C>
3699 C> @author Bill Cavanaugh @date 1992-09-22
3700  SUBROUTINE fi636 (DATA,MSGA,KBMS,REFNCE,KPTR,KPDS,KGDS)
3701 
3702  REAL DATA(*)
3703  REAL REFN
3704  REAL REFNCE
3705 C
3706  INTEGER KBDS(20)
3707  INTEGER KPTR(*)
3708  character(len=1) BMAP2(1000000)
3709  INTEGER I,IBDS
3710  INTEGER KBIT,IFOVAL,ISOVAL
3711  INTEGER KPDS(*),KGDS(*)
3712 C
3713  LOGICAL*1 KBMS(*)
3714 C
3715  CHARACTER*1 MSGA(*)
3716 C
3717 C ******************* SETUP ******************************
3718 C PRINT *,'ENTER FI636'
3719 C START OF BMS (BIT POINTER)
3720  DO i = 1,20
3721  kbds(i) = 0
3722  END DO
3723 C BYTE START OF BDS
3724  ibds = kptr(2) + kptr(3) + kptr(4) + kptr(5)
3725 C PRINT *,'KPTR(2-5) ',KPTR(2),KPTR(3),KPTR(4),KPTR(5)
3726 C BIT START OF BDS
3727  jptr = ibds * 8
3728 C PRINT *,'JPTR ',JPTR
3729  kbds(9) = jptr
3730 C PRINT *,'START OF BDS ',KBDS(9)
3731 C BINARY SCALE VALUE BDS BYTES 5-6
3732  CALL gbytec (msga,isign,jptr+32,1)
3733  CALL gbytec (msga,kbds(11),jptr+33,15)
3734  IF (isign.GT.0) THEN
3735  kbds(11) = - kbds(11)
3736  END IF
3737 C PRINT *,'BINARY SCALE VALUE =',KBDS(11)
3738 C EXTRACT REFERENCE VALUE
3739 C CALL GBYTEC(MSGA,JREF,JPTR+48,32)
3740  call gbytec(msga,jsgn,kptr(8),1)
3741  call gbytec(msga,jexp,kptr(8)+1,7)
3742  call gbytec(msga,ifr,kptr(8)+8,24)
3743  IF (ifr.EQ.0) THEN
3744  refnce = 0.0
3745  ELSE IF (jexp.EQ.0.AND.ifr.EQ.0) THEN
3746  refnce = 0.0
3747  ELSE
3748  refnce = float(ifr) * 16.0 ** (jexp - 64 - 6)
3749  IF (jsgn.NE.0) refnce = - refnce
3750  END IF
3751 C PRINT *,'DECODED REFERENCE VALUE =',REFN,REFNCE
3752 C F O BIT WIDTH
3753  CALL gbytec(msga,kbds(13),jptr+80,8)
3754  jptr = jptr + 88
3755 C AT START OF BDS BYTE 12
3756 C EXTRACT N1
3757  CALL gbytec (msga,kbds(1),jptr,16)
3758 C PRINT *,'N1 = ',KBDS(1)
3759  jptr = jptr + 16
3760 C EXTENDED FLAGS
3761  CALL gbytec (msga,kflag,jptr,8)
3762 C ISOLATE BIT MAP FLAG
3763  IF (iand(kflag,32).NE.0) THEN
3764  kbds(14) = 1
3765  ELSE
3766  kbds(14) = 0
3767  END IF
3768  IF (iand(kflag,16).NE.0) THEN
3769  kbds(16) = 1
3770  ELSE
3771  kbds(16) = 0
3772  END IF
3773  IF (iand(kflag,64).NE.0) THEN
3774  kbds(17) = 1
3775  ELSE
3776  kbds(17) = 0
3777  END IF
3778  jptr = jptr + 8
3779 C EXTRACT N2
3780  CALL gbytec (msga,kbds(2),jptr,16)
3781 C PRINT *,'N2 = ',KBDS(2)
3782  jptr = jptr + 16
3783 C EXTRACT P1
3784  CALL gbytec (msga,kbds(3),jptr,16)
3785 C PRINT *,'P1 = ',KBDS(3)
3786  jptr = jptr + 16
3787 C EXTRACT P2
3788  CALL gbytec (msga,kbds(4),jptr,16)
3789 C PRINT *,'P2 = ',KBDS(4)
3790  jptr = jptr + 16
3791 C SKIP RESERVED BYTE
3792  jptr = jptr + 8
3793 C START OF SECOND ORDER BIT WIDTHS
3794  kbds(5) = jptr
3795 C COMPUTE START OF SECONDARY BIT MAP
3796  IF (kbds(14).NE.0) THEN
3797 C FOR INCLUDED SECONDARY BIT MAP
3798  jptr = jptr + (kbds(3) * 8)
3799  kbds(6) = jptr
3800  ELSE
3801 C FOR CONSTRUCTED SECONDARY BIT MAP
3802  kbds(6) = 0
3803  END IF
3804 C CREATE POINTER TO START OF FIRST ORDER VALUES
3805  kbds(7) = kbds(9) + kbds(1) * 8 - 8
3806 C PRINT *,'BIT POINTER TO START OF FOVALS',KBDS(7)
3807 C CREATE POINTER TO START OF SECOND ORDER VALUES
3808  kbds(8) = kbds(9) + kbds(2) * 8 - 8
3809 C PRINT *,'BIT POINTER TO START OF SOVALS',KBDS(8)
3810 C PRINT *,'KBDS( 1) - N1 ',KBDS( 1)
3811 C PRINT *,'KBDS( 2) - N2 ',KBDS( 2)
3812 C PRINT *,'KBDS( 3) - P1 ',KBDS( 3)
3813 C PRINT *,'KBDS( 4) - P2 ',KBDS( 4)
3814 C PRINT *,'KBDS( 5) - BIT PTR - 2ND ORDER WIDTHS ',KBDS( 5)
3815 C PRINT *,'KBDS( 6) - " " " " BIT MAPS ',KBDS( 6)
3816 C PRINT *,'KBDS( 7) - " " F O VALS ',KBDS( 7)
3817 C PRINT *,'KBDS( 8) - " " S O VALS ',KBDS( 8)
3818 C PRINT *,'KBDS( 9) - " " START OF BDS ',KBDS( 9)
3819 C PRINT *,'KBDS(10) - " " MAIN BIT MAP ',KBDS(10)
3820 C PRINT *,'KBDS(11) - BINARY SCALING ',KBDS(11)
3821 C PRINT *,'KPDS(22) - DECIMAL SCALING ',KPDS(22)
3822 C PRINT *,'KBDS(13) - FO BIT WIDTH ',KBDS(13)
3823 C PRINT *,'KBDS(14) - 2ND ORDER BIT MAP FLAG ',KBDS(14)
3824 C PRINT *,'KBDS(15) - 2ND ORDER BIT WIDTH ',KBDS(15)
3825 C PRINT *,'KBDS(16) - CONSTANT/DIFFERENT WIDTHS ',KBDS(16)
3826 C PRINT *,'KBDS(17) - SINGLE DATUM/MATRIX ',KBDS(17)
3827 C PRINT *,'REFNCE VAL ',REFNCE
3828 C ************************* PROCESS DATA **********************
3829  ij = 0
3830 C ========================================================
3831  IF (kbds(14).EQ.0) THEN
3832 C NO BIT MAP, MUST CONSTRUCT ONE
3833  IF (kgds(2).EQ.65535) THEN
3834  IF (kgds(20).EQ.255) THEN
3835 C PRINT *,'CANNOT BE USED HERE'
3836  ELSE
3837 C POINT TO PL
3838  lp = kptr(9) + kptr(2)*8 + kptr(3)*8 + kgds(20)*8 - 8
3839 C PRINT *,'LP = ',LP
3840  jt = 0
3841  DO 2000 jz = 1, kgds(3)
3842 C GET NUMBER IN CURRENT ROW
3843  CALL gbytec (msga,number,lp,16)
3844 C INCREMENT TO NEXT ROW NUMBER
3845  lp = lp + 16
3846 C PRINT *,'NUMBER IN ROW',JZ,' = ',NUMBER
3847  DO 1500 jq = 1, number
3848  IF (jq.EQ.1) THEN
3849  CALL sbytec (bmap2,1,jt,1)
3850  ELSE
3851  CALL sbytec (bmap2,0,jt,1)
3852  END IF
3853  jt = jt + 1
3854  1500 CONTINUE
3855  2000 CONTINUE
3856  END IF
3857  ELSE
3858  IF (iand(kgds(11),32).EQ.0) THEN
3859 C ROW BY ROW
3860 C PRINT *,' ROW BY ROW'
3861  kout = kgds(3)
3862  kin = kgds(2)
3863  ELSE
3864 C COL BY COL
3865 C PRINT *,' COL BY COL'
3866  kin = kgds(3)
3867  kout = kgds(2)
3868  END IF
3869 C PRINT *,'KIN=',KIN,' KOUT= ',KOUT
3870  DO 200 i = 1, kout
3871  DO 150 j = 1, kin
3872  IF (j.EQ.1) THEN
3873  CALL sbytec (bmap2,1,ij,1)
3874  ELSE
3875  CALL sbytec (bmap2,0,ij,1)
3876  END IF
3877  ij = ij + 1
3878  150 CONTINUE
3879  200 CONTINUE
3880  END IF
3881  END IF
3882 C ========================================================
3883 C PRINT 99,(BMAP2(J),J=1,110)
3884 C99 FORMAT ( 10(1X,Z8.8))
3885 C CALL BINARY (BMAP2,2)
3886 C FOR EACH GRID POINT ENTRY
3887 C
3888  scale2 = 2.0**kbds(11)
3889  scal10 = 10.0**kpds(22)
3890 C PRINT *,'SCALE VALUES - ',SCALE2,SCAL10
3891  DO 1000 i = 1, kptr(10)
3892 C GET NEXT MASTER BIT MAP BIT POSITION
3893 C IF NEXT MASTER BIT MAP BIT POSITION IS 'ON' (1)
3894  IF (kbms(i)) THEN
3895 C WRITE(6,900)I,KBMS(I)
3896 C 900 FORMAT (1X,I4,3X,14HMAIN BIT IS ON,3X,L4)
3897  IF (kbds(14).NE.0) THEN
3898  CALL gbytec (msga,kbit,kbds(6),1)
3899  ELSE
3900  CALL gbytec (bmap2,kbit,kbds(6),1)
3901  END IF
3902 C PRINT *,'KBDS(6) =',KBDS(6),' KBIT =',KBIT
3903  kbds(6) = kbds(6) + 1
3904  IF (kbit.NE.0) THEN
3905 C PRINT *,' SOB ON'
3906 C GET NEXT FIRST ORDER PACKED VALUE
3907  CALL gbytec (msga,ifoval,kbds(7),kbds(13))
3908  kbds(7) = kbds(7) + kbds(13)
3909 C PRINT *,'FOVAL =',IFOVAL
3910 C GET SECOND ORDER BIT WIDTH
3911  CALL gbytec (msga,kbds(15),kbds(5),8)
3912  kbds(5) = kbds(5) + 8
3913 C PRINT *,KBDS(7)-KBDS(13),' FOVAL =',IFOVAL,' KBDS(5)=',
3914 C * ,KBDS(5), 'ISOWID =',KBDS(15)
3915  ELSE
3916 C PRINT *,' SOB NOT ON'
3917  END IF
3918  isoval = 0
3919  IF (kbds(15).EQ.0) THEN
3920 C IF SECOND ORDER BIT WIDTH = 0
3921 C THEN SECOND ORDER VALUE IS 0
3922 C SO CALCULATE DATA VALUE FOR THIS POINT
3923 C DATA(I) = (REFNCE + (FLOAT(IFOVAL) * SCALE2)) / SCAL10
3924  ELSE
3925  CALL gbytec (msga,isoval,kbds(8),kbds(15))
3926  kbds(8) = kbds(8) + kbds(15)
3927  END IF
3928  DATA(i) = (refnce + (float(ifoval + isoval) *
3929  * scale2)) / scal10
3930 C PRINT *,I,DATA(I),REFNCE,IFOVAL,ISOVAL,SCALE2,SCAL10
3931  ELSE
3932 C WRITE(6,901) I,KBMS(I)
3933 C 901 FORMAT (1X,I4,3X,15HMAIN BIT NOT ON,3X,L4)
3934  DATA(i) = 0.0
3935  END IF
3936 C PRINT *,I,DATA(I),IFOVAL,ISOVAL,KBDS(5),KBDS(15)
3937  1000 CONTINUE
3938 C **************************************************************
3939 C PRINT *,'EXIT FI636'
3940  RETURN
3941  END
3942 
3943 C> @brief Grib grid/size test.
3944 C> @author Bill Cavanaugh @date 1991-09-13
3945 
3946 C> To test when gds is available to see if size mismatch
3947 C> on existing grids (by center) is indicated.
3948 C>
3949 C> Program history log:
3950 C> - Bill Cavanaugh 1991-09-13
3951 C> - Mark Iredell 1995-10-31 Removed saves and prints
3952 C> - M. Bostelman 1997-02-12 Corrects ecmwf us grid 2 processing
3953 C> - Mark Iredell 1998-06-17 Removed alternate return
3954 C> - M. Baldwin 1999-01-20 Modify to handle grid 237
3955 C> - Boi Vuong 1909-05-21 Modify to handle grid 45
3956 C>
3957 C> @param[inout] J Size for indicated grid modified for ecmwf-us 2
3958 C> @param[in] KPDS
3959 C> @param[in] KGDS
3960 C> @param[out] KRET Error return (a mismatch was detected if kret is not zero)
3961 C>
3962 C> @note
3963 C> - KRET:
3964 C> - 9 - Gds indicates size mismatch with std grid
3965 C>
3966 C> @author Bill Cavanaugh @date 1991-09-13
3967  SUBROUTINE fi637(J,KPDS,KGDS,KRET)
3968 
3969  INTEGER KPDS(*)
3970  INTEGER KGDS(*)
3971  INTEGER J
3972  INTEGER I
3973 C ---------------------------------------
3974 C ---------------------------------------
3975 C IF GDS NOT INDICATED, RETURN
3976 C ----------------------------------------
3977  kret=0
3978  IF (iand(kpds(4),128).EQ.0) RETURN
3979 C ---------------------------------------
3980 C GDS IS INDICATED, PROCEED WITH TESTING
3981 C ---------------------------------------
3982  IF (kgds(2).EQ.65535) THEN
3983  RETURN
3984  END IF
3985  kret=1
3986  i = kgds(2) * kgds(3)
3987 C ---------------------------------------
3988 C INTERNATIONAL SET
3989 C ---------------------------------------
3990  IF (kpds(3).GE.21.AND.kpds(3).LE.26) THEN
3991  IF (i.NE.j) THEN
3992  RETURN
3993  END IF
3994  ELSE IF (kpds(3).GE.37.AND.kpds(3).LE.44) THEN
3995  IF (i.NE.j) THEN
3996  RETURN
3997  END IF
3998  ELSE IF (kpds(3).EQ.50) THEN
3999  IF (i.NE.j) THEN
4000  RETURN
4001  END IF
4002  ELSE IF (kpds(3).GE.61.AND.kpds(3).LE.64) THEN
4003  IF (i.NE.j) THEN
4004  RETURN
4005  END IF
4006 C ---------------------------------------
4007 C TEST ECMWF CONTENT
4008 C ---------------------------------------
4009  ELSE IF (kpds(1).EQ.98) THEN
4010  kret = 9
4011  IF (kpds(3).GE.1.AND.kpds(3).LE.16) THEN
4012  IF (i.NE.j) THEN
4013  IF (kpds(3) .NE. 2) THEN
4014  RETURN
4015  ELSEIF (i .NE. 10512) THEN ! Test for US Grid 2
4016  RETURN
4017  END IF
4018  j = i ! Set to US Grid 2, 2.5 Global
4019  END IF
4020  ELSE
4021  kret = 5
4022  RETURN
4023  END IF
4024 C ---------------------------------------
4025 C U.K. MET OFFICE, BRACKNELL
4026 C ---------------------------------------
4027  ELSE IF (kpds(1).EQ.74) THEN
4028  kret = 9
4029  IF (kpds(3).GE.25.AND.kpds(3).LE.26) THEN
4030  IF (i.NE.j) THEN
4031  RETURN
4032  END IF
4033  ELSE
4034  kret = 5
4035  RETURN
4036  END IF
4037 C ---------------------------------------
4038 C CANADA
4039 C ---------------------------------------
4040  ELSE IF (kpds(1).EQ.54) THEN
4041 C PRINT *,' NO CURRENT LISTING OF CANADIAN GRIDS'
4042  RETURN
4043 C ---------------------------------------
4044 C JAPAN METEOROLOGICAL AGENCY
4045 C ---------------------------------------
4046  ELSE IF (kpds(1).EQ.34) THEN
4047 C PRINT *,' NO CURRENT LISTING OF JMA GRIDS'
4048  RETURN
4049 C ---------------------------------------
4050 C NAVY - FNOC
4051 C ---------------------------------------
4052  ELSE IF (kpds(1).EQ.58) THEN
4053  IF (kpds(3).GE.37.AND.kpds(3).LE.44) THEN
4054  IF (i.NE.j) THEN
4055  RETURN
4056  END IF
4057  ELSE IF (kpds(3).GE.220.AND.kpds(3).LE.221) THEN
4058  IF (i.NE.j) THEN
4059  RETURN
4060  END IF
4061  ELSE IF (kpds(3).EQ.223) THEN
4062  IF (i.NE.j) THEN
4063  RETURN
4064  END IF
4065  ELSE
4066  kret = 5
4067  RETURN
4068  END IF
4069 C ---------------------------------------
4070 C U.S. GRIDS
4071 C ---------------------------------------
4072  ELSE IF (kpds(1).EQ.7) THEN
4073  kret = 9
4074  IF (kpds(3).GE.1.AND.kpds(3).LE.6) THEN
4075  IF (i.NE.j) THEN
4076  RETURN
4077  END IF
4078  ELSE IF (kpds(3).EQ.8) THEN
4079  IF (i.NE.j) THEN
4080  RETURN
4081  END IF
4082  ELSE IF (kpds(3).EQ.10) THEN
4083  IF (i.NE.j) THEN
4084  RETURN
4085  END IF
4086  ELSE IF (kpds(3).GE.11.AND.kpds(3).LE.18) THEN
4087  IF (i.NE.j) THEN
4088  RETURN
4089  END IF
4090  ELSE IF (kpds(3).GE.27.AND.kpds(3).LE.30) THEN
4091  IF (i.NE.j) THEN
4092  RETURN
4093  END IF
4094  ELSE IF (kpds(3).GE.33.AND.kpds(3).LE.34) THEN
4095  IF (i.NE.j) THEN
4096  RETURN
4097  END IF
4098  ELSE IF (kpds(3).GE.37.AND.kpds(3).LE.45) THEN
4099  IF (i.NE.j) THEN
4100  RETURN
4101  END IF
4102  ELSE IF (kpds(3).EQ.53) THEN
4103  IF (i.NE.j) THEN
4104  RETURN
4105  END IF
4106  ELSE IF (kpds(3).GE.55.AND.kpds(3).LE.56) THEN
4107  IF (i.NE.j) THEN
4108  RETURN
4109  END IF
4110  ELSE IF (kpds(3).GE.67.AND.kpds(3).LE.77) THEN
4111  IF (i.NE.j) THEN
4112  RETURN
4113  END IF
4114  ELSE IF (kpds(3).GE.85.AND.kpds(3).LE.88) THEN
4115  IF (i.NE.j) THEN
4116  RETURN
4117  END IF
4118  ELSE IF (kpds(3).GE.90.AND.kpds(3).LE.99) THEN
4119  IF (i.NE.j) THEN
4120  RETURN
4121  END IF
4122  ELSE IF (kpds(3).EQ.100.OR.kpds(3).EQ.101) THEN
4123  IF (i.NE.j) THEN
4124  RETURN
4125  END IF
4126  ELSE IF (kpds(3).GE.103.AND.kpds(3).LE.107) THEN
4127  IF (i.NE.j) THEN
4128  RETURN
4129  END IF
4130  ELSE IF (kpds(3).EQ.110) THEN
4131  IF (i.NE.j) THEN
4132  RETURN
4133  END IF
4134  ELSE IF (kpds(3).EQ.120) THEN
4135  IF (i.NE.j) THEN
4136  RETURN
4137  END IF
4138  ELSE IF (kpds(3).GE.122.AND.kpds(3).LE.130) THEN
4139  IF (i.NE.j) THEN
4140  RETURN
4141  END IF
4142  ELSE IF (kpds(3).EQ.132) THEN
4143  IF (i.NE.j) THEN
4144  RETURN
4145  END IF
4146  ELSE IF (kpds(3).EQ.138) THEN
4147  IF (i.NE.j) THEN
4148  RETURN
4149  END IF
4150  ELSE IF (kpds(3).EQ.139) THEN
4151  IF (i.NE.j) THEN
4152  RETURN
4153  END IF
4154  ELSE IF (kpds(3).EQ.140) THEN
4155  IF (i.NE.j) THEN
4156  RETURN
4157  END IF
4158  ELSE IF (kpds(3).GE.145.AND.kpds(3).LE.148) THEN
4159  IF (i.NE.j) THEN
4160  RETURN
4161  END IF
4162  ELSE IF (kpds(3).EQ.150.OR.kpds(3).EQ.151) THEN
4163  IF (i.NE.j) THEN
4164  RETURN
4165  END IF
4166  ELSE IF (kpds(3).EQ.160.OR.kpds(3).EQ.161) THEN
4167  IF (i.NE.j) THEN
4168  RETURN
4169  END IF
4170  ELSE IF (kpds(3).EQ.163) THEN
4171  IF (i.NE.j) THEN
4172  RETURN
4173  END IF
4174  ELSE IF (kpds(3).GE.170.AND.kpds(3).LE.176) THEN
4175  IF (i.NE.j) THEN
4176  RETURN
4177  END IF
4178  ELSE IF (kpds(3).GE.179.AND.kpds(3).LE.184) THEN
4179  IF (i.NE.j) THEN
4180  RETURN
4181  END IF
4182  ELSE IF (kpds(3).EQ.187) THEN
4183  IF (i.NE.j) THEN
4184  RETURN
4185  END IF
4186  ELSE IF (kpds(3).EQ.188) THEN
4187  IF (i.NE.j) THEN
4188  RETURN
4189  END IF
4190  ELSE IF (kpds(3).EQ.189) THEN
4191  IF (i.NE.j) THEN
4192  RETURN
4193  END IF
4194  ELSE IF (kpds(3).EQ.190.OR.kpds(3).EQ.192) THEN
4195  IF (i.NE.j) THEN
4196  RETURN
4197  END IF
4198  ELSE IF (kpds(3).GE.193.AND.kpds(3).LE.199) THEN
4199  IF (i.NE.j) THEN
4200  RETURN
4201  END IF
4202  ELSE IF (kpds(3).GE.200.AND.kpds(3).LE.254) THEN
4203  IF (i.NE.j) THEN
4204  RETURN
4205  END IF
4206  ELSE
4207  kret = 5
4208  RETURN
4209  END IF
4210  ELSE
4211  kret = 10
4212  RETURN
4213  END IF
4214 C ------------------------------------
4215 C NORMAL EXIT
4216 C ------------------------------------
4217  kret = 0
4218  RETURN
4219  END
gbytesc
subroutine gbytesc(IN, IOUT, ISKIP, NBYTE, NSKIP, N)
Extract arbitrary size values from a packed bit string, right justifying each value in the unpacked a...
Definition: gbytesc.f:16
fi632
subroutine fi632(MSGA, KPTR, KPDS, KRET)
Gather info from product definition sec.
Definition: w3fi63.f:1005
fi634
subroutine fi634(MSGA, KPTR, KPDS, KGDS, KBMS, KRET)
Extract or generate bit map for output.
Definition: w3fi63.f:1897
fi637
subroutine fi637(J, KPDS, KGDS, KRET)
Grib grid/size test.
Definition: w3fi63.f:3968
fi631
subroutine fi631(MSGA, KPTR, KPDS, KRET)
Find 'grib' chars & reset pointers.
Definition: w3fi63.f:848
gbytec
subroutine gbytec(IN, IOUT, ISKIP, NBYTE)
Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
Definition: gbytec.f:14
w3fi83
subroutine w3fi83(DATA, NPTS, FVAL1, FDIFF1, ISCAL2, ISC10, KPDS, KGDS)
Restore delta packed data to original values restore from boustrephedonic alignment.
Definition: w3fi83.f:33
fi634x
subroutine fi634x(NPTS, NSKP, MSGA, KBMS)
Extract bit map.
Definition: w3fi63.f:2882
fi635
subroutine fi635(MSGA, KPTR, KPDS, KGDS, KBMS, DATA, KRET)
Extract grib data elements from bds.
Definition: w3fi63.f:3056
w3fi63
subroutine w3fi63(MSGA, KPDS, KGDS, KBMS, DATA, KPTR, KRET)
Unpack a grib (edition 1) field to the exact grid specified in the grib message, isolate the bit map,...
Definition: w3fi63.f:347
fi633
subroutine fi633(MSGA, KPTR, KGDS, KRET)
Extract info from grib-gds.
Definition: w3fi63.f:1351
fi636
subroutine fi636(DATA, MSGA, KBMS, REFNCE, KPTR, KPDS, KGDS)
Process second order packing.
Definition: w3fi63.f:3701
sbytec
subroutine sbytec(OUT, IN, ISKIP, NBYTE)
This is a wrapper for sbytesc()
Definition: sbytec.f:14
w3fi01
subroutine w3fi01(LW)
Determines the number of bytes in a full word for the particular machine (IBM or cray).
Definition: w3fi01.f:19