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