Context Navigation

read_grib2map.F

Last change on this file was 11, checked in by aslmd, 14 years ago
spiga@svn-planeto:ajoute le modele meso-echelle martien
File size: 12.7 KB

Line
1	!*****************************************************************************
2	!
3	! Routine to fill a grib2map structure (linked list).
4	!
5	!*****************************************************************************
6
7	subroutine load_grib2map(filename, msg, ierr)
8
9	USE grib2tbls_types
10	Implicit None
11
12	character(), intent(in) :: filename
13	character(), intent(inout) :: msg
14	integer , intent(out) :: ierr
15	integer :: status = 0
16	integer :: fileunit
17	logical :: foundunit
18	character*(maxLineSize) :: line
19	integer :: firstval
20	integer :: numtables = 0
21	character*(1) :: delim
22	integer :: lastpos
23	integer :: pos
24	integer :: idx
25	integer :: end
26	logical :: lerr
27
28	! Open the file
29
30	! First pass:
31	! Scan the file to determine how many tables are included, and how many
32	! entries are in each table.
33	!
34
35	! Find an open fileunit
36	foundunit = .false.
37	do fileunit = 10,100
38	inquire(unit=fileunit,opened=lerr)
39	if (lerr .eqv. .false.) then
40	foundunit = .true.
41	exit
42	endif
43	enddo
44	if (foundunit .neqv. .true.) then
45	write(msg, *)'Could not find unit to open ',filename
46	ierr = -1
47	return
48	endif
49
50	! Open the file
51	open ( unit = fileunit, file=filename, status = 'old', iostat = status)
52	if (status .ne. 0) then
53	write(msg, *)'Could not open file ',filename
54	ierr = -1
55	return
56	endif
57
58	! Loop through each line to count the number of tables and entries in
59	! each table.
60
61	READLINE: do
62	!
63	! Read the line, skip line if line is comment, blank or invalid
64	!
65	read(fileunit,'(A)',iostat=status) line
66	line = adjustl(line)
67	if (status .lt. 0) then
68	exit
69	endif
70	if (len_trim(line) .eq. 0) then
71	cycle READLINE
72	endif
73	if (line(1:1) .eq. '#') then
74	cycle READLINE
75	endif
76
77	!
78	! Read the first value in the line
79	!
80	read(line,*,iostat=status) firstval
81	if (status .ne. 0) then
82	print *,'Skipping Invalid line in',trim(filename),':'
83	print *,'''',trim(line),''''
84	cycle READLINE
85	endif
86
87
88	!
89	! If the first value is -1, weve found a new table. Allocate
90	! a new member in the linked list, and add the information
91	! to that member
92	!
93	if (firstval .eq. -1) then
94	numtables = numtables + 1
95
96	!
97	! Create and allocate the next member of the linked list
98	!
99	if (.NOT. ASSOCIATED(TblHead)) THEN
100	ALLOCATE (TblHead, stat=status)
101	if (status .ne. 0) then
102	print *,'Could not allocate space for TblHead'
103	exit READLINE
104	endif
105	TblTail => TblHead
106	else
107	ALLOCATE (TblTail%next, STAT=status)
108	if (status .ne. 0) then
109	print *,'Could not allocate space for TblTail%next, continuing'
110	cycle READLINE
111	endif
112	TblTail%previous => TblTail
113	TblTail => TblTail%next
114	endif
115	nullify(TblTail%next)
116	nullify(TblTail%ParmHead)
117
118	!
119	! Parse the header line
120	!
121	lastpos = 0
122	do idx = 1,5
123	pos = index(line(lastpos+1:maxLineSize), "\|")
124
125	if (pos .lt. 0) then
126	print *,'Found invalid header line: '
127	print *,'''',trim(line),''''
128	if (associated(TblTail%previous)) then
129	TblTail => TblTail%previous
130	else
131	nullify(TblTail)
132	endif
133	cycle READLINE
134	endif
135
136	SELECT CASE (idx)
137	CASE (1)
138	! Do nothing, since this is just the indicator value
139	CASE (2)
140	read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%center
141	if (status .ne. 0) then
142	print *,'Found invalid header line: '
143	print *,'''',trim(line),''''
144	cycle READLINE
145	endif
146	CASE (3)
147	read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%subcenter
148	if (status .ne. 0) then
149	print *,'Found invalid header line: '
150	print *,'''',trim(line),''''
151	cycle READLINE
152	endif
153	CASE (4)
154	read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%MasterTblV
155	if (status .ne. 0) then
156	print *,'Found invalid header line: '
157	print *,'''',trim(line),''''
158	cycle READLINE
159	endif
160	CASE (5)
161	read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%LocalTblV
162	if (status .ne. 0) then
163	print *,'Found invalid header line: '
164	print *,'''',trim(line),''''
165	cycle READLINE
166	endif
167	END SELECT
168
169	lastpos = lastpos+pos
170
171	enddo
172
173	#ifdef TEST
174	! Test
175	print *,'Header Line: '
176	print *,TblTail%center, TblTail%subcenter, TblTail%MasterTblV, &
177	TblTail%LocalTblV
178	#endif
179
180
181	!
182	! We found the header, cycle so that the header is not interpereted
183	! as a parameter line.
184	!
185	cycle READLINE
186
187	endif
188
189	if (.NOT. ASSOCIATED(TblTail%ParmHead)) then
190	ALLOCATE (TblTail%ParmHead, stat=status)
191	if (status .ne. 0) then
192	print *,'Could not allocate space for TblTail%ParmHead, continuing'
193	cycle READLINE
194	endif
195	TblTail%ParmTail => TblTail%ParmHead
196	else
197	ALLOCATE (TblTail%ParmTail%next, STAT=status)
198	if (status .ne. 0) then
199	print *,'Could not allocate space for TblTail%ParmTail%next, continuing'
200	cycle READLINE
201	endif
202	TblTail%ParmTail%previous => TblTail%ParmTail
203	TblTail%ParmTail => TblTail%ParmTail%next
204	endif
205	nullify(TblTail%ParmTail%next)
206
207	!
208	! Parse the Parameter line
209	!
210	lastpos = 0
211	do idx = 1,7
212	pos = index(line(lastpos+1:maxLineSize), "\|")
213
214	if (pos .lt. 0) then
215	print *,'Found invalid header line: '
216	print *,'''',trim(line),''''
217	if (associated(TblTail%previous)) then
218	TblTail => TblTail%previous
219	else
220	nullify(TblTail)
221	endif
222	cycle READLINE
223	endif
224
225	SELECT CASE (idx)
226	CASE (1)
227	read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%ParmTail%Disc
228	if (status .ne. 0) then
229	print *,'Found invalid line: '
230	print *,'''',trim(line),''''
231	cycle READLINE
232	endif
233	CASE (2)
234	read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%ParmTail%Category
235	if (status .ne. 0) then
236	print *,'Found invalid line: '
237	print *,'''',trim(line),''''
238	cycle READLINE
239	endif
240	CASE (3)
241	read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%ParmTail%ParmNum
242	if (status .ne. 0) then
243	print *,'Found invalid line: '
244	print *,'''',trim(line),''''
245	cycle READLINE
246	endif
247	CASE (4)
248	TblTail%ParmTail%WRFNameString = &
249	trim(adjustl(line(lastpos+1:lastpos+pos-1)))
250	CASE (5)
251	TblTail%ParmTail%Description = &
252	trim(adjustl(line(lastpos+1:lastpos+pos-1)))
253	CASE (6)
254	read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%ParmTail%DecScl
255	if (status .ne. 0) then
256	print *,'Found invalid line: '
257	print *,'''',trim(line),''''
258	cycle READLINE
259	endif
260	CASE (7)
261	read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%ParmTail%BinScl
262	if (status .ne. 0) then
263	print *,'Found invalid line: '
264	print *,'''',trim(line),''''
265	cycle READLINE
266	endif
267	END SELECT
268
269	lastpos = lastpos+pos
270
271	enddo
272
273	#ifdef TEST
274	! Test Code
275	delim = '\|'
276	write(6,'(I4,A1,I4,A1,I4,A1,A12,A1,A42,A1,I4,A1,I4,A1)') &
277	TblTail%ParmTail%Disc, delim, &
278	TblTail%ParmTail%Category, delim, &
279	TblTail%ParmTail%ParmNum, delim, &
280	trim(TblTail%ParmTail%WRFNameString), delim, &
281	trim(TblTail%ParmTail%Description), delim, &
282	TblTail%ParmTail%DecScl, delim, &
283	TblTail%ParmTail%BinScl, delim
284	#endif
285
286	!
287	! Parse the WRFNameString
288	!
289	status = 0
290	lastpos = 0
291	idx = 1
292	do while (pos .gt. 0)
293	pos = index(TblTail%ParmTail%WRFNameString(lastpos+1:maxLineSize), ",")
294	if (pos .le. 0) then
295	end = lastpos+maxLineSize
296	else
297	end = lastpos+pos-1
298	endif
299	read(TblTail%ParmTail%WRFNameString(lastpos+1:end),*) &
300	TblTail%ParmTail%WRFNames(idx)
301	lastpos = lastpos + pos
302	idx = idx + 1
303	enddo
304	TblTail%ParmTail%numWRFNames = idx-1
305
306	#ifdef TEST
307	write(6,*)'WRFNames: ',&
308	(trim(TblTail%ParmTail%WRFNames(idx)),' ', &
309	idx=1,TblTail%ParmTail%numWRFNames)
310	#endif
311
312	enddo READLINE
313
314	close ( unit = fileunit)
315
316	end subroutine load_grib2map
317
318	!*****************************************************************************
319	!
320	! Routine to find and return the grib2 information associated with a WRF
321	! parameter.
322	!
323	!*****************************************************************************
324
325	subroutine get_parminfo(parmname, center, subcenter, MasterTblV, &
326	LocalTblV, Disc, Category, ParmNum, DecScl, BinScl, ierr)
327
328	USE grib2tbls_types
329	Implicit None
330
331	character(),intent(in) :: parmname
332	integer ,intent(out) :: center, subcenter, MasterTblV, LocalTblV, &
333	Disc, Category, ParmNum, DecScl, BinScl
334	TYPE (grib2Entries_type), pointer :: ParmPtr
335	TYPE (grib2tbls_type) , pointer :: TblPtr
336	integer :: idx
337	logical :: found
338	integer :: ierr
339
340
341	!
342	! Loop through tables
343	!
344
345	found = .false.
346	TblPtr => TblHead
347	TABLE : DO
348
349	if ( .not. associated(TblPtr)) then
350	exit TABLE
351	endif
352
353	!
354	! Loop through parameters
355	!
356	ParmPtr => TblPtr%ParmHead
357
358	PARAMETER : DO
359
360	if ( .not. associated(ParmPtr)) then
361	exit PARAMETER
362	endif
363
364	!
365	! Loop through WRF parameter names for the table parameter entry
366	!
367	WRFNAME : do idx = 1,ParmPtr%numWRFNames
368	if (parmname .eq. ParmPtr%WRFNames(idx)) then
369	found = .true.
370	exit TABLE
371	endif
372	enddo WRFNAME
373
374	ParmPtr => ParmPtr%next
375
376	ENDDO PARAMETER
377
378	TblPtr => TblPtr%next
379	ENDDO TABLE
380
381	if (found) then
382	center = TblPtr%center
383	subcenter = TblPtr%subcenter
384	MasterTblV = TblPtr%MasterTblV
385	LocalTblV = TblPtr%LocalTblV
386	Disc = ParmPtr%Disc
387	Category = ParmPtr%Category
388	ParmNum = ParmPtr%ParmNum
389	DecScl = ParmPtr%DecScl
390	BinScl = ParmPtr%BinScl
391	ierr = 0
392	else
393	ierr = 1
394	endif
395
396	end subroutine get_parminfo
397
398	!*****************************************************************************
399	!
400	! Routine to free the lists.
401	!
402	!*****************************************************************************
403
404	subroutine free_grib2map()
405	USE grib2tbls_types
406	Implicit None
407
408	TYPE (grib2Entries_type), pointer :: ParmPtr
409	TYPE (grib2Entries_type), pointer :: ParmSave
410	TYPE (grib2tbls_type) , pointer :: TblPtr
411	TYPE (grib2tbls_type) , pointer :: TblSave
412
413	TblPtr => TblHead
414	TABLE : DO
415
416	if ( .not. associated(TblPtr)) then
417	exit TABLE
418	endif
419
420	!
421	! Loop through parameters
422	!
423	ParmPtr => TblPtr%ParmHead
424
425	PARAMETER : DO
426
427	if ( .not. associated(ParmPtr)) then
428	exit PARAMETER
429	endif
430
431	ParmSave => ParmPtr%next
432	deallocate(ParmPtr)
433	ParmPtr => ParmSave
434
435	ENDDO PARAMETER
436
437
438	TblSave => TblPtr%next
439	deallocate(TblPtr)
440	TblPtr => TblSave
441
442	ENDDO TABLE
443
444	end subroutine free_grib2map

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

Download in other formats:

Original Format