!*****************************************************************************
!
! Routine to fill a grib2map structure (linked list).
!
!*****************************************************************************
subroutine load_grib2map(filename, msg, ierr) 3,1
USE grib2tbls_types
Implicit None
character*(*), intent(in) :: filename
character*(*), intent(inout) :: msg
integer , intent(out) :: ierr
integer :: status = 0
integer :: fileunit
logical :: foundunit
character*(maxLineSize) :: line
integer :: firstval
integer :: numtables = 0
character*(1) :: delim
integer :: lastpos
integer :: pos
integer :: idx
integer :: end
logical :: lerr
! Open the file
! First pass:
! Scan the file to determine how many tables are included, and how many
! entries are in each table.
!
! Find an open fileunit
foundunit = .false.
do fileunit = 10,100
inquire(unit=fileunit,opened=lerr)
if (lerr .eqv. .false.) then
foundunit = .true.
exit
endif
enddo
if (foundunit .neqv. .true.) then
write(msg, *)'Could not find unit to open ',filename
ierr = -1
return
endif
! Open the file
open ( unit = fileunit, file=filename, status = 'old', iostat = status)
if (status .ne. 0) then
write(msg, *)'Could not open file ',filename
ierr = -1
return
endif
! Loop through each line to count the number of tables and entries in
! each table.
READLINE: do
!
! Read the line, skip line if line is comment, blank or invalid
!
read(fileunit,'(A)',iostat=status) line
line = adjustl(line)
if (status .lt. 0) then
exit
endif
if (len_trim(line) .eq. 0) then
cycle READLINE
endif
if (line(1:1) .eq. '#') then
cycle READLINE
endif
!
! Read the first value in the line
!
read(line,*,iostat=status) firstval
if (status .ne. 0) then
print *,'Skipping Invalid line in',trim(filename),':'
print *,'''',trim(line),''''
cycle READLINE
endif
!
! If the first value is -1, weve found a new table. Allocate
! a new member in the linked list, and add the information
! to that member
!
if (firstval .eq. -1) then
numtables = numtables + 1
!
! Create and allocate the next member of the linked list
!
if (.NOT. ASSOCIATED(TblHead)) THEN
ALLOCATE (TblHead, stat=status)
if (status .ne. 0) then
print *,'Could not allocate space for TblHead'
exit READLINE
endif
TblTail => TblHead
else
ALLOCATE (TblTail%next, STAT=status)
if (status .ne. 0) then
print *,'Could not allocate space for TblTail%next, continuing'
cycle READLINE
endif
TblTail%previous => TblTail
TblTail => TblTail%next
endif
nullify(TblTail%next)
nullify(TblTail%ParmHead)
!
! Parse the header line
!
lastpos = 0
do idx = 1,5
pos = index(line(lastpos+1:maxLineSize), "|")
if (pos .lt. 0) then
print *,'Found invalid header line: '
print *,'''',trim(line),''''
if (associated(TblTail%previous)) then
TblTail => TblTail%previous
else
nullify(TblTail)
endif
cycle READLINE
endif
SELECT CASE (idx)
CASE (1)
! Do nothing, since this is just the indicator value
CASE (2)
read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%center
if (status .ne. 0) then
print *,'Found invalid header line: '
print *,'''',trim(line),''''
cycle READLINE
endif
CASE (3)
read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%subcenter
if (status .ne. 0) then
print *,'Found invalid header line: '
print *,'''',trim(line),''''
cycle READLINE
endif
CASE (4)
read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%MasterTblV
if (status .ne. 0) then
print *,'Found invalid header line: '
print *,'''',trim(line),''''
cycle READLINE
endif
CASE (5)
read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%LocalTblV
if (status .ne. 0) then
print *,'Found invalid header line: '
print *,'''',trim(line),''''
cycle READLINE
endif
END SELECT
lastpos = lastpos+pos
enddo
#ifdef TEST
! Test
print *,'Header Line: '
print *,TblTail%center, TblTail%subcenter, TblTail%MasterTblV, &
TblTail%LocalTblV
#endif
!
! We found the header, cycle so that the header is not interpereted
! as a parameter line.
!
cycle READLINE
endif
if (.NOT. ASSOCIATED(TblTail%ParmHead)) then
ALLOCATE (TblTail%ParmHead, stat=status)
if (status .ne. 0) then
print *,'Could not allocate space for TblTail%ParmHead, continuing'
cycle READLINE
endif
TblTail%ParmTail => TblTail%ParmHead
else
ALLOCATE (TblTail%ParmTail%next, STAT=status)
if (status .ne. 0) then
print *,'Could not allocate space for TblTail%ParmTail%next, continuing'
cycle READLINE
endif
TblTail%ParmTail%previous => TblTail%ParmTail
TblTail%ParmTail => TblTail%ParmTail%next
endif
nullify(TblTail%ParmTail%next)
!
! Parse the Parameter line
!
lastpos = 0
do idx = 1,7
pos = index(line(lastpos+1:maxLineSize), "|")
if (pos .lt. 0) then
print *,'Found invalid header line: '
print *,'''',trim(line),''''
if (associated(TblTail%previous)) then
TblTail => TblTail%previous
else
nullify(TblTail)
endif
cycle READLINE
endif
SELECT CASE (idx)
CASE (1)
read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%ParmTail%Disc
if (status .ne. 0) then
print *,'Found invalid line: '
print *,'''',trim(line),''''
cycle READLINE
endif
CASE (2)
read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%ParmTail%Category
if (status .ne. 0) then
print *,'Found invalid line: '
print *,'''',trim(line),''''
cycle READLINE
endif
CASE (3)
read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%ParmTail%ParmNum
if (status .ne. 0) then
print *,'Found invalid line: '
print *,'''',trim(line),''''
cycle READLINE
endif
CASE (4)
TblTail%ParmTail%WRFNameString = &
trim(adjustl(line(lastpos+1:lastpos+pos-1)))
CASE (5)
TblTail%ParmTail%Description = &
trim(adjustl(line(lastpos+1:lastpos+pos-1)))
CASE (6)
read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%ParmTail%DecScl
if (status .ne. 0) then
print *,'Found invalid line: '
print *,'''',trim(line),''''
cycle READLINE
endif
CASE (7)
read(line(lastpos+1:lastpos+pos-1),*,iostat=status) TblTail%ParmTail%BinScl
if (status .ne. 0) then
print *,'Found invalid line: '
print *,'''',trim(line),''''
cycle READLINE
endif
END SELECT
lastpos = lastpos+pos
enddo
#ifdef TEST
! Test Code
delim = '|'
write(6,'(I4,A1,I4,A1,I4,A1,A12,A1,A42,A1,I4,A1,I4,A1)') &
TblTail%ParmTail%Disc, delim, &
TblTail%ParmTail%Category, delim, &
TblTail%ParmTail%ParmNum, delim, &
trim(TblTail%ParmTail%WRFNameString), delim, &
trim(TblTail%ParmTail%Description), delim, &
TblTail%ParmTail%DecScl, delim, &
TblTail%ParmTail%BinScl, delim
#endif
!
! Parse the WRFNameString
!
status = 0
lastpos = 0
idx = 1
do while (pos .gt. 0)
pos = index(TblTail%ParmTail%WRFNameString(lastpos+1:maxLineSize), ",")
if (pos .le. 0) then
end = lastpos+maxLineSize
else
end = lastpos+pos-1
endif
read(TblTail%ParmTail%WRFNameString(lastpos+1:end),*) &
TblTail%ParmTail%WRFNames(idx)
lastpos = lastpos + pos
idx = idx + 1
enddo
TblTail%ParmTail%numWRFNames = idx-1
#ifdef TEST
write(6,*)'WRFNames: ',&
(trim(TblTail%ParmTail%WRFNames(idx)),' ', &
idx=1,TblTail%ParmTail%numWRFNames)
#endif
enddo READLINE
close ( unit = fileunit)
end subroutine load_grib2map
!*****************************************************************************
!
! Routine to find and return the grib2 information associated with a WRF
! parameter.
!
!*****************************************************************************
subroutine get_parminfo(parmname, center, subcenter, MasterTblV, & 7,1
LocalTblV, Disc, Category, ParmNum, DecScl, BinScl, ierr)
USE grib2tbls_types
Implicit None
character*(*),intent(in) :: parmname
integer ,intent(out) :: center, subcenter, MasterTblV, LocalTblV, &
Disc, Category, ParmNum, DecScl, BinScl
TYPE (grib2Entries_type), pointer :: ParmPtr
TYPE (grib2tbls_type) , pointer :: TblPtr
integer :: idx
logical :: found
integer :: ierr
!
! Loop through tables
!
found = .false.
TblPtr => TblHead
TABLE : DO
if ( .not. associated(TblPtr)) then
exit TABLE
endif
!
! Loop through parameters
!
ParmPtr => TblPtr%ParmHead
PARAMETER : DO
if ( .not. associated(ParmPtr)) then
exit PARAMETER
endif
!
! Loop through WRF parameter names for the table parameter entry
!
WRFNAME : do idx = 1,ParmPtr%numWRFNames
if (parmname .eq. ParmPtr%WRFNames(idx)) then
found = .true.
exit TABLE
endif
enddo WRFNAME
ParmPtr => ParmPtr%next
ENDDO PARAMETER
TblPtr => TblPtr%next
ENDDO TABLE
if (found) then
center = TblPtr%center
subcenter = TblPtr%subcenter
MasterTblV = TblPtr%MasterTblV
LocalTblV = TblPtr%LocalTblV
Disc = ParmPtr%Disc
Category = ParmPtr%Category
ParmNum = ParmPtr%ParmNum
DecScl = ParmPtr%DecScl
BinScl = ParmPtr%BinScl
ierr = 0
else
ierr = 1
endif
end subroutine get_parminfo
!*****************************************************************************
!
! Routine to free the lists.
!
!*****************************************************************************
subroutine free_grib2map() 2,1
USE grib2tbls_types
Implicit None
TYPE (grib2Entries_type), pointer :: ParmPtr
TYPE (grib2Entries_type), pointer :: ParmSave
TYPE (grib2tbls_type) , pointer :: TblPtr
TYPE (grib2tbls_type) , pointer :: TblSave
TblPtr => TblHead
TABLE : DO
if ( .not. associated(TblPtr)) then
exit TABLE
endif
!
! Loop through parameters
!
ParmPtr => TblPtr%ParmHead
PARAMETER : DO
if ( .not. associated(ParmPtr)) then
exit PARAMETER
endif
ParmSave => ParmPtr%next
deallocate(ParmPtr)
ParmPtr => ParmSave
ENDDO PARAMETER
TblSave => TblPtr%next
deallocate(TblPtr)
TblPtr => TblSave
ENDDO TABLE
end subroutine free_grib2map