NCEPLIBS-w3emc  2.11.0
w3fp12.f
Go to the documentation of this file.
1 C> @file
2 C> @brief Creates the product definition section
3 C> @author A.J. McClees @date 1991-07-30
4 
5 C> Formats the product definition section according to the
6 C> specifications set by WMO. Using o.n. 84 id's (1st 8 words)
7 C> as the input data. New subroutine corresponds to the revision
8 C> #1 of the WMO GRIB standards made march 15, 1991.
9 C>
10 C> ### Program History Log:
11 C> Date | Programmer | Comments
12 C> -----|------------|---------
13 C> 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.
14 C> 1992-01-06 | A.J. McClees | Delete paramater 202 (accumulated evap) and make parameter 57 (evaporation) the equivalent of o.n.84 117.
15 C> 1992-11-02 | Ralph Jones | Correction at same level as w3fp12() in v77w3lib on hds
16 C> 1993-03-29 | Ralph Jones | Add save statement
17 C> 1993-04-16 | Ralph Jones | Add 176, 177 lat, lon to tables
18 C> 1993-08-03 | Ralph Jones | Add 156 (cin), 204 (dswrf), 205 (dlwrf) 211 (uswrf), 212 (ulwrf) to tables
19 C> 1995-02-07 | Ralph Jones | Change pds byte 4, version number to 2.
20 C> 1995-07-14 | Ralph Jones | Correction for sfc lft x
21 C> 1998-03-10 | Boi Vuong | Remove the cdir$ integer=64 directive
22 C> 1998-12-21 | Stephen Gilbert | Replaced Function ICHAR with mova2i().
23 C> 1999-02-15 | B. Facey | Replace w3fs04 with w3movdat().
24 C> 1999-03-15 | Stephen Gilbert | Specified 8-byte integer array explicitly for ID8
25 C> 1999-03-22 | B. Facey | Remove the date recalculation for mean charts. this includes the previous change to w3movdat.
26 C>
27 C> @param[in] ID8 First 8 id workds (o.n.84) integer*4
28 C> @param[in] ICENT Century, 2 digits, for 1991 it is 20.
29 C> @param[in] IFLAG Indication of inclusion or omission of grid definition and/or bit map code character*1
30 C> @param[in] ISCALE 10 scaler integer*4
31 C> @param[out] IDPDS GRIB product definition section character*1 (28)
32 C> @param[out] IER
33 C> = 0 completed smoothly
34 C> = 1 Indicator parameter N.A. to GRIB
35 C> = 2 Level indicator N.A. to GRIB
36 C> = 3 Time range N.A. to GRIB notation
37 C> = 4 Layers or levels N.A. to GRIB
38 C>
39 C> @author A.J. McClees @date 1991-07-30
40  SUBROUTINE w3fp12(ID8, IFLAG, IDPDS, ICENT, ISCALE, IER)
41 C
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/
62 C
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)
69 C
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)
76 C
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/
111 C DATA MSK1 /Z'00000FFF'/,
112 C & MSK2 /Z'0FFFFF00'/,
113 C & MSK3 /Z'0000007F'/,
114 C & MSK4 /Z'00000080'/,
115 C & MSK5 /Z'F0000000'/,
116 C & MSK6 /Z'00000200'/,
117 C & MSK7 /Z'000000FF'/
118 C 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/
126 C
127 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
128 C
129 C$ 1.0 INITIALIZATION - NO. OF ENTRIES IN INDCATOR PARM.
130 C$ - NO. OF ENTRIES IN TYPE LEVEL
131 C
132  iq = 163
133 C
134 C$ 1.1 COPY O.N. 84 ID'S INTO WORK SPACE
135 C
136  DO 100 n = 1,4
137  idwk(n) = id8(n)
138  100 CONTINUE
139 C ---------------------------------------------------------------------
140 C 2.0 NO. OF OCTETS IN THE PDS IN THE FIRST 3
141 C$ 2.1 SET CNTR ID, DATA TYPE, GRID DEF AND FLAG
142 C
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
159 C
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)
179 C---------------------------------------------------------------------
180 C
181 C$ 3.0 FORM INDICATOR PARAMETER
182 C
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
188 C
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
195 C
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))
212 C
213 C N IS A SPECIAL TEST FOR WAVE HGTS, M AND KS ARE SPECIAL FOR
214 C ACCUMULATED PRECIP
215 C
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
223 C
224  IF (m .EQ. 0 .AND. q .EQ. 1) THEN
225  idpds(9) = char(210)
226  ENDIF
227 C
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
237 C
238 C$ 4.0 DETERMINE IF LAYERS OR LEVEL AND FORM TYPE
239 C
240 C ......... M = THE M MARKER FROM O.N.84 CHECK ABOVE
241 C ......... S1 = S1 TYPE OF SURFACE
242 C
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)
248 C
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)
254 C
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)
260 C
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)
266 C
267  ELSE IF (s1 .EQ. 7) THEN
268  idpds(10) = char(111)
269 C 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)
274 C
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)
280 C
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
292 C
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)
298 C
299 C SET LEVEL AND PARAMETER FOR MSL PRESSURE
300 C
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)
308 C
309  ELSE IF (s1 .EQ. 129) THEN
310  idpds(10) = char(1)
311  idpds(11) = char(0)
312  idpds(12) = char(0)
313 C
314  ELSE IF (s1 .EQ. 130) THEN
315  idpds(10) = char(7)
316  idpds(11) = char(0)
317  idpds(12) = char(0)
318 C
319  ELSE IF (s1 .EQ. 131) THEN
320  idpds(10) = char(6)
321  idpds(11) = char(0)
322  idpds(12) = char(0)
323 C
324  ELSE IF (s1 .EQ. 133) THEN
325  idpds(10) = char(1)
326  idpds(11) = char(0)
327  idpds(12) = char(0)
328 C
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)
340 C
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)
348 C
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)
356 C
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
365 C
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
375 C
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)
384 C
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)
391 C
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)
398 C
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)
405 C
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
422 C
423 C$ 6.0 DATE - YR.,MO,DA,& INITIAL HR AND CENTURY
424 C
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)
431 C---------------------------------------------------------------------
432 C
433 C$ OCTET (17) N.A. FROM O.N. 84 DATA
434 C
435 C$ 7.0 INDICATOR OF TIME UNIT, TIME RANGE 1 AND 2, AND TIME
436 C RANGE FLAG
437 C
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)
448 C
449  ELSE IF (t .EQ. 1) THEN
450  print 710, t, id8
451  ier = 3
452  RETURN
453 C
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
460 C
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
464 C
465  idpds(18) = char(1)
466 C CORRECTION FOR 00 HR FCST
467  itemp = f1 - f2
468  IF (itemp.LT.0) itemp = 0
469 C 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)
475 C
476  ELSE
477  idpds(18) = char(1)
478 C CORRECTION FOR 00 HR FCST
479  itemp = f1 - f2
480  IF (itemp.LT.0) itemp = 0
481 C 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
488 C
489  ELSE IF (t .EQ. 4) THEN
490 C
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)
499 C
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)
508 C
509  ENDIF
510 C
511  ELSE IF (t .EQ. 5) THEN
512  idpds(18) = char(1)
513 C CORRECTION FOR 00 HR FCST
514  itemp = f1 - f2
515  IF (itemp.LT.0) itemp = 0
516 C 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)
522 C
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)
531 C****CALCULATE NEW DATE BASED ON THE BEGINNING OF THE DATA IN MEAN
532 C INCR = (F1)
533 C IF (INCR.LT.0) THEN
534 C RINC=0
535 C RINC(2)=INCR
536 C PRINT *, 'INCR=',INCR
537 C CALL W3FS04 (IDWK(4),JDATE,INCR,IERR)
538 C IYR=ICHAR(LIDWK(25))
539 C PRINT *, 'IYR = ', IYR
540 C IF(IYR.LT.20)THEN
541 C MDATE(1)=2000+IYR
542 C ELSE
543 C MDATE(1)=1900+IYR
544 C ENDIF
545 C MDATE(2) = ICHAR(LIDWK(26))
546 C MDATE(3) = ICHAR(LIDWK(27))
547 C MDATE(4) = ICHAR(LIDWK(28))
548 C PRINT *, 'CHANGE DATE BY - ', RINC(2)
549 C CALL W3MOVDAT(RINC,MDATE,NDATE)
550 C PRINT *,'NEW DATE =',NDATE(1),NDATE(2),NDATE(3),NDATE(5)
551 C IYEAR = MOD(NDATE(1),100)
552 C LIDWK(25) = CHAR(IYEAR)
553 C LIDWK(26) = CHAR(NDATE(2))
554 C LIDWK(27) = CHAR(NDATE(3))
555 C LIDWK(28) = CHAR(NDATE(4))
556 C 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)
570 C*****THE NUMBER OF CASES AVERAGED IS ASSUMING ONE TIME A DAY
571 C L = (F2/2) + 1
572 C***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)
576 C
577  ELSE IF (t .EQ. 7) THEN
578  print 710, t, id8
579  ier = 3
580  RETURN
581 C
582  ELSE IF (t .EQ. 10) THEN
583  print 710, t, id8
584  ier = 3
585  RETURN
586 C
587  710 FORMAT (' W3FP12 (710) - NOT APPLICABLE (YET) TO GRIB. ',
588  & ', T = ',i2,/,
589  & ' O.N. 84 IDS ARE ',/,
590  & 1x,4(z16,' '))
591 C
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