NCEPLIBS-w3emc  2.11.0
w3fi74.f
Go to the documentation of this file.
1 C> @file
2 C> @brief Construct Grid Definition Section (GDS).
3 C> @author M. Farley @date 1992-07-07
4 
5 C> This subroutine constructs a GRIB grid definition section.
6 C>
7 C> @note Subprogram can be called from a multiprocessing environment.
8 C>
9 C> @param[in] IGDS Integer array supplied by w3fi71().
10 C> @param[in] ICOMP Table 7- resolution & component flag (bit 5)
11 C> for gds(17) wind components.
12 C> @param[out] GDS Completed grib grid definition section.
13 C> @param[out] LENGDS Length of gds.
14 C> @param[out] NPTS Number of points in grid.
15 C> @param[out] IGERR 1, grid representation type not valid.
16 C>
17 C> @author M. Farley @date 1992-07-07
18  SUBROUTINE w3fi74 (IGDS,ICOMP,GDS,LENGDS,NPTS,IGERR)
19 C
20  INTEGER IGDS (*)
21 C
22  CHARACTER*1 GDS (*)
23 C
24  isum = 0
25  igerr = 0
26 C
27 C PRINT *,' '
28 C PRINT *,'(W3FI74-IGDS = )'
29 C PRINT *,(IGDS(I),I=1,18)
30 C PRINT *,' '
31 C
32 C COMPUTE LENGTH OF GDS IN OCTETS (OCTETS 1-3)
33 C LENGDS = 32 FOR LAT/LON, GNOMIC, GAUSIAN LAT/LON,
34 C POLAR STEREOGRAPHIC, SPHERICAL HARMONICS,
35 C ROTATED LAT/LON E-STAGGER
36 C LENGDS = 34 ROTATED LAT/LON A,B,C,D STAGGERS
37 C LENGDS = 42 FOR MERCATOR, LAMBERT, TANGENT CONE
38 C LENGDS = 178 FOR MERCATOR, LAMBERT, TANGENT CONE
39 C
40  IF (igds(3) .EQ. 0 .OR. igds(3) .EQ. 2 .OR.
41  & igds(3) .EQ. 4 .OR. igds(3) .EQ. 5 .OR.
42  & igds(3) .EQ. 50 .OR. igds(3) .EQ. 201.OR.
43  & igds(3) .EQ. 202.OR. igds(3) .EQ. 203.OR.
44  & igds(3) .EQ. 204 ) THEN
45  lengds = 32
46 C
47 C CORRECTION FOR GRIDS 37-44
48 C
49  IF (igds(3).EQ.0.AND.igds(1).EQ.0.AND.igds(2).NE.
50  & 255) THEN
51  lengds = igds(5) * 2 + 32
52  ENDIF
53  ELSE IF (igds(3) .EQ. 1 .OR. igds(3) .EQ. 3 .OR.
54  & igds(3) .EQ. 13) THEN
55  lengds = 42
56  ELSE IF (igds(3) .EQ. 205) THEN
57  lengds = 34
58  ELSE
59 C PRINT *,' W3FI74 ERROR, GRID REPRESENTATION TYPE NOT VALID'
60  igerr = 1
61  RETURN
62  ENDIF
63 C
64 C PUT LENGTH OF GDS SECTION IN BYTES 1,2,3
65 C
66  gds(1) = char(mod(lengds/65536,256))
67  gds(2) = char(mod(lengds/ 256,256))
68  gds(3) = char(mod(lengds ,256))
69 C
70 C OCTET 4 = NV, NUMBER OF VERTICAL COORDINATE PARAMETERS
71 C OCTET 5 = PV, PL OR 255
72 C OCTET 6 = DATA REPRESENTATION TYPE (TABLE 6)
73 C
74  gds(4) = char(igds(1))
75  gds(5) = char(igds(2))
76  gds(6) = char(igds(3))
77 C
78 C FILL OCTET THE REST OF THE GDS BASED ON DATA REPRESENTATION
79 C TYPE (TABLE 6)
80 C
81 C$$
82 C PROCESS ROTATED LAT/LON A,B,C,D STAGGERS
83 C
84  IF (igds(3).EQ.205) THEN
85  gds( 7) = char(mod(igds(4)/256,256))
86  gds( 8) = char(mod(igds(4) ,256))
87  gds( 9) = char(mod(igds(5)/256,256))
88  gds(10) = char(mod(igds(5) ,256))
89  lato = igds(6) ! LAT OF FIRST POINT
90  IF (lato .LT. 0) THEN
91  lato = -lato
92  lato = ior(lato,8388608)
93  ENDIF
94  gds(11) = char(mod(lato/65536,256))
95  gds(12) = char(mod(lato/ 256,256))
96  gds(13) = char(mod(lato ,256))
97  lono = igds(7) ! LON OF FIRST POINT
98  IF (lono .LT. 0) THEN
99  lono = -lono
100  lono = ior(lono,8388608)
101  ENDIF
102  gds(14) = char(mod(lono/65536,256))
103  gds(15) = char(mod(lono/ 256,256))
104  gds(16) = char(mod(lono ,256))
105  latext = igds(9) ! CENTER LAT
106  IF (latext .LT. 0) THEN
107  latext = -latext
108  latext = ior(latext,8388608)
109  ENDIF
110  gds(18) = char(mod(latext/65536,256))
111  gds(19) = char(mod(latext/ 256,256))
112  gds(20) = char(mod(latext ,256))
113  lonext = igds(10) ! CENTER LON
114  IF (lonext .LT. 0) THEN
115  lonext = -lonext
116  lonext = ior(lonext,8388608)
117  ENDIF
118  gds(21) = char(mod(lonext/65536,256))
119  gds(22) = char(mod(lonext/ 256,256))
120  gds(23) = char(mod(lonext ,256))
121  gds(24) = char(mod(igds(11)/256,256))
122  gds(25) = char(mod(igds(11) ,256))
123  gds(26) = char(mod(igds(12)/256,256))
124  gds(27) = char(mod(igds(12) ,256))
125  gds(28) = char(igds(13))
126  lato = igds(14) ! LAT OF LAST POINT
127  IF (lato .LT. 0) THEN
128  lato = -lato
129  lato = ior(lato,8388608)
130  ENDIF
131  gds(29) = char(mod(lato/65536,256))
132  gds(30) = char(mod(lato/ 256,256))
133  gds(31) = char(mod(lato ,256))
134  lono = igds(15) ! LON OF LAST POINT
135  IF (lono .LT. 0) THEN
136  lono = -lono
137  lono = ior(lono,8388608)
138  ENDIF
139  gds(32) = char(mod(lono/65536,256))
140  gds(33) = char(mod(lono/ 256,256))
141  gds(34) = char(mod(lono ,256))
142 C
143 C PROCESS LAT/LON GRID TYPES OR GAUSSIAN GRID OR ARAKAWA
144 C STAGGERED, SEMI-STAGGERED, OR FILLED E-GRIDS
145 C
146  ELSEIF (igds(3).EQ.0.OR.igds(3).EQ.4.OR.
147  & igds(3).EQ.201.OR.igds(3).EQ.202.OR.
148  & igds(3).EQ.203.OR.igds(3).EQ.204) THEN
149  gds( 7) = char(mod(igds(4)/256,256))
150  gds( 8) = char(mod(igds(4) ,256))
151  gds( 9) = char(mod(igds(5)/256,256))
152  gds(10) = char(mod(igds(5) ,256))
153  lato = igds(6)
154  IF (lato .LT. 0) THEN
155  lato = -lato
156  lato = ior(lato,8388608)
157  ENDIF
158  gds(11) = char(mod(lato/65536,256))
159  gds(12) = char(mod(lato/ 256,256))
160  gds(13) = char(mod(lato ,256))
161  lono = igds(7)
162  IF (lono .LT. 0) THEN
163  lono = -lono
164  lono = ior(lono,8388608)
165  ENDIF
166  gds(14) = char(mod(lono/65536,256))
167  gds(15) = char(mod(lono/ 256,256))
168  gds(16) = char(mod(lono ,256))
169  latext = igds(9)
170  IF (latext .LT. 0) THEN
171  latext = -latext
172  latext = ior(latext,8388608)
173  ENDIF
174  gds(18) = char(mod(latext/65536,256))
175  gds(19) = char(mod(latext/ 256,256))
176  gds(20) = char(mod(latext ,256))
177  lonext = igds(10)
178  IF (lonext .LT. 0) THEN
179  lonext = -lonext
180  lonext = ior(lonext,8388608)
181  ENDIF
182  gds(21) = char(mod(lonext/65536,256))
183  gds(22) = char(mod(lonext/ 256,256))
184  gds(23) = char(mod(lonext ,256))
185  ires = iand(igds(8),128)
186  IF (igds(3).EQ.201.OR.igds(3).EQ.202.OR.
187  & igds(3).EQ.203.OR.igds(3).EQ.204) THEN
188  gds(24) = char(mod(igds(11)/256,256))
189  gds(25) = char(mod(igds(11) ,256))
190  ELSE IF (ires.EQ.0) THEN
191  gds(24) = char(255)
192  gds(25) = char(255)
193  ELSE
194  gds(24) = char(mod(igds(12)/256,256))
195  gds(25) = char(mod(igds(12) ,256))
196  END IF
197  IF (igds(3).EQ.4) THEN
198  gds(26) = char(mod(igds(11)/256,256))
199  gds(27) = char(mod(igds(11) ,256))
200  ELSE IF (igds(3).EQ.201.OR.igds(3).EQ.202.OR.
201  & igds(3).EQ.203.OR.igds(3).EQ.204)THEN
202  gds(26) = char(mod(igds(12)/256,256))
203  gds(27) = char(mod(igds(12) ,256))
204  ELSE IF (ires.EQ.0) THEN
205  gds(26) = char(255)
206  gds(27) = char(255)
207  ELSE
208  gds(26) = char(mod(igds(11)/256,256))
209  gds(27) = char(mod(igds(11) ,256))
210  END IF
211  gds(28) = char(igds(13))
212  gds(29) = char(0)
213  gds(30) = char(0)
214  gds(31) = char(0)
215  gds(32) = char(0)
216  IF (lengds.GT.32) THEN
217  isum = 0
218  i = 19
219  DO 10 j = 33,lengds,2
220  isum = isum + igds(i)
221  gds(j) = char(mod(igds(i)/256,256))
222  gds(j+1) = char(mod(igds(i) ,256))
223  i = i + 1
224  10 CONTINUE
225  END IF
226 C
227 C$$ PROCESS MERCATOR GRID TYPES
228 C
229  ELSE IF (igds(3) .EQ. 1) THEN
230  gds( 7) = char(mod(igds(4)/256,256))
231  gds( 8) = char(mod(igds(4) ,256))
232  gds( 9) = char(mod(igds(5)/256,256))
233  gds(10) = char(mod(igds(5) ,256))
234  lato = igds(6)
235  IF (lato .LT. 0) THEN
236  lato = -lato
237  lato = ior(lato,8388608)
238  ENDIF
239  gds(11) = char(mod(lato/65536,256))
240  gds(12) = char(mod(lato/ 256,256))
241  gds(13) = char(mod(lato ,256))
242  lono = igds(7)
243  IF (lono .LT. 0) THEN
244  lono = -lono
245  lono = ior(lono,8388608)
246  ENDIF
247  gds(14) = char(mod(lono/65536,256))
248  gds(15) = char(mod(lono/ 256,256))
249  gds(16) = char(mod(lono ,256))
250  latext = igds(9)
251  IF (latext .LT. 0) THEN
252  latext = -latext
253  latext = ior(latext,8388608)
254  ENDIF
255  gds(18) = char(mod(latext/65536,256))
256  gds(19) = char(mod(latext/ 256,256))
257  gds(20) = char(mod(latext ,256))
258  lonext = igds(10)
259  IF (lonext .LT. 0) THEN
260  lonext = -lonext
261  lonext = ior(lonext,8388608)
262  ENDIF
263  gds(21) = char(mod(lonext/65536,256))
264  gds(22) = char(mod(lonext/ 256,256))
265  gds(23) = char(mod(lonext ,256))
266  gds(24) = char(mod(igds(13)/65536,256))
267  gds(25) = char(mod(igds(13)/ 256,256))
268  gds(26) = char(mod(igds(13) ,256))
269  gds(27) = char(0)
270  gds(28) = char(igds(14))
271  gds(29) = char(mod(igds(12)/65536,256))
272  gds(30) = char(mod(igds(12)/ 256,256))
273  gds(31) = char(mod(igds(12) ,256))
274  gds(32) = char(mod(igds(11)/65536,256))
275  gds(33) = char(mod(igds(11)/ 256,256))
276  gds(34) = char(mod(igds(11) ,256))
277  gds(35) = char(0)
278  gds(36) = char(0)
279  gds(37) = char(0)
280  gds(38) = char(0)
281  gds(39) = char(0)
282  gds(40) = char(0)
283  gds(41) = char(0)
284  gds(42) = char(0)
285 C$$ PROCESS LAMBERT CONFORMAL GRID TYPES
286  ELSE IF (igds(3) .EQ. 3) THEN
287  gds( 7) = char(mod(igds(4)/256,256))
288  gds( 8) = char(mod(igds(4) ,256))
289  gds( 9) = char(mod(igds(5)/256,256))
290  gds(10) = char(mod(igds(5) ,256))
291  lato = igds(6)
292  IF (lato .LT. 0) THEN
293  lato = -lato
294  lato = ior(lato,8388608)
295  ENDIF
296  gds(11) = char(mod(lato/65536,256))
297  gds(12) = char(mod(lato/ 256,256))
298  gds(13) = char(mod(lato ,256))
299  lono = igds(7)
300  IF (lono .LT. 0) THEN
301  lono = -lono
302  lono = ior(lono,8388608)
303  ENDIF
304  gds(14) = char(mod(lono/65536,256))
305  gds(15) = char(mod(lono/ 256,256))
306  gds(16) = char(mod(lono ,256))
307  lonm = igds(9)
308  IF (lonm .LT. 0) THEN
309  lonm = -lonm
310  lonm = ior(lonm,8388608)
311  ENDIF
312  gds(18) = char(mod(lonm/65536,256))
313  gds(19) = char(mod(lonm/ 256,256))
314  gds(20) = char(mod(lonm ,256))
315  gds(21) = char(mod(igds(10)/65536,256))
316  gds(22) = char(mod(igds(10)/ 256,256))
317  gds(23) = char(mod(igds(10) ,256))
318  gds(24) = char(mod(igds(11)/65536,256))
319  gds(25) = char(mod(igds(11)/ 256,256))
320  gds(26) = char(mod(igds(11) ,256))
321  gds(27) = char(igds(12))
322  gds(28) = char(igds(13))
323  gds(29) = char(mod(igds(15)/65536,256))
324  gds(30) = char(mod(igds(15)/ 256,256))
325  gds(31) = char(mod(igds(15) ,256))
326  gds(32) = char(mod(igds(16)/65536,256))
327  gds(33) = char(mod(igds(16)/ 256,256))
328  gds(34) = char(mod(igds(16) ,256))
329  gds(35) = char(mod(igds(17)/65536,256))
330  gds(36) = char(mod(igds(17)/ 256,256))
331  gds(37) = char(mod(igds(17) ,256))
332  gds(38) = char(mod(igds(18)/65536,256))
333  gds(39) = char(mod(igds(18)/ 256,256))
334  gds(40) = char(mod(igds(18) ,256))
335  gds(41) = char(0)
336  gds(42) = char(0)
337 C$$ PROCESS POLAR STEREOGRAPHIC GRID TYPES
338  ELSE IF (igds(3) .EQ. 5) THEN
339  gds( 7) = char(mod(igds(4)/256,256))
340  gds( 8) = char(mod(igds(4) ,256))
341  gds( 9) = char(mod(igds(5)/256,256))
342  gds(10) = char(mod(igds(5) ,256))
343  lato = igds(6)
344  IF (lato .LT. 0) THEN
345  lato = -lato
346  lato = ior(lato,8388608)
347  ENDIF
348  gds(11) = char(mod(lato/65536,256))
349  gds(12) = char(mod(lato/ 256,256))
350  gds(13) = char(mod(lato ,256))
351  lono = igds(7)
352  IF (lono .LT. 0) THEN
353  lono = -lono
354  lono = ior(lono,8388608)
355  ENDIF
356  gds(14) = char(mod(lono/65536,256))
357  gds(15) = char(mod(lono/ 256,256))
358  gds(16) = char(mod(lono ,256))
359  lonm = igds(9)
360  IF (lonm .LT. 0) THEN
361  lonm = -lonm
362  lonm = ior(lonm,8388608)
363  ENDIF
364  gds(18) = char(mod(lonm/65536,256))
365  gds(19) = char(mod(lonm/ 256,256))
366  gds(20) = char(mod(lonm ,256))
367  gds(21) = char(mod(igds(10)/65536,256))
368  gds(22) = char(mod(igds(10)/ 256,256))
369  gds(23) = char(mod(igds(10) ,256))
370  gds(24) = char(mod(igds(11)/65536,256))
371  gds(25) = char(mod(igds(11)/ 256,256))
372  gds(26) = char(mod(igds(11) ,256))
373  gds(27) = char(igds(12))
374  gds(28) = char(igds(13))
375  gds(29) = char(0)
376  gds(30) = char(0)
377  gds(31) = char(0)
378  gds(32) = char(0)
379  ENDIF
380 C PRINT 10,(GDS(IG),IG=1,32)
381 C10 FORMAT (' GDS= ',32(1X,Z2.2))
382 C
383 C COMPUTE NUMBER OF POINTS IN GRID BY MULTIPLYING
384 C IGDS(4) AND IGDS(5) ... NEEDED FOR PACKER
385 C
386  IF (igds(3).EQ.0.AND.igds(1).EQ.0.AND.igds(2).NE.
387  & 255) THEN
388  npts = isum
389  ELSE
390  npts = igds(4) * igds(5)
391  ENDIF
392 C
393 C 'IOR' ICOMP-BIT 5 RESOLUTION & COMPONENT FLAG FOR WINDS
394 C WITH IGDS(8) INFO (REST OF RESOLUTION & COMPONENT FLAG DATA)
395 C
396  itemp = ishft(icomp,3)
397  gds(17) = char(ior(igds(8),itemp))
398 C
399  RETURN
400  END
lengds
function lengds(KGDS)
Program history log:
Definition: lengds.f:15
w3fi74
subroutine w3fi74(IGDS, ICOMP, GDS, LENGDS, NPTS, IGERR)
This subroutine constructs a GRIB grid definition section.
Definition: w3fi74.f:19