!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!                                                                   !!
!!                   GNU General Public License                      !!
!!                                                                   !!
!! This file is part of the Flexible Modeling System (FMS).          !!
!!                                                                   !!
!! FMS is free software; you can redistribute it and/or modify       !!
!! it and are expected to follow the terms of the GNU General Public !!
!! License as published by the Free Software Foundation.             !!
!!                                                                   !!
!! FMS is distributed in the hope that it will be useful,            !!
!! but WITHOUT ANY WARRANTY; without even the implied warranty of    !!
!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the     !!
!! GNU General Public License for more details.                      !!
!!                                                                   !!
!! You should have received a copy of the GNU General Public License !!
!! along with FMS; if not, write to:                                 !!
!!          Free Software Foundation, Inc.                           !!
!!          59 Temple Place, Suite 330                               !!
!!          Boston, MA  02111-1307  USA                              !!
!! or see:                                                           !!
!!          http://www.gnu.org/licenses/gpl.txt                      !!
!!                                                                   !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module atmos_tracer_utilities_mod
! <CONTACT EMAIL="wfc@gfdl.noaa.gov">
!   William Cooke
! </CONTACT>

! <REVIEWER EMAIL="bw@gfdl.noaa.gov">
!   Bruce Wyman
! </REVIEWER>

! <HISTORY SRC="http://www.gfdl.noaa.gov/fms-cgi-bin/cvsweb.cgi/FMS/"/>

! <OVERVIEW>
!     This code provides some utility routines for atmospheric tracers in the FMS framework.
! </OVERVIEW>
! <DESCRIPTION>
!    This module gives utility routines which can be used to provide
!    consistent removal mechanisms for atmospheric tracers.
!
!    In particular it provides schemes for wet and dry deposiiton that
!    can be easily utilized.
!
! </DESCRIPTION>

use types_mod, only : r8
use            fms_mod, only : lowercase, &
                               write_version_number, &
                               stdlog
use   time_manager_mod, only : time_type
!use   diag_manager_mod, only : send_data, &
!                               register_diag_field
use tracer_manager_mod, only : query_method, &
                               get_tracer_names, &
                               get_number_tracers
use  field_manager_mod, only : MODEL_ATMOS, parse
use      constants_mod, only : grav, rdgas, PI
use   horiz_interp_mod, only : horiz_interp

implicit none
private
!-----------------------------------------------------------------------
!----- interfaces -------

public  wet_deposition,    &
        dry_deposition,    &
        interp_emiss,      &
        atmos_tracer_utilities_end, &
        atmos_tracer_utilities_init

!---- version number -----
logical :: module_is_initialized = .FALSE.

character(len=128) :: version = '$Revision$'
character(len=128) :: tagname = '$Id$'

character(len=7), parameter :: mod_name = 'tracers'
!-----------------------------------------------------------------------
!--- identification numbers for  diagnostic fields and axes ----
integer, parameter :: max_tracers = 30
integer :: id_tracer_ddep(max_tracers), id_tracer_wdep(max_tracers)
character(len=32),  dimension(max_tracers) :: tracer_names     = ' '
character(len=32),  dimension(max_tracers) :: tracer_units     = ' '
character(len=128), dimension(max_tracers) :: tracer_longnames = ' '
character(len=32),  dimension(max_tracers) :: tracer_wdep_names     = ' '
character(len=32),  dimension(max_tracers) :: tracer_wdep_units     = ' '
character(len=128), dimension(max_tracers) :: tracer_wdep_longnames = ' '
character(len=32),  dimension(max_tracers) :: tracer_ddep_names     = ' '
character(len=32),  dimension(max_tracers) :: tracer_ddep_units     = ' '
character(len=128), dimension(max_tracers) :: tracer_ddep_longnames = ' '

real(r8), allocatable :: blon_out(:), blat_out(:)

contains

!
! ######################################################################
!
!<SUBROUTINE NAME="atmos_tracer_utilities_init">
!<OVERVIEW>
! This is a routine to create and register the dry and wet deposition
! fields of the tracers.
!</OVERVIEW>
!<DESCRIPTION>
!  This routine creates diagnostic names for dry and wet deposition fields of the tracers.
!  It takes the tracer name and appends "ddep" for the dry deposition field and "wdep" for
!  the wet deposition field. This names can then be entered in the diag_table for
!  diagnostic output of the tracer dry and wet deposition. The module name associated with
!  these fields in "tracers". The units of the deposition fields are assumed to be kg/m2/s.
!</DESCRIPTION>
!<TEMPLATE>
! call atmos_tracer_utilities_init(lonb,latb, mass_axes, Time)
!</TEMPLATE>
!   <IN NAME="lonb" TYPE="real(r8)" DIM="(:)">
!     The longitudes for the local domain.
!   </IN>
!   <IN NAME="latb" TYPE="real(r8)" DIM="(:)">
!     The latitudes for the local domain.
!   </IN>
!   <IN NAME="mass_axes" TYPE="integer" DIM="(3)">
!     The axes relating to the tracer array.
!   </IN>
!   <IN NAME="Time" TYPE="type(time_type)">
!     Model time.
!   </IN>

subroutine atmos_tracer_utilities_init(lonb, latb, mass_axes, Time)

! Routine to initialize the tracer identification numbers.
! This registers the 2D fields for the wet and dry deposition.
real(r8), dimension(:),    intent(in) :: lonb, latb
integer, dimension(3), intent(in) :: mass_axes
type(time_type),       intent(in) :: Time

integer :: ntrace
!
integer :: n, unit
character(len=128) :: name

! Make local copies of the local domain dimensions for use
! in interp_emiss.
      allocate ( blon_out(size(lonb)))
      allocate ( blat_out(size(latb)))
!      allocate ( data_out(size(lonb)-1, size(latb)-1))
      blon_out = lonb
      blat_out = latb

      do n = 1, max_tracers
         write ( tracer_names(n),     100 ) n
         write ( tracer_longnames(n), 102 ) n
         tracer_units(n) = 'none'
      enddo
  100 format ('tr',i2.2)
  102 format ('tracer ',i2.2)

call get_number_tracers(MODEL_ATMOS, num_tracers= ntrace)
   do n = 1, ntrace
!--- set tracer tendency names where tracer names have changed ---

call get_tracer_names(MODEL_ATMOS,n,tracer_names(n),tracer_longnames(n),tracer_units(n))
      write (name,100) n
      if (trim(tracer_names(n)) /= name) then
          tracer_ddep_names(n) = trim(tracer_names(n)) // 'ddep'
          tracer_wdep_names(n) = trim(tracer_names(n)) // 'wdep'
      endif
      write (name,102) n
      if (trim(tracer_longnames(n)) /= name) then
          tracer_wdep_longnames(n) = &
                  trim(tracer_longnames(n)) // ' wet deposition for tracers'
          tracer_ddep_longnames(n) = &
                  trim(tracer_longnames(n)) // ' dry deposition for tracers'
      endif

