source: trunk/WRF.COMMON/WRFV3/external/io_grib2/read_grib2map.F @ 3567

Last change on this file since 3567 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: 12.7 KB
Line 
1!*****************************************************************************
2!
3! Routine to fill a grib2map structure (linked list).
4!
5!*****************************************************************************
6
7subroutine 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
316end subroutine load_grib2map
317
318!*****************************************************************************
319!
320! Routine to find and return the grib2 information associated with a WRF
321!    parameter.
322!
323!*****************************************************************************
324
325subroutine 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
396end subroutine get_parminfo
397
398!*****************************************************************************
399!
400! Routine to free the lists.
401!
402!*****************************************************************************
403
404subroutine 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
444end subroutine free_grib2map
Note: See TracBrowser for help on using the repository browser.