! SUMMA - Structure for Unifying Multiple Modeling Alternatives
! Copyright (C) 2014-2015 NCAR/RAL
!
! This file is part of SUMMA
!
! For more information see: http://www.ral.ucar.edu/projects/summa
!
! This program is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.

module updateVars_module

! data types
USE nrtype

! missing values
USE globalData,only:integerMissing  ! missing integer
USE globalData,only:realMissing     ! missing real number

! access the global print flag
USE globalData,only:globalPrintFlag

! domain types
USE globalData,only:iname_cas       ! named variables for canopy air space
USE globalData,only:iname_veg       ! named variables for vegetation canopy
USE globalData,only:iname_snow      ! named variables for snow
USE globalData,only:iname_soil      ! named variables for soil

! named variables to describe the state variable type
USE globalData,only:iname_nrgCanair ! named variable defining the energy of the canopy air space
USE globalData,only:iname_nrgCanopy ! named variable defining the energy of the vegetation canopy
USE globalData,only:iname_watCanopy ! named variable defining the mass of total water on the vegetation canopy
USE globalData,only:iname_liqCanopy ! named variable defining the mass of liquid water on the vegetation canopy
USE globalData,only:iname_nrgLayer  ! named variable defining the energy state variable for snow+soil layers
USE globalData,only:iname_watLayer  ! named variable defining the total water state variable for snow+soil layers
USE globalData,only:iname_liqLayer  ! named variable defining the liquid  water state variable for snow+soil layers
USE globalData,only:iname_matLayer  ! named variable defining the matric head state variable for soil layers
USE globalData,only:iname_lmpLayer  ! named variable defining the liquid matric potential state variable for soil layers

! metadata for information in the data structures
USE globalData,only:indx_meta       ! metadata for the variables in the index structure

! constants
USE multiconst,only:&
                    gravity,      & ! acceleration of gravity              (m s-2)
                    Tfreeze,      & ! temperature at freezing              (K)
                    Cp_air,       & ! specific heat of air                 (J kg-1 K-1)
                    LH_fus,       & ! latent heat of fusion                (J kg-1)
                    iden_air,     & ! intrinsic density of air             (kg m-3)
                    iden_ice,     & ! intrinsic density of ice             (kg m-3)
                    iden_water      ! intrinsic density of liquid water    (kg m-3)

! provide access to the derived types to define the data structures
USE data_types,only:&
                    var_i,        & ! data vector (i4b)
                    var_d,        & ! data vector (dp)
                    var_ilength,  & ! data vector with variable length dimension (i4b)
                    var_dlength     ! data vector with variable length dimension (dp)

! provide access to indices that define elements of the data structures
USE var_lookup,only:iLookDIAG             ! named variables for structure elements
USE var_lookup,only:iLookPROG             ! named variables for structure elements
USE var_lookup,only:iLookDERIV            ! named variables for structure elements
USE var_lookup,only:iLookPARAM            ! named variables for structure elements
USE var_lookup,only:iLookINDEX            ! named variables for structure elements

! provide access to routines to update states
USE updatState_module,only:updateSnow     ! update snow states
USE updatState_module,only:updateSoil     ! update soil states

! provide access to functions for the constitutive functions and derivatives
USE snow_utils_module,only:fracliquid     ! compute the fraction of liquid water (snow)
USE snow_utils_module,only:dFracLiq_dTk   ! differentiate the freezing curve w.r.t. temperature (snow)
USE soil_utils_module,only:dTheta_dTk     ! differentiate the freezing curve w.r.t. temperature (soil)
USE soil_utils_module,only:dTheta_dPsi    ! derivative in the soil water characteristic (soil)
USE soil_utils_module,only:dPsi_dTheta    ! derivative in the soil water characteristic (soil)
USE soil_utils_module,only:matricHead     ! compute the matric head based on volumetric water content
USE soil_utils_module,only:volFracLiq     ! compute volumetric fraction of liquid water
USE soil_utils_module,only:crit_soilT     ! compute critical temperature below which ice exists
USE soil_utils_module,only:liquidHead     ! compute the liquid water matric potential

! IEEE checks
USE, intrinsic :: ieee_arithmetic            ! check values (NaN, etc.)

implicit none
private
public::updateVars

