C$PRAGMA C (GBF_WRIT)
C$PRAGMA C (GET_APPS_DEFAULTS)
c =====================================================================
c pgm: engrib (iupr,iuout,ibug,kyr,kmo,kda,khr,kmn,
c lwcol,ncol,lsrow,nrow,igds,
c mptnum,iocent,modlid,ngrid,iparm,itunit,ntup1,ntup2,
c itrang,nsbctr,ibinf,idec,iresfl,rlov,iscan,ipkflg,
c idatyp,kbuf,ifld,fld,wfld,ibmap,itot,istat)
c
c in: iupr .... unit number of output
c in: iuout .... unit number of GRIB encoded binary output file
c in: ibug .... debug control
c
c computation time:
c in: kyr .... year (4 digits)
c in: kmo .... month (1 to 12)
c in: kda .... day (1 to 31)
c in: khr .... hour (0 to 23)
c in: kmn .... minute (0 to 59)
c
c in: lwcol .... local west most HRAP column
c in: ncol .... number of HRAP columns
c in: lsrow .... local south most HRAP row
c in: nrow .... number of HRAP rows
c
c in: igds .... grid definition section array
c
c GRIB stuff:
c in: mptnum .... parameter table number
c in: iocent .... identification of originating center (Table 0)
c in: modlid .... model identification (Table A)
c in: ngrid .... grid number (Table B)
c in: iparm .... indicator of parameters and units (Table 2)
c in: itunit .... forecast time units (Table 4)
c in: ntup1 .... number of time units P1
c in: ntup2 .... number of time units P2
c in: itrang .... time range indicator (Table 5)
c in: nsbctr .... sub-center (Table C)
c in: ibinf .... binary scaling factor
c in: idec .... decimal scale factor (power of 10)
c in: iresfl .... resolution and component flag (Table 7)
c in: rlov .... longitude of meridian parallel to y-axis
c in: iscan .... scanning mode flag (Table 8)
c in: ipkflg .... packing (0 - simple, 1 - second order)
c in: idatyp .... data input type:
c 0 - floating point in array 'fld'
c 1 - integer in array 'ifld'
c in: kbuf .... array to hold packed message
c in: ifld .... integer array containing gridded values
c in: fld .... real array containing gridded values (metric)
c in: wfld .... work real array
c in: ibmap .... bitmap array
c
c out: itot .... number of bytes output to array kbuf
c out: istat .... status code
c =====================================================================
c
subroutine engrib (iupr,iuout,ibug, kyr,kmo,kda,khr,kmn,
1 lwcol,ncol,lsrow,nrow, igds,
2 mptnum,iocent,modlid,ngrid,iparm,itunit,ntup1,ntup2,
3 itrang,nsbctr,ibinf,idec,iresfl,rlov,iscan,ipkflg,
4 idatyp, kbuf,ifld,fld,wfld, ibmap, itot, istat)
c
c.......................................................................
c
c This routine initializes variables needed by the GRIB encoder,
c calls the GRIB encoder routine and outputs the GRIB encoded data.
c
c.......................................................................
c Initially written by
c Tim Sweeney, HRL Dec 10, 1992
c
c Changed to pass many GRIB variables thru argument list.
c Tim Sweeney, HRL Nov 1998
c.......................................................................
c
character*1 pds(28),kbuf(*)
character*2 subcenter0
character*25 appsvar
real fld(*),wfld(*)
integer ifld(*)
integer id(25)
integer igds(*)
integer ibdsfl(12)
integer ibmap(*)
C
C ================================= RCS keyword statements ==========
CHARACTER*68 RCSKW1,RCSKW2
DATA RCSKW1,RCSKW2 / '
.$Source: /fs/hseb/ob72/wfo_rfc/precip_proc/source/gribit/src/RCS/engrib.f,v $
. $', '
.$Id: engrib.f,v 1.2 2006/09/27 12:39:11 pst Exp $
. $' /
C ===================================================================
C
c
if (ibug.gt.0) write (iupr,*) 'enter engrib'
c
if (ibug.gt.0) then
write (iupr,10) kyr,kmo,kda,khr,kmn
10 format (' kyr=',i4,' kmo=',i2,' kda=',i2,' khr=',i2,' kmn=',i2)
write (iupr,*) 'lwcol=',lwcol,' ncol=',ncol,
+ ' lsrow=',lsrow,' nrow=',nrow
endif
c
istat = 0
c
c
c data input: 0 - floating point in array 'fld'
c 1 - integer in array 'ifld'
itype = idatyp
c
c===================================================================
c
c PRODUCT DEFINITION SECTION (PDS)
c
c===================================================================
c ipflag control: 0 - make PDS from user supplied array (id)
c for w3fi68 input
c 1 - user supplying PDS
ipflag = 0
c
c number of bytes in PDS
id(1) = 28
c
c parameter table version number (NWS field - Oct 98)
id(2) = mptnum
c
c identification of originating center (Table 0)
id(3) = iocent
c
c model identification (Table A)
id(4) = modlid
c
c grid identification (Table B)
id(5) = ngrid
if (ngrid.eq.240) id(5) = 255
c
c include GDS section (0-no, 1-yes) (Table 1)
id(6) = 1
c
c include BMS section (0-no, 1-yes) (also Table 1)
id(7) = 1
c
c indicator of parameters and units (Table 2)
id(8) = iparm
c
c indicator of type of level (Table 3)
c 1 - surface
id(9) = 1
c
c value 1 of level (0 for level 1)
id(10) = 0
c
c value 2 of level (0 for level 1)
id(11) = 0
c
c elements 12-16 are year, month, day, hour, minute
c model computation time (last data)
c year GRIB year
c 1998 98
c 1999 99
c 2000 100
c 2001 1
c 2002 2
kcc = kyr/100
id(12) = kyr - kcc*100
if (id(12).le.0) id(12) = 100
id(13) = kmo
id(14) = kda
id(15) = khr
id(16) = kmn
c
c fcst time unit (Table 4)
id(17) = itunit
c
c p1 period of time (number of time units)
id(18) = ntup1
c
c p2 period of time (number of time units)
id(19) = ntup2
c
c time range indicator (Table 5)
id(20) = itrang
c
c number included in average when average or accumulated value
c indicated in Table 5
id(21) = 0
c
c number missing from averages
id(22) = 0
c
c century of initial reference (20, change to 21 on Jan 1, 2001, etc.)
c year GRIB century
c 1998 20
c 1999 20
c 2000 20
c 2001 21
c 2002 21
id(23) = (kyr-1)/100 + 1
c
c identification of sub-center Table C
c for originating center = 9
c RFCs 150 to 162
id(24) = nsbctr
c
c check value of grib_set_subcenter_0 token
c if set to ON, then set id(24) to 0
c
appsvar='grib_set_subcenter_0'
lappsvar=lenstr(appsvar)
call get_apps_defaults (appsvar,lappsvar,subcenter0,lsub0)
if(subcenter0.eq.'ON'.or.subcenter0.eq.'on'
* .or.subcenter0.eq.'On') id(24) = 0
c
c decimal scale factor (power of 10)--number of decimal positions
id(25) = idec
c
c id(26) = 0
c id(27) = 0
c id(28) = 0
c end PDS
c
c=======================================================================
c
c GRID DEFINTION SECTION (GDS)
c
c=======================================================================
c igflag control:
c 0 - make GDS based on 'igrid' value
c 1 - make GDS from user supplied info in 'igds' and 'igrid' value
c for w3fi74 input (but doc in w3fi71)
c
igflag = 1
c
c grid identification: # - Table B
c 255 - user defined grid, 'igds' must be
c supplied and igflag must = 1
igrid = 255
c
c user defined grid - HRAP National CONUS
c
c resolution and component flag for bit 5 of gds(17)
c 0 = earth oriented winds, 1 = grid oriented winds
icomp = 0
c end GDS
c====================================================================
c
c ibflag control: 0 - make bit map from user supplied data
c # - bit map predefined by center
ibflag = 0
c
c length of bit map to be used to verify length of field
mbmap = ncol*nrow
c
c====================================================================
c
c BINARY DATA SECTION -- PACK DATA
c
c====================================================================
c Reference Table 11 FLAGS
c
c data: 0 - grid point data, 1 - spherical harmonic coefficients
ibdsfl(1) = 0
c
c packing: 0 - simple, 1 - second order
ibdsfl(2) = ipkflg
c
c original data type: 0 - floating point values, 1 - integer
ibdsfl(3) = idatyp
c
c octet 14: 0 - no additional flags, 1 - contains flag bits 5-12
ibdsfl(4) = 0
c
c reserved
ibdsfl(5) = 0
c
c each grid point: 0 - single datum, 1 - matrix of values
ibdsfl(6) = 0
c
c secondary bit maps: 0 - none, 1 - secondary bit maps present
ibdsfl(7) = 0
c
c second order values have: 0 - constant width, 1 - different widths
ibdsfl(8) = 0
c
ibdsfl(9) = 0
ibdsfl(10) = 0
ibdsfl(11) = 0
ibdsfl(12) = 0
c
c length for packing data from power of 2 (number of bits)
c 0 - best fit using variable bit packer w3fi58
c 8, 12, etc. - rescales to fit fixed number of bits using w3fi59
c
c binary scaling (3=nearest eighth value)
call getbit (id(7),ibinf,id(25),mbmap,ibmap,fld,
+ wfld,fmin,fmax,nbit)
C
c==================================================================
c
c encode using NCEP's GRIB routines
c
if (ibug.gt.0) write (iupr,*) 'ibinf=',ibinf,' mbmap=',mbmap,
+ ' fmin=',fmin,' fmax=',fmax,' nbit=',nbit
if (ibug.gt.0) write (iupr,20) (ibmap(i),i=1,mbmap)
20 format (' in engrib - (ibmap(i),i=1,mbmap)=' / (1x,50i2))
if (ibug.gt.0) write (iupr,30) (fld(i),i=1,mbmap)
30 format (' in engrib - (fld(i),j=1,mbmap)=' / (1x,15(f6.2,1x)))
if (ibug.gt.0) write (iupr,*) 'in engrib - calling w3fi72'
call w3fi72 (itype,wfld,ifld,nbit,ipflag,id,pds,
+ igflag,igrid,igds,icomp,
+ ibflag,ibmap,mbmap,ibdsfl,
+ npts,kbuf,itot,istat)
if (istat.eq.0) then
if (ibug.gt.0) write (iupr,*) 'in engrib - ',
+ 'calling gbf_writ - itot=',itot
call gbf_writ (itot,kbuf,ier)
else
write (iupr,40) istat
40 format (' ERROR: in GRIB encoding - w3fi72 istat=',i2 /
+ ' Values for istat:' /
+ 5x,'1 = IPFLAG not 0 or 1' /
+ 5x,'2 = IGFLAG not 0 or 1' /
+ 5x,'3 = error converting IEEE F.P. number' /
+ 5x,'4 = W3FI71 error/IGRID not defined' /
+ 5x,'5 = W3FK74 error/grid represntation type not valid' /
+ 5x,'6 = grid too large for packer dimension array see NCEP' /
+ 5x,'7 = length of bit map not equal to size of FLD or IFLD' /
+ 5x,'8 = W3FI73 error, all values in IBMAP are zero')
endif
c
return
c
end