PageRenderTime 39ms CodeModel.GetById 5ms 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

Large files files are truncated, but you can click here to view the full file

    

  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.    …
    1177.

Large files files are truncated, but you can click here to view the full file