contains

 ! **********************************************************************************************************
 ! public subroutine updateVars: compute diagnostic variables
 ! **********************************************************************************************************
 subroutine updateVars(&
                       ! input
                       do_adjustTemp,                             & ! intent(in):    logical flag to adjust temperature to account for the energy used in melt+freeze
                       explicitEuler,                             & ! intent(in):    flag to denote computing the explicit Euler solution
                       mpar_data,                                 & ! intent(in):    model parameters for a local HRU
                       indx_data,                                 & ! intent(in):    indices defining model states and layers
                       prog_data,                                 & ! intent(in):    model prognostic variables for a local HRU
                       diag_data,                                 & ! intent(inout): model diagnostic variables for a local HRU
                       deriv_data,                                & ! intent(inout): derivatives in model fluxes w.r.t. relevant state variables
                       ! output: variables for the vegetation canopy
                       scalarCanopyTempTrial,                     & ! intent(inout): trial value of canopy temperature (K)
                       scalarCanopyWatTrial,                      & ! intent(inout): trial value of canopy total water (kg m-2)
                       scalarCanopyLiqTrial,                      & ! intent(inout): trial value of canopy liquid water (kg m-2)
                       scalarCanopyIceTrial,                      & ! intent(inout): trial value of canopy ice content (kg m-2)
                       ! output: variables for the snow-soil domain
                       mLayerTempTrial,                           & ! intent(inout): trial vector of layer temperature (K)
                       mLayerVolFracWatTrial,                     & ! intent(inout): trial vector of volumetric total water content (-)
                       mLayerVolFracLiqTrial,                     & ! intent(inout): trial vector of volumetric liquid water content (-)
                       mLayerVolFracIceTrial,                     & ! intent(inout): trial vector of volumetric ice water content (-)
                       mLayerMatricHeadTrial,                     & ! intent(inout): trial vector of total water matric potential (m)
                       mLayerMatricHeadLiqTrial,                  & ! intent(inout): trial vector of liquid water matric potential (m)
                       ! output: error control
                       err,message)                                 ! intent(out):   error control
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! --------------------------------------------------------------------------------------------------------------------------------
 implicit none
 ! input
 logical(lgt)     ,intent(in)    :: do_adjustTemp                   ! flag to adjust temperature to account for the energy used in melt+freeze
 logical(lgt)     ,intent(in)    :: explicitEuler                   ! flag to denote computing the explicit Euler solution
 type(var_dlength),intent(in)    :: mpar_data                       ! model parameters for a local HRU
 type(var_ilength),intent(in)    :: indx_data                       ! indices defining model states and layers
 type(var_dlength),intent(in)    :: prog_data                       ! prognostic variables for a local HRU
 type(var_dlength),intent(inout) :: diag_data                       ! diagnostic variables for a local HRU
 type(var_dlength),intent(inout) :: deriv_data                      ! derivatives in model fluxes w.r.t. relevant state variables
 ! output: variables for the vegetation canopy
 real(dp),intent(inout)          :: scalarCanopyTempTrial           ! trial value of canopy temperature (K)
 real(dp),intent(inout)          :: scalarCanopyWatTrial            ! trial value of canopy total water (kg m-2)
 real(dp),intent(inout)          :: scalarCanopyLiqTrial            ! trial value of canopy liquid water (kg m-2)
 real(dp),intent(inout)          :: scalarCanopyIceTrial            ! trial value of canopy ice content (kg m-2)
 ! output: variables for the snow-soil domain
 real(dp),intent(inout)          :: mLayerTempTrial(:)              ! trial vector of layer temperature (K)
 real(dp),intent(inout)          :: mLayerVolFracWatTrial(:)        ! trial vector of volumetric total water content (-)
 real(dp),intent(inout)          :: mLayerVolFracLiqTrial(:)        ! trial vector of volumetric liquid water content (-)
 real(dp),intent(inout)          :: mLayerVolFracIceTrial(:)        ! trial vector of volumetric ice water content (-)
 real(dp),intent(inout)          :: mLayerMatricHeadTrial(:)        ! trial vector of total water matric potential (m)
 real(dp),intent(inout)          :: mLayerMatricHeadLiqTrial(:)     ! trial vector of liquid water matric potential (m)
 ! output: error control
 integer(i4b),intent(out)        :: err                             ! error code
 character(*),intent(out)        :: message                         ! error message
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! general local variables
 integer(i4b)                    :: iState                          ! index of model state variable
 integer(i4b)                    :: iLayer                          ! index of layer within the snow+soil domain
 integer(i4b)                    :: ixFullVector                    ! index within full state vector
 integer(i4b)                    :: ixDomainType                    ! name of a given model domain
 integer(i4b)                    :: ixControlIndex                  ! index within a given model domain
 integer(i4b)                    :: ixOther,ixOtherLocal            ! index of the coupled state variable within the (full, local) vector
 logical(lgt)                    :: isCoupled                       ! .true. if a given variable shared another state variable in the same control volume
 logical(lgt)                    :: isNrgState                      ! .true. if a given variable is an energy state
 logical(lgt),allocatable        :: computedCoupling(:)             ! .true. if computed the coupling for a given state variable
 real(dp)                        :: scalarVolFracLiq                ! volumetric fraction of liquid water (-)
 real(dp)                        :: scalarVolFracIce                ! volumetric fraction of ice (-)
 real(dp)                        :: Tcrit                           ! critical soil temperature below which ice exists (K)
 real(dp)                        :: xTemp                           ! temporary temperature (K)
 real(dp)                        :: effSat                          ! effective saturation (-)
 real(dp)                        :: avPore                          ! available pore space (-)
 character(len=256)              :: cMessage                        ! error message of downwind routine
 logical(lgt),parameter          :: printFlag=.false.               ! flag to turn on printing
 ! iterative solution for temperature
 real(dp)                        :: meltNrg                         ! energy for melt+freeze (J m-3)
 real(dp)                        :: residual                        ! residual in the energy equation (J m-3)
 real(dp)                        :: derivative                      ! derivative in the energy equation (J m-3 K-1)
 real(dp)                        :: tempInc                         ! iteration increment (K)
 integer(i4b)                    :: iter                            ! iteration index
 integer(i4b)                    :: niter                           ! number of iterations
 integer(i4b),parameter          :: maxiter=100                     ! maximum number of iterations
 real(dp),parameter              :: nrgConvTol=1.e-4_dp             ! convergence tolerance for energy (J m-3)
 real(dp),parameter              :: tempConvTol=1.e-6_dp            ! convergence tolerance for temperature (K)
 real(dp)                        :: critDiff                        ! temperature difference from critical (K)
 real(dp)                        :: tempMin                         ! minimum bracket for temperature (K)
 real(dp)                        :: tempMax                         ! maximum bracket for temperature (K)
 logical(lgt)                    :: bFlag                           ! flag to denote that iteration increment was constrained using bi-section
 real(dp),parameter              :: epsT=1.e-7_dp                   ! small interval above/below critical temperature (K)
 ! --------------------------------------------------------------------------------------------------------------------------------
 ! make association with variables in the data structures
 associate(&
 ! number of model layers, and layer type
 nSnow                   => indx_data%var(iLookINDEX%nSnow)%dat(1)                 ,& ! intent(in):  [i4b]    total number of snow layers
 nSoil                   => indx_data%var(iLookINDEX%nSoil)%dat(1)                 ,& ! intent(in):  [i4b]    total number of soil layers
 nLayers                 => indx_data%var(iLookINDEX%nLayers)%dat(1)               ,& ! intent(in):  [i4b]    total number of snow and soil layers
 mLayerDepth             => prog_data%var(iLookPROG%mLayerDepth)%dat               ,& ! intent(in):  [dp(:)]  depth of each layer in the snow-soil sub-domain (m)
 ! indices defining model states and layers
 ixVegNrg                => indx_data%var(iLookINDEX%ixVegNrg)%dat(1)              ,& ! intent(in):  [i4b]    index of canopy energy state variable
 ixVegHyd                => indx_data%var(iLookINDEX%ixVegHyd)%dat(1)              ,& ! intent(in):  [i4b]    index of canopy hydrology state variable (mass)
 ! indices in the full vector for specific domains
 ixNrgCanair             => indx_data%var(iLookINDEX%ixNrgCanair)%dat              ,& ! intent(in):  [i4b(:)] indices IN THE FULL VECTOR for energy states in canopy air space domain
 ixNrgCanopy             => indx_data%var(iLookINDEX%ixNrgCanopy)%dat              ,& ! intent(in):  [i4b(:)] indices IN THE FULL VECTOR for energy states in the canopy domain
 ixHydCanopy             => indx_data%var(iLookINDEX%ixHydCanopy)%dat              ,& ! intent(in):  [i4b(:)] indices IN THE FULL VECTOR for hydrology states in the canopy domain
 ixNrgLayer              => indx_data%var(iLookINDEX%ixNrgLayer)%dat               ,& ! intent(in):  [i4b(:)] indices IN THE FULL VECTOR for energy states in the snow+soil domain
 ixHydLayer              => indx_data%var(iLookINDEX%ixHydLayer)%dat               ,& ! intent(in):  [i4b(:)] indices IN THE FULL VECTOR for hydrology states in the snow+soil domain
 ! mapping between the full state vector and the state subset
 ixMapFull2Subset        => indx_data%var(iLookINDEX%ixMapFull2Subset)%dat         ,& ! intent(in):  [i4b(:)] list of indices in the state subset for each state in the full state vector
 ixMapSubset2Full        => indx_data%var(iLookINDEX%ixMapSubset2Full)%dat         ,& ! intent(in):  [i4b(:)] [state subset] list of indices of the full state vector in the state subset
 ! type of domain, type of state variable, and index of control volume within domain
 ixDomainType_subset     => indx_data%var(iLookINDEX%ixDomainType_subset)%dat      ,& ! intent(in):  [i4b(:)] [state subset] id of domain for desired model state variables
 ixControlVolume         => indx_data%var(iLookINDEX%ixControlVolume)%dat          ,& ! intent(in):  [i4b(:)] index of the control volume for different domains (veg, snow, soil)
 ixStateType             => indx_data%var(iLookINDEX%ixStateType)%dat              ,& ! intent(in):  [i4b(:)] indices defining the type of the state (iname_nrgLayer...)
 ! snow parameters
 snowfrz_scale           => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1)         ,& ! intent(in):  [dp] scaling parameter for the snow freezing curve (K-1)
 ! depth-varying model parameters
 vGn_m                   => diag_data%var(iLookDIAG%scalarVGn_m)%dat               ,& ! intent(in):  [dp(:)] van Genutchen "m" parameter (-)
 vGn_n                   => mpar_data%var(iLookPARAM%vGn_n)%dat                    ,& ! intent(in):  [dp(:)] van Genutchen "n" parameter (-)
 vGn_alpha               => mpar_data%var(iLookPARAM%vGn_alpha)%dat                ,& ! intent(in):  [dp(:)] van Genutchen "alpha" parameter (m-1)
 theta_sat               => mpar_data%var(iLookPARAM%theta_sat)%dat                ,& ! intent(in):  [dp(:)] soil porosity (-)
 theta_res               => mpar_data%var(iLookPARAM%theta_res)%dat                ,& ! intent(in):  [dp(:)] soil residual volumetric water content (-)
 ! model diagnostic variables (heat capacity)
 canopyDepth             => diag_data%var(iLookDIAG%scalarCanopyDepth)%dat(1)      ,& ! intent(in):  [dp   ] canopy depth (m)
 scalarBulkVolHeatCapVeg => diag_data%var(iLookDIAG%scalarBulkVolHeatCapVeg)%dat(1),& ! intent(in):  [dp   ] volumetric heat capacity of the vegetation (J m-3 K-1)
 mLayerVolHtCapBulk      => diag_data%var(iLookDIAG%mLayerVolHtCapBulk)%dat        ,& ! intent(in):  [dp(:)] volumetric heat capacity in each layer (J m-3 K-1)
 ! model diagnostic variables (fraction of liquid water)
 scalarFracLiqVeg        => diag_data%var(iLookDIAG%scalarFracLiqVeg)%dat(1)       ,& ! intent(out): [dp]    fraction of liquid water on vegetation (-)
 mLayerFracLiqSnow       => diag_data%var(iLookDIAG%mLayerFracLiqSnow)%dat         ,& ! intent(out): [dp(:)] fraction of liquid water in each snow layer (-)
 ! model states for the vegetation canopy
 scalarCanairTemp        => prog_data%var(iLookPROG%scalarCanairTemp)%dat(1)       ,& ! intent(in):  [dp] temperature of the canopy air space (K)
 scalarCanopyTemp        => prog_data%var(iLookPROG%scalarCanopyTemp)%dat(1)       ,& ! intent(in):  [dp] temperature of the vegetation canopy (K)
 scalarCanopyWat         => prog_data%var(iLookPROG%scalarCanopyWat)%dat(1)        ,& ! intent(in):  [dp] mass of total water on the vegetation canopy (kg m-2)
 ! model state variable vectors for the snow-soil layers
 mLayerTemp              => prog_data%var(iLookPROG%mLayerTemp)%dat                ,& ! intent(in):  [dp(:)] temperature of each snow/soil layer (K)
 mLayerVolFracWat        => prog_data%var(iLookPROG%mLayerVolFracWat)%dat          ,& ! intent(in):  [dp(:)] volumetric fraction of total water (-)
 mLayerMatricHead        => prog_data%var(iLookPROG%mLayerMatricHead)%dat          ,& ! intent(in):  [dp(:)] total water matric potential (m)
 mLayerMatricHeadLiq     => diag_data%var(iLookDIAG%mLayerMatricHeadLiq)%dat       ,& ! intent(in):  [dp(:)] liquid water matric potential (m)
 ! model diagnostic variables from a previous solution
 scalarCanopyLiq         => prog_data%var(iLookPROG%scalarCanopyLiq)%dat(1)        ,& ! intent(in):  [dp(:)] mass of liquid water on the vegetation canopy (kg m-2)
 scalarCanopyIce         => prog_data%var(iLookPROG%scalarCanopyIce)%dat(1)        ,& ! intent(in):  [dp(:)] mass of ice on the vegetation canopy (kg m-2)
 mLayerVolFracLiq        => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat          ,& ! intent(in):  [dp(:)] volumetric fraction of liquid water (-)
 mLayerVolFracIce        => prog_data%var(iLookPROG%mLayerVolFracIce)%dat          ,& ! intent(in):  [dp(:)] volumetric fraction of ice (-)
 ! derivatives
 dVolTot_dPsi0           => deriv_data%var(iLookDERIV%dVolTot_dPsi0   )%dat        ,& ! intent(out): [dp(:)] derivative in total water content w.r.t. total water matric potential
 dPsiLiq_dPsi0           => deriv_data%var(iLookDERIV%dPsiLiq_dPsi0   )%dat        ,& ! intent(out): [dp(:)] derivative in liquid water matric pot w.r.t. the total water matric pot (-)
 dPsiLiq_dTemp           => deriv_data%var(iLookDERIV%dPsiLiq_dTemp   )%dat        ,& ! intent(out): [dp(:)] derivative in the liquid water matric potential w.r.t. temperature
 mLayerdTheta_dTk        => deriv_data%var(iLookDERIV%mLayerdTheta_dTk)%dat        ,& ! intent(out): [dp(:)] derivative of volumetric liquid water content w.r.t. temperature
 dTheta_dTkCanopy        => deriv_data%var(iLookDERIV%dTheta_dTkCanopy)%dat(1)      & ! intent(out): [dp]    derivative of volumetric liquid water content w.r.t. temperature
 ) ! association with variables in the data structures

 ! --------------------------------------------------------------------------------------------------------------------------------
 ! --------------------------------------------------------------------------------------------------------------------------------

 ! initialize error control
 err=0; message='updateVars/'

 ! allocate space and assign values to the flag vector
 allocate(computedCoupling(size(ixMapSubset2Full)),stat=err)        ! .true. if computed the coupling for a given state variable
 if(err/=0)then; message=trim(message)//'problem allocating computedCoupling'; return; endif
 computedCoupling(:)=.false.

 ! loop through model state variables
 do iState=1,size(ixMapSubset2Full)

  ! check the need for the computations
  if(computedCoupling(iState)) cycle

  ! -----
  ! - compute indices...
  ! --------------------

  ! get domain type, and index of the control volume within the domain
  ixFullVector   = ixMapSubset2Full(iState)       ! index within full state vector
  ixDomainType   = ixDomainType_subset(iState)    ! named variables defining the domain (iname_cas, iname_veg, etc.)
  ixControlIndex = ixControlVolume(ixFullVector)  ! index within a given domain

  ! get the layer index
  select case(ixDomainType)
   case(iname_cas);  cycle ! canopy air space: do nothing
   case(iname_veg);  iLayer = 0
   case(iname_snow); iLayer = ixControlIndex
   case(iname_soil); iLayer = ixControlIndex + nSnow
   case default; err=20; message=trim(message)//'expect case to be iname_cas, iname_veg, iname_snow, iname_soil'; return
  end select

  ! get the index of the other (energy or mass) state variable within the full state vector
  select case(ixDomainType)
   case(iname_veg)             ; ixOther = merge(ixHydCanopy(1),    ixNrgCanopy(1),    ixStateType(ixFullVector)==iname_nrgCanopy)
   case(iname_snow, iname_soil); ixOther = merge(ixHydLayer(iLayer),ixNrgLayer(iLayer),ixStateType(ixFullVector)==iname_nrgLayer)
   case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return
  end select

  ! get the index in the local state vector
  ixOtherLocal = ixMapFull2Subset(ixOther)  ! ixOtherLocal could equal integerMissing
  if(ixOtherLocal/=integerMissing) computedCoupling(ixOtherLocal)=.true.

  ! check if we have a coupled solution
  isCoupled    = (ixOtherLocal/=integerMissing)

  ! check if we are an energy state
  isNrgState   = (ixStateType(ixFullVector)==iname_nrgCanopy .or. ixStateType(ixFullVector)==iname_nrgLayer)

  if(printFlag)then
   print*, 'iState         = ', iState, size(ixMapSubset2Full)
   print*, 'ixFullVector   = ', ixFullVector
   print*, 'ixDomainType   = ', ixDomainType
   print*, 'ixControlIndex = ', ixControlIndex
   print*, 'ixOther        = ', ixOther
   print*, 'ixOtherLocal   = ', ixOtherLocal
   print*, 'do_adjustTemp  = ', do_adjustTemp
   print*, 'isCoupled      = ', isCoupled
   print*, 'isNrgState     = ', isNrgState
  endif

  ! =======================================================================================================================================
  ! =======================================================================================================================================
  ! =======================================================================================================================================
  ! =======================================================================================================================================
  ! =======================================================================================================================================
  ! =======================================================================================================================================

  ! update hydrology state variables for the uncoupled solution
  if(.not.isNrgState .and. .not.isCoupled)then

   ! update the total water from volumetric liquid water
   if(ixStateType(ixFullVector)==iname_liqCanopy .or. ixStateType(ixFullVector)==iname_liqLayer)then
    select case(ixDomainType)
     case(iname_veg);    scalarCanopyWatTrial          = scalarCanopyLiqTrial          + scalarCanopyIceTrial
     case(iname_snow);   mLayerVolFracWatTrial(iLayer) = mLayerVolFracLiqTrial(iLayer) + mLayerVolFracIceTrial(iLayer)*iden_ice/iden_water
     case(iname_soil);   mLayerVolFracWatTrial(iLayer) = mLayerVolFracLiqTrial(iLayer) + mLayerVolFracIceTrial(iLayer) ! no volume expansion
     case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, or iname_soil'; return
    end select
   endif

   ! update the total water and the total water matric potential
   if(ixDomainType==iname_soil)then
    select case( ixStateType(ixFullVector) )
     ! --> update the total water from the liquid water matric potential
     case(iname_lmpLayer)
      effSat = volFracLiq(mLayerMatricHeadLiqTrial(ixControlIndex),vGn_alpha(ixControlIndex),0._dp,1._dp,vGn_n(ixControlIndex),vGn_m(ixControlIndex))  ! effective saturation
      avPore = theta_sat(ixControlIndex) - mLayerVolFracIceTrial(iLayer) - theta_res(ixControlIndex)  ! available pore space
      mLayerVolFracLiqTrial(iLayer) = effSat*avPore + theta_res(ixControlIndex)
      mLayerVolFracWatTrial(iLayer) = mLayerVolFracLiqTrial(iLayer) + mLayerVolFracIceTrial(iLayer) ! no volume expansion
      mLayerMatricHeadTrial(ixControlIndex) = matricHead(mLayerVolFracWatTrial(iLayer),vGn_alpha(ixControlIndex),theta_res(ixControlIndex),theta_sat(ixControlIndex),vGn_n(ixControlIndex),vGn_m(ixControlIndex))
      !write(*,'(a,1x,i4,1x,3(f20.10,1x))') 'mLayerVolFracLiqTrial(iLayer) 1 = ', iLayer, mLayerVolFracLiqTrial(iLayer), mLayerVolFracIceTrial(iLayer), mLayerVolFracWatTrial(iLayer)
     ! --> update the total water from the total water matric potential
     case(iname_matLayer)
      mLayerVolFracWatTrial(iLayer) = volFracLiq(mLayerMatricHeadTrial(ixControlIndex),vGn_alpha(ixControlIndex),theta_res(ixControlIndex),theta_sat(ixControlIndex),vGn_n(ixControlIndex),vGn_m(ixControlIndex))
     ! --> update the total water matric potential (assume already have mLayerVolFracWatTrial given block above)
     case(iname_liqLayer, iname_watLayer)
      mLayerMatricHeadTrial(ixControlIndex) = matricHead(mLayerVolFracWatTrial(iLayer),vGn_alpha(ixControlIndex),theta_res(ixControlIndex),theta_sat(ixControlIndex),vGn_n(ixControlIndex),vGn_m(ixControlIndex))
     case default; err=20; message=trim(message)//'expect iname_lmpLayer, iname_matLayer, iname_liqLayer, or iname_watLayer'; return
    end select
   endif  ! if in the soil domain

  endif  ! if hydrology state variable or uncoupled solution

  ! compute the critical soil temperature below which ice exists
  select case(ixDomainType)
   case(iname_veg, iname_snow); Tcrit = Tfreeze
   case(iname_soil);            Tcrit = crit_soilT( mLayerMatricHeadTrial(ixControlIndex) )
   case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return
  end select

  ! initialize temperature
  select case(ixDomainType)
   case(iname_veg);              xTemp = scalarCanopyTempTrial
   case(iname_snow, iname_soil); xTemp = mLayerTempTrial(iLayer)
   case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return
  end select

  ! define brackets for the root
  ! NOTE: start with an enormous range; updated quickly in the iterations
  tempMin = xTemp - 10._dp
  tempMax = xTemp + 10._dp

  ! get iterations (set to maximum iterations if adjusting the temperature)
  niter = merge(maxiter, 1, do_adjustTemp)

  ! iterate
  iterations: do iter=1,niter

   ! restrict temperature
   if(xTemp <= tempMin .or. xTemp >= tempMax)then
    xTemp = 0.5_dp*(tempMin + tempMax)  ! new value
    bFlag = .true.
   else
    bFlag = .false.
   endif

   ! -----
   ! - compute derivatives...
   ! ------------------------

   ! compute the derivative in total water content w.r.t. total water matric potential (m-1)
   ! NOTE 1: valid for frozen and unfrozen conditions
   ! NOTE 2: for case "iname_lmpLayer", dVolTot_dPsi0 = dVolLiq_dPsi
   if(ixDomainType==iname_soil)then
    select case( ixStateType(ixFullVector) )
     case(iname_lmpLayer); dVolTot_dPsi0(ixControlIndex) = dTheta_dPsi(mLayerMatricHeadLiqTrial(ixControlIndex),vGn_alpha(ixControlIndex),0._dp,1._dp,vGn_n(ixControlIndex),vGn_m(ixControlIndex))*avPore
     case default;         dVolTot_dPsi0(ixControlIndex) = dTheta_dPsi(mLayerMatricHeadTrial(ixControlIndex),vGn_alpha(ixControlIndex),theta_res(ixControlIndex),theta_sat(ixControlIndex),vGn_n(ixControlIndex),vGn_m(ixControlIndex))
    end select
   endif

   ! compute the derivative in liquid water content w.r.t. temperature
   ! --> partially frozen: dependence of liquid water on temperature
   if(xTemp<Tcrit)then
    select case(ixDomainType)
     case(iname_veg);  dTheta_dTkCanopy         = dFracLiq_dTk(xTemp,snowfrz_scale)*scalarCanopyWat/(iden_water*canopyDepth)
     case(iname_snow); mLayerdTheta_dTk(iLayer) = dFracLiq_dTk(xTemp,snowfrz_scale)*mLayerVolFracWatTrial(iLayer)
     case(iname_soil); mLayerdTheta_dTk(iLayer) = dTheta_dTk(xTemp,theta_res(ixControlIndex),theta_sat(ixControlIndex),vGn_alpha(ixControlIndex),vGn_n(ixControlIndex),vGn_m(ixControlIndex))
     case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return
    end select  ! domain type

   ! --> unfrozen: no dependence of liquid water on temperature
   else
    select case(ixDomainType)
     case(iname_veg);              dTheta_dTkCanopy         = 0._dp
     case(iname_snow, iname_soil); mLayerdTheta_dTk(iLayer) = 0._dp
     case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return
    end select  ! domain type
   endif

   ! -----
   ! - update volumetric fraction of liquid water and ice...
   !    => case of hydrology state uncoupled with energy (and when not adjusting the temperature)...
   ! -----------------------------------------------------------------------------------------------

   ! case of hydrology state uncoupled with energy (and when not adjusting the temperature)
   if(.not.do_adjustTemp .and. .not.isNrgState .and. .not.isCoupled)then

    ! compute the fraction of snow
    select case(ixDomainType)
     case(iname_veg);  scalarFracLiqVeg          = fracliquid(xTemp,snowfrz_scale)
     case(iname_snow); mLayerFracLiqSnow(iLayer) = fracliquid(xTemp,snowfrz_scale)
     case(iname_soil)  ! do nothing
     case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return
    end select  ! domain type

   ! -----
   ! - update volumetric fraction of liquid water and ice...
   !    => case of energy state or coupled solution (or adjusting the temperature)...
   ! --------------------------------------------------------------------------------

   ! case of energy state OR coupled solution (or adjusting the temperature)
   ! NOTE: do not go in here if we have the explicit Euler solution for energy state variables (isNrgState or isCoupled)
   !         --> the explicit Euler updates for ice are done separately, based on the energy partitioning into melt and temperature at the start of the step
   elseif(do_adjustTemp .or. ( (isNrgState .or. isCoupled) .and. .not.explicitEuler ) )then

    ! identify domain type
    select case(ixDomainType)

     ! *** vegetation canopy
     case(iname_veg)

      ! compute volumetric fraction of liquid water and ice
      call updateSnow(xTemp,                                        & ! intent(in)   : temperature (K)
                      scalarCanopyWatTrial/(iden_water*canopyDepth),& ! intent(in)   : volumetric fraction of total water (-)
                      snowfrz_scale,                                & ! intent(in)   : scaling parameter for the snow freezing curve (K-1)
                      scalarVolFracLiq,                             & ! intent(out)  : trial volumetric fraction of liquid water (-)
                      scalarVolFracIce,                             & ! intent(out)  : trial volumetric fraction if ice (-)
                      scalarFracLiqVeg,                             & ! intent(out)  : fraction of liquid water (-)
                      err,cmessage)                                   ! intent(out)  : error control
      if(err/=0)then; message=trim(message)//trim(cmessage); return; endif

      ! compute mass of water on the canopy
      ! NOTE: possibilities for speed-up here
      scalarCanopyLiqTrial =          scalarFracLiqVeg *scalarCanopyWatTrial
      scalarCanopyIceTrial = (1._dp - scalarFracLiqVeg)*scalarCanopyWatTrial

     ! *** snow layers
     case(iname_snow)

      ! compute volumetric fraction of liquid water and ice
      call updateSnow(xTemp,                                        & ! intent(in)   : temperature (K)
                      mLayerVolFracWatTrial(iLayer),                & ! intent(in)   : mass state variable = trial volumetric fraction of water (-)
                      snowfrz_scale,                                & ! intent(in)   : scaling parameter for the snow freezing curve (K-1)
                      mLayerVolFracLiqTrial(iLayer),                & ! intent(out)  : trial volumetric fraction of liquid water (-)
                      mLayerVolFracIceTrial(iLayer),                & ! intent(out)  : trial volumetric fraction if ice (-)
                      mLayerFracLiqSnow(iLayer),                    & ! intent(out)  : fraction of liquid water (-)
                      err,cmessage)                                   ! intent(out)  : error control
      if(err/=0)then; message=trim(message)//trim(cmessage); return; endif

     ! *** soil layers
     case(iname_soil)

      ! compute volumetric fraction of liquid water and ice
      call updateSoil(xTemp,                                                                                & ! intent(in)   : temperature (K)
                      mLayerMatricHeadTrial(ixControlIndex),                                                                                & ! intent(in)   : total water matric potential (m)
                      vGn_alpha(ixControlIndex),vGn_n(ixControlIndex),theta_sat(ixControlIndex),theta_res(ixControlIndex),vGn_m(ixControlIndex),    & ! intent(in)   : soil parameters
                      mLayerVolFracWatTrial(iLayer),                                                                                & ! intent(in)   : mass state variable = trial volumetric fraction of water (-)
                      mLayerVolFracLiqTrial(iLayer),                                                                                & ! intent(out)  : trial volumetric fraction of liquid water (-)
                      mLayerVolFracIceTrial(iLayer),                                                                                & ! intent(out)  : trial volumetric fraction if ice (-)
                      err,cmessage)                                                                                ! intent(out)  : error control
      if(err/=0)then; message=trim(message)//trim(cmessage); return; endif

     ! check
     case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return

    end select  ! domain type

   ! explicit Euler solution where energy state variables exist
   else

    ! do nothing (input = output) -- but check that we got here correctly
    if(explicitEuler .and. (isNrgState .or. isCoupled) )then
     scalarVolFracLiq = realMissing
     scalarVolFracIce = realMissing
    else
     message=trim(message)//'unexpected else branch: expect explicit Euler solution where energy state variables exist'
     err=20; return
    endif

   endif  ! if energy state or solution is coupled

   ! -----
   ! - update temperatures...
   ! ------------------------

   ! check the need to adjust temperature
   if(do_adjustTemp)then

    ! get the melt energy
    meltNrg = merge(LH_fus*iden_ice, LH_fus*iden_water, ixDomainType==iname_snow)

    ! compute the residual and the derivative
    select case(ixDomainType)

     ! * vegetation
     case(iname_veg)
      call xTempSolve(&
                      ! constant over iterations
                      meltNrg         = meltNrg                                 ,&  ! intent(in)    : energy for melt+freeze (J m-3)
                      heatCap         = scalarBulkVolHeatCapVeg                 ,&  ! intent(in)    : volumetric heat capacity (J m-3 K-1)
                      tempInit        = scalarCanopyTemp                        ,&  ! intent(in)    : initial temperature (K)
                      volFracIceInit  = scalarCanopyIce/(iden_water*canopyDepth),&  ! intent(in)    : initial volumetric fraction of ice (-)
                      ! trial values
                      xTemp           = xTemp                                   ,&  ! intent(inout) : trial value of temperature
                      dLiq_dT         = dTheta_dTkCanopy                        ,&  ! intent(in)    : derivative in liquid water content w.r.t. temperature (K-1)
                      volFracIceTrial = scalarVolFracIce                        ,&  ! intent(in)    : trial value for volumetric fraction of ice
                      ! residual and derivative
                      residual        = residual                                ,&  ! intent(out)   : residual (J m-3)
                      derivative      = derivative                               )  ! intent(out)   : derivative (J m-3 K-1)

     ! * snow and soil
     case(iname_snow, iname_soil)
      call xTempSolve(&
                      ! constant over iterations
                      meltNrg         = meltNrg                                 ,&  ! intent(in)    : energy for melt+freeze (J m-3)
                      heatCap         = mLayerVolHtCapBulk(iLayer)              ,&  ! intent(in)    : volumetric heat capacity (J m-3 K-1)
                      tempInit        = mLayerTemp(iLayer)                      ,&  ! intent(in)    : initial temperature (K)
                      volFracIceInit  = mLayerVolFracIce(iLayer)                ,&  ! intent(in)    : initial volumetric fraction of ice (-)
                      ! trial values
                      xTemp           = xTemp                                   ,&  ! intent(inout) : trial value of temperature
                      dLiq_dT         = mLayerdTheta_dTk(iLayer)                ,&  ! intent(in)    : derivative in liquid water content w.r.t. temperature (K-1)
                      volFracIceTrial = mLayerVolFracIceTrial(iLayer)           ,&  ! intent(in)    : trial value for volumetric fraction of ice
                      ! residual and derivative
                      residual        = residual                                ,&  ! intent(out)   : residual (J m-3)
                      derivative      = derivative                               )  ! intent(out)   : derivative (J m-3 K-1)

     ! * check
     case default; err=20; message=trim(message)//'expect case to be iname_veg, iname_snow, iname_soil'; return

    end select  ! domain type

    ! check validity of residual
    if( ieee_is_nan(residual) )then
     message=trim(message)//'residual is not valid'
     err=20; return
    endif

    ! update bracket
    if(residual < 0._dp)then
     tempMax = min(xTemp,tempMax)
    else
     tempMin = max(tempMin,xTemp)
    end if

    ! compute iteration increment
    tempInc    = residual/derivative  ! K

    ! check
    if(globalPrintFlag)&
    write(*,'(i4,1x,e20.10,1x,5(f20.10,1x),L1)') iter, residual, xTemp-Tcrit, tempInc, Tcrit, tempMin, tempMax, bFlag

    ! check convergence
    if(abs(residual) < nrgConvTol .or. abs(tempInc) < tempConvTol) exit iterations

    ! add constraints for snow temperature
    if(ixDomainType==iname_veg .or. ixDomainType==iname_snow)then
     if(tempInc > Tcrit - xTemp) tempInc=(Tcrit - xTemp)*0.5_dp  ! simple bi-section method
    endif  ! if the domain is vegetation or snow

    ! deal with the discontinuity between partially frozen and unfrozen soil
    if(ixDomainType==iname_soil)then
     ! difference from the temperature below which ice exists
     critDiff = Tcrit - xTemp
     ! --> initially frozen (T < Tcrit)
     if(critDiff > 0._dp)then
      if(tempInc > critDiff) tempInc = critDiff + epsT  ! set iteration increment to slightly above critical temperature
     ! --> initially unfrozen (T > Tcrit)
     else
      if(tempInc < critDiff) tempInc = critDiff - epsT  ! set iteration increment to slightly below critical temperature
     endif
    endif  ! if the domain is soil

    ! update the temperature trial
    xTemp = xTemp + tempInc

    ! check failed convergence
    if(iter==maxiter)then
     message=trim(message)//'failed to converge'
     err=-20; return ! negative error code = try to recover
    endif

   endif   ! if adjusting the temperature

  end do iterations ! iterating

  ! save temperature
  select case(ixDomainType)
   case(iname_veg);              scalarCanopyTempTrial   = xTemp
   case(iname_snow, iname_soil); mLayerTempTrial(iLayer) = xTemp
  end select

  ! =======================================================================================================================================
  ! =======================================================================================================================================

  ! -----
  ! - compute the liquid water matric potential (and necessay derivatives)...
  ! -------------------------------------------------------------------------

  ! only for soil
  if(ixDomainType==iname_soil)then

   ! check liquid water
   if(mLayerVolFracLiqTrial(iLayer) > theta_sat(ixControlIndex) )then
    message=trim(message)//'liquid water greater than porosity'
    err=20; return
   endif

   ! case of hydrology state uncoupled with energy
   if(.not.isNrgState .and. .not.isCoupled)then

    ! derivatives relating liquid water matric potential to total water matric potential and temperature
    dPsiLiq_dPsi0(ixControlIndex) = 1._dp  ! exact correspondence (psiLiq=psi0)
    dPsiLiq_dTemp(ixControlIndex) = 0._dp  ! no relationship between liquid water matric potential and temperature

   ! case of energy state or coupled solution
   else

    ! compute the liquid matric potential (and the derivatives w.r.t. total matric potential and temperature)
    call liquidHead(&
                    ! input
                    mLayerMatricHeadTrial(ixControlIndex)                                                                                ,& ! intent(in) : total water matric potential (m)
                    mLayerVolFracLiqTrial(iLayer)                                                                                ,& ! intent(in) : volumetric fraction of liquid water (-)
                    mLayerVolFracIceTrial(iLayer)                                                                                ,& ! intent(in) : volumetric fraction of ice (-)
                    vGn_alpha(ixControlIndex),vGn_n(ixControlIndex),theta_sat(ixControlIndex),theta_res(ixControlIndex),vGn_m(ixControlIndex), & ! intent(in) : soil parameters
                    dVolTot_dPsi0(ixControlIndex)                                                                                ,& ! intent(in) : derivative in the soil water characteristic (m-1)
                    mLayerdTheta_dTk(iLayer)                                                                                ,& ! intent(in) : derivative in volumetric total water w.r.t. temperature (K-1)
                    ! output
                    mLayerMatricHeadLiqTrial(ixControlIndex)                                                                                ,& ! intent(out): liquid water matric potential (m)
                    dPsiLiq_dPsi0(ixControlIndex)                                                                                ,& ! intent(out): derivative in the liquid water matric potential w.r.t. the total water matric potential (-)
                    dPsiLiq_dTemp(ixControlIndex)                                                                                ,& ! intent(out): derivative in the liquid water matric potential w.r.t. temperature (m K-1)
                    err,cmessage)                                                                                ! intent(out): error control
    if(err/=0)then; message=trim(message)//trim(cmessage); return; endif

   endif  ! switch between hydrology and energy state

  endif  ! if domain is soil

 end do ! looping through state variables

 ! deallocate space
 deallocate(computedCoupling,stat=err)        ! .true. if computed the coupling for a given state variable
 if(err/=0)then; message=trim(message)//'problem deallocating computedCoupling'; return; endif

 ! end association to the variables in the data structures
 end associate

 end subroutine updateVars

 ! **********************************************************************************************************
 ! private subroutine xTempSolve: compute residual and derivative for temperature
 ! **********************************************************************************************************
 subroutine xTempSolve(&
                       ! input: constant over iterations
                       meltNrg          ,&  ! intent(in)    : energy for melt+freeze (J m-3)
                       heatCap          ,&  ! intent(in)    : volumetric heat capacity (J m-3 K-1)
                       tempInit         ,&  ! intent(in)    : initial temperature (K)
                       volFracIceInit   ,&  ! intent(in)    : initial volumetric fraction of ice (-)
                       ! input-output: trial values
                       xTemp            ,&  ! intent(inout) : trial value of temperature
                       dLiq_dT          ,&  ! intent(in)    : derivative in liquid water content w.r.t. temperature (K-1)
                       volFracIceTrial  ,&  ! intent(in)    : trial value for volumetric fraction of ice
                       ! output: residual and derivative
                       residual         ,&  ! intent(out)   : residual (J m-3)
                       derivative        )  ! intent(out)   : derivative (J m-3 K-1)
 implicit none
 ! input: constant over iterations
 real(dp),intent(in)             :: meltNrg                         ! energy for melt+freeze (J m-3)
 real(dp),intent(in)             :: heatCap                         ! volumetric heat capacity (J m-3 K-1)
 real(dp),intent(in)             :: tempInit                        ! initial temperature (K)
 real(dp),intent(in)             :: volFracIceInit                  ! initial volumetric fraction of ice (-)
 ! input-output: trial values
 real(dp),intent(inout)          :: xTemp                           ! trial value for temperature
 real(dp),intent(in)             :: dLiq_dT                         ! derivative in liquid water content w.r.t. temperature (K-1)
 real(dp),intent(in)             :: volFracIceTrial                 ! trial value for the volumetric fraction of ice (-)
 ! output: residual and derivative
 real(dp),intent(out)            :: residual         ! residual (J m-3)
 real(dp),intent(out)            :: derivative       ! derivative (J m-3 K-1)
 ! subroutine starts here
 residual   = -heatCap*(xTemp - tempInit) + meltNrg*(volFracIceTrial - volFracIceInit)  ! J m-3
 derivative = heatCap + LH_fus*iden_water*dLiq_dT  ! J m-3 K-1
 end subroutine xTempSolve