!     id_tracer_ddep(n) = register_diag_field ( mod_name,               &
!                     trim(tracer_ddep_names(n)), mass_axes(1:2), Time, &
!                     trim(tracer_ddep_longnames(n)),                   &
!                     'kg/m2/s', missing_value=-999.     )
!     id_tracer_wdep(n) = register_diag_field ( mod_name,               &
!                     trim(tracer_wdep_names(n)), mass_axes(1:2), Time, &
!                     trim(tracer_wdep_longnames(n)),                   &
!                     'kg/m2/s', missing_value=-999.    )
   enddo

      call write_version_number (version, tagname)

         call write_namelist_values (stdlog(),ntrace)

      module_is_initialized = .TRUE.

end subroutine atmos_tracer_utilities_init
!</SUBROUTINE>
!
!#######################################################################
!
subroutine write_namelist_values (unit, ntrace)
    integer, intent(in) :: unit, ntrace
    integer :: n

    write (unit,10)
    do n = 1, ntrace
       write (unit,11) trim(tracer_wdep_names(n)),     &
                       trim(tracer_wdep_longnames(n)), &
                       trim(tracer_wdep_units(n))
       write (unit,11) trim(tracer_ddep_names(n)),     &
                       trim(tracer_ddep_longnames(n)), &
                       trim(tracer_ddep_units(n))
    enddo

 10 format (' &TRACER_DIAGNOSTICS_NML', &
          /,'    TRACER:  names  longnames  (units)')
 11 format (a16,2x,a,2x,'(',a,')')

 end subroutine write_namelist_values

!
!#######################################################################
!
!<SUBROUTINE NAME = "dry_deposition">
subroutine dry_deposition( n, is, js, u, v, T, pwt, pfull, &
                           u_star, landmask, dsinku, tracer, Time)
!
!<OVERVIEW>
! Routine to calculate the fraction of tracer to be removed by dry
! deposition.
!</OVERVIEW>
!<DESCRIPTION>
! There are two types of dry deposition coded.
!
! 1) Wind driven derived dry deposition velocity.
!
! 2) Fixed dry deposition velocity.
!
! The theory behind the wind driven dry deposition velocity calculation
! assumes that the deposition can be modeled as a parallel resistance type
! problem.
!
!  Total resistance to HNO3-type dry deposition,
!
       R = Ra + Rb
!  resisa = aerodynamic resistance
!  resisb = surface resistance (laminar layer + uptake)
!         = 5/u*  [s/cm]        for neutral stability
!      Vd = 1/R
!

! For the fixed dry deposition velocity, there is no change in the
! deposition velocity but the variation of the depth of the surface
! layer implies that there is variation in the amount deposited.
!
! To utilize this section of code add one of the following lines as
! a method for the tracer of interest in the field table.
!

! "dry_deposition","wind_driven","surfr=XXX"
!     where XXX is the total resistance defined above.
!
! "dry_deposition","fixed","land=XXX, sea=YYY"
!     where XXX is the dry deposition velocity (m/s) over land
!       and YYY is the dry deposition velocity (m/s) over sea.
!

!</DESCRIPTION>
!<TEMPLATE>
! call dry_deposition( n, is, js, u, v, T, pwt, pfull,
!                           u_star, landmask, dsinku, tracer, Time)
!</TEMPLATE>
!
!  <IN NAME="n" TYPE="integer">
!    The tracer number.
!  </IN>
!  <IN NAME="is, js" TYPE="integer">
!    Start indices for array (computational indices).
!  </IN>
!  <IN NAME="u" TYPE="real(r8)" DIM="(:,:)">
!    U wind field.
!  </IN>
!  <IN NAME="v" TYPE="real(r8)" DIM="(:,:)">
!    V wind field.
!  </IN>
!  <IN NAME="T" TYPE="real(r8)" DIM="(:,:)">
!    Temperature.
!  </IN>
!  <IN NAME="pwt" TYPE="real(r8)" DIM="(:,:)">
!     Pressure differential of half levels.
!  </IN>
!  <IN NAME="pfull" TYPE="real(r8)" DIM="(:,:)">
!     Full pressure levels.
!  </IN>
!  <IN NAME="u_star" TYPE="real(r8)" DIM="(:,:)">
!     Friction velocity.
!  </IN>
!  <IN NAME="landmask" TYPE="logical">
!     Land - sea mask.
!  </IN>
!
!  <OUT NAME="dsinku" TYPE="real(r8)" DIM="(:,:)">
!    The amount of tracer in the surface layer which is dry deposited per second.
!  </OUT>
!
integer, intent(in)                 :: n, is, js
real(r8), intent(in), dimension(:,:)    :: u, v, T, pwt, pfull, u_star, tracer
logical, intent(in), dimension(:,:) :: landmask
type(time_type), intent(in)         :: Time
real(r8), intent(out), dimension(:,:)   :: dsinku

real(r8),dimension(size(u,1),size(u,2)) :: hwindv,frictv,resisa,xxfm,dz
integer :: i,j, flagsr
real(r8)    :: land_dry_dep_vel, sea_dry_dep_vel, surfr
logical :: used, flag
character(len=80) :: name,control,scheme

! Default zero
dsinku = 0.0
flag = query_method ('dry_deposition',MODEL_ATMOS,n,name,control)

if (.not. flag) return

! delta z = dp/(rho * grav)
! delta z = RT/g*dp/p    pwt = dp/g
dz(:,:) = pwt(:,:)*rdgas*T(:,:)/pfull(:,:)

call get_drydep_param(name,control,scheme,land_dry_dep_vel,sea_dry_dep_vel)
if(lowercase(scheme)=='wind_driven') then
! Calculate horizontal wind velocity and aerodynamic resistance:
!   where xxfm=(u*/u) is drag coefficient, Ra=u/(u*^2),
!   and  u*=sqrt(momentum flux)  is friction velocity.
!
!****  Compute dry sinks (loss frequency, need modification when
!****    different vdep values are to be used for species)
        flagsr=parse(control,'surfr',surfr)
        if(flagsr == 0) surfr=500.
        hwindv=sqrt(u**2+v**2)
        frictv=u_star
        resisa=hwindv/(u_star*u_star)
        where (frictv .lt. 0.1) frictv=0.1
        dsinku=(1./(surfr/frictv + resisa))/dz
!
else if (lowercase(scheme)=='fixed') then
!
! For the moment let's try to calculate the delta-z of the bottom
! layer and using a simple dry deposition velocity times the
! timestep, idt, calculate the fraction of the lowest layer which
! deposits.
       where (landmask(:,:))
! dry dep value over the land surface divided by the height of the box.
         dsinku(:,:) = land_dry_dep_vel /dz(:,:)
      elsewhere
! dry dep value over the sea surface divided by the height of the box.
         dsinku(:,:) = sea_dry_dep_vel/dz(:,:)
      endwhere
endif

dsinku(:,:) = MAX(dsinku(:,:), 0.0_r8)
where(tracer>0)
  dsinku=dsinku*tracer
elsewhere
  dsinku=0.0
endwhere

! Now save the dry deposition to the diagnostic manager
! delta z = dp/(rho * grav)
! delta z *rho  = dp/g
! tracer(kgtracer/kgair) * dz(m)* rho(kgair/m3) = kgtracer/m2
! so rho drops out of the equation
         if (id_tracer_ddep(n) > 0 ) then
