NCEPLIBS-w3emc  2.11.0
w3ai08.f
Go to the documentation of this file.
1 C> @file
2 C> @brief Unpack grib field to grib grid.
3 C> @author Bill Cavanaugh @date 1988-01-20
4 
5 C> Unpack a grib field to the exact grid specified in the
6 C> message, isolate the bit map and make the values of the product
7 C> description sec (pds) and the grid description sec (gds)
8 C> available in return arrays.
9 C>
10 C> Program history log:
11 C> - Bill Cavanaugh 1988-01-20
12 C> - Bill Cavanaugh 1990-05-11 To assure that all u.s. grids in the grib decoder
13 C> comply with size changes in the december 1989 revisions.
14 C> - Bill Cavanaugh 1990-05-24 Corrects searching an improper location for grib
15 c> version number in grib messages.
16 C> - William Bostelman 1990-07-15 Modiifed sub. ai084 so that it will test
17 C> the grib bds byte size to determine what ecmwf grid array size is
18 C> to be specified.
19 C> - Ralph Jones 1990-09-14 Change's for ansi fortran, and pds version 1.
20 C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
21 C> - Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
22 C> - Boi Vuong 2002-10-15 Replaced function ichar with mova2i.
23 C>
24 C> @param[in] msga grib field - "grib" thru "7777" char*1
25 C> @param[out] data array containing data elements
26 C> @note (version 0):
27 C> - 1: id of center
28 C> - 2: model identification
29 C> - 3: grid identification
30 C> - 4: gds/bms flag
31 C> - 5: indicator of parameter
32 C> - 6: type of level
33 C> - 7: height/pressure , etc of level
34 C> - 8: year including century
35 C> - 9: month of year
36 C> - 10: day of month
37 C> - 11: hour of day
38 C> - 12: minute of hour
39 C> - 13: indicator of forecast time unit
40 C> - 14: time range 1
41 C> - 15: time range 2
42 C> - 16: time range flag
43 C> - 17: number included in average
44 C> - 18: grib specification edition number
45 C> @param[out] kpds array containing pds elements. (version 1)
46 C> - 1: id of center
47 C> - 2: model identification
48 C> - 3: grid identification
49 C> - 4: gds/bms flag
50 C> - 5: indicator of parameter
51 C> - 6: type of level
52 C> - 7: height/pressure , etc of level
53 C> - 8: year including century
54 C> - 9: month of year
55 C> - 10: day of month
56 C> - 11: hour of day
57 C> - 12: minute of hour
58 C> - 13: indicator of forecast time unit
59 C> - 14: time range 1
60 C> - 15: time range 2
61 C> - 16: time range flag
62 C> - 17: number included in average
63 C> - 18: version nr of grib specification
64 C> - 19: version nr of parameter table
65 C> - 20: total length of grib message (including section 0)
66 C> @param[out] kgds array containing gds elements.
67 C> - 1: data representation type
68 C> - Latitude/longitude grids
69 C> - 2: n(i) nr points on latitude circle
70 C> - 3: n(j) nr points on longitude meridian
71 C> - 4: la(1) latitude of origin
72 C> - 5: lo(1) longitude of origin
73 C> - 6: resolution flag
74 C> - 7: la(2) latitude of extreme point
75 C> - 8: lo(2) longitude of extreme point
76 C> - 9: di longitudinal direction of increment
77 C> - 10: dj latitundinal direction of increment
78 C> - 11: scanning mode flag
79 C> - Polar stereographic grids
80 C> - 2: n(i) nr points along lat circle
81 C> - 3: n(j) nr points along lon circle
82 C> - 4: la(1) latitude of origin
83 C> - 5: lo(1) longitude of origin
84 C> - 6: reserved
85 C> - 7: lov grid orientation
86 C> - 8: dx - x direction increment
87 C> - 9: dy - y direction increment
88 C> - 10: projection center flag
89 C> - 11: scanning mode
90 C> - Spherical harmonic coefficients
91 C> - 2: j pentagonal resolution parameter
92 C> - 3: k pentagonal resolution parameter
93 C> - 4: m pentagonal resolution parameter
94 C> - 5: representation type
95 C> - 6: coefficient storage mode
96 C> - Mercator grids
97 C> - 2: n(i) nr points on latitude circle
98 C> - 3: n(j) nr points on longitude meridian
99 C> - 4: la(1) latitude of origin
100 C> - 5: lo(1) longitude of origin
101 C> - 6: resolution flag
102 C> - 7: la(2) latitude of last grid point
103 C> - 8: lo(2) longitude of last grid point
104 C> - 9: longit dir increment
105 C> - 10: latit dir increment
106 C> - 11: scanning mode flag
107 C> - 12: latitude intersection
108 C> - Lambert conformal grids
109 C> - 2: nx nr points along x-axis
110 C> - 3: ny nr points along y-axis
111 C> - 4: la1 lat of origin (lower left)
112 C> - 5: lo1 lon of origin (lower left)
113 C> - 6: reserved
114 C> - 7: lov - orientation of grid
115 C> - 8: dx - x-dir increment
116 C> - 9: dy - y-dir increment
117 C> - 10: projection center flag
118 C> - 11: scanning mode flag
119 C> - 12: latin 1 - first lat from pole of secant cone inter
120 C> - 13: latin 2 - second lat from pole of secant cone inter
121 C> @param[out] kbms - bitmap describing location of output elements.
122 C> @param[out] kptr - array containing storage for following parameters
123 C> - 1: unused
124 C> - 2: unused
125 C> - 3: length of pds
126 C> - 4: length of gds
127 C> - 5: length of bms
128 C> - 6: length of bds
129 C> - 7: value of current byte
130 C> - 8: unused
131 C> - 9: grib start byte nr
132 C> - 10: grib/grid element count
133 C> @param[out] kret flag indicating quality of completion
134 C>
135 C> @note values for return flag (kret)
136 C> - kret = 0 - normal return, no errors
137 C> - = 1 - 'grib' not found in first 100 chars
138 C> - = 2 - '7777' not in correct location
139 C> - = 3 - unpacked field is larger than 32768
140 C> - = 4 - gds/ grid not one of currently accepted values
141 C> - = 5 - grid not currently avail for center indicated
142 C> - = 8 - temp gds indicated, but gds flag is off
143 C> - = 9 - gds indicates size mismatch with std grid
144 C> - = 10 - incorrect center indicator
145 C>
146 C> @author Bill Cavanaugh @date 1988-01-20
147  SUBROUTINE w3ai08(MSGA,KPDS,KGDS,KBMS,DATA,KPTR,KRET)
148 C 4 AUG 1988
149 C W3AI08
150 C
151 C
152 C GRIB UNPACKING ROUTINE
153 C
154 C
155 C THIS ROUTINE WILL UNPACK A 'GRIB' FIELD TO THE EXACT GRID
156 C TYPE SPECIFIED IN THE MESSAGE, RETURN A BIT MAP AND MAKE THE
157 C VALUES OF THE PRODUCT DEFINITION SEC (PDS) AND THE GRID
158 C DESCRIPTION SEC (GDS) AVAILABLE IN RETURN ARRAYS.
159 C SEE "GRIB - THE WMO FORMAT FOR THE STORAGE OF WEATHER PRODUCT
160 C INFORMATION AND THE EXCHANGE OF WEATHER PRODUCT MESSAGES IN
161 C GRIDDED BINARY FORM" DATED JULY 1, 1988 BY JOHN D. STACKPOLE
162 C DOC, NOAA, NWS, NATIONAL METEOROLOGICAL CENTER.
163 C
164 C THE CALL TO THE GRIB UNPACKING ROUTINE IS AS FOLLOWS:
165 C
166 C CALL W3AI08(MSGA,KPDS,KGDS,LBMS,DATA,KPTR,KRET)
167 C
168 C INPUT:
169 C
170 C MSGA = CONTAINS THE GRIB MESSAGE TO BE UNPACKED. CHARACTERS
171 C "GRIB" MAY BEGIN ANYWHERE WITHIN FIRST 100 BYTES.
172 C
173 C OUTPUT:
174 C
175 C KPDS(100) INTEGER
176 C ARRAY TO CONTAIN THE ELEMENTS OF THE PRODUCT
177 C DEFINITION SEC .
178 C (VERSION 0)
179 C KPDS(1) - ID OF CENTER
180 C KPDS(2) - MODEL IDENTIFICATION (SEE "GRIB" TABLE 1)
181 C KPDS(3) - GRID IDENTIFICATION (SEE "GRIB" TABLE 2)
182 C KPDS(4) - GDS/BMS FLAG
183 C BIT DEFINITION
184 C 25 0 - GDS OMITTED
185 C 1 - GDS INCLUDED
186 C 26 0 - BMS OMITTED
187 C 1 - BMS INCLUDED
188 C NOTE:- LEFTMOST BIT = 1,
189 C RIGHTMOST BIT = 32
190 C KPDS(5) - INDICATOR OF PARAMETER (SEE "GRIB" TABLE 5)
191 C KPDS(6) - TYPE OF LEVEL (SEE "GRIB" TABLES 6 & 7)
192 C KPDS(7) - HEIGHT,PRESSURE,ETC OF LEVEL
193 C KPDS(8) - YEAR OF CENTURY
194 C KPDS(9) - MONTH OF YEAR
195 C KPDS(10) - DAY OF MONTH
196 C KPDS(11) - HOUR OF DAY
197 C KPDS(12) - MINUTE OF HOUR
198 C KPDS(13) - INDICATOR OF FORECAST TIME UNIT (SEE "GRIB"
199 C TABLE 8)
200 C KPDS(14) - TIME 1 (SEE "GRIB" TABLE 8A)
201 C KPDS(15) - TIME 2 (SEE "GRIB" TABLE 8A)
202 C KPDS(16) - TIME RANGE INDICATOR (SEE "GRIB" TABLE 8A)
203 C KPDS(17) - NUMBER INCLUDED IN AVERAGE
204 C KPDS(18) - VERSION NR OF GRIB SPECIFICATION
205 C
206 C (VERSION 1)
207 C KPDS(1) - ID OF CENTER
208 C KPDS(2) - MODEL IDENTIFICATION (SEE "GRIB" TABLE 1)
209 C KPDS(3) - GRID IDENTIFICATION (SEE "GRIB" TABLE 2)
210 C KPDS(4) - GDS/BMS FLAG
211 C BIT DEFINITION
212 C 25 0 - GDS OMITTED
213 C 1 - GDS INCLUDED
214 C 26 0 - BMS OMITTED
215 C 1 - BMS INCLUDED
216 C NOTE:- LEFTMOST BIT = 1,
217 C RIGHTMOST BIT = 32
218 C KPDS(5) - INDICATOR OF PARAMETER (SEE "GRIB" TABLE 5)
219 C KPDS(6) - TYPE OF LEVEL (SEE "GRIB" TABLES 6 & 7)
220 C KPDS(7) - HEIGHT,PRESSURE,ETC OF LEVEL
221 C KPDS(8) - YEAR INCLUDING CENTURY
222 C KPDS(9) - MONTH OF YEAR
223 C KPDS(10) - DAY OF MONTH
224 C KPDS(11) - HOUR OF DAY
225 C KPDS(12) - MINUTE OF HOUR
226 C KPDS(13) - INDICATOR OF FORECAST TIME UNIT (SEE "GRIB"
227 C TABLE 8)
228 C KPDS(14) - TIME 1 (SEE "GRIB" TABLE 8A)
229 C KPDS(15) - TIME 2 (SEE "GRIB" TABLE 8A)
230 C KPDS(16) - TIME RANGE INDICATOR (SEE "GRIB" TABLE 8A)
231 C KPDS(17) - NUMBER INCLUDED IN AVERAGE
232 C KPDS(18) - VERSION NR OF GRIB SPECIFICATION
233 C KPDS(19) - VERSION NR OF PARAMETER TABLE
234 C KPDS(20) - TOTAL LENGTH 0F GRIB MESSAGE
235 C (INCLUDING SECTION 0)
236 C KGDS(13) INTEGER
237 C ARRAY CONTAINING GDS ELEMENTS.
238 C
239 C KGDS(1) - DATA REPRESENTATION TYPE
240 C
241 C LATITUDE/LONGITUDE GRIDS (SEE "GRIB" TABLE 10)
242 C KGDS(2) - N(I) NUMBER OF POINTS ON LATITUDE
243 C CIRCLE
244 C KGDS(3) - N(J) NUMBER OF POINTS ON LONGITUDE
245 C CIRCLE
246 C KGDS(4) - LA(1) LATITUDE OF ORIGIN
247 C KGDS(5) - LO(1) LONGITUDE OF ORIGIN
248 C KGDS(6) - RESOLUTION FLAG
249 C BIT MEANING
250 C 25 0 - DIRECTION INCREMENTS NOT
251 C GIVEN
252 C 1 - DIRECTION INCREMENTS GIVEN
253 C KGDS(7) - LA(2) LATITUDE OF EXTREME POINT
254 C KGDS(8) - LO(2) LONGITUDE OF EXTREME POINT
255 C KGDS(9) - DI LONGITUDINAL DIRECTION INCREMENT
256 C KGDS(10) - REGULAR LAT/LON GRID
257 C DJ - LATITUDINAL DIRECTION
258 C INCREMENT
259 C GAUSSIAN GRID
260 C N - NUMBER OF LATITUDE CIRCLES
261 C BETWEEN A POLE AND THE EQUATOR
262 C KGDS(11) - SCANNING MODE FLAG
263 C BIT MEANING
264 C 25 0 - POINTS ALONG A LATITUDE
265 C SCAN FROM WEST TO EAST
266 C 1 - POINTS ALONG A LATITUDE
267 C SCAN FROM EAST TO WEST
268 C 26 0 - POINTS ALONG A MERIDIAN
269 C SCAN FROM NORTH TO SOUTH
270 C 1 - POINTS ALONG A MERIDIAN
271 C SCAN FROM SOUTH TO NORTH
272 C 27 0 - POINTS SCAN FIRST ALONG
273 C CIRCLES OF LATITUDE, THEN
274 C ALONG MERIDIANS
275 C (FORTRAN: (I,J))
276 C 1 - POINTS SCAN FIRST ALONG
277 C MERIDIANS THEN ALONG
278 C CIRCLES OF LATITUDE
279 C (FORTRAN: (J,I))
280 C
281 C POLAR STEREOGRAPHIC GRIDS (SEE GRIB TABLE 12)
282 C KGDS(2) - N(I) NR POINTS ALONG LAT CIRCLE
283 C KGDS(3) - N(J) NR POINTS ALONG LON CIRCLE
284 C KGDS(4) - LA(1) LATITUDE OF ORIGIN
285 C KGDS(5) - LO(1) LONGITUDE OF ORIGIN
286 C KGDS(6) - RESERVED
287 C KGDS(7) - LOV GRID ORIENTATION
288 C KGDS(8) - DX - X DIRECTION INCREMENT
289 C KGDS(9) - DY - Y DIRECTION INCREMENT
290 C KGDS(10) - PROJECTION CENTER FLAG
291 C KGDS(11) - SCANNING MODE
292 C
293 C SPHERICAL HARMONIC COEFFICIENTS (SEE "GRIB" TABLE 14)
294 C KGDS(2) - J PENTAGONAL RESOLUTION PARAMETER
295 C KGDS(3) - K PENTAGONAL RESOLUTION PARAMETER
296 C KGDS(4) - M PENTAGONAL RESOLUTION PARAMETER
297 C KGDS(5) - REPRESENTATION TYPE
298 C KGDS(6) - COEFFICIENT STORAGE MODE
299 C
300 C MERCATOR GRIDS
301 C KGDS(2) - N(I) NR POINTS ON LATITUDE CIRCLE
302 C KGDS(3) - N(J) NR POINTS ON LONGITUDE MERIDIAN
303 C KGDS(4) - LA(1) LATITUDE OF ORIGIN
304 C KGDS(5) - LO(1) LONGITUDE OF ORIGIN
305 C KGDS(6) - RESOLUTION FLAG
306 C KGDS(7) - LA(2) LATITUDE OF LAST GRID POINT
307 C KGDS(8) - LO(2) LONGITUDE OF LAST GRID POINT
308 C KGDS(9) - LONGIT DIR INCREMENT
309 C KGDS(10) - LATIT DIR INCREMENT
310 C KGDS(11) - SCANNING MODE FLAG
311 C KGDS(12) - LATITUDE INTERSECTION
312 C LAMBERT CONFORMAL GRIDS
313 C KGDS(2) - NX NR POINTS ALONG X-AXIS
314 C KGDS(3) - NY NR POINTS ALONG Y-AXIS
315 C KGDS(4) - LA1 LAT OF ORIGIN (LOWER LEFT)
316 C KGDS(5) - LO1 LON OF ORIGIN (LOWER LEFT)
317 C KGDS(6) - RESERVED
318 C KGDS(7) - LOV - ORIENTATION OF GRID
319 C KGDS(8) - DX - X-DIR INCREMENT
320 C KGDS(9) - DY - Y-DIR INCREMENT
321 C KGDS(10) - PROJECTION CENTER FLAG
322 C KGDS(11) - SCANNING MODE FLAG
323 C KGDS(12) - LATIN 1 - FIRST LAT FROM POLE OF
324 C SECANT CONE INTERSECTION
325 C KGDS(13) - LATIN 2 - SECOND LAT FROM POLE OF
326 C SECANT CONE INTERSECTION
327 C
328 C LBMS(32768) LOGICAL
329 C ARRAY TO CONTAIN THE BIT MAP DESCRIBING THE
330 C PLACEMENT OF DATA IN THE OUTPUT ARRAY. IF A
331 C BIT MAP IS NOT INCLUDED IN THE SOURCE MESSAGE,
332 C ONE WILL BE GENERATED AUTOMATICALLY BY THE
333 C UNPACKING ROUTINE.
334 C
335 C
336 C DATA(32768) REAL
337 C THIS ARRAY WILL CONTAIN THE UNPACKED DATA POINTS.
338 C
339 C NOTE:- 32768 IS MAXIMUN FIELD SIZE ALLOWABLE
340 C
341 C KPTR(10) INTEGER
342 C ARRAY CONTAINING STORAGE FOR THE FOLLOWING
343 C PARAMETERS.
344 C
345 C (1) - UNUSED
346 C (2) - UNUSED
347 C (3) - LENGTH OF PDS (IN BYTES)
348 C (4) - LENGTH OF GDS (IN BYTES)
349 C (5) - LENGTH OF BMS (IN BYTES)
350 C (6) - LENGTH OF BDS (IN BYTES)
351 C (7) - USED BY UNPACKING ROUTINE
352 C (8) - NUMBER OF DATA POINTS FOR GRID
353 C (9) - "GRIB" CHARACTERS START IN BYTE NUMBER
354 C (10) - USED BY UNPACKING ROUTINE
355 C
356 C
357 C KRET INTEGER
358 C THIS VARIABLE WILL CONTAIN THE RETURN INDICATOR.
359 C
360 C 0 - NO ERRORS DETECTED.
361 C
362 C 1 - 'GRIB' NOT FOUND IN FIRST 100
363 C CHARACTERS.
364 C
365 C 2 - '7777' NOT FOUND, EITHER MISSING OR
366 C TOTAL OF SEC COUNTS OF INDIVIDUAL
367 C SEC'S IS INCORRECT.
368 C
369 C 3 - UNPACKED FIELD IS LARGER THAN 32768.
370 C
371 C 4 - IN GDS, DATA REPRESENTATION TYPE
372 C NOT ONE OF THE CURRENTLY ACCEPTABLE
373 C VALUES. SEE "GRIB" TABLE 9. VALUE
374 C OF INCORRECT TYPE RETURNED IN KGDS(1).
375 C
376 C 5 - GRID INDICATED IN KPDS(3) IS NOT
377 C AVAILABLE FOR THE CENTER INDICATED IN
378 C KPDS(1) AND NO GDS SENT.
379 C
380 C 7 - VERSION INDICATED IN KPDS(18) HAS NOT
381 C YET BEEN INCLUDED IN THE DECODER.
382 C
383 C 8 - GRID IDENTIFICATION = 255 (NOT STANDARD
384 C GRID) BUT FLAG INDICATING PRESENCE OF
385 C GDS IS TURNED OFF. NO METHOD OF
386 C GENERATING PROPER GRID.
387 C
388 C 9 - PRODUCT OF KGDS(2) AND KGDS(3) DOES NOT
389 C MATCH STANDARD NUMBER OF POINTS FOR THIS
390 C GRID (FOR OTHER THAN SPECTRALS). THIS
391 C WILL OCCUR ONLY IF THE GRID.
392 C IDENTIFICATION, KPDS(3), AND A
393 C TRANSMITTED GDS ARE INCONSISTENT.
394 C
395 C 10 - CENTER INDICATOR WAS NOT ONE INDICATED
396 C IN "GRIB" TABLE 1. PLEASE CONTACT AD
397 C PRODUCTION MANAGEMENT BRANCH (W/NMC42)
398 C IF THIS ERROR IS ENCOUNTERED.
399 C
400 C
401 C
402 C LIST OF TEXT MESSAGES FROM CODE
403 C
404 C
405 C W3AI08/AI082
406 C
407 C 'HAVE ENCOUNTERED A NEW GRID FOR NMC, PLEASE NOTIFY
408 C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
409 C (W/NMC42)'
410 C
411 C 'HAVE ENCOUNTERED A NEW GRID FOR ECMWF, PLEASE NOTIFY
412 C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
413 C (W/NMC42)'
414 C
415 C 'HAVE ENCOUNTERED A NEW GRID FOR U.K. METEOROLOGICAL
416 C OFFICE, BRACKNELL. PLEASE NOTIFY AUTOMATION DIVISION,
417 C PRODUCTION MANAGEMENT BRANCH (W/NMC42)'
418 C
419 C 'HAVE ENCOUNTERED A NEW GRID FOR FNOC, PLEASE NOTIFY
420 C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
421 C (W/NMC42)'
422 C
423 C
424 C W3AI08/AI083
425 C
426 C 'POLAR STEREO PROCESSING NOT AVAILABLE' *
427 C
428 C W3AI08/AI084
429 C
430 C 'WARNING - BIT MAP MAY NOT BE ASSOCIATED WITH SPHERICAL
431 C COEFFICIENTS'
432 C
433 C
434 C W3AI08/AI087
435 C
436 C 'NO CURRENT LISTING OF FNOC GRIDS' *
437 C
438 C
439 C * WILL BE AVAILABLE IN NEXT UPDATE
440 C ***************************************************************
441 C
442 C INCOMING MESSAGE HOLDER
443  CHARACTER*1 MSGA(*)
444 C BIT MAP
445  LOGICAL KBMS(*)
446 C
447 C ELEMENTS OF PRODUCT DESCRIPTION SEC (PDS)
448  INTEGER KPDS(*)
449 C ELEMENTS OF GRID DESCRIPTION SEC (PDS)
450  INTEGER KGDS(*)
451 C
452 C CONTAINER FOR GRIB GRID
453  REAL DATA(*)
454 C
455 C ARRAY OF POINTERS AND COUNTERS
456  INTEGER KPTR(*)
457 C
458 C *****************************************************************
459 C 1.0 LOCATE BEGINNING OF 'GRIB' MESSAGE
460 C FIND 'GRIB' CHARACTERS
461 C 2.0 USE COUNTS IN EACH DESCRIPTION SEC TO DETERMINE
462 C IF '7777' IS IN PROPER PLACE.
463 C 3.0 PARSE PRODUCT DEFINITION SECTION.
464 C 4.0 PARSE GRID DESCRIPTION SEC (IF INCLUDED)
465 C 5.0 PARSE BIT MAP SEC (IF INCLUDED)
466 C 6.0 USING INFORMATION FROM PRODUCT DEFINITION, GRID
467 C DESCRIPTION, AND BIT MAP SECTIONS.. EXTRACT
468 C DATA AND PLACE INTO PROPER ARRAY.
469 C *******************************************************************
470 C
471 C MAIN DRIVER
472 C
473 C *******************************************************************
474  kptr(10) = 0
475 C SEE IF PROPER 'GRIB' KEY EXISTS, THEN
476 C USING SEC COUNTS, DETERMINE IF '7777'
477 C IS IN THE PROPER LOCATION
478 C
479  CALL ai081(msga,kptr,kpds,kret)
480  IF (kret.NE.0) GO TO 900
481 C
482 C PARSE PARAMETERS FROM PRODUCT DESCRIPTION SECTION
483 C
484  IF (kpds(18).EQ.0) THEN
485  CALL ai082(msga,kptr,kpds,kret)
486  ELSE IF (kpds(18).EQ.1) THEN
487  CALL ai082a(msga,kptr,kpds,kret)
488  ELSE
489  print *,'GRIB EDITION',kpds(18),' NOT PROGRAMMED FOR'
490  kret = 7
491  GO TO 900
492  END IF
493  IF (kret.NE.0) GO TO 900
494 C
495 C EXTRACT NEW GRID DESCRIPTION
496 C
497  CALL ai083(msga,kptr,kpds,kgds,kret)
498  IF (kret.NE.0) GO TO 900
499 C
500 C EXTRACT OR GENERATE BIT MAP
501 C
502  CALL ai084(msga,kptr,kpds,kgds,kbms,kret)
503  IF (kret.NE.0) GO TO 900
504 C
505 C USING INFORMATION FROM PDS, BMS AND BIT DATA SEC ,
506 C EXTRACT AND SAVE IN GRIB GRID, ALL DATA ENTRIES.
507 C
508  IF (kpds(18).EQ.0) THEN
509  CALL ai085(msga,kptr,kpds,kbms,DATA,kret)
510  ELSE IF (kpds(18).EQ.1) THEN
511  CALL ai085a(msga,kptr,kpds,kbms,DATA,kret)
512  ELSE
513  print *,'AI085 NOT PROGRAMMED FOR VERSION NR',kpds(18)
514  kret = 7
515  END IF
516 C
517  900 RETURN
518  END
519 
520 C>Find 'grib; characters and set pointers to the next
521 C>byte following 'grib'. If they exist extract counts from gds and
522 C>bms. Extract count from bds. determine if sum of counts actually
523 C>places terminator '7777' at the correct location.
524 C>
525 C> Program history log:
526 C> - Bill Cavanaugh 1988-01-20
527 C> - Ralph Jones 1990-09-01 Change's for ansi fortran.
528 C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
529 C>
530 C> @param[in] msga grib field - "grib" thru "7777".``
531 C> @param[inout] kptr array containing storage for following parameters.
532 C> - 1: Unused.
533 C> - 2: Unused.
534 C> - 3: Length of pds.
535 C> - 4: Length of gds.
536 C> - 5: Length of bms.
537 C> - 6: Length of bds.
538 C> - 7: Value of current byte.
539 C> - 8: Unused.
540 C> - 9: Grib start byte.
541 C> - 10: Grib/grid element count.
542 C> @param[out] kpds - array containing pds elements..
543 C> - 1: Id of center.
544 C> - 2: Model identification.
545 C> - 3: Grid identification.
546 C> - 4: Gds/bms flag.
547 C> - 5: Indicator of parameter.
548 C> - 6: Type of level.
549 C> - 7: Height/pressure , etc of level.
550 C> - 8: Year of century.
551 C> - 9: Month of year.
552 C> - 10: Day of month.
553 C> - 11: Hour of day.
554 C> - 12: Minute of hour.
555 C> - 13: Indicator of forecast time unit.
556 C> - 14: Time range 1.
557 C> - 15: Time range 2.
558 C> - 16: Time range flag.
559 C> - 17: Number included in average.
560 C> - 18: Version nr of grib specification.
561 C> @param[out] kret Error return.
562 C>
563 C> @note Error returns.
564 C> - kret = 1: No 'grib'.
565 C> - kret = 2: No '7777' or mislocated (by counts).
566 C>
567 C> @author Bill Cavanaugh @date 1988-01-20
568  SUBROUTINE ai081(MSGA,KPTR,KPDS,KRET)
569 
570 C
571 C INCOMING MESSAGE HOLDER
572  CHARACTER*1 MSGA(*)
573 C ARRAY OF POINTERS AND COUNTERS
574  INTEGER KPTR(*)
575 C PRODUCT DESCRIPTION SECTION DATA.
576  INTEGER KPDS(*)
577 C
578  INTEGER KRET
579 C
580 C DATA MASK40/Z00000040/
581 C DATA MASK80/Z00000080/
582 C
583  DATA mask40/64/
584  DATA mask80/128/
585 C
586 C ******************************************************************
587  kret = 0
588 C ------------------- FIND 'GRIB' KEY
589  DO 100 i = 1, 105
590  IF (mova2i(msga(i )).NE.71) GO TO 100
591  IF (mova2i(msga(i+1)).NE.82) GO TO 100
592  IF (mova2i(msga(i+2)).NE.73) GO TO 100
593  IF (mova2i(msga(i+3)).NE.66) GO TO 100
594  kptr(9) = i
595  GO TO 200
596  100 CONTINUE
597  kret = 1
598  RETURN
599 C
600  200 CONTINUE
601  is = kptr(9)
602 C ------------------- HAVE 'GRIB' KEY
603  kcnt = 0
604 C --------------- EXTRACT COUNT FROM PDS OR GRIB
605  iss = is + 4
606  DO 300 i = 0, 2
607  kcnt = kcnt * 256 + mova2i(msga(i+iss))
608  300 CONTINUE
609 C
610 C TEST FOR VERSION NUMBER OF PDS 0 OR 1
611 C
612  IF (kcnt.EQ.24) THEN
613  kptr(3) = kcnt
614  igribl = 4
615 C
616 C --------------- EDITION NR OF GRIB SPECIFICATION, VERSION 0
617 C
618  kpds(18) = mova2i(msga(iss + 3))
619  ELSE
620  igribl = 8
621  iss = is + igribl
622 C --------------- EDITION NR OF GRIB SPECIFICATION, VERSION 1
623  kpds(18) = mova2i(msga(is + 7))
624 C
625 C --------------- PARAMETER TABLE VERSION NUMBER FOR INTERNATIONAL
626 C EXCHANGE (CURRENTLY NO. 1)
627 C
628  kpds(19) = mova2i(msga(iss + 3))
629 C
630 C ---------------- SAVE TOTAL LENGTH OF MESSAGE (INCLUDING SECTION 0)
631 C
632  kpds(20) = kcnt
633 C
634 C --------------- EXTRACT COUNT FROM PDS VERSION 1
635 C
636  kcnt = 0
637  DO 400 i = 0, 2
638  kcnt = kcnt * 256 + mova2i(msga(i+iss))
639  400 CONTINUE
640  kptr(3) = kcnt
641  ENDIF
642 C
643 C --------------- GET GDS, BMS INDICATOR
644 C
645  kpds(4) = mova2i(msga(iss+7))
646 C
647 C READY FOR NEXT SECTION
648 C
649  kptr(4) = 0
650  kptr(5) = 0
651  IF (iand(kpds(4),mask80).EQ.0) GO TO 600
652 C
653 C --------------- EXTRACT COUNT FROM GDS
654 C
655  iss = kptr(3) + is + igribl
656  kcnt = 0
657  DO 500 i = 0, 2
658  kcnt = kcnt * 256 + mova2i(msga(i+iss))
659  500 CONTINUE
660  kptr(4) = kcnt
661  600 CONTINUE
662  IF (iand(kpds(4),mask40).EQ.0) GO TO 800
663 C
664 C ---------------- EXTRACT COUNT FROM BMS
665 C
666  iss = kptr(3) + kptr(4) + is + igribl
667  kcnt = 0
668  DO 700 i = 0, 2
669  kcnt = kcnt * 256 + mova2i(msga(i+iss))
670  700 CONTINUE
671  kptr(5) = kcnt
672 C
673 C --------------- EXTRACT COUNT FROM BDS
674 C
675  800 CONTINUE
676  kcnt = 0
677  iss = kptr(3) + kptr(4) + kptr(5) + is + igribl
678  DO 900 i = 0, 2
679  kcnt = kcnt * 256 + mova2i(msga(i+iss))
680  900 CONTINUE
681  kptr(6) = kcnt
682 C
683 C --------------- TEST FOR '7777'
684 C
685  iss = kptr(3) + kptr(4) + kptr(5) + kptr(6) + is + igribl
686  kret = 0
687  DO 1000 i = 0, 3
688  IF (mova2i(msga(i+iss)).EQ.55) THEN
689  GO TO 1000
690  ELSE
691  kret = 2
692  RETURN
693  END IF
694  1000 CONTINUE
695  RETURN
696  END
697 
698 C> Extract information from the product description
699 C> sec, and generate label information to permit storage
700 C> in office note 84 format.
701 C>
702 C> Program history log:
703 C> - Bill Cavanaugh 1988-01-20
704 C> - Ralph Jones 1990-09-01 Change's for ansi fortran.
705 C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
706 C> - Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
707 C>
708 C> @param[in] msga Array containing grib message.
709 C> @param[inout] kptr Array containing storage for following parameters.
710 C> - 1: Unused.
711 C> - 2: Unused.
712 C> - 3: Length of pds.
713 C> - 4: Length of gds.
714 C> - 5: Length of bms.
715 C> - 6: Length of pds.
716 C> - 7: Value of current byte.
717 C> - 8: Unused.
718 C> - 9: Grib start byte nr.
719 C> - 10: Grib/grid element count.
720 C> @param[out] kpds Array containing pds elements.
721 C> - 1: Id of center.
722 C> - 2: Model identification.
723 C> - 3: Grid identification.
724 C> - 4: Gds/bms flag.
725 C> - 5: Indicator of parameter.
726 C> - 6: Type of level.
727 C> - 7: Height/pressure, etc of level.
728 C> - 8: Year of century.
729 C> - 9: Month of year.
730 C> - 10: Day of month.
731 C> - 11: Hour of day.
732 C> - 12: Minute of hour.
733 C> - 13: Indicator of forecast time unit.
734 C> - 14: Time range 1.
735 C> - 15: Time range 2.
736 C> - 16: Time range flag.
737 C> - 17: Number included in average.
738 C> - 18: Version number of grib spefication.
739 C> - 19: Version nr of parameter table.
740 C> - 20: Total length of grib message (including section 0).
741 C> @param[out] kret error return.
742 C>
743 C> @note error return:
744 C> - = 0 - no errors
745 C> - = 8 - temp gds indicated, but no gds
746 C>
747 C> @author Bill Cavanaugh @date 1988-01-20
748  SUBROUTINE ai082(MSGA,KPTR,KPDS,KRET)
749 C
750 C INCOMING MESSAGE HOLDER
751  CHARACTER*1 MSGA(*)
752 C
753 C ARRAY OF POINTERS AND COUNTERS
754  INTEGER KPTR(*)
755 C PRODUCT DESCRIPTION SECTION ENTRIES
756  INTEGER KPDS(*)
757 C
758  INTEGER KRET
759 C
760 C -------------------- COLLECT PDS VALUES
761 C KPDS(1) - ID OF CENTER
762 C KPDS(2) - MODEL IDENTIFICATION
763 C KPDS(3) - GRID IDENTIFICATION
764 C KPDS(4) - GDS/BMS FLAG
765 C KPDS(5) - INDICATOR OF PARAMETER
766 C ----------- KPDS(6) - TYPE OF LEVEL
767  is = kptr(9)
768  iss = is + 8
769  DO 200 i = 0, 5
770  kpds(i+1) = mova2i(msga(i+iss))
771  200 CONTINUE
772  IF (kpds(3).NE.255) GO TO 250
773  IF (iand(kpds(4),128).NE.0) GO TO 250
774  kret = 8
775  RETURN
776  250 CONTINUE
777  iss = is + 14
778  kpds(7) = 0
779  DO 300 i = 0, 1
780  kpds(7) = kpds(7) * 256 + mova2i(msga(i+iss))
781  300 CONTINUE
782 C ----------- KPDS(8) - YEAR OF CENTURY
783 C KPDS(9) - MONTH OF YEAR
784 C KPDS(10) - DAY OF MONTH
785 C KPDS(11) - HOUR OF DAY
786 C KPDS(12) - MINUTE OF HOUR
787 C KPDS(13) - INDICATOR OF FORECAST TIME UNIT
788 C KPDS(14) - TIME RANGE 1
789 C KPDS(15) - TIME RANGE 2
790 C ----------- KPDS(16) - TIME RANGE FLAG
791 C
792  iss = is + 16
793  DO 400 i = 0, 7
794  kpds(i+8) = mova2i(msga(i+iss))
795  400 CONTINUE
796 C ----------- KPDS(17) - NUMBER INCLUDED IN AVERAGE
797  iss = is + 25
798  kpds(17) = 0
799  DO 500 i = 0, 1
800  kpds(17) = kpds(17) * 256 + mova2i(msga(i+iss))
801  500 CONTINUE
802 C -----------SKIP OVER SOURCE BYTE 24
803 C ----------- TEST FOR NEW GRID
804  IF (iand(kpds(4),128).NE.0) THEN
805  IF (iand(kpds(4),64).NE.0) THEN
806  IF (kpds(3).NE.255) THEN
807  IF (kpds(1).EQ.7) THEN
808  IF (kpds(3).GE.21.AND.kpds(3).LE.26) THEN
809  ELSE IF (kpds(3).EQ.50) THEN
810  ELSE IF (kpds(3).GE.61.AND.kpds(3).LE.64) THEN
811  ELSE IF (kpds(3).EQ.70) THEN
812  ELSE IF (kpds(3).GE.85.AND.kpds(3).LE.86) THEN
813  ELSE IF (kpds(3).GE.100.AND.kpds(3).LE.103) THEN
814  ELSE IF (kpds(3).GE.201.AND.kpds(3).LE.214) THEN
815  ELSE
816  print *,' HAVE ENCOUNTERED A NEW GRID FOR',
817  * ' NMC'
818  print *,' PLEASE NOTIFY AUTOMATION DIVISION'
819  print *,' PRODUCTION MANAGEMENT BRANCH'
820  print *,' W/NMC42)'
821  END IF
822  ELSE IF (kpds(1).EQ.98) THEN
823  IF (kpds(3).GE.1.AND.kpds(3).LE.16) THEN
824  ELSE
825  print *,' HAVE ENCOUNTERED A NEW GRID FOR',
826  * ' ECMWF'
827  print *,' PLEASE NOTIFY AUTOMATION DIVISION'
828  print *,' PRODUCTION MANAGEMENT BRANCH'
829  print *,' W/NMC42)'
830  END IF
831  ELSE IF (kpds(1).EQ.74) THEN
832  IF (kpds(3).GE.1.AND.kpds(3).LE.12) THEN
833  ELSE IF (kpds(3).GE.21.AND.kpds(3).LE.26)THEN
834  ELSE IF (kpds(3).GE.61.AND.kpds(3).LE.64) THEN
835  ELSE IF (kpds(3).EQ.70) THEN
836  ELSE
837  print *,' HAVE ENCOUNTERED A NEW GRID FOR',
838  * ' U.K. MET OFFICE, BRACKNELL'
839  print *,' PLEASE NOTIFY AUTOMATION DIVISION'
840  print *,' PRODUCTION MANAGEMENT BRANCH'
841  print *,' W/NMC42)'
842  END IF
843  ELSE IF (kpds(1).EQ.58) THEN
844  IF (kpds(3).GE.1.AND.kpds(3).LE.12) THEN
845  ELSE
846  print *,' HAVE ENCOUNTERED A NEW GRID FOR',
847  * ' FNOC,'
848  print *,' PLEASE NOTIFY AUTOMATION DIVISION'
849  print *,' PRODUCTION MANAGEMENT BRANCH'
850  print *,' W/NMC42)'
851  END IF
852  END IF
853  END IF
854  END IF
855  END IF
856  RETURN
857  END
858 
859 C> Extract information from the product description section (version 1).
860 C>
861 C> Program history log:
862 C> - Bill Cavanaugh 1989-11-20
863 C> - Ralph Jones 1990-09-01 Change's for ansi fortran.
864 C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
865 C> - Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
866 C>
867 C> @param[in] MSGA Array containing grib message.
868 C> @param[inout] KPTR Array containing storage for following parameters.
869 C> - 1: Unused.
870 C> - 2: Unused.
871 C> - 3: Length of pds.
872 C> - 4: Length of gds.
873 C> - 5: Length of bms.
874 C> - 6: Length of pds.
875 C> - 7: Value of current byte.
876 C> - 8: Unused.
877 C> - 9: Grib start byte nr.
878 C> - 10: Grib/grid element count.
879 C>
880 C> @param[out] KPDS Array containing pds elements.
881 C> - 1: Id of center
882 C> - 2: Model identi.fication
883 C> - 3: Grid identification.
884 C> - 4: Gds/bms flag.
885 C> - 5: Indicator of. parameter
886 C> - 6: Type of level.
887 C> - 7: Height/pressu.re , etc of level
888 C> - 8: Year (including century).
889 C> - 9: Month of year.
890 C> - 10: Day of month..
891 C> - 11: Hour of day.
892 C> - 12: Minute of hour.
893 C> - 13: Indicator of forecast time unit.
894 C> - 14: Time range 1.
895 C> - 15: Time range 2.
896 C> - 16: Time range flag.
897 C> - 17: Number included in average.
898 C> - 18: Version nr of grib specification.
899 C> - 19: Version nr of parameter table.
900 C> - 20: Total byte count for source message.
901 C> @param[out] KRET Error return.
902 C>
903 C> @note Source pds structure (version 1).
904 C> - 1-3: Length of pds section in bytes.
905 C> - 4: Parameter table version no. for international exchange (crrently no. 1).
906 C> - 5: Center id.
907 C> - 6: Model id.
908 C> - 7: Grid id.
909 C> - 8: Flag for gds/bms.
910 C> - 9: Indicator for parameter.
911 C> - 10: Indicator for type of level.
912 C> - 11-12: Height, pressure of level.
913 C> - 13: Year of century.
914 C> - 14: Month.
915 C> - 15: Day.
916 C> - 16: Hour.
917 C> - 17: Minute.
918 C> - 18: Forecast time unit.
919 C> - 19: P1 - pd of time.
920 C> - 20: P2 - pd of time.
921 C> - 21: Time range indicator.
922 C> - 22-23: Number in average.
923 C> - 24: Number misg from averages.
924 C> - 25: Century.
925 C> - 26: Indicator of parameter in locally re-defined parameter table..
926 C> - 27-28: Units decimal scale factor (d).
927 C> - 29-40: Reserved: need not be present.
928 C> - 41-NN: National use.
929 C> - Error return:
930 C> - = 0 - No errors.
931 C> - = 8 - Temp gds indicated, but no gds.
932 C>
933 C> @author Bill Cavanaugh @date 1988-01-20
934  SUBROUTINE ai082a(MSGA,KPTR,KPDS,KRET)
935 C
936 C INCOMING MESSAGE HOLDER
937  CHARACTER*1 MSGA(*)
938 C
939 C ARRAY OF POINTERS AND COUNTERS
940  INTEGER KPTR(*)
941 C PRODUCT DESCRIPTION SECTION ENTRIES
942  INTEGER KPDS(*)
943 C
944  INTEGER KRET
945 C
946  is = kptr(9)
947  igribl = 8
948 C -------------------- COLLECT PDS VALUES
949 C KPDS(1) - ID OF CENTER
950 C KPDS(2) - MODEL IDENTIFICATION
951 C KPDS(3) - GRID IDENTIFICATION
952 C KPDS(4) - GDS/BMS FLAG
953 C KPDS(5) - INDICATOR OF PARAMETER
954 C ----------- KPDS(6) - TYPE OF LEVEL
955  iss = is + igribl + 4
956  DO 200 i = 0, 5
957  kpds(i+1) = mova2i(msga(i+iss))
958  200 CONTINUE
959  IF (kpds(3).NE.255) GO TO 250
960  IF (iand(kpds(4),128).NE.0) GO TO 250
961  kret = 8
962  RETURN
963  250 CONTINUE
964 C HEIGHT, PRESS OF LEVEL
965  iss = is + igribl + 10
966  kpds(7) = 0
967  DO 300 i = 0, 1
968  kpds(7) = kpds(7) * 256 + mova2i(msga(i+iss))
969  300 CONTINUE
970 C
971 C ----------- KPDS(8) - YEAR (INCLUDING CENTURY)
972 C
973  iss = is + igribl + 12
974  icen = is + igribl + 24
975 C
976  kpds(8) = mova2i(msga(icen)) * 100 + mova2i(msga(iss))
977 C
978 C KPDS(9) - MONTH OF YEAR
979 C KPDS(10) - DAY OF MONTH
980 C KPDS(11) - HOUR OF DAY
981 C KPDS(12) - MINUTE OF HOUR
982 C KPDS(13) - INDICATOR OF FORECAST TIME UNIT
983 C KPDS(14) - TIME RANGE 1
984 C KPDS(15) - TIME RANGE 2
985 C ----------- KPDS(16) - TIME RANGE FLAG
986 C
987  iss = is + igribl + 13
988  DO 400 i = 0, 7
989  kpds(i+9) = mova2i(msga(i+iss))
990  400 CONTINUE
991 C ----------- KPDS(17) - NUMBER INCLUDED IN AVERAGE
992  iss = is + igribl + 21
993  kpds(17) = 0
994  DO 500 i = 0, 1
995  kpds(17) = kpds(17) * 256 + mova2i(msga(i+iss))
996  500 CONTINUE
997 C -----------SKIP OVER SOURCE BYTE 28
998 C ----------- TEST FOR NEW GRID
999  IF (iand(kpds(4),128).NE.0) THEN
1000  IF (iand(kpds(4),64).NE.0) THEN
1001  IF (kpds(3).NE.255) THEN
1002  IF (kpds(1).EQ.7) THEN
1003  IF (kpds(3).GE.21.AND.kpds(3).LE.26)THEN
1004  ELSE IF (kpds(3).EQ.50) THEN
1005  ELSE IF (kpds(3).GE.61.AND.kpds(3).LE.64) THEN
1006  ELSE IF (kpds(3).EQ.70) THEN
1007  ELSE IF (kpds(3).GE.85.AND.kpds(3).LE.86) THEN
1008  ELSE IF (kpds(3).GE.100.AND.kpds(3).LE.103) THEN
1009  ELSE IF (kpds(3).GE.201.AND.kpds(3).LE.214) THEN
1010  ELSE
1011  print *,' HAVE ENCOUNTERED A NEW GRID FOR',
1012  * ' NMC'
1013  print *,' PLEASE NOTIFY AUTOMATION DIVISION'
1014  print *,' PRODUCTION MANAGEMENT BRANCH'
1015  print *,' W/NMC42)'
1016  END IF
1017  ELSE IF (kpds(1).EQ.98) THEN
1018  IF (kpds(3).GE.1.AND.kpds(3).LE.16) THEN
1019  ELSE
1020  print *,' HAVE ENCOUNTERED A NEW GRID FOR',
1021  * ' ECMWF'
1022  print *,' PLEASE NOTIFY AUTOMATION DIVISION'
1023  print *,' PRODUCTION MANAGEMENT BRANCH'
1024  print *,' W/NMC42)'
1025  END IF
1026  ELSE IF (kpds(1).EQ.74) THEN
1027  IF (kpds(3).GE.1.AND.kpds(3).LE.12) THEN
1028  ELSE IF (kpds(3).GE.21.AND.kpds(3).LE.26)THEN
1029  ELSE IF (kpds(3).GE.61.AND.kpds(3).LE.64) THEN
1030  ELSE IF (kpds(3).EQ.70) THEN
1031  ELSE
1032  print *,' HAVE ENCOUNTERED A NEW GRID FOR',
1033  * ' U.K. MET OFFICE, BRACKNELL'
1034  print *,' PLEASE NOTIFY AUTOMATION DIVISION'
1035  print *,' PRODUCTION MANAGEMENT BRANCH'
1036  print *,' W/NMC42)'
1037  END IF
1038  ELSE IF (kpds(1).EQ.58) THEN
1039  IF (kpds(3).GE.1.AND.kpds(3).LE.12) THEN
1040  ELSE
1041  print *,' HAVE ENCOUNTERED A NEW GRID FOR',
1042  * ' FNOC,'
1043  print *,' PLEASE NOTIFY AUTOMATION DIVISION'
1044  print *,' PRODUCTION MANAGEMENT BRANCH'
1045  print *,' W/NMC42)'
1046  END IF
1047  END IF
1048  END IF
1049  END IF
1050  END IF
1051  RETURN
1052  END
1053 
1054 C> Extract information on unlisted grid to allow conversion to office note 84 format.
1055 C>
1056 C> Program history log:
1057 C> - Bill Cavanaugh 1988-01-20
1058 C> - Bill Cavanaugh 1989-03-16 Added mercator & lambert conformal processing.
1059 C> - Bill Cavanaugh 1989-07-12 Corrected change entered 89-03-16 reordering
1060 C> processing for lambert conformal and mercator grids.
1061 C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
1062 C>
1063 C> @param[in] MSGA Array containing grib message.
1064 C> @param[inout] KPTR Array containing storage for following parameters.
1065 C> - 1): Unused.
1066 C> - 2): Unused.
1067 C> - 3): Length of pds.
1068 C> - 4): Length of gds.
1069 C> - 5): Length of bms.
1070 C> - 6): Length of bds.
1071 C> - 7): Value of current byte.
1072 C> - 8): Unused.
1073 C> - 9): Grib start byte nr.
1074 C> - 0): Grib/grid element count.
1075 C> @param[in] KPDS Array containing pds elements.
1076 C> - 1): Id of center.
1077 C> - 2): Model identification.
1078 C> - 3): Grid identification.
1079 C> - 4): Gds/bms flag.
1080 C> - 5): Indicator of parameter.
1081 C> - 6): Type of level.
1082 C> - 7): Height/pressure , etc of level.
1083 C> - 8): Year of century.
1084 C> - 9): Month of year.
1085 C> - 10: Day of month.
1086 C> - 11: Hour of day.
1087 C> - 12: Minute of hour.
1088 C> - 13: Indicator of forecast time unit.
1089 C> - 14: Time range 1.
1090 C> - 15: Time range 2.
1091 C> - 16: Time range flag.
1092 C> - 17: Number included in average.
1093 C> - 18: Version nr of grib specification.
1094 C> @param[out] KGDS Array containing gds elements..
1095 C> - 1): Data representation type.
1096 C> - Latitude/Longitude grids
1097 C> - 2): N(i) nr points on latitude circle.
1098 C> - 3): N(j) nr points on longitude meridian.
1099 C> - 4): La(1) latitude of origin.
1100 C> - 5): Lo(1) longitude of origin.
1101 C> - 6): Resolution flag.
1102 C> - 7): La(2) latitude of extreme point.
1103 C> - 8): Lo(2) longitude of extreme point.
1104 C> - 9): Di longitudinal direction of increment.
1105 C> - 10: Dj latitudinal direction of increment.
1106 C> - 11: Scanning mode flag.
1107 C> - Polar stereographic grids.
1108 C> - 2): N(i) nr points along lat circle.
1109 C> - 3): N(j) nr points along lon circle.
1110 C> - 4): La(1) latitude of origin.
1111 C> - 5): Lo(1) longitude of origin.
1112 C> - 6): Reserved.
1113 C> - 7): Lov grid orientation.
1114 C> - 8): Dx - x direction increment.
1115 C> - 9): Dy - y direction increment.
1116 C> - 10: Projection center flag.
1117 C> - 11: Scanning mode.
1118 C> - Spherical harmonic coefficients.
1119 C> - 2): J pentagonal resolution parameter.
1120 C> - 3): K pentagonal resolution parameter.
1121 C> - 4): M pentagonal resolution parameter.
1122 C> - 5): Representation type.
1123 C> - 6): Coefficient storage mode.
1124 C> - Mercator grids.
1125 C> - 2): N(i) nr points on latitude circle.
1126 C> - 3): N(j) nr points on longitude meridian.
1127 C> - 4): La(1) latitude of origin.
1128 C> - 5): Lo(1) longitude of origin.
1129 C> - 6): Resolution flag.
1130 C> - 7): La(2) latitude of last grid point.
1131 C> - 8): Lo(2) longitude of last grid point.
1132 C> - 9): Longit dir increment.
1133 C> - 10: Latit dir increment.
1134 C> - 11: Scanning mode flag.
1135 C> - 12: Latitude intersection.
1136 C> - Lambert conformal grids.
1137 C> - 2): Nx nr points along x-axis.
1138 C> - 3): Ny nr points along y-axis.
1139 C> - 4): La1 lat of origin (lower left).
1140 C> - 5): Lo1 lon of origin (lower left).
1141 C> - 6): Reserved.
1142 C> - 7): Lov - orientation of grid.
1143 C> - 8): Dx - x-dir increment.
1144 C> - 9): Dy - y-dir increment.
1145 C> - 10: Projection center flag.
1146 C> - 11: Scanning mode flag.
1147 C> - 12: Latin 1 - first lat from pole of secant cone inter.
1148 C> - 13: Latin 2 - second lat from pole of secant cone inter.
1149 C> @param[out] KRET Error return.
1150 C>
1151 C> @note KRET
1152 C> - = 0
1153 C> - = 4 - DATA REPRESENTATION TYPE NOT CURRENTLY ACCEPTABLE
1154 C>
1155 C> @author Bill Cavanaugh @date 1988-01-20
1156 
1157  SUBROUTINE ai083(MSGA,KPTR,KPDS,KGDS,KRET)
1158 C ************************************************************
1159 C INCOMING MESSAGE HOLDER
1160  CHARACTER*1 MSGA(*)
1161 C
1162 C ARRAY GDS ELEMENTS
1163  INTEGER KGDS(*)
1164 C ARRAY OF POINTERS AND COUNTERS
1165  INTEGER KPTR(*)
1166 C ARRAY OF PDS ELEMENTS
1167  INTEGER KPDS(*)
1168 C
1169  INTEGER KRET
1170 C
1171 C DATA MSK80 /Z00000080/
1172 C
1173  DATA msk80 /128/
1174 C ********************************************************
1175 C IF FLAG IN PDS INDICATE THAT THERE IS NO GDS ,
1176 C RETURN IMMEDIATELY
1177 C ************************************************************
1178  IF (iand(kpds(4),msk80).EQ.0) GO TO 900
1179 C ------------------- BYTE 1-3 COUNT
1180  is = kptr(9)
1181  IF (kpds(18).EQ.0) THEN
1182  igribl = 4
1183  ELSE
1184  igribl = 8
1185  ENDIF
1186  iss = is + kptr(3) + igribl
1187 C ------------------- BYTE 4 NUMBER OF UNUSED BITS AT END OF SEC
1188 C ------------------- BYTE 5 RESERVED
1189 C ------------------- BYTE 6 DATA REPRESENTATION TYPE
1190  kgds(1) = mova2i(msga(iss+5))
1191 C ------------------- DIVERT TO PROCESS CORRECT TYPE
1192  IF (kgds(1).EQ.0) THEN
1193  GO TO 1000
1194  ELSE IF (kgds(1).EQ.1) THEN
1195  GO TO 4000
1196  ELSE IF (kgds(1).EQ.2.OR.kgds(1).EQ.5) THEN
1197  GO TO 2000
1198  ELSE IF (kgds(1).EQ.3) THEN
1199  GO TO 5000
1200  ELSE IF (kgds(1).EQ.4) THEN
1201  GO TO 1000
1202  ELSE IF (kgds(1).EQ.50) THEN
1203  GO TO 3000
1204  ELSE
1205 C MARK AS GDS/ UNKNOWN DATA REPRESENTATION TYPE
1206  kret = 4
1207  GO TO 900
1208  END IF
1209 C
1210 C ------------------- LATITUDE/LONGITUDE GRIDS
1211 C
1212 C ------------------- BYTE 7-8 NR OF POINTS ALONG LATITUDE CIRCLE
1213  1000 kgds(2) = 0
1214  DO 1005 i = 0, 1
1215  kgds(2) = kgds(2) * 256 + mova2i(msga(i+iss+6))
1216  1005 CONTINUE
1217 C ------------------- BYTE 9-10 NR OF POINTS ALONG LONG MERIDIAN
1218  kgds(3) = 0
1219  DO 1010 i = 0, 1
1220  kgds(3) = kgds(3) * 256 + mova2i(msga(i+iss+8))
1221  1010 CONTINUE
1222 C ------------------- BYTE 11-13 LATITUE OF ORIGIN
1223  kgds(4) = 0
1224  DO 1020 i = 0, 2
1225  kgds(4) = kgds(4) * 256 + mova2i(msga(i+iss+10))
1226  1020 CONTINUE
1227  IF (iand(kgds(4),8388608).NE.0) THEN
1228  kgds(4) = iand(kgds(4),8388607) * (-1)
1229  END IF
1230 C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN
1231  kgds(5) = 0
1232  DO 1030 i = 0, 2
1233  kgds(5) = kgds(5) * 256 + mova2i(msga(i+iss+13))
1234  1030 CONTINUE
1235  IF (iand(kgds(5),8388608).NE.0) THEN
1236  kgds(5) = - iand(kgds(5),8388607)
1237  END IF
1238 C ------------------- BYTE 17 RESOLUTION FLAG
1239  kgds(6) = mova2i(msga(iss+16))
1240 C ------------------- BYTE 18-20 LATITUDE OF LAST GRID POINT
1241  kgds(7) = 0
1242  DO 1040 i = 0, 2
1243  kgds(7) = kgds(7) * 256 + mova2i(msga(i+iss+17))
1244  1040 CONTINUE
1245  IF (iand(kgds(7),8388608).NE.0) THEN
1246  kgds(7) = - iand(kgds(7),8388607)
1247  END IF
1248 C ------------------- BYTE 21-23 LONGITUDE OF LAST GRID POINT
1249  kgds(8) = 0
1250  DO 1050 i = 0, 2
1251  kgds(8) = kgds(8) * 256 + mova2i(msga(i+iss+20))
1252  1050 CONTINUE
1253  IF (iand(kgds(8),8388608).NE.0) THEN
1254  kgds(8) = - iand(kgds(8),8388607)
1255  END IF
1256 C ------------------- BYTE 24-25 LATITUDINAL DIR INCREMENT
1257  kgds(9) = 0
1258  DO 1060 i = 0, 1
1259  kgds(9) = kgds(9) * 256 + mova2i(msga(i+iss+23))
1260  1060 CONTINUE
1261 C ------------------- BYTE 26-27 IF REGULAR LAT/LON GRID
1262 C HAVE LONGIT DIR INCREMENT
1263 C ELSE IF GAUSSIAN GRID
1264 C HAVE NR OF LAT CIRCLES
1265 C BETWEEN POLE AND EQUATOR
1266  kgds(10) = 0
1267  DO 1070 i = 0, 1
1268  kgds(10) = kgds(10) * 256 + mova2i(msga(i+iss+25))
1269  1070 CONTINUE
1270 C ------------------- BYTE 28 SCANNING MODE FLAGS
1271  kgds(11) = mova2i(msga(iss+27))
1272 C ------------------- BYTE 29-32 RESERVED
1273 C -------------------
1274  GO TO 900
1275 C -------------------
1276 C ' POLAR STEREO PROCESSING '
1277 C
1278 C ------------------- BYTE 7-8 NR OF POINTS ALONG X=AXIS
1279  2000 kgds(2) = 0
1280  DO 2005 i = 0, 1
1281  kgds(2) = kgds(2) * 256 + mova2i(msga(i+iss+6))
1282  2005 CONTINUE
1283 C ------------------- BYTE 9-10 NR OF POINTS ALONG Y-AXIS
1284  kgds(3) = 0
1285  DO 2010 i = 0, 1
1286  kgds(3) = kgds(3) * 256 + mova2i(msga(i+iss+8))
1287  2010 CONTINUE
1288 C ------------------- BYTE 11-13 LATITUDE OF ORIGIN
1289  kgds(4) = 0
1290  DO 2020 i = 0, 2
1291  kgds(4) = kgds(4) * 256 + mova2i(msga(i+iss+10))
1292  2020 CONTINUE
1293  IF (iand(kgds(4),8388608).NE.0) THEN
1294  kgds(4) = - iand(kgds(4),8388607)
1295  END IF
1296 C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN
1297  kgds(5) = 0
1298  DO 2030 i = 0, 2
1299  kgds(5) = kgds(5) * 256 + mova2i(msga(i+iss+13))
1300  2030 CONTINUE
1301  IF (iand(kgds(5),8388608).NE.0) THEN
1302  kgds(5) = - iand(kgds(5),8388607)
1303  END IF
1304 C ------------------- BYTE 17 RESERVED
1305  kgds(6) = mova2i(msga(iss+16))
1306 C ------------------- BYTE 18-20 LOV ORIENTATION OF THE GRID
1307  kgds(7) = 0
1308  DO 2040 i = 0, 2
1309  kgds(7) = kgds(7) * 256 + mova2i(msga(i+iss+17))
1310  2040 CONTINUE
1311  IF (iand(kgds(7),8388608).NE.0) THEN
1312  kgds(7) = - iand(kgds(7),8388607)
1313  END IF
1314 C ------------------- BYTE 21-23 DX - THE X DIRECTION INCREMENT
1315  kgds(8) = 0
1316  DO 2050 i = 0, 2
1317  kgds(8) = kgds(8) * 256 + mova2i(msga(i+iss+20))
1318  2050 CONTINUE
1319  IF (iand(kgds(8),8388608).NE.0) THEN
1320  kgds(8) = - iand(kgds(8),8388607)
1321  END IF
1322 C ------------------- BYTE 24-26 DY - THE Y DIRECTION INCREMENT
1323  kgds(9) = 0
1324  DO 2060 i = 0, 2
1325  kgds(9) = kgds(9) * 256 + mova2i(msga(i+iss+23))
1326  2060 CONTINUE
1327  IF (iand(kgds(9),8388608).NE.0) THEN
1328  kgds(9) = - iand(kgds(9),8388607)
1329  END IF
1330 C ------------------- BYTE 27 PROJECTION CENTER FLAG
1331  kgds(10) = mova2i(msga(iss+26))
1332 C ------------------- BYTE 28 SCANNING MODE
1333  kgds(11) = mova2i(msga(iss+27))
1334 C ------------------- BYTE 29-32 RESERVED
1335 C -------------------
1336  GO TO 900
1337 C
1338 C ------------------- GRID DESCRIPTION FOR SPHERICAL HARMONIC COEFF.
1339 C
1340 C ------------------- BYTE 7-8 J PENTAGONAL RESOLUTION PARAMETER
1341  3000 kgds(2) = 0
1342  DO 3010 i = 0, 1
1343  kgds(2) = kgds(2) * 256 + mova2i(msga(i+iss+6))
1344  3010 CONTINUE
1345 C ------------------- BYTE 9-10 K PENTAGONAL RESOLUTION PARAMETER
1346  kgds(3) = 0
1347  DO 3020 i = 0, 1
1348  kgds(3) = kgds(3) * 256 + mova2i(msga(i+iss+8))
1349  3020 CONTINUE
1350 C ------------------- BYTE 11-12 M PENTAGONAL RESOLUTION PARAMETER
1351  kgds(4) = 0
1352  DO 3030 i = 0, 1
1353  kgds(4) = kgds(4) * 256 + mova2i(msga(i+iss+10))
1354  3030 CONTINUE
1355 C ------------------- BYTE 13 REPRESENTATION TYPE
1356  kgds(5) = mova2i(msga(iss+12))
1357 C ------------------- BYTE 14 COEFFICIENT STORAGE MODE
1358  kgds(6) = mova2i(msga(iss+13))
1359 C ------------------- EMPTY FIELDS - BYTES 15 - 32
1360  kret = 0
1361  GO TO 900
1362 C ------------------- PROCESS MERCATOR GRIDS
1363 C
1364 C ------------------- BYTE 7-8 NR OF POINTS ALONG LATITUDE CIRCLE
1365  4000 kgds(2) = 0
1366  DO 4005 i = 0, 1
1367  kgds(2) = kgds(2) * 256 + mova2i(msga(i+iss+6))
1368  4005 CONTINUE
1369 C ------------------- BYTE 9-10 NR OF POINTS ALONG LONG MERIDIAN
1370  kgds(3) = 0
1371  DO 4010 i = 0, 1
1372  kgds(3) = kgds(3) * 256 + mova2i(msga(i+iss+8))
1373  4010 CONTINUE
1374 C ------------------- BYTE 11-13 LATITUE OF ORIGIN
1375  kgds(4) = 0
1376  DO 4020 i = 0, 2
1377  kgds(4) = kgds(4) * 256 + mova2i(msga(i+iss+10))
1378  4020 CONTINUE
1379  IF (iand(kgds(4),8388608).NE.0) THEN
1380  kgds(4) = - iand(kgds(4),8388607)
1381  END IF
1382 C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN
1383  kgds(5) = 0
1384  DO 4030 i = 0, 2
1385  kgds(5) = kgds(5) * 256 + mova2i(msga(i+iss+13))
1386  4030 CONTINUE
1387  IF (iand(kgds(5),8388608).NE.0) THEN
1388  kgds(5) = - iand(kgds(5),8388607)
1389  END IF
1390 C ------------------- BYTE 17 RESOLUTION FLAG
1391  kgds(6) = mova2i(msga(iss+16))
1392 C ------------------- BYTE 18-20 LATITUDE OF EXTREME POINT
1393  kgds(7) = 0
1394  DO 4040 i = 0, 2
1395  kgds(7) = kgds(7) * 256 + mova2i(msga(i+iss+17))
1396  4040 CONTINUE
1397  IF (iand(kgds(7),8388608).NE.0) THEN
1398  kgds(7) = - iand(kgds(7),8388607)
1399  END IF
1400 C ------------------- BYTE 21-23 LONGITUDE OF EXTREME POINT
1401  kgds(8) = 0
1402  DO 4050 i = 0, 2
1403  kgds(8) = kgds(8) * 256 + mova2i(msga(i+iss+20))
1404  4050 CONTINUE
1405  IF (iand(kgds(8),8388608).NE.0) THEN
1406  kgds(8) = - iand(kgds(8),8388607)
1407  END IF
1408 C ------------------- BYTE 24-25 LONGITUDE DIR INCREMENT
1409  kgds(9) = 0
1410  DO 4070 i = 0, 1
1411  kgds(9) = kgds(9) * 256 + mova2i(msga(i+iss+23))
1412  4070 CONTINUE
1413  IF (iand(kgds(9),8388608).NE.0) THEN
1414  kgds(9) = - iand(kgds(9),32768)
1415  END IF
1416 C ------------------- BYTE 26-27 LATIT DIR INCREMENT
1417  kgds(10) = 0
1418  DO 4080 i = 0, 1
1419  kgds(10) = kgds(10) * 256 + mova2i(msga(i+iss+25))
1420  4080 CONTINUE
1421  IF (iand(kgds(10),8388608).NE.0) THEN
1422  kgds(10) = - iand(kgds(10),32768)
1423  END IF
1424 C ------------------- BYTE 28 SCANNING MODE FLAGS
1425  kgds(11) = mova2i(msga(iss+27))
1426 C ------------------- BYTE 29-31 INTERSECTION LATITUDE
1427  kgds(12) = 0
1428  DO 4060 i = 0, 2
1429  kgds(12)= kgds(12) * 256 + mova2i(msga(i+iss+28))
1430  4060 CONTINUE
1431 C ------------------- BYTE 32 RESERVED
1432 C -------------------
1433  GO TO 900
1434 C ------------------- PROCESS LAMBERT CONFORMAL
1435 C
1436 C ------------------- BYTE 7-8 NR OF POINTS ALONG X-AXIS
1437  5000 kgds(2) = 0
1438  DO 5005 i = 0, 1
1439  kgds(2) = kgds(2) * 256 + mova2i(msga(i+iss+6))
1440  5005 CONTINUE
1441 C ------------------- BYTE 9-10 NR OF POINTS ALONG Y-AXIS
1442  kgds(3) = 0
1443  DO 5010 i = 0, 1
1444  kgds(3) = kgds(3) * 256 + mova2i(msga(i+iss+8))
1445  5010 CONTINUE
1446 C ------------------- BYTE 11-13 LATITUDE OF ORIGIN
1447  kgds(4) = 0
1448  DO 5020 i = 0, 2
1449  kgds(4) = kgds(4) * 256 + mova2i(msga(i+iss+10))
1450  5020 CONTINUE
1451  IF (iand(kgds(4),8388608).NE.0) THEN
1452  kgds(4) = - iand(kgds(4),8388607)
1453  END IF
1454 C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN (LOWER LEFT)
1455  kgds(5) = 0
1456  DO 5030 i = 0, 2
1457  kgds(5) = kgds(5) * 256 + mova2i(msga(i+iss+13))
1458  5030 CONTINUE
1459  IF (iand(kgds(5),8388608).NE.0) THEN
1460  kgds(5) = - iand(kgds(5),8388607)
1461  END IF
1462 C ------------------- BYTE 17 RESERVED
1463 C KGDS(6) =
1464 C ------------------- BYTE 18-20 LOV -ORIENTATION OF GRID
1465  kgds(7) = 0
1466  DO 5040 i = 0, 2
1467  kgds(7) = kgds(7) * 256 + mova2i(msga(i+iss+17))
1468  5040 CONTINUE
1469  IF (iand(kgds(7),8388608).NE.0) THEN
1470  kgds(7) = - iand(kgds(7),8388607)
1471  END IF
1472 C ------------------- BYTE 21-23 DX - X-DIR INCREMENT
1473  kgds(8) = 0
1474  DO 5060 i = 0, 2
1475  kgds(8) = kgds(8) * 256 + mova2i(msga(i+iss+20))
1476  5060 CONTINUE
1477 C ------------------- BYTE 24-26 DY - Y-DIR INCREMENT
1478  kgds(9) = 0
1479  DO 5070 i = 0, 2
1480  kgds(9) = kgds(9) * 256 + mova2i(msga(i+iss+23))
1481  5070 CONTINUE
1482 C ------------------- BYTE 27 PROJECTION CENTER FLAG
1483  kgds(10) = mova2i(msga(iss+26))
1484 C ------------------- BYTE 28 SCANNING MODE
1485  kgds(11) = mova2i(msga(iss+27))
1486 C ------------------- BYTE 29-31 LATIN1 - 1ST LAT FROM POLE
1487  kgds(12) = 0
1488  DO 5050 i = 0, 2
1489  kgds(12)= kgds(12)* 256 + mova2i(msga(i+iss+28))
1490  5050 CONTINUE
1491  IF (iand(kgds(12),8388608).NE.0) THEN
1492  kgds(12) = - iand(kgds(12),8388607)
1493  END IF
1494 C ------------------- BYTE 32-34 LATIN2 - 2ND LAT FROM POLE
1495  kgds(13) = 0
1496  DO 5055 i = 0, 2
1497  kgds(13)= kgds(13)* 256 + mova2i(msga(i+iss+31))
1498  5055 CONTINUE
1499  IF (iand(kgds(13),8388608).NE.0) THEN
1500  kgds(13) = - iand(kgds(13),8388607)
1501  END IF
1502 C -------------------
1503  900 CONTINUE
1504  RETURN
1505  END
1506 
1507 C> If bit map sec is available in grib message,extract
1508 C> for program use, otherwise generate an appropriate bit map.
1509 C>
1510 C> Program history log:
1511 C> - Bill Cavanaugh 1988-01-20
1512 C> - Bill Cavanaugh 1989-02-24 Increment of position in bit map when bit map was included was handled improperly. corrected this data.
1513 C> - Bill Cavanaugh 1989-07-12 Altered method of calculating nr of bits in a bit map contained in grib message.
1514 C> - Bill Cavanaugh 1990-05-07 Brings all u.s. grids to revised values as of dec 89.
1515 C> - William Bostelman 1990-07-15 Modiifed to test the grib bds byte size to determine what ecmwf grid array size is to be specified.
1516 C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
1517 C> - Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
1518 C>
1519 C> @param[in] MSGA BUFR message.
1520 C> @param[inout] KPTR Array containing storage for following parameters.
1521 C> - 1: Unused.
1522 C> - 2: Unused.
1523 C> - 3: Length of pds.
1524 C> - 4: Length of gds.
1525 C> - 5: Length of bms.
1526 C> - 6: Length of bds.
1527 C> - 7: Value of current byte.
1528 C> - 8: Unused.
1529 C> - 9: Grib start byte nr.
1530 C> - 10: Grib/grid element count.
1531 C> @param[in] KPDS ARRAY CONTAINING PDS ELEMENTS.
1532 C> - 1: Id of center.
1533 C> - 2: Model identification.
1534 C> - 3: Grid identification.
1535 C> - 4: Gds/bms flag.
1536 C> - 5: Indicator of parameter.
1537 C> - 6: Type of level.
1538 C> - 7: Height/pressure , etc of level.
1539 C> - 8: Year of century.
1540 C> - 9: Month of year.
1541 C> - 10: Day of month.
1542 C> - 11: Hour of day.
1543 C> - 12: Minute of hour.
1544 C> - 13: Indicator of forecast time unit.
1545 C> - 14: Time range 1.
1546 C> - 15: Time range 2.
1547 C> - 16: Time range flag.
1548 C> - 17: Number included in average.
1549 C> - 18: Version nr of grib specification.
1550 C> @param[out] kgds array containing gds elements.
1551 C> - 1: data representation type
1552 C> - Latitude/longitude grids
1553 C> - 2: n(i) nr points on latitude circle
1554 C> - 3: n(j) nr points on longitude meridian
1555 C> - 4: la(1) latitude of origin
1556 C> - 5: lo(1) longitude of origin
1557 C> - 6: resolution flag
1558 C> - 7: la(2) latitude of extreme point
1559 C> - 8: lo(2) longitude of extreme point
1560 C> - 9: di longitudinal direction of increment
1561 C> - 10: dj latitundinal direction of increment
1562 C> - 11: scanning mode flag
1563 C> - Polar stereographic grids
1564 C> - 2: n(i) nr points along lat circle
1565 C> - 3: n(j) nr points along lon circle
1566 C> - 4: la(1) latitude of origin
1567 C> - 5: lo(1) longitude of origin
1568 C> - 6: reserved
1569 C> - 7: lov grid orientation
1570 C> - 8: dx - x direction increment
1571 C> - 9: dy - y direction increment
1572 C> - 10: projection center flag
1573 C> - 11: scanning mode
1574 C> - Spherical harmonic coefficients
1575 C> - 2: j pentagonal resolution parameter
1576 C> - 3: k pentagonal resolution parameter
1577 C> - 4: m pentagonal resolution parameter
1578 C> - 5: representation type
1579 C> - 6: coefficient storage mode
1580 C> - Mercator grids
1581 C> - 2: n(i) nr points on latitude circle
1582 C> - 3: n(j) nr points on longitude meridian
1583 C> - 4: la(1) latitude of origin
1584 C> - 5: lo(1) longitude of origin
1585 C> - 6: resolution flag
1586 C> - 7: la(2) latitude of last grid point
1587 C> - 8: lo(2) longitude of last grid point
1588 C> - 9: longit dir increment
1589 C> - 10: latit dir increment
1590 C> - 11: scanning mode flag
1591 C> - 12: latitude intersection
1592 C> - Lambert conformal grids
1593 C> - 2: nx nr points along x-axis
1594 C> - 3: ny nr points along y-axis
1595 C> - 4: la1 lat of origin (lower left)
1596 C> - 5: lo1 lon of origin (lower left)
1597 C> - 6: reserved
1598 C> - 7: lov - orientation of grid
1599 C> - 8: dx - x-dir increment
1600 C> - 9: dy - y-dir increment
1601 C> - 10: projection center flag
1602 C> - 11: scanning mode flag
1603 C> - 12: latin 1 - first lat from pole of secant cone inter
1604 C> - 13: latin 2 - second lat from pole of secant cone inter
1605 C> @param[out] KBMS Bitmap describing location of output elements..
1606 C> @param[out] KRET Error return.
1607 C>
1608 C> @note KRET
1609 C> - = 0 - No error.
1610 C> - = 5 - Grid not avail for center indicated.
1611 C> - = 10 - Incorrect center indicator.
1612 C>
1613 C> @author Bill Cavanaugh @date 1988-01-20
1614  SUBROUTINE ai084(MSGA,KPTR,KPDS,KGDS,KBMS,KRET)
1615 C
1616 C INCOMING MESSAGE HOLDER
1617  CHARACTER*1 MSGA(*)
1618 C
1619 C BIT MAP
1620  LOGICAL KBMS(*)
1621 C
1622 C ARRAY OF POINTERS AND COUNTERS
1623  INTEGER KPTR(10)
1624 C ARRAY OF POINTERS AND COUNTERS
1625  INTEGER KPDS(20)
1626  INTEGER KGDS(13)
1627 C
1628  INTEGER KRET
1629  INTEGER MASK(8)
1630 C ----------------------GRID 21 AND GRID 22 ARE THE SAME
1631  LOGICAL GRD21( 1369)
1632 C ----------------------GRID 23 AND GRID 24 ARE THE SAME
1633  LOGICAL GRD23( 1369)
1634  LOGICAL GRD25( 1368)
1635  LOGICAL GRD26( 1368)
1636 C ----------------------GRID 27 AND GRID 28 ARE THE SAME
1637 C ----------------------GRID 29 AND GRID 30 ARE THE SAME
1638 C ----------------------GRID 33 AND GRID 34 ARE THE SAME
1639  LOGICAL GRD50(1188)
1640 C -----------------------GRID 61 AND GRID 62 ARE THE SAME
1641  LOGICAL GRD61( 4186)
1642 C -----------------------GRID 63 AND GRID 64 ARE THE SAME
1643  LOGICAL GRD63( 4186)
1644 C
1645  DATA grd21 /1333*.true.,36*.false./
1646  DATA grd23 /.true.,36*.false.,1332*.true./
1647  DATA grd25 /1297*.true.,71*.false./
1648  DATA grd26 /.true.,71*.false.,1296*.true./
1649  DATA grd50/
1650 C LINE 1-4
1651  & 7*.false.,22*.true.,14*.false.,22*.true.,
1652  & 14*.false.,22*.true.,14*.false.,22*.true.,7*.false.,
1653 C LINE 5-8
1654  & 6*.false.,24*.true.,12*.false.,24*.true.,
1655  & 12*.false.,24*.true.,12*.false.,24*.true.,6*.false.,
1656 C LINE 9-12
1657  & 5*.false.,26*.true.,10*.false.,26*.true.,
1658  & 10*.false.,26*.true.,10*.false.,26*.true.,5*.false.,
1659 C LINE 13-16
1660  & 4*.false.,28*.true., 8*.false.,28*.true.,
1661  & 8*.false.,28*.true., 8*.false.,28*.true.,4*.false.,
1662 C LINE 17-20
1663  & 3*.false.,30*.true., 6*.false.,30*.true.,
1664  & 6*.false.,30*.true., 6*.false.,30*.true.,3*.false.,
1665 C LINE 21-24
1666  & 2*.false.,32*.true., 4*.false.,32*.true.,
1667  & 4*.false.,32*.true., 4*.false.,32*.true.,2*.false.,
1668 C LINE 25-28
1669  & .false.,34*.true., 2*.false.,34*.true.,
1670  & 2*.false.,34*.true., 2*.false.,34*.true., .false.,
1671 C LINE 29-33
1672  & 180*.true./
1673  DATA grd61 /4096*.true.,90*.false./
1674  DATA grd63 /.true.,90*.false.,4095*.true./
1675  DATA mask /128,64,32,16,8,4,2,1/
1676 C DATA MSK40 /Z00000040/
1677  DATA msk40 /64/
1678 C
1679  is = kptr(9)
1680  IF (kpds(18).EQ.0) THEN
1681  igribl = 4
1682  ELSE
1683  igribl = 8
1684  ENDIF
1685  iss = is + kptr(3) + kptr(4) + igribl
1686 C **********************************************************
1687 C IF THE FLAG IN PDS INDICATES THAT THERE IS NO BMS,
1688 C SET BIT MAP WITH ALL BITS ON
1689 C ELSE
1690 C RECOVER BIT MAP
1691 C THEN RETURN
1692 C **********************************************************
1693 C ---------------- NON-STANDARD GRID
1694  IF (kpds(3).EQ.255) THEN
1695  j = kgds(2) * kgds(3)
1696  kptr(10) = j
1697  DO 600 i = 1, j
1698  kbms(i) = .true.
1699  600 CONTINUE
1700  END IF
1701  IF (iand(kpds(4),msk40).EQ.0)THEN
1702 C PRINT *,' NO BIT MAP',MSK40,KPDS(4)
1703  GO TO 400
1704  ELSE
1705  print *,' HAVE A BIT MAP'
1706  END IF
1707 C ---------------- FLAG INDICATING PRESENCE OF BIT MAP IS ON
1708  IF (kgds(1).EQ.50) THEN
1709  print *,' W3AI08/AI084 WARNING - BIT MAP MAY NOT BE',
1710  * ' ASSOCIATED WITH SPHERICAL COEFFICIENTS'
1711  RETURN
1712  ENDIF
1713 C GET NUMBER OF UNUSED BITS
1714  iubits = mova2i(msga(iss+3))
1715 C SEE IF BIT MAP IS CONTAINED
1716  kflag = 0
1717  DO 150 i = 0, 1
1718  kflag = kflag * 256 + mova2i(msga(i+iss+4))
1719  150 CONTINUE
1720  print *,'KFLAG=',kflag
1721 C ----------------- IF KFLAG = 0 PICK UP NEW BIT MAP
1722 C ELSE
1723 C ------------------ USE PREDEFINED BIT MAP
1724  maxbyt = kptr(5) - 6
1725  IF (kflag.EQ.0) THEN
1726 C ------------------ UTILIZE BIT MAP FROM MESSAGE
1727  ii = 1
1728  DO 300 i = 1, maxbyt
1729  kcnt = mova2i(msga(i+iss+6))
1730  DO 200 k = 1, 8
1731  IF (iand(kcnt,mask(k)).NE.0) THEN
1732  kbms(ii) = .true.
1733  ELSE
1734  kbms(ii) = .false.
1735  END IF
1736  ii = ii + 1
1737  200 CONTINUE
1738  300 CONTINUE
1739  kptr(10) = 8 * (kptr(5) - 6) - iubits
1740  GO TO 900
1741  ELSE
1742  print *,'KFLAG SAYS USE STD BIT MAP',kflag
1743  END IF
1744 C ---------------------- PREDEFINED BIT MAP IS INDICATED
1745 C IF GRID NUMBER DOES NOT MATCH AN
1746 C EXISTING GRID, SET KRET TO 5 AND
1747 C ---------------------- RETURN.
1748  400 CONTINUE
1749  kret = 0
1750 C ---------------------- ECMWF MAP GRIDS
1751  IF (kpds(1).EQ.98) THEN
1752  IF (kpds(3).GE.1.AND.kpds(3).LE.12) THEN
1753  j = 1073
1754 C*** TEST FOR FULL HEMISPHERIC GRID ****
1755  IF (kptr(6) .GT. 2158) j= 1369
1756 C*** *** **** *** ***
1757  kptr(10) = j
1758  CALL ai087(*900,j,kpds,kgds,kret)
1759  DO 1000 i = 1, j
1760  kbms(i) = .true.
1761  1000 CONTINUE
1762  ELSE IF (kpds(3).GE.13.AND.kpds(3).LE.16) THEN
1763  j = 361
1764  kptr(10) = j
1765  CALL ai087(*900,j,kpds,kgds,kret)
1766  DO 1013 i = 1, j
1767  kbms(i) = .true.
1768  1013 CONTINUE
1769  ELSE
1770  kret = 5
1771  RETURN
1772  END IF
1773 C ---------------------- U.K. MET OFFICE BRACKNELL
1774  ELSE IF (kpds(1).EQ.74) THEN
1775  IF (kpds(3).EQ.21.OR.kpds(3).EQ.22) THEN
1776 C ----- INT'L GRIDS 21, 22 - MAP SIZE 1369
1777  j = 1369
1778  kptr(10) = j
1779  CALL ai087(*900,j,kpds,kgds,kret)
1780  DO 3021 i = 1, 1369
1781  kbms(i) = grd21(i)
1782  3021 CONTINUE
1783  ELSE IF (kpds(3).EQ.23.OR.kpds(3).EQ.24) THEN
1784 C ----- INT'L GRIDS 23, 24 - MAP SIZE 1369
1785  j = 1369
1786  kptr(10) = j
1787  CALL ai087(*900,j,kpds,kgds,kret)
1788  DO 3023 i = 1, 1369
1789  kbms(i) = grd23(i)
1790  3023 CONTINUE
1791  ELSE IF (kpds(3).EQ.25) THEN
1792 C ----- INT'L GRID 25 - MAP SIZE 1368
1793  j = 1368
1794  kptr(10) = j
1795  CALL ai087(*900,j,kpds,kgds,kret)
1796  DO 3025 i = 1, 1368
1797  kbms(i) = grd25(i)
1798  3025 CONTINUE
1799  ELSE IF (kpds(3).EQ.26) THEN
1800 C ----- INT'L GRID 26 - MAP SIZE 1368
1801  j = 1368
1802  kptr(10) = j
1803  CALL ai087(*900,j,kpds,kgds,kret)
1804  DO 3026 i = 1, 1368
1805  kbms(i) = grd26(i)
1806  3026 CONTINUE
1807  ELSE IF (kpds(3).EQ.61.OR.kpds(3).EQ.62) THEN
1808 C ----- INT'L GRIDS 61, 62 - MAP SIZE 4186
1809  j = 4186
1810  kptr(10) = j
1811  CALL ai087(*900,j,kpds,kgds,kret)
1812  DO 3061 i = 1, 4186
1813  kbms(i) = grd61(i)
1814  3061 CONTINUE
1815  ELSE IF (kpds(3).EQ.63.OR.kpds(3).EQ.64) THEN
1816 C ----- INT'L GRIDS 63, 64 - MAP SIZE 4186
1817  j = 4186
1818  kptr(10) = j
1819  CALL ai087(*900,j,kpds,kgds,kret)
1820  DO 3063 i = 1, 4186
1821  kbms(i) = grd63(i)
1822  3063 CONTINUE
1823  ELSE IF (kpds(3).EQ.70) THEN
1824 C ----- U.S. GRID 70 - MAP SIZE 16380
1825  j = 16380
1826  kptr(10) = j
1827  CALL ai087(*900,j,kpds,kgds,kret)
1828  DO 3070 i = 1, j
1829  kbms(i) = .true.
1830  3070 CONTINUE
1831  ELSE
1832  kret = 5
1833  RETURN
1834  END IF
1835 C ---------------------- FNOC NAVY
1836  ELSE IF (kpds(1).EQ.58) THEN
1837  print *,' NO STANDARD FNOC GRID AT THIS TIME'
1838  RETURN
1839 C ---------------------- U.S. GRIDS
1840  ELSE IF (kpds(1).EQ.7) THEN
1841  IF (kpds(3).EQ.5) THEN
1842 C ----- U.S. GRID 5 - MAP SIZE 3021
1843  j = 3021
1844  kptr(10) = j
1845  CALL ai087(*900,j,kpds,kgds,kret)
1846  DO 2005 i = 1, j
1847  kbms(i) = .true.
1848  2005 CONTINUE
1849  ELSE IF (kpds(3).EQ.6) THEN
1850 C ----- U.S. GRID 6 - MAP SIZE 2385
1851  j = 2385
1852  kptr(10) = j
1853  CALL ai087(*900,j,kpds,kgds,kret)
1854  DO 2006 i = 1, j
1855  kbms(i) = .true.
1856  2006 CONTINUE
1857  ELSE IF (kpds(3).EQ.21.OR.kpds(3).EQ.22) THEN
1858 C ----- U.S. GRIDS 21, 22 - MAP SIZE 1369
1859  j = 1369
1860  kptr(10) = j
1861  CALL ai087(*900,j,kpds,kgds,kret)
1862  DO 2021 i = 1, 1369
1863  kbms(i) = grd21(i)
1864  2021 CONTINUE
1865  ELSE IF (kpds(3).EQ.23.OR.kpds(3).EQ.24) THEN
1866 C ----- U.S GRIDS 23, 24 - MAP SIZE 1369
1867  j = 1369
1868  kptr(10) = j
1869  CALL ai087(*900,j,kpds,kgds,kret)
1870  DO 2023 i = 1, 1369
1871  kbms(i) = grd23(i)
1872  2023 CONTINUE
1873  ELSE IF (kpds(3).EQ.25) THEN
1874 C ----- U.S. GRID 25 - MAP SIZE 1368
1875  j = 1368
1876  kptr(10) = j
1877  CALL ai087(*900,j,kpds,kgds,kret)
1878  DO 2025 i = 1, 1368
1879  kbms(i) = grd25(i)
1880  2025 CONTINUE
1881  ELSE IF (kpds(3).EQ.26) THEN
1882 C ----- U.S.GRID 26 - MAP SIZE 1368
1883  j = 1368
1884  kptr(10) = j
1885  CALL ai087(*900,j,kpds,kgds,kret)
1886  DO 2026 i = 1, 1368
1887  kbms(i) = grd26(i)
1888  2026 CONTINUE
1889  ELSE IF (kpds(3).EQ.27.OR.kpds(3).EQ.28) THEN
1890 C ----- U.S. GRIDS 27, 28 - MAP SIZE 4225
1891  j = 4225
1892  kptr(10) = j
1893  CALL ai087(*900,j,kpds,kgds,kret)
1894  DO 2027 i = 1, j
1895  kbms(i) = .true.
1896  2027 CONTINUE
1897  ELSE IF (kpds(3).EQ.29.OR.kpds(3).EQ.30)THEN
1898 C ----- U.S. GRIDS 29,30 - MAP SIZE 5365
1899  j = 5365
1900  kptr(10) = j
1901  CALL ai087(*900,j,kpds,kgds,kret)
1902  DO 2029 i = 1, j
1903  kbms(i) = .true.
1904  2029 CONTINUE
1905  ELSE IF (kpds(3).EQ.33.OR.kpds(3).EQ.34) THEN
1906 C ----- U.S GRID 33, 34 - MAP SIZE 8326 (181 X 46)
1907  j = 8326
1908  kptr(10) = j
1909  CALL ai087(*900,j,kpds,kgds,kret)
1910  DO 2033 i = 1, j
1911  kbms(i) = .true.
1912  2033 CONTINUE
1913  ELSE IF (kpds(3).EQ.50) THEN
1914 C ----- U.S. GRID 50 - MAP SIZE 964
1915  j = 1188
1916  kptr(10) = j
1917  CALL ai087(*900,j,kpds,kgds,kret)
1918  DO 2050 i = 1, 1188
1919  kbms(i) = grd50(i)
1920  2050 CONTINUE
1921  ELSE IF (kpds(3).EQ.61.OR.kpds(3).EQ.62) THEN
1922 C ----- U.S. GRIDS 61, 62 - MAP SIZE 4186
1923  j = 4186
1924  kptr(10) = j
1925  CALL ai087(*900,j,kpds,kgds,kret)
1926  DO 2061 i = 1, 4186
1927  kbms(i) = grd61(i)
1928  2061 CONTINUE
1929  ELSE IF (kpds(3).EQ.63.OR.kpds(3).EQ.64) THEN
1930 C ----- U.S. GRIDS 63, 64 - MAP SIZE 4186
1931  j = 4186
1932  kptr(10) = j
1933  CALL ai087(*900,j,kpds,kgds,kret)
1934  DO 2063 i = 1, 4186
1935  kbms(i) = grd63(i)
1936  2063 CONTINUE
1937  ELSE IF (kpds(3).EQ.70) THEN
1938 C ----- U.S. GRID 70 - MAP SIZE 16380
1939  j = 16380
1940  kptr(10) = j
1941  CALL ai087(*900,j,kpds,kgds,kret)
1942  DO 2070 i = 1, j
1943  kbms(i) = .true.
1944  2070 CONTINUE
1945  ELSE IF (kpds(3).EQ.85.OR.kpds(3).EQ.86) THEN
1946 C ----- U.S. GRIDS 85, 86 - MAP SIZE 32400 (360 X 90)
1947  j = 32400
1948  kptr(10) = j
1949  CALL ai087(*900,j,kpds,kgds,kret)
1950  DO 2085 i = 1, j
1951  kbms(i) = .true.
1952  2085 CONTINUE
1953  ELSE IF (kpds(3).EQ.100) THEN
1954 C ----- U.S. GRID 100 - MAP SIZE 6889 (83 X 83)
1955  j = 6889
1956  kptr(10) = j
1957  CALL ai087(*900,j,kpds,kgds,kret)
1958  DO 1100 i = 1, j
1959  kbms(i) = .true.
1960  1100 CONTINUE
1961  ELSE IF (kpds(3).EQ.101) THEN
1962 C ----- U.S. GRID 101 - MAP SIZE 10283 (113 X 91)
1963  j = 10283
1964  kptr(10) = j
1965  CALL ai087(*900,j,kpds,kgds,kret)
1966  DO 2101 i = 1, j
1967  kbms(i) = .true.
1968  2101 CONTINUE
1969  ELSE IF (kpds(3).EQ.102) THEN
1970 C ----- U.S. GRID 102 - MAP SIZE 14375 (115 X 125)
1971  j = 14375
1972  kptr(10) = j
1973  CALL ai087(*900,j,kpds,kgds,kret)
1974  DO 2102 i = 1, j
1975  kbms(i) = .true.
1976  2102 CONTINUE
1977  ELSE IF (kpds(3).EQ.103) THEN
1978 C ----- U.S. GRID 103 - MAP SIZE 3640 (65 X 56)
1979  j = 3640
1980  kptr(10) = j
1981  CALL ai087(*900,j,kpds,kgds,kret)
1982  DO 2103 i = 1, j
1983  kbms(i) = .true.
1984  2103 CONTINUE
1985  ELSE IF (kpds(3).GE.201.AND.kpds(3).LE.214) THEN
1986  IF (kpds(3).EQ.201) j = 4225
1987  IF (kpds(3).EQ.202) j = 2795
1988  IF (kpds(3).EQ.203) j = 1755
1989  IF (kpds(3).EQ.204) j = 5609
1990  IF (kpds(3).EQ.205) j = 1755
1991  IF (kpds(3).EQ.206) j = 2091
1992  IF (kpds(3).EQ.207) j = 1715
1993  IF (kpds(3).EQ.208) j = 625
1994  IF (kpds(3).EQ.209) j = 8181
1995  IF (kpds(3).EQ.210) j = 625
1996  IF (kpds(3).EQ.211) j = 2915
1997  IF (kpds(3).EQ.212) j = 4225
1998  IF (kpds(3).EQ.213) j = 10965
1999  IF (kpds(3).EQ.214) j = 6693
2000  kptr(10) = j
2001  CALL ai087(*900,j,kpds,kgds,kret)
2002  DO 2201 i = 1, j
2003  kbms(i) = .true.
2004  2201 CONTINUE
2005  ELSE
2006  kret = 5
2007  RETURN
2008  END IF
2009  ELSE
2010  kret = 10
2011  RETURN
2012  END IF
2013  900 CONTINUE
2014  RETURN
2015  END
2016 
2017 C> Extract grib data and place into output arry in proper position.
2018 C>
2019 C> Program history log:
2020 C> - Bill Cavanaugh 1988-01-20
2021 C> - Ralph Jones 1990-09-01 Change's for ansi fortran.
2022 C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
2023 C> - Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
2024 C>
2025 C> @param[in] MSGA Array containing grib message.
2026 C> @param[inout] KPTR Array containing storage for following parameters.
2027 C> - 1: Unused.
2028 C> - 2: Unused.
2029 C> - 3: Length of pds.
2030 C> - 4: Length of gds.
2031 C> - 5: Length of bms.
2032 C> - 6: Length of bds.
2033 C> - 7: Value of current byte.
2034 C> - 8: Unused.
2035 C> - 9: Grib start byte nr.
2036 C> - 10: Grib/grid element count.
2037 C> @param[in] KPDS Array containing pds elements.
2038 C> - 1: Id of center.
2039 C> - 2: Model identification.
2040 C> - 3: Grid identification.
2041 C> - 4: Gds/bms flag.
2042 C> - 5: Indicator of parameter.
2043 C> - 6: Type of level.
2044 C> - 7: Height/pressure , etc of level.
2045 C> - 8: Year of century.
2046 C> - 9: Month of year.
2047 C> - 10: Day of month.
2048 C> - 11: Hour of day.
2049 C> - 12: Minute of hour.
2050 C> - 13: Indicator of forecast time unit.
2051 C> - 14: Time range 1.
2052 C> - 15: Time range 2.
2053 C> - 16: Time range flag.
2054 C> - 17: Number included in average.
2055 C> - 18: Version nr of grib specification.
2056 C> @param[in] KBMS Bitmap describing location of output elements.
2057 C> @param[out] DATA Real array of gridded elements in grib message.
2058 C> @param[out] KRET Error return.
2059 C>
2060 C> @note Error return.
2061 C> - 3 = Unpacked field is larger than 32768.
2062 C> - 6 = Does not match nr of entries for this grib/grid.
2063 C> - 7 = Number of bits in fill too large.
2064 C>
2065 C> @author Bill Cavanaugh @date 1988-01-20
2066  SUBROUTINE ai085(MSGA,KPTR,KPDS,KBMS,DATA,KRET)
2067 C *************************************************************
2068  CHARACTER*1 MSGA(*)
2069  CHARACTER*1 KREF(8)
2070  CHARACTER*1 KK(8)
2071 C
2072  LOGICAL KBMS(*)
2073 C
2074  INTEGER KPDS(*)
2075  INTEGER KPTR(*)
2076  INTEGER NRBITS
2077  INTEGER KSAVE(105000)
2078  INTEGER KSCALE
2079 C
2080  REAL DATA(*)
2081  REAL REFNCE
2082  REAL SCALE
2083  REAL REALKK
2084 C
2085  LOGICAL IBM370
2086 C
2087  equivalence(refnce,kref(1),iref)
2088  equivalence(kk(1),realkk,ikk)
2089 C
2090 C DATA MSK0F /Z0000000F/
2091 C DATA MSK80 /Z00000080/
2092 C DATA MSK40 /Z00000040/
2093 C
2094  DATA msk0f /15/
2095  DATA msk80 /128/
2096  DATA msk40 /64/
2097 C
2098 C *************************************************************
2099  kret = 0
2100  is = kptr(9)
2101  iss = is + kptr(3) + kptr(4) + kptr(5) + 4
2102 C BYTE 4
2103  kspl = mova2i(msga(iss+3))
2104 C POINT TO BYTE 5 OF BDS
2105 C
2106 C ------------- GET SCALE FACTOR
2107 C
2108  kscale = 0
2109  DO 100 i = 0, 1
2110  kscale = kscale * 256 + mova2i(msga(i+iss+4))
2111  100 CONTINUE
2112  IF (iand(kscale,32768).NE.0) THEN
2113  kscale = - iand(kscale,32767)
2114  END IF
2115  scale = 2.0**kscale
2116 C
2117 C ------------ GET REFERENCE VALUE
2118 C
2119  iref = 0
2120  DO 200 i = 0, 3
2121  kref(i+1) = msga(i+iss+6)
2122  200 CONTINUE
2123 C
2124 C THE FLOATING POINT NUMBER IN THE REFERENCE VALUE IS AN IBM370
2125 C 32 BIT NUMBER, IF YOUR COMPUTER IS NOT AN IBM370 OR CLONE
2126 C SET IBM370 TO .FALSE. SO THE NUMBER IS CONVERTED TO A F.P.
2127 C NUMBER OF YOUR MACHINE TYPE.
2128 C
2129  ibm370 = .false.
2130 C
2131  IF (.NOT.ibm370) THEN
2132  koff = 0
2133 C GET 1 BIT SIGN
2134  CALL gbyte(iref,isgn,0,1)
2135 C GET 7 BIT EXPONENT
2136  CALL gbyte(iref,iexp,1,7)
2137 C GET 24 BIT FRACTION
2138  CALL gbyte(iref,ifr,8,24)
2139  IF (ifr.EQ.0.OR.iexp.EQ.0) THEN
2140  refnce = 0.0
2141  ELSE
2142  refnce = float(ifr) * 16.0 ** (iexp-64-6)
2143  IF (isgn.NE.0) refnce = - refnce
2144  ENDIF
2145  ENDIF
2146 C
2147 C ------------- NUMBER OF BITS SPECIFIED FOR EACH ENTRY
2148 C
2149  kbits = mova2i(msga(iss+10))
2150  kentry = kptr(10)
2151 C
2152 C ------------- MAX SIZE CHECK
2153 C
2154  IF (kentry.GT.105000) THEN
2155  kret = 3
2156  RETURN
2157  END IF
2158  IF (kbits.EQ.0) THEN
2159 C
2160 C -------------------- HAVE NO BDS ENTRIES, ALL ENTRIES = REFNCE
2161 C
2162  DO 210 i = 1, kentry
2163  DATA(i) = 0.0
2164  IF (kbms(i)) THEN
2165  DATA(i) = refnce
2166  END IF
2167  210 CONTINUE
2168  GO TO 900
2169  END IF
2170 C
2171 C --------------------
2172 C CYCLE THRU BDS UNTIL HAVE USED ALL (SPECIFIED NUMBER)
2173 C ENTRIES.
2174 C
2175 C ------------- UNUSED BITS IN DATA AREA
2176 C
2177  lessbt = iand(kspl,msk0f)
2178 C
2179 C ------------- NUMBER OF BYTES IN DATA AREA
2180 C
2181  nrbyte = kptr(6) - 11
2182 C
2183 C ------------- TOTAL NR OF USABLE BITS
2184 C
2185  nrbits = nrbyte * 8 - lessbt
2186 C
2187 C ------------- TOTAL NR OF ENTRIES
2188 C
2189  kentry = nrbits / kbits
2190 C
2191 C ------------- MAX SIZE CHECK
2192 C
2193  IF (kentry.GT.105000) THEN
2194  kret = 3
2195  RETURN
2196  END IF
2197 C
2198  ibms = iand(kpds(4),msk40)
2199 C
2200 C -------------- CHECK TO SEE IF PROCESSING COEFFICIENTS
2201 C IF YES,
2202 C GO AND PROCESS AS SUCH
2203 C ELSE
2204 C CONTINUE PROCESSING
2205 C
2206  IF (iand(kspl,msk80).EQ.0) THEN
2207 C
2208 C ------------- SET POINTERS
2209 C
2210 C XMOVEX MOVES THE DATA TO MAKE SURE IT IS ON A INTEGER WORD
2211 C BOUNDARY, ON SOME COMPUTERS THIS DOES NOT HAVE TO BE DONE.
2212 C (IBM PC, VAX)
2213 C
2214 C CALL XMOVEX(MSGB,MSGA(ISS+11),NRBYTE)
2215 C ------------- UNPACK ALL FIELDS
2216  koff = 0
2217 C
2218 C THE BIT UNPACKER W3AI41 WILL CONSUME MOST OF THE CPU TIME
2219 C CONVERTING THE GRIB DATA. FOR THE IBM370 WE HAVE AN
2220 C ASSEMBLER AND FORTRAN VERSION. THE ASSMBLER VERSION WILL
2221 C RUN TWO TO THREE TIMES FASTER. THE FORTRAN VERSION IS TO
2222 C MAKE THE CODE MORE PORTABLE. FOR A VAX OR IBM PC WE HAVE
2223 C ANOTHER VERSION, IT REVERSED THE ORDER OF THE BYTES IN
2224 C AN INTEGER WORD. W3AI41 CAN BE REPLACED BY NCAR GBYTES
2225 C BIT UNPACKER. NCAR HAS A LARGE NUMBER OF VERSIONS OF GBYTES
2226 C IN FORTRAN AN ASSEMBLER FOR A NUMBER OF DIFFERENT BRANDS OF
2227 C COMPUTERS. THEY ALSO HAVE A C VERSION.
2228 C
2229 C CALL W3AI41(MSGB,KSAVE,KBITS,KENTRY,KOFF)
2230 C
2231 C ALIGN CHARACTER ARRAY MSGA STARTING ADDRESS ON CRAY
2232 C INTEGER WORD BOUNDARY
2233 C
2234  lll = mod(iss+10,8)
2235  nnn = 11 - lll
2236  koff = lll * 8
2237  CALL gbytes(msga(iss+nnn),ksave,koff,kbits,0,kentry)
2238 C
2239 C ------------- CORRECTLY PLACE ALL ENTRIES
2240 C
2241  ii = 1
2242  kentry = kptr(10)
2243  DO 500 i = 1, kentry
2244  IF (kbms(i)) THEN
2245  DATA(i) = refnce + float(ksave(ii)) * scale
2246  ii = ii + 1
2247  ELSE
2248  DATA(i) = 0.0
2249  END IF
2250  500 CONTINUE
2251  GO TO 900
2252  END IF
2253 C
2254 C ------------- PROCESS SPHERICAL HARMONIC COEFFICIENTS
2255 C
2256  ikk = 0
2257  DO 5500 i = 0, 3
2258  kk(i+1) = msga(i+iss+11)
2259  5500 CONTINUE
2260 C
2261  IF (.NOT.ibm370) THEN
2262  koff = 0
2263 C GET 1 BIT SIGN
2264  CALL gbyte(ikk,isgn,0,1)
2265 C GET 7 BIT EXPONENT
2266  CALL gbyte(ikk,iexp,1,7)
2267 C GET 24 BIT FRACTION
2268  CALL gbyte(ikk,ifr,8,24)
2269  IF (ifr.EQ.0.OR.iexp.EQ.0) THEN
2270  realkk = 0.0
2271  ELSE
2272  realkk = float(ifr) * 16.0 ** (iexp-64-6)
2273  IF (isgn.NE.0) realkk = - realkk
2274  ENDIF
2275  ENDIF
2276 C
2277  DATA(1) = realkk
2278  koff = 0
2279 C CALL XMOVEX(MSGB,MSGA(ISS+15),NRBYTE)
2280 C ------------- UNPACK ALL FIELDS
2281 C
2282 C CALL W3AI41(MSGB,KSAVE,KBITS,KENTRY,KOFF)
2283 C
2284 C ALIGN CHARACTER ARRAY MSGA STARTING ADDRESS ON CRAY
2285 C INTEGER WORD BOUNDARY
2286 C
2287  lll = mod(iss+14,8)
2288  nnn = 15 - lll
2289  koff = lll * 8
2290 C
2291  CALL gbytes(msga(iss+nnn),ksave,koff,kbits,0,kentry)
2292 C
2293 C --------------
2294  DO 6000 i = 1, kentry
2295  DATA(i+1) = refnce + float(ksave(i)) * scale
2296  6000 CONTINUE
2297  900 CONTINUE
2298  RETURN
2299  END
2300 
2301 
2302 C> Extract grib data (version 1) and place into proper position in output array.
2303 C>
2304 C> Program history log:
2305 C> - Bill Cavanaugh 1989-11-20
2306 C> - Ralph Jones 1990-09-01 Change's for ansi fortran.
2307 C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
2308 C> - Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
2309 C>
2310 C> @param[in] MSGA Array containing grib message.
2311 C> @param[inout] KPTR Array containing storage for following parameters.
2312 C> - 1:Unused.
2313 C> - 2:Unused.
2314 C> - 3:Length of pds.
2315 C> - 4:Length of gds.
2316 C> - 5:Length of bms.
2317 C> - 6:Length of bds.
2318 C> - 7:Value of current byte.
2319 C> - 8:Unused.
2320 C> - 9:Grib start byte nr.
2321 C> - 10:Grib/grid element count.
2322 C> @param[in] KPDS Array containing pds elements. (version 1)
2323 C> - 1: Id of center.
2324 C> - 2: Model identification.
2325 C> - 3: Grid identification.
2326 C> - 4: Gds/bms flag.
2327 C> - 5: Indicator of parameter.
2328 C> - 6: Type of level.
2329 C> - 7: Height/pressure , etc of level.
2330 C> - 8: Year including century.
2331 C> - 9: Month of year.
2332 C> - 10: Day of month.
2333 C> - 11: Hour of day.
2334 C> - 12: Minute of hour.
2335 C> - 13: Indicator of forecast time unit.
2336 C> - 14: Time range 1.
2337 C> - 15: Time range 2.
2338 C> - 16: Time range flag.
2339 C> - 17: Number included in average.
2340 C> - 18: Version nr of grib specification.
2341 C> - 19: Version nr of parameter table.
2342 C> - 20: Total length of grib message (including section 0).
2343 C> @param[in] KBMS Bitmap describing location of output elements.
2344 C> @param[out] DATA Real array of gridded elements in grib message.
2345 C> @param[out] KRET Error return.
2346 C>
2347 C> @note Structure of binary data section (version 1)
2348 C> - 1-3: LENGTH OF SECTION
2349 C> - 4: PACKING FLAGS
2350 C> - 5-6: SCALE FACTOR
2351 C> - 7-10: REFERENCE VALUE
2352 C> - 11: NUMBER OF BIT FOR EACH VALUE
2353 C> - 12s-N: DATA
2354 C>
2355 C> @note Error return:
2356 C> - 3 = Unpacked field is larger than 32768.
2357 C> - 6 = Does not match nr of entries for this grib/grid.
2358 C> - 7 = Number of bits in fill too large.
2359 C>
2360 C> @author Bill Cavanaugh @date 1989-11-20
2361  SUBROUTINE ai085a(MSGA,KPTR,KPDS,KBMS,DATA,KRET)
2362 C *************************************************************
2363  CHARACTER*1 MSGA(*)
2364  CHARACTER*1 KREF(8)
2365  CHARACTER*1 KK(8)
2366 C
2367  LOGICAL KBMS(*)
2368 C
2369  INTEGER KPDS(*)
2370  INTEGER KPTR(*)
2371  INTEGER NRBITS
2372  INTEGER KSAVE(105000)
2373  INTEGER KSCALE
2374 C
2375  REAL DATA(*)
2376  REAL REFNCE
2377  REAL SCALE
2378  REAL REALKK
2379 C
2380  LOGICAL IBM370
2381 C
2382  equivalence(refnce,kref(1),iref)
2383  equivalence(kk(1),realkk,ikk)
2384 C
2385 C DATA MSK0F /Z0000000F/
2386 C DATA MSK40 /Z00000040/
2387 C DATA MSK80 /Z00000080/
2388 C
2389  DATA msk0f /15/
2390  DATA msk40 /64/
2391  DATA msk80 /128/
2392 C
2393 C *************************************************************
2394 C
2395  kret = 0
2396  is = kptr(9)
2397  igribl = 8
2398  iss = is + kptr(3) + kptr(4) + kptr(5) + igribl
2399 C BYTE 4
2400  kspl = mova2i(msga(iss+3))
2401 C
2402 C ------------- POINT TO BYTE 5 OF BDS
2403 C
2404 C ------------- GET SCALE FACTOR
2405 C
2406  kscale = 0
2407  DO 100 i = 0, 1
2408  kscale = kscale * 256 + mova2i(msga(i+iss+4))
2409  100 CONTINUE
2410  IF (iand(kscale,32768).NE.0) THEN
2411  kscale = - iand(kscale,32767)
2412  END IF
2413  scale = 2.0**kscale
2414 C
2415 C -------------------- DECIMAL SCALE EXPONENT
2416 C
2417  idec = is + igribl + 26
2418  jscale = 0
2419  DO 150 i = 0, 1
2420  jscale = jscale * 256 + mova2i(msga(i+idec))
2421  150 CONTINUE
2422 C IF HIGH ORDER BIT IS ON, HAVE NEGATIVE EXPONENT
2423  IF (iand(jscale,32768).NE.0) THEN
2424  jscale = - iand(jscale,32767)
2425  END IF
2426  ascale = 10.0 ** jscale
2427 C
2428 C ------------ GET REFERENCE VALUE
2429 C
2430  iref = 0
2431  DO 200 i = 0, 3
2432  kref(i+1) = msga(i+iss+6)
2433  200 CONTINUE
2434 C
2435 C THE FLOATING POINT NUMBER IN THE REFERENCE VALUE IS AN IBM370
2436 C 32 BIT NUMBER, IF YOUR COMPUTER IS NOT AN IBM370 OR CLONE
2437 C SET IBM370 TO .FALSE. SO THE NUMBER IS CONVERTED TO A F.P.
2438 C NUMBER OF YOUR MACHINE TYPE.
2439 C
2440  ibm370 = .false.
2441 C
2442  IF (.NOT.ibm370) THEN
2443  koff = 0
2444 C GET 1 BIT SIGN
2445  CALL gbyte(iref,isgn,0,1)
2446 C GET 7 BIT EXPONENT
2447  CALL gbyte(iref,iexp,1,7)
2448 C GET 24 BIT FRACTION
2449  CALL gbyte(iref,ifr,8,24)
2450  IF (ifr.EQ.0.OR.iexp.EQ.0) THEN
2451  refnce = 0.0
2452  ELSE
2453  refnce = float(ifr) * 16.0 ** (iexp-64-6)
2454  IF (isgn.NE.0) refnce = - refnce
2455  ENDIF
2456  ENDIF
2457 C
2458 C ------------- NUMBER OF BITS SPECIFIED FOR EACH ENTRY
2459 C
2460  kbits = mova2i(msga(iss+10))
2461  kentry = kptr(10)
2462 C
2463 C ------------- MAX SIZE CHECK
2464 C
2465  IF (kentry.GT.105000) THEN
2466  kret = 3
2467  RETURN
2468  END IF
2469 C
2470  IF (kbits.EQ.0) THEN
2471 C
2472 C -------------------- HAVE NO BDS ENTRIES, ALL ENTRIES = REFNCE
2473 C
2474  DO 210 i = 1, kentry
2475  DATA(i) = 0.0
2476  IF (kbms(i)) THEN
2477  DATA(i) = refnce
2478  END IF
2479  210 CONTINUE
2480  GO TO 900
2481  END IF
2482 C
2483 C --------------------
2484 C CYCLE THRU BDS UNTIL HAVE USED ALL (SPECIFIED NUMBER)
2485 C ENTRIES.
2486 C
2487 C ------------- UNUSED BITS IN DATA AREA
2488 C
2489  lessbt = iand(kspl,msk0f)
2490 C
2491 C ------------- NUMBER OF BYTES IN DATA AREA
2492 C
2493  nrbyte = kptr(6) - 11
2494 C
2495 C ------------- TOTAL NR OF USABLE BITS
2496 C
2497  nrbits = nrbyte * 8 - lessbt
2498 C
2499 C ------------- TOTAL NR OF ENTRIES
2500 C
2501  kentry = nrbits / kbits
2502 C
2503 C ------------- MAX SIZE CHECK
2504 C
2505  IF (kentry.GT.105000) THEN
2506  kret = 3
2507  RETURN
2508  END IF
2509  ibms = iand(kpds(4),msk40)
2510 C
2511 C -------------- CHECK TO SEE IF PROCESSING COEFFICIENTS
2512 C IF YES,
2513 C GO AND PROCESS AS SUCH
2514 C ELSE
2515 C CONTINUE PROCESSING
2516  IF (iand(kspl,msk80).EQ.0) THEN
2517 C
2518 C ------------- SET POINTERS
2519 C
2520 C REPLACE XMOVEX AND W3AI41 WITH GBYTES
2521 C CALL XMOVEX(MSGB,MSGA(ISS+11),NRBYTE)
2522 C
2523 C ------------- UNPACK ALL FIELDS
2524 C
2525  koff = 0
2526 C CALL W3AI41(MSGB,KSAVE,KBITS,KENTRY,KOFF)
2527 C
2528 C THE BIT UNPACKER W3AI41 WILL CONSUME MOST OF THE CPU TIME
2529 C CONVERTING THE GRIB DATA. FOR THE IBM370 WE HAVE AN
2530 C ASSEMBLER AND FORTRAN VERSION. THE ASSMBLER VERSION WILL
2531 C RUN TWO TO THREE TIMES FASTER. THE FORTRAN VERSION IS TO
2532 C MAKE THE CODE MORE PORTABLE. FOR A VAX OR IBM PC WE HAVE
2533 C ANOTHER VERSION, IT REVERSED THE ORDER OF THE BYTES IN
2534 C AN INTEGER WORD. W3AI41 CAN BE REPLACED BY NCAR GBYTES
2535 C BIT UNPACKER. NCAR HAS A LARGE NUMBER OF VERSIONS OF GBYTES
2536 C IN FORTRAN AND ASSEMBLER FOR A NUMBER OF DIFFERENT BRANDS OF
2537 C COMPUTERS. THEY ALSO HAVE A C VERSION.
2538 C
2539 C ALIGN CHARACTER ARRAY MSGA STARTING ADDRESS ON CRAY
2540 C INTEGER WORD BOUNDARY
2541 C
2542  lll = mod(iss+10,8)
2543  nnn = 11 - lll
2544  koff = lll * 8
2545 C
2546  CALL gbytes(msga(iss+nnn),ksave,koff,kbits,0,kentry)
2547 C
2548 C ------------- CORRECTLY PLACE ALL ENTRIES
2549 C
2550  ii = 1
2551  kentry = kptr(10)
2552  DO 500 i = 1, kentry
2553  IF (kbms(i)) THEN
2554 C MUST INCLUDE DECIMAL SCALE
2555  DATA(i) = (refnce + float(ksave(ii)) * scale) / ascale
2556  ii = ii + 1
2557  ELSE
2558  DATA(i) = 0.0
2559  END IF
2560  500 CONTINUE
2561  GO TO 900
2562  END IF
2563 C
2564 C ------------- PROCESS SPHERICAL HARMONIC COEFFICIENTS
2565 C
2566  ikk = 0
2567  DO 5500 i = 0, 3
2568  kk(i+1) = msga(i+iss+11)
2569  5500 CONTINUE
2570 C
2571  IF (.NOT.ibm370) THEN
2572  koff = 0
2573 C GET 1 BIT SIGN
2574  CALL gbyte(ikk,isgn,0,1)
2575 C GET 7 BIT EXPONENT
2576  CALL gbyte(ikk,iexp,1,7)
2577 C GET 24 BIT FRACTION
2578  CALL gbyte(ikk,ifr,8,24)
2579  IF (ifr.EQ.0.OR.iexp.EQ.0) THEN
2580  realkk = 0.0
2581  ELSE
2582  realkk = float(ifr) * 16.0 ** (iexp-64-6)
2583  IF (isgn.NE.0) realkk = - realkk
2584  ENDIF
2585  ENDIF
2586 C
2587  DATA(1) = realkk
2588  koff = 0
2589 C CALL XMOVEX(MSGB,MSGA(ISS+15),NRBYTE)
2590 C
2591 C ------------- UNPACK ALL FIELDS
2592 C
2593 C CALL W3AI41(MSGB,KSAVE,KBITS,KENTRY,KOFF)
2594 C --------------
2595 C
2596 C ALIGN CHARACTER ARRAY MSGA STARTING ADDRESS ON CRAY
2597 C INTEGER WORD BOUNDARY
2598 C
2599  lll = mod(iss+14,8)
2600  nnn = 15 - lll
2601  koff = lll * 8
2602 C
2603  CALL gbytes(msga(iss+nnn),ksave,koff,kbits,0,kentry)
2604 C
2605  DO 6000 i = 1, kentry
2606  DATA(i+1) = refnce + float(ksave(i)) * scale
2607  6000 CONTINUE
2608  900 CONTINUE
2609  RETURN
2610  END
2611 
2612 C> To test when gds is available to see if size mismatch
2613 C> on existing grids (by center) is indicated.
2614 C>
2615 C> Program history log:
2616 C> - Bill Cavanaugh 1988-02-08
2617 C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
2618 C> - Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
2619 C>
2620 C> @param[in] J Size for indicated grid.
2621 C> @param[in] KPDS
2622 C> @param[in] KGDS
2623 C> @param[out] KRET Error return.
2624 C>
2625 C> @note KRET = 9 - GDS indicates size mismatch with std grid.
2626 C>
2627 C> @author Bill Cavanaugh @date 1988-02-08
2628 C$$$
2629  SUBROUTINE ai087(*,J,KPDS,KGDS,KRET)
2630  INTEGER KPDS(20)
2631  INTEGER KGDS(13)
2632  INTEGER J
2633  INTEGER I
2634 C ---------------------------------------
2635 C ---------------------------------------
2636 C IF GDS NOT INDICATED, RETURN
2637 C ----------------------------------------
2638  IF (iand(kpds(4),128).EQ.0) RETURN
2639 C ---------------------------------------
2640 C GDS IS INDICATED, PROCEED WITH TESTING
2641 C ---------------------------------------
2642  i = kgds(2) * kgds(3)
2643 C ---------------------------------------
2644 C TEST ECMWF CONTENT
2645 C ---------------------------------------
2646  IF (kpds(1).EQ.98) THEN
2647  kret = 9
2648  IF (kpds(3).GE.1.AND.kpds(3).LE.16) THEN
2649  IF (i.NE.j) THEN
2650  RETURN 1
2651  END IF
2652  ELSE
2653  kret = 5
2654  RETURN 1
2655  END IF
2656 C ---------------------------------------
2657 C U.K. MET OFFICE, BRACKNELL
2658 C ---------------------------------------
2659  ELSE IF (kpds(1).EQ.74) THEN
2660  kret = 9
2661  IF (kpds(3).GE.21.AND.kpds(3).LE.24) THEN
2662  IF (i.NE.j) THEN
2663  RETURN 1
2664  END IF
2665  ELSE IF (kpds(3).EQ.25.OR.kpds(3).EQ.26) THEN
2666  IF (i.NE.j) THEN
2667  RETURN 1
2668  END IF
2669  ELSE IF (kpds(3).GE.61.AND.kpds(3).LE.64) THEN
2670  IF (i.NE.j) THEN
2671  RETURN 1
2672  END IF
2673  ELSE IF (kpds(3).EQ.70) THEN
2674  IF (i.NE.j) THEN
2675  RETURN 1
2676  END IF
2677  ELSE
2678  kret = 5
2679  RETURN 1
2680  END IF
2681 C ---------------------------------------
2682 C NAVY - FNOC
2683 C ---------------------------------------
2684  ELSE IF (kpds(1).EQ.58) THEN
2685  print *,' NO CURRENT LISTING OF NAVY GRIDS'
2686  RETURN 1
2687 C ---------------------------------------
2688 C U.S. GRIDS
2689 C ---------------------------------------
2690  ELSE IF (kpds(1).EQ.7) THEN
2691  kret = 9
2692  IF (kpds(3).EQ.5) THEN
2693  IF (i.NE.j) THEN
2694  RETURN 1
2695  END IF
2696  ELSE IF (kpds(3).EQ.6) THEN
2697  IF (i.NE.j) THEN
2698  RETURN 1
2699  END IF
2700  ELSE IF (kpds(3).GE.21.AND.kpds(3).LE.24) THEN
2701  IF (i.NE.j) THEN
2702  RETURN 1
2703  END IF
2704  ELSE IF (kpds(3).EQ.25.OR.kpds(3).EQ.26) THEN
2705  IF (i.NE.j) THEN
2706  RETURN 1
2707  END IF
2708  ELSE IF (kpds(3).EQ.27.OR.kpds(3).EQ.28) THEN
2709  IF (i.NE.j) THEN
2710  RETURN 1
2711  END IF
2712  ELSE IF (kpds(3).EQ.29.OR.kpds(3).EQ.30) THEN
2713  IF (i.NE.j) THEN
2714  RETURN 1
2715  END IF
2716  ELSE IF (kpds(3).EQ.33.OR.kpds(3).EQ.34) THEN
2717  IF (i.NE.j) THEN
2718  RETURN 1
2719  END IF
2720  ELSE IF (kpds(3).EQ.50) THEN
2721  IF (i.NE.j) THEN
2722  RETURN 1
2723  END IF
2724  ELSE IF (kpds(3).GE.61.AND.kpds(3).LE.64) THEN
2725  IF (i.NE.j) THEN
2726  RETURN 1
2727  END IF
2728  ELSE IF (kpds(3).EQ.70) THEN
2729  IF (i.NE.j) THEN
2730  RETURN 1
2731  END IF
2732  ELSE IF (kpds(3).EQ.85.OR.kpds(3).EQ.86) THEN
2733  IF (i.NE.j) THEN
2734  RETURN 1
2735  END IF
2736  ELSE IF (kpds(3).EQ.100) THEN
2737  IF (i.NE.j) THEN
2738  RETURN 1
2739  END IF
2740  ELSE IF (kpds(3).EQ.101) THEN
2741  IF (i.NE.j) THEN
2742  RETURN 1
2743  END IF
2744  ELSE IF (kpds(3).EQ.102) THEN
2745  IF (i.NE.j) THEN
2746  RETURN 1
2747  END IF
2748  ELSE IF (kpds(3).EQ.103) THEN
2749  IF (i.NE.j) THEN
2750  RETURN 1
2751  END IF
2752  ELSE IF (kpds(3).GE.201.AND.kpds(3).LE.214) THEN
2753  IF (i.NE.j) THEN
2754  RETURN 1
2755  END IF
2756  ELSE
2757  kret = 5
2758  RETURN 1
2759  END IF
2760  ELSE
2761  kret = 10
2762  RETURN 1
2763  END IF
2764 C ------------------------------------
2765 C NORMAL EXIT
2766 C ------------------------------------
2767  kret = 0
2768  RETURN
2769  END
gbyte
subroutine gbyte(IPACKD, IUNPKD, NOFF, NBITS)
This is the fortran version of gbyte.
Definition: gbyte.f:27
gbytes
subroutine gbytes(IPACKD, IUNPKD, NOFF, NBITS, ISKIP, ITER)
Program history log:
Definition: gbytes.f:26
mova2i
integer function mova2i(a)
This Function copies a bit string from a Character*1 variable to an integer variable.
Definition: mova2i.f:25
ai084
subroutine ai084(MSGA, KPTR, KPDS, KGDS, KBMS, KRET)
If bit map sec is available in grib message,extract for program use, otherwise generate an appropriat...
Definition: w3ai08.f:1615
ai085
subroutine ai085(MSGA, KPTR, KPDS, KBMS, DATA, KRET)
Extract grib data and place into output arry in proper position.
Definition: w3ai08.f:2067
ai081
subroutine ai081(MSGA, KPTR, KPDS, KRET)
Find 'grib; characters and set pointers to the next byte following 'grib'.
Definition: w3ai08.f:569
ai083
subroutine ai083(MSGA, KPTR, KPDS, KGDS, KRET)
Extract information on unlisted grid to allow conversion to office note 84 format.
Definition: w3ai08.f:1158
ai082a
subroutine ai082a(MSGA, KPTR, KPDS, KRET)
Extract information from the product description section (version 1).
Definition: w3ai08.f:935
ai085a
subroutine ai085a(MSGA, KPTR, KPDS, KBMS, DATA, KRET)
Extract grib data (version 1) and place into proper position in output array.
Definition: w3ai08.f:2362
w3ai08
subroutine w3ai08(MSGA, KPDS, KGDS, KBMS, DATA, KPTR, KRET)
Unpack a grib field to the exact grid specified in the message, isolate the bit map and make the valu...
Definition: w3ai08.f:148
ai087
subroutine ai087(, J, KPDS, KGDS, KRET)
To test when gds is available to see if size mismatch on existing grids (by center) is indicated.
Definition: w3ai08.f:2630
ai082
subroutine ai082(MSGA, KPTR, KPDS, KRET)
Extract information from the product description sec, and generate label information to permit storag...
Definition: w3ai08.f:749