end module updateVars_module


!
!*******************************************************************************
!
subroutine PREEQ_sample(iproj, in, itarget, istate, e_in, ex_tot,      &
                        l_i, is_i, Ix_i, ip_i, icomp_i, icomp_f,       &
                        Ix_f, l_f, ip_f, nbin_f, idb,                  &
                        n_dat, dim_part, num_part_type, part_fact,     &
                        num_part, part_data,                           &
                        Ang_L_max, part_Ang_data,                      &
                        num_theta, extra_angle_data)
!
!*******************************************************************************
!
!  Discussion:
!
!    This is a subroutine to Monte Carlo sample the pre-equilibrium decay
!    of an energy bin
!
!   Dependencies:
!
!     Modules:
!
!        variable_kinds
!        constants
!        options
!        nodeinfo
!        print_control
!        useful_data
!        nuclei
!        particles_def
!        pre_equilibrium_no_1
!
!     Subroutines:
!
!        PREEQ_Angular
!        exit_YAHFC
!
!     External functions:
!
!       integer(kind=4) :: preeq_l
!       integer(kind=4) :: find_ibin
!       logical :: real8_equal
!       real(kind=8) :: exp_leg_int
!       real(kind=8) :: expdev
!
!     MPI routines:
!
!        MPI_Abort   ----    via exit_YAHFC
!
!  Licensing:
!
!    SPDX-License-Identifier: MIT
!
!  Date:
!
!    11 May 2021
!
!  Author:
!
!      Erich Ormand, LLNL
!
!*******************************************************************************
!
   use variable_kinds
   use constants
   use options
   use nodeinfo
   use print_control
   use useful_data
   use nuclei
   use particles_def
   use pre_equilibrium_no_1
   implicit none
