NCEPLIBS-w3emc  2.11.0
w3fp13.f
Go to the documentation of this file.
1 C> @file
2 C> @brief Convert GRIB PDS edition 1 to O.N. 84 ID.
3 C> @author A.J. McClees @date 1991-10-07
4 
5 C> Converts GRIB version 1 formatted product definition
6 C> section to an office note 84 id label. Formats all that is appli-
7 C> cable in the first 8 words of O.N. 84. (caution ****see remarks)
8 C>
9 C> ### Program History Log:
10 C> Date | Programmer | Comments
11 C> -----|------------|---------
12 C> 1991-10-07 | A.J. McClees | Initial
13 C> 1992-01-06 | Ralph Jones | Convert to silicongraphics 3.3 fortran 77
14 C> 1993-03-29 | Ralph Jones | Add save statement
15 C> 1994-04-17 | Ralph Jones | Complete rewrite to use sbyte, make code portable, upgrade to on388
16 C> 1994-05-05 | Ralph Jones | Correction in two tables
17 C> 1996-08-02 | Ralph Jones | Error using T marker
18 C> 1996-09-03 | Ralph Jones | Add mercator grids 8 and 53 to tables
19 C> 1999-02-15 | B. Facey | Replace w3fs04 with w3movdat().
20 C> 2002-10-15 | Boi Vuong | Replaced function ichar with mova2i()
21 C>
22 C> @param[in] GRIB GRIB section 0 read as character*8
23 C> @param[in] PDS GRIB PDS section 1 read as character*1 PDS(*)
24 C> @param[out] ID8 12 Integer*4 formatted O.N. 84 ID. 6 integer 64 bit words on cray
25 C> @param[out] IERR
26 C> 0 - Completed satisfactorily
27 C> 1 - Grib block 0 not correct
28 C> 2 - Length of pds not correct
29 C> 3 - Could not match type indicator
30 C> 4 - Grid type not in tables
31 C> 5 - Could not match type level
32 C> 6 - Could not interpret originator of code
33 C>
34 C> @note Some of the id's will not be exact to the o.n. 84
35 C> for locating field on the dataset. These differences
36 C> are mainly due to truncation errors with layers.
37 C> For example: .18019 sig .47191 sig r h for 36.o hrs
38 C> will convert to: .18000 sig .47000 sig r h for 36.0 hrs
39 C> !!!!!!!the above id's now forced to be exact!!!!!!!!!
40 C> If j the word count is greater then 32743, j is stored
41 C> in the 12th id word. Bits 16-31 of the 8th id word are
42 C> set to zero.
43 C>
44 C> @author A.J. McClees @date 1991-10-07
45  SUBROUTINE w3fp13 (GRIB, PDS, ID8, IERR )
46 C
47  INTEGER HH (255)
48  INTEGER HH1 (127)
49  INTEGER HH2 (128)
50  INTEGER LL (255)
51  INTEGER LL1 (127)
52  INTEGER LL2 (128)
53  INTEGER ICXG2 (9)
54  INTEGER ICXGB2 (9)
55  INTEGER ICXG1 (7)
56  INTEGER ICXGB1 (7)
57 C
58  INTEGER C1
59  INTEGER C2
60  INTEGER E1
61  INTEGER E2
62  INTEGER FTU
63  INTEGER F1
64  INTEGER F2
65  INTEGER ID (25)
66  INTEGER ID8 (12)
67  INTEGER IDATE
68  INTEGER JDATE
69  INTEGER IGEN ( 4)
70  INTEGER NGRD (34)
71  INTEGER NPTS (34)
72  INTEGER P1
73  INTEGER P2
74  INTEGER S1
75 C INTEGER S2
76  INTEGER T
77  INTEGER TR
78 C
79  CHARACTER * 8 GRIB
80  CHARACTER * 8 IGRIB
81  REAL RINC(5)
82  INTEGER NDATE(8), MDATE(8)
83  CHARACTER * 1 IWORK ( 8)
84  CHARACTER * 1 JWORK ( 8)
85  CHARACTER * 1 PDS ( *)
86 C
87  SAVE
88 C
89  equivalence(hh(1),hh1(1))
90  equivalence(hh(128),hh2(1))
91  equivalence(ll(1),ll1(1))
92  equivalence(ll(128),ll2(1))
93  equivalence(idate,iwork(1))
94  equivalence(jdate,jwork(1))
95 C
96  DATA hh1 / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,
97  & 11, 12, 13, 14, 15, 16, 17, 18, 19, 20,
98  & 21, 22, 23, 24, 25, 26, 27, 28, 29, 30,
99  & 31, 32, 33, 34, 35, 36, 37, 38, 39, 40,
100  & 41, 42, 43, 44, 45, 46, 47, 48, 49, 50,
101  & 51, 52, 53, 54, 55, 56, 57, 58, 59, 60,
102  & 61, 62, 63, 64, 65, 66, 67, 68, 69, 70,
103  & 71, 72, 73, 74, 75, 76, 77, 78, 79, 80,
104  & 81, 82, 83, 84, 85, 86, 87, 88, 89, 90,
105  & 91, 92, 93, 94, 95, 96, 97, 98, 99, 100,
106  & 101, 102, 103, 104, 105, 106, 107, 108, 109, 110,
107  & 111, 112, 113, 114, 115, 116, 117, 118, 119, 120,
108  & 121, 122, 123, 124, 125, 126, 127/
109  DATA hh2 / 128, 129, 130,
110  & 131, 132, 133, 134, 135, 136, 137, 138, 139, 140,
111  & 141, 142, 143, 144, 145, 146, 147, 148, 149, 150,
112  & 151, 152, 153, 154, 155, 156, 157, 158, 159, 160,
113  & 161, 162, 163, 164, 165, 166, 167, 168, 169, 170,
114  & 171, 172, 173, 174, 175, 176, 177, 178, 179, 180,
115  & 181, 182, 183, 184, 185, 186, 187, 188, 189, 190,
116  & 191, 192, 193, 194, 195, 196, 197, 198, 199, 200,
117  & 201, 202, 203, 204, 205, 206, 207, 208, 209, 210,
118  & 211, 212, 213, 214, 215, 216, 217, 218, 219, 220,
119  & 221, 222, 223, 224, 225, 226, 227, 228, 229, 230,
120  & 231, 232, 233, 234, 235, 236, 237, 238, 239, 240,
121  & 241, 242, 243, 244, 245, 246, 247, 248, 249, 250,
122  & 251, 252, 253, 254, 255/
123 C
124  DATA igen / 7, 58, 66, 98/
125 C
126 C ########### NUMBERS FORCED AFTER CONVERTING FROM GRIB LAYER.
127 C ICXG2 1.0000, .98230, .96470,
128 C .85000, .84368, .47191,
129 C .18017, .81573, .25011
130 C #################
131 C
132  DATA icxg2 /z'00002710', z'00017FB6', z'000178D6',
133  a z'00014C08', z'00014990', z'0000B857',
134  a z'00004663', z'00013EA5', z'000061B3'/
135 C
136 C ########### NUMBERS CALCULATED BY GRIB LAYER.
137 C ICXGB2 1.00000, .98000, .96000,
138 C .85000, .84000, .47000,
139 C .18000, .82000, .25000
140 C #################
141 C
142  DATA icxgb2/z'00002710', z'00017ED0', z'00017700',
143  a z'00014C00', z'00014820', z'0000B798',
144  a z'00004650', z'00014050', z'000061A8'/
145 C
146 C ########### NUMBERS FORCED AFTER CONVERTING FROM GRIB SINGLE.
147 C ICXG1 .98230, .89671, .78483
148 C .94316, .84367, .999.00, .25011
149 C #################
150 C
151  DATA icxg1 /z'00017FB6', z'00015E47', z'00013293',
152  a z'0001706C', z'0001498F', z'0000863C', z'000061B3'/
153 C
154 C ########### NUMBERS CALCULATED BY GRIB LAYER.
155 C ICXGB1 .98230, .89670, .78480
156 C .94320, .84370, 998.00, .25000
157 C #################
158 C
159  DATA icxgb1/z'00017FB6', z'00015E46', z'00013290',
160  a z'00017070', z'00014992', z'000185D8', z'000061A8'/
161 C
162  DATA ll1 / 8, 8, 9, 255, 255, 255, 1, 6, 255, 255,
163  & 16, 24, 19, 23, 20, 21, 17, 18, 255, 180,
164  & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255,
165  & 55, 50, 48, 49, 80, 81, 71, 255, 40, 42,
166  & 72, 74, 73, 255, 255, 255, 255, 255, 304, 305,
167  & 95, 88, 101, 89, 104, 255, 117, 255, 97, 98,
168  & 90, 105, 94, 255, 255, 93, 188, 255, 255, 255,
169  & 255, 211, 255, 255, 255, 255, 255, 255, 255, 384,
170  & 161, 255, 255, 169, 22, 255, 255, 255, 255, 255,
171  & 255, 255, 255, 255, 255, 255, 255, 255, 255, 400,
172  & 389, 385, 388, 391, 386, 390, 402, 401, 404, 403,
173  & 204, 255, 255, 255, 255, 255, 255, 255, 255, 255,
174  & 195, 194, 255, 255, 255, 255, 255/
175  DATA ll2 / 255, 255, 255,
176  & 112, 116, 114, 255, 103, 52, 255, 255, 255, 255,
177  & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255,
178  & 255, 255, 255, 255, 255, 119, 157, 158, 159, 255,
179  & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255,
180  & 255, 255, 255, 255, 255, 176, 177, 255, 255, 255,
181  & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255,
182  & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255,
183  & 392, 255, 255, 192, 190, 255, 199, 216, 189, 255,
184  & 193, 191, 210, 107, 255, 198, 255, 255, 255, 255,
185  & 255, 1, 255, 255, 255, 255, 255, 255, 255, 255,
186  & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255,
187  & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255,
188  & 255, 160, 255, 255, 255/
189 C
190  DATA npts / 1679, 259920, 3021, 2385, 5104, 4225,
191  & 4225, 5365, 5365, 8326, 8326,
192  & 5967, 6177, 6177, 12321, 12321, 12321,
193  & 32400, 32400, 5022, 12902, 25803,
194  & 24162, 48232, 18048, 6889, 10283,
195  & 3640, 16170, 6889, 19305, 11040,
196  & 72960, 6693/
197 C
198  DATA ngrd / 1, 4, 5, 6, 8, 27,
199  & 28, 29, 30, 33, 34,
200  & 53, 55, 56, 75, 76, 77,
201  & 85, 86, 87, 90, 91,
202  & 92, 93, 98, 100, 101,
203  & 103, 104, 105, 106, 107,
204  & 126, 214/
205 C
206 C DATA MSK1 /Z0000FFFF/,
207 C & MSK2 /Z00000080/,
208 C & MSK3 /Z00000000/,
209 C & MSK4 /Z00000200/
210 C CHANGE HEX TO DECIMAL TO MAKE SUBROUTINE MORE PORTABLE
211 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
212  DATA msk1 /65535/,
213  & msk2 /128/,
214  & msk3 /0/,
215  & msk4 /512/
216 C
217 C MAKE SECTION 0, PUT 'GRIB' IN ASCII
218 C
219  igrib(1:1) = char(71)
220  igrib(2:2) = char(82)
221  igrib(3:3) = char(73)
222  igrib(4:4) = char(66)
223  igrib(5:5) = char(0)
224  igrib(6:6) = char(0)
225  igrib(7:7) = char(0)
226  igrib(8:8) = char(1)
227 C
228 C CONVERT PDS INTO 25 INTEGER NUMBERS
229 C
230  CALL w3fi69(pds,id)
231 C
232 C ID(1) = NUMBER OF BYTES IN PDS
233 C ID(2) = PARAMETER TABLE VERSION NUMBER
234 C ID(3) = IDENTIFICATION OF ORIGINATING CENTER
235 C ID(4) = MODEL IDENTIFICATION (ALLOCATED BY ORIGINATING CENTER)
236 C ID(5) = GRID IDENTIFICATION
237 C ID(6) = 0 IF NO GDS SECTION, 1 IF GDS SECTION IS INCLUDED
238 C ID(7) = 0 IF NO BMS SECTION, 1 IF BMS SECTION IS INCLUDED
239 C ID(8) = INDICATOR OF PARAMETER AND UNITS
240 C ID(9) = INDICATOR OF TYPE OF LEVEL OR LAYER
241 C ID(10) = LEVEL 1
242 C ID(11) = LEVEL 2
243 C ID(12) = YEAR OF CENTURY
244 C ID(13) = MONTH OF YEAR
245 C ID(14) = DAY OF MONTH
246 C ID(15) = HOUR OF DAY
247 C ID(16) = MINUTE OF HOUR (IN MOST CASES SET TO 0)
248 C ID(17) = FCST TIME UNIT
249 C ID(18) = P1 PERIOD OF TIME
250 C ID(19) = P2 PERIOD OF TIME
251 C ID(20) = TIME RANGE INDICATOR
252 C ID(21) = NUMBER INCLUDED IN AVERAGE
253 C ID(22) = NUMBER MISSING FROM AVERAGES OR ACCUMULATIONS
254 C ID(23) = CENTURY
255 C ID(24) = IDENTIFICATION OF SUB-CENTER (TABLE 0 - PART 2)
256 C ID(25) = SCALING POWER OF 10
257 C
258 C THE 1ST 8 32 BIT WORDS WITH THE OFFICE NOTE 84 ID'S ARE
259 C IN 27 PARTS, SBYTE IS USED WITH BIT COUNTS TO MAKE THIS
260 C DATA. THIS MAKE IT WORD SIZE INDEPENDENT, AND MAKES THIS
261 C SUBROUTINE PORTABLE. TABLE WITH STARTING BITS IS NEXT.
262 C THE STARTING BIT AND NO. OF BITS IS USED AS THE 3RD AND
263 C 4TH PARAMETER FOR SBYTE. READ GBYTES DOCUMENT FROM NCAR
264 C FOR INFORMATION ABOUT SBYTE. SEE PAGE 38, FIGURE 1, IN
265 C OFFICE NOTE 84.
266 C
267 C NO. NAME STARTING BIT NO. OF BITS
268 C -----------------------------------------
269 C 1 Q 0 12
270 C 2 S1 12 12
271 C 3 F1 24 8
272 C 4 T 32 4
273 C 5 C1 36 20
274 C 6 E1 56 8
275 C 7 M 64 4
276 C 8 X 68 8
277 C 9 S2 76 12
278 C 10 F2 88 8
279 C 11 N 96 4
280 C 12 C2 100 20
281 C 13 E2 120 8
282 C 14 CD 128 8
283 C 15 CM 136 8
284 C 16 KS 144 8
285 C 17 K 152 8
286 C 18 GES 160 4
287 C 19 164 12
288 C 20 NW 176 16
289 C 21 YY 192 8
290 C 22 MM 200 8
291 C 23 DD 208 8
292 C 24 II 216 8
293 C 25 R 224 8
294 C 26 G 232 8
295 C 27 J 240 16
296 C OR 27 J 352 32 J > 32743
297 C----------------------------------------------
298 C
299 C$ 1.0 INITIALIZATION - NO. OF ENTRIES IN INDCATOR PARM.
300 C$ - NO. OF ENTRIES IN TYPE LEVEL
301 C$ - NO. OF ENTRIES IN CNTR PROD. DTA.
302 C$ - INITIAL ZEROS IN O.N. 84 LABEL
303 C
304  iq = 255
305  ic = 4
306  in = 34
307 C
308 C TEST FOR 32 OR 64 BIT COMPUTER (CRAY)
309 C
310  CALL w3fi01(lw)
311  IF (lw.EQ.4) THEN
312  nwords = 12
313  ELSE
314  nwords = 6
315  END IF
316 C
317 C ZERO OUTPUT ARRAY
318 C
319  DO n = 1,nwords
320  id8(n) = 0
321  END DO
322 C
323 C ---------------------------------------------------------------------
324 C$ 2.0 VERIFY GRIB IN SECTION 0
325 C
326  IF (.NOT. grib(1:4) .EQ. igrib(1:4)) THEN
327  ierr = 1
328  RETURN
329  END IF
330 C
331 C 2.1 VERIFY THE NO. OF OCTETS IN THE PDS
332 C
333  IF (id(1).NE.28) THEN
334  ierr = 2
335  print *,'IERR = ',ierr,',LENGTH OF PDS = ',id(1)
336  RETURN
337  END IF
338 C
339 C$ 3.0 GENERATING MODEL, TYPE GRID, AND NO. OF GRID PTS.
340 C
341 C IF CENTER NOT U.S., STORE CENTER IN G MARKER
342 C IF CENTER U.S. STORE MODEL NO. IN G MARKER
343 C
344  IF (id(3) .NE. 7) THEN
345  CALL sbyte(id8,id(3),232,8)
346  ELSE
347  CALL sbyte(id8,id(4),232,8)
348  END IF
349 C
350  DO kk = 1,in
351  IF (id(5) .EQ. ngrd(kk)) THEN
352  igrdpt = npts(kk)
353  IF (id(5) .EQ. 6) id(5) = 26
354  CALL sbyte(id8,id(5),152,8)
355  IF (igrdpt.LE.32743) THEN
356  CALL sbyte(id8,igrdpt,240,16)
357  ELSE
358  CALL sbyte(id8,igrdpt,352,32)
359  END IF
360  GO TO 350
361  END IF
362  END DO
363  ierr = 4
364  print *,'IERR = ',ierr,',GRID TYPE = ',id(5)
365  RETURN
366 C
367  350 CONTINUE
368 C
369 C COMPUTE R MARKER FROM MODEL NUMBERS FOR U.S. CENTER
370 C
371 C (ERL) run
372  IF (id(3).EQ.7) THEN
373  IF (id(4).EQ.19.OR.id(4).EQ.53.OR.id(4).EQ.83.OR.
374  & id(4).EQ.84.OR.id(4).EQ.85) THEN
375  CALL sbyte(id8,0,224,8)
376 C (NMC) run
377  ELSE IF (id(4).EQ.25) THEN
378  CALL sbyte(id8,1,224,8)
379 C (RGL) run
380  ELSE IF (id(4).EQ.39.OR.id(4).EQ.64) THEN
381  CALL sbyte(id8,2,224,8)
382 C (AVN) run
383  ELSE IF (id(4).EQ.10.OR.id(4).EQ.42.OR.
384  & id(4).EQ.68.OR.id(4).EQ.73.OR.
385  & id(4).EQ.74.OR.id(4).EQ.75.OR.
386  & id(4).EQ.77.OR.id(4).EQ.81.OR.
387  & id(4).EQ.88) THEN
388  CALL sbyte(id8,3,224,8)
389 C (MRF) run
390  ELSE IF (id(4).EQ.69.OR.id(4).EQ.76.OR.
391  & id(4).EQ.78.OR.id(4).EQ.79.OR.
392  & id(4).EQ.80.oR.id(4).EQ.87) THEN
393  CALL sbyte(id8,4,224,8)
394 C (FNL) run
395  ELSE IF (id(4).EQ.43.OR.id(4).EQ.44.OR.
396  & id(4).EQ.82) THEN
397  CALL sbyte(id8,5,224,8)
398 C (HCN) run
399  ELSE IF ( id(4).EQ.70) THEN
400  CALL sbyte(id8,6,224,8)
401 C (RUC) run
402  ELSE IF ( id(4).EQ.86) THEN
403  CALL sbyte(id8,7,224,8)
404 C Not applicable, set to 255
405  ELSE
406  CALL sbyte(id8,255,224,8)
407  END IF
408  END IF
409 C
410 C$ 4.0 FORM TYPE DATA PARAMETER
411 C
412  DO ii = 1,iq
413  iii = ii
414  IF (id(8) .EQ. hh(ii)) THEN
415  IF (ll(ii).NE.255) GO TO 410
416  print *,'PDS PARAMETER HAS NO OFFICE NOTE 84 Q TYPE'
417  print *,'PDS BYTE 9 PARAMETER = ',id(8)
418  ierr = 3
419  RETURN
420  END IF
421  END DO
422  ierr = 3
423  print *,'PDS BYTE 9, PARAMETER = ',id(8)
424  RETURN
425 C
426  410 CONTINUE
427 C
428 C Q DATA TYPE, BITS 1-12
429 C
430  CALL sbyte(id8,ll(iii),0,12)
431 C
432 C TEST FOR 32 OR 64 BIT COMPUTER (CRAY)
433 C
434  IF (lw.EQ.4) THEN
435  IF (id(8) .EQ. 211) id8(5) = ior(id8(5),msk4)
436  IF (id(8) .EQ. 210) id8(5) = ior(id8(5),msk4)
437  ELSE
438  IF (id(8) .EQ. 211) id8(3) = ior(id8(3),ishft(msk4,32))
439  IF (id(8) .EQ. 210) id8(3) = ior(id8(3),ishft(msk4,32))
440  END IF
441 C
442 C$ 5.0 FORM TYPE LEVEL
443 C
444  IF (id(9) .EQ. 100) THEN
445  m = 0
446  s1 = 8
447  CALL sbyte(id8,s1,12,12)
448  CALL sbyte(id8,m,64,4)
449  level = id(11)
450  IF (level .GE. 1 .AND. level .LE. 9) THEN
451  e1 = 4
452  ELSE IF (level .GE. 10 .AND. level .LE. 99) THEN
453  e1 = 3
454  ELSE IF (level .GE. 100 .AND. level .LE. 999) THEN
455  e1 = 2
456  ELSE IF (level .GE. 1000 .AND. level .LE. 9999) THEN
457  e1 = 1
458  END IF
459  c1 = level * 10 ** e1
460  CALL sbyte(id8,c1,36,20)
461  e1 = ior(e1,msk2)
462  CALL sbyte(id8,e1,56,8)
463 C
464  ELSE IF (id(9) .EQ. 103) THEN
465  m = 0
466  s1 = 1
467  CALL sbyte(id8,s1,12,12)
468  CALL sbyte(id8,m,64,4)
469  level = id(11)
470  IF (level .GE. 1 .AND. level .LE. 9) THEN
471  e1 = 4
472  ELSE IF (level .GE. 10 .AND. level .LE. 99) THEN
473  e1 = 3
474  ELSE IF (level .GE. 100 .AND. level .LE. 999) THEN
475  e1 = 2
476  ELSE IF (level .GE. 1000 .AND. level .LE. 9999) THEN
477  e1 = 1
478  END IF
479  c1 = level * 10 ** e1
480  CALL sbyte(id8,c1,36,20)
481  e1 = ior(e1,msk2)
482  CALL sbyte(id8,e1,56,8)
483 C
484  ELSE IF (id(9) .EQ. 105) THEN
485  m = 0
486  s1 = 6
487  CALL sbyte(id8,s1,12,12)
488  CALL sbyte(id8,m,64,4)
489  level = id(11)
490  IF (level .GE. 1 .AND. level .LE. 9) THEN
491  e1 = 4
492  ELSE IF (level .GE. 10 .AND. level .LE. 99) THEN
493  e1 = 3
494  ELSE IF (level .GE. 100 .AND. level .LE. 999) THEN
495  e1 = 2
496  ELSE IF (level .GE. 1000 .AND. level .LE. 9999) THEN
497  e1 = 1
498  END IF
499  c1 = level * 10 ** e1
500  CALL sbyte(id8,c1,36,20)
501  e1 = ior(e1,msk2)
502  CALL sbyte(id8,e1,56,8)
503 C
504  ELSE IF (id(9) .EQ. 111) THEN
505  m = 0
506  s1 = 7
507  CALL sbyte(id8,s1,12,12)
508  CALL sbyte(id8,m,64,4)
509  level = id(11)
510  IF (level .GE. 1 .AND. level .LE. 9) THEN
511  e1 = 4
512  ELSE IF (level .GE. 10 .AND. level .LE. 99) THEN
513  e1 = 3
514  ELSE IF (level .GE. 100 .AND. level .LE. 999) THEN
515  e1 = 2
516  ELSE IF (level .GE. 1000 .AND. level .LE. 9999) THEN
517  e1 = 1
518  END IF
519  c1 = level * 10 ** e1
520  CALL sbyte(id8,c1,36,20)
521 C XXXXXXX SCALE FROM CENTIMETERS TO METERS. XXXXXXXXXX
522  e1 = ior(e1,msk2)
523  e1 = e1 + 2
524  IF (c1 .EQ. 0) THEN
525  e1 = 0
526  END IF
527  CALL sbyte(id8,e1,56,8)
528 C
529  ELSE IF (id(9) .EQ. 107) THEN
530  m = 0
531  s1 = 148
532  CALL sbyte(id8,s1,12,12)
533  CALL sbyte(id8,m,64,4)
534  level = id(11)
535  IF (level .GE. 1 .AND. level .LE. 9) THEN
536  e1 = 4
537  ELSE IF (level .GE. 10 .AND. level .LE. 99) THEN
538  e1 = 3
539  ELSE IF (level .GE. 100 .AND. level .LE. 999) THEN
540  e1 = 2
541  ELSE IF (level .GE. 1000 .AND. level .LE. 9999) THEN
542  e1 = 1
543  ELSE
544  e1 = 0
545  END IF
546  c1 = level * 10 ** e1
547  DO isi = 1,7
548  IF (c1 .EQ. icxgb1(isi)) THEN
549  c1 = icxg1(isi)
550  END IF
551  END DO
552  CALL sbyte(id8,c1,36,20)
553 C***********SCALING OF .0001 TAKEN INTO ACCOUNT
554  e1 = e1 + 4
555  e1 = ior(e1,msk2)
556  IF (c1 .EQ. 0) THEN
557  e1 = 0
558  END IF
559  CALL sbyte(id8,e1,56,8)
560 C
561  ELSE IF (id(9) .EQ. 4) THEN
562  m = 0
563  s1 = 16
564  CALL sbyte(id8,s1,12,12)
565  CALL sbyte(id8,m,64,4)
566 C LEVEL = ID(11)
567 C******* CONSTANT VALUE OF 273.16 WILL HAVE TO BE INSERTED
568 C LEVEL = IAND (IPDS(3),MSK1)
569 C IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN
570 C E1 = 4
571 C ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN
572 C E1 = 3
573 C ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN
574 C E1 = 2
575 C ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN
576 C E1 = 1
577 C END IF
578  e1 = 2
579  c1 = (273.16 * 10 ** e1) + .5
580  CALL sbyte(id8,c1,36,20)
581  e1 = ior(e1,msk2)
582  CALL sbyte(id8,e1,56,8)
583 C*************SPECIAL CASES *********************
584  ELSE IF (id(9) .EQ. 102) THEN
585  m = 0
586  s1 = 128
587  CALL sbyte(id8,s1,12,12)
588  CALL sbyte(id8,0,64,32)
589 C
590  ELSE IF (id(9) .EQ. 1) THEN
591  m = 0
592  s1 = 129
593 C***** S1 = 133 ALSO POSSIBILITY
594  CALL sbyte(id8,s1,12,12)
595  CALL sbyte(id8,0,64,32)
596 C
597  ELSE IF (id(9) .EQ. 7) THEN
598  m = 0
599  s1 = 130
600  CALL sbyte(id8,s1,12,12)
601  CALL sbyte(id8,0,64,32)
602 C
603  ELSE IF (id(9) .EQ. 6) THEN
604  m = 0
605  s1 = 131
606  CALL sbyte(id8,s1,12,12)
607  CALL sbyte(id8,0,64,32)
608 C
609  ELSE IF (id(9) .EQ. 101) THEN
610  m = 2
611  s1 = 8
612  CALL sbyte(id8,s1,12,12)
613  CALL sbyte(id8,m,64,4)
614  CALL sbyte(id8,s1,76,12)
615  level = id(10)
616  level = (level * .1) * 10 ** 2
617  IF (level .GE. 1 .AND. level .LE. 9) THEN
618  e1 = 4
619  ELSE IF (level .GE. 10 .AND. level .LE. 99) THEN
620  e1 = 3
621  ELSE IF (level .GE. 100 .AND. level .LE. 999) THEN
622  e1 = 2
623  ELSE IF (level .GE. 1000 .AND. level .LE. 9999) THEN
624  e1 = 1
625  END IF
626  c1 = level * 10 ** e1
627  CALL sbyte(id8,c1,36,20)
628  e1 = ior(e1,msk2)
629  CALL sbyte(id8,e1,56,8)
630  level2 = id(11)
631  level2 = (level2 * .1) * 10 ** 2
632  IF (level2 .GE. 1 .AND. level2 .LE. 9) THEN
633  e2 = 4
634  ELSE IF (level2 .GE. 10 .AND. level2 .LE. 99) THEN
635  e2 = 3
636  ELSE IF (level2 .GE. 100 .AND. level2 .LE. 999) THEN
637  e2 = 2
638  ELSE IF (level2 .GE. 1000 .AND. level2 .LE. 9999) THEN
639  e2 = 1
640  END IF
641  c2 = level2 * 10 ** e2
642  CALL sbyte(id8,c2,100,20)
643  IF (c2 .EQ. 0) e2 = 0
644  e2 = ior(e2,msk2)
645  CALL sbyte(id8,e2,120,8)
646 C
647  ELSE IF (id(9) .EQ. 104) THEN
648  m = 2
649  s1 = 1
650  CALL sbyte(id8,s1,12,12)
651  CALL sbyte(id8,m,64,4)
652  CALL sbyte(id8,s1,76,12)
653  level = id(10)
654  level = (level * .1) * 10 ** 2
655  IF (level .GE. 1 .AND. level .LE. 9) THEN
656  e1 = 4
657  ELSE IF (level .GE. 10 .AND. level .LE. 99) THEN
658  e1 = 3
659  ELSE IF (level .GE. 100 .AND. level .LE. 999) THEN
660  e1 = 2
661  ELSE IF (level .GE. 1000 .AND. level .LE. 9999) THEN
662  e1 = 1
663  END IF
664  c1 = level * 10 ** e1
665  CALL sbyte(id8,c1,36,20)
666  e1 = ior(e1,msk2)
667  CALL sbyte(id8,e1,56,8)
668  level2 = id(11)
669  level2 = (level2 * .1) * 10 ** 2
670  IF (level2 .GE. 1 .AND. level2 .LE. 9) THEN
671  e2 = 4
672  ELSE IF (level2 .GE. 10 .AND. level2 .LE. 99) THEN
673  e2 = 3
674  ELSE IF (level2 .GE. 100 .AND. level2 .LE. 999) THEN
675  e2 = 2
676  ELSE IF (level2 .GE. 1000 .AND. level2 .LE. 9999) THEN
677  e2 = 1
678  END IF
679  c2 = level2 * 10 ** e2
680  CALL sbyte(id8,c2,100,20)
681  e2 = ior(e2,msk2)
682  CALL sbyte(id8,e2,120,8)
683 C
684  ELSE IF (id(9) .EQ. 106) THEN
685  m = 2
686  s1 = 6
687  CALL sbyte(id8,s1,12,12)
688  CALL sbyte(id8,m,64,4)
689  CALL sbyte(id8,s1,76,12)
690  level = id(10)
691  level = (level * .1) * 10**2
692  IF (level .GE. 1 .AND. level .LE. 9) THEN
693  e1 = 4
694  ELSE IF (level .GE. 10 .AND. level .LE. 99) THEN
695  e1 = 3
696  ELSE IF (level .GE. 100 .AND. level .LE. 999) THEN
697  e1 = 2
698  ELSE IF (level .GE. 1000 .AND. level .LE. 9999) THEN
699  e1 = 1
700  END IF
701  c1 = level * 10 ** e1
702  CALL sbyte(id8,c1,36,20)
703  e1 = ior(e1,msk2)
704  CALL sbyte(id8,e1,56,8)
705  level2 = id(10)
706  level2 = (level2 * .1) * 10 ** 2
707  IF (level2 .GE. 1 .AND. level2 .LE. 9) THEN
708  e2 = 4
709  ELSE IF (level2 .GE. 10 .AND. level2 .LE. 99) THEN
710  e2 = 3
711  ELSE IF (level2 .GE. 100 .AND. level2 .LE. 999) THEN
712  e2 = 2
713  ELSE IF (level2 .GE. 1000 .AND. level2 .LE. 9999) THEN
714  e2 = 1
715  END IF
716  c2 = level2 * 10 ** e2
717  CALL sbyte(id8,c2,100,20)
718  e2 = ior(e2,msk2)
719  CALL sbyte(id8,e2,120,8)
720 C
721  ELSE IF (id(9) .EQ. 108) THEN
722  m = 2
723  s1 = 148
724 C**** S1 = 144 ALSO POSSIBILITY
725 C**** S1 = 145 ALSO POSSIBILITY
726  CALL sbyte(id8,s1,12,12)
727  CALL sbyte(id8,m,64,4)
728  CALL sbyte(id8,s1,76,12)
729  level = id(10)
730  level = level
731  IF (level .GE. 1 .AND. level .LE. 9) THEN
732  e1 = 4
733  ELSE IF (level .GE. 10 .AND. level .LE. 99) THEN
734  e1 = 3
735  ELSE IF (level .GE. 100 .AND. level .LE. 999) THEN
736  e1 = 2
737  ELSE IF (level .GE. 1000 .AND. level .LE. 9999) THEN
738  e1 = 1
739  END IF
740  c1 = level * (10 ** e1)
741  DO isi = 1,9
742  IF (c1 .EQ. icxgb2(isi)) THEN
743  c1 = icxg2(isi)
744  END IF
745  END DO
746  CALL sbyte(id8,c1,36,20)
747  IF (c1 .EQ. 0) THEN
748  e1 = 0
749  CALL sbyte(id8,e1,56,8)
750  GO TO 700
751  END IF
752 C*****TAKE SCALING INTO ACCOUNT .01
753  e1 = e1 + 2
754  e1 = ior(e1,msk2)
755  CALL sbyte(id8,e1,56,8)
756 C
757  700 CONTINUE
758  level2 = id(11)
759  level2 = level2
760  IF (level2 .GE. 1 .AND. level2 .LE. 9) THEN
761  e2 = 4
762  ELSE IF (level2 .GE. 10 .AND. level2 .LE. 99) THEN
763  e2 = 3
764  ELSE IF (level2 .GE. 100 .AND. level2 .LE. 999) THEN
765  e2 = 2
766  ELSE IF (level2 .GE. 1000 .AND. level2 .LE. 9999) THEN
767  e2 = 1
768  END IF
769  c2 = level2 * 10 ** e2
770  DO isi = 1,9
771  IF (c2 .EQ. icxgb2(isi)) THEN
772  c2 = icxg2(isi)
773  END IF
774  END DO
775  CALL sbyte(id8,c2,100,20)
776  e2 = ior(e2,msk2)
777  CALL sbyte(id8,e2,120,8)
778 C*******TAKE SCALING INTO ACCOUNT .01
779  e2 = e2 + 2
780  e2 = ior(e2,msk2)
781  CALL sbyte(id8,e2,120,8)
782 C
783  END IF
784 C 5.1 FORCAST TIMES ,PLUS THE T MARKER AND CM FIELD
785 C
786  tr = id(20)
787  IF (tr .EQ. 0) THEN
788  p1 = id(18)
789  CALL sbyte(id8,id(18),24,8)
790  ELSE IF (tr .EQ. 4) THEN
791  p2 = id(19)
792  CALL sbyte(id8,p2,24,8)
793  p1 = id(18)
794  CALL sbyte(id8,(p2 - p1),88,8)
795  t = 3
796  CALL sbyte(id8,t,32,4)
797  ELSE IF (tr .EQ. 5) THEN
798  p2 = id(19)
799  CALL sbyte(id8,p2,24,8)
800  p1 = id(18)
801  CALL sbyte(id8,(p2 - p1),88,8)
802  t = 3
803  CALL sbyte(id8,t,32,4)
804 C
805  ELSE IF (tr .EQ. 124) THEN
806  ftu = id(17)
807  IF (ftu .EQ. 2) THEN
808  f1 = id(21)
809  CALL sbyte(id8,f1,24,8)
810  t = 4
811  CALL sbyte(id8,t,32,4)
812  ELSE IF (ftu .EQ. 4) THEN
813  f2 = id(21)
814  CALL sbyte(id8,f2,88,8)
815  t = 4
816  CALL sbyte(id8,t,32,4)
817  END IF
818 C
819  ELSE IF (tr .EQ.123) THEN
820  f1 = 3
821  f1 = ior(f1,msk2)
822  CALL sbyte(id8,f1,24,8)
823  f2 = 5 * 2
824  CALL sbyte(id8,f2,88,8)
825  t = 6
826  CALL sbyte(id8,t,32,4)
827  rinc = 0.0
828  rinc(2) = 36.0
829  iyr=mova2i(pds(13))
830  print *, 'IYR = ', iyr
831  IF(iyr.LT.20)THEN
832  mdate(1)=2000+iyr
833  ELSE
834  mdate(1)=1900+iyr
835  ENDIF
836  mdate(2) = mova2i(pds(14))
837  mdate(3) = mova2i(pds(15))
838  mdate(5) = mova2i(pds(16))
839 C PRINT *, 'OLD DATE = ', MDATE(1), MDATE(2), MDATE(3), MDATE(5)
840 C PRINT *, 'CHANGE DATE BY - ', RINC(2)
841  CALL w3movdat(rinc,mdate,ndate)
842 C PRINT *, 'NEW DATE = ', NDATE(1), NDATE(2), NDATE(3), NDATE(5)
843 C CALL W3FS04 (IDATE,JDATE,3,IERR)
844  iyear = mod(ndate(1),100)
845  jwork(1) = char(iyear)
846  jwork(2) = char(ndate(2))
847  jwork(3) = char(ndate(3))
848  jwork(4) = char(ndate(5))
849  idate = jdate
850  GO TO 710
851 C
852  ELSE IF (tr .EQ.3) THEN
853  p1 = id(18)
854  p2 = id(19)
855  f1 = p1 / 12
856  CALL sbyte(id8,f1,24,8)
857 C
858 C ***** NAVG IS IN BITES 22 23 *****
859 C USING BITE 23 ONLY *******
860 C FIX LATER ******************************************
861 C
862 C NAVG = MOVA2I(PDS(23))
863  f2 = (p2 - p1) / 12
864  CALL sbyte(id8,f2,88,8)
865  t = 6
866  CALL sbyte(id8,t,32,4)
867  rinc = 0.0
868  rinc(2) = -36.0
869  iyr=mova2i(pds(13))
870  print *, 'IYR = ', iyr
871  IF(iyr.LT.20)THEN
872  mdate(1)=2000+iyr
873  ELSE
874  mdate(1)=1900+iyr
875  ENDIF
876  mdate(2) = mova2i(pds(14))
877  mdate(3) = mova2i(pds(15))
878  mdate(5) = mova2i(pds(16))
879 C PRINT *, 'OLD DATE = ', MDATE(1), MDATE(2), MDATE(3), MDATE(5)
880 C PRINT *, 'CHANGE DATE BY - ', RINC(2)
881  CALL w3movdat(rinc,mdate,ndate)
882 C PRINT *, 'NEW DATE = ', NDATE(1), NDATE(2), NDATE(3), NDATE(5)
883 C CALL W3FS04 (IDATE,JDATE,-3,IERR)
884  iyear = mod(ndate(1),100)
885  jwork(1) = char(iyear)
886  jwork(2) = char(ndate(2))
887  jwork(3) = char(ndate(3))
888  jwork(4) = char(ndate(5))
889  idate = jdate
890  GO TO 710
891  END IF
892 C
893 C$ 7.0 TRANSFER THE DATE
894 C
895  iwork(1) = pds(13)
896  iwork(2) = pds(14)
897  iwork(3) = pds(15)
898  iwork(4) = pds(16)
899 C
900  710 CONTINUE
901 C
902 C TEST FOR 64 BIT COMPUTER (CRAY)
903 C
904  IF (lw.EQ.8) idate = ishft(idate,-32)
905  CALL sbyte(id8,idate,192,32)
906 C
907  ierr = 0
908  RETURN
909  END
mova2i
integer function mova2i(a)
This Function copies a bit string from a Character*1 variable to an integer variable.
Definition: mova2i.f:25
sbyte
subroutine sbyte(IOUT, IN, ISKIP, NBYTE)
Definition: sbyte.f:12
w3fi01
subroutine w3fi01(LW)
Determines the number of bytes in a full word for the particular machine (IBM or cray).
Definition: w3fi01.f:19
w3fi69
subroutine w3fi69(PDS, ID)
Converts an edition 1 grib produce definition section (pds) to a 25, or 27 word integer array.
Definition: w3fi69.f:29
w3fp13
subroutine w3fp13(GRIB, PDS, ID8, IERR)
Converts GRIB version 1 formatted product definition section to an office note 84 id label.
Definition: w3fp13.f:46
w3movdat
subroutine w3movdat(rinc, idat, jdat)
This subprogram returns the date and time that is a given NCEP relative time interval from an NCEP ab...
Definition: w3movdat.f:24