!         used = send_data ( id_tracer_ddep(n), dsinku*pwt, Time, &
!         is_in =is,js_in=js)
endif
end subroutine dry_deposition
!</SUBROUTINE>
!
!#######################################################################
!
!<SUBROUTINE NAME = "wet_deposition">
!<TEMPLATE>
!CALL wet_deposition(n, T, pfull, phalf, rain, snow, qdt, tracer, tracer_dt, Time, cloud_param, is, js)
!</TEMPLATE>
subroutine wet_deposition(n, T, pfull, phalf, rain, snow, qdt, tracer, tracer_dt, Time, cloud_param, is, js)
!
!<OVERVIEW>
! Routine to calculate the fraction of tracer removed by wet deposition
!</OVERVIEW>
!
!<IN NAME="n" TYPE="integer">
!   Tracer number
!</IN>
!<IN NAME="is, js" TYPE="integer">
!   start indices for array (computational indices)
!</IN>
!<IN NAME="T" TYPE="real(r8)" DIM="(:,:,:)">
!   Temperature
!</IN>
!<IN NAME="pfull" TYPE="real(r8)" DIM="(:,:,:)">
!   Full level pressure field
!</IN>
!<IN NAME="phalf" TYPE="real(r8)" DIM="(:,:,:)">
!   Half level pressure field
!</IN>
!<IN NAME="rain" TYPE="real(r8)" DIM="(:,:)">
!   Precipitation in the form of rain
!</IN>
!<IN NAME="snow" TYPE="real(r8)" DIM="(:,:)">
!   Precipitation in the form of snow
!</IN>
!<IN NAME="qdt" TYPE="real(r8)" DIM="(:,:,:)">
!   The tendency of the specific humidity due to the cloud parametrization
!</IN>
!<IN NAME="tracer" TYPE="real(r8)" DIM="(:,:,:)">
!   The tracer field
!</IN>
!<IN NAME="Time" TYPE="type(time_type)">
!   The time structure for submitting wet deposition as a diagnostic
!</IN>
!<IN NAME="cloud_param" TYPE="character">
!   Is this a convective (convect) or large scale (lscale) cloud parametrization?
!</IN>
!  <OUT NAME="tracer_dt" TYPE="real(r8)" DIM="(:,:,:)">
!  The tendency of the tracer field due to wet deposition.
! </OUT>
!<DESCRIPTION>
! Schemes allowed here are
!
! 1) Deposition removed in the same fractional amount as the modeled precipitation rate is to
!    a standardized precipitation rate.
!    Basically this scheme assumes that a fractional area of the gridbox is affected by
!    precipitation and that this precipitation rate is due to a cloud of standardized cloud
!    liquid water content. Removal is constant throughout the column where precipitation is occuring.
!
! 2) Removal according to Henry's Law. This law states that the ratio of the concentation in
!    cloud water and the partial pressure in the interstitial air is a constant. In this
!    instance, the units for Henry's constant are kg/L/Pa (normally it is M/L/Pa)
!    Parameters for a large number of species can be found at
!    http://www.mpch-mainz.mpg.de/~sander/res/henry.html

! To utilize this section of code add one of the following lines as
! a method for the tracer of interest in the field table.
!

! "wet_deposition","henry","henry=XXX, dependence=YYY"
!     where XXX is the Henry's constant for the tracer in question
!       and YYY is the temperature dependence of the Henry's Law constant.
!
! "wet_deposition","fraction","lslwc=XXX, convlwc=YYY"
!     where XXX is the liquid water content of a standard large scale cloud
!       and YYY is the liquid water content of a standard convective cloud.
!

!</DESCRIPTION>
!
integer, intent(in)                 :: n, is, js
real(r8), intent(in), dimension(:,:,:)  :: T, pfull,phalf, qdt, tracer
real(r8), intent(in), dimension(:,:)    :: rain, snow
character(len=*),intent(in)         :: cloud_param
type (time_type)  , intent(in)      :: Time
real(r8), intent(out), dimension(:,:,:) :: tracer_dt
!
real(r8), dimension(size(T,1),size(T,2),size(pfull,3))   :: wsinku
real(r8), dimension(size(T,1),size(T,2)) :: Htemp, dz, washout,scav_factor, sum_wdep
integer, dimension(size(T,1),size(T,2)) :: ktopcd, kendcd
integer :: i,j,k,kd, flaglw
real(r8)    :: Henry_constant, Henry_variable, inv298p15, clwc, wash, premin, prenow, hwtop
!real(r8), dimension(size(rain,1),size(rain,2)) :: prenow,hwtop
logical :: used,flag
character(len=80) :: name,control,scheme
tracer_dt = 0.0E+00
ktopcd = 0
kendcd = 0

flag = query_method ('wet_deposition',MODEL_ATMOS,n,name,control)
if(.not. flag) return
call get_wetdep_param(name,control,scheme,Henry_constant,Henry_variable)
if(lowercase(scheme)=='henry') then
! Henry_constant = [X](aq) / Px(g)
! where [X](aq) is the concentration of tracer X in precipitation
!       Px(g) is the partial pressure of the tracer in the air
! [X](aq) = Mixing ratio (MR) in cloud / qdt
! Px(g)   = MR (non cloud) * Pfull
!
! [X](aq)/Px = MR(incloud)/qdt /(Pfull MR non cloud) = H
! => MR(in cloud) = H * qdt * Pfull* MR(non cloud)
! MR (total) = MR(incloud) + MR(noncloud)
!            = MR(noncloud) * ( 1 + H*Pfull*qdt)
! MR(incloud) = H*Pfull*qdt * MR(total)/(1+H*Pfull*qdt)
! Fraction removed = MR(incloud)/MR(total) =
!  H*Pfull*qdt/(1+H*Pfull*qdt)
!

 if(Henry_constant > 0 ) then
  inv298p15 = 1/298.15
  kd = size(T,3)
  do k = 1, kd
  ! Calculate the temperature dependent part of Henry's constant
  ! exp( k *(1/T - 1/298.15))
   Htemp(:,:) = exp(Henry_variable*(1/T(:,:,k)-inv298p15))
   tracer_dt(:,:,k) = 0.0
   scav_factor(:,:) = 0.0
   where (qdt(:,:,k) < 0.0)
   !qdt is -ve so need to multiply by -1.0
    scav_factor(:,:) = -1.0*Henry_constant*Htemp*pfull(:,:,k)*qdt(:,:,k)
    tracer_dt(:,:,k) = scav_factor(:,:)/(1+scav_factor(:,:))
   endwhere
  enddo
 endif
endif

if(lowercase(scheme)=='fraction') then
tracer_dt = 0.0
!-----------------------------------------------------------------------
!
!     Compute areal(r8) fractions experiencing wet deposition:
!
!     Set minimum precipitation rate below which no wet removal
!     occurs to 0.01 cm/day ie 1.16e-6 mm/sec (kg/m2/s)
         premin=1.16e-6
!
!     Large scale cloud liquid water content (kg/m3)
!     and below cloud washout efficiency (cm-1):
            flaglw =parse(control,'lslwc',clwc)
            if (flaglw == 0 ) clwc=0.5e-3
            wash=1.0
!
!     When convective adjustment occurs, use convective cloud liquid water content:
!
            if(trim(cloud_param) .eq. 'convect') then
              flaglw = parse(control,'convlwc',clwc)
              if (flaglw == 0) clwc=2.0e-3
              wash=0.3
            end if
