202 lines
6.5 KiB
Fortran
202 lines
6.5 KiB
Fortran
c ==================================================================
|
|
c pgm: rdxmrgg (pthnam,iunit,ipr,xver,ixor,iyor,maxx,maxy,
|
|
c user,sdatim,proces,vdatim,mxval,
|
|
c ihfld,istat)
|
|
c
|
|
c in: pthnam .... xmrg file path name
|
|
c in: iunit .... xmrg file unit number
|
|
c in: ipr .... print device number
|
|
c out: xver .... xmrg file format version number
|
|
c i/o: ixor .... most west HRAP column
|
|
c i/o: iyor .... most south HRAP row
|
|
c i/o: maxx .... number of columns
|
|
c i/o: maxy .... number of rows
|
|
c out: user .... office generating the file
|
|
c out: sdatim .... date and time (Informix format) data saved
|
|
c out: process ... process generating the data
|
|
c out: vdatim .... valid date and time (Informix format)
|
|
c out: mxval .... maximum value of data in hundredths of millimeters
|
|
c out: ihfld .... array of HRAP data (southwest corner is ihfld(1))
|
|
c out: istat .... status code and read header flag
|
|
c ==================================================================
|
|
c
|
|
subroutine rdxmrgg (pthnam,iunit,ipr,xver,ixor,iyor,maxx,maxy,
|
|
* user,sdatim,proces,vdatim,mxval,
|
|
* ihfld,istat)
|
|
c
|
|
c....................................................................
|
|
c
|
|
c Routine reads gridded values from a file in xmrg format
|
|
c
|
|
c....................................................................
|
|
c rdxmrg Initially written by
|
|
c Tim Sweeney, HRL Nov 1997
|
|
c
|
|
c Added three more fields to second record. If extra fields not
|
|
c found (error), then rewind and read as old unformat.
|
|
c Tim Sweeney, HRL Oct 1998
|
|
c
|
|
c Adapted from rdxmrg for the need to first read the header and then
|
|
c read the XMRG file, specifically for the gribit routine
|
|
c David T. Miller, RSIS, OHD/HSEB Nov 2007
|
|
c....................................................................
|
|
c
|
|
integer*2 ihfld(*)
|
|
integer irdheader
|
|
c
|
|
character*128 pthnam
|
|
ckwz.10/13/04.user should not include os.
|
|
ckwz character user*10,sdatim*20,proces*8,vdatim*20
|
|
character os*2,user*8,sdatim*20,proces*8,vdatim*20
|
|
C
|
|
C ================================= RCS keyword statements ==========
|
|
CHARACTER*68 RCSKW1,RCSKW2
|
|
DATA RCSKW1,RCSKW2 / '
|
|
.$Source: /fs/hseb/ob82/ohd/pproc/src/gribit/RCS/rdxmrg.f,v $
|
|
. $', '
|
|
.$Id: rdxmrg.f,v 1.1 2006/10/19 16:06:04 dsa Exp $
|
|
. $' /
|
|
C ===================================================================
|
|
C
|
|
c
|
|
irdheader = istat
|
|
|
|
call prbug ('rdxmrgg',1,1,ibug)
|
|
c ibug = 1
|
|
c
|
|
istat = 0
|
|
c
|
|
os = ' '
|
|
user = ' '
|
|
sdatim = ' '
|
|
proces = ' '
|
|
vdatim = ' '
|
|
mxval = -999
|
|
c
|
|
iform = 2
|
|
if (ibug.eq.1) write (ipr,*) 'iform=',iform
|
|
irec = 0
|
|
irow = 0
|
|
c
|
|
c read header records
|
|
10 if (iform.ne.2) then
|
|
rewind (iunit)
|
|
irec=0
|
|
endif
|
|
if (iform.eq.2) then
|
|
iform = 3
|
|
if (ibug.eq.1) write (ipr,*) 'iform=',iform
|
|
c version 2.1 format
|
|
irec=irec+1
|
|
read (iunit,err=10,end=90) ixor,iyor,maxx,maxy
|
|
if (ibug.eq.1) write (ipr,*) 'ixor=',ixor,' iyor=',iyor,
|
|
+ ' maxx=',maxx,' maxy=',maxy
|
|
irec=irec+1
|
|
read (iunit,err=15,end=90) os,user,sdatim,proces,vdatim,mxval,
|
|
+ xver
|
|
if (ibug.eq.1) write (ipr,*) 'os=',os,'user=',user,' sdatim=',
|
|
+ sdatim,' proces=',proces,' vdatim=',vdatim,' mxval=',mxval,
|
|
+ ' xver=',xver
|
|
go to 17
|
|
15 iform = 1
|
|
if (ibug.eq.1) write (ipr,*) 'iform=',iform
|
|
go to 10
|
|
17 if (xver.le.0.0) xver = 2.1
|
|
else if (iform.eq.1) then
|
|
c version 2.0 format
|
|
iform = 4
|
|
if (ibug.eq.1) write (ipr,*) 'iform=',iform
|
|
irec=irec+1
|
|
read (iunit,err=60,end=90) ixor,iyor,maxx,maxy
|
|
if (ibug.eq.1) write (ipr,*) 'ixor=',ixor,' iyor=',iyor,
|
|
+ ' maxx=',maxx,' maxy=',maxy
|
|
irec=irec+1
|
|
read (iunit,err=60,end=90) os,user,vdatim(1:19),proces
|
|
if (ibug.eq.1) write (ipr,*) 'os=',os,'user=',user,
|
|
+ ' vdatim=',vdatim,' proces=',proces
|
|
xver = 2.0
|
|
write(ipr,20)
|
|
20 format (' NOTE: using old xmrg file format.')
|
|
else
|
|
write (ipr,30)
|
|
30 format (' ERROR: cannot read xmrg file headers.')
|
|
istat=1
|
|
go to 100
|
|
endif
|
|
c
|
|
do 35 i=1,len(proces)
|
|
if (proces(i:i).eq.char(0)) then
|
|
if (ibug.eq.1) write (ipr,*) 'i=',i,
|
|
+ 'proces(i:i)=',proces(i:i)
|
|
proces(i:i)=' '
|
|
endif
|
|
35 continue
|
|
c
|
|
if (maxx.eq.0) then
|
|
write (ipr,40) 'maxx'
|
|
40 format (' ERROR: value of variable ',a,' read from xmrg file ',
|
|
+ 'header is zero.')
|
|
istat=1
|
|
endif
|
|
if (maxy.eq.0) then
|
|
write (ipr,40) 'maxy'
|
|
istat=1
|
|
endif
|
|
if (istat.ne.0) go to 100
|
|
|
|
c
|
|
c DTM Nov 07 Check to see if the header has been read or not.
|
|
c If so, go back to the beginning of the file so that
|
|
c the data records can be read on the next call from
|
|
c gribit.
|
|
c
|
|
if (irdheader.ne.0) then
|
|
rewind (iunit)
|
|
else
|
|
|
|
c
|
|
c read data records
|
|
maxval=0
|
|
do 50 irow=1,maxy
|
|
ib = (irow-1)*maxx + 1
|
|
ie = ib + maxx - 1
|
|
irec=irec+1
|
|
read (iunit,err=60,end=90) (ihfld(i),i=ib,ie)
|
|
if (ibug.eq.1) write (ipr,*) 'ib=',ib,' ie=',ie,
|
|
+ ' (ihfld(i),i=ib,ie)=',(ihfld(i),i=ib,ie)
|
|
do 45 i=ib,ie
|
|
if (ihfld(i).gt.maxval) maxval=ihfld(i)
|
|
45 continue
|
|
50 continue
|
|
if (ibug.eq.1) write (ipr,*) 'maxval=',maxval
|
|
endif
|
|
go to 100
|
|
c
|
|
c error reading record
|
|
60 if (irow.eq.0) then
|
|
write (ipr,70) 'i/o error encountered',irec,
|
|
+ pthnam(1:lenstr(pthnam))
|
|
70 format (' ERROR: ',a,' reading xmrg file header record ',i1,
|
|
+ ' from file ',a,'.')
|
|
istat=1
|
|
else
|
|
write (ipr,80) 'i/o error encountered',irow,irec
|
|
80 format (' ERROR: ',a,' reading xmrg data for row ',i4,
|
|
+ ' from record ',i4,'.')
|
|
istat=1
|
|
endif
|
|
go to 100
|
|
c
|
|
c end-of-file encountered
|
|
90 if (irow.eq.0) then
|
|
write (ipr,70) 'end-of-file encountered',irec,
|
|
+ pthnam(1:lenstr(pthnam))
|
|
istat=1
|
|
else
|
|
write (ipr,80) 'end-of-file encountered',irow,irec
|
|
endif
|
|
c
|
|
100 return
|
|
c
|
|
end
|
|
|