!--------------------------------    Argument data
   integer(kind=4), intent(in) :: iproj, in, itarget, istate
   real(kind=8), intent(in) :: e_in, ex_tot
   integer(kind=4), intent(in) :: l_i, is_i, Ix_i, ip_i, icomp_i
   integer(kind=4), intent(out) :: icomp_f, Ix_f, l_f, ip_f, nbin_f, idb
   integer(kind=4), intent(in) :: n_dat, dim_part
   integer(kind=4), intent(inout) :: num_part_type(0:6)
   real(kind=8), intent(inout) :: part_fact(0:7)
   integer(kind=4), intent(out) :: num_part
   real(kind=8), intent(out) :: part_data(n_dat,dim_part)
   integer(kind=4), intent(in) :: Ang_L_max
   real(kind=8), intent(out) :: part_Ang_data(0:Ang_L_max,dim_part)
   integer(kind=4), intent(in) :: num_theta
   real(kind=8), intent(inout) :: extra_angle_data(3*num_theta,dim_part)
!--------------------------------    Internal data
   real(kind=8) :: preeq_cs, preeq_cs_k
   integer(kind=4) :: i, k, kk, m
   integer(kind=4) :: l, l_min, l_max
   real(kind=8) :: xj_f, xI_i, xI_f
   real(kind=8) :: prob, ran, frac, rho_sum
   real(kind=8) :: energy, e_max, ex_final, e_cut
   integer(kind=4) :: nbin_end
   real(kind=8) :: mass_p, mass_e
   integer(kind=4) :: A_p, A_t
   real(kind=8) :: xj_i, xj_f_min, xj_f_max, xI_f_min, xI_f_max
   integer(kind=4) :: ixI_f_min, ixI_f_max
   real(kind=8) :: cpar, cpar2, par, par_f
   real(kind=8) :: ex_min_bin
   real(kind=8) :: a_factor
   real(kind=8) :: x_Ang
   real(kind=8) :: factor
   real(kind=8) :: xnorm
   integer(kind=4) :: nang

   real(kind=8) :: e_state
   integer(kind=4) :: closest
   real(kind=8) :: e_closest
   real(kind=8) :: e_diff
   real(kind=8) :: xI_state
   integer(kind=4) :: ip_state

   real(kind=8) :: base_prob, tally_norm

   real(kind=8) :: dee

   real(kind=8) :: theta_0, phi_0

   real(kind=8) :: prob_part(0:6)
   real(kind=8) :: sum_prob
   real(kind=8) :: tally_prob

