c
c	various utility routines
c


	subroutine setprs(kpds, kgds, iprs)
c
c	set the pressure to iprs mb
c
	integer kpds(*), kgds(*)
	kpds(6) = 100
	kpds(7) = iprs
	return
	end

	subroutine setlev(kpds, kgds, level)
c
c	level - compatible with ezwgb, getlev
c
	integer kpds(*), kgds(*), i
	real level

	if (level.gt.256*256) then
	    i = level
	    kpds(6) = i / (256*256)
	    kpds(7) = mod(i,256*256)
	else if (level.ge.2000.0) then
c	    meters - 2000.0
	    kpds(6) = 105
	    kpds(7) = level - 2000.0
	else if (level.gt.1.0) then
c	    prs level
	    kpds(6) = 100
	    kpds(7) = level
	else if (level.ge.0 .and. level.le.1.0) then
c	    sigma level
	    kpds(6) = 107
	    kpds(7) = int(level * 10000.0 + 0.5)
	else if (level.eq.-1.0) then
c	    surface
	    kpds(6) = 1
	    kpds(7) = 0
	else if (level.le.-1.0 .and.level.gt.-256.999) then
	    rlevel = -level
	    kpds(6) = int(rlevel)
	    rlevel = 1000 * (rlevel - int(rlevel))
	    kpds(7) = int(rlevel + 0.5)
	    rlevel = rlevel - kpds(7)
	else if (level.eq.-257.0) then
c	    0 ->1 sigma
	    kpds(6) = 108
	    kpds(7) = 0*256 + 100
	else
	    write(*,*) '*** setlev - bad arg:',level
	endif
	return
	end

	subroutine set2sig(kpds, kgds, sigma1,sigma2)
c
	integer kpds(*), kgds(*)
	real sigma1, sigma2, sig1,sig2

	if (sigma1.lt.sigma2) then
	    sig1 = sigma1
	    sig2 = sigma2
	else
	    sig1 = sigma2
	    sig2 = sigma1
	endif

	kpds(6) = 108
	kpds(7) = 256*int(sig1*100+0.5) + int(sig2*100+0.5)
	return
	end

	subroutine m2lev(meters,lev)
	real meters, lev
	lev = meters + 2000.0
	return
	end
	subroutine lev2m(lev,meters)
	real meters, lev
	meters = lev - 2000.0
	return
	end

	subroutine getlev(kpds, kgds, level)
c
c	get level - compatible with ezwgb
c	0 <= x =< 1.0		sigma
c	1.0 < x < 2000  	pressure
c	2000 <= x < 256*256	meters
c	256*256 <= x		arb level
c
c	-1 = surface
c	-257 = sigma 0..1
c
c	-1 -> -255.999 -> grib level type: 1->255 (0 arguments)
c
	integer kpds(*), kgds(*)
	real level

	if (kpds(6).eq.100) then
c	    pressure
	    level = kpds(7)
	    return
	else if (kpds(6).eq.1) then
c	    surface
	    level = -1.0
	    return
	else if (kpds(6).eq.105) then
c	    meters
	    level = 2000.0 + kpds(7)
	else if (kpds(6).eq.107) then
c	    sigma
	    level = kpds(7) / 10000.0
	    return
	else if (kpds(6).eq.108) then
c	    sigma1 to sigma2
	    s1 = mod(kpds(7),256)
	    s2 = kpds(7)/256
	    if (s1.eq.100.and.s2.eq.0) then
		level = -257.0
	    else
		level = kpds(7)
	    endif
	else if (kpds(6).ge.1.and.kpds(6).le.255) then
	    if (kpds(7).lt.999) then
		level = -(kpds(6)+kpds(7)/1000.0)
	    else
		level = kpds(6)*256*256 + kpds(7)
	    endif
	else
	    level = 99999.0
	endif
	return
	end

	subroutine initnm
c
c	initializes name list
c
	character*8 names(255)
	logical init
	common /shname/names
	data init/.false./
	save init

	if (init) return
	init = .true.

	do 10 i = 1, 255
	    names(i) = 'unknown'
10	continue

	names(1) = 'P'
	names(7) = 'Z'
	names(8) = 'H'
	names(11) = 'T'
	names(12) = 'Tv'
	names(13) = 'Theta'
	names(14) = 'ThetaE'
	names(15) = 'TMax'
	names(16) = 'TMin'
	names(17) = 'TD'
	names(18) = 'T-TD'
	names(33) = 'U'
	names(34) = 'V'
	names(35) = 'Psi'
	names(36) = 'Chi'
	names(39) = 'Omega'
	names(51) = 'SpecH'
	names(52) = 'RH'
	names(53) = 'MixRatio'
	names(54) = 'PrcpWatr'
	names(57) = 'Evap'
	names(61) = 'TtlPrcp'
	names(62) = 'PrcpLrge'
	names(63) = 'PrcpCnvc'
	names(65) = 'SnowEqu'
	names(66) = 'SnowDpth'

	names(71) = 'Cloud'
	names(72) = 'CloudCnv'
	names(73) = 'CloudLow'
	names(74) = 'CloudMid'
	names(75) = 'CloudHi'
	names(80) = 'TWater'
	names(81) = 'LSMask'
	names(84) = 'Albedo'
	names(85) = 'SoilTemp'
	names(86) = 'SoilMois'
	names(111) = 'SWRSfc'
	names(112) = 'LWRSfc'
	names(113) = 'SWRTop'
	names(114) = 'LWRTop'
	names(115) = 'LWR'
	names(116) = 'SWR'
	names(117) = 'GlblRad'
	names(121) = 'LHF'
	names(122) = 'SHF'
	names(150) = 'CovUV'
	names(151) = 'CovUT'
	names(152) = 'CovVT'
	names(155) = 'GFlux'
	names(170) = 'UStress'
	names(171) = 'VStress'
	names(175) = 'PSigLev'

        names(204) = 'SWRDn'
        names(205) = 'LWRDn'
        names(211) = 'SWRUp'
        names(212) = 'LWRUp'

	return
	end

	subroutine name2id(name,id)
