NCEPLIBS-w3emc 2.12.0
Loading...
Searching...
No Matches
w3fi74.f
Go to the documentation of this file.
1C> @file
2C> @brief Construct Grid Definition Section (GDS).
3C> @author M. Farley @date 1992-07-07
4
5C> This subroutine constructs a GRIB grid definition section.
6C>
7C> @note Subprogram can be called from a multiprocessing environment.
8C>
9C> @param[in] IGDS Integer array supplied by w3fi71().
10C> @param[in] ICOMP Table 7- resolution & component flag (bit 5)
11C> for gds(17) wind components.
12C> @param[out] GDS Completed grib grid definition section.
13C> @param[out] LENGDS Length of gds.
14C> @param[out] NPTS Number of points in grid.
15C> @param[out] IGERR 1, grid representation type not valid.
16C>
17C> @author M. Farley @date 1992-07-07
18 SUBROUTINE w3fi74 (IGDS,ICOMP,GDS,LENGDS,NPTS,IGERR)
19C
20 INTEGER IGDS (*)
21C
22 CHARACTER*1 GDS (*)
23C
24 isum = 0
25 igerr = 0
26C
27C PRINT *,' '
28C PRINT *,'(W3FI74-IGDS = )'
29C PRINT *,(IGDS(I),I=1,18)
30C PRINT *,' '
31C
32C COMPUTE LENGTH OF GDS IN OCTETS (OCTETS 1-3)
33C LENGDS = 32 FOR LAT/LON, GNOMIC, GAUSIAN LAT/LON,
34C POLAR STEREOGRAPHIC, SPHERICAL HARMONICS,
35C ROTATED LAT/LON E-STAGGER
36C LENGDS = 34 ROTATED LAT/LON A,B,C,D STAGGERS
37C LENGDS = 42 FOR MERCATOR, LAMBERT, TANGENT CONE
38C LENGDS = 178 FOR MERCATOR, LAMBERT, TANGENT CONE
39C
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
46C
47C CORRECTION FOR GRIDS 37-44
48C
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
59C PRINT *,' W3FI74 ERROR, GRID REPRESENTATION TYPE NOT VALID'
60 igerr = 1
61 RETURN
62 ENDIF
63C
64C PUT LENGTH OF GDS SECTION IN BYTES 1,2,3
65C
66 gds(1) = char(mod(lengds/65536,256))
67 gds(2) = char(mod(lengds/ 256,256))
68 gds(3) = char(mod(lengds ,256))
69C
70C OCTET 4 = NV, NUMBER OF VERTICAL COORDINATE PARAMETERS
71C OCTET 5 = PV, PL OR 255
72C OCTET 6 = DATA REPRESENTATION TYPE (TABLE 6)
73C
74 gds(4) = char(igds(1))
75 gds(5) = char(igds(2))
76 gds(6) = char(igds(3))
77C
78C FILL OCTET THE REST OF THE GDS BASED ON DATA REPRESENTATION
79C TYPE (TABLE 6)
80C
81C$$
82C PROCESS ROTATED LAT/LON A,B,C,D STAGGERS
83C
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))
142C
143C PROCESS LAT/LON GRID TYPES OR GAUSSIAN GRID OR ARAKAWA
144C STAGGERED, SEMI-STAGGERED, OR FILLED E-GRIDS
145C
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
226C
227C$$ PROCESS MERCATOR GRID TYPES
228C
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)
285C$$ 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)
337C$$ 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
380C PRINT 10,(GDS(IG),IG=1,32)
381C10 FORMAT (' GDS= ',32(1X,Z2.2))
382C
383C COMPUTE NUMBER OF POINTS IN GRID BY MULTIPLYING
384C IGDS(4) AND IGDS(5) ... NEEDED FOR PACKER
385C
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
392C
393C 'IOR' ICOMP-BIT 5 RESOLUTION & COMPONENT FLAG FOR WINDS
394C WITH IGDS(8) INFO (REST OF RESOLUTION & COMPONENT FLAG DATA)
395C
396 itemp = ishft(icomp,3)
397 gds(17) = char(ior(igds(8),itemp))
398C
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