read_grib2map.F
References to this file elsewhere.
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