!--------------------------------    External functions
   real(kind=8) :: random_32
   integer(kind=4) :: preeq_l
   integer(kind=4) :: find_ibin
   logical :: real8_equal
   real(kind=8) :: exp_leg_int
   real(kind=8) :: expdev
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!--------------------------------    Start Calculation

!----
!----  General procedure is to first select an emitting particle type
!----  usually selected based on total cross section (with unbiased
!----  sampling, each particle is nearly equally probable). Then, select
!----  and energy based on the exciton emission probabilities. Next,
!----  find an emission angle based on Kalbach-Mann statistics. From
!----  this and the emission energy, estimate the final angular momentum
!----  under the assumption that the react occurs near the nuclear surface.
!----  The angular momentum is then coupled to the particle spin and the
!----  initial angular momentum to find a range of valied angular momenta.
!----  the angular momentum of the final state is then selected randomly
!----  weighted by the density of states for each angular momentum.
!----  For lighter nuclei with lower density of states and high-energy
!----  pre-equilibrium particle emission, and high initial angular momentum,
!----  there is a chance that the level density is zero for all angular
!----  momentum bins. In this rare case, start at min angular momentum and
!----  reduce spin and select the first bin with non-zero level density.
!----  If for some reason this fails, EXTREMELY unlikely, reinitiate
!----  pre-equilibrium search with goto 22
!----

 22  continue

     tally_prob =1.0d0

     cpar = particle(iproj)%par*nucleus(itarget)%state(istate)%parity
     par = cpar*(-1.0d0)**l_i
     xj_i = abs(real(l_i,kind=8) - particle(iproj)%spin) + real(is_i,kind=8)

     mass_p = particle(iproj)%mass
     A_p = particle(iproj)%A
     A_t = nucleus(itarget)%A

     xI_i = real(Ix_i,kind=8) + nucleus(1)%jshift
     par = 2*ip_i - 1
     ran = random_32(iseed_32)
     preeq_cs = nucleus(icomp_i)%PREEQ_cs(in)
     k = -1

     prob = 0.0d0

     if(biased_sampling)then
        prob = 0.0d0
        do kk = 1, nucleus(icomp_i)%num_decay                       !   Loop over particle allowed to decay from this nucleus
           k = nucleus(icomp_i)%decay_particle(kk)
           icomp_f = nucleus(icomp_i)%decay_to(kk)
           prob = prob + nucleus(icomp_i)%PREEQ_part_cs(kk,in)/preeq_cs
           if(ran < prob)exit
        end do
        tally_prob = 1.0d0
     else
        prob_part(0:6) = 0.0d0
        sum_prob = 0.0d0
        tally_norm = 0.0d0
        do kk = 1, nucleus(icomp_i)%num_decay
           k = nucleus(icomp_i)%decay_particle(kk)
           if(nucleus(icomp_i)%PREEQ_part_cs(kk,in)/preeq_cs >= 1.0d-6)then
              prob_part(k) = 1.0d0
              tally_norm = tally_norm + nucleus(icomp_i)%PREEQ_part_cs(kk,in)
              sum_prob = sum_prob + 1.0d0
           end if
        end do
        base_prob = 1.0d0/sum_prob
        tally_norm = 1.0d0/tally_norm
        prob = 0.0d0
        do kk = 1, nucleus(icomp_i)%num_decay                       !   Loop over particle allowed to decay from this nucleus
           if(nucleus(icomp_i)%PREEQ_part_cs(kk,in)/preeq_cs < 1.0-6)cycle
           k = nucleus(icomp_i)%decay_particle(kk)
           icomp_f = nucleus(icomp_i)%decay_to(kk)
           prob = prob + prob_part(k)*base_prob
           if(ran < prob)exit
        end do
        tally_prob = nucleus(icomp_i)%PREEQ_part_cs(kk,in)*tally_norm*sum_prob
     end if

     if(k == -1)stop 'k not set properly in PREEQ_Samp'

     ran = random_32(iseed_32)
     preeq_cs_k = nucleus(icomp_i)%PREEQ_part_cs(kk,in)
     e_max = max(ex_tot - nucleus(icomp_i)%sep_e(k),0.0d0)
     nbin_end = min(int(e_max/de),nucleus(icomp_i)%nbin_part)
