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