!
      do j=1,size(rain,2)
        do i=1,size(rain,1)
          tracer_dt(i,j,:)=0.0
          washout(i,j)=0.0
          prenow = rain(i,j) + snow(i,j)
          if(prenow .gt. premin) then
!
! Assume that the top of the cloud is where the highest model level
! specific humidity is reduced. And the the bottom of the cloud is the
! lowest model level where specific humidity is reduced.
!
            ktopcd(i,j) = 0
            do k = size(t,3),1,-1
             if (qdt(i,j,k) < 0.0 ) ktopcd(i,j) = k
            enddo
            kendcd(i,j) = 0
            do k = 1,size(t,3)
             if (qdt(i,j,k) < 0.0 ) kendcd(i,j) = k
            enddo
!
!     Thickness of precipitating cloud deck:
!
            if(ktopcd(i,j).gt.1) then
            hwtop = 0.0
            do k=ktopcd(i,j),kendcd(i,j)
             hwtop=hwtop+(phalf(i,j,k+1)-phalf(i,j,k))*rdgas*T(i,j,k)/grav/pfull(i,j,k)
            enddo
            do k=ktopcd(i,j),kendcd(i,j)
!     Areal(r8) fraction affected by precip clouds (max = 0.5):
             tracer_dt(i,j,k)=prenow/(clwc*hwtop)
            end do
            endif

            washout(i,j)=prenow*wash
          end if
        end do
      end do
endif

! Now multiply by the tracer mixing ratio to get the actual tendency.
where (tracer_dt(:,:,:) .gt. 0.5) tracer_dt(:,:,:)=0.5
tracer_dt(:,:,:) = MAX(tracer_dt(:,:,:), 0.0_r8)
where(tracer>0)
tracer_dt=tracer_dt*tracer
elsewhere
tracer_dt=0.0
endwhere

sum_wdep=0.0
do k=1,size(tracer_dt,3)
! delta z = dp/(rho * grav)
! delta z = RT/g*dp/p
! tracer(kgtracer/kgair) * dz(m)* rho(kgair/m3) = kgtracer/m2
! so rho drops out of the equation
sum_wdep=sum_wdep + tracer_dt(:,:,k)*(phalf(:,:,k+1)-phalf(:,:,k))/grav
enddo

         if (id_tracer_wdep(n) > 0 ) then
!        used = send_data ( id_tracer_wdep(n), sum_wdep, Time , &
!         is_in =is,js_in=js)
endif
end subroutine wet_deposition
!</SUBROUTINE>
!
!#######################################################################
!
subroutine get_drydep_param(text_in_scheme,text_in_param,scheme,land_dry_dep_vel,sea_dry_dep_vel)
!
! Subroutine to initialiize the parameters for the dry deposition scheme.
! If the dry dep scheme is 'fixed' then the dry_deposition velocity value
! has to be set.
! If the dry dep scheme is 'wind_driven' then the dry_deposition
! velocity value will be calculated. So set to a dummy value of 0.0
! INTENT IN
!  text_in_scheme   : The text that has been parsed from tracer table as
!                     the dry deposition scheme to be used.
!  text_in_param    : The parameters that are associated with the dry
!                     deposition scheme.
! INTENT OUT
!  scheme           : The scheme that is being used.
!  land_dry_dep_vel : Dry deposition velocity over the land
!  sea_dry_dep_vel  : Dry deposition velocity over the sea
!
character(len=*), intent(in)    :: text_in_scheme, text_in_param
character(len=*), intent(out)   :: scheme
real(r8), intent(out)               :: land_dry_dep_vel, sea_dry_dep_vel

integer :: m,m1,n,lentext, flag
character(len=32) :: dummy

!Default
scheme                  = 'None'
land_dry_dep_vel=0.0
sea_dry_dep_vel=0.0

if(lowercase(trim(text_in_scheme(1:4))).eq.'wind') then
scheme                  = 'Wind_driven'
land_dry_dep_vel=0.0
sea_dry_dep_vel=0.0
endif

if(lowercase(trim(text_in_scheme(1:5))).eq.'fixed') then
scheme                 = 'fixed'
flag=parse(text_in_param,'land',land_dry_dep_vel)
flag=parse(text_in_param,'sea', sea_dry_dep_vel)
endif

end subroutine get_drydep_param
!
!#######################################################################
!
subroutine get_wetdep_param(text_in_scheme,text_in_param,scheme,henry_constant,henry_temp)
!
! Routine to initialize the parameters for the wet deposition scheme.
! INTENT IN
!  text_in_scheme : Text read from the tracer table which provides information on which
!                   wet deposition scheme to use.
!  text_in_param  : Parameters associated with the wet deposition scheme. These will be
!                   parsed in this routine.
! INTENT OUT
!  scheme         : Wet deposition scheme to use.
!                   Choices are None, Fraction and Henry
!  henry_constant : Henry's constant for the tracer (see wet_deposition for explanation of Henry's Law)
!  henry_temp     : The temperature dependence of the Henry's Law constant.
!
!
character(len=*), intent(in)    :: text_in_scheme, text_in_param
character(len=*), intent(out)   :: scheme
real(r8), intent(out)               :: henry_constant, henry_temp

integer :: m,m1,n,lentext, flag
character(len=32) :: dummy

!Default
scheme                  = 'None'
henry_constant=0.0
henry_temp=0.0

if(trim(lowercase(text_in_scheme(1:8))).eq.'fraction') then
scheme                 = 'Fraction'
henry_constant=0.0
henry_temp=0.0
endif

if(trim(lowercase(text_in_scheme(1:5))).eq.'henry') then
scheme                 = 'Henry'
flag=parse(text_in_param,'henry',     henry_constant)
flag=parse(text_in_param,'dependence',henry_temp    )
endif

end subroutine get_wetdep_param
!
!#######################################################################
!
!<SUBROUTINE NAME="interp_emiss">
subroutine interp_emiss(global_source, start_lon, start_lat, &
                        lon_resol, lat_resol, data_out)
!
!<OVERVIEW>
! A routine to interpolate emission fields of arbitrary resolution onto the
! resolution of the model.
!</OVERVIEW>
!<DESCRIPTION>
! Routine to interpolate emission fields (or any 2D field) to the model
! resolution. The local section of the global field is returned to the
! local processor.
!</DESCRIPTION>
!
!<TEMPLATE>
! call interp_emiss(global_source, start_lon, start_lat, &
!                        lon_resol, lat_resol, data_out)
!</TEMPLATE>
! INTENT IN
!<IN NAME="global_source" TYPE="real(r8)" DIM="(:,:)">
!  Global emission field.
!</IN>
!<IN NAME="start_lon" TYPE="real(r8)">
!  Longitude of starting point of emission field
!  (in radians). This is the westernmost boundary of the
!  global field.
!</IN>
!<IN NAME="start_lat" TYPE="real(r8)">
!  Latitude of starting point of emission field
!  (in radians). This is the southern boundary of the
!  global field.
!</IN>
!<IN NAME="lon_resol" TYPE="real(r8)">
!  Longitudinal resolution of the emission data (in radians).
!</IN>
!<IN NAME="lat_resol" TYPE="real(r8)">
!  Latitudinal resolution of the emission data (in radians).
!</IN>
!
! INTENT OUT
!<OUT NAME="data_out" TYPE="real(r8)" DIM="(:,:)">
!  Interpolated emission field on the local PE.
!</OUT>

