156 lines
5 KiB
Fortran
156 lines
5 KiB
Fortran
C$PRAGMA C (GET_APPS_DEFAULTS)
|
|
c =====================================================================
|
|
c pgm: pintbl (inp,iutw,iupr,ibug,mptnum,istat)
|
|
c
|
|
c in: inp .... unit number of parameter file
|
|
c in: iupr .... unit number of output device
|
|
c in: ibug .... debug control
|
|
c out: mptnum .... parameter table number
|
|
c out: istat .... status code
|
|
c =====================================================================
|
|
c
|
|
subroutine pintbl (inp,iutw,iupr,ibug,mptnum,istat)
|
|
c
|
|
c.......................................................................
|
|
c
|
|
c Routine reads gribparm file to change default parameters.
|
|
c
|
|
c.......................................................................
|
|
c Initially written by
|
|
c Tim Sweeney, HL Apr 2000
|
|
c.......................................................................
|
|
c
|
|
character*1 dum
|
|
character*4 id
|
|
character*5 abv
|
|
character*6 tbid,wmo
|
|
character*25 appsvar
|
|
character*50 des
|
|
character*80 line
|
|
character*50 filnam
|
|
character*128 dirnam
|
|
c
|
|
include 'xmrg_tbl'
|
|
include 'grib_tbl'
|
|
C
|
|
C ================================= RCS keyword statements ==========
|
|
CHARACTER*68 RCSKW1,RCSKW2
|
|
DATA RCSKW1,RCSKW2 / '
|
|
.$Source: /fs/hseb/ob72/wfo_rfc/precip_proc/source/gribit/src/RCS/pintbl.f,v $
|
|
. $', '
|
|
.$Id: pintbl.f,v 1.1 2006/05/03 13:43:59 gsood Exp $
|
|
. $' /
|
|
C ===================================================================
|
|
c
|
|
c
|
|
call prbug ('pintbl',1,1,ibug)
|
|
c
|
|
ccc write (*,*) ' iutw=',iutw,' iupr=',iupr
|
|
c
|
|
istat=0
|
|
c
|
|
c check if directory name specified
|
|
appsvar='grib_tab_dir'
|
|
lappsvar=lenstr(appsvar)
|
|
call get_apps_defaults (appsvar,lappsvar,dirnam,ldirnam)
|
|
if (ldirnam.eq.0) then
|
|
iprint=0
|
|
if (iprint.eq.1) then
|
|
write (iutw,10) appsvar(1:lappsvar)
|
|
if (iupr.ne.iutw) then
|
|
if (iupr.ne.iutw) write (iupr,*)
|
|
write (iupr,10) appsvar(1:lappsvar)
|
|
10 format (' NOTE: apps_default ',a,' not specified.')
|
|
endif
|
|
endif
|
|
go to 120
|
|
endif
|
|
c
|
|
c open file
|
|
filnam = dirnam(1:ldirnam)//'/'//'gribtab'
|
|
lfilnam = lenstr(filnam)
|
|
open (inp,access='sequential',form='formatted',
|
|
+ file=filnam,status='old',iostat=iostat)
|
|
if (iostat.eq.0) then
|
|
write (iutw,20) filnam(1:lfilnam)
|
|
if (iupr.ne.iutw) write (iupr,20) filnam(1:lfilnam)
|
|
20 format (' NOTE: reading from User Table file ',a,'.')
|
|
go to 40
|
|
else
|
|
write (iutw,30) iostat,filnam(1:lfilnam)
|
|
if (iupr.ne.iutw) write (iupr,30) filnam(1:lfilnam)
|
|
30 format (' ERROR: iostat ',i3,' encountered opening file ',a,'.')
|
|
istat = 1
|
|
go to 120
|
|
endif
|
|
c
|
|
c read record
|
|
40 read (inp,'(a)',end=110,err=50) line
|
|
go to 70
|
|
50 write (iutw,60) filnam(1:lfilnam)
|
|
60 format (' ERROR: encountered reading file ',a,'.')
|
|
if (iupr.ne.iutw) write (iupr,60) filnam(1:lfilnam)
|
|
istat = 1
|
|
go to 110
|
|
c
|
|
c determine table id
|
|
70 call tablid (iupr,ibug,line,num,icent,isubc,tbid,istat)
|
|
if (istat.gt.0) then
|
|
go to 40
|
|
else if (tbid.eq.'xmrg ') then
|
|
num = num + 1
|
|
call xmparm (iupr,ibug,line,num,istat)
|
|
mproc = num
|
|
else if (tbid.eq.'qpfwmo'.or.tbid.eq.'QPFWMO') then
|
|
nw1 = 3
|
|
nw2 = 6
|
|
nw3 = 0
|
|
call gbparm (iupr,ibug,line,nw1,nw2,nw3,num,wmo,
|
|
+ dum,istat)
|
|
if (num.ge.1.and.num.le.12) qpfwmo(num) = wmo
|
|
else if (tbid.eq.'128 ') then
|
|
nw1 = 3
|
|
nw2 = 5
|
|
nw3 = 50
|
|
call gbparm (iupr,ibug,line,nw1,nw2,nw3,num,id,des,istat)
|
|
if (num.lt.128.or.num.gt.255) then
|
|
write (iutw,80) num
|
|
if (iupr.ne.iutw) write (iupr,80) num
|
|
80 format (' ERROR: table 128 number ',i4,' outside range.')
|
|
else
|
|
abv128(num) = abv
|
|
des128(num) = des
|
|
endif
|
|
else if (tbid.eq.'A ') then
|
|
nw1 = 3
|
|
nw2 = 50
|
|
nw3 = 0
|
|
call gbparm (iupr,ibug,line,nw1,nw2,nw3,num,des,dum,istat)
|
|
if (num.lt.0.or.num.gt.255) then
|
|
write (iutw,90) num
|
|
if (iupr.ne.iutw) write (iupr,90) num
|
|
90 format (' ERROR: process number' ,i4,' outside range.')
|
|
else
|
|
tab_a(num) = des
|
|
endif
|
|
else if (tbid.eq.'C ') then
|
|
nw2 = 4
|
|
nw3 = 50
|
|
call gbparm (iupr,ibug,line,nw1,nw2,nw3,num,id,des,istat)
|
|
if (num.le.0.or.num.gt.255) then
|
|
write (iutw,100) num
|
|
if (iupr.ne.iutw) write (iupr,100) num
|
|
100 format (' ERROR: sub-center number ',i4,' outside range.')
|
|
else
|
|
scid9c(num) = id
|
|
scnam9c(num) = des
|
|
endif
|
|
else
|
|
endif
|
|
go to 40
|
|
c
|
|
110 close (inp)
|
|
c
|
|
120 return
|
|
c
|
|
end
|