PageRenderTime 89ms CodeModel.GetById 27ms RepoModel.GetById 0ms app.codeStats 1ms

/WPS/ungrib/src/ngl/w3/w3fi63.f

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 4020 lines | 1716 code | 1 blank | 2303 comment | 0 complexity | 0c471b57123c3c19f33701c39a780cf2 MD5 | raw file
Possible License(s): AGPL-1.0 
    

  1.       SUBROUTINE W3FI63(MSGA,KPDS,KGDS,KBMS,DATA,KPTR,KRET)
    2. 

  2. C$$$  SUBPROGRAM DOCUMENTATION  BLOCK
    3. 

  3. C                .      .    .                                       .
    4. 

  4. C SUBPROGRAM:  W3FI63        UNPK GRIB FIELD TO GRIB GRID
    5. 

  5. C   PRGMMR: FARLEY           ORG: NMC421      DATE:94-11-22
    6. 

  6. C
    7. 

  7. C ABSTRACT: UNPACK A GRIB (EDITION 1) FIELD TO THE EXACT GRID
    8. 

  8. C   SPECIFIED IN THE GRIB MESSAGE, ISOLATE THE BIT MAP, AND MAKE
    9. 

  9. C   THE VALUES OF THE PRODUCT DESCRIPTON SECTION (PDS) AND THE
    10. 

  10. C   GRID DESCRIPTION SECTION (GDS) AVAILABLE IN RETURN ARRAYS.
    11. 

  11. C
    12. 

  12. C   WHEN DECODING IS COMPLETED, DATA AT EACH GRID POINT HAS BEEN
    13. 

  13. C          RETURNED IN THE UNITS SPECIFIED IN THE GRIB MANUAL.
    14. 

  14. C
    15. 

  15. C PROGRAM HISTORY LOG:
    16. 

  16. C   91-09-13  CAVANAUGH
    17. 

  17. C   91-11-12  CAVANAUGH   MODIFIED SIZE OF ECMWF GRIDS 5-8
    18. 

  18. C   91-12-22  CAVANAUGH   CORRECTED PROCESSING OF MERCATOR PROJECTIONS
    19. 

  19. C                         IN GRID DEFINITION SECTION (GDS) IN
    20. 

  20. C                         ROUTINE FI633
    21. 

  21. C   92-08-05  CAVANAUGH   CORRECTED MAXIMUM GRID SIZE TO ALLOW FOR
    22. 

  22. C                         ONE DEGREE BY ONE DEGREE GLOBAL GRIDS
    23. 

  23. C   92-08-27  CAVANAUGH   CORRECTED TYPO ERROR, ADDED CODE TO COMPARE
    24. 

  24. C                         TOTAL BYTE SIZE FROM SECTION 0 WITH SUM OF
    25. 

  25. C                         SECTION SIZES.
    26. 

  26. C   92-10-21  CAVANAUGH   CORRECTIONS WERE MADE (IN FI634) TO REDUCE
    27. 

  27. C                         PROCESSING TIME FOR INTERNATIONAL GRIDS.
    28. 

  28. C                         REMOVED A TYPOGRAPHICAL ERROR IN FI635.
    29. 

  29. C   93-01-07  CAVANAUGH   CORRECTIONS WERE MADE (IN FI635) TO
    30. 

  30. C                         FACILITATE USE OF THESE ROUTINES ON A PC.
    31. 

  31. C                         A TYPOGRAPHICAL ERROR WAS ALSO CORRECTED
    32. 

  32. C   93-01-13  CAVANAUGH   CORRECTIONS WERE MADE (IN FI632) TO
    33. 

  33. C                         PROPERLY HANDLE CONDITION WHEN
    34. 

  34. C                         TIME RANGE INDICATOR = 10.
    35. 

  35. C                         ADDED U.S.GRID 87.
    36. 

  36. C   93-02-04  CAVANAUGH   ADDED U.S.GRIDS 85 AND 86
    37. 

  37. C   93-02-26  CAVANAUGH   ADDED GRIDS 2, 3, 37 THRU 44,AND
    38. 

  38. C                         GRIDS 55, 56, 90, 91, 92, AND 93 TO
    39. 

  39. C                         LIST OF U.S. GRIDS.
    40. 

  40. C   93-04-07  CAVANAUGH   ADDED GRIDS 67 THRU 77 TO
    41. 

  41. C                         LIST OF U.S. GRIDS.
    42. 

  42. C   93-04-20  CAVANAUGH   INCREASED MAX SIZE TO ACCOMODATE
    43. 

  43. C                         GAUSSIAN GRIDS.
    44. 

  44. C   93-05-26  CAVANAUGH   CORRECTED GRID RANGE SELECTION IN FI634
    45. 

  45. C                         FOR RANGES 67-71 & 75-77
    46. 

  46. C   93-06-08  CAVANAUGH   CORRECTED FI635 TO ACCEPT GRIB MESSAGES
    47. 

  47. C                         WITH SECOND ORDER PACKING. ADDED ROUTINE FI636
    48. 

  48. C                         TO PROCESS MESSAGES WITH SECOND ORDER PACKING.
    49. 

  49. C   93-09-22  CAVANAUGH   MODIFIED TO EXTRACT SUB-CENTER NUMBER FROM
    50. 

  50. C                         PDS BYTE 26
    51. 

  51. C   93-10-13  CAVANAUGH   MODIFIED FI634 TO CORRECT GRID SIZES FOR
    52. 

  52. C                         GRIDS 204 AND 208
    53. 

  53. C   93-10-14  CAVANAUGH   INCREASED SIZE OF KGDS TO INCLUDE ENTRIES FOR
    54. 

  54. C                         NUMBER OF POINTS IN GRID AND NUMBER OF WORDS
    55. 

  55. C                         IN EACH ROW
    56. 

  56. C   93-12-08  CAVANAUGH   CORRECTED TEST FOR EDITION NUMBER INSTEAD
    57. 

  57. C                         OF VERSION NUMBER
    58. 

  58. C   93-12-15  CAVANAUGH   MODIFIED SECOND ORDER POINTERS TO FIRST ORDER
    59. 

  59. C                         VALUES AND SECOND ORDER VALUES CORRECTLY
    60. 

  60. C                         IN ROUTINE FI636
    61. 

  61. C   94-03-02  CAVANAUGH   ADDED CALL TO W3FI83 WITHIN DECODER.  USER
    62. 

  62. C                         NO LONGER NEEDS TO MAKE CALL TO THIS ROUTINE
    63. 

  63. C   94-04-22  CAVANAUGH   MODIFIED FI635, FI636 TO PROCESS ROW BY ROW
    64. 

  64. C                         SECOND ORDER PACKING, ADDED SCALING CORRECTION
    65. 

  65. C                         TO FI635, AND CORRECTED TYPOGRAPHICAL ERRORS
    66. 

  66. C                         IN COMMENT FIELDS IN FI634
    67. 

  67. C   94-05-17  CAVANAUGH   CORRECTED ERROR IN FI633 TO EXTRACT RESOLUTION
    68. 

  68. C                         FOR LAMBERT-CONFORMAL GRIDS. ADDED CLARIFYING
    69. 

  69. C                         INFORMATION TO DOCBLOCK ENTRIES
    70. 

  70. C   94-05-25  CAVANAUGH   ADDED CODE TO PROCESS COLUMN BY COLUMN AS WELL
    71. 

  71. C                         AS ROW BY ROW ORDERING OF SECOND ORDER DATA
    72. 

  72. C   94-06-27  CAVANAUGH   ADDED PROCESSING FOR GRIDS 45, 94 AND 95.
    73. 

  73. C                         INCLUDES CONSTRUCTION OF SECOND ORDER BIT MAPS
    74. 

  74. C                         FOR THINNED GRIDS IN FI636.
    75. 

  75. C   94-07-08  CAVANAUGH   COMMENTED OUT PRINT OUTS USED FOR DEBUGGING
    76. 

  76. C   94-09-08  CAVANAUGH   ADDED GRIDS 220, 221, 223 FOR FNOC
    77. 

  77. C   94-11-10  FARLEY      INCREASED MXSIZE FROM 72960 TO 260000
    78. 

  78. C                         FOR .5 DEGREE SST ANALYSIS FIELDS
    79. 

  79. C   94-12-06  R.E.JONES   CHANGES IN FI632 FOR PDS GREATER THAN 28
    80. 

  80. C   95-02-14  R.E.JONES   CORRECT IN FI633 FOR NAVY WAFS GRIB
    81. 

  81. C   95-03-20  M.BALDWIN   FI633 MODIFICATION TO GET
    82. 

  82. C                         DATA REP TYPES [KGDS(1)] 201 AND 202 TO WORK.
    83. 

  83. C   95-04-10  E.ROGERS    ADDED GRIDS 96 AND 97 FOR ETA MODEL IN FI634.
    84. 

  84. C   95-04-26  R.E.JONES   FI636 CORECTION FOR 2ND ORDER COMPLEX
    85. 

  85. C                         UNPACKING. R
    86. 

  86. C   95-05-19  R.E.JONES   ADDED GRID 215, 20 KM AWIPS GRID
    87. 

  87. C   95-07-06  R.E.JONES   ADDED GAUSSIAN T62, T126 GRID 98, 126
    88. 

  88. C   95-10-19  R.E.JONES   ADDED GRID 216, 45 KM ETA AWIPS ALASKA GRID 
    89. 

  89. C   95-10-31  IREDELL     REMOVED SAVES AND PRINTS
    90. 

  90. C   96-03-07  R.E.JONES   CONTINUE UNPACK WITH KRET ERROR 9 IN FI631. 
    91. 

  91. C   96-08-19  R.E.JONES   ADDED MERCATOR GRIDS 8 AND 53, AND GRID 196
    92. 

  92. C   97-02-12  W BOSTELMAN CORRECTS ECMWF US GRID 2 PROCESSING
    93. 

  93. C   98-06-17  IREDELL     REMOVED ALTERNATE RETURN IN FI637
    94. 

  94. C   98-08-31  IREDELL     ELIMINATED NEED FOR MXSIZE
    95. 

  95. C   98-09-02  Gilbert     Corrected error in map size for U.S. Grid 92
    96. 

  96. C   98-09-08  BALDWIN     ADD DATA REP TYPE [KGDS(1)] 203
    97. 

  97. C   01-03-08  ROGERS      CHANGED ETA GRIDS 90-97, ADDED ETA GRIDS
    98. 

  98. C                         194, 198. ADDED AWIPS GRIDS 241,242,243,
    99. 

  99. C                         245, 246, 247, 248, AND 250
    100. 

  100. C   01-03-19  VUONG       ADDED AWIPS GRIDS 238,239,240, AND 244
    101. 

  101. C 2001-06-06  GILBERT     Changed gbyte/sbyte calls to refer to 
    102. 

  102. C                         Wesley Ebisuzaki's endian independent
    103. 

  103. C                         versions gbytec/sbytec.
    104. 

  104. C                         Removed equivalences.
    105. 

  105. C   01-05-03  ROGERS      ADDED GRID 249  (12KM FOR ALASKA)
    106. 

  106. C   01-10-10  ROGERS      REDEFINED GRID 218 FOR 12 KM ETA
    107. 

  107. C                         REDEFINED GRID 192 FOR NEW 32-KM ETA GRID
    108. 

  108. C   02-03-27  VUONG       ADDED RSAS GRID 88 AND AWIPS GRIDS 219, 220,
    109. 

  109. C                         223, 224, 225, 226, 227, 228, 229, 230, 231,
    110. 

  110. C                         232, 233, 234, 235, 251, AND 252
    111. 

  111. C   02-08-06  ROGERS      REDEFINED GRIDS 90-93,97,194,245-250 FOR THE
    112. 

  112. C                         8KM HI-RES-WINDOW MODEL AND ADD AWIPS GRID 253
    113. 

  113. C 2003-06-30  GILBERT     SET NEW VALUES IN ARRAY KPTR TO PASS BACK ADDITIONAL
    114. 

  114. C                         PACKING INFO.
    115. 

  115. C                         KPTR(19) - BINARY SCALE FACTOR
    116. 

  116. C                         KPTR(20) - NUM BITS USED TO PACK EACH DATUM
    117. 

  117. C 2003-06-30  GILBERT     ADDED GRIDS 145 and 146 for CMAQ
    118. 

  118. C                         and GRID 175 for AWIPS over GUAM.
    119. 

  119. C 2003-07-08  VUONG       ADDED GRIDS 110, 127, 171, 172 AND MODIFIED GRID 170
    120. 

  120. C 2004-09-02  VUONG       ADDED AWIPS GRIDS 147, 148, 173 AND 254
    121. 

  121. C 2005-01-04  COOKE       ADDED AWIPS GRIDS 160 AND 161
    122. 

  122. C 2005-03-03  VUONG       MOVED GRID 170 TO GRID 174 AND ADD GRID 170
    123. 

  123. C 2005-03-21  VUONG       ADDED AWIPS GRID 130
    124. 

  124. C 2005-10-11  VUONG       ADDED AWIPS GRID 163
    125. 

  125. C 2006-12-12  VUONG       ADDED AWIPS GRID 120
    126. 

  126. C 2007-04-12  VUONG       ADDED AWIPS 176 AND  DATA REP TYPE KGDS(1) 204
    127. 

  127. C 2007-06-11  VUONG       ADDED NEW GRIDS 11 TO 18 AND 122 TO 125 AND 138
    128. 

  128. C                         AND 180 TO 183
    129. 

  129. C 2007-11-06  VUONG       CHANGED GRID 198 FROM ARAKAWA STAGGERED E-GRID TO POLAR
    130. 

  130. C                         STEREOGRAPGIC GRID ADDED NEW GRID 10, 99, 150, 151, 197
    131. 

  131. C 2008-01-17  VUONG       ADDED NEW GRID 195 AND CHANGED GRID 196 (ARAKAWA-E TO MERCATOR)
    132. 

  132. C 2009-05-21  VUONG       MODIFIED TO HANDLE GRID 45
    133. 

  133. C 2010-05-11  VUONG       DATA REP TYPE KGDS(1) 205
    134. 

  134. C 2010-02-18  VUONG       ADDED GRID 128, 139 AND 140
    135. 

  135. C 2010-07-20  GAYNO       ADDED ROTATED LAT/LON "A,B,C,D" STAGGERS -> KGDS(1) 205
    136. 

  136. C 2010-08-05  VUONG       ADDED NEW GRID 184, 199, 83 AND
    137. 

  137. C                         REDEFINED GRID 90 FOR NEW RTMA CONUS 1.27-KM
    138. 

  138. C                         REDEFINED GRID 91 FOR NEW RTMA ALASKA 2.976-KM
    139. 

  139. C                         REDEFINED GRID 92 FOR NEW RTMA ALASKA 1.488-KM
    140. 

  140. C 2010-09-08  ROGERS      CHANGED GRID 94 TO ALASKA 6KM STAGGERED B-GRID
    141. 

  141. C                         CHANGED GRID 95 TO PUERTO RICO 3KM STAGGERED B-GRID
    142. 

  142. C                         CHANGED GRID 96 TO HAWAII 3KM STAGGERED B-GRID
    143. 

  143. C                         CHANGED GRID 96 TO HAWAII 3KM STAGGERED B-GRID
    144. 

  144. C                         CHANGED GRID 97 TO CONUS 4KM STAGGERED B-GRID
    145. 

  145. C                         CHANGED GRID 99 TO NAM 12KM STAGGERED B-GRID
    146. 

  146. C                         ADDED GRID 179 (12 KM POLAR STEREOGRAPHIC OVER NORTH AMERICA)
    147. 

  147. C                         CHANGED GRID 194 TO 3KM MERCATOR GRID OVER PUERTO RICO
    148. 

  148. C                         CORRECTED LATITUDE OF SW CORNER POINT OF GRID 151
    149. 

  149. C
    150. 

  150. C USAGE:    CALL W3FI63(MSGA,KPDS,KGDS,KBMS,DATA,KPTR,KRET)
    151. 

  151. C   INPUT ARGUMENT LIST:
    152. 

  152. C     MSGA     - GRIB FIELD - "GRIB" THRU "7777"   CHAR*1
    153. 

  153. C                   (MESSAGE CAN BE PRECEDED BY JUNK CHARS)
    154. 

  154. C
    155. 

  155. C   OUTPUT ARGUMENT LIST:
    156. 

  156. C     DATA     - ARRAY CONTAINING DATA ELEMENTS
    157. 

  157. C     KPDS     - ARRAY CONTAINING PDS ELEMENTS.  (EDITION 1)
    158. 

  158. C          (1)   - ID OF CENTER
    159. 

  159. C          (2)   - GENERATING PROCESS ID NUMBER
    160. 

  160. C          (3)   - GRID DEFINITION
    161. 

  161. C          (4)   - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8)
    162. 

  162. C          (5)   - INDICATOR OF PARAMETER
    163. 

  163. C          (6)   - TYPE OF LEVEL
    164. 

  164. C          (7)   - HEIGHT/PRESSURE , ETC OF LEVEL
    165. 

  165. C          (8)   - YEAR INCLUDING (CENTURY-1)
    166. 

  166. C          (9)   - MONTH OF YEAR
    167. 

  167. C          (10)  - DAY OF MONTH
    168. 

  168. C          (11)  - HOUR OF DAY
    169. 

  169. C          (12)  - MINUTE OF HOUR
    170. 

  170. C          (13)  - INDICATOR OF FORECAST TIME UNIT
    171. 

  171. C          (14)  - TIME RANGE 1
    172. 

  172. C          (15)  - TIME RANGE 2
    173. 

  173. C          (16)  - TIME RANGE FLAG
    174. 

  174. C          (17)  - NUMBER INCLUDED IN AVERAGE
    175. 

  175. C          (18)  - VERSION NR OF GRIB SPECIFICATION
    176. 

  176. C          (19)  - VERSION NR OF PARAMETER TABLE
    177. 

  177. C          (20)  - NR MISSING FROM AVERAGE/ACCUMULATION
    178. 

  178. C          (21)  - CENTURY OF REFERENCE TIME OF DATA
    179. 

  179. C          (22)  - UNITS DECIMAL SCALE FACTOR
    180. 

  180. C          (23)  - SUBCENTER NUMBER
    181. 

  181. C          (24)  - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS
    182. 

  182. C                  128 IF FORECAST FIELD ERROR
    183. 

  183. C                   64 IF BIAS CORRECTED FCST FIELD
    184. 

  184. C                   32 IF SMOOTHED FIELD
    185. 

  185. C                  WARNING: CAN BE COMBINATION OF MORE THAN 1
    186. 

  186. C          (25)  - PDS BYTE 30, NOT USED
    187. 

  187. C       (26-35)  - RESERVED
    188. 

  188. C       (36-N)   - CONSECUTIVE BYTES EXTRACTED FROM PROGRAM
    189. 

  189. C                  DEFINITION SECTION (PDS) OF GRIB MESSAGE
    190. 

  190. C     KGDS     - ARRAY CONTAINING GDS ELEMENTS.
    191. 

  191. C          (1)   - DATA REPRESENTATION TYPE
    192. 

  192. C          (19)  - NUMBER OF VERTICAL COORDINATE PARAMETERS
    193. 

  193. C          (20)  - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE
    194. 

  194. C                  PARAMETERS
    195. 

  195. C                  OR
    196. 

  196. C                  OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS
    197. 

  197. C                  IN EACH ROW
    198. 

  198. C                  OR
    199. 

  199. C                  255 IF NEITHER ARE PRESENT
    200. 

  200. C          (21)  - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID
    201. 

  201. C          (22)  - NUMBER OF WORDS IN EACH ROW
    202. 

  202. C       LATITUDE/LONGITUDE GRIDS
    203. 

  203. C          (2)   - N(I) NR POINTS ON LATITUDE CIRCLE
    204. 

  204. C          (3)   - N(J) NR POINTS ON LONGITUDE MERIDIAN
    205. 

  205. C          (4)   - LA(1) LATITUDE OF ORIGIN
    206. 

  206. C          (5)   - LO(1) LONGITUDE OF ORIGIN
    207. 

  207. C          (6)   - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17)
    208. 

  208. C          (7)   - LA(2) LATITUDE OF EXTREME POINT
    209. 

  209. C          (8)   - LO(2) LONGITUDE OF EXTREME POINT
    210. 

  210. C          (9)   - DI LONGITUDINAL DIRECTION OF INCREMENT
    211. 

  211. C          (10)  - DJ LATITUDINAL DIRECTION INCREMENT
    212. 

  212. C          (11)  - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
    213. 

  213. C       GAUSSIAN  GRIDS
    214. 

  214. C          (2)   - N(I) NR POINTS ON LATITUDE CIRCLE
    215. 

  215. C          (3)   - N(J) NR POINTS ON LONGITUDE MERIDIAN
    216. 

  216. C          (4)   - LA(1) LATITUDE OF ORIGIN
    217. 

  217. C          (5)   - LO(1) LONGITUDE OF ORIGIN
    218. 

  218. C          (6)   - RESOLUTION FLAG  (RIGHT ADJ COPY OF OCTET 17)
    219. 

  219. C          (7)   - LA(2) LATITUDE OF EXTREME POINT
    220. 

  220. C          (8)   - LO(2) LONGITUDE OF EXTREME POINT
    221. 

  221. C          (9)   - DI LONGITUDINAL DIRECTION OF INCREMENT
    222. 

  222. C          (10)  - N - NR OF CIRCLES POLE TO EQUATOR
    223. 

  223. C          (11)  - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
    224. 

  224. C          (12)  - NV - NR OF VERT COORD PARAMETERS
    225. 

  225. C          (13)  - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS
    226. 

  226. C                             OR
    227. 

  227. C                  PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN
    228. 

  228. C                       EACH ROW (IF NO VERT COORD PARAMETERS
    229. 

  229. C                       ARE PRESENT
    230. 

  230. C                             OR
    231. 

  231. C                  255 IF NEITHER ARE PRESENT
    232. 

  232. C       POLAR STEREOGRAPHIC GRIDS
    233. 

  233. C          (2)   - N(I) NR POINTS ALONG LAT CIRCLE
    234. 

  234. C          (3)   - N(J) NR POINTS ALONG LON CIRCLE
    235. 

  235. C          (4)   - LA(1) LATITUDE OF ORIGIN
    236. 

  236. C          (5)   - LO(1) LONGITUDE OF ORIGIN
    237. 

  237. C          (6)   - RESOLUTION FLAG  (RIGHT ADJ COPY OF OCTET 17)
    238. 

  238. C          (7)   - LOV GRID ORIENTATION
    239. 

  239. C          (8)   - DX - X DIRECTION INCREMENT
    240. 

  240. C          (9)   - DY - Y DIRECTION INCREMENT
    241. 

  241. C          (10)  - PROJECTION CENTER FLAG
    242. 

  242. C          (11)  - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28)
    243. 

  243. C       SPHERICAL HARMONIC COEFFICIENTS
    244. 

  244. C          (2)   - J PENTAGONAL RESOLUTION PARAMETER
    245. 

  245. C          (3)   - K      "          "         "
    246. 

  246. C          (4)   - M      "          "         "
    247. 

  247. C          (5)   - REPRESENTATION TYPE
    248. 

  248. C          (6)   - COEFFICIENT STORAGE MODE
    249. 

  249. C       MERCATOR GRIDS
    250. 

  250. C          (2)   - N(I) NR POINTS ON LATITUDE CIRCLE
    251. 

  251. C          (3)   - N(J) NR POINTS ON LONGITUDE MERIDIAN
    252. 

  252. C          (4)   - LA(1) LATITUDE OF ORIGIN
    253. 

  253. C          (5)   - LO(1) LONGITUDE OF ORIGIN
    254. 

  254. C          (6)   - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17)
    255. 

  255. C          (7)   - LA(2) LATITUDE OF LAST GRID POINT
    256. 

  256. C          (8)   - LO(2) LONGITUDE OF LAST GRID POINT
    257. 

  257. C          (9)   - LATIT - LATITUDE OF PROJECTION INTERSECTION
    258. 

  258. C          (10)  - RESERVED
    259. 

  259. C          (11)  - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
    260. 

  260. C          (12)  - LONGITUDINAL DIR GRID LENGTH
    261. 

  261. C          (13)  - LATITUDINAL DIR GRID LENGTH
    262. 

  262. C       LAMBERT CONFORMAL GRIDS
    263. 

  263. C          (2)   - NX NR POINTS ALONG X-AXIS
    264. 

  264. C          (3)   - NY NR POINTS ALONG Y-AXIS
    265. 

  265. C          (4)   - LA1 LAT OF ORIGIN (LOWER LEFT)
    266. 

  266. C          (5)   - LO1 LON OF ORIGIN (LOWER LEFT)
    267. 

  267. C          (6)   - RESOLUTION (RIGHT ADJ COPY OF OCTET 17)
    268. 

  268. C          (7)   - LOV - ORIENTATION OF GRID
    269. 

  269. C          (8)   - DX - X-DIR INCREMENT
    270. 

  270. C          (9)   - DY - Y-DIR INCREMENT
    271. 

  271. C          (10)  - PROJECTION CENTER FLAG
    272. 

  272. C          (11)  - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
    273. 

  273. C          (12)  - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER
    274. 

  274. C          (13)  - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER
    275. 

  275. C       E-STAGGERED ARAKAWA ROTATED LAT/LON GRIDS (TYPE 203)
    276. 

  276. C          (2)   - N(I) NR POINTS ON LATITUDE CIRCLE
    277. 

  277. C          (3)   - N(J) NR POINTS ON LONGITUDE MERIDIAN
    278. 

  278. C          (4)   - LA(1) LATITUDE OF ORIGIN
    279. 

  279. C          (5)   - LO(1) LONGITUDE OF ORIGIN
    280. 

  280. C          (6)   - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17)
    281. 

  281. C          (7)   - LA(2) LATITUDE OF CENTER
    282. 

  282. C          (8)   - LO(2) LONGITUDE OF CENTER
    283. 

  283. C          (9)   - DI LONGITUDINAL DIRECTION OF INCREMENT
    284. 

  284. C          (10)  - DJ LATITUDINAL DIRECTION INCREMENT
    285. 

  285. C          (11)  - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
    286. 

  286. C       CURVILINEAR ORTHIGINAL GRID (TYPE 204)
    287. 

  287. C          (2)   - N(I) NR POINTS ON LATITUDE CIRCLE
    288. 

  288. C          (3)   - N(J) NR POINTS ON LONGITUDE MERIDIAN
    289. 

  289. C          (4)   - RESERVED SET TO 0
    290. 

  290. C          (5)   - RESERVED SET TO 0
    291. 

  291. C          (6)   - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17)
    292. 

  292. C          (7)   - RESERVED SET TO 0
    293. 

  293. C          (8)   - RESERVED SET TO 0
    294. 

  294. C          (9)   - RESERVED SET TO 0
    295. 

  295. C          (10)  - RESERVED SET TO 0
    296. 

  296. C          (11)  - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
    297. 

  297. C       ROTATED LAT/LON A,B,C,D-STAGGERED (TYPE 205)
    298. 

  298. C          (2)   - N(I) NR POINTS ON LATITUDE CIRCLE
    299. 

  299. C          (3)   - N(J) NR POINTS ON LONGITUDE MERIDIAN
    300. 

  300. C          (4)   - LA(1) LATITUDE OF FIRST POINT
    301. 

  301. C          (5)   - LO(1) LONGITUDE OF FIRST POINT
    302. 

  302. C          (6)   - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17)
    303. 

  303. C          (7)   - LA(2) LATITUDE OF CENTER
    304. 

  304. C          (8)   - LO(2) LONGITUDE OF CENTER
    305. 

  305. C          (9)   - DI LONGITUDINAL DIRECTION OF INCREMENT
    306. 

  306. C          (10)  - DJ LATITUDINAL DIRECTION INCREMENT
    307. 

  307. C          (11)  - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
    308. 

  308. C          (12)  - LATITUDE OF LAST POINT
    309. 

  309. C          (13)  - LONGITUDE OF LAST POINT
    310. 

  310. C     KBMS       - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS.
    311. 

  311. C                            (ALWAYS CONSTRUCTED)
    312. 

  312. C     KPTR       - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
    313. 

  313. C          (1)   - TOTAL LENGTH OF GRIB MESSAGE
    314. 

  314. C          (2)   - LENGTH OF INDICATOR (SECTION  0)
    315. 

  315. C          (3)   - LENGTH OF PDS       (SECTION  1)
    316. 

  316. C          (4)   - LENGTH OF GDS       (SECTION  2)
    317. 

  317. C          (5)   - LENGTH OF BMS       (SECTION  3)
    318. 

  318. C          (6)   - LENGTH OF BDS       (SECTION  4)
    319. 

  319. C          (7)   - VALUE OF CURRENT BYTE
    320. 

  320. C          (8)   - BIT POINTER
    321. 

  321. C          (9)   - GRIB START BIT NR
    322. 

  322. C         (10)   - GRIB/GRID ELEMENT COUNT
    323. 

  323. C         (11)   - NR UNUSED BITS AT END OF SECTION 3
    324. 

  324. C         (12)   - BIT MAP FLAG (COPY OF BMS OCTETS 5,6)
    325. 

  325. C         (13)   - NR UNUSED BITS AT END OF SECTION 2
    326. 

  326. C         (14)   - BDS FLAGS (RIGHT ADJ COPY OF OCTET 4)
    327. 

  327. C         (15)   - NR UNUSED BITS AT END OF SECTION 4
    328. 

  328. C         (16)   - RESERVED
    329. 

  329. C         (17)   - RESERVED
    330. 

  330. C         (18)   - RESERVED
    331. 

  331. C         (19)   - BINARY SCALE FACTOR
    332. 

  332. C         (20)   - NUM BITS USED TO PACK EACH DATUM
    333. 

  333. C     KRET       - FLAG INDICATING QUALITY OF COMPLETION
    334. 

  334. C
    335. 

  335. C REMARKS: WHEN DECODING IS COMPLETED, DATA AT EACH GRID POINT HAS BEEN
    336. 

  336. C          RETURNED IN THE UNITS SPECIFIED IN THE GRIB MANUAL.
    337. 

  337. C
    338. 

  338. C          VALUES FOR RETURN FLAG (KRET)
    339. 

  339. C     KRET = 0 - NORMAL RETURN, NO ERRORS
    340. 

  340. C          = 1 - 'GRIB' NOT FOUND IN FIRST 100 CHARS
    341. 

  341. C          = 2 - '7777' NOT IN CORRECT LOCATION
    342. 

  342. C          = 3 - UNPACKED FIELD IS LARGER THAN 260000
    343. 

  343. C          = 4 - GDS/ GRID NOT ONE OF CURRENTLY ACCEPTED VALUES
    344. 

  344. C          = 5 - GRID NOT CURRENTLY AVAIL FOR CENTER INDICATED
    345. 

  345. C          = 8 - TEMP GDS INDICATED, BUT GDS FLAG IS OFF
    346. 

  346. C          = 9 - GDS INDICATES SIZE MISMATCH WITH STD GRID
    347. 

  347. C          =10 - INCORRECT CENTER INDICATOR
    348. 

  348. C          =11 - BINARY DATA SECTION (BDS) NOT COMPLETELY PROCESSED.
    349. 

  349. C                PROGRAM IS NOT SET TO PROCESS FLAG COMBINATIONS
    350. 

  350. C                SHOWN IN OCTETS 4 AND 14.
    351. 

  351. C          =12 - BINARY DATA SECTION (BDS) NOT COMPLETELY PROCESSED.
    352. 

  352. C                PROGRAM IS NOT SET TO PROCESS FLAG COMBINATIONS
    353. 

  353. C
    354. 

  354. C   SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
    355. 

  355. C
    356. 

  356. C ATTRIBUTES:
    357. 

  357. C   LANGUAGE: FORTRAN 90
    358. 

  358. C
    359. 

  359. C$$$
    360. 

  360. C                                                         4 AUG 1988
    361. 

  361. C                               W3FI63
    362. 

  362. C
    363. 

  363. C
    364. 

  364. C                       GRIB UNPACKING ROUTINE
    365. 

  365. C
    366. 

  366. C
    367. 

  367. C       THIS ROUTINE WILL UNPACK A 'GRIB' FIELD TO THE EXACT GRID
    368. 

  368. C  TYPE SPECIFIED IN THE MESSAGE, RETURN A BIT MAP AND MAKE THE
    369. 

  369. C  VALUES OF THE PRODUCT DEFINITION SEC   (PDS) AND THE GRID
    370. 

  370. C  DESCRIPTION SEC   (GDS) AVAILABLE IN RETURN ARRAYS.
    371. 

  371. C  SEE "GRIB - THE WMO FORMAT FOR THE STORAGE OF WEATHER PRODUCT
    372. 

  372. C  INFORMATION AND THE EXCHANGE OF WEATHER PRODUCT MESSAGES IN
    373. 

  373. C  GRIDDED BINARY FORM" DATED JULY 1, 1988 BY JOHN D. STACKPOLE
    374. 

  374. C  DOC, NOAA, NWS, NATIONAL METEOROLOGICAL CENTER.
    375. 

  375. C
    376. 

  376. C       THE CALL TO THE GRIB UNPACKING ROUTINE IS AS FOLLOWS:
    377. 

  377. C
    378. 

  378. C            CALL W3FI63(MSGA,KPDS,KGDS,LBMS,DATA,KPTR,KRET)
    379. 

  379. C
    380. 

  380. C  INPUT:
    381. 

  381. C
    382. 

  382. C       MSGA  = CONTAINS THE GRIB MESSAGE TO BE UNPACKED. CHARACTERS
    383. 

  383. C               "GRIB" MAY BEGIN ANYWHERE WITHIN FIRST 100 BYTES.
    384. 

  384. C
    385. 

  385. C  OUTPUT:
    386. 

  386. C
    387. 

  387. C       KPDS(100)      INTEGER*4
    388. 

  388. C               ARRAY TO CONTAIN THE ELEMENTS OF THE PRODUCT
    389. 

  389. C               DEFINITION SEC  .
    390. 

  390. C         (VERSION 1)
    391. 

  391. C            KPDS(1)  - ID OF CENTER
    392. 

  392. C            KPDS(2)  - MODEL IDENTIFICATION (SEE "GRIB" TABLE 1)
    393. 

  393. C            KPDS(3)  - GRID IDENTIFICATION (SEE "GRIB" TABLE 2)
    394. 

  394. C            KPDS(4)  - GDS/BMS FLAG
    395. 

  395. C                           BIT       DEFINITION
    396. 

  396. C                            25        0 - GDS OMITTED
    397. 

  397. C                                      1 - GDS INCLUDED
    398. 

  398. C                            26        0 - BMS OMITTED
    399. 

  399. C                                      1 - BMS INCLUDED
    400. 

  400. C                        NOTE:- LEFTMOST BIT = 1,
    401. 

  401. C                               RIGHTMOST BIT = 32
    402. 

  402. C            KPDS(5)  - INDICATOR OF PARAMETER (SEE "GRIB" TABLE 5)
    403. 

  403. C            KPDS(6)  - TYPE OF LEVEL (SEE "GRIB" TABLES 6 & 7)
    404. 

  404. C            KPDS(7)  - HEIGHT,PRESSURE,ETC  OF LEVEL
    405. 

  405. C            KPDS(8)  - YEAR INCLUDING CENTURY
    406. 

  406. C            KPDS(9)  - MONTH OF YEAR
    407. 

  407. C            KPDS(10) - DAY OF MONTH
    408. 

  408. C            KPDS(11) - HOUR OF DAY
    409. 

  409. C            KPDS(12) - MINUTE OF HOUR
    410. 

  410. C            KPDS(13) - INDICATOR OF FORECAST TIME UNIT (SEE "GRIB"
    411. 

  411. C                       TABLE 8)
    412. 

  412. C            KPDS(14) - TIME 1               (SEE "GRIB" TABLE 8A)
    413. 

  413. C            KPDS(15) - TIME 2               (SEE "GRIB" TABLE 8A)
    414. 

  414. C            KPDS(16) - TIME RANGE INDICATOR (SEE "GRIB" TABLE 8A)
    415. 

  415. C            KPDS(17) - NUMBER INCLUDED IN AVERAGE
    416. 

  416. C            KPDS(18) - EDITION NR OF GRIB SPECIFICATION
    417. 

  417. C            KPDS(19) - VERSION NR OF PARAMETER TABLE
    418. 

  418. C
    419. 

  419. C       KGDS(13)       INTEGER*4
    420. 

  420. C             ARRAY CONTAINING GDS ELEMENTS.
    421. 

  421. C
    422. 

  422. C            KGDS(1)  - DATA REPRESENTATION TYPE
    423. 

  423. C
    424. 

  424. C         LATITUDE/LONGITUDE GRIDS (SEE "GRIB" TABLE 10)
    425. 

  425. C            KGDS(2)  - N(I) NUMBER OF POINTS ON LATITUDE
    426. 

  426. C                       CIRCLE
    427. 

  427. C            KGDS(3)  - N(J) NUMBER OF POINTS ON LONGITUDE
    428. 

  428. C                       CIRCLE
    429. 

  429. C            KGDS(4)  - LA(1) LATITUDE OF ORIGIN
    430. 

  430. C            KGDS(5)  - LO(1) LONGITUDE OF ORIGIN
    431. 

  431. C            KGDS(6)  - RESOLUTION FLAG
    432. 

  432. C                           BIT       MEANING
    433. 

  433. C                            25       0 - DIRECTION INCREMENTS NOT
    434. 

  434. C                                         GIVEN
    435. 

  435. C                                     1 - DIRECTION INCREMENTS GIVEN
    436. 

  436. C            KGDS(7)  - LA(2) LATITUDE OF EXTREME POINT
    437. 

  437. C            KGDS(8)  - LO(2) LONGITUDE OF EXTREME POINT
    438. 

  438. C            KGDS(9)  - DI LONGITUDINAL DIRECTION INCREMENT
    439. 

  439. C            KGDS(10) - REGULAR LAT/LON GRID
    440. 

  440. C                           DJ - LATITUDINAL DIRECTION
    441. 

  441. C                                INCREMENT
    442. 

  442. C                       GAUSSIAN GRID
    443. 

  443. C                           N  - NUMBER OF LATITUDE CIRCLES
    444. 

  444. C                                BETWEEN A POLE AND THE EQUATOR
    445. 

  445. C            KGDS(11) - SCANNING MODE FLAG
    446. 

  446. C                           BIT       MEANING
    447. 

  447. C                            25       0 - POINTS ALONG A LATITUDE
    448. 

  448. C                                         SCAN FROM WEST TO EAST
    449. 

  449. C                                     1 - POINTS ALONG A LATITUDE
    450. 

  450. C                                         SCAN FROM EAST TO WEST
    451. 

  451. C                            26       0 - POINTS ALONG A MERIDIAN
    452. 

  452. C                                         SCAN FROM NORTH TO SOUTH
    453. 

  453. C                                     1 - POINTS ALONG A MERIDIAN
    454. 

  454. C                                         SCAN FROM SOUTH TO NORTH
    455. 

  455. C                            27       0 - POINTS SCAN FIRST ALONG
    456. 

  456. C                                         CIRCLES OF LATITUDE, THEN
    457. 

  457. C                                         ALONG MERIDIANS
    458. 

  458. C                                         (FORTRAN: (I,J))
    459. 

  459. C                                     1 - POINTS SCAN FIRST ALONG
    460. 

  460. C                                         MERIDIANS THEN ALONG
    461. 

  461. C                                         CIRCLES OF LATITUDE
    462. 

  462. C                                         (FORTRAN: (J,I))
    463. 

  463. C
    464. 

  464. C         POLAR STEREOGRAPHIC GRIDS  (SEE GRIB TABLE 12)
    465. 

  465. C            KGDS(2)  - N(I) NR POINTS ALONG LAT CIRCLE
    466. 

  466. C            KGDS(3)  - N(J) NR POINTS ALONG LON CIRCLE
    467. 

  467. C            KGDS(4)  - LA(1) LATITUDE OF ORIGIN
    468. 

  468. C            KGDS(5)  - LO(1) LONGITUDE OF ORIGIN
    469. 

  469. C            KGDS(6)  - RESERVED
    470. 

  470. C            KGDS(7)  - LOV GRID ORIENTATION
    471. 

  471. C            KGDS(8)  - DX - X DIRECTION INCREMENT
    472. 

  472. C            KGDS(9)  - DY - Y DIRECTION INCREMENT
    473. 

  473. C            KGDS(10) - PROJECTION CENTER FLAG
    474. 

  474. C            KGDS(11) - SCANNING MODE
    475. 

  475. C
    476. 

  476. C         SPHERICAL HARMONIC COEFFICIENTS (SEE "GRIB" TABLE 14)
    477. 

  477. C            KGDS(2)  - J PENTAGONAL RESOLUTION PARAMETER
    478. 

  478. C            KGDS(3)  - K PENTAGONAL RESOLUTION PARAMETER
    479. 

  479. C            KGDS(4)  - M PENTAGONAL RESOLUTION PARAMETER
    480. 

  480. C            KGDS(5)  - REPRESENTATION TYPE
    481. 

  481. C            KGDS(6)  - COEFFICIENT STORAGE MODE
    482. 

  482. C
    483. 

  483. C       MERCATOR GRIDS
    484. 

  484. C            KGDS(2)   - N(I) NR POINTS ON LATITUDE CIRCLE
    485. 

  485. C            KGDS(3)   - N(J) NR POINTS ON LONGITUDE MERIDIAN
    486. 

  486. C            KGDS(4)   - LA(1) LATITUDE OF ORIGIN
    487. 

  487. C            KGDS(5)   - LO(1) LONGITUDE OF ORIGIN
    488. 

  488. C            KGDS(6)   - RESOLUTION FLAG
    489. 

  489. C            KGDS(7)   - LA(2) LATITUDE OF LAST GRID POINT
    490. 

  490. C            KGDS(8)   - LO(2) LONGITUDE OF LAST GRID POINT
    491. 

  491. C            KGDS(9)   - LATIN - LATITUDE OF PROJECTION INTERSECTION
    492. 

  492. C            KGDS(10)  - RESERVED
    493. 

  493. C            KGDS(11)  - SCANNING MODE FLAG
    494. 

  494. C            KGDS(12)  - LONGITUDINAL DIR GRID LENGTH
    495. 

  495. C            KGDS(13)  - LATITUDINAL DIR GRID LENGTH
    496. 

  496. C       LAMBERT CONFORMAL GRIDS
    497. 

  497. C            KGDS(2)   - NX NR POINTS ALONG X-AXIS
    498. 

  498. C            KGDS(3)   - NY NR POINTS ALONG Y-AXIS
    499. 

  499. C            KGDS(4)   - LA1 LAT OF ORIGIN (LOWER LEFT)
    500. 

  500. C            KGDS(5)   - LO1 LON OF ORIGIN (LOWER LEFT)
    501. 

  501. C            KGDS(6)   - RESOLUTION (RIGHT ADJ COPY OF OCTET 17)
    502. 

  502. C            KGDS(7)   - LOV - ORIENTATION OF GRID
    503. 

  503. C            KGDS(8)   - DX - X-DIR INCREMENT
    504. 

  504. C            KGDS(9)   - DY - Y-DIR INCREMENT
    505. 

  505. C            KGDS(10)  - PROJECTION CENTER FLAG
    506. 

  506. C            KGDS(11)  - SCANNING MODE FLAG
    507. 

  507. C            KGDS(12)  - LATIN 1 - FIRST LAT FROM POLE OF
    508. 

  508. C                        SECANT CONE INTERSECTION
    509. 

  509. C            KGDS(13)  - LATIN 2 - SECOND LAT FROM POLE OF
    510. 

  510. C                        SECANT CONE INTERSECTION
    511. 

  511. C
    512. 

  512. C       LBMS(*)    LOGICAL
    513. 

  513. C               ARRAY TO CONTAIN THE BIT MAP DESCRIBING THE
    514. 

  514. C               PLACEMENT OF DATA IN THE OUTPUT ARRAY.  IF A
    515. 

  515. C               BIT MAP IS NOT INCLUDED IN THE SOURCE MESSAGE,
    516. 

  516. C               ONE WILL BE GENERATED AUTOMATICALLY BY THE
    517. 

  517. C               UNPACKING ROUTINE.
    518. 

  518. C
    519. 

  519. C
    520. 

  520. C       DATA(*)    REAL*4
    521. 

  521. C               THIS ARRAY WILL CONTAIN THE UNPACKED DATA POINTS.
    522. 

  522. C
    523. 

  523. C                      NOTE:- 65160 IS MAXIMUN FIELD SIZE ALLOWABLE
    524. 

  524. C
    525. 

  525. C       KPTR(10)       INTEGER*4
    526. 

  526. C               ARRAY CONTAINING STORAGE FOR THE FOLLOWING
    527. 

  527. C               PARAMETERS.
    528. 

  528. C
    529. 

  529. C                 (1)  -    UNUSED
    530. 

  530. C                 (2)  -    UNUSED
    531. 

  531. C                 (3)  -    LENGTH OF PDS (IN BYTES)
    532. 

  532. C                 (4)  -    LENGTH OF GDS (IN BYTES)
    533. 

  533. C                 (5)  -    LENGTH OF BMS (IN BYTES)
    534. 

  534. C                 (6)  -    LENGTH OF BDS (IN BYTES)
    535. 

  535. C                 (7)  -    USED BY UNPACKING ROUTINE
    536. 

  536. C                 (8)  -    NUMBER OF DATA POINTS FOR GRID
    537. 

  537. C                 (9)  -    "GRIB" CHARACTERS START IN BYTE NUMBER
    538. 

  538. C                 (10) -    USED BY UNPACKING ROUTINE
    539. 

  539. C
    540. 

  540. C
    541. 

  541. C       KRET      INTEGER*4
    542. 

  542. C                 THIS VARIABLE WILL CONTAIN THE RETURN INDICATOR.
    543. 

  543. C
    544. 

  544. C                 0    -    NO ERRORS DETECTED.
    545. 

  545. C
    546. 

  546. C                 1    -    'GRIB' NOT FOUND IN FIRST 100
    547. 

  547. C                           CHARACTERS.
    548. 

  548. C
    549. 

  549. C                 2    -    '7777' NOT FOUND, EITHER MISSING OR
    550. 

  550. C                           TOTAL OF SEC   COUNTS OF INDIVIDUAL
    551. 

  551. C                           SECTIONS  IS INCORRECT.
    552. 

  552. C
    553. 

  553. C                 3    -    UNPACKED FIELD IS LARGER THAN 65160.
    554. 

  554. C
    555. 

  555. C                 4    -    IN GDS, DATA REPRESENTATION TYPE
    556. 

  556. C                           NOT ONE OF THE CURRENTLY ACCEPTABLE
    557. 

  557. C                           VALUES. SEE "GRIB" TABLE 9. VALUE
    558. 

  558. C                           OF INCORRECT TYPE RETURNED IN KGDS(1).
    559. 

  559. C
    560. 

  560. C                 5    -    GRID INDICATED IN KPDS(3) IS NOT
    561. 

  561. C                           AVAILABLE FOR THE CENTER INDICATED IN
    562. 

  562. C                           KPDS(1) AND NO GDS SENT.
    563. 

  563. C
    564. 

  564. C                 7    -    EDITION INDICATED IN KPDS(18) HAS NOT
    565. 

  565. C                           YET BEEN INCLUDED IN THE DECODER.
    566. 

  566. C
    567. 

  567. C                 8    -    GRID IDENTIFICATION = 255 (NOT STANDARD
    568. 

  568. C                           GRID) BUT FLAG INDICATING PRESENCE OF
    569. 

  569. C                           GDS IS TURNED OFF. NO METHOD OF
    570. 

  570. C                           GENERATING PROPER GRID.
    571. 

  571. C
    572. 

  572. C                 9    -    PRODUCT OF KGDS(2) AND KGDS(3) DOES NOT
    573. 

  573. C                           MATCH STANDARD NUMBER OF POINTS FOR THIS
    574. 

  574. C                           GRID (FOR OTHER THAN SPECTRALS). THIS
    575. 

  575. C                           WILL OCCUR ONLY IF THE GRID.
    576. 

  576. C                           IDENTIFICATION, KPDS(3), AND A
    577. 

  577. C                           TRANSMITTED GDS ARE INCONSISTENT.
    578. 

  578. C
    579. 

  579. C                10    -    CENTER INDICATOR WAS NOT ONE INDICATED
    580. 

  580. C                           IN "GRIB" TABLE 1.  PLEASE CONTACT AD
    581. 

  581. C                           PRODUCTION MANAGEMENT BRANCH (W/NMC42)
    582. 

  582. C                                     IF THIS ERROR IS ENCOUNTERED.
    583. 

  583. C
    584. 

  584. C                11    -    BINARY DATA SECTION (BDS) NOT COMPLETELY
    585. 

  585. C                           PROCESSED.  PROGRAM IS NOT SET TO PROCESS
    586. 

  586. C                           FLAG COMBINATIONS AS SHOWN IN
    587. 

  587. C                           OCTETS 4 AND 14.
    588. 

  588. C
    589. 

  589. C
    590. 

  590. C  LIST OF TEXT MESSAGES FROM CODE
    591. 

  591. C
    592. 

  592. C
    593. 

  593. C  W3FI63/FI632
    594. 

  594. C
    595. 

  595. C            'HAVE ENCOUNTERED A NEW GRID FOR NMC, PLEASE NOTIFY
    596. 

  596. C            AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
    597. 

  597. C            (W/NMC42)'
    598. 

  598. C
    599. 

  599. C            'HAVE ENCOUNTERED A NEW GRID FOR ECMWF, PLEASE NOTIFY
    600. 

  600. C            AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
    601. 

  601. C            (W/NMC42)'
    602. 

  602. C
    603. 

  603. C            'HAVE ENCOUNTERED A NEW GRID FOR U.K. METEOROLOGICAL
    604. 

  604. C            OFFICE, BRACKNELL.  PLEASE NOTIFY AUTOMATION DIVISION,
    605. 

  605. C            PRODUCTION MANAGEMENT BRANCH (W/NMC42)'
    606. 

  606. C
    607. 

  607. C            'HAVE ENCOUNTERED A NEW GRID FOR FNOC, PLEASE NOTIFY
    608. 

  608. C            AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
    609. 

  609. C            (W/NMC42)'
    610. 

  610. C
    611. 

  611. C
    612. 

  612. C  W3FI63/FI633
    613. 

  613. C
    614. 

  614. C            'POLAR STEREO PROCESSING NOT AVAILABLE'  *
    615. 

  615. C
    616. 

  616. C  W3FI63/FI634
    617. 

  617. C
    618. 

  618. C            'WARNING - BIT MAP MAY NOT BE ASSOCIATED WITH SPHERICAL
    619. 

  619. C            COEFFICIENTS'
    620. 

  620. C
    621. 

  621. C
    622. 

  622. C  W3FI63/FI637
    623. 

  623. C
    624. 

  624. C            'NO CURRENT LISTING OF FNOC GRIDS'      *
    625. 

  625. C
    626. 

  626. C
    627. 

  627. C  * WILL BE AVAILABLE IN NEXT UPDATE
    628. 

  628. C  ***************************************************************
    629. 

  629. C
    630. 

  630. C                       INCOMING MESSAGE HOLDER
    631. 

  631.       CHARACTER*1   MSGA(*)
    632. 

  632. C                       BIT MAP
    633. 

  633.       LOGICAL*1     KBMS(*)
    634. 

  634. C
    635. 

  635. C                       ELEMENTS OF PRODUCT DESCRIPTION SEC   (PDS)
    636. 

  636.       INTEGER       KPDS(*)
    637. 

  637. C                       ELEMENTS OF GRID DESCRIPTION SEC   (PDS)
    638. 

  638.       INTEGER       KGDS(*)
    639. 

  639. C
    640. 

  640. C                       CONTAINER FOR GRIB GRID
    641. 

  641.       REAL          DATA(*)
    642. 

  642. C
    643. 

  643. C                       ARRAY OF POINTERS AND COUNTERS
    644. 

  644.       INTEGER       KPTR(*)
    645. 

  645. C
    646. 

  646. C  *****************************************************************
    647. 

  647.       INTEGER       JSGN,JEXP,IFR,NPTS
    648. 

  648.       REAL          REALKK,FVAL1,FDIFF1
    649. 

  649. C  *****************************************************************
    650. 

  650. C        1.0 LOCATE BEGINNING OF 'GRIB' MESSAGE
    651. 

  651. C             FIND 'GRIB' CHARACTERS
    652. 

  652. C        2.0  USE COUNTS IN EACH DESCRIPTION SEC   TO DETERMINE
    653. 

  653. C             IF '7777' IS IN PROPER PLACE.
    654. 

  654. C        3.0  PARSE PRODUCT DEFINITION SECTION.
    655. 

  655. C        4.0  PARSE GRID DESCRIPTION SEC   (IF INCLUDED)
    656. 

  656. C        5.0  PARSE BIT MAP SEC   (IF INCLUDED)
    657. 

  657. C        6.0  USING INFORMATION FROM PRODUCT DEFINITION, GRID
    658. 

  658. C                  DESCRIPTION, AND BIT MAP SECTIONS.. EXTRACT
    659. 

  659. C                  DATA AND PLACE INTO PROPER ARRAY.
    660. 

  660. C  *******************************************************************
    661. 

  661. C
    662. 

  662. C                      MAIN DRIVER
    663. 

  663. C
    664. 

  664. C  *******************************************************************
    665. 

  665.       KPTR(10) = 0
    666. 

  666. C                  SEE IF PROPER 'GRIB' KEY EXISTS, THEN
    667. 

  667. C                  USING SEC   COUNTS, DETERMINE IF '7777'
    668. 

  668. C                  IS IN THE PROPER LOCATION
    669. 

  669. C
    670. 

  670.       CALL FI631(MSGA,KPTR,KPDS,KRET)
    671. 

  671.       IF(KRET.NE.0) THEN
    672. 

  672.           GO TO 900
    673. 

  673.       END IF
    674. 

  674. C     PRINT *,'FI631 KPTR',(KPTR(I),I=1,16)
    675. 

  675. C
    676. 

  676. C                  PARSE PARAMETERS FROM PRODUCT DESCRIPTION SECTION
    677. 

  677. C
    678. 

  678.       CALL FI632(MSGA,KPTR,KPDS,KRET)
    679. 

  679.       IF(KRET.NE.0) THEN
    680. 

  680.           GO TO 900
    681. 

  681.       END IF
    682. 

  682. C     PRINT *,'FI632 KPTR',(KPTR(I),I=1,16)
    683. 

  683. C
    684. 

  684. C                  IF AVAILABLE, EXTRACT NEW GRID DESCRIPTION
    685. 

  685. C
    686. 

  686.       IF (IAND(KPDS(4),128).NE.0) THEN
    687. 

  687.           CALL FI633(MSGA,KPTR,KGDS,KRET)
    688. 

  688.           IF(KRET.NE.0) THEN
    689. 

  689.               GO TO 900
    690. 

  690.           END IF
    691. 

  691. C         PRINT *,'FI633 KPTR',(KPTR(I),I=1,16)
    692. 

  692.       END IF
    693. 

  693. C
    694. 

  694. C                  EXTRACT OR GENERATE BIT MAP
    695. 

  695. C
    696. 

  696.       CALL FI634(MSGA,KPTR,KPDS,KGDS,KBMS,KRET)
    697. 

  697.       IF (KRET.NE.0) THEN
    698. 

  698.         IF (KRET.NE.9) THEN
    699. 

  699.           GO TO 900
    700. 

  700.         END IF
    701. 

  701.       END IF
    702. 

  702. C     PRINT *,'FI634 KPTR',(KPTR(I),I=1,16)
    703. 

  703. C
    704. 

  704. C                  USING INFORMATION FROM PDS, BMS AND BIT DATA SEC  ,
    705. 

  705. C                  EXTRACT AND SAVE IN GRIB GRID, ALL DATA ENTRIES.
    706. 

  706. C
    707. 

  707.       IF (KPDS(18).EQ.1) THEN
    708. 

  708.           CALL FI635(MSGA,KPTR,KPDS,KGDS,KBMS,DATA,KRET)
    709. 

  709.           IF (KPTR(3).EQ.50) THEN
    710. 

  710. C
    711. 

  711. C                     PDS EQUAL 50 BYTES
    712. 

  712. C                        THEREFORE SOMETHING SPECIAL IS GOING ON
    713. 

  713. C
    714. 

  714. C                        IN THIS CASE 2ND DIFFERENCE PACKING
    715. 

  715. C                                NEEDS TO BE UNDONE.
    716. 

  716. C
    717. 

  717. C                   EXTRACT FIRST VALUE FROM BYTE 41-44 PDS
    718. 

  718. C                              KPTR(9) CONTAINS OFFSET TO START OF
    719. 

  719. C                              GRIB MESSAGE.
    720. 

  720. C                   EXTRACT FIRST FIRST-DIFFERENCE FROM BYTES 45-48 PDS
    721. 

  721. C
    722. 

  722. C                  AND EXTRACT SCALE FACTOR (E) TO UNDO 2**E
    723. 

  723. C                  THAT WAS APPLIED PRIOR TO 2ND ORDER PACKING
    724. 

  724. C                  AND PLACED IN PDS BYTES 49-51
    725. 

  725. C                  FACTOR IS A SIGNED TWO BYTE INTEGER
    726. 

  726. C
    727. 

  727. C                  ALSO NEED THE DECIMAL SCALING FROM PDS(27-28)
    728. 

  728. C                  (AVAILABLE IN KPDS(22) FROM UNPACKER)
    729. 

  729. C                  TO UNDO THE DECIMAL SCALING APPLIED TO THE
    730. 

  730. C                  SECOND DIFFERENCES DURING UNPACKING.
    731. 

  731. C                  SECOND DIFFS ALWAYS PACKED WITH 0 DECIMAL SCALE
    732. 

  732. C                  BUT UNPACKER DOESNT KNOW THAT.
    733. 

  733. C
    734. 

  734. C             CALL GBYTE  (MSGA,FVAL1,KPTR(9)+384,32)
    735. 

  735. C
    736. 

  736. C         NOTE INTEGERS, CHARACTERS AND EQUIVALENCES
    737. 

  737. C         DEFINED ABOVE TO MAKE THIS KKK EXTRACTION
    738. 

  738. C         WORK AND LINE UP ON WORD BOUNDARIES
    739. 

  739. C
    740. 

  740. C       THE NEXT CODE WILL CONVERT THE IBM370 FOATING POINT
    741. 

  741. C       TO THE FLOATING POINT USED ON YOUR MACHINE.
    742. 

  742. C
    743. 

  743.         call gbytec(MSGA,JSGN,KPTR(9)+384,1)
    744. 

  744.         call gbytec(MSGA,JEXP,KPTR(9)+385,7)
    745. 

  745.         call gbytec(MSGA,IFR,KPTR(9)+392,24)
    746. 

  746. C
    747. 

  747.               IF (IFR.EQ.0) THEN
    748. 

  748.                   REALKK = 0.0
    749. 

  749.               ELSE IF (JEXP.EQ.0.AND.IFR.EQ.0) THEN
    750. 

  750.                   REALKK = 0.0
    751. 

  751.               ELSE
    752. 

  752.                   REALKK = FLOAT(IFR) * 16.0 ** (JEXP - 64 - 6)
    753. 

  753.                   IF (JSGN.NE.0) REALKK = -REALKK
    754. 

  754.               END IF
    755. 

  755.               FVAL1 = REALKK
    756. 

  756. C
    757. 

  757. C             CALL GBYTE  (MSGA,FDIFF1,KPTR(9)+416,32)
    758. 

  758. C          (REPLACED BY FOLLOWING EXTRACTION)
    759. 

  759. C
    760. 

  760. C       THE NEXT CODE WILL CONVERT THE IBM370 FOATING POINT
    761. 

  761. C       TO THE FLOATING POINT USED ON YOUR MACHINE.
    762. 

  762. C
    763. 

  763.              call gbytec(MSGA,JSGN,KPTR(9)+416,1)
    764. 

  764.              call gbytec(MSGA,JEXP,KPTR(9)+417,7)
    765. 

  765.              call gbytec(MSGA,IFR,KPTR(9)+424,24)
    766. 

  766. C
    767. 

  767.               IF (IFR.EQ.0) THEN
    768. 

  768.                   REALKK = 0.0
    769. 

  769.               ELSE IF (JEXP.EQ.0.AND.IFR.EQ.0) THEN
    770. 

  770.                   REALKK = 0.0
    771. 

  771.               ELSE
    772. 

  772.                   REALKK = FLOAT(IFR) * 16.0 ** (JEXP - 64 - 6)
    773. 

  773.                   IF (JSGN.NE.0) REALKK = -REALKK
    774. 

  774.               END IF
    775. 

  775.               FDIFF1 = REALKK
    776. 

  776. C
    777. 

  777.               CALL GBYTEC (MSGA,ISIGN,KPTR(9)+448,1)
    778. 

  778.               CALL GBYTEC (MSGA,ISCAL2,KPTR(9)+449,15)
    779. 

  779.               IF(ISIGN.GT.0) THEN
    780. 

  780.                   ISCAL2 = - ISCAL2
    781. 

  781.               ENDIF
    782. 

  782. C             PRINT *,'DELTA POINT 1-',FVAL1
    783. 

  783. C             PRINT *,'DELTA POINT 2-',FDIFF1
    784. 

  784. C             PRINT *,'DELTA POINT 3-',ISCAL2
    785. 

  785.               NPTS  = KPTR(10)
    786. 

  786. C             WRITE (6,FMT='(''  2ND DIFF POINTS IN FIELD = '',/,
    787. 

  787. C    &         10(3X,10F12.2,/))') (DATA(I),I=1,NPTS)
    788. 

  788. C             PRINT *,'DELTA POINT 4-',KPDS(22)
    789. 

  789.               CALL W3FI83 (DATA,NPTS,FVAL1,FDIFF1,
    790. 

  790.      &                            ISCAL2,KPDS(22),KPDS,KGDS)
    791. 

  791. C             WRITE (6,FMT='(''  2ND DIFF EXPANDED POINTS IN FIELD = '',
    792. 

  792. C    &            /,10(3X,10F12.2,/))') (DATA(I),I=1,NPTS)
    793. 

  793. C             WRITE (6,FMT='(''  END OF ARRAY IN FIELD = '',/,
    794. 

  794. C    &         10(3X,10F12.2,/))') (DATA(I),I=NPTS-5,NPTS)
    795. 

  795.           END IF
    796. 

  796.       ELSE
    797. 

  797. C         PRINT *,'FI635 NOT PROGRAMMED FOR EDITION NR',KPDS(18)
    798. 

  798.           KRET   = 7
    799. 

  799.       END IF
    800. 

  800. C
    801. 

  801.   900 RETURN
    802. 

  802.       END
    803. 

  803.       SUBROUTINE FI631(MSGA,KPTR,KPDS,KRET)
    804. 

  804. C$$$  SUBPROGRAM DOCUMENTATION  BLOCK
    805. 

  805. C                .      .    .                                       .
    806. 

  806. C SUBPROGRAM:    FI631       FIND 'GRIB' CHARS & RESET POINTERS
    807. 

  807. C   PRGMMR: BILL CAVANAUGH   ORG: W/NMC42    DATE: 91-09-13
    808. 

  808. C
    809. 

  809. C ABSTRACT: FIND 'GRIB; CHARACTERS AND SET POINTERS TO THE NEXT
    810. 

  810. C   BYTE FOLLOWING 'GRIB'. IF THEY EXIST EXTRACT COUNTS FROM GDS AND
    811. 

  811. C   BMS. EXTRACT COUNT FROM BDS. DETERMINE IF SUM OF COUNTS ACTUALLY
    812. 

  812. C   PLACES TERMINATOR '7777' AT THE CORRECT LOCATION.
    813. 

  813. C
    814. 

  814. C PROGRAM HISTORY LOG:
    815. 

  815. C   91-09-13  CAVANAUGH
    816. 

  816. C   95-10-31  IREDELL     REMOVED SAVES AND PRINTS
    817. 

  817. C
    818. 

  818. C USAGE:    CALL FI631(MSGA,KPTR,KPDS,KRET)
    819. 

  819. C   INPUT ARGUMENT LIST:
    820. 

  820. C     MSGA       - GRIB FIELD - "GRIB" THRU "7777"
    821. 

  821. C     KPTR       - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
    822. 

  822. C          (1)   - TOTAL LENGTH OF GRIB MESSAGE
    823. 

  823. C          (2)   - LENGTH OF INDICATOR (SECTION  0)
    824. 

  824. C          (3)   - LENGTH OF PDS       (SECTION  1)
    825. 

  825. C          (4)   - LENGTH OF GDS       (SECTION  2)
    826. 

  826. C          (5)   - LENGTH OF BMS       (SECTION  3)
    827. 

  827. C          (6)   - LENGTH OF BDS       (SECTION  4)
    828. 

  828. C          (7)   - VALUE OF CURRENT BYTE
    829. 

  829. C          (8)   - BIT POINTER
    830. 

  830. C          (9)   - GRIB START BIT NR
    831. 

  831. C         (10)   - GRIB/GRID ELEMENT COUNT
    832. 

  832. C         (11)   - NR UNUSED BITS AT END OF SECTION 3
    833. 

  833. C         (12)   - BIT MAP FLAG
    834. 

  834. C         (13)   - NR UNUSED BITS AT END OF SECTION 2
    835. 

  835. C         (14)   - BDS FLAGS
    836. 

  836. C         (15)   - NR UNUSED BITS AT END OF SECTION 4
    837. 

  837. C
    838. 

  838. C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
    839. 

  839. C     KPDS     - ARRAY CONTAINING PDS ELEMENTS.
    840. 

  840. C          (1)   - ID OF CENTER
    841. 

  841. C          (2)   - MODEL IDENTIFICATION
    842. 

  842. C          (3)   - GRID IDENTIFICATION
    843. 

  843. C          (4)   - GDS/BMS FLAG
    844. 

  844. C          (5)   - INDICATOR OF PARAMETER
    845. 

  845. C          (6)   - TYPE OF LEVEL
    846. 

  846. C          (7)   - HEIGHT/PRESSURE , ETC OF LEVEL
    847. 

  847. C          (8)   - YEAR OF CENTURY
    848. 

  848. C          (9)   - MONTH OF YEAR
    849. 

  849. C          (10)  - DAY OF MONTH
    850. 

  850. C          (11)  - HOUR OF DAY
    851. 

  851. C          (12)  - MINUTE OF HOUR
    852. 

  852. C          (13)  - INDICATOR OF FORECAST TIME UNIT
    853. 

  853. C          (14)  - TIME RANGE 1
    854. 

  854. C          (15)  - TIME RANGE 2
    855. 

  855. C          (16)  - TIME RANGE FLAG
    856. 

  856. C          (17)  - NUMBER INCLUDED IN AVERAGE
    857. 

  857. C     KPTR       - SEE INPUT LIST
    858. 

  858. C     KRET       - ERROR RETURN
    859. 

  859. C
    860. 

  860. C REMARKS:
    861. 

  861. C     ERROR RETURNS
    862. 

  862. C     KRET  = 1  -  NO 'GRIB'
    863. 

  863. C             2  -  NO '7777' OR MISLOCATED (BY COUNTS)
    864. 

  864. C
    865. 

  865. C   SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
    866. 

  866. C
    867. 

  867. C ATTRIBUTES:
    868. 

  868. C   LANGUAGE: FORTRAN 77
    869. 

  869. C   MACHINE:  HDS9000
    870. 

  870. C
    871. 

  871. C$$$
    872. 

  872. C
    873. 

  873. C                       INCOMING MESSAGE HOLDER
    874. 

  874.       CHARACTER*1   MSGA(*)
    875. 

  875. C                       ARRAY OF POINTERS AND COUNTERS
    876. 

  876.       INTEGER       KPTR(*)
    877. 

  877. C                       PRODUCT DESCRIPTION SECTION DATA.
    878. 

  878.       INTEGER       KPDS(*)
    879. 

  879. C
    880. 

  880.       INTEGER       KRET
    881. 

  881. C
    882. 

  882. C  ******************************************************************
    883. 

  883.       KRET = 0
    884. 

  884. C  -------------------  FIND 'GRIB' KEY
    885. 

  885.       DO 50 I = 0, 839, 8
    886. 

  886.           CALL GBYTEC (MSGA,MGRIB,I,32)
    887. 

  887.           IF (MGRIB.EQ.1196575042) THEN
    888. 

  888.               KPTR(9)   = I
    889. 

  889.               GO TO 60
    890. 

  890.           END IF
    891. 

  891.    50 CONTINUE
    892. 

  892.       KRET  = 1
    893. 

  893.       RETURN
    894. 

  894.    60 CONTINUE
    895. 

  895. C  -------------FOUND 'GRIB'
    896. 

  896. C                        SKIP GRIB CHARACTERS
    897. 

  897. C     PRINT *,'FI631 GRIB AT',I
    898. 

  898.       KPTR(8)   = KPTR(9) + 32
    899. 

  899.       CALL GBYTEC (MSGA,ITOTAL,KPTR(8),24)
    900. 

  900. C                    HAVE LIFTED WHAT MAY BE A MSG TOTAL BYTE COUNT
    901. 

  901.       IPOINT    = KPTR(9) + ITOTAL * 8 - 32
    902. 

  902.       CALL GBYTEC (MSGA,I7777,IPOINT,32)
    903. 

  903.       IF (I7777.EQ.926365495) THEN
    904. 

  904. C                 HAVE FOUND END OF MESSAGE '7777' IN PROPER LOCATION
    905. 

  905. C                 MARK AND PROCESS AS GRIB VERSION 1 OR HIGHER
    906. 

  906. C         PRINT *,'FI631 7777 AT',IPOINT
    907. 

  907.           KPTR(8)   = KPTR(8) + 24
    908. 

  908.           KPTR(1)   = ITOTAL
    909. 

  909.           KPTR(2)   = 8
    910. 

  910.           CALL GBYTEC (MSGA,KPDS(18),KPTR(8),8)
    911. 

  911.           KPTR(8)   = KPTR(8) + 8
    912. 

  912.       ELSE
    913. 

  913. C                 CANNOT FIND END OF GRIB EDITION 1 MESSAGE
    914. 

  914.           KRET      = 2
    915. 

  915.           RETURN
    916. 

  916.       END IF
    917. 

  917. C  -------------------  PROCESS SECTION 1
    918. 

  918. C                   EXTRACT COUNT FROM PDS
    919. 

  919. C     PRINT *,'START OF PDS',KPTR(8)
    920. 

  920.       CALL GBYTEC (MSGA,KPTR(3),KPTR(8),24)
    921. 

  921.       LOOK      = KPTR(8) + 56
    922. 

  922. C                   EXTRACT GDS/BMS FLAG
    923. 

  923.       CALL GBYTEC (MSGA,KPDS(4),LOOK,8)
    924. 

  924.       KPTR(8)   = KPTR(8) + KPTR(3) * 8
    925. 

  925. C     PRINT *,'START OF GDS',KPTR(8)
    926. 

  926.       IF (IAND(KPDS(4),128).NE.0) THEN
    927. 

  927. C                   EXTRACT COUNT FROM GDS
    928. 

  928.           CALL GBYTEC (MSGA,KPTR(4),KPTR(8),24)
    929. 

  929.           KPTR(8)   = KPTR(8) + KPTR(4) * 8
    930. 

  930.       ELSE
    931. 

  931.           KPTR(4)   = 0
    932. 

  932.       END IF
    933. 

  933. C     PRINT *,'START OF BMS',KPTR(8)
    934. 

  934.       IF (IAND(KPDS(4),64).NE.0) THEN
    935. 

  935. C                   EXTRACT COUNT FROM BMS
    936. 

  936.           CALL GBYTEC (MSGA,KPTR(5),KPTR(8),24)
    937. 

  937.       ELSE
    938. 

  938.           KPTR(5)   = 0
    939. 

  939.       END IF
    940. 

  940.       KPTR(8)   = KPTR(8) + KPTR(5) * 8
    941. 

  941. C     PRINT *,'START OF BDS',KPTR(8)
    942. 

  942. C                   EXTRACT COUNT FROM BDS
    943. 

  943.       CALL GBYTEC (MSGA,KPTR(6),KPTR(8),24)
    944. 

  944. C  ---------------  TEST FOR '7777'
    945. 

  945. C     PRINT *,(KPTR(KJ),KJ=1,10)
    946. 

  946.       KPTR(8)   = KPTR(8) + KPTR(6) * 8
    947. 

  947. C                   EXTRACT FOUR BYTES FROM THIS LOCATION
    948. 

  948. C     PRINT *,'FI631 LOOKING FOR 7777 AT',KPTR(8)
    949. 

  949.       CALL GBYTEC (MSGA,K7777,KPTR(8),32)
    950. 

  950.       MATCH  = KPTR(2) + KPTR(3) + KPTR(4) + KPTR(5) + KPTR(6) + 4
    951. 

  951.       IF (K7777.NE.926365495.OR.MATCH.NE.KPTR(1)) THEN
    952. 

  952.           KRET  = 2
    953. 

  953.       ELSE
    954. 

  954. C         PRINT *,'FI631 7777 AT',KPTR(8)
    955. 

  955.           IF (KPDS(18).EQ.0) THEN
    956. 

  956.               KPTR(1)  = KPTR(2) + KPTR(3) + KPTR(4) + KPTR(5) +
    957. 

  957.      *                KPTR(6) + 4
    958. 

  958.           END IF
    959. 

  959.       END IF
    960. 

  960. C     PRINT *,'KPTR',(KPTR(I),I=1,16)
    961. 

  961.       RETURN
    962. 

  962.       END
    963. 

  963.       SUBROUTINE FI632(MSGA,KPTR,KPDS,KRET)
    964. 

  964. C$$$  SUBPROGRAM DOCUMENTATION  BLOCK
    965. 

  965. C                .      .    .                                       .
    966. 

  966. C SUBPROGRAM:    FI632       GATHER INFO FROM PRODUCT DEFINITION SEC
    967. 

  967. C   PRGMMR: BILL CAVANAUGH   ORG: W/NMC42    DATE: 91-09-13
    968. 

  968. C
    969. 

  969. C ABSTRACT: EXTRACT INFORMATION FROM THE PRODUCT DESCRIPTION
    970. 

  970. C   SEC  , AND GENERATE LABEL INFORMATION TO PERMIT STORAGE
    971. 

  971. C   IN OFFICE NOTE 84 FORMAT.
    972. 

  972. C
    973. 

  973. C PROGRAM HISTORY LOG:
    974. 

  974. C   91-09-13  CAVANAUGH
    975. 

  975. C   93-12-08  CAVANAUGH   CORRECTED TEST FOR EDITION NUMBER INSTEAD
    976. 

  976. C                         OF VERSION NUMBER
    977. 

  977. C   95-10-31  IREDELL     REMOVED SAVES AND PRINTS
    978. 

  978. C   99-01-20  BALDWIN     MODIFIED TO HANDLE GRID 237
    979. 

  979. C
    980. 

  980. C USAGE:    CALL FI632(MSGA,KPTR,KPDS,KRET)
    981. 

  981. C   INPUT ARGUMENT LIST:
    982. 

  982. C     MSGA      - ARRAY CONTAINING GRIB MESSAGE
    983. 

  983. C     KPTR       - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
    984. 

  984. C          (1)   - TOTAL LENGTH OF GRIB MESSAGE
    985. 

  985. C          (2)   - LENGTH OF INDICATOR (SECTION  0)
    986. 

  986. C          (3)   - LENGTH OF PDS       (SECTION  1)
    987. 

  987. C          (4)   - LENGTH OF GDS       (SECTION  2)
    988. 

  988. C          (5)   - LENGTH OF BMS       (SECTION  3)
    989. 

  989. C          (6)   - LENGTH OF BDS       (SECTION  4)
    990. 

  990. C          (7)   - VALUE OF CURRENT BYTE
    991. 

  991. C          (8)   - BIT POINTER
    992. 

  992. C          (9)   - GRIB START BIT NR
    993. 

  993. C         (10)   - GRIB/GRID ELEMENT COUNT
    994. 

  994. C         (11)   - NR UNUSED BITS AT END OF SECTION 3
    995. 

  995. C         (12)   - BIT MAP FLAG
    996. 

  996. C         (13)   - NR UNUSED BITS AT END OF SECTION 2
    997. 

  997. C         (14)   - BDS FLAGS
    998. 

  998. C         (15)   - NR UNUSED BITS AT END OF SECTION 4
    999. 

  999. C
    1000. 

  1000. C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
    1001. 

  1001. C     KPDS     - ARRAY CONTAINING PDS ELEMENTS.
    1002. 

  1002. C          (1)   - ID OF CENTER
    1003. 

  1003. C          (2)   - MODEL IDENTIFICATION
    1004. 

  1004. C          (3)   - GRID IDENTIFICATION
    1005. 

  1005. C          (4)   - GDS/BMS FLAG
    1006. 

  1006. C          (5)   - INDICATOR OF PARAMETER
    1007. 

  1007. C          (6)   - TYPE OF LEVEL
    1008. 

  1008. C          (7)   - HEIGHT/PRESSURE , ETC OF LEVEL
    1009. 

  1009. C          (8)   - YEAR OF CENTURY
    1010. 

  1010. C          (9)   - MONTH OF YEAR
    1011. 

  1011. C          (10)  - DAY OF MONTH
    1012. 

  1012. C          (11)  - HOUR OF DAY
    1013. 

  1013. C          (12)  - MINUTE OF HOUR
    1014. 

  1014. C          (13)  - INDICATOR OF FORECAST TIME UNIT
    1015. 

  1015. C          (14)  - TIME RANGE 1
    1016. 

  1016. C          (15)  - TIME RANGE 2
    1017. 

  1017. C          (16)  - TIME RANGE FLAG
    1018. 

  1018. C          (17)  - NUMBER INCLUDED IN AVERAGE
    1019. 

  1019. C          (18)  -
    1020. 

  1020. C          (19)  -
    1021. 

  1021. C          (20)  - NUMBER MISSING FROM AVGS/ACCUMULATIONS
    1022. 

  1022. C          (21)  - CENTURY
    1023. 

  1023. C          (22)  - UNITS DECIMAL SCALE FACTOR
    1024. 

  1024. C          (23)  - SUBCENTER
    1025. 

  1025. C     KPTR       - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
    1026. 

  1026. C                  SEE INPUT LIST
    1027. 

  1027. C     KRET   - ERROR RETURN
    1028. 

  1028. C
    1029. 

  1029. C REMARKS:
    1030. 

  1030. C        ERROR RETURN = 0 - NO ERRORS
    1031. 

  1031. C                     = 8 - TEMP GDS INDICATED, BUT NO GDS
    1032. 

  1032. C
    1033. 

  1033. C   SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
    1034. 

  1034. C
    1035. 

  1035. C ATTRIBUTES:
    1036. 

  1036. C   LANGUAGE: FORTRAN 77
    1037. 

  1037. C   MACHINE:  HDS9000
    1038. 

  1038. C
    1039. 

  1039. C$$$
    1040. 

  1040. C
    1041. 

  1041. C                       INCOMING MESSAGE HOLDER
    1042. 

  1042.       CHARACTER*1   MSGA(*)
    1043. 

  1043. C
    1044. 

  1044. C                       ARRAY OF POINTERS AND COUNTERS
    1045. 

  1045.       INTEGER       KPTR(*)
    1046. 

  1046. C                       PRODUCT DESCRIPTION SECTION ENTRIES
    1047. 

  1047.       INTEGER       KPDS(*)
    1048. 

  1048. C
    1049. 

  1049.       INTEGER       KRET
    1050. 

  1050.       KRET=0
    1051. 

  1051. C  -------------------  PROCESS SECTION 1
    1052. 

  1052.       KPTR(8)  = KPTR(9) + KPTR(2) * 8 + 24
    1053. 

  1053. C  BYTE 4
    1054. 

  1054. C                   PARAMETER TABLE VERSION NR
    1055. 

  1055.           CALL GBYTEC (MSGA,KPDS(19),KPTR(8),8)
    1056. 

  1056.           KPTR(8)   = KPTR(8) + 8
    1057. 

  1057. C  BYTE 5           IDENTIFICATION OF CENTER
    1058. 

  1058.       CALL GBYTEC (MSGA,KPDS(1),KPTR(8),8)
    1059. 

  1059.       KPTR(8)   = KPTR(8) + 8
    1060. 

  1060. C  BYTE 6
    1061. 

  1061. C                       GET GENERATING PROCESS ID NR
    1062. 

  1062.       CALL GBYTEC (MSGA,KPDS(2),KPTR(8),8)
    1063. 

  1063.       KPTR(8)   = KPTR(8) + 8
    1064. 

  1064. C  BYTE 7
    1065. 

  1065. C                      GRID DEFINITION
    1066. 

  1066.       CALL GBYTEC (MSGA,KPDS(3),KPTR(8),8)
    1067. 

  1067.       KPTR(8)   = KPTR(8) + 8
    1068. 

  1068. C  BYTE 8
    1069. 

  1069. C                      GDS/BMS FLAGS
    1070. 

  1070. C     CALL GBYTEC (MSGA,KPDS(4),KPTR(8),8)
    1071. 

  1071.       KPTR(8)   = KPTR(8) + 8
    1072. 

  1072. C  BYTE 9
    1073. 

  1073. C                      INDICATOR OF PARAMETER
    1074. 

  1074.       CALL GBYTEC (MSGA,KPDS(5),KPTR(8),8)
    1075. 

  1075.       KPTR(8)   = KPTR(8) + 8
    1076. 

  1076. C  BYTE 10
    1077. 

  1077. C                      TYPE OF LEVEL
    1078. 

  1078.       CALL GBYTEC (MSGA,KPDS(6),KPTR(8),8)
    1079. 

  1079.       KPTR(8)   = KPTR(8) + 8
    1080. 

  1080. C  BYTE 11,12
    1081. 

  1081. C                      HEIGHT/PRESSURE
    1082. 

  1082.       CALL GBYTEC (MSGA,KPDS(7),KPTR(8),16)
    1083. 

  1083.       KPTR(8)   = KPTR(8) + 16
    1084. 

  1084. C  BYTE 13
    1085. 

  1085. C                      YEAR OF CENTURY
    1086. 

  1086.       CALL GBYTEC (MSGA,KPDS(8),KPTR(8),8)
    1087. 

  1087.       KPTR(8)   = KPTR(8) + 8
    1088. 

  1088. C  BYTE 14
    1089. 

  1089. C                      MONTH OF YEAR
    1090. 

  1090.       CALL GBYTEC (MSGA,KPDS(9),KPTR(8),8)
    1091. 

  1091.       KPTR(8)   = KPTR(8) + 8
    1092. 

  1092. C  BYTE 15
    1093. 

  1093. C                      DAY OF MONTH
    1094. 

  1094.       CALL GBYTEC (MSGA,KPDS(10),KPTR(8),8)
    1095. 

  1095.       KPTR(8)   = KPTR(8) + 8
    1096. 

  1096. C  BYTE 16
    1097. 

  1097. C                      HOUR OF DAY
    1098. 

  1098.       CALL GBYTEC (MSGA,KPDS(11),KPTR(8),8)
    1099. 

  1099.       KPTR(8)   = KPTR(8) + 8
    1100. 

  1100. C  BYTE 17
    1101. 

  1101. C                      MINUTE
    1102. 

  1102.       CALL GBYTEC (MSGA,KPDS(12),KPTR(8),8)
    1103. 

  1103.       KPTR(8)   = KPTR(8) + 8
    1104. 

  1104. C  BYTE 18
    1105. 

  1105. C                      INDICATOR TIME UNIT RANGE
    1106. 

  1106.       CALL GBYTEC (MSGA,KPDS(13),KPTR(8),8)
    1107. 

  1107.       KPTR(8)   = KPTR(8) + 8
    1108. 

  1108. C  BYTE 19
    1109. 

  1109. C                      P1 - PERIOD OF TIME
    1110. 

  1110.       CALL GBYTEC (MSGA,KPDS(14),KPTR(8),8)
    1111. 

  1111.       KPTR(8)   = KPTR(8) + 8
    1112. 

  1112. C  BYTE 20
    1113. 

  1113. C                      P2 - PERIOD OF TIME
    1114. 

  1114.       CALL GBYTEC (MSGA,KPDS(15),KPTR(8),8)
    1115. 

  1115.       KPTR(8)   = KPTR(8) + 8
    1116. 

  1116. C  BYTE 21
    1117. 

  1117. C                      TIME RANGE INDICATOR
    1118. 

  1118.       CALL GBYTEC (MSGA,KPDS(16),KPTR(8),8)
    1119. 

  1119.       KPTR(8)   = KPTR(8) + 8
    1120. 

  1120. C
    1121. 

  1121. C     IF TIME RANGE INDICATOR IS 10, P1 IS PACKED IN
    1122. 

  1122. C     PDS BYTES 19-20
    1123. 

  1123. C
    1124. 

  1124.       IF (KPDS(16).EQ.10) THEN
    1125. 

  1125.           KPDS(14)  = KPDS(14) * 256 + KPDS(15)
    1126. 

  1126.           KPDS(15)  = 0
    1127. 

  1127.       END IF
    1128. 

  1128. C  BYTE 22,23
    1129. 

  1129. C                      NUMBER INCLUDED IN AVERAGE
    1130. 

  1130.       CALL GBYTEC (MSGA,KPDS(17),KPTR(8),16)
    1131. 

  1131.       KPTR(8)   = KPTR(8) + 16
    1132. 

  1132. C  BYTE 24
    1133. 

  1133. C                      NUMBER MISSING FROM AVERAGES/ACCUMULATIONS
    1134. 

  1134.       CALL GBYTEC (MSGA,KPDS(20),KPTR(8),8)
    1135. 

  1135.       KPTR(8)   = KPTR(8) + 8
    1136. 

  1136. C  BYTE 25
    1137. 

  1137. C                      IDENTIFICATION OF CENTURY
    1138. 

  1138.       CALL GBYTEC (MSGA,KPDS(21),KPTR(8),8)
    1139. 

  1139.       KPTR(8)   = KPTR(8) + 8
    1140. 

  1140.       IF (KPTR(3).GT.25) THEN
    1141. 

  1141. C  BYTE 26              SUB CENTER NUMBER
    1142. 

  1142.           CALL GBYTEC (MSGA,KPDS(23),KPTR(8),8)
    1143. 

  1143.           KPTR(8)   = KPTR(8) + 8
    1144. 

  1144.           IF (KPTR(3).GE.28) THEN
    1145. 

  1145. C  BYTE 27-28
    1146. 

  1146. C                          UNITS DECIMAL SCALE FACTOR
    1147. 

  1147.               CALL GBYTEC (MSGA,ISIGN,KPTR(8),1)
    1148. 

  1148.               KPTR(8)  = KPTR(8) + 1
    1149. 

  1149.               CALL GBYTEC (MSGA,IDEC,KPTR(8),15)
    1150. 

  1150.               KPTR(8)  = KPTR(8) + 15
    1151. 

  1151.               IF (ISIGN.GT.0) THEN
    1152. 

  1152.                   KPDS(22)  = - IDEC
    1153. 

  1153.               ELSE
    1154. 

  1154.                   KPDS(22)  = IDEC
    1155. 

  1155.               END IF
    1156. 

  1156.               ISIZ  = KPTR(3) - 28
    1157. 

  1157.               IF (ISIZ.LE.12) THEN
    1158. 

  1158. C  BYTE  29
    1159. 

  1159.                   CALL GBYTEC (MSGA,KPDS(24),KPTR(8)+8,8)
    1160. 

  1160. C  BYTE  30
    1161. 

  1161.                   CALL GBYTEC (MSGA,KPDS(25),KPTR(8)+16,8)
    1162. 

  1162. C  BYTES 31-40                  CURRENTLY RESERVED FOR FUTURE USE
    1163. 

  1163.                   KPTR(8)  = KPTR(8) + ISIZ * 8
    1164. 

  1164.               ELSE
    1165. 

  1165. C  BYTE  29
    1166. 

  1166.                   CALL GBYTEC (MSGA,KPDS(24),KPTR(8)+8,8)
    1167. 

  1167. C  BYTE  30
    1168. 

  1168.                   CALL GBYTEC (MSGA,KPDS(25),KPTR(8)+16,8)
    1169. 

  1169. C  BYTES 31-40                  CURRENTLY RESERVED FOR FUTURE USE
    1170. 

  1170.                   KPTR(8)  = KPTR(8) + 12 * 8
    1171. 

  1171. C  BYTES 41 - N                 LOCAL USE DATA
    1172. 

  1172.                   CALL W3FI01(LW)
    1173. 

  1173. C                  MWDBIT  = LW * 8
    1174. 

  1174.                   MWDBIT  = bit_size(KPDS)
    1175. 

  1175.                   ISIZ    = KPTR(3) - 40
    1176. 

  1176.                   ITER    = ISIZ / LW
    1177. 

  1177.                   IF (MOD(ISIZ,LW).NE.0) ITER = ITER + 1
    1178. 

  1178.                   CALL GBYTESC (MSGA,KPDS(36),KPTR(8),MWDBIT,0,ITER)
    1179. 

  1179.                   KPTR(8)  = KPTR(8) + ISIZ * 8
    1180. 

  1180.               END IF
    1181. 

  1181.           END IF
    1182. 

  1182.       END IF
    1183. 

  1183. C  ----------- TEST FOR NEW GRID
    1184. 

  1184.       IF (IAND(KPDS(4),128).NE.0) THEN
    1185. 

  1185.           IF (IAND(KPDS(4),64).NE.0) THEN
    1186. 

  1186.               IF (KPDS(3).NE.255) THEN
    1187. 

  1187.                   IF (KPDS(3).GE.21.AND.KPDS(3).LE.26)THEN
    1188. 

  1188.                       RETURN
    1189. 

  1189.                   ELSE IF (KPDS(3).GE.37.AND.KPDS(3).LE.44)THEN
    1190. 

  1190.                       RETURN
    1191. 

  1191.                   ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN
    1192. 

  1192.                       RETURN
    1193. 

  1193.                   END IF
    1194. 

  1194.                   IF (KPDS(1).EQ.7) THEN
    1195. 

  1195.                       IF (KPDS(3).GE.2.AND.KPDS(3).LE.3) THEN
    1196. 

  1196.                       ELSE IF (KPDS(3).GE.5.AND.KPDS(3).LE.6) THEN
    1197. 

  1197.                       ELSE IF (KPDS(3).EQ.8) THEN
    1198. 

  1198.                       ELSE IF (KPDS(3).EQ.10) THEN
    1199. 

  1199.                       ELSE IF (KPDS(3).GE.27.AND.KPDS(3).LE.34) THEN
    1200. 

  1200.                       ELSE IF (KPDS(3).EQ.50) THEN
    1201. 

  1201.                       ELSE IF (KPDS(3).EQ.53) THEN
    1202. 

  1202.                       ELSE IF (KPDS(3).GE.70.AND.KPDS(3).LE.77) THEN
    1203. 

  1203.                       ELSE IF (KPDS(3).EQ.98) THEN
    1204. 

  1204.                       ELSE IF (KPDS(3).EQ.99) THEN
    1205. 

  1205.                       ELSE IF (KPDS(3).GE.100.AND.KPDS(3).LE.105) THEN
    1206. 

  1206.                       ELSE IF (KPDS(3).EQ.126) THEN
    1207. 

  1207.                       ELSE IF (KPDS(3).EQ.195) THEN
    1208. 

  1208.                       ELSE IF (KPDS(3).EQ.196) THEN
    1209. 

  1209.                       ELSE IF (KPDS(3).EQ.197) THEN
    1210. 

  1210.                       ELSE IF (KPDS(3).EQ.198) THEN
    1211. 

  1211.                       ELSE IF (KPDS(3).GE.201.AND.KPDS(3).LE.237) THEN
    1212. 

  1212.                       ELSE
    1213. 

  1213. C                         PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR',
    1214. 

  1214. C    *                    ' NMC WITHOUT A GRID DESCRIPTION SECTION'
    1215. 

  1215. C                         PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
    1216. 

  1216. C                         PRINT *,' PRODUCTION MANAGEMENT BRANCH'
    1217. 

  1217. C                         PRINT *,' W/NMC42)'
    1218. 

  1218.                       END IF
    1219. 

  1219.                   ELSE IF (KPDS(1).EQ.98) THEN
    1220. 

  1220.                       IF (KPDS(3).GE.1.AND.KPDS(3).LE.16) THEN
    1221. 

  1221.                       ELSE
    1222. 

  1222. C                         PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR',
    1223. 

  1223. C    *                    ' ECMWF WITHOUT A GRID DESCRIPTION SECTION'
    1224. 

  1224. C                         PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
    1225. 

  1225. C                         PRINT *,' PRODUCTION MANAGEMENT BRANCH'
    1226. 

  1226. C                         PRINT *,' W/NMC42)'
    1227. 

  1227.                       END IF
    1228. 

  1228.                   ELSE IF (KPDS(1).EQ.74) THEN
    1229. 

  1229.                       IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN
    1230. 

  1230.                       ELSE IF (KPDS(3).GE.21.AND.KPDS(3).LE.26)THEN
    1231. 

  1231.                       ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN
    1232. 

  1232.                       ELSE IF (KPDS(3).GE.70.AND.KPDS(3).LE.77) THEN
    1233. 

  1233.                       ELSE
    1234. 

  1234. C                         PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR',
    1235. 

  1235. C    *                            ' U.K. MET OFFICE, BRACKNELL',
    1236. 

  1236. C    *                            ' WITHOUT A GRID DESCRIPTION SECTION'
    1237. 

  1237. C                         PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
    1238. 

  1238. C                         PRINT *,' PRODUCTION MANAGEMENT BRANCH'
    1239. 

  1239. C                         PRINT *,' W/NMC42)'
    1240. 

  1240.                       END IF
    1241. 

  1241.                   ELSE IF (KPDS(1).EQ.58) THEN
    1242. 

  1242.                       IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN
    1243. 

  1243.                       ELSE
    1244. 

  1244. C                         PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR',
    1245. 

  1245. C    *                      ' FNOC WITHOUT A GRID DESCRIPTION SECTION'
    1246. 

  1246. C                         PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
    1247. 

  1247. C                         PRINT *,' PRODUCTION MANAGEMENT BRANCH'
    1248. 

  1248. C                         PRINT *,' W/NMC42)'
    1249. 

  1249.                       END IF
    1250. 

  1250.                   END IF
    1251. 

  1251.               END IF
    1252. 

  1252.           END IF
    1253. 

  1253.       END IF
    1254. 

  1254.       RETURN
    1255. 

  1255.       END
    1256. 

  1256.       SUBROUTINE FI633(MSGA,KPTR,KGDS,KRET)
    1257. 

  1257. C$$$  SUBPROGRAM DOCUMENTATION  BLOCK
    1258. 

  1258. C                .      .    .                                       .
    1259. 

  1259. C SUBPROGRAM:    FI633       EXTRACT INFO FROM GRIB-GDS
    1260. 

  1260. C   PRGMMR: BILL CAVANAUGH   ORG: W/NMC42    DATE: 91-09-13
    1261. 

  1261. C
    1262. 

  1262. C ABSTRACT: EXTRACT INFORMATION ON UNLISTED GRID TO ALLOW
    1263. 

  1263. C   CONVERSION TO OFFICE NOTE 84 FORMAT.
    1264. 

  1264. C
    1265. 

  1265. C PROGRAM HISTORY LOG:
    1266. 

  1266. C   91-09-13  CAVANAUGH
    1267. 

  1267. C   95-03-20  M.BALDWIN   FI633 MODIFICATION TO GET
    1268. 

  1268. C                         DATA REP TYPES [KGDS(1)] 201 AND 202 TO WORK.
    1269. 

  1269. C   95-10-31  IREDELL     REMOVED SAVES AND PRINTS
    1270. 

  1270. C   98-09-08  BALDWIN     ADD DATA REP TYPE [KGDS(1)] 203
    1271. 

  1271. C   07-04-24  VUONG       ADD DATA REP TYPE [KGDS(1)] 204
    1272. 

  1272. C   10-07-20  GAYNO       ADD DATA REP TYPE [KGDS(1)] 205
    1273. 

  1273. C                        
    1274. 

  1274. C
    1275. 

  1275. C USAGE:    CALL FI633(MSGA,KPTR,KGDS,KRET)
    1276. 

  1276. C   INPUT ARGUMENT LIST:
    1277. 

  1277. C     MSGA      - ARRAY CONTAINING GRIB MESSAGE
    1278. 

  1278. C     KPTR       - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
    1279. 

  1279. C          (1)   - TOTAL LENGTH OF GRIB MESSAGE
    1280. 

  1280. C          (2)   - LENGTH OF INDICATOR (SECTION  0)
    1281. 

  1281. C          (3)   - LENGTH OF PDS       (SECTION  1)
    1282. 

  1282. C          (4)   - LENGTH OF GDS       (SECTION  2)
    1283. 

  1283. C          (5)   - LENGTH OF BMS       (SECTION  3)
    1284. 

  1284. C          (6)   - LENGTH OF BDS       (SECTION  4)
    1285. 

  1285. C          (7)   - VALUE OF CURRENT BYTE
    1286. 

  1286. C          (8)   - BIT POINTER
    1287. 

  1287. C          (9)   - GRIB START BIT NR
    1288. 

  1288. C         (10)   - GRIB/GRID ELEMENT COUNT
    1289. 

  1289. C         (11)   - NR UNUSED BITS AT END OF SECTION 3
    1290. 

  1290. C         (12)   - BIT MAP FLAG
    1291. 

  1291. C         (13)   - NR UNUSED BITS AT END OF SECTION 2
    1292. 

  1292. C         (14)   - BDS FLAGS
    1293. 

  1293. C         (15)   - NR UNUSED BITS AT END OF SECTION 4
    1294. 

  1294. C
    1295. 

  1295. C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
    1296. 

  1296. C     KGDS     - ARRAY CONTAINING GDS ELEMENTS.
    1297. 

  1297. C          (1)   - DATA REPRESENTATION TYPE
    1298. 

  1298. C          (19)  - NUMBER OF VERTICAL COORDINATE PARAMETERS
    1299. 

  1299. C          (20)  - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE
    1300. 

  1300. C                  PARAMETERS
    1301. 

  1301. C                  OR
    1302. 

  1302. C                  OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS
    1303. 

  1303. C                  IN EACH ROW
    1304. 

  1304. C                  OR
    1305. 

  1305. C                  255 IF NEITHER ARE PRESENT
    1306. 

  1306. C          (21)  - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID
    1307. 

  1307. C          (22)  - NUMBER OF WORDS IN EACH ROW
    1308. 

  1308. C       LATITUDE/LONGITUDE GRIDS
    1309. 

  1309. C          (2)   - N(I) NR POINTS ON LATITUDE CIRCLE
    1310. 

  1310. C          (3)   - N(J) NR POINTS ON LONGITUDE MERIDIAN
    1311. 

  1311. C          (4)   - LA(1) LATITUDE OF ORIGIN
    1312. 

  1312. C          (5)   - LO(1) LONGITUDE OF ORIGIN
    1313. 

  1313. C          (6)   - RESOLUTION FLAG
    1314. 

  1314. C          (7)   - LA(2) LATITUDE OF EXTREME POINT
    1315. 

  1315. C          (8)   - LO(2) LONGITUDE OF EXTREME POINT
    1316. 

  1316. C          (9)   - DI LONGITUDINAL DIRECTION OF INCREMENT
    1317. 

  1317. C          (10)  - DJ LATITUDINAL DIRECTION INCREMENT
    1318. 

  1318. C          (11)  - SCANNING MODE FLAG
    1319. 

  1319. C       POLAR STEREOGRAPHIC GRIDS
    1320. 

  1320. C          (2)   - N(I) NR POINTS ALONG LAT CIRCLE
    1321. 

  1321. C          (3)   - N(J) NR POINTS ALONG LON CIRCLE
    1322. 

  1322. C          (4)   - LA(1) LATITUDE OF ORIGIN
    1323. 

  1323. C          (5)   - LO(1) LONGITUDE OF ORIGIN
    1324. 

  1324. C          (6)   - RESERVED
    1325. 

  1325. C          (7)   - LOV GRID ORIENTATION
    1326. 

  1326. C          (8)   - DX - X DIRECTION INCREMENT
    1327. 

  1327. C          (9)   - DY - Y DIRECTION INCREMENT
    1328. 

  1328. C          (10)  - PROJECTION CENTER FLAG
    1329. 

  1329. C          (11)  - SCANNING MODE
    1330. 

  1330. C       SPHERICAL HARMONIC COEFFICIENTS
    1331. 

  1331. C          (2)   - J PENTAGONAL RESOLUTION PARAMETER
    1332. 

  1332. C          (3)   - K      "          "         "
    1333. 

  1333. C          (4)   - M      "          "         "
    1334. 

  1334. C          (5)   - REPRESENTATION TYPE
    1335. 

  1335. C          (6)   - COEFFICIENT STORAGE MODE
    1336. 

  1336. C       MERCATOR GRIDS
    1337. 

  1337. C          (2)   - N(I) NR POINTS ON LATITUDE CIRCLE
    1338. 

  1338. C          (3)   - N(J) NR POINTS ON LONGITUDE MERIDIAN
    1339. 

  1339. C          (4)   - LA(1) LATITUDE OF ORIGIN
    1340. 

  1340. C          (5)   - LO(1) LONGITUDE OF ORIGIN
    1341. 

  1341. C          (6)   - RESOLUTION FLAG
    1342. 

  1342. C          (7)   - LA(2) LATITUDE OF LAST GRID POINT
    1343. 

  1343. C          (8)   - LO(2) LONGITUDE OF LAST GRID POINT
    1344. 

  1344. C          (9)   - LATIN - LATITUDE OF PROJECTION INTERSECTION
    1345. 

  1345. C          (10)  - RESERVED
    1346. 

  1346. C          (11)  - SCANNING MODE FLAG
    1347. 

  1347. C          (12)  - LONGITUDINAL DIR GRID LENGTH
    1348. 

  1348. C          (13)  - LATITUDINAL DIR GRID LENGTH
    1349. 

  1349. C       LAMBERT CONFORMAL GRIDS
    1350. 

  1350. C          (2)   - NX NR POINTS ALONG X-AXIS
    1351. 

  1351. C          (3)   - NY NR POINTS ALONG Y-AXIS
    1352. 

  1352. C          (4)   - LA1 LAT OF ORIGIN (LOWER LEFT)
    1353. 

  1353. C          (5)   - LO1 LON OF ORIGIN (LOWER LEFT)
    1354. 

  1354. C          (6)   - RESOLUTION (RIGHT ADJ COPY OF OCTET 17)
    1355. 

  1355. C          (7)   - LOV - ORIENTATION OF GRID
    1356. 

  1356. C          (8)   - DX - X-DIR INCREMENT
    1357. 

  1357. C          (9)   - DY - Y-DIR INCREMENT
    1358. 

  1358. C          (10)  - PROJECTION CENTER FLAG
    1359. 

  1359. C          (11)  - SCANNING MODE FLAG
    1360. 

  1360. C          (12)  - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER
    1361. 

  1361. C          (13)  - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER
    1362. 

  1362. C       STAGGERED ARAKAWA ROTATED LAT/LON GRIDS (203 E STAGGER)
    1363. 

  1363. C          (2)   - N(I) NR POINTS ON ROTATED LATITUDE CIRCLE
    1364. 

  1364. C          (3)   - N(J) NR POINTS ON ROTATED LONGITUDE MERIDIAN
    1365. 

  1365. C          (4)   - LA(1) LATITUDE OF ORIGIN
    1366. 

  1366. C          (5)   - LO(1) LONGITUDE OF ORIGIN
    1367. 

  1367. C          (6)   - RESOLUTION FLAG
    1368. 

  1368. C          (7)   - LA(2) LATITUDE OF CENTER
    1369. 

  1369. C          (8)   - LO(2) LONGITUDE OF CENTER
    1370. 

  1370. C          (9)   - DI LONGITUDINAL DIRECTION OF INCREMENT
    1371. 

  1371. C          (10)  - DJ LATITUDINAL DIRECTION INCREMENT
    1372. 

  1372. C          (11)  - SCANNING MODE FLAG
    1373. 

  1373. C       STAGGERED ARAKAWA ROTATED LAT/LON GRIDS (205 A,B,C,D STAGGERS)
    1374. 

  1374. C          (2)   - N(I) NR POINTS ON ROTATED LATITUDE CIRCLE
    1375. 

  1375. C          (3)   - N(J) NR POINTS ON ROTATED LONGITUDE MERIDIAN
    1376. 

  1376. C          (4)   - LA(1) LATITUDE OF ORIGIN
    1377. 

  1377. C          (5)   - LO(1) LONGITUDE OF ORIGIN
    1378. 

  1378. C          (6)   - RESOLUTION FLAG
    1379. 

  1379. C          (7)   - LA(2) LATITUDE OF CENTER
    1380. 

  1380. C          (8)   - LO(2) LONGITUDE OF CENTER
    1381. 

  1381. C          (9)   - DI LONGITUDINAL DIRECTION OF INCREMENT
    1382. 

  1382. C          (10)  - DJ LATITUDINAL DIRECTION INCREMENT
    1383. 

  1383. C          (11)  - SCANNING MODE FLAG
    1384. 

  1384. C          (12)  - LATITUDE OF LAST POINT
    1385. 

  1385. C          (13)  - LONGITUDE OF LAST POINT
    1386. 

  1386. C     KPTR       - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
    1387. 

  1387. C                  SEE INPUT LIST
    1388. 

  1388. C     KRET       - ERROR RETURN
    1389. 

  1389. C
    1390. 

  1390. C REMARKS:
    1391. 

  1391. C     KRET = 0
    1392. 

  1392. C          = 4   - DATA REPRESENTATION TYPE NOT CURRENTLY ACCEPTABLE
    1393. 

  1393. C
    1394. 

  1394. C   SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
    1395. 

  1395. C
    1396. 

  1396. C ATTRIBUTES:
    1397. 

  1397. C   LANGUAGE: FORTRAN 77
    1398. 

  1398. C   MACHINE:  HDS9000
    1399. 

  1399. C
    1400. 

  1400. C$$$
    1401. 

  1401. C  ************************************************************
    1402. 

  1402. C                       INCOMING MESSAGE HOLDER
    1403. 

  1403.       CHARACTER*1   MSGA(*)
    1404. 

  1404. C
    1405. 

  1405. C                       ARRAY GDS ELEMENTS
    1406. 

  1406.       INTEGER       KGDS(*)
    1407. 

  1407. C                       ARRAY OF POINTERS AND COUNTERS
    1408. 

  1408.       INTEGER       KPTR(*)
    1409. 

  1409. C
    1410. 

  1410.       INTEGER       KRET
    1411. 

  1411. C  ---------------------------------------------------------------
    1412. 

  1412.       KRET    = 0
    1413. 

  1413. C                PROCESS GRID DEFINITION SECTION (IF PRESENT)
    1414. 

  1414. C             MAKE SURE BIT POINTER IS PROPERLY SET
    1415. 

  1415.       KPTR(8)  = KPTR(9) + (KPTR(2)*8) + (KPTR(3)*8) + 24
    1416. 

  1416.       NSAVE    = KPTR(8) - 24
    1417. 

  1417. C  BYTE 4
    1418. 

  1418. C                   NV - NR OF VERT COORD PARAMETERS
    1419. 

  1419.       CALL GBYTEC (MSGA,KGDS(19),KPTR(8),8)
    1420. 

  1420.       KPTR(8)  = KPTR(8) + 8
    1421. 

  1421. C  BYTE 5
    1422. 

  1422. C                   PV - LOCATION - SEE FM92 MANUAL
    1423. 

  1423.       CALL GBYTEC (MSGA,KGDS(20),KPTR(8),8)
    1424. 

  1424.       KPTR(8)  = KPTR(8) + 8
    1425. 

  1425. C  BYTE 6
    1426. 

  1426. C                      DATA REPRESENTATION TYPE
    1427. 

  1427.       CALL GBYTEC (MSGA,KGDS(1),KPTR(8),8)
    1428. 

  1428.       KPTR(8)   = KPTR(8) + 8
    1429. 

  1429. C           BYTES 7-32 ARE GRID DEFINITION DEPENDING ON
    1430. 

  1430. C           DATA REPRESENTATION TYPE
    1431. 

  1431.       IF (KGDS(1).EQ.0) THEN
    1432. 

  1432.           GO TO 1000
    1433. 

  1433.       ELSE IF (KGDS(1).EQ.1) THEN
    1434. 

  1434.           GO TO 4000
    1435. 

  1435.       ELSE IF (KGDS(1).EQ.2.OR.KGDS(1).EQ.5) THEN
    1436. 

  1436.           GO TO 2000
    1437. 

  1437.       ELSE IF (KGDS(1).EQ.3) THEN
    1438. 

  1438.           GO TO 5000
    1439. 

  1439.       ELSE IF (KGDS(1).EQ.4) THEN
    1440. 

  1440.           GO TO 1000
    1441. 

  1441. C     ELSE IF (KGDS(1).EQ.10) THEN
    1442. 

  1442. C     ELSE IF (KGDS(1).EQ.14) THEN
    1443. 

  1443. C     ELSE IF (KGDS(1).EQ.20) THEN
    1444. 

  1444. C     ELSE IF (KGDS(1).EQ.24) THEN
    1445. 

  1445. C     ELSE IF (KGDS(1).EQ.30) THEN
    1446. 

  1446. C     ELSE IF (KGDS(1).EQ.34) THEN
    1447. 

  1447.       ELSE IF (KGDS(1).EQ.50) THEN
    1448. 

  1448.           GO TO 3000
    1449. 

  1449. C     ELSE IF (KGDS(1).EQ.60) THEN
    1450. 

  1450. C     ELSE IF (KGDS(1).EQ.70) THEN
    1451. 

  1451. C     ELSE IF (KGDS(1).EQ.80) THEN
    1452. 

  1452.       ELSE IF (KGDS(1).EQ.201.OR.KGDS(1).EQ.202.OR.
    1453. 

  1453.      &      KGDS(1).EQ.203.OR.KGDS(1).EQ.204.OR.KGDS(1).EQ.205) THEN
    1454. 

  1454.           GO TO 1000
    1455. 

  1455.       ELSE
    1456. 

  1456. C                      MARK AS GDS/ UNKNOWN DATA REPRESENTATION TYPE
    1457. 

  1457.           KRET     = 4
    1458. 

  1458.           RETURN
    1459. 

  1459.       END IF
    1460. 

  1460. C     BYTE 33-N   VERTICAL COORDINATE PARAMETERS
    1461. 

  1461. C  -----------
    1462. 

  1462. C     BYTES 33-42 EXTENSIONS OF GRID DEFINITION FOR ROTATION
    1463. 

  1463. C                 OR STRETCHING OF THE COORDINATE SYSTEM OR
    1464. 

  1464. C                 LAMBERT CONFORMAL PROJECTION.
    1465. 

  1465. C     BYTE 43-N   VERTICAL COORDINATE PARAMETERS
    1466. 

  1466. C  -----------
    1467. 

  1467. C     BYTES 33-52 EXTENSIONS OF GRID DEFINITION FOR STRETCHED
    1468. 

  1468. C                 AND ROTATED COORDINATE SYSTEM
    1469. 

  1469. C     BYTE 53-N   VERTICAL COORDINATE PARAMETERS
    1470. 

  1470. C  -----------
    1471. 

  1471. C ************************************************************
    1472. 

  1472. C  ------------------- LATITUDE/LONGITUDE GRIDS
    1473. 

  1473. C  ------------------- ARAKAWA STAGGERED, SEMI-STAGGERED, OR FILLED
    1474. 

  1474. C       ROTATED LAT/LON GRIDS OR CURVILINEAR ORTHIGINAL GRIDS
    1475. 

  1475. C
    1476. 

  1476. C  ------------------- BYTE 7-8     NR OF POINTS ALONG LATITUDE CIRCLE
    1477. 

  1477.  1000 CONTINUE
    1478. 

  1478.       CALL GBYTEC (MSGA,KGDS(2),KPTR(8),16)
    1479. 

  1479.       KPTR(8)  = KPTR(8) + 16
    1480. 

  1480. C  ------------------- BYTE 9-10    NR OF POINTS ALONG LONG MERIDIAN
    1481. 

  1481.       CALL GBYTEC (MSGA,KGDS(3),KPTR(8),16)
    1482. 

  1482.       KPTR(8)  = KPTR(8) + 16
    1483. 

  1483. C  ------------------- BYTE 11-13   LATITUDE OF ORIGIN
    1484. 

  1484.       CALL GBYTEC (MSGA,KGDS(4),KPTR(8),24)
    1485. 

  1485.       KPTR(8)  = KPTR(8) + 24
    1486. 

  1486.       IF (IAND(KGDS(4),8388608).NE.0) THEN
    1487. 

  1487.           KGDS(4)  =  IAND(KGDS(4),8388607) * (-1)
    1488. 

  1488.       END IF
    1489. 

  1489. C  ------------------- BYTE 14-16   LONGITUDE OF ORIGIN
    1490. 

  1490.       CALL GBYTEC (MSGA,KGDS(5),KPTR(8),24)
    1491. 

  1491.       KPTR(8)  = KPTR(8) + 24
    1492. 

  1492.       IF (IAND(KGDS(5),8388608).NE.0) THEN
    1493. 

  1493.           KGDS(5)  =  - IAND(KGDS(5),8388607)
    1494. 

  1494.       END IF
    1495. 

  1495. C  ------------------- BYTE 17      RESOLUTION FLAG
    1496. 

  1496.       CALL GBYTEC (MSGA,KGDS(6),KPTR(8),8)
    1497. 

  1497.       KPTR(8)  = KPTR(8) + 8
    1498. 

  1498. C  ------------------- BYTE 18-20   LATITUDE OF LAST GRID POINT
    1499. 

  1499.       CALL GBYTEC (MSGA,KGDS(7),KPTR(8),24)
    1500. 

  1500.       KPTR(8)  = KPTR(8) + 24
    1501. 

  1501.       IF (IAND(KGDS(7),8388608).NE.0) THEN
    1502. 

  1502.           KGDS(7)  =  - IAND(KGDS(7),8388607)
    1503. 

  1503.       END IF
    1504. 

  1504. C  ------------------- BYTE 21-23   LONGITUDE OF LAST GRID POINT
    1505. 

  1505.       CALL GBYTEC (MSGA,KGDS(8),KPTR(8),24)
    1506. 

  1506.       KPTR(8)  = KPTR(8) + 24
    1507. 

  1507.       IF (IAND(KGDS(8),8388608).NE.0) THEN
    1508. 

  1508.           KGDS(8)  =  - IAND(KGDS(8),8388607)
    1509. 

  1509.       END IF
    1510. 

  1510. C  ------------------- BYTE 24-25   LATITUDINAL DIR INCREMENT
    1511. 

  1511.       CALL GBYTEC (MSGA,KGDS(9),KPTR(8),16)
    1512. 

  1512.       KPTR(8)  = KPTR(8) + 16
    1513. 

  1513. C  ------------------- BYTE 26-27   IF REGULAR LAT/LON GRID
    1514. 

  1514. C                                       HAVE LONGIT DIR INCREMENT
    1515. 

  1515. C                                   ELSE IF GAUSSIAN GRID
    1516. 

  1516. C                                       HAVE NR OF LAT CIRCLES
    1517. 

  1517. C                                       BETWEEN POLE AND EQUATOR
    1518. 

  1518.       CALL GBYTEC (MSGA,KGDS(10),KPTR(8),16)
    1519. 

  1519.       KPTR(8)  = KPTR(8) + 16
    1520. 

  1520. C  ------------------- BYTE 28      SCANNING MODE FLAGS
    1521. 

  1521.       CALL GBYTEC (MSGA,KGDS(11),KPTR(8),8)
    1522. 

  1522.       KPTR(8)  = KPTR(8) + 8
    1523. 

  1523.       IF(KGDS(1).EQ.205)THEN
    1524. 

  1524. C  ------------------- BYTE 29-31   LATITUDE OF LAST GRID POINT
    1525. 

  1525.         CALL GBYTEC (MSGA,KGDS(12),KPTR(8),24)
    1526. 

  1526.         KPTR(8)  = KPTR(8) + 24
    1527. 

  1527.         IF (IAND(KGDS(12),8388608).NE.0) THEN
    1528. 

  1528.             KGDS(12)  =  - IAND(KGDS(12),8388607)
    1529. 

  1529.         END IF
    1530. 

  1530. C  ------------------- BYTE 32-34   LONGITUDE OF LAST GRID POINT
    1531. 

  1531.         CALL GBYTEC (MSGA,KGDS(13),KPTR(8),24)
    1532. 

  1532.         KPTR(8)  = KPTR(8) + 24
    1533. 

  1533.         IF (IAND(KGDS(13),8388608).NE.0) THEN
    1534. 

  1534.             KGDS(13)  =  - IAND(KGDS(13),8388607)
    1535. 

  1535.         END IF
    1536. 

  1536.       ELSE
    1537. 

  1537. 

  1538. C  ------------------- BYTE 29-32   RESERVED
    1539. 

  1539. C                             SKIP TO START OF BYTE 33
    1540. 

  1540.       CALL GBYTEC (MSGA,KGDS(12),KPTR(8),32)
    1541. 

  1541.       KPTR(8)  = KPTR(8) + 32
    1542. 

  1542.       ENDIF
    1543. 

  1543. C  -------------------
    1544. 

  1544.       GO TO 900
    1545. 

  1545. C  ******************************************************************
    1546. 

  1546. C            ' POLAR STEREO PROCESSING '
    1547. 

  1547. C
    1548. 

  1548. C  ------------------- BYTE 7-8     NR OF POINTS ALONG X=AXIS
    1549. 

  1549.  2000 CONTINUE
    1550. 

  1550.       CALL GBYTEC (MSGA,KGDS(2),KPTR(8),16)
    1551. 

  1551.       KPTR(8)  = KPTR(8) + 16
    1552. 

  1552. C  ------------------- BYTE 9-10    NR OF POINTS ALONG Y-AXIS
    1553. 

  1553.       CALL GBYTEC (MSGA,KGDS(3),KPTR(8),16)
    1554. 

  1554.       KPTR(8)  = KPTR(8) + 16
    1555. 

  1555. C  ------------------- BYTE 11-13   LATITUDE OF ORIGIN
    1556. 

  1556.       CALL GBYTEC (MSGA,KGDS(4),KPTR(8),24)
    1557. 

  1557.       KPTR(8)  = KPTR(8) + 24
    1558. 

  1558.       IF (IAND(KGDS(4),8388608).NE.0) THEN
    1559. 

  1559.           KGDS(4)  =  - IAND(KGDS(4),8388607)
    1560. 

  1560.       END IF
    1561. 

  1561. C  ------------------- BYTE 14-16   LONGITUDE OF ORIGIN
    1562. 

  1562.       CALL GBYTEC (MSGA,KGDS(5),KPTR(8),24)
    1563. 

  1563.       KPTR(8)  = KPTR(8) + 24
    1564. 

  1564.       IF (IAND(KGDS(5),8388608).NE.0) THEN
    1565. 

  1565.           KGDS(5)  =   - IAND(KGDS(5),8388607)
    1566. 

  1566.       END IF
    1567. 

  1567. C  ------------------- BYTE 17      RESERVED
    1568. 

  1568.       CALL GBYTEC (MSGA,KGDS(6),KPTR(8),8)
    1569. 

  1569.       KPTR(8)  = KPTR(8) + 8
    1570. 

  1570. C  ------------------- BYTE 18-20   LOV ORIENTATION OF THE GRID
    1571. 

  1571.       CALL GBYTEC (MSGA,KGDS(7),KPTR(8),24)
    1572. 

  1572.       KPTR(8)  = KPTR(8) + 24
    1573. 

  1573.       IF (IAND(KGDS(7),8388608).NE.0) THEN
    1574. 

  1574.           KGDS(7)  =  - IAND(KGDS(7),8388607)
    1575. 

  1575.       END IF
    1576. 

  1576. C  ------------------- BYTE 21-23   DX - THE X DIRECTION INCREMENT
    1577. 

  1577.       CALL GBYTEC (MSGA,KGDS(8),KPTR(8),24)
    1578. 

  1578.       KPTR(8)  = KPTR(8) + 24
    1579. 

  1579.       IF (IAND(KGDS(8),8388608).NE.0) THEN
    1580. 

  1580.           KGDS(8)  =  - IAND(KGDS(8),8388607)
    1581. 

  1581.       END IF
    1582. 

  1582. C  ------------------- BYTE 24-26   DY - THE Y DIRECTION INCREMENT
    1583. 

  1583.       CALL GBYTEC (MSGA,KGDS(9),KPTR(8),24)
    1584. 

  1584.       KPTR(8)  = KPTR(8) + 24
    1585. 

  1585.       IF (IAND(KGDS(9),8388608).NE.0) THEN
    1586. 

  1586.           KGDS(9)  =  - IAND(KGDS(9),8388607)
    1587. 

  1587.       END IF
    1588. 

  1588. C  ------------------- BYTE 27      PROJECTION CENTER FLAG
    1589. 

  1589.       CALL GBYTEC (MSGA,KGDS(10),KPTR(8),8)
    1590. 

  1590.       KPTR(8)  = KPTR(8) + 8
    1591. 

  1591. C  ------------------- BYTE 28      SCANNING MODE
    1592. 

  1592.       CALL GBYTEC (MSGA,KGDS(11),KPTR(8),8)
    1593. 

  1593.       KPTR(8)  = KPTR(8) + 8
    1594. 

  1594. C  ------------------- BYTE 29-32   RESERVED
    1595. 

  1595. C                             SKIP TO START OF BYTE 33
    1596. 

  1596.       CALL GBYTEC (MSGA,KGDS(12),KPTR(8),32)
    1597. 

  1597.       KPTR(8)  = KPTR(8) + 32
    1598. 

  1598. C
    1599. 

  1599. C  -------------------
    1600. 

  1600.       GO TO 900
    1601. 

  1601. C
    1602. 

  1602. C  ******************************************************************
    1603. 

  1603. C  ------------------- GRID DESCRIPTION FOR SPHERICAL HARMONIC COEFF.
    1604. 

  1604. C
    1605. 

  1605. C  ------------------- BYTE 7-8     J PENTAGONAL RESOLUTION PARAMETER
    1606. 

  1606.  3000 CONTINUE
    1607. 

  1607.       CALL GBYTEC (MSGA,KGDS(2),KPTR(8),16)
    1608. 

  1608.       KPTR(8)  = KPTR(8) + 16
    1609. 

  1609. C  ------------------- BYTE 9-10    K PENTAGONAL RESOLUTION PARAMETER
    1610. 

  1610.       CALL GBYTEC (MSGA,KGDS(3),KPTR(8),16)
    1611. 

  1611.       KPTR(8)  = KPTR(8) + 16
    1612. 

  1612. C  ------------------- BYTE 11-12   M PENTAGONAL RESOLUTION PARAMETER
    1613. 

  1613.       CALL GBYTEC (MSGA,KGDS(4),KPTR(8),16)
    1614. 

  1614.       KPTR(8)  = KPTR(8) + 16
    1615. 

  1615. C  ------------------- BYTE 13 REPRESENTATION TYPE
    1616. 

  1616.       CALL GBYTEC (MSGA,KGDS(5),KPTR(8),8)
    1617. 

  1617.       KPTR(8)  = KPTR(8) + 8
    1618. 

  1618. C  ------------------- BYTE 14 COEFFICIENT STORAGE MODE
    1619. 

  1619.       CALL GBYTEC (MSGA,KGDS(6),KPTR(8),8)
    1620. 

  1620.       KPTR(8)  = KPTR(8) + 8
    1621. 

  1621. C  -------------------        EMPTY FIELDS - BYTES 15 - 32
    1622. 

  1622. C                 SET TO START OF BYTE 33
    1623. 

  1623.       KPTR(8)  = KPTR(8) + 18 * 8
    1624. 

  1624.       GO TO 900
    1625. 

  1625. C  ******************************************************************
    1626. 

  1626. C                      PROCESS MERCATOR GRIDS
    1627. 

  1627. C
    1628. 

  1628. C  ------------------- BYTE 7-8     NR OF POINTS ALONG LATITUDE CIRCLE
    1629. 

  1629.  4000 CONTINUE
    1630. 

  1630.       CALL GBYTEC (MSGA,KGDS(2),KPTR(8),16)
    1631. 

  1631.       KPTR(8)  = KPTR(8) + 16
    1632. 

  1632. C  ------------------- BYTE 9-10    NR OF POINTS ALONG LONG MERIDIAN
    1633. 

  1633.       CALL GBYTEC (MSGA,KGDS(3),KPTR(8),16)
    1634. 

  1634.       KPTR(8)  = KPTR(8) + 16
    1635. 

  1635. C  ------------------- BYTE 11-13   LATITUE OF ORIGIN
    1636. 

  1636.       CALL GBYTEC (MSGA,KGDS(4),KPTR(8),24)
    1637. 

  1637.       KPTR(8)  = KPTR(8) + 24
    1638. 

  1638.       IF (IAND(KGDS(4),8388608).NE.0) THEN
    1639. 

  1639.           KGDS(4)  =  - IAND(KGDS(4),8388607)
    1640. 

  1640.       END IF
    1641. 

  1641. C  ------------------- BYTE 14-16   LONGITUDE OF ORIGIN
    1642. 

  1642.       CALL GBYTEC (MSGA,KGDS(5),KPTR(8),24)
    1643. 

  1643.       KPTR(8)  = KPTR(8) + 24
    1644. 

  1644.       IF (IAND(KGDS(5),8388608).NE.0) THEN
    1645. 

  1645.           KGDS(5)  =  - IAND(KGDS(5),8388607)
    1646. 

  1646.       END IF
    1647. 

  1647. C  ------------------- BYTE 17      RESOLUTION FLAG
    1648. 

  1648.       CALL GBYTEC (MSGA,KGDS(6),KPTR(8),8)
    1649. 

  1649.       KPTR(8)  = KPTR(8) + 8
    1650. 

  1650. C  ------------------- BYTE 18-20   LATITUDE OF EXTREME POINT
    1651. 

  1651.       CALL GBYTEC (MSGA,KGDS(7),KPTR(8),24)
    1652. 

  1652.       KPTR(8)  = KPTR(8) + 24
    1653. 

  1653.       IF (IAND(KGDS(7),8388608).NE.0) THEN
    1654. 

  1654.           KGDS(7)  =  - IAND(KGDS(7),8388607)
    1655. 

  1655.       END IF
    1656. 

  1656. C  ------------------- BYTE 21-23   LONGITUDE OF EXTREME POINT
    1657. 

  1657.       CALL GBYTEC (MSGA,KGDS(8),KPTR(8),24)
    1658. 

  1658.       KPTR(8)  = KPTR(8) + 24
    1659. 

  1659.       IF (IAND(KGDS(8),8388608).NE.0) THEN
    1660. 

  1660.           KGDS(8)  =  - IAND(KGDS(8),8388607)
    1661. 

  1661.       END IF
    1662. 

  1662. C  ------------------- BYTE 24-26   LATITUDE OF PROJECTION INTERSECTION
    1663. 

  1663.       CALL GBYTEC (MSGA,KGDS(9),KPTR(8),24)
    1664. 

  1664.       KPTR(8)  = KPTR(8) + 24
    1665. 

  1665.       IF (IAND(KGDS(9),8388608).NE.0) THEN
    1666. 

  1666.           KGDS(9)  =  - IAND(KGDS(9),8388607)
    1667. 

  1667.       END IF
    1668. 

  1668. C  ------------------- BYTE 27   RESERVED
    1669. 

  1669.       CALL GBYTEC (MSGA,KGDS(10),KPTR(8),8)
    1670. 

  1670.       KPTR(8)  = KPTR(8) + 8
    1671. 

  1671. C  ------------------- BYTE 28      SCANNING MODE
    1672. 

  1672.       CALL GBYTEC (MSGA,KGDS(11),KPTR(8),8)
    1673. 

  1673.       KPTR(8)  = KPTR(8) + 8
    1674. 

  1674. C  ------------------- BYTE 29-31   LONGITUDINAL DIR INCREMENT
    1675. 

  1675.       CALL GBYTEC (MSGA,KGDS(12),KPTR(8),24)
    1676. 

  1676.       KPTR(8)  = KPTR(8) + 24
    1677. 

  1677.       IF (IAND(KGDS(12),8388608).NE.0) THEN
    1678. 

  1678.           KGDS(12)  =  - IAND(KGDS(12),8388607)
    1679. 

  1679.       END IF
    1680. 

  1680. C  ------------------- BYTE 32-34   LATITUDINAL DIR INCREMENT
    1681. 

  1681.       CALL GBYTEC (MSGA,KGDS(13),KPTR(8),24)
    1682. 

  1682.       KPTR(8)  = KPTR(8) + 24
    1683. 

  1683.       IF (IAND(KGDS(13),8388608).NE.0) THEN
    1684. 

  1684.           KGDS(13)  =  - IAND(KGDS(13),8388607)
    1685. 

  1685.       END IF
    1686. 

  1686. C  ------------------- BYTE 35-42   RESERVED
    1687. 

  1687. C                        SKIP TO START OF BYTE 43
    1688. 

  1688.       KPTR(8)  = KPTR(8) + 8 * 8
    1689. 

  1689. C  -------------------
    1690. 

  1690.       GO TO 900
    1691. 

  1691. C  ******************************************************************
    1692. 

  1692. C                      PROCESS LAMBERT CONFORMAL
    1693. 

  1693. C
    1694. 

  1694. C  ------------------- BYTE 7-8     NR OF POINTS ALONG X-AXIS
    1695. 

  1695.  5000 CONTINUE
    1696. 

  1696.       CALL GBYTEC (MSGA,KGDS(2),KPTR(8),16)
    1697. 

  1697.       KPTR(8)  = KPTR(8) + 16
    1698. 

  1698. C  ------------------- BYTE 9-10    NR OF POINTS ALONG Y-AXIS
    1699. 

  1699.       CALL GBYTEC (MSGA,KGDS(3),KPTR(8),16)
    1700. 

  1700.       KPTR(8)  = KPTR(8) + 16
    1701. 

  1701. C  ------------------- BYTE 11-13   LATITUDE OF ORIGIN
    1702. 

  1702.       CALL GBYTEC (MSGA,KGDS(4),KPTR(8),24)
    1703. 

  1703.       KPTR(8)  = KPTR(8) + 24
    1704. 

  1704.       IF (IAND(KGDS(4),8388608).NE.0) THEN
    1705. 

  1705.           KGDS(4)  =  - IAND(KGDS(4),8388607)
    1706. 

  1706.       END IF
    1707. 

  1707. C  ------------------- BYTE 14-16   LONGITUDE OF ORIGIN (LOWER LEFT)
    1708. 

  1708.       CALL GBYTEC (MSGA,KGDS(5),KPTR(8),24)
    1709. 

  1709.       KPTR(8)  = KPTR(8) + 24
    1710. 

  1710.       IF (IAND(KGDS(5),8388608).NE.0) THEN
    1711. 

  1711.           KGDS(5)  = - IAND(KGDS(5),8388607)
    1712. 

  1712.       END IF
    1713. 

  1713. C  ------------------- BYTE 17      RESOLUTION
    1714. 

  1714.       CALL GBYTEC (MSGA,KGDS(6),KPTR(8),8)
    1715. 

  1715.       KPTR(8)  = KPTR(8) + 8
    1716. 

  1716. C  ------------------- BYTE 18-20   LOV -ORIENTATION OF GRID
    1717. 

  1717.       CALL GBYTEC (MSGA,KGDS(7),KPTR(8),24)
    1718. 

  1718.       KPTR(8)  = KPTR(8) + 24
    1719. 

  1719.       IF (IAND(KGDS(7),8388608).NE.0) THEN
    1720. 

  1720.           KGDS(7)  = - IAND(KGDS(7),8388607)
    1721. 

  1721.       END IF
    1722. 

  1722. C  ------------------- BYTE 21-23   DX - X-DIR INCREMENT
    1723. 

  1723.       CALL GBYTEC (MSGA,KGDS(8),KPTR(8),24)
    1724. 

  1724.       KPTR(8)  = KPTR(8) + 24
    1725. 

  1725. C  ------------------- BYTE 24-26   DY - Y-DIR INCREMENT
    1726. 

  1726.       CALL GBYTEC (MSGA,KGDS(9),KPTR(8),24)
    1727. 

  1727.       KPTR(8)  = KPTR(8) + 24
    1728. 

  1728. C  ------------------- BYTE 27       PROJECTION CENTER FLAG
    1729. 

  1729.       CALL GBYTEC (MSGA,KGDS(10),KPTR(8),8)
    1730. 

  1730.       KPTR(8)  = KPTR(8) + 8
    1731. 

  1731. C  ------------------- BYTE 28      SCANNING MODE
    1732. 

  1732.       CALL GBYTEC (MSGA,KGDS(11),KPTR(8),8)
    1733. 

  1733.       KPTR(8)  = KPTR(8) + 8
    1734. 

  1734. C  ------------------- BYTE 29-31   LATIN1 - 1ST LAT FROM POLE
    1735. 

  1735.       CALL GBYTEC (MSGA,KGDS(12),KPTR(8),24)
    1736. 

  1736.       KPTR(8)  = KPTR(8) + 24
    1737. 

  1737.       IF (IAND(KGDS(12),8388608).NE.0) THEN
    1738. 

  1738.           KGDS(12)  =  - IAND(KGDS(12),8388607)
    1739. 

  1739.       END IF
    1740. 

  1740. C  ------------------- BYTE 32-34   LATIN2 - 2ND LAT FROM POLE
    1741. 

  1741.       CALL GBYTEC (MSGA,KGDS(13),KPTR(8),24)
    1742. 

  1742.       KPTR(8)  = KPTR(8) + 24
    1743. 

  1743.       IF (IAND(KGDS(13),8388608).NE.0) THEN
    1744. 

  1744.           KGDS(13)  =  - IAND(KGDS(13),8388607)
    1745. 

  1745.       END IF
    1746. 

  1746. C  ------------------- BYTE 35-37   LATITUDE OF SOUTHERN POLE
    1747. 

  1747.       CALL GBYTEC (MSGA,KGDS(14),KPTR(8),24)
    1748. 

  1748.       KPTR(8)  = KPTR(8) + 24
    1749. 

  1749.       IF (IAND(KGDS(14),8388608).NE.0) THEN
    1750. 

  1750.           KGDS(14)  =  - IAND(KGDS(14),8388607)
    1751. 

  1751.       END IF
    1752. 

  1752. C  ------------------- BYTE 38-40   LONGITUDE OF SOUTHERN POLE
    1753. 

  1753.       CALL GBYTEC (MSGA,KGDS(15),KPTR(8),24)
    1754. 

  1754.       KPTR(8)  = KPTR(8) + 24
    1755. 

  1755.       IF (IAND(KGDS(15),8388608).NE.0) THEN
    1756. 

  1756.           KGDS(15)  =  - IAND(KGDS(15),8388607)
    1757. 

  1757.       END IF
    1758. 

  1758. C  ------------------- BYTE 41-42   RESERVED
    1759. 

  1759.       CALL GBYTEC (MSGA,KGDS(16),KPTR(8),16)
    1760. 

  1760.       KPTR(8)  = KPTR(8) + 16
    1761. 

  1761. C  -------------------
    1762. 

  1762.   900 CONTINUE
    1763. 

  1763. C
    1764. 

  1764. C                        MORE CODE FOR GRIDS WITH PL
    1765. 

  1765. C
    1766. 

  1766.       IF (KGDS(19).EQ.0.OR.KGDS(19).EQ.255) THEN
    1767. 

  1767.         IF (KGDS(20).NE.255) THEN
    1768. 

  1768.           ISUM  = 0
    1769. 

  1769.           KPTR(8)  = NSAVE + (KGDS(20) - 1) * 8
    1770. 

  1770.           CALL GBYTESC (MSGA,KGDS(22),KPTR(8),16,0,KGDS(3))
    1771. 

  1771.           DO 910 J = 1, KGDS(3)
    1772. 

  1772.               ISUM  = ISUM + KGDS(21+J)
    1773. 

  1773.   910     CONTINUE
    1774. 

  1774.           KGDS(21)  = ISUM
    1775. 

  1775.         END IF
    1776. 

  1776.       END IF
    1777. 

  1777.       RETURN
    1778. 

  1778.       END
    1779. 

  1779.       SUBROUTINE FI634(MSGA,KPTR,KPDS,KGDS,KBMS,KRET)
    1780. 

  1780. C$$$  SUBPROGRAM DOCUMENTATION  BLOCK
    1781. 

  1781. C                .      .    .                                       .
    1782. 

  1782. C SUBPROGRAM:    FI634       EXTRACT OR GENERATE BIT MAP FOR OUTPUT
    1783. 

  1783. C   PRGMMR: BILL CAVANAUGH   ORG: W/NMC42    DATE: 91-09-13
    1784. 

  1784. C
    1785. 

  1785. C ABSTRACT: IF BIT MAP SEC   IS AVAILABLE IN GRIB MESSAGE, EXTRACT
    1786. 

  1786. C   FOR PROGRAM USE, OTHERWISE GENERATE AN APPROPRIATE BIT MAP.
    1787. 

  1787. C
    1788. 

  1788. C PROGRAM HISTORY LOG:
    1789. 

  1789. C   91-09-13  CAVANAUGH
    1790. 

  1790. C   91-11-12  CAVANAUGH   MODIFIED SIZE OF ECMWF GRIDS 5 - 8.
    1791. 

  1791. C   95-10-31  IREDELL     REMOVED SAVES AND PRINTS
    1792. 

  1792. C   97-02-12  W BOSTELMAN CORRECTS ECMWF US GRID 2 PROCESSING
    1793. 

  1793. C   97-09-19  IREDELL     VECTORIZED BITMAP DECODER
    1794. 

  1794. C   98-09-02  GILBERT     CORRECTED ERROR IN MAP SIZE FOR U.S. GRID 92
    1795. 

  1795. C   98-09-08  BALDWIN     ADD GRIDS 190,192
    1796. 

  1796. C   99-01-20  BALDWIN     ADD GRIDS 236,237
    1797. 

  1797. C   01-10-02  ROGERS      REDEFINED GRID #218 FOR 12 KM ETA
    1798. 

  1798. C                         REDEFINED GRID 192 FOR NEW 32-KM ETA GRID
    1799. 

  1799. C 2003-06-30  GILBERT      ADDED GRIDS 145 and 146 for CMAQ
    1800. 

  1800. C                          and GRID 175 for AWIPS over GUAM.
    1801. 

  1801. C 2004-09-02  VUONG       ADDED AWIPS GRIDS 147, 148, 173 AND 254
    1802. 

  1802. C 2006-12-12  VUONG       ADDED AWIPS GRIDS 120
    1803. 

  1803. C 2007-04-20  VUONG       ADDED AWIPS GRIDS 176
    1804. 

  1804. C 2007-06-11  VUONG       ADDED AWIPS GRIDS 11 TO 18 AND 122 TO 125
    1805. 

  1805. C                         AND 180 TO 183
    1806. 

  1806. C 2010-08-05  VUONG       ADDED NEW GRID 184, 199, 83 AND
    1807. 

  1807. C                         REDEFINED GRID 90 FOR NEW RTMA CONUS 1.27-KM
    1808. 

  1808. C                         REDEFINED GRID 91 FOR NEW RTMA ALASKA 2.976-KM
    1809. 

  1809. C                         REDEFINED GRID 92 FOR NEW RTMA ALASKA 1.488-KM
    1810. 

  1810. C
    1811. 

  1811. C USAGE:    CALL FI634(MSGA,KPTR,KPDS,KGDS,KBMS,KRET)
    1812. 

  1812. C   INPUT ARGUMENT LIST:
    1813. 

  1813. C     MSGA       - BUFR MESSAGE
    1814. 

  1814. C     KPTR       - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
    1815. 

  1815. C          (1)   - TOTAL LENGTH OF GRIB MESSAGE
    1816. 

  1816. C          (2)   - LENGTH OF INDICATOR (SECTION  0)
    1817. 

  1817. C          (3)   - LENGTH OF PDS       (SECTION  1)
    1818. 

  1818. C          (4)   - LENGTH OF GDS       (SECTION  2)
    1819. 

  1819. C          (5)   - LENGTH OF BMS       (SECTION  3)
    1820. 

  1820. C          (6)   - LENGTH OF BDS       (SECTION  4)
    1821. 

  1821. C          (7)   - VALUE OF CURRENT BYTE
    1822. 

  1822. C          (8)   - BIT POINTER
    1823. 

  1823. C          (9)   - GRIB START BIT NR
    1824. 

  1824. C         (10)   - GRIB/GRID ELEMENT COUNT
    1825. 

  1825. C         (11)   - NR UNUSED BITS AT END OF SECTION 3
    1826. 

  1826. C         (12)   - BIT MAP FLAG
    1827. 

  1827. C         (13)   - NR UNUSED BITS AT END OF SECTION 2
    1828. 

  1828. C         (14)   - BDS FLAGS
    1829. 

  1829. C         (15)   - NR UNUSED BITS AT END OF SECTION 4
    1830. 

  1830. C     KPDS     - ARRAY CONTAINING PDS ELEMENTS.
    1831. 

  1831. C          (1)   - ID OF CENTER
    1832. 

  1832. C          (2)   - MODEL IDENTIFICATION
    1833. 

  1833. C          (3)   - GRID IDENTIFICATION
    1834. 

  1834. C          (4)   - GDS/BMS FLAG
    1835. 

  1835. C          (5)   - INDICATOR OF PARAMETER
    1836. 

  1836. C          (6)   - TYPE OF LEVEL
    1837. 

  1837. C          (7)   - HEIGHT/PRESSURE , ETC OF LEVEL
    1838. 

  1838. C          (8)   - YEAR OF CENTURY
    1839. 

  1839. C          (9)   - MONTH OF YEAR
    1840. 

  1840. C          (10)  - DAY OF MONTH
    1841. 

  1841. C          (11)  - HOUR OF DAY
    1842. 

  1842. C          (12)  - MINUTE OF HOUR
    1843. 

  1843. C          (13)  - INDICATOR OF FORECAST TIME UNIT
    1844. 

  1844. C          (14)  - TIME RANGE 1
    1845. 

  1845. C          (15)  - TIME RANGE 2
    1846. 

  1846. C          (16)  - TIME RANGE FLAG
    1847. 

  1847. C          (17)  - NUMBER INCLUDED IN AVERAGE
    1848. 

  1848. C
    1849. 

  1849. C   OUTPUT ARGUMENT LIST:
    1850. 

  1850. C     KBMS       - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS.
    1851. 

  1851. C     KPTR       - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
    1852. 

  1852. C                  SEE INPUT LIST
    1853. 

  1853. C     KRET       - ERROR RETURN
    1854. 

  1854. C
    1855. 

  1855. C REMARKS:
    1856. 

  1856. C     KRET   = 0 - NO ERROR
    1857. 

  1857. C            = 5 - GRID NOT AVAIL FOR CENTER INDICATED
    1858. 

  1858. C            =10 - INCORRECT CENTER INDICATOR
    1859. 

  1859. C            =12 - BYTES 5-6 ARE NOT ZERO IN BMS, PREDEFINED BIT MAP
    1860. 

  1860. C                  NOT PROVIDED BY THIS CENTER
    1861. 

  1861. C
    1862. 

  1862. C   SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
    1863. 

  1863. C
    1864. 

  1864. C ATTRIBUTES:
    1865. 

  1865. C   LANGUAGE: FORTRAN 77
    1866. 

  1866. C   MACHINE:  HDS9000
    1867. 

  1867. C
    1868. 

  1868. C$$$
    1869. 

  1869. C
    1870. 

  1870. C                       INCOMING MESSAGE HOLDER
    1871. 

  1871.       CHARACTER*1   MSGA(*)
    1872. 

  1872. C
    1873. 

  1873. C                       BIT MAP
    1874. 

  1874.       LOGICAL*1     KBMS(*)
    1875. 

  1875. C
    1876. 

  1876. C                       ARRAY OF POINTERS AND COUNTERS
    1877. 

  1877.       INTEGER       KPTR(*)
    1878. 

  1878. C                       ARRAY OF POINTERS AND COUNTERS
    1879. 

  1879.       INTEGER       KPDS(*)
    1880. 

  1880.       INTEGER       KGDS(*)
    1881. 

  1881. C
    1882. 

  1882.       INTEGER       KRET
    1883. 

  1883.       INTEGER       MASK(8)
    1884. 

  1884. C  ----------------------GRID 21 AND GRID 22 ARE THE SAME
    1885. 

  1885.       LOGICAL*1     GRD21( 1369)
    1886. 

  1886. C  ----------------------GRID 23 AND GRID 24 ARE THE SAME
    1887. 

  1887.       LOGICAL*1     GRD23( 1369)
    1888. 

  1888.       LOGICAL*1     GRD25( 1368)
    1889. 

  1889.       LOGICAL*1     GRD26( 1368)
    1890. 

  1890. C  ----------------------GRID 27 AND GRID 28 ARE THE SAME
    1891. 

  1891. C  ----------------------GRID 29 AND GRID 30 ARE THE SAME
    1892. 

  1892. C  ----------------------GRID 33 AND GRID 34 ARE THE SAME
    1893. 

  1893.       LOGICAL*1     GRD50( 1188)
    1894. 

  1894. C  -----------------------GRID 61 AND GRID 62 ARE THE SAME
    1895. 

  1895.       LOGICAL*1     GRD61( 4186)
    1896. 

  1896. C  -----------------------GRID 63 AND GRID 64 ARE THE SAME
    1897. 

  1897.       LOGICAL*1     GRD63( 4186)
    1898. 

  1898. C     LOGICAL*1     GRD70(16380)/16380*.TRUE./
    1899. 

  1899. C  -------------------------------------------------------------
    1900. 

  1900.       DATA  GRD21 /1333*.TRUE.,36*.FALSE./
    1901. 

  1901.       DATA  GRD23 /.TRUE.,36*.FALSE.,1332*.TRUE./
    1902. 

  1902.       DATA  GRD25 /1297*.TRUE.,71*.FALSE./
    1903. 

  1903.       DATA  GRD26 /.TRUE.,71*.FALSE.,1296*.TRUE./
    1904. 

  1904.       DATA  GRD50/
    1905. 

  1905. C LINE 1-4
    1906. 

  1906.      &  7*.FALSE.,22*.TRUE.,14*.FALSE.,22*.TRUE.,
    1907. 

  1907.      & 14*.FALSE.,22*.TRUE.,14*.FALSE.,22*.TRUE.,7*.FALSE.,
    1908. 

  1908. C LINE 5-8
    1909. 

  1909.      &  6*.FALSE.,24*.TRUE.,12*.FALSE.,24*.TRUE.,
    1910. 

  1910.      & 12*.FALSE.,24*.TRUE.,12*.FALSE.,24*.TRUE.,6*.FALSE.,
    1911. 

  1911. C LINE 9-12
    1912. 

  1912.      &  5*.FALSE.,26*.TRUE.,10*.FALSE.,26*.TRUE.,
    1913. 

  1913.      & 10*.FALSE.,26*.TRUE.,10*.FALSE.,26*.TRUE.,5*.FALSE.,
    1914. 

  1914. C LINE 13-16
    1915. 

  1915.      &  4*.FALSE.,28*.TRUE., 8*.FALSE.,28*.TRUE.,
    1916. 

  1916.      &  8*.FALSE.,28*.TRUE., 8*.FALSE.,28*.TRUE.,4*.FALSE.,
    1917. 

  1917. C LINE 17-20
    1918. 

  1918.      &  3*.FALSE.,30*.TRUE., 6*.FALSE.,30*.TRUE.,
    1919. 

  1919.      &  6*.FALSE.,30*.TRUE., 6*.FALSE.,30*.TRUE.,3*.FALSE.,
    1920. 

  1920. C LINE 21-24
    1921. 

  1921.      &  2*.FALSE.,32*.TRUE., 4*.FALSE.,32*.TRUE.,
    1922. 

  1922.      &  4*.FALSE.,32*.TRUE., 4*.FALSE.,32*.TRUE.,2*.FALSE.,
    1923. 

  1923. C LINE 25-28
    1924. 

  1924.      &    .FALSE.,34*.TRUE., 2*.FALSE.,34*.TRUE.,
    1925. 

  1925.      &  2*.FALSE.,34*.TRUE., 2*.FALSE.,34*.TRUE.,  .FALSE.,
    1926. 

  1926. C LINE 29-33
    1927. 

  1927.      &           180*.TRUE./
    1928. 

  1928.       DATA  GRD61 /4096*.TRUE.,90*.FALSE./
    1929. 

  1929.       DATA  GRD63 /.TRUE.,90*.FALSE.,4095*.TRUE./
    1930. 

  1930.       DATA  MASK  /128,64,32,16,8,4,2,1/
    1931. 

  1931. C
    1932. 

  1932. C     PRINT *,'FI634'
    1933. 

  1933.       IF (IAND(KPDS(4),64).EQ.64) THEN
    1934. 

  1934. C
    1935. 

  1935. C                   SET UP BIT POINTER
    1936. 

  1936. C                          SECTION 0    SECTION 1     SECTION 2
    1937. 

  1937.       KPTR(8) = KPTR(9) + (KPTR(2)*8) + (KPTR(3)*8) + (KPTR(4)*8) + 24
    1938. 

  1938. C
    1939. 

  1939. C  BYTE 4           NUMBER OF UNUSED BITS AT END OF SECTION 3
    1940. 

  1940. C
    1941. 

  1941.       CALL GBYTEC (MSGA,KPTR(11),KPTR(8),8)
    1942. 

  1942.       KPTR(8)  = KPTR(8) + 8
    1943. 

  1943. C
    1944. 

  1944. C  BYTE 5,6         TABLE REFERENCE IF 0, BIT MAP FOLLOWS
    1945. 

  1945. C
    1946. 

  1946.       CALL GBYTEC (MSGA,KPTR(12),KPTR(8),16)
    1947. 

  1947.       KPTR(8)  = KPTR(8) + 16
    1948. 

  1948. C                   IF TABLE REFERENCE = 0, EXTRACT BIT MAP
    1949. 

  1949.         IF (KPTR(12).EQ.0) THEN
    1950. 

  1950. C                   CALCULATE NR OF BITS IN BIT MAP
    1951. 

  1951.           IBITS   = (KPTR(5) - 6) * 8 - KPTR(11)
    1952. 

  1952.           KPTR(10)  = IBITS
    1953. 

  1953.           IF (KPDS(3).EQ.21.OR.KPDS(3).EQ.22.OR.KPDS(3).EQ.25.
    1954. 

  1954.      *             OR.KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN
    1955. 

  1955. C                    NORTHERN HEMISPHERE  21, 22, 25, 61, 62
    1956. 

  1956.               CALL FI634X(IBITS,KPTR(8),MSGA,KBMS)
    1957. 

  1957.               IF (KPDS(3).EQ.25) THEN
    1958. 

  1958.                   KADD     = 71
    1959. 

  1959.               ELSE IF (KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN
    1960. 

  1960.                   KADD     = 90
    1961. 

  1961.               ELSE
    1962. 

  1962.                   KADD     = 36
    1963. 

  1963.               END IF
    1964. 

  1964.               DO 25 I = 1, KADD
    1965. 

  1965.                   KBMS(I+IBITS)  = .FALSE.
    1966. 

  1966.    25         CONTINUE
    1967. 

  1967.               KPTR(10)   = KPTR(10) + KADD
    1968. 

  1968.               RETURN
    1969. 

  1969.           ELSE IF (KPDS(3).EQ.23.OR.KPDS(3).EQ.24.OR.KPDS(3).EQ.26.
    1970. 

  1970.      *             OR.KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN
    1971. 

  1971. C                    SOUTHERN HEMISPHERE  23, 24, 26, 63, 64
    1972. 

  1972.               CALL FI634X(IBITS,KPTR(8),MSGA,KBMS)
    1973. 

  1973.               IF (KPDS(3).EQ.26) THEN
    1974. 

  1974.                   KADD     = 72
    1975. 

  1975.               ELSE IF (KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN
    1976. 

  1976.                   KADD     = 91
    1977. 

  1977.               ELSE
    1978. 

  1978.                   KADD     = 37
    1979. 

  1979.               END IF
    1980. 

  1980.               DO 26 I = 1, KADD
    1981. 

  1981.                   KBMS(I+IBITS)  = .FALSE.
    1982. 

  1982.    26         CONTINUE
    1983. 

  1983.               KPTR(10)   = KPTR(10) + KADD - 1
    1984. 

  1984.               RETURN
    1985. 

  1985.           ELSE IF (KPDS(3).EQ.50) THEN
    1986. 

  1986.               KPAD    = 7
    1987. 

  1987.               KIN     = 22
    1988. 

  1988.               KBITS   = 0
    1989. 

  1989.               DO 55 I = 1, 7
    1990. 

  1990.                   DO 54 J = 1, 4
    1991. 

  1991.                       DO 51 K = 1, KPAD
    1992. 

  1992.                           KBITS   = KBITS + 1
    1993. 

  1993.                           KBMS(KBITS)  = .FALSE.
    1994. 

  1994.    51                 CONTINUE
    1995. 

  1995.                       CALL FI634X(KIN,KPTR(8),MSGA,KBMS(KBITS+1))
    1996. 

  1996.                       KPTR(8)=KPTR(8)+KIN
    1997. 

  1997.                       KBITS=KBITS+KIN
    1998. 

  1998.                       DO 53 K = 1, KPAD
    1999. 

  1999.                           KBITS   = KBITS + 1
    2000. 

  2000.                           KBMS(KBITS)  = .FALSE.
    2001. 

  2001.    53                 CONTINUE
    2002. 

  2002.    54             CONTINUE
    2003. 

  2003.                   KIN    = KIN + 2
    2004. 

  2004.                   KPAD   = KPAD - 1
    2005. 

  2005.    55         CONTINUE
    2006. 

  2006.               DO 57 II = 1, 5
    2007. 

  2007.                   CALL FI634X(KIN,KPTR(8),MSGA,KBMS(KBITS+1))
    2008. 

  2008.                   KPTR(8)=KPTR(8)+KIN
    2009. 

  2009.                   KBITS=KBITS+KIN
    2010. 

  2010.    57         CONTINUE
    2011. 

  2011.           ELSE
    2012. 

  2012. C                        EXTRACT BIT MAP FROM BMS FOR OTHER GRIDS
    2013. 

  2013.               CALL FI634X(IBITS,KPTR(8),MSGA,KBMS)
    2014. 

  2014.           END IF
    2015. 

  2015.           RETURN
    2016. 

  2016.         ELSE
    2017. 

  2017. C         PRINT *,'FI634-NO PREDEFINED BIT MAP PROVIDED BY THIS CENTER'
    2018. 

  2018.           KRET = 12
    2019. 

  2019.           RETURN
    2020. 

  2020.         END IF
    2021. 

  2021. C
    2022. 

  2022.       END IF
    2023. 

  2023.       KRET = 0
    2024. 

  2024. C  -------------------------------------------------------
    2025. 

  2025. C                   PROCESS NON-STANDARD GRID
    2026. 

  2026. C  -------------------------------------------------------
    2027. 

  2027.       IF (KPDS(3).EQ.255) THEN
    2028. 

  2028. C         PRINT *,'NON STANDARD GRID, CENTER = ',KPDS(1)
    2029. 

  2029.           J      = KGDS(2) * KGDS(3)
    2030. 

  2030.           KPTR(10) = J
    2031. 

  2031.           DO 600 I = 1, J
    2032. 

  2032.               KBMS(I) = .TRUE.
    2033. 

  2033.   600     CONTINUE
    2034. 

  2034.           RETURN
    2035. 

  2035.       END IF
    2036. 

  2036. C  -------------------------------------------------------
    2037. 

  2037. C                   CHECK INTERNATIONAL SET
    2038. 

  2038. C  -------------------------------------------------------
    2039. 

  2039.       IF (KPDS(3).EQ.21.OR.KPDS(3).EQ.22) THEN
    2040. 

  2040. C                   ----- INT'L GRIDS 21, 22 - MAP SIZE 1369
    2041. 

  2041.           J   = 1369
    2042. 

  2042.           KPTR(10)  = J
    2043. 

  2043.           CALL FI637(J,KPDS,KGDS,KRET)
    2044. 

  2044.           IF(KRET.NE.0) GO TO 820
    2045. 

  2045.           DO 3021 I = 1, 1369
    2046. 

  2046.               KBMS(I) = GRD21(I)
    2047. 

  2047.  3021     CONTINUE
    2048. 

  2048.           RETURN
    2049. 

  2049.       ELSE IF (KPDS(3).EQ.23.OR.KPDS(3).EQ.24) THEN
    2050. 

  2050. C                   ----- INT'L GRIDS 23, 24 - MAP SIZE 1369
    2051. 

  2051.           J   = 1369
    2052. 

  2052.           KPTR(10)  = J
    2053. 

  2053.           CALL FI637(J,KPDS,KGDS,KRET)
    2054. 

  2054.           IF(KRET.NE.0) GO TO 820
    2055. 

  2055.           DO 3023 I = 1, 1369
    2056. 

  2056.               KBMS(I) = GRD23(I)
    2057. 

  2057.  3023     CONTINUE
    2058. 

  2058.           RETURN
    2059. 

  2059.       ELSE IF (KPDS(3).EQ.25) THEN
    2060. 

  2060. C                   ----- INT'L GRID 25 - MAP SIZE 1368
    2061. 

  2061.           J   = 1368
    2062. 

  2062.           KPTR(10)  = J
    2063. 

  2063.           CALL FI637(J,KPDS,KGDS,KRET)
    2064. 

  2064.           IF(KRET.NE.0) GO TO 820
    2065. 

  2065.           DO 3025 I = 1, 1368
    2066. 

  2066.               KBMS(I) = GRD25(I)
    2067. 

  2067.  3025     CONTINUE
    2068. 

  2068.           RETURN
    2069. 

  2069.       ELSE IF (KPDS(3).EQ.26) THEN
    2070. 

  2070. C                  ----- INT'L GRID  26 - MAP SIZE 1368
    2071. 

  2071.           J   = 1368
    2072. 

  2072.           KPTR(10)  = J
    2073. 

  2073.           CALL FI637(J,KPDS,KGDS,KRET)
    2074. 

  2074.           IF(KRET.NE.0) GO TO 820
    2075. 

  2075.           DO 3026 I = 1, 1368
    2076. 

  2076.               KBMS(I) = GRD26(I)
    2077. 

  2077.  3026     CONTINUE
    2078. 

  2078.           RETURN
    2079. 

  2079.       ELSE IF (KPDS(3).GE.37.AND.KPDS(3).LE.44) THEN
    2080. 

  2080. C                  ----- INT'L GRID  37-44 - MAP SIZE 3447
    2081. 

  2081.           J   = 3447
    2082. 

  2082.           GO TO 800
    2083. 

  2083.       ELSE IF (KPDS(1).EQ.7.AND.KPDS(3).EQ.50) THEN
    2084. 

  2084. C                   ----- INT'L GRIDS 50 - MAP SIZE 964
    2085. 

  2085.           J     = 1188
    2086. 

  2086.           KPTR(10)  = J
    2087. 

  2087.           CALL FI637(J,KPDS,KGDS,KRET)
    2088. 

  2088.           IF(KRET.NE.0) GO TO 890
    2089. 

  2089.           DO 3050 I = 1, J
    2090. 

  2090.               KBMS(I) = GRD50(I)
    2091. 

  2091.  3050     CONTINUE
    2092. 

  2092.           RETURN
    2093. 

  2093.       ELSE IF (KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN
    2094. 

  2094. C                   ----- INT'L GRIDS 61, 62 - MAP SIZE 4186
    2095. 

  2095.           J     = 4186
    2096. 

  2096.           KPTR(10)  = J
    2097. 

  2097.           CALL FI637(J,KPDS,KGDS,KRET)
    2098. 

  2098.           IF(KRET.NE.0) GO TO 820
    2099. 

  2099.           DO 3061 I = 1, 4186
    2100. 

  2100.               KBMS(I) = GRD61(I)
    2101. 

  2101.  3061     CONTINUE
    2102. 

  2102.           RETURN
    2103. 

  2103.       ELSE IF (KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN
    2104. 

  2104. C                  ----- INT'L GRIDS 63, 64 - MAP SIZE 4186
    2105. 

  2105.           J     = 4186
    2106. 

  2106.           KPTR(10)  = J
    2107. 

  2107.           CALL FI637(J,KPDS,KGDS,KRET)
    2108. 

  2108.           IF(KRET.NE.0) GO TO 820
    2109. 

  2109.           DO 3063 I = 1, 4186
    2110. 

  2110.               KBMS(I) = GRD63(I)
    2111. 

  2111.  3063     CONTINUE
    2112. 

  2112.           RETURN
    2113. 

  2113.       END IF
    2114. 

  2114. C  -------------------------------------------------------
    2115. 

  2115. C                   CHECK UNITED STATES SET
    2116. 

  2116. C  -------------------------------------------------------
    2117. 

  2117.       IF (KPDS(1).EQ.7) THEN
    2118. 

  2118.           IF (KPDS(3).LT.100) THEN
    2119. 

  2119.               IF (KPDS(3).EQ.1) THEN
    2120. 

  2120. C                       ----- U.S. GRID 1 - MAP SIZE 1679
    2121. 

  2121.                   J   = 1679
    2122. 

  2122.                   GO TO 800
    2123. 

  2123.               END IF
    2124. 

  2124.               IF (KPDS(3).EQ.2) THEN
    2125. 

  2125. C                       ----- U.S. GRID 2 - MAP SIZE 10512
    2126. 

  2126.                   J   = 10512
    2127. 

  2127.                   GO TO 800
    2128. 

  2128.               ELSE IF (KPDS(3).EQ.3) THEN
    2129. 

  2129. C                       ----- U.S. GRID 3 - MAP SIZE 65160
    2130. 

  2130.                   J   = 65160
    2131. 

  2131.                   GO TO 800
    2132. 

  2132.               ELSE IF (KPDS(3).EQ.4) THEN
    2133. 

  2133. C                       ----- U.S. GRID 4 - MAP SIZE 259920
    2134. 

  2134.                   J   = 259920
    2135. 

  2135.                   GO TO 800
    2136. 

  2136.               ELSE IF (KPDS(3).EQ.5) THEN
    2137. 

  2137. C                       ----- U.S. GRID 5 - MAP SIZE 3021
    2138. 

  2138.                   J   = 3021
    2139. 

  2139.                   GO TO 800
    2140. 

  2140.               ELSE IF (KPDS(3).EQ.6) THEN
    2141. 

  2141. C                       ----- U.S. GRID 6 - MAP SIZE 2385
    2142. 

  2142.                   J   = 2385
    2143. 

  2143.                   GO TO 800
    2144. 

  2144.               ELSE IF (KPDS(3).EQ.8) THEN
    2145. 

  2145. C                       ----- U.S. GRID 8 - MAP SIZE 5104
    2146. 

  2146.                   J   = 5104
    2147. 

  2147.                   GO TO 800
    2148. 

  2148.               ELSE IF (KPDS(3).EQ.10) THEN
    2149. 

  2149. C                       ----- U.S. GRID 10 - MAP SIZE 25020
    2150. 

  2150.                   J   = 25020
    2151. 

  2151.                   GO TO 800
    2152. 

  2152.               ELSE IF (KPDS(3).EQ.11) THEN
    2153. 

  2153. C                       ----- U.S. GRID 11 - MAP SIZE 223920
    2154. 

  2154.                   J   = 223920
    2155. 

  2155.                   GO TO 800
    2156. 

  2156.               ELSE IF (KPDS(3).EQ.12) THEN
    2157. 

  2157. C                       ----- U.S. GRID 12 - MAP SIZE 99631
    2158. 

  2158.                   J   = 99631
    2159. 

  2159.                   GO TO 800
    2160. 

  2160.               ELSE IF (KPDS(3).EQ.13) THEN
    2161. 

  2161. C                       ----- U.S. GRID 13 - MAP SIZE 36391
    2162. 

  2162.                   J   = 36391
    2163. 

  2163.                   GO TO 800
    2164. 

  2164.               ELSE IF (KPDS(3).EQ.14) THEN
    2165. 

  2165. C                       ----- U.S. GRID 14 - MAP SIZE 153811
    2166. 

  2166.                   J   = 153811
    2167. 

  2167.                   GO TO 800
    2168. 

  2168.               ELSE IF (KPDS(3).EQ.15) THEN
    2169. 

  2169. C                       ----- U.S. GRID 15 - MAP SIZE 74987
    2170. 

  2170.                   J   = 74987
    2171. 

  2171.                   GO TO 800
    2172. 

  2172.               ELSE IF (KPDS(3).EQ.16) THEN
    2173. 

  2173. C                       ----- U.S. GRID 16 - MAP SIZE 214268
    2174. 

  2174.                   J   = 214268
    2175. 

  2175.                   GO TO 800
    2176. 

  2176.               ELSE IF (KPDS(3).EQ.17) THEN
    2177. 

  2177. C                       ----- U.S. GRID 17 - MAP SIZE 387136
    2178. 

  2178.                   J   = 387136
    2179. 

  2179.                   GO TO 800
    2180. 

  2180.               ELSE IF (KPDS(3).EQ.18) THEN
    2181. 

  2181. C                       ----- U.S. GRID 18 - MAP SIZE 281866
    2182. 

  2182.                   J   = 281866
    2183. 

  2183.                   GO TO 800
    2184. 

  2184.               ELSE IF (KPDS(3).EQ.27.OR.KPDS(3).EQ.28) THEN
    2185. 

  2185. C                       ----- U.S. GRIDS 27, 28 - MAP SIZE 4225
    2186. 

  2186.                   J     = 4225
    2187. 

  2187.                   GO TO 800
    2188. 

  2188.               ELSE IF (KPDS(3).EQ.29.OR.KPDS(3).EQ.30) THEN
    2189. 

  2189. C                       ----- U.S. GRIDS 29,30 - MAP SIZE 5365
    2190. 

  2190.                   J     = 5365
    2191. 

  2191.                   GO TO 800
    2192. 

  2192.               ELSE IF (KPDS(3).EQ.33.OR.KPDS(3).EQ.34) THEN
    2193. 

  2193. C                       ----- U.S GRID 33, 34 - MAP SIZE 8326
    2194. 

  2194.                   J     = 8326
    2195. 

  2195.                   GO TO 800
    2196. 

  2196.               ELSE IF (KPDS(3).GE.37.AND.KPDS(3).LE.44) THEN
    2197. 

  2197. C                  -----  U.S. GRID  37-44 - MAP SIZE 3447
    2198. 

  2198.                   J   = 3447
    2199. 

  2199.                   GO TO 800
    2200. 

  2200.               ELSE IF (KPDS(3).EQ.45) THEN
    2201. 

  2201. C                  ----- U.S.  GRID  45    - MAP SIZE 41760
    2202. 

  2202.                   J   = 41760
    2203. 

  2203.                   GO TO 800
    2204. 

  2204.               ELSE IF (KPDS(3).EQ.53) THEN
    2205. 

  2205. C                  ----- U.S.  GRID  53    - MAP SIZE 5967
    2206. 

  2206.                   J   = 5967
    2207. 

  2207.                   GO TO 800
    2208. 

  2208.               ELSE IF (KPDS(3).EQ.55.OR.KPDS(3).EQ.56) THEN
    2209. 

  2209. C                       ----- U.S GRID 55, 56 - MAP SIZE 6177
    2210. 

  2210.                   J     = 6177
    2211. 

  2211.                   GO TO 800
    2212. 

  2212.               ELSE IF (KPDS(3).GE.67.AND.KPDS(3).LE.71) THEN
    2213. 

  2213. C                       ----- U.S GRID 67-71 - MAP SIZE 13689
    2214. 

  2214.                   J     = 13689
    2215. 

  2215.                   GO TO 800
    2216. 

  2216.               ELSE IF (KPDS(3).EQ.72) THEN
    2217. 

  2217. C                       ----- U.S GRID    72 - MAP SIZE 406
    2218. 

  2218.                   J     = 406
    2219. 

  2219.                   GO TO 800
    2220. 

  2220.               ELSE IF (KPDS(3).EQ.73) THEN
    2221. 

  2221. C                       ----- U.S GRID    73 - MAP SIZE 13056
    2222. 

  2222.                   J     = 13056
    2223. 

  2223.                   GO TO 800
    2224. 

  2224.               ELSE IF (KPDS(3).EQ.74) THEN
    2225. 

  2225. C                       ----- U.S GRID    74 - MAP SIZE 10800
    2226. 

  2226.                   J     = 10800
    2227. 

  2227.                   GO TO 800
    2228. 

  2228.               ELSE IF (KPDS(3).GE.75.AND.KPDS(3).LE.77) THEN
    2229. 

  2229. C                       ----- U.S GRID 75-77 - MAP SIZE 12321
    2230. 

  2230.                   J     = 12321
    2231. 

  2231.                   GO TO 800
    2232. 

  2232.               ELSE IF (KPDS(3).EQ.83) THEN
    2233. 

  2233. C                       ----- U.S GRID 83 - MAP SIZE 429786
    2234. 

  2234.                   J     = 429786
    2235. 

  2235.                   GO TO 800
    2236. 

  2236.               ELSE IF (KPDS(3).EQ.85.OR.KPDS(3).EQ.86) THEN
    2237. 

  2237. C                       ----- U.S GRID 85,86 - MAP SIZE 32400
    2238. 

  2238.                   J     = 32400
    2239. 

  2239.                   GO TO 800
    2240. 

  2240.               ELSE IF (KPDS(3).EQ.87) THEN
    2241. 

  2241. C                       ----- U.S GRID 87     - MAP SIZE 5022
    2242. 

  2242.                   J     = 5022
    2243. 

  2243.                   GO TO 800
    2244. 

  2244.               ELSE IF (KPDS(3).EQ.88) THEN
    2245. 

  2245. C                       ----- U.S GRID 88     - MAP SIZE 317840
    2246. 

  2246.                   J     = 317840
    2247. 

  2247.                   GO TO 800
    2248. 

  2248.               ELSE IF (KPDS(3).EQ.90) THEN
    2249. 

  2249. C                       ----- U.S GRID 90     - MAP SIZE 11807617
    2250. 

  2250.                   J     = 11807617
    2251. 

  2251.                   GO TO 800
    2252. 

  2252.               ELSE IF (KPDS(3).EQ.91) THEN
    2253. 

  2253. C                       ----- U.S GRID 91     - MAP SIZE 1822145
    2254. 

  2254.                   J     = 1822145
    2255. 

  2255.                   GO TO 800
    2256. 

  2256.               ELSE IF (KPDS(3).EQ.92) THEN
    2257. 

  2257. C                       ----- U.S GRID 92     - MAP SIZE 7283073
    2258. 

  2258.                   J     = 7283073
    2259. 

  2259.                   GO TO 800
    2260. 

  2260.               ELSE IF (KPDS(3).EQ.93) THEN
    2261. 

  2261. C                       ----- U.S GRID 93     - MAP SIZE 111723
    2262. 

  2262.                   J     = 111723
    2263. 

  2263.                   GO TO 800
    2264. 

  2264.               ELSE IF (KPDS(3).EQ.94) THEN
    2265. 

  2265. C                       ----- U.S GRID 94     - MAP SIZE 371875
    2266. 

  2266.                   J     = 371875
    2267. 

  2267.                   GO TO 800
    2268. 

  2268.               ELSE IF (KPDS(3).EQ.95) THEN
    2269. 

  2269. C                       ----- U.S GRID 95     - MAP SIZE 130325
    2270. 

  2270.                   J     = 130325
    2271. 

  2271.                   GO TO 800
    2272. 

  2272.               ELSE IF (KPDS(3).EQ.96) THEN
    2273. 

  2273. C                       ----- U.S GRID 96     - MAP SIZE 209253
    2274. 

  2274.                   J     = 209253
    2275. 

  2275.                   GO TO 800
    2276. 

  2276.               ELSE IF (KPDS(3).EQ.97) THEN
    2277. 

  2277. C                       ----- U.S GRID 97     - MAP SIZE 1508100
    2278. 

  2278.                   J     = 1508100
    2279. 

  2279.                   GO TO 800
    2280. 

  2280.               ELSE IF (KPDS(3).EQ.98) THEN
    2281. 

  2281. C                       ----- U.S GRID 98     - MAP SIZE 18048
    2282. 

  2282.                   J     = 18048
    2283. 

  2283.                   GO TO 800
    2284. 

  2284.               ELSE IF (KPDS(3).EQ.99) THEN
    2285. 

  2285. C                       ----- U.S GRID 99     - MAP SIZE 779385
    2286. 

  2286.                   J     = 779385
    2287. 

  2287.                   GO TO 800
    2288. 

  2288.               END IF
    2289. 

  2289.           ELSE IF (KPDS(3).GE.100.AND.KPDS(3).LT.200) THEN
    2290. 

  2290.               IF (KPDS(3).EQ.100) THEN
    2291. 

  2291. C                       ----- U.S. GRID 100 - MAP SIZE 6889
    2292. 

  2292.                   J     = 6889
    2293. 

  2293.                   GO TO 800
    2294. 

  2294.               ELSE IF (KPDS(3).EQ.101) THEN
    2295. 

  2295. C                    ----- U.S. GRID 101 - MAP SIZE 10283
    2296. 

  2296.                   J     = 10283
    2297. 

  2297.                   GO TO 800
    2298. 

  2298.               ELSE IF (KPDS(3).EQ.103) THEN
    2299. 

  2299. C                     ----- U.S. GRID 103 - MAP SIZE 3640
    2300. 

  2300.                   J     = 3640
    2301. 

  2301.                   GO TO 800
    2302. 

  2302.               ELSE IF (KPDS(3).EQ.104) THEN
    2303. 

  2303. C                     ----- U.S. GRID 104 - MAP SIZE 16170
    2304. 

  2304.                   J     = 16170
    2305. 

  2305.                   GO TO 800
    2306. 

  2306.               ELSE IF (KPDS(3).EQ.105) THEN
    2307. 

  2307. C                 ----- U.S. GRID 105 - MAP SIZE 6889
    2308. 

  2308.                   J     = 6889
    2309. 

  2309.                   GO TO 800
    2310. 

  2310.               ELSE IF (KPDS(3).EQ.106) THEN
    2311. 

  2311. C                     ----- U.S. GRID 106 - MAP SIZE 19305
    2312. 

  2312.                   J     = 19305
    2313. 

  2313.                   GO TO 800
    2314. 

  2314.               ELSE IF (KPDS(3).EQ.107) THEN
    2315. 

  2315. C                 ----- U.S. GRID 107 - MAP SIZE 11040
    2316. 

  2316.                   J     = 11040
    2317. 

  2317.                   GO TO 800
    2318. 

  2318.               ELSE IF (KPDS(3).EQ.110) THEN
    2319. 

  2319. C                 ----- U.S. GRID 110 - MAP SIZE 103936
    2320. 

  2320.                   J     = 103936
    2321. 

  2321.                   GO TO 800
    2322. 

  2322.               ELSE IF (KPDS(3).EQ.120) THEN
    2323. 

  2323. C                 ----- U.S. GRID 120 - MAP SIZE 2020800
    2324. 

  2324.                   J     = 2020800
    2325. 

  2325.                   GO TO 800
    2326. 

  2326.               ELSE IF (KPDS(3).EQ.122) THEN
    2327. 

  2327. C                 ----- U.S. GRID 122 - MAP SIZE 162750
    2328. 

  2328.                   J     = 162750
    2329. 

  2329.                   GO TO 800
    2330. 

  2330.               ELSE IF (KPDS(3).EQ.123) THEN
    2331. 

  2331. C                 ----- U.S. GRID 123 - MAP SIZE 100800
    2332. 

  2332.                   J     = 100800
    2333. 

  2333.                   GO TO 800
    2334. 

  2334.               ELSE IF (KPDS(3).EQ.124) THEN
    2335. 

  2335. C                 ----- U.S. GRID 124 - MAP SIZE 75360
    2336. 

  2336.                   J     = 75360
    2337. 

  2337.                   GO TO 800
    2338. 

  2338.               ELSE IF (KPDS(3).EQ.125) THEN
    2339. 

  2339. C                 ----- U.S. GRID 125 - MAP SIZE 102000
    2340. 

  2340.                   J     = 102000
    2341. 

  2341.                   GO TO 800
    2342. 

  2342.               ELSE IF (KPDS(3).EQ.126) THEN
    2343. 

  2343. C                 ----- U.S. GRID 126 - MAP SIZE 72960
    2344. 

  2344.                   J     = 72960
    2345. 

  2345.                   GO TO 800
    2346. 

  2346.               ELSE IF (KPDS(3).EQ.127) THEN
    2347. 

  2347. C                 ----- U.S. GRID 127 - MAP SIZE 294912
    2348. 

  2348.                   J     = 294912
    2349. 

  2349.                   GO TO 800
    2350. 

  2350.               ELSE IF (KPDS(3).EQ.128) THEN
    2351. 

  2351. C                 ----- U.S. GRID 128 - MAP SIZE 663552
    2352. 

  2352.                   J     = 663552
    2353. 

  2353.                   GO TO 800
    2354. 

  2354.               ELSE IF (KPDS(3).EQ.130) THEN
    2355. 

  2355. C                 ----- U.S. GRID 130 - MAP SIZE 151987
    2356. 

  2356.                   J     = 151987
    2357. 

  2357.                   GO TO 800
    2358. 

  2358.               ELSE IF (KPDS(3).EQ.138) THEN
    2359. 

  2359. C                 ----- U.S. GRID 138 - MAP SIZE 134784
    2360. 

  2360.                   J     = 134784
    2361. 

  2361.                   GO TO 800
    2362. 

  2362.               ELSE IF (KPDS(3).EQ.139) THEN
    2363. 

  2363. C                 ----- U.S. GRID 139 - MAP SIZE 4160
    2364. 

  2364.                   J     = 4160
    2365. 

  2365.                   GO TO 800
    2366. 

  2366.               ELSE IF (KPDS(3).EQ.140) THEN
    2367. 

  2367. C                 ----- U.S. GRID 140 - MAP SIZE 32437
    2368. 

  2368.                   J     = 32437
    2369. 

  2369.                   GO TO 800
    2370. 

  2370. C
    2371. 

  2371.               ELSE IF (KPDS(3).EQ.145) THEN
    2372. 

  2372. C                 ----- U.S. GRID 145 - MAP SIZE 24505
    2373. 

  2373.                   J     = 24505
    2374. 

  2374.                   GO TO 800
    2375. 

  2375.               ELSE IF (KPDS(3).EQ.146) THEN
    2376. 

  2376. C                 ----- U.S. GRID 146 - MAP SIZE 23572
    2377. 

  2377.                   J     = 23572
    2378. 

  2378.                   GO TO 800
    2379. 

  2379.               ELSE IF (KPDS(3).EQ.147) THEN
    2380. 

  2380. C                 ----- U.S. GRID 147 - MAP SIZE 69412
    2381. 

  2381.                   J     = 69412
    2382. 

  2382.                   GO TO 800
    2383. 

  2383.               ELSE IF (KPDS(3).EQ.148) THEN
    2384. 

  2384. C                 ----- U.S. GRID 148 - MAP SIZE 117130
    2385. 

  2385.                   J     = 117130
    2386. 

  2386.                   GO TO 800
    2387. 

  2387.               ELSE IF (KPDS(3).EQ.150) THEN
    2388. 

  2388. C                 ----- U.S. GRID 150 - MAP SIZE 806010
    2389. 

  2389.                   J     = 806010
    2390. 

  2390.                   GO TO 800
    2391. 

  2391.               ELSE IF (KPDS(3).EQ.151) THEN
    2392. 

  2392. C                 ----- U.S. GRID 151 - MAP SIZE 205062
    2393. 

  2393.                   J     = 205062
    2394. 

  2394.                   GO TO 800
    2395. 

  2395.               ELSE IF (KPDS(3).EQ.160) THEN
    2396. 

  2396. C                 ----- U.S. GRID 160 - MAP SIZE 28080
    2397. 

  2397.                   J     = 28080
    2398. 

  2398.                   GO TO 800
    2399. 

  2399.               ELSE IF (KPDS(3).EQ.161) THEN
    2400. 

  2400. C                 ----- U.S. GRID 161 - MAP SIZE 13974
    2401. 

  2401.                   J     = 13974
    2402. 

  2402.                   GO TO 800
    2403. 

  2403.               ELSE IF (KPDS(3).EQ.163) THEN
    2404. 

  2404. C                 ----- U.S. GRID 163 - MAP SIZE 727776
    2405. 

  2405.                   J     = 727776
    2406. 

  2406.                   GO TO 800
    2407. 

  2407.               ELSE IF (KPDS(3).EQ.170) THEN
    2408. 

  2408. C                 ----- U.S. GRID 170 - MAP SIZE 131072
    2409. 

  2409.                   J     =  131072
    2410. 

  2410.                   GO TO 800
    2411. 

  2411.               ELSE IF (KPDS(3).EQ.171) THEN
    2412. 

  2412. C                 ----- U.S. GRID 171 - MAP SIZE 716100
    2413. 

  2413.                   J     = 716100
    2414. 

  2414.                   GO TO 800
    2415. 

  2415.               ELSE IF (KPDS(3).EQ.172) THEN
    2416. 

  2416. C                 ----- U.S. GRID 172 - MAP SIZE 489900
    2417. 

  2417.                   J     = 489900
    2418. 

  2418.                   GO TO 800
    2419. 

  2419.               ELSE IF (KPDS(3).EQ.173) THEN
    2420. 

  2420. C                 ----- U.S. GRID 173 - MAP SIZE 9331200
    2421. 

  2421.                   J     = 9331200
    2422. 

  2422.                   GO TO 800
    2423. 

  2423.               ELSE IF (KPDS(3).EQ.174) THEN
    2424. 

  2424. C                 ----- U.S. GRID 174 - MAP SIZE 4147200
    2425. 

  2425.                   J     = 4147200
    2426. 

  2426.                   GO TO 800
    2427. 

  2427.               ELSE IF (KPDS(3).EQ.175) THEN
    2428. 

  2428. C                 ----- U.S. GRID 175 - MAP SIZE 185704
    2429. 

  2429.                   J     = 185704
    2430. 

  2430.                   GO TO 800
    2431. 

  2431.               ELSE IF (KPDS(3).EQ.176) THEN
    2432. 

  2432. C                 ----- U.S. GRID 176 - MAP SIZE 76845
    2433. 

  2433.                   J     = 76845
    2434. 

  2434.                   GO TO 800
    2435. 

  2435.               ELSE IF (KPDS(3).EQ.179) THEN
    2436. 

  2436. C                 ----- U.S. GRID 179 - MAP SIZE 977132
    2437. 

  2437.                   J     = 977132
    2438. 

  2438.                   GO TO 800
    2439. 

  2439.               ELSE IF (KPDS(3).EQ.180) THEN
    2440. 

  2440. C                 ----- U.S. GRID 180 - MAP SIZE 267168
    2441. 

  2441.                   J     = 267168
    2442. 

  2442.                   GO TO 800
    2443. 

  2443.               ELSE IF (KPDS(3).EQ.181) THEN
    2444. 

  2444. C                 ----- U.S. GRID 181 - MAP SIZE 102860
    2445. 

  2445.                   J     = 102860
    2446. 

  2446.                   GO TO 800
    2447. 

  2447.               ELSE IF (KPDS(3).EQ.182) THEN
    2448. 

  2448. C                 ----- U.S. GRID 182 - MAP SIZE 64218
    2449. 

  2449.                   J     = 64218
    2450. 

  2450.                   GO TO 800
    2451. 

  2451.               ELSE IF (KPDS(3).EQ.183) THEN
    2452. 

  2452. C                 ----- U.S. GRID 183 - MAP SIZE 180144
    2453. 

  2453.                   J     = 180144
    2454. 

  2454.                   GO TO 800
    2455. 

  2455.               ELSE IF (KPDS(3).EQ.184) THEN
    2456. 

  2456. C                 ----- U.S. GRID 184 - MAP SIZE 2953665
    2457. 

  2457.                   J     = 2953665
    2458. 

  2458.                   GO TO 800
    2459. 

  2459.               ELSE IF (KPDS(3).EQ.190) THEN
    2460. 

  2460. C                 ----- U.S GRID 190  - MAP SIZE 796590
    2461. 

  2461.                   J     = 796590
    2462. 

  2462.                   GO TO 800
    2463. 

  2463.               ELSE IF (KPDS(3).EQ.192) THEN
    2464. 

  2464. C                 ----- U.S GRID 192  - MAP SIZE 91719
    2465. 

  2465.                   J     = 91719
    2466. 

  2466.                   GO TO 800
    2467. 

  2467.               ELSE IF (KPDS(3).EQ.194) THEN
    2468. 

  2468. C                 ----- U.S GRID 194  - MAP SIZE 168640
    2469. 

  2469.                   J     = 168640
    2470. 

  2470.                   GO TO 800
    2471. 

  2471.               ELSE IF (KPDS(3).EQ.195) THEN
    2472. 

  2472. C                 ----- U.S. GRID 195 - MAP SIZE 22833
    2473. 

  2473.                   J     = 22833
    2474. 

  2474.                   GO TO 800
    2475. 

  2475.               ELSE IF (KPDS(3).EQ.196) THEN
    2476. 

  2476. C                 ----- U.S. GRID 196 - MAP SIZE 72225
    2477. 

  2477.                   J     = 72225
    2478. 

  2478.                   GO TO 800
    2479. 

  2479.               ELSE IF (KPDS(3).EQ.197) THEN
    2480. 

  2480. C                 ----- U.S. GRID 197 - MAP SIZE 739297
    2481. 

  2481.                   J     = 739297
    2482. 

  2482.                   GO TO 800
    2483. 

  2483.               ELSE IF (KPDS(3).EQ.198) THEN
    2484. 

  2484. C                 ----- U.S. GRID 198 - MAP SIZE 456225
    2485. 

  2485.                   J     = 456225
    2486. 

  2486.                   GO TO 800
    2487. 

  2487.               ELSE IF (KPDS(3).EQ.199) THEN
    2488. 

  2488. C                 ----- U.S. GRID 199 - MAP SIZE 37249
    2489. 

  2489.                   J     = 37249
    2490. 

  2490.                   GO TO 800
    2491. 

  2491.               ELSE IF (IAND(KPDS(4),128).EQ.128) THEN
    2492. 

  2492. C                     ----- U.S. NON-STANDARD GRID
    2493. 

  2493.                   GO TO 895
    2494. 

  2494.               END IF
    2495. 

  2495.           ELSE IF (KPDS(3).GE.200) THEN
    2496. 

  2496.               IF (KPDS(3).EQ.201) THEN
    2497. 

  2497.                   J = 4225
    2498. 

  2498.                   GO TO 800
    2499. 

  2499.               ELSE IF (KPDS(3).EQ.202) THEN
    2500. 

  2500.                   J = 2795
    2501. 

  2501.                   GO TO 800
    2502. 

  2502.               ELSE IF (KPDS(3).EQ.203.OR.KPDS(3).EQ.205) THEN
    2503. 

  2503.                   J = 1755
    2504. 

  2504.                   GO TO 800
    2505. 

  2505.               ELSE IF (KPDS(3).EQ.204) THEN
    2506. 

  2506.                   J = 6324
    2507. 

  2507.                   GO TO 800
    2508. 

  2508.               ELSE IF (KPDS(3).EQ.206) THEN
    2509. 

  2509.                   J = 2091
    2510. 

  2510.                   GO TO 800
    2511. 

  2511.               ELSE IF (KPDS(3).EQ.207) THEN
    2512. 

  2512.                   J = 1715
    2513. 

  2513.                   GO TO 800
    2514. 

  2514.               ELSE IF (KPDS(3).EQ.208) THEN
    2515. 

  2515.                   J = 783
    2516. 

  2516.                   GO TO 800
    2517. 

  2517.               ELSE IF (KPDS(3).EQ.209) THEN
    2518. 

  2518.                   J = 61325
    2519. 

  2519.                   GO TO 800
    2520. 

  2520.               ELSE IF (KPDS(3).EQ.210) THEN
    2521. 

  2521.                   J = 625
    2522. 

  2522.                   GO TO 800
    2523. 

  2523.               ELSE IF (KPDS(3).EQ.211) THEN
    2524. 

  2524.                   J = 6045
    2525. 

  2525.                   GO TO 800
    2526. 

  2526.               ELSE IF (KPDS(3).EQ.212) THEN
    2527. 

  2527.                   J = 23865
    2528. 

  2528.                   GO TO 800
    2529. 

  2529.               ELSE IF (KPDS(3).EQ.213) THEN
    2530. 

  2530.                   J = 10965
    2531. 

  2531.                   GO TO 800
    2532. 

  2532.               ELSE IF (KPDS(3).EQ.214) THEN
    2533. 

  2533.                   J = 6693
    2534. 

  2534.                   GO TO 800
    2535. 

  2535.               ELSE IF (KPDS(3).EQ.215) THEN
    2536. 

  2536.                   J = 94833
    2537. 

  2537.                   GO TO 800
    2538. 

  2538.               ELSE IF (KPDS(3).EQ.216) THEN
    2539. 

  2539.                   J = 14873
    2540. 

  2540.                   GO TO 800
    2541. 

  2541.               ELSE IF (KPDS(3).EQ.217) THEN
    2542. 

  2542.                   J = 59001
    2543. 

  2543.                   GO TO 800
    2544. 

  2544.               ELSE IF (KPDS(3).EQ.218) THEN
    2545. 

  2545.                   J = 262792
    2546. 

  2546.                   GO TO 800
    2547. 

  2547.               ELSE IF (KPDS(3).EQ.219) THEN
    2548. 

  2548.                   J = 179025
    2549. 

  2549.                   GO TO 800
    2550. 

  2550.               ELSE IF (KPDS(3).EQ.220) THEN
    2551. 

  2551.                   J = 122475
    2552. 

  2552.                   GO TO 800
    2553. 

  2553.               ELSE IF (KPDS(3).EQ.221) THEN
    2554. 

  2554.                   J = 96673
    2555. 

  2555.                   GO TO 800
    2556. 

  2556.               ELSE IF (KPDS(3).EQ.222) THEN
    2557. 

  2557.                   J = 15456
    2558. 

  2558.                   GO TO 800
    2559. 

  2559.               ELSE IF (KPDS(3).EQ.223) THEN
    2560. 

  2560.                   J = 16641
    2561. 

  2561.                   GO TO 800
    2562. 

  2562.               ELSE IF (KPDS(3).EQ.224) THEN
    2563. 

  2563.                   J = 4225
    2564. 

  2564.                   GO TO 800
    2565. 

  2565.               ELSE IF (KPDS(3).EQ.225) THEN
    2566. 

  2566.                   J = 24975
    2567. 

  2567.                   GO TO 800
    2568. 

  2568.               ELSE IF (KPDS(3).EQ.226) THEN
    2569. 

  2569.                   J = 381029
    2570. 

  2570.                   GO TO 800
    2571. 

  2571.               ELSE IF (KPDS(3).EQ.227) THEN
    2572. 

  2572.                   J = 1509825
    2573. 

  2573.                   GO TO 800
    2574. 

  2574.               ELSE IF (KPDS(3).EQ.228) THEN
    2575. 

  2575.                   J = 10512
    2576. 

  2576.                   GO TO 800
    2577. 

  2577.               ELSE IF (KPDS(3).EQ.229) THEN
    2578. 

  2578.                   J = 65160
    2579. 

  2579.                   GO TO 800
    2580. 

  2580.               ELSE IF (KPDS(3).EQ.230) THEN
    2581. 

  2581.                   J = 259920
    2582. 

  2582.                   GO TO 800
    2583. 

  2583.               ELSE IF (KPDS(3).EQ.231) THEN
    2584. 

  2584.                   J = 130320
    2585. 

  2585.                   GO TO 800
    2586. 

  2586.               ELSE IF (KPDS(3).EQ.232) THEN
    2587. 

  2587.                   J = 32760
    2588. 

  2588.                   GO TO 800
    2589. 

  2589.               ELSE IF (KPDS(3).EQ.233) THEN
    2590. 

  2590.                   J = 45216
    2591. 

  2591.                   GO TO 800
    2592. 

  2592.               ELSE IF (KPDS(3).EQ.234) THEN
    2593. 

  2593.                   J = 16093
    2594. 

  2594.                   GO TO 800
    2595. 

  2595.               ELSE IF (KPDS(3).EQ.235) THEN
    2596. 

  2596.                   J = 259200
    2597. 

  2597.                   GO TO 800
    2598. 

  2598.               ELSE IF (KPDS(3).EQ.236) THEN
    2599. 

  2599.                   J = 17063
    2600. 

  2600.                   GO TO 800
    2601. 

  2601.               ELSE IF (KPDS(3).EQ.237) THEN
    2602. 

  2602.                   J = 2538
    2603. 

  2603.                   GO TO 800
    2604. 

  2604.               ELSE IF (KPDS(3).EQ.238) THEN
    2605. 

  2605.                   J = 55825
    2606. 

  2606.                   GO TO 800
    2607. 

  2607.               ELSE IF (KPDS(3).EQ.239) THEN
    2608. 

  2608.                   J = 19065
    2609. 

  2609.                   GO TO 800
    2610. 

  2610.               ELSE IF (KPDS(3).EQ.240) THEN
    2611. 

  2611.                   J = 987601
    2612. 

  2612.                   GO TO 800
    2613. 

  2613.               ELSE IF (KPDS(3).EQ.241) THEN
    2614. 

  2614.                   J = 244305
    2615. 

  2615.                   GO TO 800
    2616. 

  2616.               ELSE IF (KPDS(3).EQ.242) THEN
    2617. 

  2617.                   J = 235025
    2618. 

  2618.                   GO TO 800
    2619. 

  2619.               ELSE IF (KPDS(3).EQ.243) THEN
    2620. 

  2620.                   J = 12726
    2621. 

  2621.                   GO TO 800
    2622. 

  2622.               ELSE IF (KPDS(3).EQ.244) THEN
    2623. 

  2623.                   J = 55825
    2624. 

  2624.                   GO TO 800
    2625. 

  2625.               ELSE IF (KPDS(3).EQ.245) THEN
    2626. 

  2626.                   J = 124992
    2627. 

  2627.                   GO TO 800
    2628. 

  2628.               ELSE IF (KPDS(3).EQ.246) THEN
    2629. 

  2629.                   J = 123172
    2630. 

  2630.                   GO TO 800
    2631. 

  2631.               ELSE IF (KPDS(3).EQ.247) THEN
    2632. 

  2632.                   J = 124992
    2633. 

  2633.                   GO TO 800
    2634. 

  2634.               ELSE IF (KPDS(3).EQ.248) THEN
    2635. 

  2635.                   J = 13635
    2636. 

  2636.                   GO TO 800
    2637. 

  2637.               ELSE IF (KPDS(3).EQ.249) THEN
    2638. 

  2638.                   J = 125881
    2639. 

  2639.                   GO TO 800
    2640. 

  2640.               ELSE IF (KPDS(3).EQ.250) THEN
    2641. 

  2641.                   J = 13635
    2642. 

  2642.                   GO TO 800
    2643. 

  2643.               ELSE IF (KPDS(3).EQ.251) THEN
    2644. 

  2644.                   J = 69720
    2645. 

  2645.                   GO TO 800
    2646. 

  2646.               ELSE IF (KPDS(3).EQ.252) THEN
    2647. 

  2647.                   J = 67725
    2648. 

  2648.                   GO TO 800
    2649. 

  2649.               ELSE IF (KPDS(3).EQ.253) THEN
    2650. 

  2650.                   J = 83552
    2651. 

  2651.                   GO TO 800
    2652. 

  2652.               ELSE IF (KPDS(3).EQ.254) THEN
    2653. 

  2653.                   J = 110700
    2654. 

  2654.                   GO TO 800
    2655. 

  2655.               ELSE IF (IAND(KPDS(4),128).EQ.128) THEN
    2656. 

  2656.                   GO TO 895
    2657. 

  2657.               END IF
    2658. 

  2658.               KRET  = 5
    2659. 

  2659.               RETURN
    2660. 

  2660.           END IF
    2661. 

  2661.       END IF
    2662. 

  2662. C  -------------------------------------------------------
    2663. 

  2663. C                   CHECK JAPAN METEOROLOGICAL AGENCY SET
    2664. 

  2664. C  -------------------------------------------------------
    2665. 

  2665.       IF (KPDS(1).EQ.34) THEN
    2666. 

  2666.           IF (IAND(KPDS(4),128).EQ.128) THEN
    2667. 

  2667. C             PRINT *,'JMA MAP IS NOT PREDEFINED, THE GDS WILL'
    2668. 

  2668. C             PRINT *,'BE USED TO UNPACK THE DATA, MAP = ',KPDS(3)
    2669. 

  2669.               GO TO 900
    2670. 

  2670.           END IF
    2671. 

  2671.       END IF
    2672. 

  2672. C  -------------------------------------------------------
    2673. 

  2673. C                   CHECK CANADIAN SET
    2674. 

  2674. C  -------------------------------------------------------
    2675. 

  2675.       IF (KPDS(1).EQ.54) THEN
    2676. 

  2676.           IF (IAND(KPDS(4),128).EQ.128) THEN
    2677. 

  2677. C             PRINT *,'CANADIAN MAP IS NOT PREDEFINED, THE GDS WILL'
    2678. 

  2678. C             PRINT *,'BE USED TO UNPACK THE DATA, MAP = ',KPDS(3)
    2679. 

  2679.               GO TO 900
    2680. 

  2680.           END IF
    2681. 

  2681.       END IF
    2682. 

  2682. C  -------------------------------------------------------
    2683. 

  2683. C                   CHECK FNOC SET
    2684. 

  2684. C  -------------------------------------------------------
    2685. 

  2685.       IF (KPDS(1).EQ.58) THEN
    2686. 

  2686.           IF (KPDS(3).EQ.220.OR.KPDS(3).EQ.221) THEN
    2687. 

  2687. C                      FNOC GRID 220, 221 - MAPSIZE 3969 (63 * 63)
    2688. 

  2688.               J  = 3969
    2689. 

  2689.               KPTR(10)  = J
    2690. 

  2690.               DO I = 1, J
    2691. 

  2691.                   KBMS(I)  = .TRUE.
    2692. 

  2692.               END DO
    2693. 

  2693.               RETURN
    2694. 

  2694.           END IF
    2695. 

  2695.           IF (KPDS(3).EQ.223) THEN
    2696. 

  2696. C                      FNOC GRID 223 - MAPSIZE 10512 (73 * 144)
    2697. 

  2697.               J  = 10512
    2698. 

  2698.               KPTR(10)  = J
    2699. 

  2699.               DO I = 1, J
    2700. 

  2700.                   KBMS(I)  = .TRUE.
    2701. 

  2701.               END DO
    2702. 

  2702.               RETURN
    2703. 

  2703.           END IF
    2704. 

  2704.           IF (IAND(KPDS(4),128).EQ.128) THEN
    2705. 

  2705. C             PRINT *,'FNOC MAP IS NOT PREDEFINED, THE GDS WILL'
    2706. 

  2706. C             PRINT *,'BE USED TO UNPACK THE DATA, MAP = ',KPDS(3)
    2707. 

  2707.               GO TO 900
    2708. 

  2708.           END IF
    2709. 

  2709.       END IF
    2710. 

  2710. C  -------------------------------------------------------
    2711. 

  2711. C                   CHECK UKMET SET
    2712. 

  2712. C  -------------------------------------------------------
    2713. 

  2713.       IF (KPDS(1).EQ.74) THEN
    2714. 

  2714.           IF (IAND(KPDS(4),128).EQ.128) THEN
    2715. 

  2715.               GO TO 820
    2716. 

  2716.           END IF
    2717. 

  2717.       END IF
    2718. 

  2718. C  -------------------------------------------------------
    2719. 

  2719. C                   CHECK ECMWF SET
    2720. 

  2720. C  -------------------------------------------------------
    2721. 

  2721.       IF (KPDS(1).EQ.98) THEN
    2722. 

  2722.           IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN
    2723. 

  2723.               IF (KPDS(3).GE.5.AND.KPDS(3).LE.8) THEN
    2724. 

  2724.                   J     = 1073
    2725. 

  2725.               ELSE
    2726. 

  2726.                   J     = 1369
    2727. 

  2727.               END IF
    2728. 

  2728.               KPTR(10)  = J
    2729. 

  2729.               CALL FI637(J,KPDS,KGDS,KRET)
    2730. 

  2730.               IF(KRET.NE.0) GO TO 810
    2731. 

  2731.               KPTR(10)  = J  ! Reset For Modified J
    2732. 

  2732.               DO 1000 I = 1, J
    2733. 

  2733.                   KBMS(I) = .TRUE.
    2734. 

  2734.  1000         CONTINUE
    2735. 

  2735.               RETURN
    2736. 

  2736.           ELSE IF (KPDS(3).GE.13.AND.KPDS(3).LE.16) THEN
    2737. 

  2737.               J         = 361
    2738. 

  2738.               KPTR(10)  = J
    2739. 

  2739.               CALL FI637(J,KPDS,KGDS,KRET)
    2740. 

  2740.               IF(KRET.NE.0) GO TO 810
    2741. 

  2741.               DO 1013 I = 1, J
    2742. 

  2742.                   KBMS(I) = .TRUE.
    2743. 

  2743.  1013         CONTINUE
    2744. 

  2744.               RETURN
    2745. 

  2745.           ELSE IF (IAND(KPDS(4),128).EQ.128) THEN
    2746. 

  2746.                   GO TO 810
    2747. 

  2747.           ELSE
    2748. 

  2748.               KRET  = 5
    2749. 

  2749.               RETURN
    2750. 

  2750.           END IF
    2751. 

  2751.       ELSE
    2752. 

  2752. C         PRINT *,'CENTER ',KPDS(1),' IS NOT DEFINED'
    2753. 

  2753.           IF (IAND(KPDS(4),128).EQ.128) THEN
    2754. 

  2754. C             PRINT *,'GDS WILL BE USED TO UNPACK THE DATA',
    2755. 

  2755. C    *                        ' MAP = ',KPDS(3)
    2756. 

  2756.               GO TO 900
    2757. 

  2757.           ELSE
    2758. 

  2758.               KRET  = 10
    2759. 

  2759.               RETURN
    2760. 

  2760.           END IF
    2761. 

  2761.       END IF
    2762. 

  2762. C =======================================
    2763. 

  2763. C
    2764. 

  2764.   800 CONTINUE
    2765. 

  2765.       KPTR(10)  = J
    2766. 

  2766.       CALL FI637 (J,KPDS,KGDS,KRET)
    2767. 

  2767.       IF(KRET.NE.0) GO TO 801
    2768. 

  2768.       DO 2201 I = 1, J
    2769. 

  2769.           KBMS(I)  = .TRUE.
    2770. 

  2770.  2201 CONTINUE
    2771. 

  2771.       RETURN
    2772. 

  2772.   801 CONTINUE
    2773. 

  2773. C
    2774. 

  2774. C  ----- THE MAP HAS A GDS, BYTE 7 OF THE (PDS) THE GRID IDENTIFICATION
    2775. 

  2775. C  ----- IS NOT 255, THE SIZE OF THE GRID IS NOT THE SAME AS THE
    2776. 

  2776. C  ----- PREDEFINED SIZES OF THE U.S. GRIDS, OR KNOWN GRIDS OF THE
    2777. 

  2777. C  ----- OF THE OTHER CENTERS. THE GRID CAN BE UNKNOWN, OR FROM AN
    2778. 

  2778. C  ----- UNKNOWN CENTER, WE WILL USE THE INFORMATION IN THE GDS TO MAKE
    2779. 

  2779. C  ----- A BIT MAP.
    2780. 

  2780. C
    2781. 

  2781.   810 CONTINUE
    2782. 

  2782. C     PRINT *,'ECMWF PREDEFINED MAP SIZE DOES NOT MATCH, I WILL USE'
    2783. 

  2783.       GO TO 895
    2784. 

  2784. C
    2785. 

  2785.   820 CONTINUE
    2786. 

  2786. C     PRINT *,'U.K. MET PREDEFINED MAP SIZE DOES NOT MATCH, I WILL USE'
    2787. 

  2787.       GO TO 895
    2788. 

  2788. C
    2789. 

  2789.   890 CONTINUE
    2790. 

  2790. C     PRINT *,'PREDEFINED MAP SIZE DOES NOT MATCH, I WILL USE'
    2791. 

  2791.   895 CONTINUE
    2792. 

  2792. C     PRINT *,'THE GDS TO UNPACK THE DATA, MAP TYPE = ',KPDS(3)
    2793. 

  2793. C
    2794. 

  2794.   900 CONTINUE
    2795. 

  2795.         J      = KGDS(2) * KGDS(3)
    2796. 

  2796. C                    AFOS AFOS AFOS        SPECIAL CASE
    2797. 

  2797. C                             INVOLVES NEXT SINGLE STATEMENT ONLY
    2798. 

  2798.         IF (KPDS(3).EQ.211) KRET = 0
    2799. 

  2799.         KPTR(10) = J
    2800. 

  2800.         DO 2203 I = 1, J
    2801. 

  2801.           KBMS(I) = .TRUE.
    2802. 

  2802.  2203   CONTINUE
    2803. 

  2803. C     PRINT *,'EXIT FI634'
    2804. 

  2804.       RETURN
    2805. 

  2805.       END
    2806. 

  2806. C-----------------------------------------------------------------------
    2807. 

  2807.       SUBROUTINE FI634X(NPTS,NSKP,MSGA,KBMS)
    2808. 

  2808. C$$$  SUBPROGRAM DOCUMENTATION  BLOCK
    2809. 

  2809. C                .      .    .                                       .
    2810. 

  2810. C SUBPROGRAM:    FI634X      EXTRACT BIT MAP
    2811. 

  2811. C   PRGMMR: IREDELL          ORG: W/NP23     DATE: 91-09-19
    2812. 

  2812. C
    2813. 

  2813. C ABSTRACT: EXTRACT THE PACKED BITMAP INTO A LOGICAL ARRAY.
    2814. 

  2814. C
    2815. 

  2815. C PROGRAM HISTORY LOG:
    2816. 

  2816. C   97-09-19  IREDELL     VECTORIZED BITMAP DECODER
    2817. 

  2817. C
    2818. 

  2818. C USAGE:    CALL FI634X(NPTS,NSKP,MSGA,KBMS)
    2819. 

  2819. C   INPUT ARGUMENT LIST:
    2820. 

  2820. C     NPTS       - INTEGER NUMBER OF POINTS IN THE BITMAP FIELD
    2821. 

  2821. C     NSKP       - INTEGER NUMBER OF BITS TO SKIP IN GRIB MESSAGE
    2822. 

  2822. C     MSGA       - CHARACTER*1 GRIB MESSAGE
    2823. 

  2823. C
    2824. 

  2824. C   OUTPUT ARGUMENT LIST:
    2825. 

  2825. C     KBMS       - LOGICAL*1 BITMAP
    2826. 

  2826. C
    2827. 

  2827. C REMARKS:
    2828. 

  2828. C   SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
    2829. 

  2829. C
    2830. 

  2830. C ATTRIBUTES:
    2831. 

  2831. C   LANGUAGE: FORTRAN 77
    2832. 

  2832. C   MACHINE:  CRAY
    2833. 

  2833. C
    2834. 

  2834. C$$$
    2835. 

  2835.       CHARACTER*1   MSGA(*)
    2836. 

  2836.       LOGICAL*1     KBMS(NPTS)
    2837. 

  2837.       INTEGER       ICHK(NPTS)
    2838. 

  2838. C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    2839. 

  2839.       CALL GBYTESC(MSGA,ICHK,NSKP,1,0,NPTS)
    2840. 

  2840.       KBMS=ICHK.NE.0
    2841. 

  2841. C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    2842. 

  2842.       END
    2843. 

  2843.       SUBROUTINE FI635(MSGA,KPTR,KPDS,KGDS,KBMS,DATA,KRET)
    2844. 

  2844. C$$$  SUBPROGRAM DOCUMENTATION  BLOCK
    2845. 

  2845. C                .      .    .                                       .
    2846. 

  2846. C SUBPROGRAM:    FI635         EXTRACT GRIB DATA ELEMENTS FROM BDS
    2847. 

  2847. C   PRGMMR: BILL CAVANAUGH   ORG: W/NMC42    DATE: 91-09-13
    2848. 

  2848. C
    2849. 

  2849. C ABSTRACT: EXTRACT GRIB DATA FROM BINARY DATA SECTION AND PLACE
    2850. 

  2850. C           INTO OUTPUT ARRAY IN PROPER POSITION.
    2851. 

  2851. C
    2852. 

  2852. C PROGRAM HISTORY LOG:
    2853. 

  2853. C   91-09-13  CAVANAUGH
    2854. 

  2854. C   94-04-01  CAVANAUGH  MODIFIED CODE TO INCLUDE DECIMAL SCALING WHEN
    2855. 

  2855. C                        CALCULATING THE VALUE OF DATA POINTS SPECIFIED
    2856. 

  2856. C                        AS BEING EQUAL TO THE REFERENCE VALUE
    2857. 

  2857. C   94-11-10  FARLEY     INCREASED MXSIZE FROM 72960 TO 260000
    2858. 

  2858. C                        FOR .5 DEGREE SST ANALYSIS FIELDS
    2859. 

  2859. C   95-10-31  IREDELL    REMOVED SAVES AND PRINTS
    2860. 

  2860. C   98-08-31  IREDELL    ELIMINATED NEED FOR MXSIZE
    2861. 

  2861. C
    2862. 

  2862. C USAGE:    CALL FI635(MSGA,KPTR,KPDS,KGDS,KBMS,DATA,KRET)
    2863. 

  2863. C   INPUT ARGUMENT LIST:
    2864. 

  2864. C     MSGA       - ARRAY CONTAINING GRIB MESSAGE
    2865. 

  2865. C     KPTR       - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
    2866. 

  2866. C          (1)   - TOTAL LENGTH OF GRIB MESSAGE
    2867. 

  2867. C          (2)   - LENGTH OF INDICATOR (SECTION  0)
    2868. 

  2868. C          (3)   - LENGTH OF PDS       (SECTION  1)
    2869. 

  2869. C          (4)   - LENGTH OF GDS       (SECTION  2)
    2870. 

  2870. C          (5)   - LENGTH OF BMS       (SECTION  3)
    2871. 

  2871. C          (6)   - LENGTH OF BDS       (SECTION  4)
    2872. 

  2872. C          (7)   - VALUE OF CURRENT BYTE
    2873. 

  2873. C          (8)   - BIT POINTER
    2874. 

  2874. C          (9)   - GRIB START BIT NR
    2875. 

  2875. C         (10)   - GRIB/GRID ELEMENT COUNT
    2876. 

  2876. C         (11)   - NR UNUSED BITS AT END OF SECTION 3
    2877. 

  2877. C         (12)   - BIT MAP FLAG
    2878. 

  2878. C         (13)   - NR UNUSED BITS AT END OF SECTION 2
    2879. 

  2879. C         (14)   - BDS FLAGS
    2880. 

  2880. C         (15)   - NR UNUSED BITS AT END OF SECTION 4
    2881. 

  2881. C         (16)   - RESERVED
    2882. 

  2882. C         (17)   - RESERVED
    2883. 

  2883. C         (18)   - RESERVED
    2884. 

  2884. C         (19)   - BINARY SCALE FACTOR
    2885. 

  2885. C         (20)   - NUM BITS USED TO PACK EACH DATUM
    2886. 

  2886. C     KPDS     - ARRAY CONTAINING PDS ELEMENTS.
    2887. 

  2887. C                  SEE INITIAL ROUTINE
    2888. 

  2888. C     KBMS       - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS.
    2889. 

  2889. C
    2890. 

  2890. C   OUTPUT ARGUMENT LIST:
    2891. 

  2891. C     KBDS       - INFORMATION EXTRACTED FROM BINARY DATA SECTION
    2892. 

  2892. C     KBDS(1)  - N1
    2893. 

  2893. C     KBDS(2)  - N2
    2894. 

  2894. C     KBDS(3)  - P1
    2895. 

  2895. C     KBDS(4)  - P2
    2896. 

  2896. C     KBDS(5)  - BIT POINTER TO 2ND ORDER WIDTHS
    2897. 

  2897. C     KBDS(6)  -  "    "     "   "   "    BIT MAPS
    2898. 

  2898. C     KBDS(7)  -  "    "     "  FIRST ORDER VALUES
    2899. 

  2899. C     KBDS(8)  -  "    "     "  SECOND ORDER VALUES
    2900. 

  2900. C     KBDS(9)  -  "    "     START OF BDS
    2901. 

  2901. C     KBDS(10) -  "    "     MAIN BIT MAP
    2902. 

  2902. C     KBDS(11) - BINARY SCALING
    2903. 

  2903. C     KBDS(12) - DECIMAL SCALING
    2904. 

  2904. C     KBDS(13) - BIT WIDTH OF FIRST ORDER VALUES
    2905. 

  2905. C     KBDS(14) - BIT MAP FLAG
    2906. 

  2906. C                 0 = NO SECOND ORDER BIT MAP
    2907. 

  2907. C                 1 = SECOND ORDER BIT MAP PRESENT
    2908. 

  2908. C     KBDS(15) - SECOND ORDER BIT WIDTH
    2909. 

  2909. C     KBDS(16) - CONSTANT / DIFFERENT WIDTHS
    2910. 

  2910. C                 0 = CONSTANT WIDTHS
    2911. 

  2911. C                 1 = DIFFERENT WIDTHS
    2912. 

  2912. C     KBDS(17) - SINGLE DATUM / MATRIX
    2913. 

  2913. C                 0 = SINGLE DATUM AT EACH GRID POINT
    2914. 

  2914. C                 1 = MATRIX OF VALUES AT EACH GRID POINT
    2915. 

  2915. C       (18-20)- UNUSED
    2916. 

  2916. C
    2917. 

  2917. C     DATA       - REAL*4 ARRAY OF GRIDDED ELEMENTS IN GRIB MESSAGE.
    2918. 

  2918. C     KPTR       - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
    2919. 

  2919. C                  SEE INPUT LIST
    2920. 

  2920. C     KRET       - ERROR RETURN
    2921. 

  2921. C
    2922. 

  2922. C REMARKS:
    2923. 

  2923. C     ERROR RETURN
    2924. 

  2924. C              3 = UNPACKED FIELD IS LARGER THAN 65160
    2925. 

  2925. C              6 = DOES NOT MATCH NR OF ENTRIES FOR THIS GRIB/GRID
    2926. 

  2926. C              7 = NUMBER OF BITS IN FILL TOO LARGE
    2927. 

  2927. C
    2928. 

  2928. C   SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
    2929. 

  2929. C
    2930. 

  2930. C ATTRIBUTES:
    2931. 

  2931. C   LANGUAGE: FORTRAN 77
    2932. 

  2932. C   MACHINE:  HDS9000
    2933. 

  2933. C
    2934. 

  2934. C$$$
    2935. 

  2935. C
    2936. 

  2936.       CHARACTER*1   MSGA(*)
    2937. 

  2937. C
    2938. 

  2938.       LOGICAL*1     KBMS(*)
    2939. 

  2939. C
    2940. 

  2940.       INTEGER       KPDS(*)
    2941. 

  2941.       INTEGER       KGDS(*)
    2942. 

  2942.       INTEGER       KBDS(20)
    2943. 

  2943.       INTEGER       KPTR(*)
    2944. 

  2944.       INTEGER       NRBITS
    2945. 

  2945.       INTEGER,ALLOCATABLE::  KSAVE(:)
    2946. 

  2946.       INTEGER       KSCALE
    2947. 

  2947. C
    2948. 

  2948.       REAL          DATA(*)
    2949. 

  2949.       REAL          REFNCE
    2950. 

  2950.       REAL          SCALE
    2951. 

  2951.       REAL          REALKK
    2952. 

  2952. C
    2953. 

  2953. C
    2954. 

  2954. C     CHANGED HEX VALUES TO DECIMAL TO MAKE CODE MORE PORTABLE
    2955. 

  2955. C
    2956. 

  2956. C  *************************************************************
    2957. 

  2957. C     PRINT *,'ENTER FI635'
    2958. 

  2958. C              SET UP BIT POINTER
    2959. 

  2959.       KPTR(8) = KPTR(9) + (KPTR(2)*8) + (KPTR(3)*8) + (KPTR(4)*8)
    2960. 

  2960.      *                + (KPTR(5)*8) + 24
    2961. 

  2961. C  ------------- EXTRACT FLAGS
    2962. 

  2962. C            BYTE 4
    2963. 

  2963.       CALL GBYTEC(MSGA,KPTR(14),KPTR(8),4)
    2964. 

  2964.       KPTR(8)  = KPTR(8) + 4
    2965. 

  2965. C  --------- NR OF UNUSED BITS IN SECTION 4
    2966. 

  2966.       CALL GBYTEC(MSGA,KPTR(15),KPTR(8),4)
    2967. 

  2967.       KPTR(8)  = KPTR(8) + 4
    2968. 

  2968.       KEND    = KPTR(9) + (KPTR(2)*8) + (KPTR(3)*8) + (KPTR(4)*8)
    2969. 

  2969.      *                + (KPTR(5)*8) + KPTR(6) * 8 - KPTR(15)
    2970. 

  2970. C  ------------- GET SCALE FACTOR
    2971. 

  2971. C            BYTES 5,6
    2972. 

  2972. C                                  CHECK SIGN
    2973. 

  2973.       CALL GBYTEC (MSGA,KSIGN,KPTR(8),1)
    2974. 

  2974.       KPTR(8)  = KPTR(8) + 1
    2975. 

  2975. C                                  GET ABSOLUTE SCALE VALUE
    2976. 

  2976.       CALL GBYTEC (MSGA,KSCALE,KPTR(8),15)
    2977. 

  2977.       KPTR(8)  = KPTR(8) + 15
    2978. 

  2978.       IF (KSIGN.GT.0) THEN
    2979. 

  2979.           KSCALE  = - KSCALE
    2980. 

  2980.       END IF
    2981. 

  2981.       SCALE = 2.0**KSCALE
    2982. 

  2982.       KPTR(19)=KSCALE
    2983. 

  2983. C  ------------ GET REFERENCE VALUE
    2984. 

  2984. C            BYTES 7,10
    2985. 

  2985. C      CALL GBYTE (MSGA,KREF,KPTR(8),32)
    2986. 

  2986.       call gbytec(MSGA,JSGN,KPTR(8),1)
    2987. 

  2987.       call gbytec(MSGA,JEXP,KPTR(8)+1,7)
    2988. 

  2988.       call gbytec(MSGA,IFR,KPTR(8)+8,24)
    2989. 

  2989.       KPTR(8)  = KPTR(8) + 32
    2990. 

  2990. C
    2991. 

  2991. C     THE NEXT CODE WILL CONVERT THE IBM370 FLOATING POINT
    2992. 

  2992. C     TO THE FLOATING POINT USED ON YOUR COMPUTER.
    2993. 

  2993. C
    2994. 

  2994. C
    2995. 

  2995. C     PRINT *,109,JSGN,JEXP,IFR
    2996. 

  2996. C 109 FORMAT (' JSGN,JEXP,IFR = ',3(1X,Z8))
    2997. 

  2997.       IF (IFR.EQ.0) THEN
    2998. 

  2998.           REFNCE  = 0.0
    2999. 

  2999.       ELSE IF (JEXP.EQ.0.AND.IFR.EQ.0) THEN
    3000. 

  3000.           REFNCE  = 0.0
    3001. 

  3001.       ELSE
    3002. 

  3002.           REFNCE  = FLOAT(IFR) * 16.0 ** (JEXP - 64 - 6)
    3003. 

  3003.           IF (JSGN.NE.0) REFNCE = - REFNCE
    3004. 

  3004.       END IF
    3005. 

  3005. C     PRINT *,'SCALE ',SCALE,' REF VAL ',REFNCE
    3006. 

  3006. C  ------------- NUMBER OF BITS SPECIFIED FOR EACH ENTRY
    3007. 

  3007. C            BYTE 11
    3008. 

  3008.       CALL GBYTEC (MSGA,KBITS,KPTR(8),8)
    3009. 

  3009.       KPTR(8)  = KPTR(8) + 8
    3010. 

  3010.       KBDS(4)  = KBITS
    3011. 

  3011. C     KBDS(13) = KBITS
    3012. 

  3012.       KPTR(20) = KBITS
    3013. 

  3013.       IBYT12   = KPTR(8)
    3014. 

  3014. C  ------------------ IF THERE ARE NO EXTENDED FLAGS PRESENT
    3015. 

  3015. C                     THIS IS WHERE DATA BEGINS AND AND THE PROCESSING
    3016. 

  3016. C                     INCLUDED IN THE FOLLOWING IF...END IF
    3017. 

  3017. C                     WILL BE SKIPPED
    3018. 

  3018. C     PRINT *,'BASIC FLAGS =',KPTR(14) ,IAND(KPTR(14),1)
    3019. 

  3019.       IF (IAND(KPTR(14),1).EQ.0) THEN
    3020. 

  3020. C         PRINT *,'NO EXTENDED FLAGS'
    3021. 

  3021.       ELSE
    3022. 

  3022. C            BYTES 12,13
    3023. 

  3023.           CALL GBYTEC (MSGA,KOCTET,KPTR(8),16)
    3024. 

  3024.           KPTR(8)  = KPTR(8) + 16
    3025. 

  3025. C  --------------------------- EXTENDED FLAGS
    3026. 

  3026. C            BYTE 14
    3027. 

  3027.           CALL GBYTEC (MSGA,KXFLAG,KPTR(8),8)
    3028. 

  3028. C         PRINT *,'HAVE EXTENDED FLAGS',KXFLAG
    3029. 

  3029.           KPTR(8)  = KPTR(8) + 8
    3030. 

  3030.           IF (IAND(KXFLAG,16).EQ.0) THEN
    3031. 

  3031. C                          SECOND ORDER VALUES CONSTANT WIDTHS
    3032. 

  3032.               KBDS(16)  = 0
    3033. 

  3033.           ELSE
    3034. 

  3034. C                          SECOND ORDER VALUES DIFFERENT WIDTHS
    3035. 

  3035.               KBDS(16)  = 1
    3036. 

  3036.           END IF
    3037. 

  3037.           IF (IAND (KXFLAG,32).EQ.0) THEN
    3038. 

  3038. C                         NO SECONDARY BIT MAP
    3039. 

  3039.               KBDS(14)  = 0
    3040. 

  3040.           ELSE
    3041. 

  3041. C                         HAVE SECONDARY BIT MAP
    3042. 

  3042.               KBDS(14)  = 1
    3043. 

  3043.           END IF
    3044. 

  3044.           IF (IAND (KXFLAG,64).EQ.0) THEN
    3045. 

  3045. C                         SINGLE DATUM AT GRID POINT
    3046. 

  3046.               KBDS(17)  = 0
    3047. 

  3047.           ELSE
    3048. 

  3048. C                         MATRIX OF VALUES AT GRID POINT
    3049. 

  3049.               KBDS(17)  = 1
    3050. 

  3050.           END IF
    3051. 

  3051. C  ---------------------- NR - FIRST DIMENSION (ROWS) OF EACH MATRIX
    3052. 

  3052. C            BYTES 15,16
    3053. 

  3053.           CALL GBYTEC (MSGA,NR,KPTR(8),16)
    3054. 

  3054.           KPTR(8)  = KPTR(8) + 16
    3055. 

  3055. C  ---------------------- NC - SECOND DIMENSION (COLS) OF EACH MATRIX
    3056. 

  3056. C            BYTES 17,18
    3057. 

  3057.           CALL GBYTEC (MSGA,NC,KPTR(8),16)
    3058. 

  3058.           KPTR(8)  = KPTR(8) + 16
    3059. 

  3059. C  ---------------------- NRV - FIRST DIM COORD VALS
    3060. 

  3060. C            BYTE 19
    3061. 

  3061.           CALL GBYTEC (MSGA,NRV,KPTR(8),8)
    3062. 

  3062.           KPTR(8)  = KPTR(8) + 8
    3063. 

  3063. C  ---------------------- NC1 - NR COEFF'S OR VALUES
    3064. 

  3064. C            BYTE 20
    3065. 

  3065.           CALL GBYTEC (MSGA,NC1,KPTR(8),8)
    3066. 

  3066.           KPTR(8)  = KPTR(8) + 8
    3067. 

  3067. C  ---------------------- NCV - SECOND DIM COORD OR VALUE
    3068. 

  3068. C            BYTE 21
    3069. 

  3069.           CALL GBYTEC (MSGA,NCV,KPTR(8),8)
    3070. 

  3070.           KPTR(8)  = KPTR(8) + 8
    3071. 

  3071. C  ---------------------- NC2 - NR COEFF'S OR VALS
    3072. 

  3072. C            BYTE 22
    3073. 

  3073.           CALL GBYTEC (MSGA,NC2,KPTR(8),8)
    3074. 

  3074.           KPTR(8)  = KPTR(8) + 8
    3075. 

  3075. C  ---------------------- KPHYS1 - FIRST DIM PHYSICAL SIGNIF
    3076. 

  3076. C            BYTE 23
    3077. 

  3077.           CALL GBYTEC (MSGA,KPHYS1,KPTR(8),8)
    3078. 

  3078.           KPTR(8)  = KPTR(8) + 8
    3079. 

  3079. C  ---------------------- KPHYS2 - SECOND DIM PHYSICAL SIGNIF
    3080. 

  3080. C            BYTE 24
    3081. 

  3081.           CALL GBYTEC (MSGA,KPHYS2,KPTR(8),8)
    3082. 

  3082.           KPTR(8)  = KPTR(8) + 8
    3083. 

  3083. C            BYTES 25-N
    3084. 

  3084.       END IF
    3085. 

  3085.       IF (KBITS.EQ.0) THEN
    3086. 

  3086. C                       HAVE NO BDS ENTRIES, ALL ENTRIES = REFNCE
    3087. 

  3087.           SCAL10  = 10.0 ** KPDS(22)
    3088. 

  3088.           SCAL10  = 1.0 / SCAL10
    3089. 

  3089.           REFN10  = REFNCE * SCAL10
    3090. 

  3090.           KENTRY = KPTR(10)
    3091. 

  3091.           DO 210 I = 1, KENTRY
    3092. 

  3092.               DATA(I) = 0.0
    3093. 

  3093.               IF (KBMS(I)) THEN
    3094. 

  3094.                    DATA(I) = REFN10
    3095. 

  3095.               END IF
    3096. 

  3096.   210     CONTINUE
    3097. 

  3097.           GO TO 900
    3098. 

  3098.       END IF
    3099. 

  3099. C     PRINT *,'KEND ',KEND,' KPTR(8) ',KPTR(8),'KBITS ',KBITS
    3100. 

  3100.       KNR     = (KEND - KPTR(8)) / KBITS
    3101. 

  3101. C     PRINT *,'NUMBER OF ENTRIES IN DATA ARRAY',KNR
    3102. 

  3102. C  --------------------
    3103. 

  3103. C       CYCLE THRU BDS UNTIL HAVE USED ALL (SPECIFIED NUMBER)
    3104. 

  3104. C       ENTRIES.
    3105. 

  3105. C  ------------- UNUSED BITS IN DATA AREA
    3106. 

  3106. C NUMBER OF BYTES IN DATA AREA
    3107. 

  3107.       NRBYTE  = KPTR(6) - 11
    3108. 

  3108. C  ------------- TOTAL NR OF USABLE BITS
    3109. 

  3109.       NRBITS  = NRBYTE * 8  - KPTR(15)
    3110. 

  3110. C  ------------- TOTAL NR OF ENTRIES
    3111. 

  3111.       KENTRY = NRBITS / KBITS
    3112. 

  3112. C                             ALLOCATE KSAVE
    3113. 

  3113.       ALLOCATE(KSAVE(KENTRY))
    3114. 

  3114. C
    3115. 

  3115. C     IF (IAND(KPTR(14),2).EQ.0) THEN
    3116. 

  3116. C        PRINT *,'SOURCE VALUES IN FLOATING POINT'
    3117. 

  3117. C     ELSE
    3118. 

  3118. C        PRINT *,'SOURCE VALUES IN INTEGER'
    3119. 

  3119. C     END IF
    3120. 

  3120. C
    3121. 

  3121.       IF (IAND(KPTR(14),8).EQ.0) THEN
    3122. 

  3122. C        PRINT *,'PROCESSING GRID POINT DATA'
    3123. 

  3123.          IF (IAND(KPTR(14),4).EQ.0) THEN
    3124. 

  3124. C            PRINT *,'    WITH SIMPLE PACKING'
    3125. 

  3125.              IF (IAND(KPTR(14),1).EQ.0) THEN
    3126. 

  3126. C                PRINT *,'        WITH NO ADDITIONAL FLAGS'
    3127. 

  3127.                  GO TO 4000
    3128. 

  3128.              ELSE IF (IAND(KPTR(14),1).NE.0) THEN
    3129. 

  3129. C                PRINT *,'        WITH ADDITIONAL FLAGS',KXFLAG
    3130. 

  3130.                  IF (KBDS(17).EQ.0) THEN
    3131. 

  3131. C                    PRINT *,'            SINGLE DATUM EACH GRID PT'
    3132. 

  3132.                      IF (KBDS(14).EQ.0) THEN
    3133. 

  3133. C                        PRINT *,'            NO SEC BIT MAP'
    3134. 

  3134.                          IF (KBDS(16).EQ.0) THEN
    3135. 

  3135. C                            PRINT *,'            SECOND ORDER',
    3136. 

  3136. C    *                          ' VALUES CONSTANT WIDTH'
    3137. 

  3137.                          ELSE IF (KBDS(16).NE.0) THEN
    3138. 

  3138. C                            PRINT *,'            SECOND ORDER',
    3139. 

  3139. C    *                            ' VALUES DIFFERENT WIDTHS'
    3140. 

  3140.                          END IF
    3141. 

  3141.                      ELSE IF (KBDS(14).NE.0) THEN
    3142. 

  3142. C                        PRINT *,'            SEC BIT MAP'
    3143. 

  3143.                          IF (KBDS(16).EQ.0) THEN
    3144. 

  3144. C                             PRINT *,'            SECOND ORDER',
    3145. 

  3145. C    *                              ' VALUES CONSTANT WIDTH'
    3146. 

  3146.                          ELSE IF (KBDS(16).NE.0) THEN
    3147. 

  3147. C                            PRINT *,'            SECOND ORDER',
    3148. 

  3148. C    *                             ' VALUES DIFFERENT WIDTHS'
    3149. 

  3149.                          END IF
    3150. 

  3150.                      END IF
    3151. 

  3151.                  ELSE IF (KBDS(17).NE.0) THEN
    3152. 

  3152. C                    PRINT *,'            MATRIX OF VALS EACH PT'
    3153. 

  3153.                      IF (KBDS(14).EQ.0) THEN
    3154. 

  3154. C                        PRINT *,'            NO SEC BIT MAP'
    3155. 

  3155.                          IF (KBDS(16).EQ.0) THEN
    3156. 

  3156. C                            PRINT *,'            SECOND ORDER',
    3157. 

  3157. C    *                          ' VALUES CONSTANT WIDTH'
    3158. 

  3158.                          ELSE IF (KBDS(16).NE.0) THEN
    3159. 

  3159. C                            PRINT *,'            SECOND ORDER',
    3160. 

  3160. C    *                              ' VALUES DIFFERENT WIDTHS'
    3161. 

  3161.                          END IF
    3162. 

  3162.                      ELSE IF (KBDS(14).NE.0) THEN
    3163. 

  3163. C                        PRINT *,'            SEC BIT MAP'
    3164. 

  3164.                          IF (KBDS(16).EQ.0) THEN
    3165. 

  3165. C                            PRINT *,'            SECOND ORDER',
    3166. 

  3166. C    *                             ' VALUES CONSTANT WIDTH'
    3167. 

  3167.                          ELSE IF (KBDS(16).NE.0) THEN
    3168. 

  3168. C                            PRINT *,'            SECOND ORDER',
    3169. 

  3169. C    *                              ' VALUES DIFFERENT WIDTHS'
    3170. 

  3170.                          END IF
    3171. 

  3171.                      END IF
    3172. 

  3172.                  END IF
    3173. 

  3173.              END IF
    3174. 

  3174.          ELSE IF (IAND(KPTR(14),4).NE.0) THEN
    3175. 

  3175. C            PRINT *,'    WITH COMPLEX/SECOND ORDER PACKING'
    3176. 

  3176.              IF (IAND(KPTR(14),1).EQ.0) THEN
    3177. 

  3177. C                    PRINT *,'        WITH NO ADDITIONAL FLAGS'
    3178. 

  3178.              ELSE IF (IAND(KPTR(14),1).NE.0) THEN
    3179. 

  3179. C                PRINT *,'        WITH ADDITIONAL FLAGS'
    3180. 

  3180.                  IF (KBDS(17).EQ.0) THEN
    3181. 

  3181. C                    PRINT *,'            SINGLE DATUM AT EACH PT'
    3182. 

  3182.                      IF (KBDS(14).EQ.0) THEN
    3183. 

  3183. C                            PRINT *,'            NO SEC BIT MAP'
    3184. 

  3184.                          IF (KBDS(16).EQ.0) THEN
    3185. 

  3185. C                            PRINT *,'            SECOND ORDER',
    3186. 

  3186. C    *                             ' VALUES CONSTANT WIDTH'
    3187. 

  3187.                          ELSE IF (KBDS(16).NE.0) THEN
    3188. 

  3188. C                            PRINT *,'            SECOND ORDER',
    3189. 

  3189. C    *                              ' VALUES DIFFERENT WIDTHS'
    3190. 

  3190.                          END IF
    3191. 

  3191. C                                       ROW BY ROW - COL BY COL
    3192. 

  3192.                          CALL FI636 (DATA,MSGA,KBMS,
    3193. 

  3193.      *                                         REFNCE,KPTR,KPDS,KGDS)
    3194. 

  3194.                          GO TO 900
    3195. 

  3195.                      ELSE IF (KBDS(14).NE.0) THEN
    3196. 

  3196. C                        PRINT *,'            SEC BIT MAP'
    3197. 

  3197.                          IF (KBDS(16).EQ.0) THEN
    3198. 

  3198. C                                PRINT *,'            SECOND ORDER',
    3199. 

  3199. C    *                              ' VALUES CONSTANT WIDTH'
    3200. 

  3200.                          ELSE IF (KBDS(16).NE.0) THEN
    3201. 

  3201. C                                PRINT *,'            SECOND ORDER',
    3202. 

  3202. C    *                              ' VALUES DIFFERENT WIDTHS'
    3203. 

  3203.                          END IF
    3204. 

  3204.                          CALL FI636 (DATA,MSGA,KBMS,
    3205. 

  3205.      *                                         REFNCE,KPTR,KPDS,KGDS)
    3206. 

  3206.                          GO TO 900
    3207. 

  3207.                      END IF
    3208. 

  3208.                  ELSE IF (KBDS(17).NE.0) THEN
    3209. 

  3209. C                    PRINT *,'            MATRIX OF VALS EACH PT'
    3210. 

  3210.                      IF (KBDS(14).EQ.0) THEN
    3211. 

  3211. C                        PRINT *,'            NO SEC BIT MAP'
    3212. 

  3212.                          IF (KBDS(16).EQ.0) THEN
    3213. 

  3213. C                              PRINT *,'            SECOND ORDER',
    3214. 

  3214. C    *                              ' VALUES CONSTANT WIDTH'
    3215. 

  3215.                          ELSE IF (KBDS(16).NE.0) THEN
    3216. 

  3216. C                            PRINT *,'            SECOND ORDER',
    3217. 

  3217. C    *                              ' VALUES DIFFERENT WIDTHS'
    3218. 

  3218.                          END IF
    3219. 

  3219.                      ELSE IF (KBDS(14).NE.0) THEN
    3220. 

  3220. C                        PRINT *,'            SEC BIT MAP'
    3221. 

  3221.                          IF (KBDS(16).EQ.0) THEN
    3222. 

  3222. C                              PRINT *,'            SECOND ORDER',
    3223. 

  3223. C    *                              ' VALUES CONSTANT WIDTH'
    3224. 

  3224.                          ELSE IF (KBDS(16).NE.0) THEN
    3225. 

  3225. C                                PRINT *,'            SECOND ORDER',
    3226. 

  3226. C    *                              ' VALUES DIFFERENT WIDTHS'
    3227. 

  3227.                          END IF
    3228. 

  3228.                      END IF
    3229. 

  3229.                  END IF
    3230. 

  3230.              END IF
    3231. 

  3231.          END IF
    3232. 

  3232.       ELSE IF (IAND(KPTR(14),8).NE.0) THEN
    3233. 

  3233. C        PRINT *,'PROCESSING SPHERICAL HARMONIC COEFFICIENTS'
    3234. 

  3234.          IF (IAND(KPTR(14),4).EQ.0) THEN
    3235. 

  3235. C            PRINT *,'    WITH SIMPLE PACKING'
    3236. 

  3236.              IF (IAND(KPTR(14),1).EQ.0) THEN
    3237. 

  3237. C                PRINT *,'        WITH NO ADDITIONAL FLAGS'
    3238. 

  3238.                  GO TO 5000
    3239. 

  3239.              ELSE IF (IAND(KPTR(14),1).NE.0) THEN
    3240. 

  3240. C                PRINT *,'        WITH ADDITIONAL FLAGS'
    3241. 

  3241.                  IF (KBDS(17).EQ.0) THEN
    3242. 

  3242. C                    PRINT *,'            SINGLE DATUM EACH GRID PT'
    3243. 

  3243.                      IF (KBDS(14).EQ.0) THEN
    3244. 

  3244. C                        PRINT *,'            NO SEC BIT MAP'
    3245. 

  3245.                          IF (KBDS(16).EQ.0) THEN
    3246. 

  3246. C                            PRINT *,'            SECOND ORDER',
    3247. 

  3247. C    *                              ' VALUES CONSTANT WIDTH'
    3248. 

  3248.                          ELSE IF (KBDS(16).NE.0) THEN
    3249. 

  3249. C                            PRINT *,'            SECOND ORDER',
    3250. 

  3250. C    *                              ' VALUES DIFFERENT WIDTHS'
    3251. 

  3251.                          END IF
    3252. 

  3252.                      ELSE IF (KBDS(14).NE.0) THEN
    3253. 

  3253. C                        PRINT *,'            SEC BIT MAP'
    3254. 

  3254.                          IF (KBDS(16).EQ.0) THEN
    3255. 

  3255. C                            PRINT *,'            SECOND ORDER',
    3256. 

  3256. C    *                              ' VALUES CONSTANT WIDTH'
    3257. 

  3257.                          ELSE IF (KBDS(16).NE.0) THEN
    3258. 

  3258. C                            PRINT *,'            SECOND ORDER',
    3259. 

  3259. C    *                            ' VALUES DIFFERENT WIDTHS'
    3260. 

  3260.                          END IF
    3261. 

  3261.                      END IF
    3262. 

  3262.                  ELSE IF (KBDS(17).NE.0) THEN
    3263. 

  3263. C                    PRINT *,'            MATRIX OF VALS EACH PT'
    3264. 

  3264.                      IF (KBDS(14).EQ.0) THEN
    3265. 

  3265. C                        PRINT *,'            NO SEC BIT MAP'
    3266. 

  3266.                          IF (KBDS(16).EQ.0) THEN
    3267. 

  3267. C                            PRINT *,'            SECOND ORDER',
    3268. 

  3268. C    *                              ' VALUES CONSTANT WIDTH'
    3269. 

  3269.                          ELSE IF (KBDS(16).NE.0) THEN
    3270. 

  3270. C                            PRINT *,'            SECOND ORDER',
    3271. 

  3271. C    *                             ' VALUES DIFFERENT WIDTHS'
    3272. 

  3272.                          END IF
    3273. 

  3273.                      ELSE IF (KBDS(14).NE.0) THEN
    3274. 

  3274. C                        PRINT *,'            SEC BIT MAP'
    3275. 

  3275.                          IF (KBDS(16).EQ.0) THEN
    3276. 

  3276. C                            PRINT *,'            SECOND ORDER',
    3277. 

  3277. C    *                              ' VALUES CONSTANT WIDTH'
    3278. 

  3278.                          ELSE IF (KBDS(16).NE.0) THEN
    3279. 

  3279. C                            PRINT *,'            SECOND ORDER',
    3280. 

  3280. C    *                             ' VALUES DIFFERENT WIDTHS'
    3281. 

  3281.                          END IF
    3282. 

  3282.                      END IF
    3283. 

  3283.                  END IF
    3284. 

  3284.              END IF
    3285. 

  3285.          ELSE IF (IAND(KPTR(14),4).NE.0) THEN
    3286. 

  3286. C                                  COMPLEX/SECOND ORDER PACKING
    3287. 

  3287. C            PRINT *,'    WITH COMPLEX/SECOND ORDER PACKING'
    3288. 

  3288.              IF (IAND(KPTR(14),1).EQ.0) THEN
    3289. 

  3289. C                PRINT *,'        WITH NO ADDITIONAL FLAGS'
    3290. 

  3290.              ELSE IF (IAND(KPTR(14),1).NE.0) THEN
    3291. 

  3291. C                PRINT *,'        WITH ADDITIONAL FLAGS'
    3292. 

  3292.                  IF (KBDS(17).EQ.0) THEN
    3293. 

  3293. C                    PRINT *,'            SINGLE DATUM EACH GRID PT'
    3294. 

  3294.                      IF (KBDS(14).EQ.0) THEN
    3295. 

  3295. C                        PRINT *,'            NO SEC BIT MAP'
    3296. 

  3296.                          IF (KBDS(16).EQ.0) THEN
    3297. 

  3297. C                            PRINT *,'            SECOND ORDER',
    3298. 

  3298. C    *                             ' VALUES CONSTANT WIDTH'
    3299. 

  3299.                          ELSE IF (KBDS(16).NE.0) THEN
    3300. 

  3300. C                            PRINT *,'            SECOND ORDER',
    3301. 

  3301. C    *                              ' VALUES DIFFERENT WIDTHS'
    3302. 

  3302.                          END IF
    3303. 

  3303.                      ELSE IF (KBDS(14).NE.0) THEN
    3304. 

  3304. C                        PRINT *,'            SEC BIT MAP'
    3305. 

  3305.                          IF (KBDS(16).EQ.0) THEN
    3306. 

  3306. C                            PRINT *,'            SECOND ORDER',
    3307. 

  3307. C    *                              ' VALUES CONSTANT WIDTH'
    3308. 

  3308.                          ELSE IF (KBDS(16).NE.0) THEN
    3309. 

  3309. C                            PRINT *,'            SECOND ORDER',
    3310. 

  3310. C    *                              ' VALUES DIFFERENT WIDTHS'
    3311. 

  3311.                          END IF
    3312. 

  3312.                      END IF
    3313. 

  3313.                  ELSE IF (KBDS(17).NE.0) THEN
    3314. 

  3314. C                    PRINT *,'            MATRIX OF VALS EACH PT'
    3315. 

  3315.                      IF (KBDS(14).EQ.0) THEN
    3316. 

  3316. C                        PRINT *,'            NO SEC BIT MAP'
    3317. 

  3317.                          IF (KBDS(16).EQ.0) THEN
    3318. 

  3318. C                            PRINT *,'            SECOND ORDER',
    3319. 

  3319. C    *                            ' VALUES CONSTANT WIDTH'
    3320. 

  3320.                          ELSE IF (KBDS(16).NE.0) THEN
    3321. 

  3321. C                            PRINT *,'            SECOND ORDER',
    3322. 

  3322. C    *                              ' VALUES DIFFERENT WIDTHS'
    3323. 

  3323.                          END IF
    3324. 

  3324.                      ELSE IF (KBDS(14).NE.0) THEN
    3325. 

  3325. C                        PRINT *,'            SEC BIT MAP'
    3326. 

  3326.                          IF (KBDS(16).EQ.0) THEN
    3327. 

  3327. C                            PRINT *,'            SECOND ORDER',
    3328. 

  3328. C    *                              ' VALUES CONSTANT WIDTH'
    3329. 

  3329.                          ELSE IF (KBDS(16).NE.0) THEN
    3330. 

  3330. C                            PRINT *,'            SECOND ORDER',
    3331. 

  3331. C    *                              ' VALUES DIFFERENT WIDTHS'
    3332. 

  3332.                          END IF
    3333. 

  3333.                      END IF
    3334. 

  3334.                  END IF
    3335. 

  3335.              END IF
    3336. 

  3336.          END IF
    3337. 

  3337.       END IF
    3338. 

  3338.       IF(ALLOCATED(KSAVE)) DEALLOCATE(KSAVE)
    3339. 

  3339. C     PRINT *,' NOT PROCESSED - NOT PROCESSED - NOT PROCESSED'
    3340. 

  3340.       KRET   = 11
    3341. 

  3341.       RETURN
    3342. 

  3342.  4000 CONTINUE
    3343. 

  3343. C  ****************************************************************
    3344. 

  3344. C
    3345. 

  3345. C GRID POINT DATA, SIMPLE PACKING, FLOATING POINT, NO ADDN'L FLAGS
    3346. 

  3346. C
    3347. 

  3347.       SCAL10  = 10.0 ** KPDS(22)
    3348. 

  3348.       SCAL10  = 1.0 / SCAL10
    3349. 

  3349.       IF (KPDS(3).EQ.23.OR.KPDS(3).EQ.24.OR.KPDS(3).EQ.26.
    3350. 

  3350.      *            OR.KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN
    3351. 

  3351.           IF (KPDS(3).EQ.26) THEN
    3352. 

  3352.               KADD    = 72
    3353. 

  3353.           ELSE IF (KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN
    3354. 

  3354.               KADD    = 91
    3355. 

  3355.           ELSE
    3356. 

  3356.               KADD    = 37
    3357. 

  3357.           END IF
    3358. 

  3358.           CALL GBYTESC (MSGA,KSAVE,KPTR(8),KBITS,0,KNR)
    3359. 

  3359.           KPTR(8)   = KPTR(8) + KBITS * KNR
    3360. 

  3360.           II        = 1
    3361. 

  3361.           KENTRY    = KPTR(10)
    3362. 

  3362.           DO 4001 I = 1, KENTRY
    3363. 

  3363.               IF (KBMS(I)) THEN
    3364. 

  3364.                   DATA(I)   = (REFNCE+FLOAT(KSAVE(II))*SCALE)*SCAL10
    3365. 

  3365.                   II        = II + 1
    3366. 

  3366.               ELSE
    3367. 

  3367.                   DATA(I)   = 0.0
    3368. 

  3368.               END IF
    3369. 

  3369.  4001     CONTINUE
    3370. 

  3370.           DO 4002 I = 2, KADD
    3371. 

  3371.               DATA(I)   = DATA(1)
    3372. 

  3372.  4002     CONTINUE
    3373. 

  3373.       ELSE IF (KPDS(3).EQ.21.OR.KPDS(3).EQ.22.OR.KPDS(3).EQ.25.
    3374. 

  3374.      *            OR.KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN
    3375. 

  3375.           CALL GBYTESC (MSGA,KSAVE,KPTR(8),KBITS,0,KNR)
    3376. 

  3376.           II    = 1
    3377. 

  3377.           KENTRY = KPTR(10)
    3378. 

  3378.           DO 4011 I = 1, KENTRY
    3379. 

  3379.               IF (KBMS(I)) THEN
    3380. 

  3380.                   DATA(I) = (REFNCE + FLOAT(KSAVE(II)) * SCALE) * SCAL10
    3381. 

  3381.                   II  = II + 1
    3382. 

  3382.               ELSE
    3383. 

  3383.                   DATA(I) = 0.0
    3384. 

  3384.               END IF
    3385. 

  3385.  4011     CONTINUE
    3386. 

  3386.           IF (KPDS(3).EQ.25) THEN
    3387. 

  3387.               KADD    = 71
    3388. 

  3388.           ELSE IF (KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN
    3389. 

  3389.               KADD    = 90
    3390. 

  3390.           ELSE
    3391. 

  3391.               KADD    = 36
    3392. 

  3392.           END IF
    3393. 

  3393.           LASTP   = KENTRY - KADD
    3394. 

  3394.           DO 4012 I = LASTP+1, KENTRY
    3395. 

  3395.               DATA(I) = DATA(LASTP)
    3396. 

  3396.  4012     CONTINUE
    3397. 

  3397.       ELSE
    3398. 

  3398.           CALL GBYTESC (MSGA,KSAVE,KPTR(8),KBITS,0,KNR)
    3399. 

  3399.           II    = 1
    3400. 

  3400.           KENTRY = KPTR(10)
    3401. 

  3401.           DO 500 I = 1, KENTRY
    3402. 

  3402.               IF (KBMS(I)) THEN
    3403. 

  3403.                   DATA(I) = (REFNCE + FLOAT(KSAVE(II)) * SCALE) * SCAL10
    3404. 

  3404.                   II  = II + 1
    3405. 

  3405.               ELSE
    3406. 

  3406.                   DATA(I) = 0.0
    3407. 

  3407.               END IF
    3408. 

  3408.   500     CONTINUE
    3409. 

  3409.       END IF
    3410. 

  3410.       GO TO 900
    3411. 

  3411. C  ------------- PROCESS SPHERICAL HARMONIC COEFFICIENTS,
    3412. 

  3412. C               SIMPLE PACKING, FLOATING POINT, NO ADDN'L FLAGS
    3413. 

  3413.  5000 CONTINUE
    3414. 

  3414. C     PRINT *,'CHECK POINT SPECTRAL COEFF'
    3415. 

  3415.       KPTR(8)  = IBYT12
    3416. 

  3416. C      CALL GBYTE (MSGA,KKK,KPTR(8),32)
    3417. 

  3417.       call gbytec(MSGA,JSGN,KPTR(8),1)
    3418. 

  3418.       call gbytec(MSGA,JEXP,KPTR(8)+1,7)
    3419. 

  3419.       call gbytec(MSGA,IFR,KPTR(8)+8,24)
    3420. 

  3420.       KPTR(8)  = KPTR(8) + 32
    3421. 

  3421. C
    3422. 

  3422. C     THE NEXT CODE WILL CONVERT THE IBM370 FOATING POINT
    3423. 

  3423. C     TO THE FLOATING POINT USED ON YOUR MACHINE.
    3424. 

  3424. C
    3425. 

  3425.       IF (IFR.EQ.0) THEN
    3426. 

  3426.           REALKK  = 0.0
    3427. 

  3427.       ELSE IF (JEXP.EQ.0.AND.IFR.EQ.0) THEN
    3428. 

  3428.           REALKK  = 0.0
    3429. 

  3429.       ELSE
    3430. 

  3430.           REALKK  = FLOAT(IFR) * 16.0 ** (JEXP - 64 - 6)
    3431. 

  3431.           IF (JSGN.NE.0) REALKK  = -REALKK
    3432. 

  3432.       END IF
    3433. 

  3433.       DATA(1)  = REALKK
    3434. 

  3434.       CALL GBYTESC (MSGA,KSAVE,KPTR(8),KBITS,0,KNR)
    3435. 

  3435. C  --------------
    3436. 

  3436.       DO 6000 I = 1, KENTRY
    3437. 

  3437.           DATA(I+1)  = REFNCE + FLOAT(KSAVE(I)) * SCALE
    3438. 

  3438.  6000 CONTINUE
    3439. 

  3439.   900 CONTINUE
    3440. 

  3440.       IF(ALLOCATED(KSAVE)) DEALLOCATE(KSAVE)
    3441. 

  3441. C     PRINT *,'EXIT FI635'
    3442. 

  3442.       RETURN
    3443. 

  3443.       END
    3444. 

  3444.       SUBROUTINE FI636 (DATA,MSGA,KBMS,REFNCE,KPTR,KPDS,KGDS)
    3445. 

  3445. C$$$  SUBPROGRAM DOCUMENTATION BLOCK
    3446. 

  3446. C                .      .    .                                       .
    3447. 

  3447. C SUBPROGRAM:    FI636       PROCESS SECOND ORDER PACKING
    3448. 

  3448. C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 92-09-22
    3449. 

  3449. C
    3450. 

  3450. C ABSTRACT: PROCESS SECOND ORDER PACKING FROM THE BINARY DATA SECTION
    3451. 

  3451. C   (BDS) FOR SINGLE DATA ITEMS GRID POINT DATA
    3452. 

  3452. C
    3453. 

  3453. C PROGRAM HISTORY LOG:
    3454. 

  3454. C   93-06-08  CAVANAUGH
    3455. 

  3455. C   93-12-15  CAVANAUGH   MODIFIED SECOND ORDER POINTERS TO FIRST ORDER
    3456. 

  3456. C                         VALUES AND SECOND ORDER VALUES CORRECTLY.
    3457. 

  3457. C   95-04-26  R.E.JONES   FI636 CORECTION FOR 2ND ORDER COMPLEX
    3458. 

  3458. C                         UNPACKING.
    3459. 

  3459. C   95-10-31  IREDELL     REMOVED SAVES AND PRINTS
    3460. 

  3460. C
    3461. 

  3461. C USAGE:    CALL FI636 (DATA,MSGA,KBMS,REFNCE,KPTR,KPDS,KGDS)
    3462. 

  3462. C   INPUT ARGUMENT LIST:
    3463. 

  3463. C
    3464. 

  3464. C     MSGA     - ARRAY CONTAINING GRIB MESSAGE
    3465. 

  3465. C     REFNCE   - REFERENCE VALUE
    3466. 

  3466. C     KPTR     - WORK ARRAY
    3467. 

  3467. C
    3468. 

  3468. C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
    3469. 

  3469. C     DATA     - LOCATION OF OUTPUT ARRAY
    3470. 

  3470. C              WORKING ARRAY
    3471. 

  3471. C     KBDS(1)  - N1
    3472. 

  3472. C     KBDS(2)  - N2
    3473. 

  3473. C     KBDS(3)  - P1
    3474. 

  3474. C     KBDS(4)  - P2
    3475. 

  3475. C     KBDS(5)  - BIT POINTER TO 2ND ORDER WIDTHS
    3476. 

  3476. C     KBDS(6)  -  "    "     "   "   "    BIT MAPS
    3477. 

  3477. C     KBDS(7)  -  "    "     "  FIRST ORDER VALUES
    3478. 

  3478. C     KBDS(8)  -  "    "     "  SECOND ORDER VALUES
    3479. 

  3479. C     KBDS(9)  -  "    "     START OF BDS
    3480. 

  3480. C     KBDS(10) -  "    "     MAIN BIT MAP
    3481. 

  3481. C     KBDS(11) - BINARY SCALING
    3482. 

  3482. C     KBDS(12) - DECIMAL SCALING
    3483. 

  3483. C     KBDS(13) - BIT WIDTH OF FIRST ORDER VALUES
    3484. 

  3484. C     KBDS(14) - BIT MAP FLAG
    3485. 

  3485. C                 0 = NO SECOND ORDER BIT MAP
    3486. 

  3486. C                 1 = SECOND ORDER BIT MAP PRESENT
    3487. 

  3487. C     KBDS(15) - SECOND ORDER BIT WIDTH
    3488. 

  3488. C     KBDS(16) - CONSTANT / DIFFERENT WIDTHS
    3489. 

  3489. C                 0 = CONSTANT WIDTHS
    3490. 

  3490. C                 1 = DIFFERENT WIDTHS
    3491. 

  3491. C     KBDS(17) - SINGLE DATUM / MATRIX
    3492. 

  3492. C                 0 = SINGLE DATUM AT EACH GRID POINT
    3493. 

  3493. C                 1 = MATRIX OF VALUES AT EACH GRID POINT
    3494. 

  3494. C       (18-20)- UNUSED
    3495. 

  3495. C
    3496. 

  3496. C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
    3497. 

  3497. C
    3498. 

  3498. C ATTRIBUTES:
    3499. 

  3499. C   LANGUAGE: FORTRAN 77
    3500. 

  3500. C   MACHINE:  HDS, CRAY
    3501. 

  3501. C
    3502. 

  3502. C$$$
    3503. 

  3503.       REAL         DATA(*)
    3504. 

  3504.       REAL         REFN
    3505. 

  3505.       REAL         REFNCE
    3506. 

  3506. C
    3507. 

  3507.       INTEGER      KBDS(20)
    3508. 

  3508.       INTEGER      KPTR(*)
    3509. 

  3509.       character(len=1)      BMAP2(1000000)
    3510. 

  3510.       INTEGER      I,IBDS
    3511. 

  3511.       INTEGER      KBIT,IFOVAL,ISOVAL
    3512. 

  3512.       INTEGER      KPDS(*),KGDS(*)
    3513. 

  3513. C
    3514. 

  3514.       LOGICAL*1    KBMS(*)
    3515. 

  3515. C
    3516. 

  3516.       CHARACTER*1  MSGA(*)
    3517. 

  3517. C
    3518. 

  3518. C  *******************     SETUP     ******************************
    3519. 

  3519. C     PRINT *,'ENTER FI636'
    3520. 

  3520. C                                START OF BMS (BIT POINTER)
    3521. 

  3521.       DO I = 1,20
    3522. 

  3522.         KBDS(I)  = 0
    3523. 

  3523.       END DO
    3524. 

  3524. C                BYTE START OF BDS
    3525. 

  3525.       IBDS  = KPTR(2) + KPTR(3) + KPTR(4) + KPTR(5)
    3526. 

  3526. C     PRINT *,'KPTR(2-5) ',KPTR(2),KPTR(3),KPTR(4),KPTR(5)
    3527. 

  3527. C                BIT START OF BDS
    3528. 

  3528.       JPTR  = IBDS * 8
    3529. 

  3529. C     PRINT *,'JPTR ',JPTR
    3530. 

  3530.       KBDS(9) = JPTR
    3531. 

  3531. C     PRINT *,'START OF BDS         ',KBDS(9)
    3532. 

  3532. C                    BINARY SCALE VALUE  BDS BYTES 5-6
    3533. 

  3533.       CALL GBYTEC (MSGA,ISIGN,JPTR+32,1)
    3534. 

  3534.       CALL GBYTEC (MSGA,KBDS(11),JPTR+33,15)
    3535. 

  3535.       IF (ISIGN.GT.0) THEN
    3536. 

  3536.           KBDS(11)  = - KBDS(11)
    3537. 

  3537.       END IF
    3538. 

  3538. C     PRINT *,'BINARY SCALE VALUE =',KBDS(11)
    3539. 

  3539. C                  EXTRACT REFERENCE VALUE
    3540. 

  3540. C      CALL GBYTEC(MSGA,JREF,JPTR+48,32)
    3541. 

  3541.       call gbytec(MSGA,JSGN,KPTR(8),1)
    3542. 

  3542.       call gbytec(MSGA,JEXP,KPTR(8)+1,7)
    3543. 

  3543.       call gbytec(MSGA,IFR,KPTR(8)+8,24)
    3544. 

  3544.       IF (IFR.EQ.0) THEN
    3545. 

  3545.           REFNCE  = 0.0
    3546. 

  3546.       ELSE IF (JEXP.EQ.0.AND.IFR.EQ.0) THEN
    3547. 

  3547.           REFNCE  = 0.0
    3548. 

  3548.       ELSE
    3549. 

  3549.           REFNCE  = FLOAT(IFR) * 16.0 ** (JEXP - 64 - 6)
    3550. 

  3550.           IF (JSGN.NE.0) REFNCE = - REFNCE
    3551. 

  3551.       END IF
    3552. 

  3552. C     PRINT *,'DECODED REFERENCE VALUE =',REFN,REFNCE
    3553. 

  3553. C                F O BIT WIDTH
    3554. 

  3554.       CALL GBYTEC(MSGA,KBDS(13),JPTR+80,8)
    3555. 

  3555.       JPTR  = JPTR + 88
    3556. 

  3556. C              AT START OF BDS BYTE 12
    3557. 

  3557. C                EXTRACT N1
    3558. 

  3558.       CALL GBYTEC (MSGA,KBDS(1),JPTR,16)
    3559. 

  3559. C     PRINT *,'N1  = ',KBDS(1)
    3560. 

  3560.       JPTR  = JPTR + 16
    3561. 

  3561. C                 EXTENDED FLAGS
    3562. 

  3562.       CALL GBYTEC (MSGA,KFLAG,JPTR,8)
    3563. 

  3563. C                 ISOLATE BIT MAP FLAG
    3564. 

  3564.       IF (IAND(KFLAG,32).NE.0) THEN
    3565. 

  3565.         KBDS(14)  = 1
    3566. 

  3566.       ELSE
    3567. 

  3567.         KBDS(14)  = 0
    3568. 

  3568.       END IF
    3569. 

  3569.       IF (IAND(KFLAG,16).NE.0) THEN
    3570. 

  3570.         KBDS(16)  = 1
    3571. 

  3571.       ELSE
    3572. 

  3572.         KBDS(16)  = 0
    3573. 

  3573.       END IF
    3574. 

  3574.       IF (IAND(KFLAG,64).NE.0) THEN
    3575. 

  3575.         KBDS(17)  = 1
    3576. 

  3576.       ELSE
    3577. 

  3577.         KBDS(17)  = 0
    3578. 

  3578.       END IF
    3579. 

  3579.       JPTR  = JPTR + 8
    3580. 

  3580. C                EXTRACT N2
    3581. 

  3581.       CALL GBYTEC (MSGA,KBDS(2),JPTR,16)
    3582. 

  3582. C     PRINT *,'N2  = ',KBDS(2)
    3583. 

  3583.       JPTR  = JPTR + 16
    3584. 

  3584. C                EXTRACT P1
    3585. 

  3585.       CALL GBYTEC (MSGA,KBDS(3),JPTR,16)
    3586. 

  3586. C     PRINT *,'P1  = ',KBDS(3)
    3587. 

  3587.       JPTR  = JPTR + 16
    3588. 

  3588. C                EXTRACT P2
    3589. 

  3589.       CALL GBYTEC (MSGA,KBDS(4),JPTR,16)
    3590. 

  3590. C     PRINT *,'P2  = ',KBDS(4)
    3591. 

  3591.       JPTR  = JPTR + 16
    3592. 

  3592. C                 SKIP RESERVED BYTE
    3593. 

  3593.       JPTR    = JPTR + 8
    3594. 

  3594. C                START OF SECOND ORDER BIT WIDTHS
    3595. 

  3595.       KBDS(5) = JPTR
    3596. 

  3596. C                COMPUTE START OF SECONDARY BIT MAP
    3597. 

  3597.       IF (KBDS(14).NE.0) THEN
    3598. 

  3598. C                           FOR INCLUDED SECONDARY BIT MAP
    3599. 

  3599.           JPTR    = JPTR + (KBDS(3) * 8)
    3600. 

  3600.           KBDS(6) = JPTR
    3601. 

  3601.       ELSE
    3602. 

  3602. C                           FOR CONSTRUCTED SECONDARY BIT MAP
    3603. 

  3603.           KBDS(6)  = 0
    3604. 

  3604.       END IF
    3605. 

  3605. C                CREATE POINTER TO START OF FIRST ORDER VALUES
    3606. 

  3606.       KBDS(7) =  KBDS(9) + KBDS(1) * 8 - 8
    3607. 

  3607. C     PRINT *,'BIT POINTER TO START OF FOVALS',KBDS(7)
    3608. 

  3608. C                CREATE POINTER TO START OF SECOND ORDER VALUES
    3609. 

  3609.       KBDS(8) =  KBDS(9) + KBDS(2) * 8 - 8
    3610. 

  3610. C     PRINT *,'BIT POINTER TO START OF SOVALS',KBDS(8)
    3611. 

  3611. C     PRINT *,'KBDS( 1) - N1                         ',KBDS( 1)
    3612. 

  3612. C     PRINT *,'KBDS( 2) - N2                         ',KBDS( 2)
    3613. 

  3613. C     PRINT *,'KBDS( 3) - P1                         ',KBDS( 3)
    3614. 

  3614. C     PRINT *,'KBDS( 4) - P2                         ',KBDS( 4)
    3615. 

  3615. C     PRINT *,'KBDS( 5) - BIT PTR - 2ND ORDER WIDTHS ',KBDS( 5)
    3616. 

  3616. C     PRINT *,'KBDS( 6) -  "   "     "   " BIT MAPS  ',KBDS( 6)
    3617. 

  3617. C     PRINT *,'KBDS( 7) -  "   "     F O VALS        ',KBDS( 7)
    3618. 

  3618. C     PRINT *,'KBDS( 8) -  "   "     S O VALS        ',KBDS( 8)
    3619. 

  3619. C     PRINT *,'KBDS( 9) -  "   "    START OF BDS     ',KBDS( 9)
    3620. 

  3620. C     PRINT *,'KBDS(10) -  "   "    MAIN BIT MAP     ',KBDS(10)
    3621. 

  3621. C     PRINT *,'KBDS(11) - BINARY SCALING             ',KBDS(11)
    3622. 

  3622. C     PRINT *,'KPDS(22) - DECIMAL SCALING            ',KPDS(22)
    3623. 

  3623. C     PRINT *,'KBDS(13) - FO BIT WIDTH               ',KBDS(13)
    3624. 

  3624. C     PRINT *,'KBDS(14) - 2ND ORDER BIT MAP FLAG     ',KBDS(14)
    3625. 

  3625. C     PRINT *,'KBDS(15) - 2ND ORDER BIT WIDTH        ',KBDS(15)
    3626. 

  3626. C     PRINT *,'KBDS(16) - CONSTANT/DIFFERENT WIDTHS  ',KBDS(16)
    3627. 

  3627. C     PRINT *,'KBDS(17) - SINGLE DATUM/MATRIX        ',KBDS(17)
    3628. 

  3628. C     PRINT *,'REFNCE VAL                            ',REFNCE
    3629. 

  3629. C  ************************* PROCESS DATA  **********************
    3630. 

  3630.       IJ  = 0
    3631. 

  3631. C  ========================================================
    3632. 

  3632.       IF (KBDS(14).EQ.0) THEN
    3633. 

  3633. C                           NO BIT MAP, MUST CONSTRUCT ONE
    3634. 

  3634.           IF (KGDS(2).EQ.65535) THEN
    3635. 

  3635.               IF (KGDS(20).EQ.255) THEN
    3636. 

  3636. C                 PRINT *,'CANNOT BE USED HERE'
    3637. 

  3637.               ELSE
    3638. 

  3638. C                               POINT TO PL
    3639. 

  3639.           LP  = KPTR(9) + KPTR(2)*8 + KPTR(3)*8 + KGDS(20)*8 - 8
    3640. 

  3640. C                 PRINT *,'LP = ',LP
    3641. 

  3641.                   JT  = 0
    3642. 

  3642.                   DO 2000 JZ = 1, KGDS(3)
    3643. 

  3643. C                               GET NUMBER IN CURRENT ROW
    3644. 

  3644.                       CALL GBYTEC (MSGA,NUMBER,LP,16)
    3645. 

  3645. C                               INCREMENT TO NEXT ROW NUMBER
    3646. 

  3646.                       LP  = LP + 16
    3647. 

  3647. C                     PRINT *,'NUMBER IN ROW',JZ,' = ',NUMBER
    3648. 

  3648.                       DO 1500 JQ = 1, NUMBER
    3649. 

  3649.                           IF (JQ.EQ.1) THEN
    3650. 

  3650.                               CALL SBYTEC (BMAP2,1,JT,1)
    3651. 

  3651.                           ELSE
    3652. 

  3652.                               CALL SBYTEC (BMAP2,0,JT,1)
    3653. 

  3653.                           END IF
    3654. 

  3654.                           JT  = JT + 1
    3655. 

  3655.  1500                 CONTINUE
    3656. 

  3656.  2000             CONTINUE
    3657. 

  3657.               END IF
    3658. 

  3658.           ELSE
    3659. 

  3659.               IF (IAND(KGDS(11),32).EQ.0) THEN
    3660. 

  3660. C                           ROW BY ROW
    3661. 

  3661. C                 PRINT *,'     ROW BY ROW'
    3662. 

  3662.                   KOUT  = KGDS(3)
    3663. 

  3663.                   KIN   = KGDS(2)
    3664. 

  3664.               ELSE
    3665. 

  3665. C                           COL BY COL
    3666. 

  3666. C                 PRINT *,'     COL BY COL'
    3667. 

  3667.                   KIN   = KGDS(3)
    3668. 

  3668.                   KOUT  = KGDS(2)
    3669. 

  3669.               END IF
    3670. 

  3670. C             PRINT *,'KIN=',KIN,' KOUT= ',KOUT
    3671. 

  3671.               DO 200 I = 1, KOUT
    3672. 

  3672.                   DO 150 J = 1, KIN
    3673. 

  3673.                       IF (J.EQ.1) THEN
    3674. 

  3674.                           CALL SBYTEC (BMAP2,1,IJ,1)
    3675. 

  3675.                       ELSE
    3676. 

  3676.                           CALL SBYTEC (BMAP2,0,IJ,1)
    3677. 

  3677.                       END IF
    3678. 

  3678.                       IJ  = IJ + 1
    3679. 

  3679.   150             CONTINUE
    3680. 

  3680.   200         CONTINUE
    3681. 

  3681.           END IF
    3682. 

  3682.       END IF
    3683. 

  3683. C  ========================================================
    3684. 

  3684. C     PRINT 99,(BMAP2(J),J=1,110)
    3685. 

  3685. C99   FORMAT ( 10(1X,Z8.8))
    3686. 

  3686. C     CALL BINARY (BMAP2,2)
    3687. 

  3687. C                FOR EACH GRID POINT ENTRY
    3688. 

  3688. C
    3689. 

  3689.          SCALE2  = 2.0**KBDS(11)
    3690. 

  3690.          SCAL10  = 10.0**KPDS(22)
    3691. 

  3691. C     PRINT *,'SCALE VALUES - ',SCALE2,SCAL10
    3692. 

  3692.       DO 1000 I = 1, KPTR(10)
    3693. 

  3693. C                    GET NEXT MASTER BIT MAP BIT POSITION
    3694. 

  3694. C                    IF NEXT MASTER BIT MAP BIT POSITION IS 'ON' (1)
    3695. 

  3695.           IF (KBMS(I)) THEN
    3696. 

  3696. C             WRITE(6,900)I,KBMS(I)
    3697. 

  3697. C 900         FORMAT (1X,I4,3X,14HMAIN BIT IS ON,3X,L4)
    3698. 

  3698.               IF (KBDS(14).NE.0) THEN
    3699. 

  3699.                   CALL GBYTEC (MSGA,KBIT,KBDS(6),1)
    3700. 

  3700.               ELSE
    3701. 

  3701.                   CALL GBYTEC (BMAP2,KBIT,KBDS(6),1)
    3702. 

  3702.               END IF
    3703. 

  3703. C             PRINT *,'KBDS(6) =',KBDS(6),' KBIT =',KBIT
    3704. 

  3704.               KBDS(6)  = KBDS(6) + 1
    3705. 

  3705.               IF (KBIT.NE.0) THEN
    3706. 

  3706. C                 PRINT *,'          SOB ON'
    3707. 

  3707. C                                  GET NEXT FIRST ORDER PACKED VALUE
    3708. 

  3708.                   CALL GBYTEC (MSGA,IFOVAL,KBDS(7),KBDS(13))
    3709. 

  3709.                   KBDS(7)  = KBDS(7) + KBDS(13)
    3710. 

  3710. C                 PRINT *,'FOVAL =',IFOVAL
    3711. 

  3711. C                                   GET SECOND ORDER BIT WIDTH
    3712. 

  3712.                   CALL GBYTEC (MSGA,KBDS(15),KBDS(5),8)
    3713. 

  3713.                   KBDS(5)  = KBDS(5) + 8
    3714. 

  3714. C                PRINT *,KBDS(7)-KBDS(13),' FOVAL =',IFOVAL,' KBDS(5)=',
    3715. 

  3715. C    *                           ,KBDS(5), 'ISOWID =',KBDS(15)
    3716. 

  3716.               ELSE
    3717. 

  3717. C                 PRINT *,'          SOB NOT ON'
    3718. 

  3718.               END IF
    3719. 

  3719.               ISOVAL  = 0
    3720. 

  3720.               IF (KBDS(15).EQ.0) THEN
    3721. 

  3721. C                        IF SECOND ORDER BIT WIDTH = 0
    3722. 

  3722. C                             THEN SECOND ORDER VALUE IS 0
    3723. 

  3723. C                            SO CALCULATE DATA VALUE FOR THIS POINT
    3724. 

  3724. C                 DATA(I) = (REFNCE + (FLOAT(IFOVAL) * SCALE2)) / SCAL10
    3725. 

  3725.               ELSE
    3726. 

  3726.                   CALL GBYTEC (MSGA,ISOVAL,KBDS(8),KBDS(15))
    3727. 

  3727.                   KBDS(8)  = KBDS(8) + KBDS(15)
    3728. 

  3728.               END IF
    3729. 

  3729.               DATA(I) = (REFNCE + (FLOAT(IFOVAL + ISOVAL) *
    3730. 

  3730.      *                         SCALE2)) / SCAL10
    3731. 

  3731. C             PRINT *,I,DATA(I),REFNCE,IFOVAL,ISOVAL,SCALE2,SCAL10
    3732. 

  3732.           ELSE
    3733. 

  3733. C             WRITE(6,901) I,KBMS(I)
    3734. 

  3734. C 901         FORMAT (1X,I4,3X,15HMAIN BIT NOT ON,3X,L4)
    3735. 

  3735.               DATA(I)  = 0.0
    3736. 

  3736.           END IF
    3737. 

  3737. C         PRINT *,I,DATA(I),IFOVAL,ISOVAL,KBDS(5),KBDS(15)
    3738. 

  3738.  1000 CONTINUE
    3739. 

  3739. C  **************************************************************
    3740. 

  3740. C     PRINT *,'EXIT FI636'
    3741. 

  3741.       RETURN
    3742. 

  3742.       END
    3743. 

  3743.       SUBROUTINE FI637(J,KPDS,KGDS,KRET)
    3744. 

  3744. C$$$  SUBPROGRAM DOCUMENTATION  BLOCK
    3745. 

  3745. C                .      .    .                                       .
    3746. 

  3746. C SUBPROGRAM:    FI637       GRIB GRID/SIZE TEST
    3747. 

  3747. C   PRGMMR: CAVANAUGH        ORG: W/NMC42    DATE: 91-09-13
    3748. 

  3748. C
    3749. 

  3749. C ABSTRACT: TO TEST WHEN GDS IS AVAILABLE TO SEE IF SIZE MISMATCH
    3750. 

  3750. C   ON EXISTING GRIDS (BY CENTER) IS INDICATED
    3751. 

  3751. C
    3752. 

  3752. C PROGRAM HISTORY LOG:
    3753. 

  3753. C   91-09-13  CAVANAUGH
    3754. 

  3754. C   95-10-31  IREDELL     REMOVED SAVES AND PRINTS
    3755. 

  3755. C   97-02-12  W BOSTELMAN CORRECTS ECMWF US GRID 2 PROCESSING
    3756. 

  3756. C   98-06-17  IREDELL     REMOVED ALTERNATE RETURN
    3757. 

  3757. C   99-01-20  BALDWIN    MODIFY TO HANDLE GRID 237
    3758. 

  3758. C   09-05-21  VUONG      MODIFY TO HANDLE GRID 45
    3759. 

  3759. C
    3760. 

  3760. C USAGE:    CALL FI637(J,KPDS,KGDS,KRET)
    3761. 

  3761. C   INPUT ARGUMENT LIST:
    3762. 

  3762. C     J        - SIZE FOR INDICATED GRID
    3763. 

  3763. C     KPDS     -
    3764. 

  3764. C     KGDS     -
    3765. 

  3765. C
    3766. 

  3766. C   OUTPUT ARGUMENT LIST:      (INCLUDING WORK ARRAYS)
    3767. 

  3767. C     J        - SIZE FOR INDICATED GRID MODIFIED FOR ECMWF-US 2
    3768. 

  3768. C     KRET     - ERROR RETURN
    3769. 

  3769. C                (A MISMATCH WAS DETECTED IF KRET IS NOT ZERO)
    3770. 

  3770. C
    3771. 

  3771. C REMARKS:
    3772. 

  3772. C     KRET     -
    3773. 

  3773. C          = 9 - GDS INDICATES SIZE MISMATCH WITH STD GRID
    3774. 

  3774. C
    3775. 

  3775. C   SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT.
    3776. 

  3776. C
    3777. 

  3777. C ATTRIBUTES:
    3778. 

  3778. C   LANGUAGE: FORTRAN 77
    3779. 

  3779. C   MACHINE:  HDS
    3780. 

  3780. C
    3781. 

  3781. C$$$
    3782. 

  3782.       INTEGER       KPDS(*)
    3783. 

  3783.       INTEGER       KGDS(*)
    3784. 

  3784.       INTEGER       J
    3785. 

  3785.       INTEGER       I
    3786. 

  3786. C  ---------------------------------------
    3787. 

  3787. C  ---------------------------------------
    3788. 

  3788. C           IF GDS NOT INDICATED, RETURN
    3789. 

  3789. C  ----------------------------------------
    3790. 

  3790.       KRET=0
    3791. 

  3791.       IF (IAND(KPDS(4),128).EQ.0) RETURN
    3792. 

  3792. C  ---------------------------------------
    3793. 

  3793. C            GDS IS INDICATED, PROCEED WITH TESTING
    3794. 

  3794. C  ---------------------------------------
    3795. 

  3795.       IF (KGDS(2).EQ.65535) THEN
    3796. 

  3796.           RETURN
    3797. 

  3797.       END IF
    3798. 

  3798.       KRET=1
    3799. 

  3799.       I     = KGDS(2) * KGDS(3)
    3800. 

  3800. C  ---------------------------------------
    3801. 

  3801. C            INTERNATIONAL SET
    3802. 

  3802. C  ---------------------------------------
    3803. 

  3803.       IF (KPDS(3).GE.21.AND.KPDS(3).LE.26) THEN
    3804. 

  3804.           IF (I.NE.J) THEN
    3805. 

  3805.                RETURN
    3806. 

  3806.           END IF
    3807. 

  3807.       ELSE IF (KPDS(3).GE.37.AND.KPDS(3).LE.44) THEN
    3808. 

  3808.           IF (I.NE.J) THEN
    3809. 

  3809.               RETURN
    3810. 

  3810.           END IF
    3811. 

  3811.       ELSE IF (KPDS(3).EQ.50) THEN
    3812. 

  3812.           IF (I.NE.J) THEN
    3813. 

  3813.               RETURN
    3814. 

  3814.           END IF
    3815. 

  3815.       ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN
    3816. 

  3816.           IF (I.NE.J) THEN
    3817. 

  3817.               RETURN
    3818. 

  3818.           END IF
    3819. 

  3819. C  ---------------------------------------
    3820. 

  3820. C            TEST ECMWF CONTENT
    3821. 

  3821. C  ---------------------------------------
    3822. 

  3822.       ELSE IF (KPDS(1).EQ.98) THEN
    3823. 

  3823.           KRET  = 9
    3824. 

  3824.           IF (KPDS(3).GE.1.AND.KPDS(3).LE.16) THEN
    3825. 

  3825.               IF (I.NE.J) THEN
    3826. 

  3826.                 IF (KPDS(3) .NE. 2) THEN 
    3827. 

  3827.                   RETURN
    3828. 

  3828.                 ELSEIF (I .NE. 10512) THEN ! Test for US Grid 2
    3829. 

  3829.                   RETURN
    3830. 

  3830.                 END IF
    3831. 

  3831.                 J  = I   ! Set to US Grid 2, 2.5 Global
    3832. 

  3832.               END IF
    3833. 

  3833.           ELSE
    3834. 

  3834.               KRET  = 5
    3835. 

  3835.               RETURN
    3836. 

  3836.           END IF
    3837. 

  3837. C  ---------------------------------------
    3838. 

  3838. C           U.K. MET OFFICE, BRACKNELL
    3839. 

  3839. C  ---------------------------------------
    3840. 

  3840.       ELSE IF (KPDS(1).EQ.74) THEN
    3841. 

  3841.           KRET  = 9
    3842. 

  3842.           IF (KPDS(3).GE.25.AND.KPDS(3).LE.26) THEN
    3843. 

  3843.               IF (I.NE.J) THEN
    3844. 

  3844.                   RETURN
    3845. 

  3845.               END IF
    3846. 

  3846.           ELSE
    3847. 

  3847.               KRET  = 5
    3848. 

  3848.               RETURN
    3849. 

  3849.           END IF
    3850. 

  3850. C  ---------------------------------------
    3851. 

  3851. C           CANADA
    3852. 

  3852. C  ---------------------------------------
    3853. 

  3853.       ELSE IF (KPDS(1).EQ.54) THEN
    3854. 

  3854. C         PRINT *,' NO CURRENT LISTING OF CANADIAN GRIDS'
    3855. 

  3855.           RETURN
    3856. 

  3856. C  ---------------------------------------
    3857. 

  3857. C           JAPAN METEOROLOGICAL AGENCY
    3858. 

  3858. C  ---------------------------------------
    3859. 

  3859.       ELSE IF (KPDS(1).EQ.34) THEN
    3860. 

  3860. C         PRINT *,' NO CURRENT LISTING OF JMA GRIDS'
    3861. 

  3861.           RETURN
    3862. 

  3862. C  ---------------------------------------
    3863. 

  3863. C           NAVY - FNOC
    3864. 

  3864. C  ---------------------------------------
    3865. 

  3865.       ELSE IF (KPDS(1).EQ.58) THEN
    3866. 

  3866.           IF (KPDS(3).GE.37.AND.KPDS(3).LE.44) THEN
    3867. 

  3867.               IF (I.NE.J) THEN
    3868. 

  3868.                   RETURN
    3869. 

  3869.               END IF
    3870. 

  3870.           ELSE IF (KPDS(3).GE.220.AND.KPDS(3).LE.221) THEN
    3871. 

  3871.               IF (I.NE.J) THEN
    3872. 

  3872.                   RETURN
    3873. 

  3873.               END IF
    3874. 

  3874.           ELSE IF (KPDS(3).EQ.223) THEN
    3875. 

  3875.               IF (I.NE.J) THEN
    3876. 

  3876.                   RETURN
    3877. 

  3877.               END IF
    3878. 

  3878.           ELSE
    3879. 

  3879.               KRET = 5
    3880. 

  3880.               RETURN
    3881. 

  3881.           END IF
    3882. 

  3882. C  ---------------------------------------
    3883. 

  3883. C                 U.S. GRIDS
    3884. 

  3884. C  ---------------------------------------
    3885. 

  3885.       ELSE IF (KPDS(1).EQ.7) THEN
    3886. 

  3886.           KRET  = 9
    3887. 

  3887.           IF (KPDS(3).GE.1.AND.KPDS(3).LE.6) THEN
    3888. 

  3888.               IF (I.NE.J) THEN
    3889. 

  3889.                   RETURN
    3890. 

  3890.               END IF
    3891. 

  3891.           ELSE IF (KPDS(3).EQ.8) THEN
    3892. 

  3892.               IF (I.NE.J) THEN
    3893. 

  3893.                   RETURN
    3894. 

  3894.               END IF
    3895. 

  3895.           ELSE IF (KPDS(3).EQ.10) THEN
    3896. 

  3896.               IF (I.NE.J) THEN
    3897. 

  3897.                   RETURN
    3898. 

  3898.               END IF
    3899. 

  3899.           ELSE IF (KPDS(3).GE.11.AND.KPDS(3).LE.18) THEN
    3900. 

  3900.               IF (I.NE.J) THEN
    3901. 

  3901.                   RETURN
    3902. 

  3902.               END IF
    3903. 

  3903.           ELSE IF (KPDS(3).GE.27.AND.KPDS(3).LE.30) THEN
    3904. 

  3904.               IF (I.NE.J) THEN
    3905. 

  3905.                   RETURN
    3906. 

  3906.               END IF
    3907. 

  3907.           ELSE IF (KPDS(3).GE.33.AND.KPDS(3).LE.34) THEN
    3908. 

  3908.               IF (I.NE.J) THEN
    3909. 

  3909.                   RETURN
    3910. 

  3910.               END IF
    3911. 

  3911.           ELSE IF (KPDS(3).GE.37.AND.KPDS(3).LE.45) THEN
    3912. 

  3912.               IF (I.NE.J) THEN
    3913. 

  3913.                   RETURN
    3914. 

  3914.               END IF
    3915. 

  3915.           ELSE IF (KPDS(3).EQ.53) THEN
    3916. 

  3916.               IF (I.NE.J) THEN
    3917. 

  3917.                   RETURN
    3918. 

  3918.               END IF
    3919. 

  3919.           ELSE IF (KPDS(3).GE.55.AND.KPDS(3).LE.56) THEN
    3920. 

  3920.               IF (I.NE.J) THEN
    3921. 

  3921.                   RETURN
    3922. 

  3922.               END IF
    3923. 

  3923.           ELSE IF (KPDS(3).GE.67.AND.KPDS(3).LE.77) THEN
    3924. 

  3924.               IF (I.NE.J) THEN
    3925. 

  3925.                   RETURN
    3926. 

  3926.               END IF
    3927. 

  3927.           ELSE IF (KPDS(3).GE.85.AND.KPDS(3).LE.88) THEN
    3928. 

  3928.               IF (I.NE.J) THEN
    3929. 

  3929.                   RETURN
    3930. 

  3930.               END IF
    3931. 

  3931.           ELSE IF (KPDS(3).GE.90.AND.KPDS(3).LE.99) THEN
    3932. 

  3932.               IF (I.NE.J) THEN
    3933. 

  3933.                   RETURN
    3934. 

  3934.               END IF
    3935. 

  3935.           ELSE IF (KPDS(3).EQ.100.OR.KPDS(3).EQ.101) THEN
    3936. 

  3936.               IF (I.NE.J) THEN
    3937. 

  3937.                   RETURN
    3938. 

  3938.               END IF
    3939. 

  3939.           ELSE IF (KPDS(3).GE.103.AND.KPDS(3).LE.107) THEN
    3940. 

  3940.               IF (I.NE.J) THEN
    3941. 

  3941.                   RETURN
    3942. 

  3942.               END IF
    3943. 

  3943.           ELSE IF (KPDS(3).EQ.110) THEN
    3944. 

  3944.               IF (I.NE.J) THEN
    3945. 

  3945.                   RETURN
    3946. 

  3946.               END IF
    3947. 

  3947.           ELSE IF (KPDS(3).EQ.120) THEN
    3948. 

  3948.               IF (I.NE.J) THEN
    3949. 

  3949.                   RETURN
    3950. 

  3950.               END IF
    3951. 

  3951.           ELSE IF (KPDS(3).GE.122.AND.KPDS(3).LE.128) THEN
    3952. 

  3952.               IF (I.NE.J) THEN
    3953. 

  3953.                   RETURN
    3954. 

  3954.               END IF
    3955. 

  3955.           ELSE IF (KPDS(3).EQ.130) THEN
    3956. 

  3956.               IF (I.NE.J) THEN
    3957. 

  3957.                   RETURN
    3958. 

  3958.               END IF
    3959. 

  3959.           ELSE IF (KPDS(3).EQ.138) THEN
    3960. 

  3960.               IF (I.NE.J) THEN
    3961. 

  3961.                   RETURN
    3962. 

  3962.               END IF
    3963. 

  3963.           ELSE IF (KPDS(3).EQ.139) THEN
    3964. 

  3964.               IF (I.NE.J) THEN
    3965. 

  3965.                   RETURN
    3966. 

  3966.               END IF
    3967. 

  3967.           ELSE IF (KPDS(3).EQ.140) THEN
    3968. 

  3968.               IF (I.NE.J) THEN
    3969. 

  3969.                   RETURN
    3970. 

  3970.               END IF
    3971. 

  3971.           ELSE IF (KPDS(3).GE.145.AND.KPDS(3).LE.148) THEN
    3972. 

  3972.               IF (I.NE.J) THEN
    3973. 

  3973.                   RETURN
    3974. 

  3974.               END IF
    3975. 

  3975.           ELSE IF (KPDS(3).EQ.150.OR.KPDS(3).EQ.151) THEN
    3976. 

  3976.               IF (I.NE.J) THEN
    3977. 

  3977.                   RETURN
    3978. 

  3978.               END IF
    3979. 

  3979.           ELSE IF (KPDS(3).EQ.160.OR.KPDS(3).EQ.161) THEN
    3980. 

  3980.               IF (I.NE.J) THEN
    3981. 

  3981.                   RETURN
    3982. 

  3982.               END IF
    3983. 

  3983.           ELSE IF (KPDS(3).EQ.163) THEN
    3984. 

  3984.               IF (I.NE.J) THEN
    3985. 

  3985.                   RETURN
    3986. 

  3986.               END IF
    3987. 

  3987.           ELSE IF (KPDS(3).GE.170.AND.KPDS(3).LE.176) THEN
    3988. 

  3988.               IF (I.NE.J) THEN
    3989. 

  3989.                   RETURN
    3990. 

  3990.               END IF
    3991. 

  3991.           ELSE IF (KPDS(3).GE.179.AND.KPDS(3).LE.184) THEN
    3992. 

  3992.               IF (I.NE.J) THEN
    3993. 

  3993.                   RETURN
    3994. 

  3994.               END IF
    3995. 

  3995.           ELSE IF (KPDS(3).EQ.190.OR.KPDS(3).EQ.192) THEN
    3996. 

  3996.               IF (I.NE.J) THEN
    3997. 

  3997.                   RETURN
    3998. 

  3998.               END IF
    3999. 

  3999.           ELSE IF (KPDS(3).GE.194.AND.KPDS(3).LE.199) THEN
    4000. 

  4000.               IF (I.NE.J) THEN
    4001. 

  4001.                   RETURN
    4002. 

  4002.               END IF
    4003. 

  4003.           ELSE IF (KPDS(3).GE.201.AND.KPDS(3).LE.254) THEN
    4004. 

  4004.               IF (I.NE.J) THEN
    4005. 

  4005.                   RETURN
    4006. 

  4006.               END IF
    4007. 

  4007.           ELSE
    4008. 

  4008.               KRET  = 5
    4009. 

  4009.               RETURN
    4010. 

  4010.           END IF
    4011. 

  4011.       ELSE
    4012. 

  4012.           KRET  = 10
    4013. 

  4013.           RETURN
    4014. 

  4014.       END IF
    4015. 

  4015. C  ------------------------------------
    4016. 

  4016. C                    NORMAL EXIT
    4017. 

  4017. C  ------------------------------------
    4018. 

  4018.       KRET  = 0
    4019. 

  4019.       RETURN
    4020. 

  4020.       END
    4021. 

  4021.