!------------------------------------------   Energy of emitted particle
     ex_final = -1.0d0
     prob = 0.0d0
     do m = 0, nbin_end
        energy = real(m,kind=8)*de
        ex_final = ex_tot - energy - nucleus(icomp_i)%sep_e(k)
        prob = prob + nucleus(icomp_i)%PREEQ_part_spectrum(kk,m)*de
        if(ran <= prob)exit
     end do

     e_cut = nucleus(icomp_f)%level_param(7)

     num_part = 1
!
!------   Find angular distribution quantities for pre-equilirum emission
!------   Finds angle based Kalbach-Mann statistics for pre-equilibrium
!------   emission
!
     theta_0 = 0.0d0

     a_factor = 0.0d0

     call PREEQ_Angular(icomp_i, icomp_f, iproj, e_in, k, energy, a_factor)

     do nang = 1, num_theta
        if(k > 0)then
           x_Ang = expdev(iseed_32,a_factor)
           if(abs(x_Ang) > 1.0d0)then
              write(6,*)'cos(theta) wrong in PREEQ_sample'
              write(6,*)'iproc = ',iproc
              call exit_YAHFC(101)
           end if
           extra_angle_data(nang,num_part) = acos(x_Ang)
        else               !   make photons isotropic for now
           extra_angle_data(nang,num_part) = two_pi*random_32(iseed_32)
        end if
     end do
     theta_0 = extra_angle_data(1,num_part)
     phi_0 = two_pi*random_32(iseed_32)
!------------------------------------------------------------------------------------
!-----     Also, compute Legendre coefficients
!------------------------------------------------------------------------------------
     part_Ang_data(0,num_part) = 0.5d0
     xnorm = exp_leg_int(0,a_factor)
     do L = 0, Ang_L_max
        factor = 0.5d0*(2.0d0*real(L,kind=8)+1.0d0)/xnorm
        part_Ang_data(L,num_part) = factor*exp_leg_int(L,a_factor)
     end do

!-----------------------------------------  Find energy bin, or discrete state
     ex_min_bin = nucleus(icomp_f)%e_grid(1) - 0.5d0*nucleus(icomp_f)%delta_e(1)

!------
!------   Decay to a continuous energy bin, defined by nbin_f
!------
     xj_f = -1.0d0
     xI_f = -1.0d0
     xj_f_min = -1.0d0
     xj_f_max = -1.0d0
     xI_f_min = -1.0d0
     xI_f_max = -1.0d0
     ixI_f_min = -1
     ixI_f_max = -1

     if(ex_final > e_cut .and. ex_final > ex_min_bin)then     !  energy bin
        nbin_f = 0
        nbin_f = find_ibin(ex_final,icomp_f)
!-------
        if(nbin_f <= 0) nbin_f = 1
        idb = 0

        ex_final = nucleus(icomp_f)%e_grid(nbin_f)
        energy = ex_tot - ex_final - nucleus(icomp_i)%sep_e(k)
        if(energy <= 0.0d0)nbin_f = nbin_f -1
        ex_final = nucleus(icomp_f)%e_grid(nbin_f)
        energy = ex_tot - ex_final - nucleus(icomp_i)%sep_e(k)
