NCEPLIBS-w3emc 2.12.0
Loading...
Searching...
No Matches
w3fp12.f
Go to the documentation of this file.
1C> @file
2C> @brief Creates the product definition section
3C> @author A.J. McClees @date 1991-07-30
4
5C> Formats the product definition section according to the
6C> specifications set by WMO. Using o.n. 84 id's (1st 8 words)
7C> as the input data. New subroutine corresponds to the revision
8C> #1 of the WMO GRIB standards made march 15, 1991.
9C>
10C> ### Program History Log:
11C> Date | Programmer | Comments
12C> -----|------------|---------
13C> 1991-07-30 | A.J. McClees | New subroutine which formats the pds section from the o.n. 84 id's from the GRIB edition 1 dated march 15, 1991.
14C> 1992-01-06 | A.J. McClees | Delete paramater 202 (accumulated evap) and make parameter 57 (evaporation) the equivalent of o.n.84 117.
15C> 1992-11-02 | Ralph Jones | Correction at same level as w3fp12() in v77w3lib on hds
16C> 1993-03-29 | Ralph Jones | Add save statement
17C> 1993-04-16 | Ralph Jones | Add 176, 177 lat, lon to tables
18C> 1993-08-03 | Ralph Jones | Add 156 (cin), 204 (dswrf), 205 (dlwrf) 211 (uswrf), 212 (ulwrf) to tables
19C> 1995-02-07 | Ralph Jones | Change pds byte 4, version number to 2.
20C> 1995-07-14 | Ralph Jones | Correction for sfc lft x
21C> 1998-03-10 | Boi Vuong | Remove the cdir$ integer=64 directive
22C> 1998-12-21 | Stephen Gilbert | Replaced Function ICHAR with mova2i().
23C> 1999-02-15 | B. Facey | Replace w3fs04 with w3movdat().
24C> 1999-03-15 | Stephen Gilbert | Specified 8-byte integer array explicitly for ID8
25C> 1999-03-22 | B. Facey | Remove the date recalculation for mean charts. this includes the previous change to w3movdat.
26C>
27C> @param[in] ID8 First 8 id workds (o.n.84) integer*4
28C> @param[in] ICENT Century, 2 digits, for 1991 it is 20.
29C> @param[in] IFLAG Indication of inclusion or omission of grid definition and/or bit map code character*1
30C> @param[in] ISCALE 10 scaler integer*4
31C> @param[out] IDPDS GRIB product definition section character*1 (28)
32C> @param[out] IER
33C> = 0 completed smoothly
34C> = 1 Indicator parameter N.A. to GRIB
35C> = 2 Level indicator N.A. to GRIB
36C> = 3 Time range N.A. to GRIB notation
37C> = 4 Layers or levels N.A. to GRIB
38C>
39C> @author A.J. McClees @date 1991-07-30
40 SUBROUTINE w3fp12(ID8, IFLAG, IDPDS, ICENT, ISCALE, IER)
41C
42 INTEGER E1
43 INTEGER E2
44 INTEGER F1
45 INTEGER F2
46 DATA f1/0/, f2/0/
47 INTEGER HH (163)
48 INTEGER(8) ID8 ( 4)
49 INTEGER(8) IDWK ( 4)
50 INTEGER(8) MSK1,MSK2,MSK3,MSK4,MSK5,MSK6,MSK7
51 INTEGER ISIGN
52 INTEGER ISCALE
53 INTEGER ICENT
54 INTEGER LL (163)
55 INTEGER L
56 INTEGER M
57 INTEGER N
58 INTEGER Q
59 INTEGER S1
60 INTEGER T
61 DATA t/0/
62C
63 CHARACTER*1 IDPDS (28)
64 CHARACTER*1 IFLAG
65 CHARACTER*1 IHOLD ( 8)
66 CHARACTER*1 IPDS1 ( 8)
67 CHARACTER*1 KDATE ( 8)
68 CHARACTER*1 LIDWK (32)
69C
70 equivalence(idwk(1),lidwk(1))
71 equivalence(l,ipds1(1))
72 equivalence(nbytes,ihold(1))
73 equivalence(jdate,kdate(1))
74 REAL RINC(5)
75 INTEGER NDATE(8), MDATE(8)
76C
77 DATA ll / 8, 8, 9, 255, 255, 255, 1, 6, 255, 255,
78 & 16, 24, 19, 23, 20, 21, 17, 18, 255, 180,
79 & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255,
80 & 55, 50, 48, 56, 49, 57, 80, 81, 71, 255,
81 & 40, 42, 72, 74, 73, 255, 255, 255, 255, 255,
82 & 304, 305, 95, 88, 101, 89, 104, 255, 117, 255,
83 & 97, 98, 90, 105, 94, 255, 255, 93, 188, 255,
84 & 255, 255, 255, 211, 255, 255, 255, 255, 255, 255,
85 & 255, 384, 161, 255, 255, 169, 22, 255, 255, 255,
86 & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255,
87 & 255, 400, 389, 385, 388, 391, 386, 390, 402, 401,
88 & 404, 403, 204, 255, 255, 255, 255, 255, 255, 255,
89 & 255, 255, 195, 194, 255, 255, 255, 255, 255, 255,
90 & 255, 255, 112, 116, 114, 255, 103, 52, 255, 255,
91 & 255, 255, 119, 157, 158, 159, 255, 176, 177, 392,
92 & 192, 190, 199, 216, 189, 193, 191, 210, 198, 255,
93 & 255, 1, 255/
94 DATA hh / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,
95 & 11, 12, 13, 14, 15, 16, 17, 18, 19, 20,
96 & 21, 22, 23, 24, 25, 26, 27, 28, 29, 30,
97 & 31, 32, 33, 33, 34, 34, 35, 36, 37, 38,
98 & 39, 40, 41, 42, 43, 44, 45, 46, 47, 48,
99 & 49, 50, 51, 52, 53, 54, 55, 56, 57, 58,
100 & 59, 60, 61, 62, 63, 64, 65, 66, 67, 68,
101 & 69, 70, 71, 72, 73, 74, 75, 76, 77, 78,
102 & 79, 80, 81, 82, 83, 84, 85, 86, 87, 88,
103 & 89, 90, 91, 92, 93, 94, 95, 96, 97, 98,
104 & 99, 100, 101, 102, 103, 104, 105, 106, 107, 108,
105 & 109, 110, 111, 112, 113, 114, 115, 116, 117, 118,
106 & 119, 120, 121, 122, 123, 124, 125, 126, 127, 128,
107 & 129, 130, 131, 132, 133, 134, 135, 136, 137, 150,
108 & 151, 152, 156, 157, 158, 159, 175, 176, 177, 201,
109 & 204, 205, 207, 208, 209, 211, 212, 213, 216, 218,
110 & 220, 222, 255/
111C DATA MSK1 /Z'00000FFF'/,
112C & MSK2 /Z'0FFFFF00'/,
113C & MSK3 /Z'0000007F'/,
114C & MSK4 /Z'00000080'/,
115C & MSK5 /Z'F0000000'/,
116C & MSK6 /Z'00000200'/,
117C & MSK7 /Z'000000FF'/
118C CHANGE HEX TO DECIMAL TO MAKE SUBROUTINE MORE PORTABLE
119 DATA msk1 /4095/,
120 & msk2 /268435200/,
121 & msk3 /127/,
122 & msk4 /128/,
123 & msk5 /z'00000000F0000000'/
124 & msk6 /512/,
125 & msk7 /255/
126C
127C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
128C
129C$ 1.0 INITIALIZATION - NO. OF ENTRIES IN INDCATOR PARM.
130C$ - NO. OF ENTRIES IN TYPE LEVEL
131C
132 iq = 163
133C
134C$ 1.1 COPY O.N. 84 ID'S INTO WORK SPACE
135C
136 DO 100 n = 1,4
137 idwk(n) = id8(n)
138 100 CONTINUE
139C ---------------------------------------------------------------------
140C 2.0 NO. OF OCTETS IN THE PDS IN THE FIRST 3
141C$ 2.1 SET CNTR ID, DATA TYPE, GRID DEF AND FLAG
142C
143 nbytes = 28
144 idpds(1) = ihold(6)
145 idpds(2) = ihold(7)
146 idpds(3) = ihold(8)
147 idpds(4) = char(2)
148 idpds(5) = char(7)
149 idpds(6) = lidwk(30)
150 jscale = iscale
151 IF (jscale.LT.0) THEN
152 jscale = -jscale
153 idpds(27) = char(128)
154 idpds(28) = char(jscale)
155 ELSE
156 idpds(27) = char(0)
157 idpds(28) = char(jscale)
158 END IF
159C
160 IF (lidwk(30) .EQ. char(69)) THEN
161 IF (lidwk(29) .EQ. char(3)) THEN
162 idpds(6) = char(68)
163 ELSE IF (lidwk(29) .EQ. char(4)) THEN
164 idpds(6) = char(69)
165 ENDIF
166 ENDIF
167 IF (lidwk(30) .EQ. char(78)) THEN
168 IF (lidwk(29) .EQ. char(3)) THEN
169 idpds(6) = char(77)
170 ELSE IF (lidwk(29) .EQ. char(4)) THEN
171 idpds(6) = char(78)
172 ENDIF
173 ENDIF
174 idpds(7) = lidwk(20)
175 IF (lidwk(20) .EQ. char(26)) idpds(7) = char(6)
176 idpds(8) = iflag
177 idpds(24) = char(0)
178 idpds(26) = char(0)
179C---------------------------------------------------------------------
180C
181C$ 3.0 FORM INDICATOR PARAMETER
182C
183 q = ishft(idwk(1),-52_8)
184 DO 300 i = 1,iq
185 ii = i
186 IF (q .EQ. ll(i)) GO TO 310
187 300 CONTINUE
188C
189 ier = 1
190 print 320, ier, q, id8
191 320 FORMAT (' W3FP12 (320) - IER = ',i2,', Q = ',i3,/,
192 & ' OFFICE NOTE 84 PARAMETER N.A. IN GRIB',
193 & /,1x,4(z16,' '))
194 RETURN
195C
196 310 i = ii
197 s1 = iand(ishft(idwk(1),-40_8),msk1)
198 c1 = ishft(iand(idwk(1),msk2),-8_8)
199 isig1 = iand(idwk(1),msk4)
200 e1 = iand(idwk(1),msk3)
201 IF (isig1 .NE. 0) e1 = -e1
202 m = ishft(iand(ishft(idwk(2),-32_8),msk5),-28_8)
203 n = ishft(iand(idwk(2),msk5),-28_8)
204 ks = ishft(iand(ishft(idwk(3),-32_8),msk6),-8_8)
205 IF (m.NE.0) THEN
206 c2 = ishft(iand(idwk(2),msk2),-8_8)
207 isig2 = iand(idwk(2),msk4)
208 e2 = iand(idwk(2),msk3)
209 IF (isig2 .NE. 0) e2 = -e2
210 ENDIF
211 idpds(9) = char(hh(i))
212C
213C N IS A SPECIAL TEST FOR WAVE HGTS, M AND KS ARE SPECIAL FOR
214C ACCUMULATED PRECIP
215C
216 IF (n .EQ. 5 .AND. q .EQ. 1) THEN
217 idpds(9) = char(222)
218 ENDIF
219 IF (ks .EQ. 2) THEN
220 IF (m .EQ. 0 .AND. q .EQ. 8) THEN
221 idpds(9) = char(211)
222 END IF
223C
224 IF (m .EQ. 0 .AND. q .EQ. 1) THEN
225 idpds(9) = char(210)
226 ENDIF
227C
228 IF (m .EQ. 1 .AND. q .EQ. 1) THEN
229 ier = 1
230 print 330, ier, id8
231 330 FORMAT (' W3FP12 (330) - IER =',i2,/,
232 & ' OFFICE NOTE 84 PARAMETER N.A. IN GRIB',
233 & /,1x,4(z16,' '))
234 RETURN
235 ENDIF
236 ENDIF
237C
238C$ 4.0 DETERMINE IF LAYERS OR LEVEL AND FORM TYPE
239C
240C ......... M = THE M MARKER FROM O.N.84 CHECK ABOVE
241C ......... S1 = S1 TYPE OF SURFACE
242C
243 IF (m .EQ. 0) THEN
244 IF (s1.EQ.0.AND.(q.EQ.176.OR.q.EQ.177)) THEN
245 idpds(10) = char(0)
246 idpds(11) = char(0)
247 idpds(12) = char(0)
248C
249 ELSE IF (s1 .EQ. 8) THEN
250 idpds(10) = char(100)
251 l = c1 * (10. ** e1) + .5
252 idpds(11) = ipds1(7)
253 idpds(12) = ipds1(8)
254C
255 ELSE IF (s1 .EQ. 1) THEN
256 idpds(10) = char(103)
257 l = c1 * (10. ** e1) + .5
258 idpds(11) = ipds1(7)
259 idpds(12) = ipds1(8)
260C
261 ELSE IF (s1 .EQ. 6) THEN
262 idpds(10) = char(105)
263 l = c1 * (10. ** e1) + .5
264 idpds(11) = ipds1(7)
265 idpds(12) = ipds1(8)
266C
267 ELSE IF (s1 .EQ. 7) THEN
268 idpds(10) = char(111)
269C CONVERT FROM METERS TO CENTIMETERS
270 IF (isig1 .NE. 0) e1 = e1 + 2
271 l = c1 * (10. ** e1) + .5
272 idpds(11) = ipds1(7)
273 idpds(12) = ipds1(8)
274C
275 ELSE IF (s1.EQ.148 .OR. s1 .EQ. 144 .OR. s1 .EQ. 145) THEN
276 idpds(10) = char(107)
277 l = (c1 * (10. ** e1) * 10**4) + .5
278 idpds(11) = ipds1(7)
279 idpds(12) = ipds1(8)
280C
281 ELSE IF (s1 .EQ. 16) THEN
282 l = c1 * (10. ** e1) + .5
283 IF (l .EQ. 273) THEN
284 idpds(10) = char(4)
285 idpds(11) = char(0)
286 idpds(12) = char(0)
287 ELSE
288 ier = 2
289 print 410, ier, s1, id8
290 RETURN
291 ENDIF
292C
293 ELSE IF (s1 .EQ. 19) THEN
294 l = c1 * (10. ** e1) + .5
295 idpds(10) = char(113)
296 idpds(11) = ipds1(7)
297 idpds(12) = ipds1(8)
298C
299C SET LEVEL AND PARAMETER FOR MSL PRESSURE
300C
301 ELSE IF (s1 .EQ. 128) THEN
302 IF (q.EQ.8) THEN
303 idpds(9) = char(2)
304 END IF
305 idpds(10) = char(102)
306 idpds(11) = char(0)
307 idpds(12) = char(0)
308C
309 ELSE IF (s1 .EQ. 129) THEN
310 idpds(10) = char(1)
311 idpds(11) = char(0)
312 idpds(12) = char(0)
313C
314 ELSE IF (s1 .EQ. 130) THEN
315 idpds(10) = char(7)
316 idpds(11) = char(0)
317 idpds(12) = char(0)
318C
319 ELSE IF (s1 .EQ. 131) THEN
320 idpds(10) = char(6)
321 idpds(11) = char(0)
322 idpds(12) = char(0)
323C
324 ELSE IF (s1 .EQ. 133) THEN
325 idpds(10) = char(1)
326 idpds(11) = char(0)
327 idpds(12) = char(0)
328C
329 ELSE IF (s1 .EQ. 136) THEN
330 IF (q.EQ.8) THEN
331 IF (t.EQ.2.AND.f1.EQ.0.AND.f2.EQ.3) THEN
332 idpds(9) = char(137)
333 ELSE
334 idpds(9) = char(128)
335 END IF
336 END IF
337 idpds(10) = char(102)
338 idpds(11) = char(0)
339 idpds(12) = char(0)
340C
341 ELSE IF (s1 .EQ. 137) THEN
342 IF (q.EQ.8) THEN
343 idpds(9) = char(129)
344 END IF
345 idpds(10) = char(102)
346 idpds(11) = char(0)
347 idpds(12) = char(0)
348C
349 ELSE IF (s1 .EQ. 138) THEN
350 IF (q.EQ.8) THEN
351 idpds(9) = char(130)
352 END IF
353 idpds(10) = char(102)
354 idpds(11) = char(0)
355 idpds(12) = char(0)
356C
357 ELSE
358 ier = 2
359 print 410, ier, s1, id8
360 410 FORMAT (' W3FP12 (410) - IER = ',i2,', S1 = ',i5,/,
361 & ' SURFACE TYPE N.A. IN GRIB',/,' ID8 = ',
362 & 4(z16,' '))
363 RETURN
364 ENDIF
365C
366 ELSE IF (m .EQ. 1) THEN
367 IF ((s1 .EQ. 8) .AND. (q .EQ. 1)) THEN
368 idpds(9) = char(101)
369 idpds(10) = char(101)
370 jjj = ((c1 * 10. ** e1) * .1) + .5
371 idpds(11) = char(jjj)
372 kkk = ((c2 * 10. ** e2) * .1) + .5
373 idpds(12) = char(kkk)
374 END IF
375C
376 ELSE IF (m .EQ. 2) THEN
377 IF (s1 .EQ. 8) THEN
378 idpds(10) = char(101)
379 jjj = ((c1 * 10. ** e1) * .1) + .5
380 idpds(11) = char(jjj)
381 kkk = ((c2 * 10. ** e2) * .1) + .5
382 idpds(12) = char(kkk)
383 IF (idpds(9) .EQ. char(131)) idpds(12) = char(100)
384C
385 ELSE IF (s1 .EQ. 1) THEN
386 idpds(10) = char(104)
387 jjj = ((c1 * 10. ** e1) * .1) + .5
388 idpds(11) = char(jjj)
389 kkk = ((c2 * 10. ** e2) * .1) + .5
390 idpds(12) = char(kkk)
391C
392 ELSE IF (s1 .EQ. 6) THEN
393 idpds(10) = char(106)
394 jjj = ((c1 * 10. ** e1) * .1) + .5
395 idpds(11) = char(jjj)
396 kkk = ((c2 * 10. ** e2) * .1) + .5
397 idpds(12) = char(kkk)
398C
399 ELSE IF (s1.EQ.148 .OR. s1 .EQ. 144 .OR. s1 .EQ. 145) THEN
400 idpds(10) = char(108)
401 jjj = ((c1 * 10. ** e1) * 10**2) + .5
402 idpds(11) = char(jjj)
403 kkk = ((c2 * 10. ** e2) * 10**2) + .5
404 idpds(12) = char(kkk)
405C
406 ELSE
407 ier = 2
408 print 420, ier, s1, id8
409 420 FORMAT (' W3FP12 (420) - IER = ',i2,', S1 = ',i5,/,
410 & ' SURFACE LAYERS N.A. IN GRIB',
411 & /,' ID8= ',4(z16,' '))
412 RETURN
413 ENDIF
414 ELSE IF (m .GT. 2) THEN
415 ier = 4
416 print 500, ier, m, id8
417 500 FORMAT ('W3FP12 (500) - IER = ',i2,', M = ',/,
418 & ' THE M FROM O.N. 84 N.A. IN GRIB',
419 & /,' ID8 = ',4(z16,' '))
420 RETURN
421 ENDIF
422C
423C$ 6.0 DATE - YR.,MO,DA,& INITIAL HR AND CENTURY
424C
425 idpds(13) = lidwk(25)
426 idpds(14) = lidwk(26)
427 idpds(15) = lidwk(27)
428 idpds(16) = lidwk(28)
429 idpds(17) = char(0)
430 idpds(25) = char(icent)
431C---------------------------------------------------------------------
432C
433C$ OCTET (17) N.A. FROM O.N. 84 DATA
434C
435C$ 7.0 INDICATOR OF TIME UNIT, TIME RANGE 1 AND 2, AND TIME
436C RANGE FLAG
437C
438 t = ishft((iand(idwk(1),msk5)),-28_8)
439 f1 = iand(ishft(idwk(1),-32_8),msk7)
440 f2 = iand(ishft(idwk(2),-32_8),msk7)
441 IF (t .EQ. 0) THEN
442 idpds(18) = char(1)
443 idpds(19) = char(f1)
444 idpds(20) = char(0)
445 idpds(21) = char(0)
446 idpds(22) = char(0)
447 idpds(23) = char(0)
448C
449 ELSE IF (t .EQ. 1) THEN
450 print 710, t, id8
451 ier = 3
452 RETURN
453C
454 ELSE IF (t .EQ. 2) THEN
455 IF (mova2i(idpds(9)).NE.137) THEN
456 print 710, t, id8
457 ier = 3
458 RETURN
459 END IF
460C
461 ELSE IF (t .EQ. 3) THEN
462 IF (q .EQ. 89 .OR. q .EQ. 90 .OR. q .EQ. 94
463 & .OR. q .EQ. 105) THEN
464C
465 idpds(18) = char(1)
466C CORRECTION FOR 00 HR FCST
467 itemp = f1 - f2
468 IF (itemp.LT.0) itemp = 0
469C IDPDS(19) = CHAR (F1 - F2)
470 idpds(19) = char(itemp)
471 idpds(20) = char(f1)
472 idpds(21) = char(4)
473 idpds(22) = char(0)
474 idpds(23) = char(0)
475C
476 ELSE
477 idpds(18) = char(1)
478C CORRECTION FOR 00 HR FCST
479 itemp = f1 - f2
480 IF (itemp.LT.0) itemp = 0
481C IDPDS(19) = CHAR (F1 - F2)
482 idpds(19) = char(itemp)
483 idpds(20) = char(f1)
484 idpds(21) = char(5)
485 idpds(22) = char(0)
486 idpds(23) = char(0)
487 END IF
488C
489 ELSE IF (t .EQ. 4) THEN
490C
491 IF (f1 .EQ. 0 .AND. f2 .NE. 0) THEN
492 idpds(18) = char(4)
493 idpds(19) = char(0)
494 idpds(20) = char(1)
495 idpds(21) = char(124)
496 l = f2
497 idpds(22) = ipds1(7)
498 idpds(23) = ipds1(8)
499C
500 ELSE IF (f1 .NE. 0 .AND. f2 .EQ. 0) THEN
501 idpds(18) = char(2)
502 idpds(19) = char(0)
503 idpds(20) = char(1)
504 idpds(21) = char(124)
505 l = f1
506 idpds(22) = ipds1(7)
507 idpds(23) = ipds1(8)
508C
509 ENDIF
510C
511 ELSE IF (t .EQ. 5) THEN
512 idpds(18) = char(1)
513C CORRECTION FOR 00 HR FCST
514 itemp = f1 - f2
515 IF (itemp.LT.0) itemp = 0
516C IDPDS(19) = CHAR (F1 - F2)
517 idpds(19) = char(itemp)
518 idpds(20) = char(f1)
519 idpds(21) = char(2)
520 idpds(22) = char(0)
521 idpds(23) = char(0)
522C
523 ELSE IF (t .EQ. 6) THEN
524 jsign = iand(ishft(idwk(1),-32_8),msk4)
525 jsigo = iand(ishft(idwk(2),-32_8),msk4)
526 f1 = iand(ishft(idwk(1),-32_8),msk3)
527 f2 = iand(ishft(idwk(2),-32_8),msk3)
528 IF (jsign .NE. 0) f1 = -f1
529 IF (jsigo .NE. 0) f2 = -f2
530 idpds(18) = char(1)
531C****CALCULATE NEW DATE BASED ON THE BEGINNING OF THE DATA IN MEAN
532C INCR = (F1)
533C IF (INCR.LT.0) THEN
534C RINC=0
535C RINC(2)=INCR
536C PRINT *, 'INCR=',INCR
537C CALL W3FS04 (IDWK(4),JDATE,INCR,IERR)
538C IYR=ICHAR(LIDWK(25))
539C PRINT *, 'IYR = ', IYR
540C IF(IYR.LT.20)THEN
541C MDATE(1)=2000+IYR
542C ELSE
543C MDATE(1)=1900+IYR
544C ENDIF
545C MDATE(2) = ICHAR(LIDWK(26))
546C MDATE(3) = ICHAR(LIDWK(27))
547C MDATE(4) = ICHAR(LIDWK(28))
548C PRINT *, 'CHANGE DATE BY - ', RINC(2)
549C CALL W3MOVDAT(RINC,MDATE,NDATE)
550C PRINT *,'NEW DATE =',NDATE(1),NDATE(2),NDATE(3),NDATE(5)
551C IYEAR = MOD(NDATE(1),100)
552C LIDWK(25) = CHAR(IYEAR)
553C LIDWK(26) = CHAR(NDATE(2))
554C LIDWK(27) = CHAR(NDATE(3))
555C LIDWK(28) = CHAR(NDATE(4))
556C END IF
557 idpds(13) = lidwk(25)
558 idpds(14) = lidwk(26)
559 idpds(15) = lidwk(27)
560 idpds(16) = lidwk(28)
561 IF (f1.LT.0) THEN
562 idpds(19) = char(0)
563 idpds(21) = char(123)
564 ELSE
565 nf1 = f1 * 12
566 idpds(19) = char(nf1)
567 idpds(21) = char(113)
568 END IF
569 idpds(20) = char(24)
570C*****THE NUMBER OF CASES AVERAGED IS ASSUMING ONE TIME A DAY
571C L = (F2/2) + 1
572C***THE ABOVE CALCULATION WOULD BE CORR. IF ID8(3) WERE CORR.
573 l = (f2+1) / 2
574 idpds(22) = ipds1(7)
575 idpds(23) = ipds1(8)
576C
577 ELSE IF (t .EQ. 7) THEN
578 print 710, t, id8
579 ier = 3
580 RETURN
581C
582 ELSE IF (t .EQ. 10) THEN
583 print 710, t, id8
584 ier = 3
585 RETURN
586C
587 710 FORMAT (' W3FP12 (710) - NOT APPLICABLE (YET) TO GRIB. ',
588 & ', T = ',i2,/,
589 & ' O.N. 84 IDS ARE ',/,
590 & 1x,4(z16,' '))
591C
592 ENDIF
593 ier = 0
594 RETURN
595 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
w3fp12
subroutine w3fp12(id8, iflag, idpds, icent, iscale, ier)
Formats the product definition section according to the specifications set by WMO.
Definition w3fp12.f:41