Context Navigation

getgb2s.F

Last change on this file was 2759, checked in by aslmd, 2 years ago
adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 24.6 KB

Line
1	C-----------------------------------------------------------------------
2	SUBROUTINE GETGB2S(CBUF,NLEN,NNUM,J,GUESS,JDISC,JIDS,JPDTN,JPDT,
3	& JGDTN,JGDT,K,GFLD,LPOS,IRET)
4	C$$$ SUBPROGRAM DOCUMENTATION BLOCK
5	C
6	C SUBPROGRAM: GETGB2S FINDS A GRIB MESSAGE
7	C PRGMMR: GILBERT ORG: W/NP11 DATE: 02-01-15
8	C
9	C ABSTRACT: FIND A GRIB MESSAGE.
10	C FIND IN THE INDEX FILE A REFERENCE TO THE GRIB FIELD REQUESTED.
11	C THE GRIB FIELD REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP
12	C AND THE UNPACKED IDENTIFICATION SECTION, GRID DEFINITION TEMPLATE AND
13	C PRODUCT DEFINTION SECTION PARAMETERS. (A REQUESTED PARAMETER
14	C OF -9999 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.)
15	C
16	C EACH INDEX RECORD HAS THE FOLLOWING FORM:
17	C BYTE 001 - 004: LENGTH OF INDEX RECORD
18	C BYTE 005 - 008: BYTES TO SKIP IN DATA FILE BEFORE GRIB MESSAGE
19	C BYTE 009 - 012: BYTES TO SKIP IN MESSAGE BEFORE LUS (LOCAL USE)
20	C SET = 0, IF NO LOCAL USE SECTION IN GRIB2 MESSAGE.
21	C BYTE 013 - 016: BYTES TO SKIP IN MESSAGE BEFORE GDS
22	C BYTE 017 - 020: BYTES TO SKIP IN MESSAGE BEFORE PDS
23	C BYTE 021 - 024: BYTES TO SKIP IN MESSAGE BEFORE DRS
24	C BYTE 025 - 028: BYTES TO SKIP IN MESSAGE BEFORE BMS
25	C BYTE 029 - 032: BYTES TO SKIP IN MESSAGE BEFORE DATA SECTION
26	C BYTE 033 - 040: BYTES TOTAL IN THE MESSAGE
27	C BYTE 041 - 041: GRIB VERSION NUMBER ( CURRENTLY 2 )
28	C BYTE 042 - 042: MESSAGE DISCIPLINE
29	C BYTE 043 - 044: FIELD NUMBER WITHIN GRIB2 MESSAGE
30	C BYTE 045 - II: IDENTIFICATION SECTION (IDS)
31	C BYTE II+1- JJ: GRID DEFINITION SECTION (GDS)
32	C BYTE JJ+1- KK: PRODUCT DEFINITION SECTION (PDS)
33	C BYTE KK+1- LL: THE DATA REPRESENTATION SECTION (DRS)
34	C BYTE LL+1-LL+6: FIRST 6 BYTES OF THE BIT MAP SECTION (BMS)
35	C
36	C Most of the decoded information for the selected GRIB field
37	C is returned in a derived type variable, gfld.
38	C Gfld is of type gribfield, which is defined
39	C in module grib_mod, so users of this routine will need to include
40	C the line "USE GRIB_MOD" in their calling routine. Each component of the
41	C gribfield type is described in the OUTPUT ARGUMENT LIST section below.
42	C Only the unpacked bitmap and data field components are not set by this
43	C routine.
44	C
45	C PROGRAM HISTORY LOG:
46	C 95-10-31 IREDELL
47	C 2002-01-02 GILBERT MODIFIED FROM GETG1S TO WORK WITH GRIB2
48	C
49	C USAGE: CALL GETGB2S(CBUF,NLEN,NNUM,J,GUESS,JDISC,JIDS,JPDTN,JPDT,JGDTN,
50	C & JGDT,K,GFLD,LPOS,IRET)
51	C INPUT ARGUMENTS:
52	C CBUF CHARACTER*1 (NLEN) BUFFER CONTAINING INDEX DATA
53	C NLEN INTEGER TOTAL LENGTH OF ALL INDEX RECORDS
54	C NNUM INTEGER NUMBER OF INDEX RECORDS
55	C J INTEGER NUMBER OF MESSAGES TO SKIP
56	C (=0 TO SEARCH FROM BEGINNING)
57	C GUESS A GUESS FOR THE INDEX OF THE GRIB RECORD THAT CONTAINS
58	C THE REQUESTED DATA. IF GUESS IS CORRECT, SEARCHING
59	C CAN BE SIGNFICANTLY FASTER, ESPECIALLY FOR FILES
60	C WITH MANY RECORDS. IF GUESS IS WRONG OR MISSING (<0),
61	C ALL RECORDS ARE SEARCHED
62	C JDISC GRIB2 DISCIPLINE NUMBER OF REQUESTED FIELD
63	C ( IF = -1, ACCEPT ANY DISCIPLINE)
64	C ( SEE CODE TABLE 0.0 )
65	C 0 - Meteorological products
66	C 1 - Hydrological products
67	C 2 - Land surface products
68	C 3 - Space products
69	C 10 - Oceanographic products
70	C JIDS() INTEGER ARRAY OF VALUES IN THE IDENTIFICATION SECTION
71	C (=-9999 FOR WILDCARD)
72	C JIDS(1) = IDENTIFICATION OF ORIGINATING CENTRE
73	C ( SEE COMMON CODE TABLE C-1 )
74	C JIDS(2) = IDENTIFICATION OF ORIGINATING SUB-CENTRE
75	C JIDS(3) = GRIB MASTER TABLES VERSION NUMBER
76	C ( SEE CODE TABLE 1.0 )
77	C 0 - Experimental
78	C 1 - Initial operational version number
79	C JIDS(4) = GRIB LOCAL TABLES VERSION NUMBER
80	C ( SEE CODE TABLE 1.1 )
81	C 0 - Local tables not used
82	C 1-254 - Number of local tables version used
83	C JIDS(5) = SIGNIFICANCE OF REFERENCE TIME (CODE TABLE 1.2)
84	C 0 - Analysis
85	C 1 - Start of forecast
86	C 2 - Verifying time of forecast
87	C 3 - Observation time
88	C JIDS(6) = YEAR ( 4 DIGITS )
89	C JIDS(7) = MONTH
90	C JIDS(8) = DAY
91	C JIDS(9) = HOUR
92	C JIDS(10) = MINUTE
93	C JIDS(11) = SECOND
94	C JIDS(12) = PRODUCTION STATUS OF PROCESSED DATA
95	C ( SEE CODE TABLE 1.3 )
96	C 0 - Operational products
97	C 1 - Operational test products
98	C 2 - Research products
99	C 3 - Re-analysis products
100	C JIDS(13) = TYPE OF PROCESSED DATA ( SEE CODE TABLE 1.4 )
101	C 0 - Analysis products
102	C 1 - Forecast products
103	C 2 - Analysis and forecast products
104	C 3 - Control forecast products
105	C 4 - Perturbed forecast products
106	C 5 - Control and perturbed forecast products
107	C 6 - Processed satellite observations
108	C 7 - Processed radar observations
109	C JPDTN INTEGER PRODUCT DEFINITION TEMPLATE NUMBER (N)
110	C ( IF = -1, DON'T BOTHER MATCHING PDT )
111	C JPDT() INTEGER ARRAY OF VALUES DEFINING THE PRODUCT DEFINITION
112	C TEMPLATE 4.N OF THE FIELD FOR WHICH TO SEARCH
113	C (=-9999 FOR WILDCARD)
114	C JGDTN INTEGER GRID DEFINITION TEMPLATE NUMBER (M)
115	C ( IF = -1, DON'T BOTHER MATCHING GDT )
116	C JGDT() INTEGER ARRAY OF VALUES DEFINING THE GRID DEFINITION
117	C TEMPLATE 3.M OF THE FIELD FOR WHICH TO SEARCH
118	C (=-9999 FOR WILDCARD)
119	C OUTPUT ARGUMENTS:
120	C K INTEGER MESSAGE NUMBER FOUND
121	C (CAN BE SAME AS J IN CALLING PROGRAM
122	C IN ORDER TO FACILITATE MULTIPLE SEARCHES)
123	C gfld - derived type gribfield ( defined in module grib_mod )
124	C ( NOTE: See Remarks Section )
125	C gfld%version = GRIB edition number ( currently 2 )
126	C gfld%discipline = Message Discipline ( see Code Table 0.0 )
127	C gfld%idsect() = Contains the entries in the Identification
128	C Section ( Section 1 )
129	C This element is actually a pointer to an array
130	C that holds the data.
131	C gfld%idsect(1) = Identification of originating Centre
132	C ( see Common Code Table C-1 )
133	C 7 - US National Weather Service
134	C gfld%idsect(2) = Identification of originating Sub-centre
135	C gfld%idsect(3) = GRIB Master Tables Version Number
136	C ( see Code Table 1.0 )
137	C 0 - Experimental
138	C 1 - Initial operational version number
139	C gfld%idsect(4) = GRIB Local Tables Version Number
140	C ( see Code Table 1.1 )
141	C 0 - Local tables not used
142	C 1-254 - Number of local tables version used
143	C gfld%idsect(5) = Significance of Reference Time (Code Table 1.2)
144	C 0 - Analysis
145	C 1 - Start of forecast
146	C 2 - Verifying time of forecast
147	C 3 - Observation time
148	C gfld%idsect(6) = Year ( 4 digits )
149	C gfld%idsect(7) = Month
150	C gfld%idsect(8) = Day
151	C gfld%idsect(9) = Hour
152	C gfld%idsect(10) = Minute
153	C gfld%idsect(11) = Second
154	C gfld%idsect(12) = Production status of processed data
155	C ( see Code Table 1.3 )
156	C 0 - Operational products
157	C 1 - Operational test products
158	C 2 - Research products
159	C 3 - Re-analysis products
160	C gfld%idsect(13) = Type of processed data ( see Code Table 1.4 )
161	C 0 - Analysis products
162	C 1 - Forecast products
163	C 2 - Analysis and forecast products
164	C 3 - Control forecast products
165	C 4 - Perturbed forecast products
166	C 5 - Control and perturbed forecast products
167	C 6 - Processed satellite observations
168	C 7 - Processed radar observations
169	C gfld%idsectlen = Number of elements in gfld%idsect().
170	C gfld%local() = Pointer to character array containing contents
171	C of Local Section 2, if included
172	C gfld%locallen = length of array gfld%local()
173	C gfld%ifldnum = field number within GRIB message
174	C gfld%griddef = Source of grid definition (see Code Table 3.0)
175	C 0 - Specified in Code table 3.1
176	C 1 - Predetermined grid Defined by originating centre
177	C gfld%ngrdpts = Number of grid points in the defined grid.
178	C gfld%numoct_opt = Number of octets needed for each
179	C additional grid points definition.
180	C Used to define number of
181	C points in each row ( or column ) for
182	C non-regular grids.
183	C = 0, if using regular grid.
184	C gfld%interp_opt = Interpretation of list for optional points
185	C definition. (Code Table 3.11)
186	C gfld%igdtnum = Grid Definition Template Number (Code Table 3.1)
187	C gfld%igdtmpl() = Contains the data values for the specified Grid
188	C Definition Template ( NN=gfld%igdtnum ). Each
189	C element of this integer array contains an entry (in
190	C the order specified) of Grid Defintion Template 3.NN
191	C This element is actually a pointer to an array
192	C that holds the data.
193	C gfld%igdtlen = Number of elements in gfld%igdtmpl(). i.e. number of
194	C entries in Grid Defintion Template 3.NN
195	C ( NN=gfld%igdtnum ).
196	C gfld%list_opt() = (Used if gfld%numoct_opt .ne. 0) This array
197	C contains the number of grid points contained in
198	C each row ( or column ). (part of Section 3)
199	C This element is actually a pointer to an array
200	C that holds the data. This pointer is nullified
201	C if gfld%numoct_opt=0.
202	C gfld%num_opt = (Used if gfld%numoct_opt .ne. 0) The number of entries
203	C in array ideflist. i.e. number of rows ( or columns )
204	C for which optional grid points are defined. This value
205	C is set to zero, if gfld%numoct_opt=0.
206	C gfdl%ipdtnum = Product Definition Template Number (see Code Table 4.0)
207	C gfld%ipdtmpl() = Contains the data values for the specified Product
208	C Definition Template ( N=gfdl%ipdtnum ). Each element
209	C of this integer array contains an entry (in the
210	C order specified) of Product Defintion Template 4.N.
211	C This element is actually a pointer to an array
212	C that holds the data.
213	C gfld%ipdtlen = Number of elements in gfld%ipdtmpl(). i.e. number of
214	C entries in Product Defintion Template 4.N
215	C ( N=gfdl%ipdtnum ).
216	C gfld%coord_list() = Real array containing floating point values
217	C intended to document the vertical discretisation
218	C associated to model data on hybrid coordinate
219	C vertical levels. (part of Section 4)
220	C This element is actually a pointer to an array
221	C that holds the data.
222	C gfld%num_coord = number of values in array gfld%coord_list().
223	C gfld%ndpts = Number of data points unpacked and returned.
224	C gfld%idrtnum = Data Representation Template Number
225	C ( see Code Table 5.0)
226	C gfld%idrtmpl() = Contains the data values for the specified Data
227	C Representation Template ( N=gfld%idrtnum ). Each
228	C element of this integer array contains an entry
229	C (in the order specified) of Product Defintion
230	C Template 5.N.
231	C This element is actually a pointer to an array
232	C that holds the data.
233	C gfld%idrtlen = Number of elements in gfld%idrtmpl(). i.e. number
234	C of entries in Data Representation Template 5.N
235	C ( N=gfld%idrtnum ).
236	C gfld%unpacked = logical value indicating whether the bitmap and
237	C data values were unpacked. If false,
238	C gfld%bmap and gfld%fld pointers are nullified.
239	C NOTE: This routine sets this component to .FALSE.
240	C gfld%ibmap = Bitmap indicator ( see Code Table 6.0 )
241	C 0 = bitmap applies and is included in Section 6.
242	C 1-253 = Predefined bitmap applies
243	C 254 = Previously defined bitmap applies to this field
244	C 255 = Bit map does not apply to this product.
245	C gfld%bmap() = Logical*1 array containing decoded bitmap,
246	C if ibmap=0 or ibap=254. Otherwise nullified.
247	C This element is actually a pointer to an array
248	C that holds the data.
249	C NOTE: This component is not set by this routine.
250	C gfld%fld() = Array of gfld%ndpts unpacked data points.
251	C This element is actually a pointer to an array
252	C that holds the data.
253	C NOTE: This component is not set by this routine.
254	C LPOS STARTING POSITION OF THE FOUND INDEX RECORD WITHIN
255	C THE COMPLETE INDEX BUFFER, CBUF.
256	C = 0, IF REQUEST NOT FOUND
257	C IRET INTEGER RETURN CODE
258	C 0 ALL OK
259	C 1 REQUEST NOT FOUND
260	C
261	C REMARKS:
262	C THIS SUBPROGRAM IS INTENDED FOR PRIVATE USE BY GETGB2 ROUTINES ONLY.
263	C
264	C Note that derived type gribfield contains pointers to many
265	C arrays of data. The memory for these arrays is allocated
266	C when the values in the arrays are set, to help minimize
267	C problems with array overloading. Because of this users
268	C are encouraged to free up this memory, when it is no longer
269	C needed, by an explicit call to subroutine gf_free.
270	C ( i.e. CALL GF_FREE(GFLD) )
271	C
272	C SUBPROGRAMS CALLED:
273	C G2LIB_GBYTE UNPACK BYTES
274	C GF_UNPACK1 UNPACK IDS
275	C GF_UNPACK4 UNPACK PDS
276	C GF_UNPACK3 UNPACK GDS
277	C
278	C ATTRIBUTES:
279	C LANGUAGE: FORTRAN 90
280	C
281	C$$$
282	USE GRIB_MOD
283
284	! CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF
285	CHARACTER(LEN=1),INTENT(IN) :: CBUF(NLEN)
286	INTEGER,INTENT(IN) :: NLEN,NNUM,J,JDISC,JPDTN,JGDTN
287	INTEGER,DIMENSION(:) :: JIDS(),JPDT(),JGDT(*)
288	INTEGER,INTENT(OUT) :: K,LPOS,IRET
289	TYPE(GRIBFIELD),INTENT(OUT) :: GFLD
290	INTEGER,INTENT(IN) :: GUESS
291	INTEGER :: KGDS(5)
292	LOGICAL :: MATCH1,MATCH3,MATCH4
293	INTEGER :: SKIP
294	INTEGER :: LOOPNUM
295	logical :: skip2
296	! INTEGER,POINTER,DIMENSION(:) :: KIDS,KPDT,KGDT
297	! INTEGER,POINTER,DIMENSION(:) :: IDEF
298	! REAL,POINTER,DIMENSION(:) :: COORD
299
300	interface
301	subroutine gf_unpack1(cgrib,lcgrib,iofst,ids,idslen,ierr)
302	character(len=1),intent(in) :: cgrib(lcgrib)
303	integer,intent(in) :: lcgrib
304	integer,intent(inout) :: iofst
305	integer,pointer,dimension(:) :: ids
306	integer,intent(out) :: ierr,idslen
307	end subroutine gf_unpack1
308	subroutine gf_unpack3(cgrib,lcgrib,iofst,igds,igdstmpl,
309	& mapgridlen,ideflist,idefnum,ierr)
310	character(len=1),intent(in) :: cgrib(lcgrib)
311	integer,intent(in) :: lcgrib
312	integer,intent(inout) :: iofst
313	integer,pointer,dimension(:) :: igdstmpl,ideflist
314	integer,intent(out) :: igds(5)
315	integer,intent(out) :: ierr,idefnum
316	end subroutine gf_unpack3
317	subroutine gf_unpack4(cgrib,lcgrib,iofst,ipdsnum,ipdstmpl,
318	& mappdslen,coordlist,numcoord,ierr)
319	character(len=1),intent(in) :: cgrib(lcgrib)
320	integer,intent(in) :: lcgrib
321	integer,intent(inout) :: iofst
322	real,pointer,dimension(:) :: coordlist
323	integer,pointer,dimension(:) :: ipdstmpl
324	integer,intent(out) :: ipdsnum
325	integer,intent(out) :: ierr,numcoord
326	end subroutine gf_unpack4
327	subroutine gf_unpack5(cgrib,lcgrib,iofst,ndpts,idrsnum,
328	& idrstmpl,mapdrslen,ierr)
329	character(len=1),intent(in) :: cgrib(lcgrib)
330	integer,intent(in) :: lcgrib
331	integer,intent(inout) :: iofst
332	integer,intent(out) :: ndpts,idrsnum
333	integer,pointer,dimension(:) :: idrstmpl
334	integer,intent(out) :: ierr
335	end subroutine gf_unpack5
336	end interface
337
338	C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
339	C INITIALIZE
340
341
342	K=0
343	SKIP = J
344	LPOS=0
345	IRET=1
346	IPOS=0
347	LOOPNUM = 1
348	skip2 = .false.
349	nullify(gfld%list_opt,gfld%igdtmpl,gfld%ipdtmpl)
350	nullify(gfld%coord_list,gfld%idrtmpl,gfld%bmap,gfld%fld)
351	C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
352	C SEARCH FOR REQUEST
353	DOWHILE(IRET.NE.0)
354
355	if (guess .gt. 0) then
356	if (loopnum .eq. 1) then
357
358	! Check if we are at end of data., If so, search from beginning
359	if (k .ge. NNUM) then
360	loopnum = loopnum + 1
361	cycle
362	endif
363
364	! Set first search to be the guess index.
365	SKIP = guess - 1
366
367	else if (loopnum .eq. 2) then
368
369	! Set 2nd search to start from beginning.
370	if (.not. skip2) then
371	SKIP = J
372	K = 0
373	ipos = 0
374	skip2 = .true.
375	endif
376
377	endif
378	endif
379
380	if (k .ge. NNUM) then
381	exit
382	endif
383
384
385	K=K+1
386	CALL G2LIB_GBYTE(CBUF,INLEN,IPOS8,48) ! GET LENGTH OF CURRENT
387	! INDEX RECORD
388
389	IF ( K.LE.SKIP ) THEN ! SKIP THIS INDEX
390	IPOS=IPOS+INLEN
391	CYCLE
392	ELSE
393	LOOPNUM = LOOPNUM + 1
394	ENDIF
395
396	C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
397	C CHECK IF GRIB2 DISCIPLINE IS A MATCH
398	CALL G2LIB_GBYTE(CBUF,GFLD%DISCIPLINE,(IPOS+41)8,18)
399	IF ( (JDISC.NE.-1).AND.(JDISC.NE.GFLD%DISCIPLINE) ) THEN
400	IPOS=IPOS+INLEN
401	CYCLE
402	ENDIF
403	C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
404	C CHECK IF IDENTIFICATION SECTION IS A MATCH
405	MATCH1=.FALSE.
406	CALL G2LIB_GBYTE(CBUF,LSEC1,(IPOS+44)8,48) ! GET LENGTH OF IDS
407	IOF=0
408	CALL GF_UNPACK1(CBUF(IPOS+45),LSEC1,IOF,GFLD%IDSECT,
409	& GFLD%IDSECTLEN,ICND)
410	IF ( ICND.EQ.0 ) THEN
411	MATCH1=.TRUE.
412	DO I=1,GFLD%IDSECTLEN
413	IF ( (JIDS(I).NE.-9999).AND.
414	& (JIDS(I).NE.GFLD%IDSECT(I)) ) THEN
415	MATCH1=.FALSE.
416	EXIT
417	ENDIF
418	ENDDO
419	ENDIF
420	IF ( .NOT. MATCH1 ) THEN
421	DEALLOCATE(GFLD%IDSECT)
422	IPOS=IPOS+INLEN
423	CYCLE
424	ENDIF
425	C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
426	C CHECK IF GRID DEFINITION TEMPLATE IS A MATCH
427	JPOS=IPOS+44+LSEC1
428	MATCH3=.FALSE.
429	CALL G2LIB_GBYTE(CBUF,LSEC3,JPOS8,48) ! GET LENGTH OF GDS
430	IF ( JGDTN.EQ.-1 ) THEN
431	MATCH3=.TRUE.
432	ELSE
433	CALL G2LIB_GBYTE(CBUF,NUMGDT,(JPOS+12)8,28) ! GET GDT TEMPLATE NO.
434	IF ( JGDTN.EQ.NUMGDT ) THEN
435	IOF=0
436	CALL GF_UNPACK3(CBUF(JPOS+1),LSEC3,IOF,KGDS,GFLD%IGDTMPL,
437	& GFLD%IGDTLEN,GFLD%LIST_OPT,GFLD%NUM_OPT,ICND)
438	IF ( ICND.EQ.0 ) THEN
439	MATCH3=.TRUE.
440	DO I=1,GFLD%IGDTLEN
441	IF ( (JGDT(I).NE.-9999).AND.
442	& (JGDT(I).NE.GFLD%IGDTMPL(I)) ) THEN
443	MATCH3=.FALSE.
444	EXIT
445	ENDIF
446	ENDDO
447	C WHERE ( JGDT(1:GFLD%IGDTLEN).NE.-9999 )
448	C & MATCH3=ALL(JGDT(1:GFLD%IGDTLEN).EQ.GFLD%IGDTMPL(1:GFLD%IGDTLEN))
449	ENDIF
450	ENDIF
451	ENDIF
452	IF ( .NOT. MATCH3 ) THEN
453	IF (ASSOCIATED(GFLD%IGDTMPL)) DEALLOCATE(GFLD%IGDTMPL)
454	IF (ASSOCIATED(GFLD%LIST_OPT)) DEALLOCATE(GFLD%LIST_OPT)
455	IPOS=IPOS+INLEN
456	CYCLE
457	ELSE
458	GFLD%GRIDDEF=KGDS(1)
459	GFLD%NGRDPTS=KGDS(2)
460	GFLD%NUMOCT_OPT=KGDS(3)
461	GFLD%INTERP_OPT=KGDS(4)
462	GFLD%IGDTNUM=KGDS(5)
463	ENDIF
464	C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
465	C CHECK IF PRODUCT DEFINITION TEMPLATE IS A MATCH
466	JPOS=JPOS+LSEC3
467	MATCH4=.FALSE.
468	CALL G2LIB_GBYTE(CBUF,LSEC4,JPOS8,48) ! GET LENGTH OF PDS
469	IF ( JPDTN.EQ.-1 ) THEN
470	MATCH4=.TRUE.
471	ELSE
472	CALL G2LIB_GBYTE(CBUF,NUMPDT,(JPOS+7)8,28) ! GET PDT TEMPLATE NO.
473	IF ( JPDTN.EQ.NUMPDT ) THEN
474	IOF=0
475	CALL GF_UNPACK4(CBUF(JPOS+1),LSEC4,IOF,GFLD%IPDTNUM,
476	& GFLD%IPDTMPL,GFLD%IPDTLEN,
477	& GFLD%COORD_LIST,GFLD%NUM_COORD,ICND)
478	IF ( ICND.EQ.0 ) THEN
479	MATCH4=.TRUE.
480	DO I=1,GFLD%IPDTLEN
481	IF ( (JPDT(I).NE.-9999).AND.
482	& (JPDT(I).NE.GFLD%IPDTMPL(I)) ) THEN
483	MATCH4=.FALSE.
484	EXIT
485	ENDIF
486	ENDDO
487	c WHERE ( JPDT.NE.-9999)
488	c & MATCH4=ALL( JPDT(1:GFLD%IPDTLEN) .EQ. GFLD%IPDTMPL(1:GFLD%IPDTLEN) )
489	ENDIF
490	ENDIF
491	ENDIF
492	IF ( .NOT. MATCH4 ) THEN
493	IF (ASSOCIATED(GFLD%IPDTMPL)) DEALLOCATE(GFLD%IPDTMPL)
494	IF (ASSOCIATED(GFLD%COORD_LIST)) DEALLOCATE(GFLD%COORD_LIST)
495	ENDIF
496	C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
497	C IF REQUEST IS FOUND
498	C SET VALUES FOR DERIVED TYPE GFLD AND RETURN
499	IF(MATCH1.AND.MATCH3.AND.MATCH4) THEN
500	LPOS=IPOS+1
501	CALL G2LIB_GBYTE(CBUF,GFLD%VERSION,(IPOS+40)8,18)
502	CALL G2LIB_GBYTE(CBUF,GFLD%IFLDNUM,(IPOS+42)8,28)
503	GFLD%UNPACKED=.FALSE.
504	JPOS=IPOS+44+LSEC1
505	IF ( JGDTN.EQ.-1 ) THEN ! UNPACK GDS, IF NOT DONE BEFORE
506	IOF=0
507	CALL GF_UNPACK3(CBUF(JPOS+1),LSEC3,IOF,KGDS,GFLD%IGDTMPL,
508	& GFLD%IGDTLEN,GFLD%LIST_OPT,GFLD%NUM_OPT,ICND)
509	GFLD%GRIDDEF=KGDS(1)
510	GFLD%NGRDPTS=KGDS(2)
511	GFLD%NUMOCT_OPT=KGDS(3)
512	GFLD%INTERP_OPT=KGDS(4)
513	GFLD%IGDTNUM=KGDS(5)
514	ENDIF
515	JPOS=JPOS+LSEC3
516	IF ( JPDTN.EQ.-1 ) THEN ! UNPACK PDS, IF NOT DONE BEFORE
517	IOF=0
518	CALL GF_UNPACK4(CBUF(JPOS+1),LSEC4,IOF,GFLD%IPDTNUM,
519	& GFLD%IPDTMPL,GFLD%IPDTLEN,
520	& GFLD%COORD_LIST,GFLD%NUM_COORD,ICND)
521	ENDIF
522	JPOS=JPOS+LSEC4
523	CALL G2LIB_GBYTE(CBUF,LSEC5,JPOS8,48) ! GET LENGTH OF DRS
524	IOF=0
525	CALL GF_UNPACK5(CBUF(JPOS+1),LSEC5,IOF,GFLD%NDPTS,
526	& GFLD%IDRTNUM,GFLD%IDRTMPL,
527	& GFLD%IDRTLEN,ICND)
528	JPOS=JPOS+LSEC5
529	CALL G2LIB_GBYTE(CBUF,GFLD%IBMAP,(JPOS+5)8,18) ! GET IBMAP
530	IRET=0
531	ELSE ! PDT DID NOT MATCH
532	IPOS=IPOS+INLEN
533	ENDIF
534	ENDDO
535	C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
536	RETURN
537	END

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format