327 lines
11 KiB
Fortran
327 lines
11 KiB
Fortran
C$PRAGMA C (GET_APPS_DEFAULTS)
|
|
c =====================================================================
|
|
c pgm: putxmrg (iuout,iudm,ibug,sdatim,fld,kptr,kpds,
|
|
c kgds,kbms,mwcol,msrow,ncol,nrow,
|
|
c ihfld,griddir,lgriddir,xmrgpath,lxmrgpath,
|
|
c ivrb,istat)
|
|
c
|
|
c in: iuout .... unit number of xmrg output file
|
|
c in: iudm .... unit number of RFC HRAP domain file
|
|
c in: ibug .... debug control
|
|
c in: sdatim .... saved date and time of data
|
|
c in: fld .... real array of data
|
|
c in: kptr .... array containing pointers in GRIB message
|
|
c in: kpds .... array containing Product Definition Section
|
|
c parameters
|
|
c in: kgds .... array containing Grid Definition Section parmeters
|
|
c in: kbms .... bitmap array
|
|
c in: mwcol .... most west HRAP column
|
|
c in: msrow .... most south HRAP row
|
|
c in: ncol .... number of HRAP columns
|
|
c in: nrow .... number of HRAP rows
|
|
c in: ihfld .... array of data in xmrg file (SW corner is ihfld(1))
|
|
c in: griddir ... directory and path of xmrg file
|
|
c in: lgriddir .. length of directory name of xmrg file
|
|
c out: xmrgpath .. directory and filename of xmrg file
|
|
c out: lxmrgpath . length of directory and filename of xmrg file
|
|
c in: ivrb .... verbose option
|
|
c i/o: istat .... completion status code
|
|
c =====================================================================
|
|
c
|
|
subroutine putxmrg (iuout,iudm,ibug,sdatim,fld,kptr,kpds,
|
|
+ kgds,kbms,mwcol,msrow,ncol,nrow,
|
|
+ ihfld,griddir,lgriddir,xmrgpath,lxmrgpath,
|
|
+ ivrb,istat)
|
|
c
|
|
c.......................................................................
|
|
c
|
|
c This routine takes parameters from a decoded GRIB file,
|
|
c translates them for an xmrg file and writes the xmrg file.
|
|
c
|
|
c.......................................................................
|
|
c Initially written by
|
|
c Tim Sweeney, HL Jan 2001
|
|
c.......................................................................
|
|
c
|
|
include 'ffg_inc/iuws'
|
|
include 'grib_tbl'
|
|
include 'xmrg_tbl'
|
|
c
|
|
logical*1 kbms(*)
|
|
character*8 rfcid
|
|
character*25 appsvar
|
|
character*50 fidm
|
|
character*128 dirdm,fname,griddir,xmrgpath,xmrgfile
|
|
character user*8,sdatim*20,proces*8,vdatim*20
|
|
character ctime*10
|
|
c
|
|
dimension fld(*)
|
|
c
|
|
integer*2 ihfld(*)
|
|
dimension kptr(*),kpds(*),kgds(*)
|
|
dimension mon(12)
|
|
C
|
|
C ================================= RCS keyword statements ==========
|
|
CHARACTER*68 RCSKW1,RCSKW2
|
|
DATA RCSKW1,RCSKW2 / '
|
|
.$Source: /fs/hseb/ob72/wfo_rfc/precip_proc/source/gribit/src/RCS/putxmrg.f,v $
|
|
. $', '
|
|
.$Id: putxmrg.f,v 1.1 2006/05/03 13:43:59 gsood Exp $
|
|
. $' /
|
|
C ===================================================================
|
|
C
|
|
data mon / 31,28,31,30,31,30,31,31,30,31,30,31 /
|
|
c
|
|
c
|
|
if (ibug.gt.0) write (iupr,*) 'enter putxmrg'
|
|
c
|
|
if (istat.eq.20) go to 240
|
|
c
|
|
c initial values
|
|
mxval = -9999
|
|
c
|
|
c get HRAP domain for a subset (lwcol,lsrow,lncol,lnrow)
|
|
appsvar='hrap_domain_dir'
|
|
lappsvar=lenstr(appsvar)
|
|
call get_apps_defaults (appsvar,lappsvar,dirdm,ldirdm)
|
|
if (ldirdm.eq.0) then
|
|
appsvar='geo_st3_ascii'
|
|
lappsvar=lenstr(appsvar)
|
|
call get_apps_defaults (appsvar,lappsvar,dirdm,ldirdm)
|
|
endif
|
|
appsvar='hrap_domain_id'
|
|
lappsvar=lenstr(appsvar)
|
|
call get_apps_defaults (appsvar,lappsvar,rfcid,lrfcid)
|
|
if (lrfcid.eq.0) then
|
|
appsvar='st3_rfc'
|
|
lappsvar=lenstr(appsvar)
|
|
call get_apps_defaults (appsvar,lappsvar,rfcid,lrfcid)
|
|
endif
|
|
appsvar='hrap_domain_file'
|
|
lappsvar=lenstr(appsvar)
|
|
call get_apps_defaults (appsvar,lappsvar,fidm,lfidm)
|
|
if (lfidm.eq.0) then
|
|
fidm = 'coord_'//rfcid(1:lrfcid)//'.dat'
|
|
lfidm = lenstr(fidm)
|
|
endif
|
|
fname = dirdm(1:ldirdm)//'/'//fidm(1:lfidm)
|
|
lfname=lenstr(fname)
|
|
open (iudm,access='sequential',form='formatted',
|
|
+ file=fname,status='old',iostat=ios)
|
|
if (ios.eq.0) then
|
|
if (ivrb.eq.1) write (iupr,10) fname(1:lfname)
|
|
10 format (/ ' File ',a,' opened.')
|
|
read (iudm,'(i4)',end=30,err=50) lwcol,lsrow,lncol,lnrow
|
|
close (iudm)
|
|
if (ibug.gt.0) write (iupr,*) ' in putxmrg - ',
|
|
+ 'rfcid=',rfcid(1:lfname),
|
|
+ ' lwcol=',lwcol,' lsrow=',lsrow,
|
|
+ ' lncol=',lncol,' lnrow=',lnrow
|
|
if (lwcol.ne.mwcol) write (iupr,20) 'western','column',
|
|
+ fname(1:lfname),lwcol,mwcol
|
|
20 format (' WARNING: ',a,' HRAP grid ',a,' in file ',a,' (',i4,')' /
|
|
+ t11,'is not the same as in GRIB file (',i4,').')
|
|
if (lsrow.ne.msrow) write (iupr,20) 'southern','row',
|
|
+ fname(1:lfname),lsrow,msrow
|
|
if (lncol.ne.ncol) write (iupr,20) 'number of','columns',
|
|
+ fname(1:lfname),lncol,ncol
|
|
if (lnrow.ne.nrow) write (iupr,20) 'number of','rows',
|
|
+ fname(1:lfname),lnrow,nrow
|
|
go to 60
|
|
30 write (iutw,40) 'end-of-file',fname(1:lfname)
|
|
40 format (' ERROR: ',a,' encountered reading file ',a,'.')
|
|
istat = 20
|
|
go to 240
|
|
50 write (iutw,40) 'i/o error',fname(1:lfname)
|
|
istat = 20
|
|
go to 240
|
|
else
|
|
lwcol = mwcol
|
|
lsrow = msrow
|
|
lncol = ncol
|
|
lnrow = nrow
|
|
endif
|
|
c
|
|
c determine user, GRIB Table C
|
|
60 isubc = kpds(23)
|
|
user = ' '
|
|
if (isubc.gt.0.and.isubc.le.255) then
|
|
if (kpds(1).eq.9) then
|
|
user(1:4) = scid9c(isubc)
|
|
else
|
|
endif
|
|
if (ibug.gt.0) write (iupr,70) user,isubc
|
|
70 format (' user=',a,4x,'isubc=',i4)
|
|
else
|
|
write (iupr,80) isubc
|
|
80 format (' ERROR: subcenter number ',i5,' out of range.')
|
|
istat = 20
|
|
go to 240
|
|
endif
|
|
c
|
|
c set date and time of data
|
|
kyr = kpds(8) + (kpds(21)-1)*100
|
|
kmo = kpds(9)
|
|
kda = kpds(10)
|
|
khr = kpds(11)
|
|
kmn = kpds(12)
|
|
itunit = kpds(13)
|
|
nturef = kpds(14)
|
|
ntufc = kpds(15)
|
|
mptver = kpds(19)
|
|
c
|
|
c determine vdatim
|
|
istep = ntufc - nturef
|
|
if (istep.eq.1) then
|
|
call datimi (istep,kmo,kda,kyr,khr,kmn,imo,ida,iyr,ihr,imn,mon)
|
|
isc = 0
|
|
else if (istep.gt.0) then
|
|
imo = kmo
|
|
ida = kda
|
|
iyr = kyr
|
|
ihr = khr
|
|
imn = -kmn
|
|
isc = ntufc
|
|
endif
|
|
call infxdt (imo,ida,iyr,ihr,imn,isc,vdatim)
|
|
if (ibug.gt.0) write (iupr,*) 'imo=',imo,' ida=',ida,' iyr=',iyr,
|
|
+ ' ihr=',ihr,' imn=',imn,' vdatim=',vdatim
|
|
|
|
c
|
|
c check if satellite data
|
|
if (kpds(2).eq.190) then
|
|
c create output xmrg file name
|
|
ipos = 1
|
|
iwid = 4
|
|
num = 1
|
|
call ffi2a (ctime,ipos,iwid,num,iyr,ier)
|
|
ipos = 5
|
|
iwid = 2
|
|
call ffi2a (ctime,ipos,iwid,num,imo,ier)
|
|
ipos = 7
|
|
call ffi2a (ctime,ipos,iwid,num,ida,ier)
|
|
ipos = 9
|
|
call ffi2a (ctime,ipos,iwid,num,ihr,ier)
|
|
do 90 i=1,10
|
|
if (ctime(i:i).eq.' ') ctime(i:i) = '0'
|
|
90 continue
|
|
xmrgfile = 'SATPRE'//ctime//'z'
|
|
lxmrgfile = lenstr(xmrgfile)
|
|
go to 120
|
|
endif
|
|
c
|
|
c check if xmrg output file name specified
|
|
appsvar='grib_xmrg_out_file'
|
|
lappsvar=lenstr(appsvar)
|
|
call get_apps_defaults (appsvar,lappsvar,xmrgfile,lxmrgfile)
|
|
if (lxmrgfile.eq.0) then
|
|
appsvar='grib_out_file'
|
|
lappsvar=lenstr(appsvar)
|
|
call get_apps_defaults (appsvar,lappsvar,xmrgfile,lxmrgfile)
|
|
endif
|
|
if (lxmrgfile.eq.0) then
|
|
write (iutw,100)
|
|
100 format (/ ' Enter XMRG output file name: ',$)
|
|
read (iutr,'(a)',end=240,err=240) xmrgfile
|
|
if (xmrgfile.eq.'.') then
|
|
xmrgfile='grib_xmrg_out_file'
|
|
write (iutw,110) 'XMRG',xmrgfile(1:lenstr(xmrgfile))
|
|
110 format (' NOTE: ',a,' file name set to ',a,'.')
|
|
endif
|
|
lxmrgfile = lenstr(xmrgfile)
|
|
endif
|
|
if (lxmrgfile.eq.0) go to 240
|
|
c
|
|
120 xmrgpath = griddir(1:lgriddir)//'/'//xmrgfile(1:lxmrgfile)
|
|
open (iuout,access='sequential',form='unformatted',
|
|
+ file=xmrgpath,status='unknown',iostat=ios)
|
|
if (ios.eq.0) then
|
|
lxmrgpath = lenstr(xmrgpath)
|
|
if (ivrb.eq.1) write (iutw,130) xmrgpath(1:lxmrgpath)
|
|
130 format (/ ' File ',a,' opened.')
|
|
else
|
|
write (iutw,140) xmrgpath(1:lenstr(xmrgpath))
|
|
140 format (' ERROR: in putxmrg : unable to open file ',a,'.')
|
|
istat = 20
|
|
go to 240
|
|
endif
|
|
c
|
|
c determine process from GRIB Table A and xmrg table for xmrg process
|
|
modlid = kpds(2)
|
|
do 150 ixpm=1,mproc
|
|
if (modlid.eq.xmodlid(ixpm)) go to 170
|
|
150 continue
|
|
c
|
|
c no process defined
|
|
write (iupr,160) istep
|
|
160 format (' ERROR: no process defined in GRIB Table A and xmrg ',
|
|
* ' table for process ',i4,'.')
|
|
istat = 20
|
|
go to 240
|
|
c
|
|
170 proces = xmproc(ixpm)
|
|
if (proces(1:2).ne.'FF') then
|
|
c check for appending time step
|
|
do 190 ipt=1,8
|
|
if (proces(ipt:ipt).eq.'*') then
|
|
ipos = ipt
|
|
iwidth = 2
|
|
num = 1
|
|
call ffi2a (proces,ipos,iwidth,num,istep,istat)
|
|
if (istat.ne.0) then
|
|
write (iupr,180) istep
|
|
180 format (' ERROR: in ffi2a for istep of ',i4,'.')
|
|
istat = 20
|
|
go to 240
|
|
endif
|
|
if (proces(ipt:ipt).eq.' ') proces(ipt:ipt) = '0'
|
|
endif
|
|
190 continue
|
|
else
|
|
proces = abv128(kpds(5))
|
|
proces(6:8) = ' '
|
|
endif
|
|
if (ibug.gt.0) write (iupr,200) proces,modlid
|
|
200 format (' proces=',a,4x,'modlid=',i4)
|
|
c
|
|
c transfer data to sub-set array
|
|
mecol = mwcol + ncol - 1
|
|
mnrow = msrow + nrow - 1
|
|
do 230 irow=1,lnrow
|
|
krow = lsrow + irow - 1
|
|
jrow = krow - msrow + 1
|
|
if (krow.ge.msrow.and.krow.le.mnrow) then
|
|
do 210 icol=1,lncol
|
|
kcol = lwcol + icol - 1
|
|
if (kcol.ge.mwcol.and.kcol.le.mecol) then
|
|
jcol = kcol - mwcol + 1
|
|
ipm = (jrow-1)*ncol + jcol
|
|
ips = (irow-1)*lncol + icol
|
|
if (kbms(ipm).eqv..TRUE.) then
|
|
ihfld(ips) = fld(ipm)*100.
|
|
if (fld(ipm).gt.mxval) mxval = fld(ipm)
|
|
else
|
|
ihfld(ips) = -251
|
|
endif
|
|
else
|
|
ihfld(ips) = -251
|
|
endif
|
|
210 continue
|
|
else
|
|
do 220 icol=1,lncol
|
|
ips = (irow-1)*lncol + icol
|
|
ihfld(ips) = -251
|
|
220 continue
|
|
endif
|
|
230 continue
|
|
c
|
|
c write xmrg file
|
|
call wrxmrg (iuout,iupr,lwcol,lsrow,lncol,lnrow,
|
|
+ user,sdatim,proces,vdatim,mxval,ihfld,istat)
|
|
close (iuout)
|
|
c
|
|
240 return
|
|
c
|
|
end
|
|
|
|
|