real(r8), intent(in)  :: global_source(:,:)
real(r8), intent(in)  :: start_lon,start_lat,lon_resol,lat_resol
real(r8), intent(out) :: data_out(:,:)

real(r8) :: modydeg,modxdeg, tpi
integer :: i, j, nlon_in, nlat_in
real(r8) :: blon_in(size(global_source,1)+1)
real(r8) :: blat_in(size(global_source,2)+1)
! Set up the global surface boundary condition longitude-latitude boundary values

   tpi = 2. *PI
   nlon_in = size(global_source,1)
   nlat_in = size(global_source,2)
! For some reason the input longitude needs to be incremented by 180 degrees.
   do i = 1, nlon_in+1
      blon_in(i) = start_lon + float(i-1)*lon_resol + PI
   enddo
      if (abs(blon_in(nlon_in+1)-blon_in(1)-tpi) < epsilon(blon_in)) &
              blon_in(nlon_in+1)=blon_in(1)+tpi

   do j = 2, nlat_in
      blat_in(j) = start_lat + float(j-1)*lat_resol
   enddo
      blat_in(1)         = -0.5*PI
      blat_in(nlat_in+1) =  0.5*PI

! Now interpolate the global data to the model resolution
   call horiz_interp (global_source, blon_in, blat_in,    &
                        blon_out, blat_out, data_out )

end subroutine interp_emiss
!</SUBROUTINE>
!
!######################################################################
!<SUBROUTINE NAME="tracer_utilities_end">
!<OVERVIEW>
!  The destructor routine for the tracer utilities module.
!</OVERVIEW>
! <DESCRIPTION>
! This subroutine writes the version name to logfile and exits.
! </DESCRIPTION>

subroutine atmos_tracer_utilities_end

   deallocate(blon_out, blat_out)
   module_is_initialized = .FALSE.

 end subroutine atmos_tracer_utilities_end
!</SUBROUTINE>

! ######################################################################
!

end module atmos_tracer_utilities_mod


      PROGRAM MPEX15
C
C This is a test program for the routines MAPNGR, MAPNGD, and MAPNGQ,
C which allow one to display a transformed PNG as an Ezmap background.
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C       PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C       PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C       PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C       PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
        PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)
C
C Define flags that control the drawing of grids and outlines.
C
        DATA IGRD,IOUT / 2,4 /
C
C Define conversion constants.
C
        DATA DTOR / .017453292519943 /
        DATA RTOD / 57.2957795130823 /
C
C Open GKS.
C
        CALL GOPKS (IERRF,0)
        CALL GOPWK (IWKID,LUNIT,IWTYPE)
        CALL GACWK (IWKID)
C
C Turn off clipping.
C
        CALL GSCLIP (0)
C
C Define basic colors.
C
        CALL GSCR (IWKID,0,1.,1.,1.)
        CALL GSCR (IWKID,1,0.,0.,0.)
        CALL GSCR (IWKID,2,1.,0.,0.)
        CALL GSCR (IWKID,3,0.,.8,0.)
C
C Define 129 gray-scale colors.
C
        DO 101 I=4,132
          P=REAL(I-4)/128.
          CALL GSCR (IWKID,I,P,P,P)
  101   CONTINUE
C
C Turn error recovery on.
C
        CALL ENTSR (ITMP,1)
C
C Tell PLOTCHAR to use a filled font and to outline the characters.
C
        CALL PCSETI ('FN',25)
        CALL PCSETI ('OF',1)
C
C Tell EZMAP what grid spacing to use.
C
        CALL MPSETI ('GR',IGRD)
