NCEPLIBS-w3emc 2.12.0
Loading...
Searching...
No Matches
w3fp13.f
Go to the documentation of this file.
1C> @file
2C> @brief Convert GRIB PDS edition 1 to O.N. 84 ID.
3C> @author A.J. McClees @date 1991-10-07
4
5C> Converts GRIB version 1 formatted product definition
6C> section to an office note 84 id label. Formats all that is appli-
7C> cable in the first 8 words of O.N. 84. (caution ****see remarks)
8C>
9C> ### Program History Log:
10C> Date | Programmer | Comments
11C> -----|------------|---------
12C> 1991-10-07 | A.J. McClees | Initial
13C> 1992-01-06 | Ralph Jones | Convert to silicongraphics 3.3 fortran 77
14C> 1993-03-29 | Ralph Jones | Add save statement
15C> 1994-04-17 | Ralph Jones | Complete rewrite to use sbyte, make code portable, upgrade to on388
16C> 1994-05-05 | Ralph Jones | Correction in two tables
17C> 1996-08-02 | Ralph Jones | Error using T marker
18C> 1996-09-03 | Ralph Jones | Add mercator grids 8 and 53 to tables
19C> 1999-02-15 | B. Facey | Replace w3fs04 with w3movdat().
20C> 2002-10-15 | Boi Vuong | Replaced function ichar with mova2i()
21C>
22C> @param[in] GRIB GRIB section 0 read as character*8
23C> @param[in] PDS GRIB PDS section 1 read as character*1 PDS(*)
24C> @param[out] ID8 12 Integer*4 formatted O.N. 84 ID. 6 integer 64 bit words on cray
25C> @param[out] IERR
26C> 0 - Completed satisfactorily
27C> 1 - Grib block 0 not correct
28C> 2 - Length of pds not correct
29C> 3 - Could not match type indicator
30C> 4 - Grid type not in tables
31C> 5 - Could not match type level
32C> 6 - Could not interpret originator of code
33C>
34C> @note Some of the id's will not be exact to the o.n. 84
35C> for locating field on the dataset. These differences
36C> are mainly due to truncation errors with layers.
37C> For example: .18019 sig .47191 sig r h for 36.o hrs
38C> will convert to: .18000 sig .47000 sig r h for 36.0 hrs
39C> !!!!!!!the above id's now forced to be exact!!!!!!!!!
40C> If j the word count is greater then 32743, j is stored
41C> in the 12th id word. Bits 16-31 of the 8th id word are
42C> set to zero.
43C>
44C> @author A.J. McClees @date 1991-10-07
45 SUBROUTINE w3fp13 (GRIB, PDS, ID8, IERR )
46C
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)
57C
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
75C INTEGER S2
76 INTEGER T
77 INTEGER TR
78C
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 ( *)
86C
87 SAVE
88C
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))
95C
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/
123C
124 DATA igen / 7, 58, 66, 98/
125C
126C ########### NUMBERS FORCED AFTER CONVERTING FROM GRIB LAYER.
127C ICXG2 1.0000, .98230, .96470,
128C .85000, .84368, .47191,
129C .18017, .81573, .25011
130C #################
131C
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'/
135C
136C ########### NUMBERS CALCULATED BY GRIB LAYER.
137C ICXGB2 1.00000, .98000, .96000,
138C .85000, .84000, .47000,
139C .18000, .82000, .25000
140C #################
141C
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'/
145C
146C ########### NUMBERS FORCED AFTER CONVERTING FROM GRIB SINGLE.
147C ICXG1 .98230, .89671, .78483
148C .94316, .84367, .999.00, .25011
149C #################
150C
151 DATA icxg1 /z'00017FB6', z'00015E47', z'00013293',
152 a z'0001706C', z'0001498F', z'0000863C', z'000061B3'/
153C
154C ########### NUMBERS CALCULATED BY GRIB LAYER.
155C ICXGB1 .98230, .89670, .78480
156C .94320, .84370, 998.00, .25000
157C #################
158C
159 DATA icxgb1/z'00017FB6', z'00015E46', z'00013290',
160 a z'00017070', z'00014992', z'000185D8', z'000061A8'/
161C
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/
189C
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/
197C
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/
205C
206C DATA MSK1 /Z0000FFFF/,
207C & MSK2 /Z00000080/,
208C & MSK3 /Z00000000/,
209C & MSK4 /Z00000200/
210C CHANGE HEX TO DECIMAL TO MAKE SUBROUTINE MORE PORTABLE
211C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
212 DATA msk1 /65535/,
213 & msk2 /128/,
214 & msk3 /0/,
215 & msk4 /512/
216C
217C MAKE SECTION 0, PUT 'GRIB' IN ASCII
218C
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)
227C
228C CONVERT PDS INTO 25 INTEGER NUMBERS
229C
230 CALL w3fi69(pds,id)
231C
232C ID(1) = NUMBER OF BYTES IN PDS
233C ID(2) = PARAMETER TABLE VERSION NUMBER
234C ID(3) = IDENTIFICATION OF ORIGINATING CENTER
235C ID(4) = MODEL IDENTIFICATION (ALLOCATED BY ORIGINATING CENTER)
236C ID(5) = GRID IDENTIFICATION
237C ID(6) = 0 IF NO GDS SECTION, 1 IF GDS SECTION IS INCLUDED
238C ID(7) = 0 IF NO BMS SECTION, 1 IF BMS SECTION IS INCLUDED
239C ID(8) = INDICATOR OF PARAMETER AND UNITS
240C ID(9) = INDICATOR OF TYPE OF LEVEL OR LAYER
241C ID(10) = LEVEL 1
242C ID(11) = LEVEL 2
243C ID(12) = YEAR OF CENTURY
244C ID(13) = MONTH OF YEAR
245C ID(14) = DAY OF MONTH
246C ID(15) = HOUR OF DAY
247C ID(16) = MINUTE OF HOUR (IN MOST CASES SET TO 0)
248C ID(17) = FCST TIME UNIT
249C ID(18) = P1 PERIOD OF TIME
250C ID(19) = P2 PERIOD OF TIME
251C ID(20) = TIME RANGE INDICATOR
252C ID(21) = NUMBER INCLUDED IN AVERAGE
253C ID(22) = NUMBER MISSING FROM AVERAGES OR ACCUMULATIONS
254C ID(23) = CENTURY
255C ID(24) = IDENTIFICATION OF SUB-CENTER (TABLE 0 - PART 2)
256C ID(25) = SCALING POWER OF 10
257C
258C THE 1ST 8 32 BIT WORDS WITH THE OFFICE NOTE 84 ID'S ARE
259C IN 27 PARTS, SBYTE IS USED WITH BIT COUNTS TO MAKE THIS
260C DATA. THIS MAKE IT WORD SIZE INDEPENDENT, AND MAKES THIS
261C SUBROUTINE PORTABLE. TABLE WITH STARTING BITS IS NEXT.
262C THE STARTING BIT AND NO. OF BITS IS USED AS THE 3RD AND
263C 4TH PARAMETER FOR SBYTE. READ GBYTES DOCUMENT FROM NCAR
264C FOR INFORMATION ABOUT SBYTE. SEE PAGE 38, FIGURE 1, IN
265C OFFICE NOTE 84.
266C
267C NO. NAME STARTING BIT NO. OF BITS
268C -----------------------------------------
269C 1 Q 0 12
270C 2 S1 12 12
271C 3 F1 24 8
272C 4 T 32 4
273C 5 C1 36 20
274C 6 E1 56 8
275C 7 M 64 4
276C 8 X 68 8
277C 9 S2 76 12
278C 10 F2 88 8
279C 11 N 96 4
280C 12 C2 100 20
281C 13 E2 120 8
282C 14 CD 128 8
283C 15 CM 136 8
284C 16 KS 144 8
285C 17 K 152 8
286C 18 GES 160 4
287C 19 164 12
288C 20 NW 176 16
289C 21 YY 192 8
290C 22 MM 200 8
291C 23 DD 208 8
292C 24 II 216 8
293C 25 R 224 8
294C 26 G 232 8
295C 27 J 240 16
296C OR 27 J 352 32 J > 32743
297C----------------------------------------------
298C
299C$ 1.0 INITIALIZATION - NO. OF ENTRIES IN INDCATOR PARM.
300C$ - NO. OF ENTRIES IN TYPE LEVEL
301C$ - NO. OF ENTRIES IN CNTR PROD. DTA.
302C$ - INITIAL ZEROS IN O.N. 84 LABEL
303C
304 iq = 255
305 ic = 4
306 in = 34
307C
308C TEST FOR 32 OR 64 BIT COMPUTER (CRAY)
309C
310 CALL w3fi01(lw)
311 IF (lw.EQ.4) THEN
312 nwords = 12
313 ELSE
314 nwords = 6
315 END IF
316C
317C ZERO OUTPUT ARRAY
318C
319 DO n = 1,nwords
320 id8(n) = 0
321 END DO
322C
323C ---------------------------------------------------------------------
324C$ 2.0 VERIFY GRIB IN SECTION 0
325C
326 IF (.NOT. grib(1:4) .EQ. igrib(1:4)) THEN
327 ierr = 1
328 RETURN
329 END IF
330C
331C 2.1 VERIFY THE NO. OF OCTETS IN THE PDS
332C
333 IF (id(1).NE.28) THEN
334 ierr = 2
335 print *,'IERR = ',ierr,',LENGTH OF PDS = ',id(1)
336 RETURN
337 END IF
338C
339C$ 3.0 GENERATING MODEL, TYPE GRID, AND NO. OF GRID PTS.
340C
341C IF CENTER NOT U.S., STORE CENTER IN G MARKER
342C IF CENTER U.S. STORE MODEL NO. IN G MARKER
343C
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
349C
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
366C
367 350 CONTINUE
368C
369C COMPUTE R MARKER FROM MODEL NUMBERS FOR U.S. CENTER
370C
371C (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)
376C (NMC) run
377 ELSE IF (id(4).EQ.25) THEN
378 CALL sbyte(id8,1,224,8)
379C (RGL) run
380 ELSE IF (id(4).EQ.39.OR.id(4).EQ.64) THEN
381 CALL sbyte(id8,2,224,8)
382C (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)
389C (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)
394C (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)
398C (HCN) run
399 ELSE IF ( id(4).EQ.70) THEN
400 CALL sbyte(id8,6,224,8)
401C (RUC) run
402 ELSE IF ( id(4).EQ.86) THEN
403 CALL sbyte(id8,7,224,8)
404C Not applicable, set to 255
405 ELSE
406 CALL sbyte(id8,255,224,8)
407 END IF
408 END IF
409C
410C$ 4.0 FORM TYPE DATA PARAMETER
411C
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
425C
426 410 CONTINUE
427C
428C Q DATA TYPE, BITS 1-12
429C
430 CALL sbyte(id8,ll(iii),0,12)
431C
432C TEST FOR 32 OR 64 BIT COMPUTER (CRAY)
433C
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
441C
442C$ 5.0 FORM TYPE LEVEL
443C
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)
463C
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)
483C
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)
503C
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)
521C 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)
528C
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)
553C***********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)
560C
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)
566C LEVEL = ID(11)
567C******* CONSTANT VALUE OF 273.16 WILL HAVE TO BE INSERTED
568C LEVEL = IAND (IPDS(3),MSK1)
569C IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN
570C E1 = 4
571C ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN
572C E1 = 3
573C ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN
574C E1 = 2
575C ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN
576C E1 = 1
577C 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)
583C*************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)
589C
590 ELSE IF (id(9) .EQ. 1) THEN
591 m = 0
592 s1 = 129
593C***** S1 = 133 ALSO POSSIBILITY
594 CALL sbyte(id8,s1,12,12)
595 CALL sbyte(id8,0,64,32)
596C
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)
602C
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)
608C
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)
646C
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)
683C
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)
720C
721 ELSE IF (id(9) .EQ. 108) THEN
722 m = 2
723 s1 = 148
724C**** S1 = 144 ALSO POSSIBILITY
725C**** 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
752C*****TAKE SCALING INTO ACCOUNT .01
753 e1 = e1 + 2
754 e1 = ior(e1,msk2)
755 CALL sbyte(id8,e1,56,8)
756C
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)
778C*******TAKE SCALING INTO ACCOUNT .01
779 e2 = e2 + 2
780 e2 = ior(e2,msk2)
781 CALL sbyte(id8,e2,120,8)
782C
783 END IF
784C 5.1 FORCAST TIMES ,PLUS THE T MARKER AND CM FIELD
785C
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)
804C
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
818C
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))
839C PRINT *, 'OLD DATE = ', MDATE(1), MDATE(2), MDATE(3), MDATE(5)
840C PRINT *, 'CHANGE DATE BY - ', RINC(2)
841 CALL w3movdat(rinc,mdate,ndate)
842C PRINT *, 'NEW DATE = ', NDATE(1), NDATE(2), NDATE(3), NDATE(5)
843C 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
851C
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)
857C
858C ***** NAVG IS IN BITES 22 23 *****
859C USING BITE 23 ONLY *******
860C FIX LATER ******************************************
861C
862C 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))
879C PRINT *, 'OLD DATE = ', MDATE(1), MDATE(2), MDATE(3), MDATE(5)
880C PRINT *, 'CHANGE DATE BY - ', RINC(2)
881 CALL w3movdat(rinc,mdate,ndate)
882C PRINT *, 'NEW DATE = ', NDATE(1), NDATE(2), NDATE(3), NDATE(5)
883C 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
892C
893C$ 7.0 TRANSFER THE DATE
894C
895 iwork(1) = pds(13)
896 iwork(2) = pds(14)
897 iwork(3) = pds(15)
898 iwork(4) = pds(16)
899C
900 710 CONTINUE
901C
902C TEST FOR 64 BIT COMPUTER (CRAY)
903C
904 IF (lw.EQ.8) idate = ishft(idate,-32)
905 CALL sbyte(id8,idate,192,32)
906C
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