!------
!------   Estimate of angular momentum for emitted particle based on the
!------   emitted angle and assuming the reaction occurs near the surface
!------   l_f is outgoing orbital angular momentum
!------
        if(k > 0)then
           mass_e = particle(k)%mass
           l_f = preeq_l(l_i, mass_p, E_in, mass_e, energy, theta_0, A_p, A_t)
           if(l_f > particle(k)%lmax)then
              if(iproc == 0)then
                 write(6,*)'*******  Warning l_f > particle%lmax in PREEQ_samp  ******'
                 write(6,*)'*******  l_f set = particle%lmax                    ******'
                 write(6,*)particle(k)%name
                 write(6,*)energy, theta_0
                 write(6,*)l_i, l_f, particle(k)%lmax
              end if
              l_f = particle(k)%lmax
           end if
           cpar2 = par*(-1.0d0)**l_f                        !  Parity of nucleus and emitted particle
           par_f = cpar2*particle(k)%par                 !  Parity of final nucleus
           ip_f = nint((par_f + 1.0d0)/2.0d0)
!------
!------   With estimate of outgoing orbital angular momentum, couple to spin
!------   and initial angular momentum to find possible final angular momenta
!------   Then choose final angular momentum based on density of states within
!------   the min and max ranges
!------
           xj_f_min = abs(real(l_f,kind=8) - particle(k)%spin)
           xj_f_max = real(l_f,kind=8) + particle(k)%spin
           xI_f_min = min(abs(xI_i - xj_f_min),abs(xI_i - xj_f_max))
           xI_f_max = xI_i + xj_f_max
           ixI_f_min = nint(xI_f_min - nucleus(icomp_f)%jshift)
           ixI_f_max = min(nint(xI_f_max - nucleus(icomp_f)%jshift), nucleus(icomp_f)%j_max)
        elseif(k == 0)then
           par_f = -par
           ip_f = nint((par_f + 1.0d0)/2.0d0)
           xI_f_min = abs(xI_i - 1.0d0)
           xI_f_max = xI_i + 1.0d0
           ixI_f_min = nint(xI_f_min - nucleus(icomp_f)%jshift)
           ixI_f_max = min(nint(xI_f_max - nucleus(icomp_f)%jshift), nucleus(icomp_f)%j_max)
        end if
!
!---- Distribute J and parity according to level density
!
        rho_sum = 0.0d0
        do Ix_f = ixI_f_min, ixI_f_max
           rho_sum = rho_sum + nucleus(icomp_f)%bins(Ix_f, ip_f, nbin_f)%rho
        end do
!
!---- If rho_sum > 0.0, is normal situation, choose angular momentum
!---- randomly with probability defined by the density of states
!----
        if(rho_sum >= 1.0d-6)then
           ran = random_32(iseed_32)
           prob = 0.0d0
           do Ix_f = ixI_f_min, ixI_f_max
              prob = prob + nucleus(icomp_f)%bins(Ix_f, ip_f, nbin_f)%rho/rho_sum
              if(ran <= prob)exit
           end do
        else
!---- If rho_sum = 0.0, then this decay can't happen due to no states
!---- being in the angular momentum window. Generally rare, but possible
!---- for lighter nuclei with lower level densities, high emission energy,
!---- and higher initial angular momentum. In this case, reduce spin to
!---- first angular momentum bin with non-zero level density. If, for some
!---- reason it still can't be distributed, start over.
           do Ix_f = iXI_f_min, 0, -1
              if(nucleus(icomp_f)%bins(Ix_f, ip_f, nbin_f)%rho > 1.0d-6)exit
           end do
           if(Ix_f < 0)goto 22    !---  It went past min value; no bin allowed, start over
        end if
        xI_f = Ix_f + nucleus(icomp_f)%jshift
        xj_f = xj_f_min
     else                         ! Discrete state
!----- Trap that ex_final is actually greater than e_cut
        if(ex_final > e_cut)ex_final = e_cut - nucleus(icomp_f)%delta_e(1)*random_32(iseed_32)
        dee = 0.5d0*de
        idb = 1
        nbin_f = 0
        if(k > 0)then
           frac = 0
           do i = 1, nucleus(icomp_f)%num_discrete     ! start with 1st excited state - inelastic
              e_state = nucleus(icomp_f)%state(i)%energy
              if(e_state + dee >= ex_final .and. e_state - dee <= ex_final)frac = frac + 1
           end do
           if(frac > 0.0d0)then
              frac=1.0d0/frac
              ran = random_32(iseed_32)
              prob = 0.0d0
              do i = 1, nucleus(icomp_f)%num_discrete
                 e_state = nucleus(icomp_f)%state(i)%energy
                 if(e_state + dee >= ex_final .and. e_state - dee <= ex_final)then
                    prob = prob + frac
                    if(ran <= prob)then
                       nbin_f = i
                       exit
                    end if
                 end if
               end do
           else            ! special case where there are no states, Force into closest level below ex-final
              do i = nucleus(icomp_f)%num_discrete,1,-1
                 if(nucleus(icomp_f)%state(i)%energy < ex_final)then
                    nbin_f = i
                    exit
                 end if
              end do
!------------   Lastly, it is possible due to roundoff error that the energy could fall just below the
!------------   tolerance for the ground-state, returning nbin_f = 0, which will cause a seg fault
!------------   force decay to ground state
              if(nbin_f == 0)nbin_f = 2                !   lowest state has to be first excited state
           end if

           ex_final = nucleus(icomp_f)%state(nbin_f)%energy
           energy = ex_tot - ex_final - nucleus(icomp_i)%sep_e(k)

           xI_f = nucleus(icomp_f)%state(nbin_f)%spin
           ip_f = nint((nucleus(icomp_f)%state(nbin_f)%parity+1.0d0)/2.0d0)
           xj_f_min = abs(xI_i - xI_f)
           xj_f_max = xI_i + xI_f
           l_min = nint(min(abs(xj_f_min - particle(k)%spin),abs(xj_f_max - particle(k)%spin)))
           l_max = nint(xj_f_max + particle(k)%spin)
           do l = l_min, l_max
              par_f = (-1.0d0)**l*nucleus(icomp_f)%state(nbin_f)%parity*particle(k)%par
              if(real8_equal(par_f,par))exit
           end do
           l_f = l
           if(l_f == 0)then
              xj_f = particle(k)%spin
           else
              if(random_32(iseed_32) <= 0.5)then
                 xj_f = real(l_f) + particle(k)%spin
              else
              xj_f = real(l_f) - particle(k)%spin
              end if
           end if
        elseif(k == 0)then                       !   E1 decay, more restrictive, so force decay to closest discrete state
           xI_f_min = abs(xI_i - 1.0d0)
           xI_f_max = xI_i + 1.0d0
           par_f = -par
           ip_f = nint((par_f + 1.0d0)/2.0d0)
           e_closest = 99999.0d0
           closest = -1
           do i = 1, nucleus(icomp_f)%num_discrete
              e_diff = abs(ex_final - nucleus(icomp_f)%state(i)%energy)
              xI_state = nucleus(icomp_f)%state(i)%spin
              ip_state = nint((nucleus(icomp_f)%state(i)%parity + 1.0d0)/2.0d0)
              if((xI_state >= xI_f_min .and. xI_state <= xI_f_max) .and. ip_f == ip_state .and.     &
                  e_diff < e_closest)then
                  closest = i
                  e_closest = e_diff
              end if
           end do
           if(closest > 0)then
              nbin_f = closest
              xI_f = nucleus(icomp_f)%state(closest)%spin
              ex_final = nucleus(icomp_f)%state(closest)%energy
              energy = ex_tot - ex_final - nucleus(icomp_i)%sep_e(k)
           else
              goto 22                                         !  It didn't work, so start over
           end if
        end if
     end if
!
!----   Store date for decay in part_data, specifying all aspects of this decay
!
     part_data(1,num_part) = real(icomp_f,kind=8)
     part_data(2,num_part) = real(k,kind=8)
     part_data(3,num_part) = xI_f
     part_data(4,num_part) = real(2*ip_f-1,kind=8)
     part_data(5,num_part) = real(nbin_f,kind=8)
     part_data(6,num_part) = real(idb,kind=8)
     part_data(7,num_part) = real(l_f,kind=8)
     part_data(9,num_part) = energy

     if(k == 0)then
        part_data(8,num_part) = 0.0d0     !  set to zero for now because no photons in preeq
     else
        part_data(8,num_part) = xj_f
     end if

     part_data(10,num_part) = theta_0
     part_data(11,num_part) = phi_0
!     part_data(12,num_part) = T_1
!     part_data(13,num_part) = theta
!     part_data(14,num_part) = phi
!     part_data(15,num_part) = T_L
!     part_data(16,num_part) = theta_L
!     part_data(17,num_part) = phi_L
!     part_data(18,num_part) = T_2
     part_data(19,num_part) = tally_prob
     part_data(20,num_part) = ex_final
     part_data(21,num_part) = icomp_i
     part_data(22,num_part) = nucleus(itarget)%state(istate)%spin
     part_data(23,num_part) = nucleus(itarget)%state(istate)%parity
     part_data(24,num_part) = istate
!     nucleus(icomp_f)%Kinetic_Energy = T_2
!
!----    Before leaving update number of particles for this decay type
!
     if(k >= 0 .and. k <= 6)then
        num_part_type(k) = num_part_type(k) + 1
        if(k > 0 .and. num_part_type(k) >= max_particle(k))part_fact(k) = 0.0d0
     end if

   return