C
C Read a PNG, downloaded from Wikimapia, showing most of Europe, and
C an associated PNGI and initilize information that geo-references the
C PNG so that it can be displayed as a background on a different
C projection of the globe.
C
        CALL MAPNGR ('Europe.png'//CHAR(0),40000)
C
C If an error occurred, print an error message.
C
        IF (NERRO(ITMP).NE.0) THEN
C
          CALL EPRIN
          CALL ERROF
          STOP
C
C Otherwise, produce the example plot.
C
        ELSE
C
C Initialize EZMAP to produce a satellite view of Europe looking north
C from a position somewhere over the Mediterranean.
C
          CALL MAPROJ ('SV', 25., 18., 10.)
          DFCE=2.
          CALL MPSETR ('SA',DFCE)
          CALL MPSETR ('S1',.6*RTOD*ASIN(1./DFCE))
          CALL MPSETR ('S2',90.)
          CALL MAPSET ('AN',8.,8.,8.,8.)
C
          CALL MAPINT
C
C Draw the projected PNG of the European map.
C
          CALL MAPNGD (4194304,0,4,129)
C
          IF (IGRD.NE.0) THEN
            CALL PLOTIF (0.,0.,2)
            CALL GSLWSC (2.)
            CALL GSPLCI (2)
            CALL MDPGRD
            CALL MDPLBL
            CALL PLOTIF (0.,0.,2)
            CALL GSLWSC (1.)
            CALL GSPLCI (1)
          END IF
C
C If the "outline" flag is set, overlay geopolitical boundary lines
C from "Earth..4" on the map.
C
          IF (IOUT.NE.0) THEN
            CALL PLOTIF (0.,0.,2)
            CALL GSLWSC (2.)
            CALL GSPLCI (3)
            CALL MDLNDR ('Earth..4',IOUT)
            CALL PLOTIF (0.,0.,2)
            CALL GSLWSC (1.)
            CALL GSPLCI (1)
          END IF
C
C Supply a title for the frame.
C
          CALL PLCHHQ (CFUX(.5),CFUY(.975),
     +               'USING A PROJECTED PNG AS A BACKGROUND',.018,0.,0.)
C
          CALL FRAME
C
          CALL MAPNGQ
C
        END IF
C
C Close GKS.
C
        CALL GDAWK (IWKID)
        CALL GCLWK (IWKID)
        CALL GCLKS
C
C Done.
C
        STOP
C
      END


	SUBROUTINE SDSS_COLOR(t,x,y,inw,lun,bolflux)

!	computes magnitude and colors in AB system

!	Array declarations
	parameter (nc=20,lb=50,mxft=300)
	character genfile*96,envfile*96,rfcolorfile*96,fid(0:mxft)*64
	integer no(lb),n1(nc),n2(nc),kerr(nc)
	real x(inw),y(inw),col(nc),fx(lb),ab(0:nc)
	real gmag
	common /kpercent/ ipcall,iplast,iphead,jc
	common /r_filter/ iread,jread,ireset
	data icall/0/,last/0/,nb/0/
	data nb,no,n1,n2,ng,nv,mc,kb,v0/0,lb*0,nc*0,nc*0,4*0,0./
	data kerr/nc*0/
!	Add V and g filters to list of desired filters
	integer glog
	data glog/121/			! SDSS g filter
	common /f1001/ mc,ab

!	Check for zero flux sed
	if (t.eq.0..or.bolflux.le.0.) return

!	Check if number of points has changed
	if (inw.ne.last) then
!		icall=0
!		write (6,*) 'Resetting sdss:',inw,last
!		ireset=1
		last=inw
	endif

	if (icall.eq.0) then
		icall=1

!		Format of file modified 07/01/2003:
!		To avoid recompiling this routine the arrays n1,n2 of
!		up to 12 elements each are now read from a file.
!		Get file name from environment variable RF_COLORS_ARRAYS
		envfile='RF_COLORS_ARRAYS'
		call getenv(envfile,rfcolorfile)
		close (1)
		open (1,file=rfcolorfile,status='old',form='formatted',err=2)
!		write (6,*)
!		write (6,*) 'List of filters in file: ',rfcolorfile(1:largo(rfcolorfile))
!		Skip first lines
		do i=1,100
		read (1,'(a)') genfile
		if (index(genfile,'AB system').gt.0) goto 5
		enddo
!5		write (6,*) genfile(1:largo(genfile))
5		kb=0
!		Read filter pairs
		do i=1,nc
		read (1,'(2i4)',end=10) n1(i),n2(i)
		kb=kb+1
		fx(kb)=n1(i)
		kb=kb+1
		fx(kb)=n2(i)
		enddo
10		mc=i-1
		close (1)
!		Make sure that SDSS g filter = filter glog in filter file, are included
		kb=kb+1
		fx(kb)=glog
!		Sort filters in numerical order
		call sort(kb,fx)
!		Find independent filters in arrays n1 and n2 and store in array no
		nb=1
		no(1)=fx(1)
		do i=2,kb
		if (fx(i).gt.fx(i-1)) then
			nb=nb+1
			no(nb)=nint(fx(i))
		endif
		enddo
!		Write filter ID
		call filterid(fid)
!		write (6,'(x,a)') 'Selected filters:'
!		do i=1,nb
!		write (6,'(i4,'': '',i4,3x,a)') i,no(i),fid(no(i))
!		enddo
!		write (6,*) 'Selected colors:'
!		write (6,'(20i4)') (n1(i),i=1,mc)
!		write (6,'(20i4)') (n2(i),i=1,mc)
!		write (6,*)

!		Fill arrays with filter numbers
		do i=1,mc
		do j=1,nb
		if (n1(i).eq.no(j)) n1(i) = j
		if (n2(i).eq.no(j)) n2(i) = j
		if (no(j).eq.glog)  ng    = j
		enddo
		enddo

	endif

!	Compute flux through each of nb filters
	do i=1,nb
	if (kerr(i).eq.0) then
		fx(i)=f_mean(no(i),x,y,inw,0.,kerr(i))
	else
		fx(i)=0.
	endif
	enddo

!	Compute colors in file RF_COLORS.sdss on  AB  mag system
	do i=1,mc
	col(i)=-2.5*alog10(fx(n1(i))/fx(n2(i)))
	enddo

!	Compute absolute g AB magnitude for a 1 Mo galaxy
!	It is -27.5 magnitudes brighter for a 1E11 Mo galaxy
!	10 pc in units of Mpc
	dl=1.e-5
	gmag=-2.5*alog10(fx(ng))-48.6
	gmag=gmag+(5. * alog10(1.7684e+08 * dl))	! this factor is SQRT(4*pi*(3.0856E24)^2/Lsun)

!	Compute flux inside GALEX filters
	nfuv = 139	! FUV Galex filter
	ffuv = f_mean(nfuv,x,y,inw,0.,kerruv)
	nnuv = 140	! NUV Galex filter
	fnuv = f_mean(nnuv,x,y,inw,0.,kerruv)

!	Compute flux inside a 100 A square filtered centered at 1500 A
	n1500 = 235     ! filter number
	f1500 = f_mean(n1500,x,y,inw,0.,kerruv)

!	Write colors to file
	tl=alog10(t)
!	write (lun+13,101) tl,bolmag,gmag,(col(i),i=1,mc),ffuv,fnuv,f1500
!	write (lun+13,101) tl,gmag-col(1),gmag,(gmag-col(i),i=2,mc),ffuv,fnuv,f1500
!101	format (f10.6,5f10.4,3x,7f10.4,3x,2f10.4,1p3e13.4)
!	write (1001,102) gmag-col(1),gmag,(gmag-col(i),i=2,mc)
!102	format (20f8.4)

!	Store AB mags
	ab(0) = gmag-col(1)
	ab(1) = gmag
	do i=2,mc
	ab(i) = gmag-col(i)
	enddo

!	Prepare filters for next call to filter_n
!	ireset=1

	return
2	write (6,*) 'Error opening file: ',rfcolorfile(1:largo(rfcolorfile))
	stop
	end


C$Procedure  SPKR05 ( Read SPK record from segment, type 5 )

      SUBROUTINE SPKR05 ( HANDLE, DESCR, ET, RECORD )
      IMPLICIT NONE

C$ Abstract
C
C     Read a single SPK data record from a segment of type 5
C     ( two body propagation between discrete state vectors ).
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     SPK
C
C$ Keywords
C
C     EPHEMERIS
C
C$ Declarations

      INTEGER               HANDLE
      DOUBLE PRECISION      DESCR    ( 5 )
      DOUBLE PRECISION      ET
      DOUBLE PRECISION      RECORD   ( * )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     HANDLE     I   File handle.
C     DESCR      I   Segment descriptor.
C     ET         I   Target epoch.
C     RECORD     O   Data record.
C
C$ Detailed_Input
C
C     HANDLE,
C     DESCR       are the file handle and segment descriptor for
C                 the type 05 SPK segment to be read.
C
C     ET          is a target epoch, specified as ephemeris seconds past
C                 J2000, for which a data record from the segment is
C                 required.
C
C$ Detailed_Output
C
C     RECORD      is a logical record from the specified segment which,
C                 when evaluated at epoch ET, will give the state
C                 (position and velocity) of some body, relative
C                 to some center, in some inertial reference frame.
C
C                 The structure of RECORD is:
C
C                     RECORD(1)
C                        .            state of the body at epoch 1.
C                        .
C                        .
C                     RECORD(6)
C
C                     RECORD(7)
C                        .
C                        .            state of the body at epoch 2.
C                        .
C                     RECORD(12)
C                     RECORD(13)      epoch 1 in seconds past 2000.
C                     RECORD(14)      epoch 2 in seconds past 2000.
C                     RECORD(15)      GM for the center of motion.
C
C
C                 Epoch 1 and epoch 2 are the times in the segment that
C                 bracket ET.  If ET is less than the first time in the
C                 segment then both epochs 1 and 2 are equal to the
C                 first time.  And if ET is greater than the last time
C                 then, epochs 1 and 2 are set equal to this last time.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1) If the segment specified by DESCR is not of data type 05,
C        the error 'SPICE(WRONGSPKTYPE)' is signalled.
C
C     2) No error is signalled if ET is outside the time bounds of
C        the segment. The output RECORD will contain epochs and the
C        associated states which satisfy the rules stated above.
C
C$ Files
C
C     See argument HANDLE.
C
C$ Particulars
C
C     This routine reads the segment specified by DESCR from the SPK
C     file attached to HANDLE to locate the two epochs in the segment
C     that bracket the input ET. It then returns a logical record which
C     contains these times and their associated states, and also the
C     mass of the center of motion. The routine makes explicit use of
C     the structure of the type 05 data segment to locate this data.
C
C     See the section of the SPK Required Reading on data type 05 for
C     a description of the structure of a type 05 segment.
C
C$ Examples
C
C     The data returned by the SPKRnn routine is in its rawest form,
C     taken directly from the segment.  As such, it will be meaningless
C     to a user unless he/she understands the structure of the data type
C     completely.  Given that understanding, however, the SPKRnn
C     routines might be used to "dump" and check segment data for a
C     particular epoch.
C
C
C     C
C     C     Get a segment applicable to a specified body and epoch.
C     C
C           CALL SPKSFS ( BODY, ET, HANDLE, DESCR, IDENT, FOUND )
C
C           IF ( FOUND ) THEN
C
C     C
C     C        Look at parts of the descriptor.
C     C
C              CALL DAFUS ( DESCR, 2, 6, DCD, ICD )
C              CENTER = ICD( 2 )
C              REF    = ICD( 3 )
C              TYPE   = ICD( 4 )
C
C              IF ( TYPE .EQ. 05 ) THEN
C
C                 CALL SPKR05 ( HANDLE, DESCR, ET, RECORD )
C                     .
C                     .  Look at the RECORD data.
C                     .
C              END IF
C
C           END IF
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     J.M. Lynch      (JPL)
C     W.L. Taber      (JPL)
C     I.M. Underwood  (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.1.0, 07-SEP-2001 (EDW)
C
C        Replaced DAFRDA call with DAFGDA.
C        Added IMPLICIT NONE.
C
C-    SPICELIB Version 1.0.0, 01-APR-1992 (JML) (WLT) (IMU)
C
C-&

C$ Index_Entries
C
C     read record from type_5 spk segment
C
C-&

C
C     Local parameters
C
      INTEGER               SIZE
      PARAMETER           ( SIZE    = 100 )

      INTEGER               DIRSIZ
      PARAMETER           ( DIRSIZ  = SIZE )

      INTEGER               BUFSIZ
      PARAMETER           ( BUFSIZ  = SIZE )

      INTEGER               STASIZ
      PARAMETER           ( STASIZ =    6 )

      INTEGER               ND
      PARAMETER           ( ND =        2 )

      INTEGER               NI
      PARAMETER           ( NI =        6 )

C
C     SPICELIB functions
C
      INTEGER               LSTLTD
      LOGICAL               RETURN

C
C     Local variables
C
      DOUBLE PRECISION      DC       (   ND )
      DOUBLE PRECISION      DATA     ( SIZE )

      INTEGER               IC       (   NI )
      INTEGER               BEGIN
      INTEGER               END
      INTEGER               TYPE
      INTEGER               NREC
      INTEGER               NDIR
      INTEGER               GROUP
      INTEGER               DIRLOC
      INTEGER               REMAIN
      INTEGER               SKIP
      INTEGER               GRPADD
      INTEGER               ADDRSS
      INTEGER               I
      INTEGER               N

      LOGICAL               FND

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'SPKR05' )
      END IF

