!*****************************************************************************!
! Subroutine PARSE_TABLE !
! !
! Purpose: !
! Read the Vtable, and fill arrays in the TABLE module with the Vtable !
! information. Broadly, the Vtable file is how the user tells the !
! program what fields to extract from the archive files. !
! !
! Argument list: !
! Input: DEBUG_LEVEL: 0 = no prints, bigger numbers = more prints !
!
! Externals: !
! Module TABLE !
! Subroutine ABORT !
! !
! Side Effects: !
! !
! - File "Vtable" is opened, read, and closed as Fortran unit 10. !
! !
! - Various prints, especially if DEBUG_PRINT = .TRUE. !
! !
! - Abort for some miscellaneous error conditions. !
! !
! - Variables in module TABLE are filled., specifically, variables !
! MAXVAR !
! MAXOUT !
! !
! - Arrays in module TABLE are filled., specifically, arrays !
! NAMVAR !
! NAMEOUT !
! UNITOUT !
! DESCOUT !
! GCODE !
! LCODE !
! LEVEL1 !
! LEVEL2 !
! IPRTY !
! DUNITS !
! DDESC !
! !
! Author: Kevin W. Manning !
! NCAR/MMM !
! Summer 1998, and continuing !
! SDG !
! !
!*****************************************************************************!
subroutine parse_table(debug_level,vtable_columns)
use Table
use module_debug
use stringutil
implicit none
integer :: debug_level
character(LEN=255) :: string = ' '
integer :: ierr
integer :: istart, ibar, i, j, ipcount
integer :: jstart, jbar, jmax, tot_bars
integer :: vtable_columns
integer :: nstart, maxtmp
logical :: lexist
character(len=9) :: tmp9
! added for IBM
blankcode = -99
splatcode = -88
! end added for IBM
! Open the file called "Vtable"
open(10, file='Vtable', status='old', form='formatted', iostat=ierr)
! Check to see that the OPEN worked without error.
if (ierr.ne.0) then
inquire(file='Vtable', exist=LEXIST)
call mprintf(.true.,STDOUT," ***** ERROR in Subroutine PARSE_TABLE:")
call mprintf(.true.,LOGFILE," ***** ERROR in Subroutine PARSE_TABLE:")
if (.not.lexist) then
call mprintf(.true.,STDOUT,"Problem opening file Vtable.")
call mprintf(.true.,STDOUT,"File ''Vtable'' does not exist.")
call mprintf(.true.,LOGFILE,"Problem opening file Vtable.")
call mprintf(.true.,LOGFILE,"File ''Vtable'' does not exist.")
else
call mprintf(.true.,STDOUT,"Problem opening file Vtable.")
call mprintf(.true.,STDOUT,"File Vtable exists, but Fortran OPEN statement")
call mprintf(.true.,STDOUT,"failed with error %i",i1=ierr)
call mprintf(.true.,LOGFILE,"Problem opening file Vtable.")
call mprintf(.true.,LOGFILE,"File Vtable exists, but Fortran OPEN statement")
call mprintf(.true.,LOGFILE,"failed with error %i",i1=ierr)
endif
call mprintf(.true.,ERROR," ***** Stopping in Subroutine PARSE_TABLE")
endif
! First, read past the headers, i.e., skip lines until we hit the first
! line beginning with '-'
do while (string(1:1).ne.'-')
read(10,'(A255)', iostat=ierr) string
call mprintf ((ierr /= 0),ERROR,"Read error 1 in PARSE_TABLE.")
enddo
string = ' '
! Now interpret everything from here to the next '-' line:
!
RDLOOP : do while (string(1:1).ne.'-')
read(10,'(A255)', iostat=ierr) string
call mprintf ((ierr /= 0),ERROR,"Read error 2 in PARSE_TABLE.")
if (string(1:1).eq.'#') cycle RDLOOP
if (len_trim(string) == 0) cycle RDLOOP
if (string(1:1).eq.'-') then
! Skip over internal header lines
BLOOP : do
read(10,'(A255)', iostat=ierr) string
if (ierr /= 0) exit RDLOOP
if (len_trim(string) == 0) then
cycle BLOOP
else if (string(1:1) == '#') then
cycle BLOOP
else
exit BLOOP
endif
enddo BLOOP
do while (string(1:1).ne.'-')
read(10,'(A255)', iostat=ierr) string
call mprintf ((ierr /= 0),ERROR,"Read error 3 in PARSE_TABLE.")
enddo
string(1:1) = ' '
elseif (string(1:1).ne.'-') then
! This is a line of values to interpret and parse.
maxvar = maxvar + 1 ! increment the variable count
! --- Determine Grib1 or Grib2
! If there are seven fields this is a Grib1 Vtable,
! if there are eleven fields this is a Grib2 Vtable.
jstart = 1
jmax=jstart
tot_bars=0
do j = 1, vtable_columns
! The fields are delimited by '|'
jbar = index(string(jstart:255),'|') + jstart - 2
jstart = jbar + 2
if (jstart.gt.jmax) then
tot_bars=tot_bars+1
jmax=jstart
else
cycle
endif
enddo
call mprintf((tot_bars.eq.7.and.vtable_columns.ge.11),ERROR, &
'Vtable does not contain Grib2 decoding information.'// &
' 11 or 12 columns of information is expected.'// &
' *** stopping parse_table ***')
istart = 1
! There are seven fields (Grib1) or eleven fields (Grib2) to each line.
PLOOP : do i = 1, vtable_columns
! The fields are delimited by '|'
ibar = index(string(istart:255),'|') + istart - 2
if (i.eq.1) then
! The first field is the Grib1 param code number:
if (string(istart:ibar) == ' ') then
gcode(maxvar) = blankcode
elseif (scan(string(istart:ibar),'*') /= 0) then
call mprintf(.true.,ERROR,'Parse_table: Please give a '// &
'Grib1 parm code rather than $ in the first column of Vtable '// &
'*** stopping in parse_table ***')
else
read(string(istart:ibar), * ) gcode(maxvar)
endif
elseif (i.eq.2) then
! The second field is the Grib1 level type:
if (string(istart:ibar) == ' ') then
if (lcode(maxvar) /= blankcode) then
call mprintf(.true.,ERROR,'Parse_table: '// &
'Please supply a Grib1 level type in the Vtable: %s '// &
'*** stopping in parse_table ***',s1=string)
else
lcode(maxvar) = blankcode
endif
elseif (scan(string(istart:ibar),'*') /= 0) then
call mprintf(.true.,ERROR,'Parse_table: '// &
"Used a * in Grib1 level type...don't do this! "// &
'*** stopping in parse_table ***')
else
read(string(istart:ibar), *) lcode(maxvar)
endif
elseif (i.eq.3) then
! The third field is the Level 1 value, which may be '*':
if (string(istart:ibar) == ' ') then
level1(maxvar) = blankcode
elseif (scan(string(istart:ibar),'*') == 0) then
read(string(istart:ibar), *) level1(maxvar)
else
level1(maxvar) = splatcode
endif
elseif (i.eq.4) then
! The fourth field is the Level 2 value, which may be blank:
if (string(istart:ibar) == ' ') then
if ( (lcode(maxvar) == 112) .or.&
(lcode(maxvar) == 116) ) then
call mprintf(.true.,ERROR,'Parse_table: '// &
'Level Code expects two Level values. '// &
'*** stopping in parse_table ***')
else
level2(maxvar) = blankcode
endif
elseif (scan(string(istart:ibar),'*') /= 0) then
call mprintf(.true.,ERROR,'Parse_table: '// &
'Please give a Level 2 value (or blank), rather * in Vtable column 4 '// &
'*** stopping in parse_table ***')
else
read(string(istart:ibar), *) level2(maxvar)
endif
elseif (i.eq.5) then
! The fifth field is the param name:
if (string(istart:ibar).ne.' ') then
nstart = 0
do while (string(istart+nstart:istart+nstart).eq.' ')
nstart = nstart + 1
enddo
namvar(maxvar) = string(istart+nstart:ibar)
else
call mprintf(.true.,ERROR,'Parse_table: '// &
'A field name is missing in the Vtable. '// &
'*** stopping in parse_table ***')
endif
elseif (i.eq.6) then
! The sixth field is the Units string, which may be blank:
if (string(istart:ibar).ne.' ') then
nstart = 0
do while (string(istart+nstart:istart+nstart).eq.' ')
nstart = nstart + 1
enddo
Dunits(maxvar) = string(istart+nstart:ibar)
else
Dunits(maxvar) = ' '
endif
elseif (i.eq.7) then
! The seventh field is the description string, which may be blank:
if (string(istart:ibar).ne.' ') then
nstart = 0
do while (string(istart+nstart:istart+nstart).eq.' ')
nstart = nstart + 1
enddo
Ddesc(maxvar) = string(istart+nstart:ibar)
! If the description string is not blank, this is a
! field we want to output. In that case, copy the
! param name to the MAXOUT array:
maxout = maxout + 1
nameout(maxout) = namvar(maxvar)
unitout(maxout) = Dunits(maxvar)
descout(maxout) = Ddesc(maxvar)
else
Ddesc(maxvar) = ' '
endif
elseif (i.eq.8) then
! The eighth field is the Grib2 Product Discipline (see the
! Product Definition Template, Table 4.2).
!cycle RDLOOP
!read(string(istart:ibar), * ,eor=995) g2code(1,maxvar)
if (string(istart:ibar) == ' ') then
g2code(1,maxvar) = blankcode
elseif (scan(string(istart:ibar),'*') /= 0) then
call mprintf(.true.,STDOUT," ERROR reading Grib2 Discipline")
call mprintf(.true.,STDOUT, &
"This Grib2 Vtable line is incorrectly specified:")
call mprintf(.true.,STDOUT," %s",s1=string)
call mprintf(.true.,LOGFILE," ERROR reading Grib2 Discipline")
call mprintf(.true.,LOGFILE, &
"This Grib2 Vtable line is incorrectly specified:")
call mprintf(.true.,LOGFILE," %s",s1=string)
call mprintf(.true.,ERROR,"Stopping in PARSE_TABLE")
else
read(string(istart:ibar), *) g2code(1,maxvar)
endif
elseif (i.eq.9) then
! The ninth field is the Grib2 Parameter Category per Discipline.
if (string(istart:ibar) == ' ') then
g2code(2,maxvar) = blankcode
elseif (scan(string(istart:ibar),'*') /= 0) then
call mprintf(.true.,STDOUT," ERROR reading Grib2 Category")
call mprintf(.true.,STDOUT, &
"This Grib2 Vtable line is incorrectly specified:")
call mprintf(.true.,STDOUT," %s",s1=string)
call mprintf(.true.,LOGFILE," ERROR reading Grib2 Category")
call mprintf(.true.,LOGFILE, &
"This Grib2 Vtable line is incorrectly specified:")
call mprintf(.true.,LOGFILE," %s",s1=string)
call mprintf(.true.,ERROR,"Stopping in PARSE_TABLE")
else
read(string(istart:ibar), * ) g2code(2,maxvar)
endif
elseif (i.eq.10) then
! The tenth field is the Grib2 Parameter Number per Category.
if (string(istart:ibar) == ' ') then
g2code(3,maxvar) = blankcode
elseif (scan(string(istart:ibar),'*') /= 0) then
call mprintf(.true.,STDOUT, &
" ERROR reading Grib2 Parameter Number ")
call mprintf(.true.,STDOUT, &
"This Grib2 Vtable line is incorrectly specified:")
call mprintf(.true.,STDOUT," %s",s1=string)
call mprintf(.true.,LOGFILE, &
" ERROR reading Grib2 Parameter Number ")
call mprintf(.true.,LOGFILE, &
"This Grib2 Vtable line is incorrectly specified:")
call mprintf(.true.,LOGFILE," %s",s1=string)
call mprintf(.true.,ERROR,"Stopping in PARSE_TABLE")
else
read(string(istart:ibar), * ) g2code(3,maxvar)
endif
elseif (i.eq.11) then
! The eleventh field is the Grib2 Level Type (see the Product
! Definition Template, Table 4.5).
if (string(istart:ibar) == ' ') then
if (g2code(4,maxvar) /= blankcode) then
call mprintf(.true.,STDOUT," ERROR reading Grib2 Level Type ")
call mprintf(.true.,STDOUT, &
"This Grib2 Vtable line is incorrectly specified:")
call mprintf(.true.,STDOUT," %s",s1=string)
call mprintf(.true.,LOGFILE," ERROR reading Grib2 Level Type ")
call mprintf(.true.,LOGFILE, &
"This Grib2 Vtable line is incorrectly specified:")
call mprintf(.true.,LOGFILE," %s",s1=string)
call mprintf(.true.,ERROR,"Stopping in PARSE_TABLE")
else
g2code(4,maxvar) = blankcode
endif
elseif (scan(string(istart:ibar),'*') /= 0) then
call mprintf(.true.,STDOUT,"ERROR in Subroutine Parse_table: ")
call mprintf(.true.,STDOUT, &
"Used a * in Grib2 level type...don't do this! ")
call mprintf(.true.,STDOUT," %s ",s1=string)
call mprintf(.true.,LOGFILE,"ERROR in Subroutine Parse_table: ")
call mprintf(.true.,LOGFILE, &
"Used a * in Grib2 level type...don't do this! ")
call mprintf(.true.,LOGFILE," %s ",s1=string)
call mprintf(.true.,ERROR," ***** Abort in Subroutine PARSE_TABLE")
else
read(string(istart:ibar), *) g2code(4,maxvar)
endif
elseif (i.eq.12) then
! The twelfth field is the Grib2 Product Definition Template number
! Defaults to template 4.0, an instantaneous horizontal field.
! The only other supported value is 8 - an accumulated or averaged field.
if (istart .lt. ibar) then
if (string(istart:ibar) == ' ') then
g2code(5,maxvar) = 0
elseif (scan(string(istart:ibar),'*') /= 0) then
call mprintf(.true.,STDOUT, &
" ERROR reading Grib2 Parameter Number ")
call mprintf(.true.,STDOUT, &
"This Grib2 Vtable line is incorrectly specified:")
call mprintf(.true.,STDOUT," %s",s1=string)
call mprintf(.true.,LOGFILE, &
" ERROR reading Grib2 Parameter Number ")
call mprintf(.true.,LOGFILE, &
"This Grib2 Vtable line is incorrectly specified:")
call mprintf(.true.,LOGFILE," %s",s1=string)
call mprintf(.true.,ERROR,"Stopping in PARSE_TABLE")
else
read(string(istart:ibar), * ) g2code(5,maxvar)
endif
else ! occurs when 11 columns are in the Vtable rather than 12.
g2code(5,maxvar) = 0
endif
endif
istart = ibar + 2
enddo PLOOP ! 1,vtable_columns
endif
!995 continue
enddo RDLOOP
! Now we have finished reading the file.
close(10)
! Now remove duplicates from the NAMEOUT array. Duplicates may arise
! when we have the same name referred to by different level or parameter
! codes in some dataset.
maxtmp = maxout
do i = 1, maxtmp-1
do j = i+1, maxtmp
if ((nameout(i).eq.nameout(j)).and.(nameout(j).ne.' ')) then
call mprintf(.true.,DEBUG, &
"Duplicate name. Removing %s from output list.",s1=nameout(j))
nameout(j:maxlines-1) = nameout(j+1:maxlines)
unitout(j:maxlines-1) = unitout(j+1:maxlines)
descout(j:maxlines-1) = descout(j+1:maxlines)
maxout = maxout - 1
endif
enddo
enddo
! Compute a priority level based on position in the table:
! This assumes Grib.
! Priorities are used only for surface fields. If it is not a
! surface fields, the priority is assigned a value of 100.
! For surface fields, priorities are assigned values of 100, 101,
! 102, etc. in the order the field names appear in the Vtable.
ipcount = 99
do i = 1, maxvar
if ((lcode(i).eq.105).or.(lcode(i).eq.118)) then
ipcount = ipcount + 1
iprty(i) = ipcount
elseif (lcode(i).eq.116.and.level1(i).le.50.and.level2(i).eq.0) then
ipcount = ipcount + 1
iprty(i) = ipcount
else
iprty(i) = 100
endif
enddo
if (debug_level .gt. 0) then
write(*,'(//"Read from file ''Vtable'' by subroutine PARSE_TABLE:")')
call mprintf(.true.,DEBUG, &
"Read from file Vtable by subroutine PARSE_TABLE:")
do i = 1, maxvar
if (vtable_columns.ge.11) then
write(*,'(4I6, 3x,A10, 5I6)')&
gcode(i), lcode(i), level1(i), level2(i), namvar(i), &
g2code(1,i), g2code(2,i), g2code(3,i), g2code(4,i), g2code(5,i)
write(tmp9,'(i9)') gcode(i)
call mprintf(.true.,DEBUG,'%s ',s1=tmp9(4:9),newline=.false.)
write(tmp9,'(i9)') lcode(i)
call mprintf(.true.,DEBUG,'%s ',s1=tmp9(4:9),newline=.false.)
write(tmp9,'(i9)') level1(i)
call mprintf(.true.,DEBUG,'%s ',s1=tmp9(4:9),newline=.false.)
write(tmp9,'(i9)') level2(i)
call mprintf(.true.,DEBUG,'%s ',s1=tmp9(4:9),newline=.false.)
write(tmp9,'(a9)') namvar(i)(1:9)
call right_justify(tmp9,9)
call mprintf(.true.,DEBUG,tmp9,newline=.false.)
do j = 1, 5
write(tmp9,'(i9)') g2code(j,i)
call mprintf(.true.,DEBUG,'%s ',s1=tmp9(4:9),newline=.false.)
enddo
call mprintf(.true.,DEBUG,' ',newline=.true.)
else
write(*,'(4I6, 3x,A10)')&
gcode(i), lcode(i), level1(i), level2(i), namvar(i)
endif
enddo
write(*,'(//)')
endif
end subroutine parse_table