xan/awips2
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
awips2/nativeLib/rary.ohd.pproc.gribit/TEXT/rdxmrgg.f
root 8e80217e59 Initial revision of AWIPS2 11.9.0-7p5 
Former-commit-id: a02aeb236c [formerly 9f19e3f712] [formerly 06a8b51d6d [formerly 64fa9254b946eae7e61bbc3f513b7c3696c4f54f]]
Former-commit-id: 06a8b51d6d
Former-commit-id: 3360eb6c5f
2012-01-06 08:55:05 -06:00

202 lines
6.5 KiB
Fortran
Raw Blame History

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
Reference in a new issue View git blame Copy permalink