C
C     Unpack the segment descriptor.
C
      CALL DAFUS ( DESCR, ND, NI, DC, IC )

      TYPE  = IC(4)
      BEGIN = IC(5)
      END   = IC(6)

C
C     Make sure that this really is a type 5 data segment.
C
      IF ( TYPE .NE. 05 ) THEN
         CALL SETMSG( 'You are attempting to locate type 5 '      //
     .                'data in a type # data segment.'              )
         CALL ERRINT( '#',  TYPE                                    )
         CALL SIGERR( 'SPICE(WRONGSPKTYPE)'                         )
         CALL CHKOUT( 'SPKR05'                                      )
         RETURN
      END IF

C
C     Get the number of records in the segment. While we're at it,
C     get the GM of the central body (it's adjacent to NREC)
C     since we'll need it anyway. Put it where it belongs, at the
C     end of the output record.
C
      CALL DAFGDA ( HANDLE, END-1, END, DATA )

      NREC       = NINT ( DATA(2) )
      RECORD(15) =        DATA(1)

C
C     From the number of records, we can compute the number of
C     directory epochs.
C
      NDIR = NREC / DIRSIZ

C
C     The directory epochs narrow down the search to a group of DIRSIZ
C     or fewer records. Because the Ith directory epoch is the I*100th
C     epoch, the Ith group will contain epochs ((I-1)*100 + 1) through
C     (I*100).  For example:
C                            group   first epoch #   last epoch #
C                            -----   -------------   ------------
C                              1               1          100
C                              2             101          200
C                              .               .            .
C                              .               .            .
C                             10             901         1000
C                              .               .            .
C                              .               .            .
C                              N     (N-1)*100+1        N*100

      IF ( NDIR .EQ. 0 ) THEN
C
C        There is only one group if there are no directory epochs.
C
         GROUP = 1

      ELSE
C
C        Compute the location of the first directory epoch.  From the
C        beginning of the segment, we need to go through all of the
C        NREC states and epochs.
C
         DIRLOC = BEGIN + ( STASIZ + 1 ) * NREC

C
C        Determine which group of DIRSIZ times to search, by finding
C        the last directory epoch that is less than ET.
C
         FND    = .FALSE.
         REMAIN =  NDIR
         GROUP  =  0

         DO WHILE ( .NOT. FND )
C
C           Read in as many as BUFSIZ directory epochs at a time
C           for comparison.
C
            N = MIN( REMAIN, BUFSIZ )

            CALL DAFGDA ( HANDLE, DIRLOC, DIRLOC + N - 1, DATA )

            REMAIN = REMAIN - N

C
C           Determine the last directory element in DATA that's less
C           than ET.
C
C           If we reach the end of the directories, and still haven't
C           found one bigger than the epoch, the group is the last group
C           in the segment.
C
C           Otherwise keep looking.
C
C
            I = LSTLTD( ET, N, DATA )

            IF ( I .LT. N ) THEN

               GROUP =  GROUP + I + 1
               FND   = .TRUE.

            ELSE IF ( REMAIN .EQ. 0 ) THEN

               GROUP =  NDIR + 1
               FND   = .TRUE.

            ELSE

               DIRLOC = DIRLOC + N
               GROUP  = GROUP  + N

            END IF

         END DO

      END IF

C
C     Now we know which group of DIRSIZ (or less) epochs to look at.
C     Out of the NREC epochs, the number that we should skip over
C     to get to the proper group is DIRSIZ * ( GROUP - 1 ).
C
      SKIP = DIRSIZ * ( GROUP - 1 )

C
C     From this we can compute the index into the segment of the group
C     of times we want.  From the beginning, we need to pass through
C     STASIZ * NREC state numbers to get to the first epoch. Then we
C     skip over the number just computed above.
C
      GRPADD = BEGIN + NREC * ( STASIZ ) + SKIP

C
C     The number of epochs that we have to look at may be less than
C     DIRSIZ.  However many there are, go ahead and read them into the
C     buffer.
C
C     If there are no times in the last group then the time that we
C     are looking for is the same as the last directory epoch.
C     We should not try to read in this instance.
C
      N = MIN ( DIRSIZ, NREC - SKIP )

      IF ( N .NE. 0 ) THEN

         CALL DAFGDA ( HANDLE, GRPADD, GRPADD + N - 1, DATA )
C
C        Find the index of the largest time in the group that is less
C        than the input time.
C
         I = LSTLTD ( ET, N, DATA )

      ELSE
C
C        If we are here it means that ET is greater then the last
C        time in the segment and there are no elements in the last
C        group.  This can occur when the number of epochs is a multiple
C        DIRSIZ.
C
C        By setting N equal to I we can handle this case in the
C        same branch as when there are elements in the last group.
C        This is because the DATA array still contains the directory
C        epochs and I is pointing at the last element which is also the
C        last time in the segment.
C
         N = I

      END IF

C
C     At this point N is the number of epochs in this GROUP which is
C     also the size of the array DATA which contains the epochs. I is
C     the index of the largest time in DATA which is less than ET.
C
C     We need to take different actions depending on whether ET is less
C     than the first time or greater than the last one in the GROUP.
C

      IF ( I .EQ. 0 ) THEN

         IF ( GROUP .EQ. 1 ) THEN

C
C           ET is less than or equal to the first time in the segment.
C           Return the state at the first time twice.
C
            RECORD(13) = DATA(1)
            RECORD(14) = DATA(1)

            CALL DAFGDA ( HANDLE, BEGIN, BEGIN + 5, DATA )

            CALL MOVED  ( DATA, 6, RECORD(1) )
            CALL MOVED  ( DATA, 6, RECORD(7) )

            CALL CHKOUT( 'SPKR05' )
            RETURN

         ELSE
C
C           ET is less than or equal to the first time in this group
C           but not the first time in the segment. Get the last time
C           from the preceding group. The states for this case will
C           be read outside of the IF block.
C
            CALL DAFGDA ( HANDLE, GRPADD - 1, GRPADD, DATA )

            RECORD(13) = DATA(1)
            RECORD(14) = DATA(2)

         END IF

      ELSE IF ( I .EQ. N ) THEN

         IF ( GROUP .EQ. (NDIR + 1) ) THEN
C
C           ET is greater than all of the times in the segment. Return
C           the state for the last time twice.
C
            RECORD(13) = DATA(N)
            RECORD(14) = DATA(N)

            ADDRSS = BEGIN + ( NREC - 1 ) * STASIZ

            CALL DAFGDA ( HANDLE, ADDRSS, ADDRSS + 5, DATA )

            CALL MOVED ( DATA, 6, RECORD(1) )
            CALL MOVED ( DATA, 6, RECORD(7) )

            CALL CHKOUT( 'SPKR05' )
            RETURN

         ELSE
C
C           ET is greater than the last time in this group but this is
C           not the last time in the segment.  Need the first time from
C           the following group. The states for this case will be read
C           outside of the IF block.
C
            CALL DAFGDA ( HANDLE, GRPADD + N - 1, GRPADD + N, DATA )

            RECORD(13) = DATA(1)
            RECORD(14) = DATA(2)

         END IF

      ELSE
C
C        There are two times in the group that bracket ET. The states
C        for this case will be read outside of the IF block.
C
         RECORD(13) = DATA( I )
         RECORD(14) = DATA(I+1)

      END IF

C
C     Read the consecutive states for the two epochs found above.
C     ET is greater than the (SKIP + I)th time but less than or
C     equal to the time (SKIP + I + 1).
C

      ADDRSS = BEGIN + ( SKIP + I - 1 ) * STASIZ

      CALL DAFGDA ( HANDLE, ADDRSS, ADDRSS + 11, DATA )

      CALL MOVED  ( DATA, 12, RECORD(1) )

      CALL CHKOUT( 'SPKR05' )
      RETURN
      END


      SUBROUTINE PKB(NVAL,NBITS,IBAY,IBIT)

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    PKB
C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
C
C ABSTRACT: THIS SUBROUTINE PACKS AN INTEGER VALUE (NVAL) INTO NBITS
C   BITS OF AN INTEGER ARRAY (IBAY), STARTING WITH BIT (IBIT+1).  ON
C   OUTPUT, IBIT IS UPDATED TO POINT TO THE LAST BIT THAT WAS PACKED.
C
C PROGRAM HISTORY LOG:
C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
C 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
C 2003-11-04  J. WOOLLEN -- BIG-ENDIAN/LITTLE-ENDIAN INDEPENDENT (WAS
C                           IN DECODER VERSION)
C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
C                           INTERDEPENDENCIES
C 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY
C                           DOCUMENTATION
C
C USAGE:    CALL PKB (NVAL, NBITS, IBAY, IBIT)
C   INPUT ARGUMENT LIST:
C     NVAL     - INTEGER: INTEGER TO BE PACKED
C     NBITS    - INTEGER: NUMBER OF BITS OF IBAY WITHIN WHICH TO PACK
C                NVAL
C     IBAY     - INTEGER: *-WORD PACKED BINARY ARRAY NOT YET CONTAINING
C                PACKED NVAL
C     IBIT     - INTEGER: BIT POINTER WITHIN IBAY INDICATING BIT AFTER
C                WHICH TO START PACKING
C
C   OUTPUT ARGUMENT LIST:
C     IBAY     - INTEGER: *-WORD PACKED BINARY ARRAY NOW CONTAINING
C                PACKED NVAL
C     IBIT     - INTEGER: BIT POINTER WITHIN IBAY INDICATING LAST BIT
C                THAT WAS PACKED
C
C REMARKS:
C    THIS SUBROUTINE IS THE INVERSE OF BUFR ARCHIVE LIBRARY ROUTINE
C    UPB.
C
C    THIS ROUTINE CALLS:        IREV
C    THIS ROUTINE IS CALLED BY: CMSGINI  CNVED4   CPYUPD   DXMINI
C                               MSGINI   MSGUPD   MSGWRT   MVB
C                               OVRBS1   PAD      PADMSG   PKBS1
C                               STNDRD   SUBUPD   WRCMPS   WRITDX
C                               WRTREE
C                               Normally not called by any application
C                               programs.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  PORTABLE TO ALL PLATFORMS
C
C$$$

      COMMON /HRDWRD/ NBYTW,NBITW,NREV,IORD(8)

      DIMENSION IBAY(*)

C----------------------------------------------------------------------
C----------------------------------------------------------------------

      NWD  = IBIT/NBITW + 1
      NBT  = MOD(IBIT,NBITW)
      IVAL = NVAL
      IF(ISHFT(IVAL,-NBITS).GT.0) IVAL = -1
      INT = ISHFT(IVAL,NBITW-NBITS)
      INT = ISHFT(INT,-NBT)
      MSK = ISHFT(  -1,NBITW-NBITS)
      MSK = ISHFT(MSK,-NBT)
      IBAY(NWD) = IREV(IOR(IAND(IREV(IBAY(NWD)),NOT(MSK)),INT))
      IF(NBT+NBITS.GT.NBITW) THEN

C        There are less than NBITS bits remaining within the current
C        word (i.e. array member) of IBAY, so store as many bits as
C        will fit within the current word and then store the remaining
C        bits within the next word.

         INT = ISHFT(IVAL,2*NBITW-(NBT+NBITS))
         MSK = ISHFT(  -1,2*NBITW-(NBT+NBITS))
         IBAY(NWD+1) = IREV(IOR(IAND(IREV(IBAY(NWD+1)),NOT(MSK)),INT))
      ENDIF

      IBIT = IBIT + NBITS

      RETURN
      END