end subroutine PREEQ_Sample
!
!*******************************************************************************
!
subroutine PREEQ_Angular(icomp_C, icomp_B, iproj, E_A, ieject, E_B, a)
!
!*******************************************************************************
!
!  Discussion:
!
!   Calculates the factor a for the ejected particle defining the angular distribution
!   via exp(a*cos(theta)).
!
!   Dependencies:
!
!     Modules:
!
!        variable_kinds
!        options
!        nuclei
!        particles_def
!        constants
!        nodeinfo
!
!     Subroutines:
!
!        None
!
!     External functions:
!
!        None
!
!     MPI routines:
!
!        None
!
!  Licensing:
!
!    SPDX-License-Identifier: MIT
!
!  Date:
!
!    11 May 2021
!
!  Author:
!
!      Erich Ormand, LLNL
!
!*******************************************************************************
!
   use variable_kinds
   use options
   use nuclei
   use particles_def
   use constants
   use nodeinfo
   implicit none
!-------------------   Argument data
   integer(kind=4), intent(in) :: icomp_C, icomp_B
   integer(kind=4), intent(in) :: iproj
   real(kind=8), intent(in) :: E_A
   integer(kind=4), intent(in) :: ieject
   real(kind=8), intent(in) :: E_B
   real(kind=8), intent(out) :: a           !    return a to compute Legendre coeeficients
!-------------------   Internal data
   real(kind=8) :: E1, E3, eap, ebp, Sa, Sb
   real(kind=8) :: Mb, ma
   real(kind=8) :: A_C, A_B, Z_C, Z_B, N_C, N_B, Ia, Ib

   real(kind=8) :: ex1, ex2, ex4
!------------   External functions    -------------------------------
!-------------------   Run program    -------------------------------

   Ma = 0.0d0
   if(iproj < 6)Ma = 1.0d0
   if(ieject == 1)then
      Mb = 0.5d0
   elseif(ieject > 1 .and. ieject < 6)then
      Mb = 1.0d0
   else
      Mb = 2.0d0
   end if
   Ia = 0.0d0
   if(iproj == 3)Ia = 2.225d0
   if(iproj == 4)Ia = 8.482d0
   if(iproj == 5)Ia = 7.718d0
   if(iproj == 6)Ia = 28.296d0
   Ib = 0.0d0
   if(ieject == 3)Ib = 2.225d0
   if(ieject == 4)Ib = 8.482d0
   if(ieject == 5)Ib = 7.718d0
   if(ieject == 6)Ib = 28.296d0

   A_C = nucleus(icomp_C)%A
   Z_C = nucleus(icomp_C)%Z
   N_C = A_C - Z_C
   A_B = nucleus(icomp_B)%A
   Z_B = nucleus(icomp_B)%Z
   N_B = A_B - Z_B

   ex1 = 1.0d0/3.0d0
   ex2 = 2.0d0/3.0d0
   ex4 = 4.0d0/3.0d0
   Sa = 15.68d0*(A_C-A_B) - 28.07*((N_C-Z_C)**2/A_C - (N_B-Z_B)**2/A_B) -    &
        18.56d0*(A_C**ex2 - A_B**ex2) +                                      &
        28.07d0*((N_C-Z_C)**2/A_C**ex4 - (N_B-Z_B)**2/A_B**ex4) -            &
        0.717d0*(Z_C**2/A_C**ex1 - Z_B**2/A_B**ex1) +                        &
        1.211d0*(Z_C**2/A_C - Z_B**2/A_B)
   Sb = Sa
   Sa = Sa - Ia
   Sb = Sb - Ib

   eap = E_a + Sa
   ebp = E_b + Sb

   E1 = min(eap, 130.0d0)
   E3 = min(eap, 41.0d0)

   a = 0.04d0*E1*ebp/eap + 1.8d-6*(E1*ebp/eap)**3 +      &
       6.7d-7*Ma*mb*(E3*ebp/eap)**4

   return
end subroutine PREEQ_Angular
!
!*******************************************************************************
!
real(kind=8) function exp_leg_int(L,a)
!
!*******************************************************************************
!
!  Discussion:
!
!    This subroutine calculates the integral of exp(-a*x)*Leg(L,x)
!    Perfomed using Guass-Legendre integration with n_leg
!    points. Weights and abbscissas are calculated in main
!    routine with a call to gauleg. The points x_gleg, and
!    w_gleg are stored in the module Gauss_integration.
!
!   Dependencies:
!
!     Modules:
!
!        variable_kinds
!        constants
!        Gauss_integration
!
!     Subroutines:
!
!        None
!
!     External functions:
!
!        poly
!
!     MPI routines:
!
!        None
!
!  Licensing:
!
!    SPDX-License-Identifier: MIT
!
!  Date:
!
!    11 May 2021
!
!  Author:
!
!      Erich Ormand, LLNL
!
!*******************************************************************************
!
   use variable_kinds
   use constants
   use Gauss_integration
   implicit none
!------------   Argument declarations
   integer(kind=4), intent(in) :: L
   real(kind=8), intent(in) :: a
!------------  Internal data
   integer(kind=4) :: ix
   real(kind=8) :: sum
!------------  External functions
!   real(kind=8) :: poly
!------------  Start calculation
!-----   Legendre(n,x) polynomials are computed with function poly(n,kind,alf,bet,x)
!-----   and are stored in the array Gauss_Leg(n,ix) in the module Gauss_integration to save time
!-----   with kind=1, alf=bet=0.0
   exp_leg_int = 0.0d0
   alf = 0.0d0
   bet = 0.0d0
   sum = 0.0d0
   do ix = 1 , n_gleg
!      sum = sum + w_gleg(ix)*exp(a*x_gleg(ix))*poly(n,1,alf,bet,x_gleg(ix))
      sum = sum + w_gleg(ix)*exp(a*x_gleg(ix))*Gauss_Leg(L,ix)
   end do
   sum = sum*(0.5d0*a/sinh(a))
   exp_leg_int = sum
   return
end function exp_leg_int
!
!*******************************************************************************
!
integer(kind=4) function preeq_l(l_p, mass_p, E_p, mass_e, E_e, theta_e, A_p, A_t)
!
!*******************************************************************************
!
!  Discussion:
!
!    This function uses a model to compute the orbital angular momentum l
!    of an emitted particle given is energy, mass and emitted angle.
!    It assumes momentum conservation and that the reaction occurs on
!    the nuclear surface.
!
!   Dependencies:
!
!     Modules:
!
!        variable_kinds
!
!     Subroutines:
!
!        None
!
!     External functions:
!
!        None
!
!     MPI routines:
!
!        None
!
!  Licensing:
!
!    SPDX-License-Identifier: MIT
!
!  Date:
!
!    11 May 2021
!
!  Author:
!
!      Erich Ormand, LLNL
!
!*******************************************************************************
!
   use variable_kinds
   use constants
   implicit none
!--------------------   Argument declarations
   integer(kind=4), intent(in) :: l_p
   real(kind=8), intent(in) :: mass_p, E_p, mass_e, E_e, theta_e
   integer(kind=4), intent(in) :: A_p, A_t
!--------------------   Internal data
   real(kind=8) :: phi
   real(kind=8) :: b_p, k_p, b_e, k_e
   real(kind=8) :: R
   real(kind=8) :: ex1
!--------------------   Calculation
   if(E_p < 1.0d-2)then
      preeq_l = 0
      return
   end if
   ex1 = 1.0d0/3.0d0
   R = 1.2*(real(A_p,kind=8)**ex1 + real(A_t,kind=8)**ex1)
   k_p = sqrt(2.0d0*mass_p*E_p)/hbar_c
   k_e = sqrt(2.0d0*mass_e*E_e)/hbar_c
   b_p = (real(l_p,kind=8)+0.5d0)/k_p
   if(b_p < R)then
      phi = asin(b_p/R)
      if(theta_e < pi/2.0d0)then
         b_e = sqrt(R**2-b_p**2)*sin(theta_e) + b_p*cos(theta_e)
      else
         b_e = abs(sqrt(R**2-b_p**2)*sin(theta_e) + b_p*cos(theta_e))
      end if
   else
      b_e = R*abs(cos(theta_e))
   end if

   preeq_l = nint(b_e*k_e)

   return
end function preeq_l
!
!*******************************************************************************
!
real(kind=8) function expdev(iseed_32,a)
!
!*******************************************************************************
!
!  Discussion:
!
!    This function generates random variables distributed
!    according to exp(a*x) on the interval (-1,1)
!    actually, properly normalized is a*exp(a*x)/(2*sinh(a))
!
!   Dependencies:
!
!     Modules:
!
!        variable_kinds
!
!     Subroutines:
!
!        None
!
!     External functions:
!
!       real(kind=8) random_32
!       logical :: real8_equal
!
!     MPI routines:
!
!        None
!
!  Licensing:
!
!    SPDX-License-Identifier: MIT
!
!  Date:
!
!    11 May 2021
!
!  Author:
!
!      Erich Ormand, LLNL
!
!*******************************************************************************
!
   use variable_kinds
   implicit none
   integer(kind=int_32), intent(inout) :: iseed_32
   real(kind=8), intent(in) :: a
   real(kind=8) dum
!--------    External Functions    -------------------------------------------
   real(kind=8) random_32
   logical :: real8_equal
!-----------------------------------------------------------------------------
   expdev = 10.0d0
   do while(expdev > 1.0d0)
      dum = 1.0d0 - random_32(iseed_32)*(1.0d0-exp(-2.0d0*a))
      do while(real8_equal(dum,0.0d0))
         dum = 1.0d0 - random_32(iseed_32)*(1.0d0-exp(-2.0d0*a))
      end do
      expdev = -log(dum)/a
      expdev = -(expdev - 1.0d0)
   end do

   return
end function expdev