c
c	given name (text), return grib-id
c	only common ones supported
c
	character names(255)*8, name*(*)
	common /shname/names

	call initnm
	do 10 i = 1, 255
	    if (names(i).eq.name) then
		id = i
		return
	    endif
10	continue
	write(*,*) 'fix initnm:',name
	stop
	end

	subroutine id2name(id,name)
c
c	given grib-id, return short name
c	only common ones supported
c
	character names(255)*8, name*(*)
	common /shname/names

	call initnm
	name = names(id)
	return
	end

	subroutine setname(kpds, kgds, name)
c
c	set the name of the variable
c	only common one supported
c
	integer kpds(*), kgds(*)
	character*(*) name

	call initnm
	call name2id(name,id)
	if (id.eq.-1) then
	    kpds(5) = 0
	    write(*,*) 'unknown name'
	else
	    kpds(5) = id
	endif
	return
	end

	subroutine setdate(kpds,kgds,iyr,imo,iday,ihour)
c
c	sets the date
c
	integer kpds(*), kgds(*)
	kpds(8) = iyr
	kpds(9) = imo
	kpds(10) = iday
	kpds(11) = ihour
	kpds(12) = 0
	kpds(13) = 0

	return
	end

	subroutine getdate(kpds,kgds,iyr,imo,iday,ihour)
c
c	gets the date
c
	integer kpds(*), kgds(*)
	iyr = kpds(8)
	imo = kpds(9)
	iday = kpds(10)
	ihour = kpds(11)

	return
	end


	subroutine getbit(kpds, kgds, hasbit)
c
c	check for a bitmap
c
	integer kpds(*), kgds(*)
	logical hasbit

	hasbit = mod(kpds(4)/64,2) .eq. 1

	return
	end

        subroutine setbit(kpds, kgds, hasbit)
c
c       set flag for a bitmap
c
        integer kpds(*), kgds(*)
        logical hasbit

	ilow = mod(kpds(4),64)
	ihigh = kpds(4)/128

	if (hasbit) then
	    kpds(4) = ihigh*128 + 64 + ilow
	else
	    kpds(4) = ihigh*128      + ilow
	endif

        return
        end

	subroutine setid(kpds, kgds, id)
c
c	sets id
c
	integer kpds(*), kgds(*)
	kpds(5) = id
	return
	end

	subroutine getid(kpds, kgds, id)
c
c	sets id
c
	integer kpds(*), kgds(*)
	id = kpds(5)
	return
	end

	subroutine gettr(kpds, kgds, trange)
c
c	trange = 'inst', 'acc','ave','climo'
c
	integer kpds(*), kgds(*), itr
	character*(*) trange

	itr = kpds(16)
	if (itr.eq.3) then
	    trange = 'ave'
	elseif (itr.eq.4) then
	    trange = 'acc'
	elseif (itr.eq.51) then
	    trange = 'climo'
	elseif (itr.eq.10) then
	    trange = 'inst'
	elseif (itr.eq.113) then
	    trange = 'ave-in'
	elseif (itr.eq.118) then
	    trange = 'var'
	elseif (itr.eq.123) then
	    trange = 'ave-un'
	else
	    write(*,*) '*** error in gettr (get time-range)'
	    write(*,*) 'kpds(16) =', itr
	    call exit(99)
	endif
	return
	end


	subroutine settr(kpds, kgds, trange)
c
c	trange = 'inst', 'acc','ave','climo'
c
	integer kpds(*), kgds(*), itr
	character*(*) trange

	if (trange.eq.'ave') then
	    kpds(16) = 3
	elseif (trange.eq.'acc') then
	    kpds(16) = 4
	else if (trange.eq.'climo') then
	    kpds(16) = 51
	else if (trange.eq.'inst') then
	    kpds(16) = 10
	else if (trange.eq.'ave-in') then
	    kpds(16) = 113
	else if (trange.eq.'var') then
	    kpds(16) = 118
	else if (trange.eq.'ave-un') then
	    kpds(16) = 123
	else
	    write(*,*) '*** error in settr (get time-range) ',trange
	    call exit(99)
	endif
	end
