c               Copyright 1993 Colorado State University
c                       All Rights Reserved

      subroutine prelim

      implicit none
      include 'comput.inc'
      include 'const.inc'
      include 'dovars.inc'
      include 'param.inc'
      include 'parcp.inc'
      include 'parfs.inc'
      include 'parfx.inc'
      include 'plot1.inc'
      include 'plot2.inc'
      include 'plot3.inc'
      include 'seq.inc'
      include 'site.inc'
      include 't0par.inc'
      include 'timvar.inc'
      include 'wth.inc'
      include 'zztim.inc'

c ... Initialize variables and parameters

c ... Function declarations
      double precision catanf, line
      external  catanf, line

c ... Local variables
      integer   ii, lyr
      double precision dely, delx, fcbd(6), fccl(6), fcin(6), fcom(6),
     &          fcsa(6), fcsi(6), fcwp(6), ompc, xslope,
     &          textur, wpbd(6), wpcl(6), wpin(6),
     &          wpom(6), wpsa(6), wpsi(6), wpwp(6), yint
      double precision soildepth, adepsum

c ... swflag lets the model user choose between using actual data
c ... for awilt and afiel or equations from Gupta and Larson (1979)
c ... or Rawls et al (1982).
c ...
c ... swflag=0 Use actual data
c ... swflag=1 Use G&L for both awilt (-15 bar) and afiel (-0.33 bar)
c ... swflag=2 Use G&L for both awilt (-15 bar) and afiel (-0.10 bar)
c ... swflag=3 Use Rawls for both awilt (-15 bar) and afiel (-0.33 bar)
c ... swflag=4 Use Rawls for both awilt (-15 bar) and afiel (-0.10 bar)
c ... swflag=5 Use Rawls for afiel (-0.33 bar) and actual data for awilt
c ... swflag=6 Use Rawls for afiel (-0.10 bar) and actual data for awilt
c ...
c ...     swflag   1          2          3        4       5       6
      data fcsa / 0.3075,    0.5018,   -0.20,   -0.30,  -0.19,   0.31/
      data fcsi / 0.5886,    0.8548,    0.0,     0.0,    0.0,    0.0/
      data fccl / 0.8039,    0.8833,    0.36,    0.23,   0.0,    0.0/
      data fcom / 2.208E-03, 4.966E-03, 0.0299,  0.0317, 0.0210, 0.026/
      data fcbd /-0.1434,   -0.2423,    0.0,     0.0,    0.0,    0.0/
      data fcwp / 0.0,       0.0,       0.0,     0.0,    0.72,   0.41/
      data fcin / 0.0,       0.0,       0.2576, 0.4118, 0.2391, 0.4103/
      data wpsa /-0.0059,   -0.0059,    0.0,     0.0,    0.0,    0.0/
      data wpsi / 0.1142,    0.1142,    0.0,     0.0,    0.0,    0.0/
      data wpcl / 0.5766,    0.5766,    0.50,    0.50,   0.0,    0.0/
      data wpom / 2.228E-03, 2.228E-03, 0.0158,  0.0158, 0.0,    0.0/
      data wpbd / 0.02671,   0.02671,   0.0,     0.0,    0.0,    0.0/
      data wpwp / 0.0,       0.0,       0.0,     0.0,    1.0,    1.0/
      data wpin / 0.0,       0.0,       0.0260,  0.0260, 0.0,    0.0/

c ... Time initializations -  time step is one month
      dt = 1.0/12.0
      time = strtyr
      month = 0
      cntstep = 0
      time2 = strtyr

c ... Allow for time step < 1 month for running decomp
c ... ntspm is the number of time steps per month for decomp
c ... (read from the fix.100 file)

c ... Initializations
      crpgrw = 0
      seedl = 0
      forgrw = 0
      falprc = 0

c ... Initialize volitalization accumulators
      volgma = 0.0
      volexa = 0.0
      volpla = 0.0

c ... Initialize erosion variables
      scloss = 0.0
      sclosa = 0.0

c ... Initialize accumulators
      call annacc

c ... Open the c14 data file
      if (labtyp .eq. 1) then
        open(unit=10,file='c14data',status='OLD')
      endif

c ... Field capacity and wilting point.  Computations based on
c ... Gupta and Larson 1979, 'Estimating soil and water retention
c ... characteristics from particle size distribution, organic
c ... matter percent and bulk density'. Water Resources Research 15:1633
c ... or Rawls et al (1982) 'Estimation of soil water properties'
c ... Trans. ASAE ???:1316
c ... Field capacity options of -0.1 or -0.33 bar.
c ... Wilting point assumed to be water content at -15 bars.
c ... Calculate organic matter from initial conditions, ivauto or
c ... value at the beginning of an extend
c ... Note that Gupta and Larson and Rawls use % for texture
c ... but values here are fractions.
      soildepth = 0.0
      if (swflag .ne. 0) then
        do 11 lyr = 1, nlayer
          soildepth = soildepth + adep(lyr)
11      continue
c ..... For really deep soils, don't use rock fraction -mdh 6/29/99
        if (soildepth .gt. 150) then
          rock = 0.0
        endif
c ..... Set somsc using initial values read from the <site>.100 file
        somsc = som1ci(2,1) + som1ci(2,2) + som2ci(2,1) + som2ci(2,2) +
     &          som3ci(1) + som3ci(2)
        ompc = somsc*1.724/(10000*bulkd*edepth)
        do 10 lyr = 1, nlayer
          afiel(lyr) = fcsa(swflag)*sand  + fcsi(swflag)*silt +
     &                 fccl(swflag)*clay  + fcom(swflag)*ompc +
     &                 fcbd(swflag)*bulkd + fcwp(swflag)*awilt(lyr) +
     &                 fcin(swflag)
          awilt(lyr) = wpsa(swflag)*sand  + wpsi(swflag)*silt +
     &                 wpcl(swflag)*clay  + wpom(swflag)*ompc +
     &                 wpbd(swflag)*bulkd + wpwp(swflag)*awilt(lyr) +
     &                 wpin(swflag)
          ompc = ompc * 0.85
c ....... modifiy afiel and awilt according to fractional volume of rock -mdh 5/27/99
          afiel(lyr) = afiel(lyr) * (1.0 - rock)
          awilt(lyr) = awilt(lyr) * (1.0 - rock)
10      continue
      endif

      open(unit=80,file='daily.csv')
      write(80,85) 'time', 'dayofyr', 'PET(cm)', 'tfunc',
     &             'agwfunc', 'bgwfunc', 'agdefac', 'bgdefac',
     &             'stemp(C)', 'snow', 'snlq', 'srad'
85    format(a10,',',a8,',',7(a12,','),a7,',',a7,',',a12)

      open(unit=90,file='summary.csv')
      write(90,95) 'time','dayofyr','tmax', 'tmin', 'ppt', 'N2Oflux',
     &             'NOflux', 'CH4', 'NIT', 'CO2resp'
95    format(a10,',',1x,a8,',',1x,3(a8,',',1x),5(a12,',',1x))

      open(unit=123,file='cbalance.csv')
      write(123,96) 'time','dayofyr','balance', 'Cstate1', 'Cstate2',
     &             'Cgains', 'Closses', 'omadC', 'hrespCO2',
     &             'co2losUV', 'strm5u', 'strm5l', 'CH4'
96    format(a10,',',1x,a8,',',1x,11(a10,',',1x))

      open(unit=124,file='nbalance.csv')
      write(124,97) 'time','dayofyr','balance', 'Nstate1', 'Nstate2',
     &              'Ngains', 'Nlosses', 'atmosNdep', 'nonSymSoilNfix',
     &              'omadN', 'fertN', 'orgNlch','inorgNlch',
     &              'NOflux', 'Nn2oflux', 'Dn2oflux', 'Dn2flux',
     &              'NOabsorp_g', 'NOabsorp_t'
97    format(a10,',',1x,a8,',',1x,17(a10,',',1x))

      open(unit=125,file='decomp.csv')
      write(125,98) 'cntstep', 'time', 'dayofyr', 'month', 'timestep',
     &              'strucc(1)', 'metabc(1)', 'strucc(2)', 'metabc(2)',
     &              'som1c(1)', 'som2c(1)', 'som1c(2)',' som2c(2)',
     &              'som3c', 'struce(1_1)', 'metabe(1_1)','struce(2_1)',
     &              'metabe(2_1)', 'som1e(1_1)', 'som2e(1_1)',
     &              'som1e(2_1)', 'som2e(2_1)', 'som3e(1)', 'tnetmn(1)',
     &              'agdefac', 'bgdefac', 'somsc', 'somtc', 'Rh'
98    format(a10, ',', 1x, 28(a11,',',1x))

      open(unit=128,file='diagnostics.txt')

c ... Calculate available water holding capacity in top 30 cm of soil
c ... as this is the zone where the majority of plant roots occur
      awhc  = 0.0
      adepsum = 0.0
      do 12 lyr = 1, nlayer
        adepsum = adepsum + adep(lyr)
        if (adepsum .le. 30.0) then
          awhc = awhc + (afiel(lyr) - awilt(lyr)) * adep(lyr)
        endif
12    continue

c ... Calculate total water holding capacity in top 30 cm of soil
c ... as this is the zone where the majority of plant roots occur
      twhc = 0.0
      adepsum = 0.0
      do 15 lyr = 1, nlayer
        adepsum = adepsum + adep(lyr)
        if (adepsum .le. 30.0) then
          twhc = twhc + (afiel(lyr) * adep(lyr))
        endif
15    continue

c ... Compute ORGLCH for use in SOMDEC.
      orglch = omlech(1) + omlech(2) * sand

c ... Intercept for the texture equation of secondary P depends upon
c ... pH input.
      if (ph .le. phesp(1)) then
        texesp(2) = phesp(2)
      else if (ph .ge. phesp(3)) then
        texesp(2) = phesp(4)
      else
        dely = phesp(4) - phesp(2)
        delx = phesp(3) - phesp(1)
        xslope = dely / delx
        yint = phesp(2) - (xslope*phesp(1))
        texesp(2) = (xslope*ph) + yint
      endif

      if (micosm .eq. 0) then
c ..... Preset array which will contain monthly values of defac
        do 20 ii = 1, MONTHS
          agdefacm(ii) = -1.
          bgdefacm(ii) = -1.
20      continue
        aagdefac = 0.
        abgdefac = 0.
        agdefac = 0.
        bgdefac = 0.
      else
        call message(' ')
        call message('Microcosms are not implemented in this version')
        call message('of Daily Century')
        STOP
      endif

c ... Effect of soil texture on the microbe decomposition rate
      eftext = peftxa+peftxb*sand

c ... Compute parameters which control decomposition of som1
c ... p1co2 must be computed for surface and soil.   vek  08/91
c ... Note that p1co2b(1) must equal 0 because there is no
c ... soil texture effect on the surface.
      p1co2(SRFC) = p1co2a(SRFC)
      p1co2(SOIL) = p1co2a(SOIL)+p1co2b(SOIL)*sand

c ... Decomposition of som1 to som3 is a function of clay content
c ... vek june90
      fps1s3 = ps1s3(1) + ps1s3(2) * clay
      fps2s3 = ps2s3(1) + ps2s3(2) * clay

      if (texepp(1) .eq. 1.0) then
c ..... Calculate pparmn(2)
c ..... Include effect of texture; weathering factor should be per year
c ..... Note that this code changes the value of a 'fixed' parameter
c ..... (pparmn(2))
        textur = clay + silt
        pparmn(2) = 12.0 * catanf(textur, texepp(2), texepp(3),
     &                            texepp(4), texepp(5))
      endif

      if (texesp(1) .eq. 1.0) then
c ..... Calculate psecmn(2)
c ..... Include effect of texture
c ..... Note that this code changes the value of a 'fixed' parameter
c ..... (psecmn(2))
        psecmn(2) = 12.0 * (texesp(2) + texesp(3) * sand)
      endif

c ... Compute VLOSSG as a function of soil texture based on clay content
c ... vlossg_m is the VLOSSG parameter value as read from the fix.100 file,
      if (clay .lt. 0.10) then
c        vlossg = 0.015
        vlossg = 0.03
c      else if (clay .gt. 0.40) then
      else if (clay .gt. 0.30) then
c        vlossg = 0.003
        vlossg = 0.01
      else
c        vlossg = line(clay, 0.10, 0.015, 0.40, 0.003)
        vlossg = line(clay, 0.10, 0.03, 0.30, 0.01)
      endif
      vlossg = vlossg * vlossg_m

c ... Save initial values for printing or plotting
      call savarp

c ... Clear the flow stack.
      call floclr

      return
      end


!
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!
subroutine particle_data
!
!*******************************************************************************
!
!  Discussion:
!
!    This subroutine puts particle data into appropriate arrays for later use
!
!   Dependencies:
!
!     Modules:
!
!        variable_kinds
!        constants
!        particles_def
!        directory_structure
!
!     Subroutines:
!
!        None
!
!     External functions:
!
!        None
!
!     MPI routines:
!
!        None
!
!  Licensing:
!
!    SPDX-License-Identifier: MIT
!
!  Date:
!
!    11 May 2021
!
!  Author:
!
!      Erich Ormand, LLNL
!
!  Revised:
!      19 July 2021
!  Author:
!      Ian Thompson, LLNL
!  Changes:
!    1. Now 4 (not 3) kinds of optical potentials for neutrons and protons

!*******************************************************************************
!
   use variable_kinds
   use constants
   use particles_def
   use directory_structure
   implicit none
!--------------   data for emitted particle types
   allocate(particle(-2:7))
   particle(-2:7)%name = '        '
!--------------   Blank - used for population calculations
   particle(-2)%Z = 0
   particle(-2)%A = 0
   particle(-2)%spin = 0.0
   particle(-2)%par = 0.0
   particle(-2)%ME = 0.0d0
   particle(-2)%mass = 0.0d0
   particle(-2)%label = 'X'
   particle(-2)%name = 'PopDecay'
   particle(-2)%opt_pot_set = .false.
   particle(-2)%max_opt_pot = 1
   particle(-2)%om_option = 0
   particle(-2)%nume = 0
!--------------   electron
   particle(-1)%Z = 0
   particle(-1)%A = 0
   particle(-1)%spin = 0.5
   particle(-1)%par = 1.0
   particle(-1)%ME = 0.00000
   particle(-1)%mass = 5.485799090d-4*mass_u
   particle(-1)%label = 'e'
   particle(-1)%name = 'electron'
   particle(-1)%opt_pot_set = .false.
   particle(-1)%max_opt_pot = -1
   particle(-1)%om_option = -1
   particle(-1)%nume = 0
!--------------   photon
   particle(0)%Z = 0
   particle(0)%A = 0
   particle(0)%spin = 1.0
   particle(0)%par = 1.0
   particle(0)%ME = 0.00000
   particle(0)%mass = 0.00000
   particle(0)%label = 'g'
   particle(0)%name = 'photon'
   particle(0)%opt_pot_set = .false.
   particle(0)%max_opt_pot = -1
   particle(0)%om_option = -1
   particle(0)%nume = 0
!--------------   neutron
   particle(1)%Z = 0
   particle(1)%A = 1
   particle(1)%spin = 0.5
   particle(1)%par = 1.0
   particle(1)%ME = 8.071323
   particle(1)%mass = real(1,kind=8)*mass_u + particle(1)%ME
   particle(1)%label = 'n'
   particle(1)%name = 'neutron'
   particle(1)%opt_pot_set = .false.
   particle(1)%max_opt_pot = 4
   particle(1)%om_option = 0
   particle(1)%nume = 0
!--------------   proton
   particle(2)%Z = 1
   particle(2)%A = 1
   particle(2)%spin = 0.5
   particle(2)%par = 1.0
   particle(2)%ME = 7.288969
   particle(2)%mass = real(1,kind=8)*mass_u + particle(2)%ME
   particle(2)%label = 'p'
   particle(2)%name = 'proton'
   particle(2)%opt_pot_set = .false.
   particle(2)%max_opt_pot = 4
   particle(2)%om_option = 0
   particle(2)%nume = 0
!--------------   deuteron
   particle(3)%Z = 1
   particle(3)%A = 2
   particle(3)%spin = 1.0
   particle(3)%par = 1.0
   particle(3)%ME = 13.135720
   particle(3)%mass = real(2,kind=8)*mass_u + particle(3)%ME
   particle(3)%label = 'd'
   particle(3)%name = 'deuteron'
   particle(3)%opt_pot_set = .false.
   particle(3)%max_opt_pot = 1
   particle(3)%om_option = 0
   particle(3)%nume = 0
!--------------   triton
   particle(4)%Z = 1
   particle(4)%A = 3
   particle(4)%spin = 0.5
   particle(4)%par = 1.0
   particle(4)%ME = 14.949794
   particle(4)%mass = real(3,kind=8)*mass_u + particle(4)%ME
   particle(4)%label = 't'
   particle(4)%name = 'triton'
   particle(4)%opt_pot_set = .false.
   particle(4)%max_opt_pot = 1
   particle(4)%om_option = 0
   particle(4)%nume = 0
!--------------   Helium-3
   particle(5)%Z = 2
   particle(5)%A = 3
   particle(5)%spin = 0.5
   particle(5)%par = 1.0
   particle(5)%ME = 14.931204
   particle(5)%mass = real(3,kind=8)*mass_u + particle(5)%ME
   particle(5)%label = 'h'
   particle(5)%name = 'He3'
   particle(5)%opt_pot_set = .false.
   particle(5)%max_opt_pot = 1
   particle(5)%om_option = 0
   particle(5)%nume = 0
!--------------   Alpha
   particle(6)%Z = 2
   particle(6)%A = 4
   particle(6)%spin = 0.0
   particle(6)%par = 1.0
   particle(6)%ME = 2.424911
   particle(6)%mass = real(4,kind=8)*mass_u + particle(6)%ME
   particle(6)%label = 'a'
   particle(6)%name = 'alpha'
   particle(6)%opt_pot_set = .false.
   particle(6)%max_opt_pot = 1
   particle(6)%om_option = 0
   particle(6)%nume = 0
!--------------   Blank - used to define fission
   particle(7)%Z = 0
   particle(7)%A = 0
   particle(7)%spin = 0.0
   particle(7)%par = 0.0
   particle(7)%ME = 0.0d0
   particle(7)%mass = 0.0d0
   particle(7)%label = 'f'
   particle(7)%name = 'fission'
   particle(7)%opt_pot_set = .false.
   particle(7)%max_opt_pot = 1
   particle(7)%om_option = 0
   particle(7)%nume = 0
   return
end subroutine particle_data


!!****h* Conquest/md_model *
!!  NAME
!!   md_model
!!  PURPOSE
!!   Store the current state of the MD run
!!  AUTHOR
!!   Zamaan Raza
!!  CREATION DATE
!!   2017/10/31 11:50
!!  MODIFICATION HISTORY
!!   2018/05/30 zamaan
!!    Modified dump_stats to print correct header and columns when using
!!    Berendsen equilibration in NVT ensemble
!!  2019/05/09 zmaaan
!!    New dump_heat_flux subroutine to save heat flux to file for thermal
!!    conductivity calculations
!!
!!  SOURCE
!!
module md_model

  use datatypes
  use numbers
  use GenComms,         only: inode, ionode
  use input_module,     only: leqi
  use force_module,     only: tot_force, stress
  use global_module,    only: ni_in_cell, io_lun, atom_coord, iprint_MD, &
                              flag_MDcontinue, flag_MDdebug, x_atom_cell, &
                              y_atom_cell, z_atom_cell, rcellx, rcelly, rcellz
  use species_module,   only: species
  use md_control,       only: md_n_nhc, ion_velocity, type_thermostat, &
                              type_barostat, lattice_vec, &
                              flag_extended_system, md_cell_constraint, heat_flux

  implicit none

  logical       :: md_tdep ! Dump output for a TDEP calculation?
  character(20) :: file_meta      = 'infile.meta' ! filenames for TDEP
  character(20) :: file_positions = 'infile.positions'
  character(20) :: file_forces    = 'infile.forces'
  character(20) :: file_stat      = 'infile.stat'
  character(20) :: file_loto      = 'infile.lotosplitting'

  !!****s* md_model/type_md_model *
  !!  NAME
  !!   type_md_model
  !!  PURPOSE
  !!   Container for one step of MD data
  !!  AUTHOR
  !!   Zamaan Raza
  !!  SOURCE
  !!
  type type_md_model

    logical                                 :: append   ! append to file?

    ! Simulation parameters
    integer                                 :: step
    integer                                 :: ndof     ! degrees of freedom
    character(3)                            :: ensemble ! nve, nvt, npt etc
    real(double), dimension(:,:), pointer   :: lattice_vec
    real(double), pointer                   :: volume
    real(double)                            :: timestep
    integer                                 :: nequil   ! equilibration steps

    ! ionic variables
    integer                                 :: natoms
    integer, pointer, dimension(:)          :: species
    real(double), pointer                   :: lat_a, lat_b, lat_c
    real(double), pointer, dimension(:)     :: pos_x, pos_y, pos_z
    real(double), pointer, dimension(:,:)   :: atom_coords
    real(double), pointer, dimension(:,:)   :: atom_velocity
    real(double), pointer, dimension(:,:)   :: atom_force

    ! MD variables
    real(double)                            :: ion_kinetic_energy
    real(double)                            :: dft_total_energy
    real(double)                            :: h_prime  ! conserved qty

    ! Thermodynamic variables
    real(double), pointer                   :: T_int    ! internal temperature
    real(double), pointer                   :: T_ext    ! target temperature
    real(double), pointer                   :: P_int    ! internal pressure
    real(double), pointer                   :: P_ext    ! target pressure
    real(double), pointer                   :: PV
    real(double)                            :: enthalpy
    real(double), pointer, dimension(:)     :: J_v

    ! Thermostat
    character(20), pointer                  :: thermo_type
    real(double), pointer                   :: lambda   ! velocity scaling fac
    real(double), pointer                   :: tau_T    ! T coupling period
    integer, pointer                        :: n_nhc
    real(double), pointer                   :: e_thermostat
    real(double), pointer                   :: nhc_cell_energy
    real(double), pointer                   :: nhc_ion_energy
    real(double), pointer, dimension(:)     :: eta
    real(double), pointer, dimension(:)     :: v_eta
    real(double), pointer, dimension(:)     :: G_nhc
    real(double), pointer, dimension(:)     :: m_nhc
    real(double), pointer, dimension(:)     :: eta_cell
    real(double), pointer, dimension(:)     :: v_eta_cell
    real(double), pointer, dimension(:)     :: G_nhc_cell
    real(double), pointer, dimension(:)     :: m_nhc_cell

    ! Barostat
    character(20), pointer                  :: baro_type
    real(double), pointer, dimension(:,:)   :: stress
    real(double), pointer, dimension(:,:)   :: static_stress
    real(double), pointer, dimension(:,:)   :: ke_stress
    real(double), pointer                   :: e_barostat
    real(double), pointer                   :: m_box
    real(double), pointer                   :: eps
    real(double), pointer                   :: v_eps
    real(double), pointer                   :: G_eps
    real(double), dimension(3,3)            :: c_g
    real(double), dimension(3,3)            :: v_g

    contains

      procedure, public   :: init_model
      procedure, public   :: get_cons_qty
      procedure, public   :: print_md_energy
      procedure, public   :: dump_stats
      procedure, public   :: dump_frame
      procedure, public   :: dump_heat_flux
      procedure, public   :: dump_tdep

      procedure, private  :: dump_mdl_atom_arr

  end type type_md_model
  !!***

contains

  !!****m* md_model/init_model *
  !!  NAME
  !!   init_model
  !!  PURPOSE
  !!   Initialiase the MD model
  !!  AUTHOR
  !!   Zamaan Raza
  !!  SOURCE
  !!
  subroutine init_model(mdl, ensemble, timestep, thermo, baro)

    ! passed variables
    class(type_md_model), intent(inout)       :: mdl
    character(3), intent(in)                  :: ensemble
    real(double), intent(in)                  :: timestep
    type(type_thermostat), intent(in), target :: thermo
    type(type_barostat), intent(in), target   :: baro

    if (inode==ionode .and. iprint_MD > 2) &
      write(io_lun,'(2x,a)') "Initialising model"

    mdl%append = .false.
    if (flag_MDcontinue) mdl%append = .true.

    ! General MD arrays
    mdl%step = 0
    mdl%natoms = ni_in_cell
    mdl%ensemble = ensemble
    mdl%timestep = timestep
    mdl%species       => species
    mdl%lat_a         => rcellx
    mdl%lat_b         => rcelly
    mdl%lat_c         => rcellz
    mdl%pos_x         => x_atom_cell
    mdl%pos_y         => y_atom_cell
    mdl%pos_z         => z_atom_cell
    mdl%atom_coords   => atom_coord
    mdl%atom_force    => tot_force
    mdl%atom_velocity => ion_velocity
    mdl%lattice_vec   => lattice_vec
    mdl%stress        => stress
    mdl%J_v           => heat_flux

    ! Thermostat
    mdl%T_int         => thermo%T_int
    mdl%T_ext         => thermo%T_ext
    mdl%thermo_type   => thermo%thermo_type
    mdl%lambda        => thermo%lambda
    mdl%tau_T         => thermo%tau_T
    mdl%n_nhc         => thermo%n_nhc
    mdl%e_thermostat    => thermo%e_thermostat
    mdl%nhc_ion_energy  => thermo%e_nhc_ion
    mdl%nhc_cell_energy => thermo%e_nhc_cell
    mdl%eta           => thermo%eta
    mdl%v_eta         => thermo%v_eta
    mdl%G_nhc         => thermo%G_nhc
    mdl%m_nhc         => thermo%m_nhc
    mdl%eta_cell      => thermo%eta_cell
    mdl%v_eta_cell    => thermo%v_eta_cell
    mdl%G_nhc_cell    => thermo%G_nhc_cell
    mdl%m_nhc_cell    => thermo%m_nhc_cell

    ! Barostat
    mdl%P_int         => baro%P_int
    mdl%P_ext         => baro%P_ext
    mdl%volume        => baro%volume
    mdl%PV            => baro%PV
    mdl%e_barostat => baro%e_barostat
    mdl%baro_type     => baro%baro_type
    mdl%static_stress => baro%static_stress
    mdl%ke_stress     => baro%ke_stress
    mdl%m_box         => baro%box_mass
    mdl%eps           => baro%eps
    mdl%v_eps         => baro%v_eps
    mdl%G_eps         => baro%G_eps

  end subroutine init_model
  !!***

  !!****m* md_model/get_cons_qty *
  !!  NAME
  !!   get_cons_qty
  !!  PURPOSE
  !!   Initialiase the MD model
  !!  AUTHOR
  !!   Zamaan Raza
  !!  SOURCE
  !!
  subroutine get_cons_qty(mdl)

    use input_module,     only: leqi

    ! passed variables
    class(type_md_model), intent(inout)   :: mdl

    if (inode==ionode .and. flag_MDdebug .and. iprint_MD > 1) &
      write(io_lun,'(2x,a)') "get_cons_qty"

    select case(mdl%ensemble)
    case("nve")
      mdl%h_prime = mdl%ion_kinetic_energy + mdl%dft_total_energy
    case("nvt")
      select case(mdl%thermo_type)
      case('nhc')
        mdl%h_prime = mdl%ion_kinetic_energy + mdl%dft_total_energy + &
                      mdl%e_thermostat
      case('svr')
        mdl%h_prime = mdl%ion_kinetic_energy + mdl%dft_total_energy + &
                      mdl%e_thermostat
      case default
        mdl%h_prime = mdl%ion_kinetic_energy + mdl%dft_total_energy
      end select
    case("nph")
      if (flag_extended_system) then
        mdl%h_prime = mdl%ion_kinetic_energy + mdl%dft_total_energy + &
                      mdl%e_barostat + mdl%PV
      else
        mdl%h_prime = mdl%ion_kinetic_energy + mdl%dft_total_energy + mdl%PV
      end if
    case("npt")
      if (flag_extended_system) then
        select case(mdl%thermo_type)
        case('nhc')
          mdl%h_prime = mdl%ion_kinetic_energy + mdl%dft_total_energy + &
                        mdl%e_thermostat + mdl%e_barostat + mdl%PV
        case('svr')
          mdl%h_prime = mdl%ion_kinetic_energy + mdl%dft_total_energy + &
                        mdl%e_thermostat + mdl%e_barostat + mdl%PV
        end select
      else
        mdl%h_prime = mdl%ion_kinetic_energy + mdl%dft_total_energy + mdl%PV
      end if
    end select

  end subroutine get_cons_qty
  !!***

  !!****m* md_model/print_md_energy *
  !!  NAME
  !!   print_md_energy
  !!  PURPOSE
  !!   Print MD output at the end of each ionic step
  !!  AUTHOR
  !!   Zamaan Raza
  !!  SOURCE
  !!
  subroutine print_md_energy(mdl)

    ! passed variables
    class(type_md_model), intent(inout)   :: mdl

    ! local variables

    if (inode==ionode .and. flag_MDdebug .and. iprint_MD > 1) &
      write(io_lun,'(2x,a)') "print_md_energy"

    if (inode==ionode) then
      write (io_lun, '(4x,"Conserved quantity H''  : ",f15.8)') &
        mdl%h_prime
      write (io_lun, '(4x,a)') "Components of conserved quantity"
      write (io_lun, '(4x,"Kinetic energy          : ",f15.8)') &
        mdl%ion_kinetic_energy
      write (io_lun, '(4x,"Potential energy        : ",f15.8)') &
        mdl%dft_total_energy
      select case(mdl%ensemble)
      case('nvt')
        select case(mdl%thermo_type)
        case('nhc')
          write (io_lun, '(4x,"Nose-Hoover energy      : ",f15.8)') &
            mdl%e_thermostat
        case('svr')
          write (io_lun, '(4x,"SVR energy              : ",f15.8)') &
            mdl%e_thermostat
        end select
      case('npt')
        if (flag_extended_system .and. mdl%nequil < 1) then
          select case(mdl%thermo_type)
          case('nhc')
            write (io_lun, '(4x,"Nose-Hoover energy      : ",f15.8)') &
              mdl%e_thermostat
          case('svr')
            write (io_lun, '(4x,"SVR energy              : ",f15.8)') &
              mdl%e_thermostat
          end select
          write (io_lun, '(4x,"Box kinetic energy      : ",f15.8)') &
            mdl%e_barostat
        end if
        write (io_lun, '(4x,"PV                      : ",f15.8)') &
          mdl%PV
      end select
    end if
  end subroutine print_md_energy

  !!****m* md_model/dump_stats *
  !!  NAME
  !!   dump_stats
  !!  PURPOSE
  !!   dump thermodynamics stats to a file
  !!  AUTHOR
  !!   Zamaan Raza
  !!  SOURCE
  !!
  subroutine dump_stats(mdl, filename, nequil)

    use input_module,     only: io_assign, io_close
    use units,            only: HaBohr3ToGPa

    ! passed variables
    class(type_md_model), intent(inout)   :: mdl
    character(len=*), intent(in)          :: filename
    integer, intent(in)                   :: nequil

    ! local variables
    integer                               :: lun
    real(double)                          :: P_GPa

    if (inode==ionode .and. iprint_MD > 1) &
      write(io_lun,'(2x,"Writing statistics to ",a)') filename

    ! Convert units if necessary
    P_GPa = mdl%P_int*HaBohr3ToGPa

    if (inode==ionode) then
      call io_assign(lun)

      if (mdl%append) then
        open(unit=lun,file=filename,position='append')
      else
        open(unit=lun,file=filename,status='replace')
        select case (mdl%ensemble)
        case ('nve')
          write(lun,'(a10,3a18,2a12)') "step", "pe", "ke", "H'", "T", "P"
        case ('nvt')
          write(lun,'(a10,4a18,2a12)') "step", "pe", "ke", "thermostat", &
            "H'", "T", "P"
        case ('nph')
          write(lun,'(a10,5a18,2a12,a16)') "step", "pe", "ke", "barostat", &
            "pV", "H'", "T", "P", "V"
        case ('npt')
          write(lun,'(a10,6a18,2a12,a16)') "step", "pe", "ke", "thermostat", &
            "barostat", "pV", "H'", "T", "P", "V"
        end select
      end if
      select case (mdl%ensemble)
      case ('nve')
        write(lun,'(i10,3e18.8,2f12.4)') mdl%step, mdl%dft_total_energy, &
          mdl%ion_kinetic_energy, mdl%h_prime, mdl%T_int, P_GPa
      case ('nvt')
        write(lun,'(i10,4e18.8,2f12.4)') mdl%step, mdl%dft_total_energy, &
          mdl%ion_kinetic_energy, mdl%e_thermostat, mdl%h_prime, mdl%T_int, &
          P_GPa
      case ('nph')
        write(lun,'(i10,5e18.8,2f12.4,e16.8)') mdl%step, &
          mdl%dft_total_energy, mdl%ion_kinetic_energy, &
          mdl%e_barostat, mdl%PV, mdl%h_prime, mdl%T_int, P_GPa, &
          mdl%volume
      case ('npt')
        write(lun,'(i10,6e18.8,2f12.4,e16.8)') mdl%step, &
          mdl%dft_total_energy, mdl%ion_kinetic_energy, mdl%e_thermostat, &
          mdl%e_barostat, mdl%PV, mdl%h_prime, mdl%T_int, &
          P_GPa, mdl%volume
      end select
      call io_close(lun)
    end if

  end subroutine dump_stats
  !!***

  !!****m* md_model/dump_frame *
  !!  NAME
  !!   dump_frame
  !!  PURPOSE
  !!   Dump all relevant restart/analysis-relevant data to file
  !!  AUTHOR
  !!   Zamaan Raza
  !!  SOURCE
  !!
  subroutine dump_frame(mdl, filename)

    use input_module,     only: io_assign, io_close

    ! passed variables
    class(type_md_model), intent(inout)   :: mdl
    character(len=*), intent(in)          :: filename

    ! local variables
    integer                               :: lun, i

    if (inode==ionode) then
      if (iprint_MD > 1) write(io_lun,'(2x,"Writing frame to ",a)') filename
      call io_assign(lun)
      if (mdl%append) then
        open(unit=lun,file=filename,position='append')
      else
        open(unit=lun,file=filename,status='replace')
      end if

      write(lun,'("frame ",i8)') mdl%step
      write(lun,'(a)') "cell_vectors"
      do i=1,3
        write(lun,'(3f12.6)') mdl%lattice_vec(i,:)
      end do
      write(lun,'(a)') "end cell_vectors"
      write(lun,'(a)') "stress_tensor"
      write(lun,'(3f14.6)') mdl%stress(1,:)
      write(lun,'(3f14.6)') mdl%stress(2,:)
      write(lun,'(3f14.6)') mdl%stress(3,:)
      write(lun,'(a)') "end stress_tensor"
      write(lun,'(a)') "positions"
      call mdl%dump_mdl_atom_arr(lun, mdl%atom_coords)
      write(lun,'(a)') "end positions"
      write(lun,'(a)') "velocities"
      call mdl%dump_mdl_atom_arr(lun, mdl%atom_velocity)
      write(lun,'(a)') "end velocities"
      write(lun,'(a)') "forces"
      call mdl%dump_mdl_atom_arr(lun, mdl%atom_force)
      write(lun,'(a)') "end forces"
      write(lun,'(a)') "end frame"
    end if

    call io_close(lun)

  end subroutine dump_frame
  !!***

  !!****m* md_model/dump_heat_flux *
  !!  NAME
  !!   dump_heat_flux
  !!  PURPOSE
  !!   Dump the heat flux for Green-Kubo thermal conductivity
  !!  AUTHOR
  !!   Zamaan Raza
  !!  SOURCE
  !!
  subroutine dump_heat_flux(mdl, filename)

    use input_module,     only: io_assign, io_close

    ! passed variables
    class(type_md_model), intent(inout)   :: mdl
    character(len=*), intent(in)          :: filename

    ! local variables
    integer                               :: lun, i

    if (inode==ionode) then
      if (iprint_MD > 1) write(io_lun,'(2x,"Writing heat flux to ",a)') filename
      call io_assign(lun)
      if (mdl%append) then
        open(unit=lun,file=filename,position='append')
      else
        open(unit=lun,file=filename,status='replace')
      end if

      write(lun,'(i8,3e20.10)') mdl%step, mdl%J_v
    end if

    call io_close(lun)

  end subroutine dump_heat_flux
  !!***

  !!****m* md_model/dump_mdl_atom_arr *
  !!  NAME
  !!   dump_mdl_atom_arr
  !!  PURPOSE
  !!   dump an array of atomic data to file (positions, velocities, forces)
  !!  AUTHOR
  !!   Zamaan Raza
  !!  SOURCE
  !!
  subroutine dump_mdl_atom_arr(mdl, lun, arr)

    ! passed variables
    class(type_md_model), intent(inout)       :: mdl
    integer, intent(in)                       :: lun
    real(double), dimension(:,:), intent(in)  :: arr

    ! local variables
    integer                           :: i

    do i=1,mdl%natoms
      write(lun,'(2i5,3e20.10)') i, mdl%species(i), arr(:,i)
    end do

  end subroutine dump_mdl_atom_arr
  !!***

  !!****m* md_model/dump_tdep *
  !!  NAME
  !!   dump_tdep_frame
  !!  PURPOSE
  !!   Dump a MD step for TDEP postprocessing
  !!  AUTHOR
  !!   Zamaan Raza
  !!  SOURCE
  !!
  subroutine dump_tdep(mdl)

    use input_module,     only: io_assign, io_close
    use units,            only: HaToEv, BohrToAng
    use md_control,       only: HaBohr3ToGPa

    ! passed variables
    class(type_md_model), intent(inout)   :: mdl

    ! local variables
    integer                               :: lun1, lun2, i

    if (inode==ionode) then
      if (flag_MDdebug .and. iprint_MD > 1) &
        write(io_lun,'(2x,a)') "Writing TDEP output"
      call io_assign(lun1)
      open(unit=lun1,file=file_meta,status='replace')
      write(lun1,'(i12,a)') mdl%natoms, " # N atoms"
      write(lun1,'(i12,a)') mdl%step, " # N time steps"
      write(lun1,'(f12.2,a)') mdl%timestep, " # time step in fs"
      write(lun1,'(f12.2,a)') mdl%T_ext, " # temperature in K"
      call io_close(lun1)

      call io_assign(lun1)
      call io_assign(lun2)

      if (mdl%append) then
        open(unit=lun1,file=file_positions,status='old',position='append')
        open(unit=lun2,file=file_forces,status='old',position='append')
      else
        open(unit=lun1,file=file_positions,status='replace')
        open(unit=lun2,file=file_forces,status='replace')
      end if

      do i=1,mdl%natoms
        write(lun1,'(3e20.12)') mdl%pos_x(i)/mdl%lat_a, &
                                mdl%pos_y(i)/mdl%lat_b, &
                                mdl%pos_z(i)/mdl%lat_c
        write(lun2,'(3e20.12)') mdl%atom_force(:,i)*HaToeV/BohrToAng
      end do
      call io_close(lun1)
      call io_close(lun2)

      call io_assign(lun1)
      if (mdl%append) then
        open(unit=lun1,file=file_stat,status='old',position='append')
      else
        open(unit=lun1,file=file_stat,status='replace')
      end if

      write(lun1,'(i7,f10.1,3e16.8,8e14.6)') mdl%step, mdl%step*mdl%timestep, &
        (mdl%dft_total_energy+mdl%ion_kinetic_energy)*HaToeV, &
        mdl%dft_total_energy*HaToeV, &
        mdl%ion_kinetic_energy*HaToeV, mdl%T_int, mdl%P_int, &
        mdl%stress(1,1)*HaBohr3ToGPa, mdl%stress(2,2)*HaBohr3ToGPa, &
        mdl%stress(3,3)*HaBohr3ToGPa, zero, zero, zero

      call io_close(lun1)
    end if

  end subroutine dump_tdep
  !!***

end module md_model


      subroutine  eflxz(flxz_flag,ptime)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
!***********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 Read control information for writing history files.
!D1
!***********************************************************************
!D2
!D2 REVISION HISTORY
!D2
!D2 FEHM Version 2.22
!D2 Initial implementation: 1-JUN-04,  Programmer: Z. Dash
!D2
!D2 $Log:   /pvcs.config/fehm90/src/flxz.f_a  $
!D2
!***********************************************************************
!D3
!D3  REQUIREMENTS TRACEABILITY
!D3
!D3 2.6 Provide Input/Output Data Files
!D3 3.0 INPUT AND OUTPUT REQUIREMENTS
!D3
!***********************************************************************
!D4
!D4  SPECIAL COMMENTS AND REFERENCES
!D4
!D4 Requirements from SDN: 10086-RD-2.20-00
!D4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
!D4   FEHM Application Version 2.20
!D4
!***********************************************************************

      use comai
      use combi
      use comci
      use comco2, only : c_axy, c_vxy, skco2
      use comdi
      use comji
      use comdti
      use comflow
      use davidi

      implicit none
      integer addnode, iconn, idummy, i1, i2, ishisfzz, ishiscfzz
      integer flxz_flag, indexa_axy, inneq, inode, izone
      integer ii, iv, ic, jj, i3, i4,iq,i11,kb
      integer, allocatable :: md(:)
      real*8, allocatable :: sumfout(:,:), sumsink(:,:)
      real*8, allocatable :: sumsource(:,:), sumboun(:,:)
      real*8, allocatable :: qheat_tot(:)
      real*8 ptime, out_tol,distol,dis2,sx3c
      real*8 sx2c,thxkb,thykb,thzkb,delx2,dely2,delz2
      real*8 sx2t,sx3t,sxzt,thxi,thyi,thzi
      real*8 qheat
      character*18 value_string
      character*24 form_string
      character*90, allocatable :: flux_string(:)
      logical matrix_node

      parameter (out_tol = 1.e-30,distol = 1.e-15)

      if(.not.eflux_flag) return
      if (.not. allocated(sumfout)) then
         allocate (md(nflxz))
         if (eflux_flag) then
             allocate (sumfout(nflxz,2), sumsink(nflxz,2))
             allocate (sumsource(nflxz,2), sumboun(nflxz,2))
             allocate (qheat_tot(nflxz))
         end if
      end if
      ii = 1
      iv = 2
      if (flxz_flag .eq. 1) then
c     Fluxes are written to tty and output file
         if(iatty.ne.0) then
            write(iatty,*)
            write(iatty,*)
     2           'Total Energy (MW) Leaving Zone (eflxz macro option)'
            write(iatty,*)
            write(iatty,*)'Zone(# nodes)       Source      ',
     &       '  Sink        Net     Boundary     Conduction'
            write(iatty,*)
         end if
         if(ntty.eq.2 .and. iout .ne. 0) then
            write(iout,*)
            write(iout,*)
     2            'Total Energy (MW) Leaving Zone (eflxz macro option)'
            write(iout,*)
            write(iout,*)'Zone(# nodes)       Source      ',
     &       '  Sink         Net     Boundary     Conduction'
            write(iout,*)
         end if
      else
c     Fluxes are written to flux history file
         if (.not. allocated (flux_string))
     &        allocate (flux_string(nflxz))
      end if
c     Compute fluxes out of zone (>0), leaving out fluxes
c     into other parts of the zone
      ii = 1

      sumfout = 0.0
      sumsink = 0.0
      sumsource = 0.0
      sumboun = 0.0
      qheat_tot = 0.0
      md = 0
      do izone = 1, nflxz
c     Loop over all nodes
         do inode = 1, n0
c     Determine if node is fracture or matrix, set indexes
c     and flags accordingly
            if(inode.gt.neq) then
               inneq = inode-neq
               matrix_node = .true.
               addnode = nelm(neq+1)-neq-1
               idummy = neq
            else
               matrix_node = .false.
               inneq = inode
               addnode = 0
               idummy = 0
            end if
c     Determine if node is part of the zone being summed
            if(izoneflxz(inode).eq.izone) then
               thxi=thx(inode)
               thyi=thy(inode)
               thzi=thz(inode)
c     Figure out coefficients for heat conduction term
               i1 = nelm(inneq)+1
               i11 = nelmdg(inneq)
               i2 = nelm(inneq+1)
               iq = 0
               do iconn = i1,i11-1
                kb = nelm(iconn)
                i3 = nelmdg(kb)+1
                i4 = nelm(kb+1)
                do jj = i3,i4
                 if(nelm(jj).eq.inneq) then
                  indexa_axy = jj-neq-1
                  iq = iq +1
                  it10(iq)=istrw(indexa_axy)
                  go to 300
                 endif
                enddo
300            continue
               enddo
               do iconn = i11+1,i2
                indexa_axy = iconn-neq-1
                iq = iq +1
                it10(iq)=istrw(indexa_axy)
               enddo

               md(izone) = md(izone) + 1
c     Add boundary condition sources
                  sumboun(izone,1) = sumboun(izone,1) + qh(inode)
c     Set index for looping through a_axy depending on whether
c     the node is a fracture or matrix node

c     loop over every connecting node
               iq = 0
               do iconn = i1, i2
                  kb = nelm(iconn)
                  indexa_axy = iconn-neq-1+addnode
c     add to sum if it is flow out of the node
c     RJP 07/05/07 changed for CO2 flux
                  if(kb.eq.inode) then
                   if(qh(inode).gt.0.0) sumsink(izone,ii) =
     &             sumsink(izone,ii) + qh(inode)
                   if(qh(inode).lt.0.0) sumsource(izone,ii) =
     &             sumsource(izone,ii) + qh(inode)
                  endif
c     heat conduction term
                  if(kb.ne.inode) then
                   iq = iq +1
                   iw = it10(iq)
                   sx2c=sx(iw,isox)+sx(iw,isoy)+sx(iw,isoz)
                   thxkb=thx(kb)
                   thykb=thy(kb)
                   thzkb=thz(kb)
                   sx2t=2.*thxi*thxkb/(thxi+thxkb)
                   sx3t=2.*thyi*thykb/(thyi+thykb)
                   sxzt=2.*thzi*thzkb/(thzi+thzkb)
                    delx2=max((cord(kb,1)-cord(inode,1))**2,distol)
                    dely2=max((cord(kb,2)-cord(inode,2))**2,distol)
                    delz2=max((cord(kb,3)-cord(inode,3))**2,distol)
                    dis2=delx2+dely2+delz2
                    sx3c=sx2c*dis2/(delx2/sx2t+dely2/sx3t+
     &              delz2/sxzt)
                    qheat = sx3c*(t(kb)-t(inode))
                    qheat_tot(izone) = qheat_tot(izone) + qheat
c                    write(ierr,*) l,izone,inode,kb,qheat,qheat_tot
                  endif
                  if (flxz_flag.eq.3) then
                  else
                     if(wflux_flag .and. a_axy(indexa_axy).gt.0.) then
c     add to sum only if the connecting node is not also
c     in the zone or else the connecting node is itself, i.e.
c     the value is a sink term
                        if(izoneflxz(idummy+nelm(iconn))
     2                       .ne.izone) then
                           sumfout(izone,ii) = sumfout(izone,ii) +
     &                          a_axy(indexa_axy)*enlf(inode)
                        end if
                     elseif(wflux_flag.and.a_axy(indexa_axy).lt.0.) then
c     add to source sum
                        if(izoneflxz(idummy+nelm(iconn))
     2                       .ne.izone) then
                           sumfout(izone,ii) = sumfout(izone,ii) +
     2                          a_axy(indexa_axy)*enlf(kb)
                        end if
                     end if
                     if(vflux_flag) then
                        if (a_vxy(indexa_axy).gt.0.) then
c     add to sum only if the connecting node is not also
c     in the zone or else the connecting node is itself, i.e.
c     the value is a sink term
                        if(izoneflxz(idummy+nelm(iconn))
     2                       .ne.izone) then
                              sumfout(izone,iv) = sumfout(izone,iv) +
     &                             a_vxy(indexa_axy)*envf(inode)
                           end if
                        else if (a_vxy(indexa_axy).lt.0.) then
c     add to source sum
                        if(izoneflxz(idummy+nelm(iconn))
     2                       .ne.izone) then
                              sumfout(izone,iv) = sumfout(izone,iv)
     2                             + a_vxy(indexa_axy)*envf(kb)
                           end if
                       end if
                     end if
                  end if
               end do
            end if
         end do
      end do
c     Write results
      if (flxz_flag .eq. 1) then
c     Fluxes are written to tty and output file
         if(eflux_flag) then
            do izone = 1, nflxz
               if(iatty.ne.0) then
                  write(iatty,1045) iflxz(izone), md(izone),
     2                 sumsource(izone,ii)+sumsource(izone,iv),
     &                 sumsink(izone,ii)+sumsink(izone,iv),
     3                 sumfout(izone,ii)+sumfout(izone,iv),
     &                 sumboun(izone,ii)+sumboun(izone,iv),
     &                 qheat_tot(izone)
               end if
               if(ntty.eq.2 .and. iout .ne. 0) then
                  write(iout,1045) iflxz(izone), md(izone),
     2                 sumsource(izone,ii)+sumsource(izone,iv),
     &                 sumsink(izone,ii)+sumsink(izone,iv),
     3                 sumfout(izone,ii)+sumfout(izone,iv),
     &                 sumboun(izone,ii)+sumboun(izone,iv),
     &                 qheat_tot(izone)
               end if
                if(l.eq.1.and.izone.eq.1) then
                 write(ierr,*) 'days,zone, and conduction heat loss(1)'
                endif
               if(izone.eq.1) then
                write(ierr,*) ' days = ',days
                do i3 = 1,nflxz
                 write(ierr,'(1x,i6,1x,g14.5,1x,i6,g14.5)')
     &              iflxz(i3),qheat_tot(i3)
                enddo
               endif
            end do
         end if
      else if (flxz_flag .eq. 2) then
c     Fluxes are written to flux history file
         form_string = ''
         if (form_flag .le. 1) then
            form_string = '(1x, g16.9)'
         else
            form_string = '(", ", g16.9)'
         end if
         if (eflux_flag) then
            do izone = 1, nflxz
               flux_string = ''
               if (prnt_flxzvar(1)) then
                  write(value_string, form_string) (sumsource(izone,ii)+
     &               sumsource(izone,iv))
                  flux_string(izone) = trim(flux_string(izone)) //
     &                 trim(value_string)
               end if
               if (prnt_flxzvar(2)) then
                  write(value_string, form_string) (sumsink(izone,ii)+
     &               sumsink(izone,iv))
                  flux_string(izone) = trim(flux_string(izone)) //
     &                 trim(value_string)
               end if
               if (prnt_flxzvar(3)) then
                  write(value_string, form_string) (sumfout(izone,ii)+
     &               sumfout(izone,iv))
                  flux_string(izone) = trim(flux_string(izone)) //
     &                 trim(value_string)
               end if
               if (prnt_flxzvar(4)) then
                  write(value_string, form_string) (sumboun(izone,ii)+
     &               sumboun(izone,iv))
                  flux_string(izone) = trim(flux_string(izone)) //
     &                 trim(value_string)
               end if
               if (prnt_flxzvar(5)) then
                  write(value_string, form_string) qheat_tot(izone)

                  flux_string(izone) = trim(flux_string(izone)) //
     &                 trim(value_string)
               end if
               ishisfzz = ishisfz + izone + 800
               if (form_flag .le. 1) then
                  write (ishisfzz, 1051) ptime, trim(flux_string(izone))
               else
                  write (ishisfzz, 1057) ptime, trim(flux_string(izone))
               end if
               call flush(ishisfzz)
            end do
         end if
      elseif (flxz_flag.eq.3) then
c     Fluxes are written to flux history file
         flux_string = ''
         do izone = 1, nflxz
            if (abs(sumsource(izone,ic)) .lt. out_tol)
     &           sumsource(izone,ic) = 0.d0
            if (abs(sumsink(izone,ic)) .lt. out_tol)
     &           sumsink(izone,ic) = 0.d0
            if (abs(sumfout(izone,ic)) .lt. out_tol)
     &           sumfout(izone,ic) = 0.d0
            if (abs(sumboun(izone,ic)) .lt. out_tol)
     &           sumboun(izone,ic) = 0.d0
            if (form_flag .le. 1) then
               write (flux_string(izone), 1050) sumsource(izone,ic),
     &              sumsink(izone,ic), sumfout(izone,ic),
     &              sumboun(izone,ic)
            else
               write (flux_string(izone), 1055) sumsource(izone,ic),
     &              sumsink(izone,ic), sumfout(izone,ic),
     &              sumboun(izone,ic)
            end if
            ishiscfzz = ishiscfz + izone
            if (form_flag .le. 1) then
               write (ishiscfzz, 1051) ptime, trim(flux_string(izone))
            else
               write (ishiscfzz, 1057) ptime, trim(flux_string(izone))
            end if
            call flush(ishiscfzz)
         end do
      end if

 1045 format(1x,i4,' (',i6,')',2x,1p,5(1x,e12.5))
 1046 format(1x,i4,' (',i6,')',2x,1p,5(1x,e12.5))
 1047 format('(g16.9, ', i3, '(a))')
 1050 format(4(g16.9, 1x), g16.9)
 1051 format(g16.9, 1x, a)
 1055 format(4(", ", g16.9))
 1056 format(5(", ", g16.9))
 1057 format(g16.9, a)

      end


! 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 layerDivide_module

! variable types
USE nrtype

! physical constants
USE multiconst,only:&
                    iden_ice,       & ! intrinsic density of ice             (kg m-3)
                    iden_water        ! intrinsic density of liquid water    (kg m-3)

! access named variables for snow and soil
USE globalData,only:iname_snow        ! named variables for snow
USE globalData,only:iname_soil        ! named variables for soil

! define look-up values for the choice of method to combine and sub-divide snow layers
USE mDecisions_module,only:&
 sameRulesAllLayers,       & ! SNTHERM option: same combination/sub-dividion rules applied to all layers
 rulesDependLayerIndex       ! CLM option: combination/sub-dividion rules depend on layer index

! define look-up values for the choice of canopy shortwave radiation method
USE mDecisions_module,only:&
 noah_mp,                  & ! full Noah-MP implementation (including albedo)
 CLM_2stream,              & ! CLM 2-stream model (see CLM documentation)
 UEB_2stream,              & ! UEB 2-stream model (Mahat and Tarboton, WRR 2011)
 NL_scatter,               & ! Simplified method Nijssen and Lettenmaier (JGR 1999)
 BeersLaw                    ! Beer's Law (as implemented in VIC)

! define look-up values for the choice of albedo method
USE mDecisions_module,only:& ! identify model options for snow albedo
 constantDecay,            & ! constant decay in snow albedo (e.g., VIC, CLASS)
 variableDecay               ! variable decay in snow albedo (e.g., BATS approach, with destructive metamorphism + soot content)

implicit none
private
public::layerDivide

! provide access to the number layers throughout the module
integer(i4b)                    :: nSnow               ! number of snow layers
integer(i4b)                    :: nSoil               ! number of soil layers
integer(i4b)                    :: nLayers             ! total number of layers
! define missing values
real(dp)              :: missingDouble=-9999._dp  ! missing value (double precision)
integer(i4b)          :: missingInteger=-9999     ! missing value (integer)

contains

 ! ***********************************************************************************************************
 ! public subroutine layerDivide: add new snowfall to the system, and increase number of snow layers if needed
 ! ***********************************************************************************************************
 subroutine layerDivide(&
                        ! input/output: model data structures
                        model_decisions,             & ! intent(in):    model decisions
                        mpar_data,                   & ! intent(in):    model parameters
                        indx_data,                   & ! intent(inout): type of each layer
                        prog_data,                   & ! intent(inout): model prognostic variables for a local HRU
                        diag_data,                   & ! intent(inout): model diagnostic variables for a local HRU
                        flux_data,                   & ! intent(inout): model fluxes for a local HRU
                        ! output
                        divideLayer,                 & ! intent(out): flag to denote that a layer was divided
                        err,message)                   ! intent(out): error control
 ! --------------------------------------------------------------------------------------------------------
 ! --------------------------------------------------------------------------------------------------------
 ! access the derived types to define the data structures
 USE data_types,only:&
                     var_d,            & ! data vector (dp)
                     var_ilength,      & ! data vector with variable length dimension (i4b)
                     var_dlength,      & ! data vector with variable length dimension (dp)
                     model_options       ! defines the model decisions
 ! access metadata
 USE globalData,only:prog_meta,diag_meta,flux_meta,indx_meta   ! metadata
 ! access named variables defining elements in the data structures
 USE var_lookup,only:iLookPROG,iLookDIAG,iLookFLUX,iLookINDEX  ! named variables for structure elements
 USE var_lookup,only:iLookDECISIONS                            ! named variables for elements of the decision structure
 USE var_lookup,only:iLookPARAM                                ! named variables for elements of the parameter structure
 ! computational modules
 USE snow_utils_module,only:fracliquid,templiquid              ! functions to compute temperature/liquid water
 implicit none
 ! --------------------------------------------------------------------------------------------------------
 ! input/output: model data structures
 type(model_options),intent(in)  :: model_decisions(:)  ! model decisions
 type(var_dlength),intent(in)    :: mpar_data           ! model parameters
 type(var_ilength),intent(inout) :: indx_data           ! type of each layer
 type(var_dlength),intent(inout) :: prog_data           ! model prognostic variables for a local HRU
 type(var_dlength),intent(inout) :: diag_data           ! model diagnostic variables for a local HRU
 type(var_dlength),intent(inout) :: flux_data           ! model flux variables
 ! output
 logical(lgt),intent(out)        :: divideLayer         ! flag to denote that a layer was divided
 integer(i4b),intent(out)        :: err                 ! error code
 character(*),intent(out)        :: message             ! error message
 ! --------------------------------------------------------------------------------------------------------
 ! define local variables
 character(LEN=256)              :: cmessage            ! error message of downwind routine
 integer(i4b)                    :: iLayer              ! layer index
 integer(i4b)                    :: jLayer              ! layer index
 real(dp),dimension(4)           :: zmax_lower          ! lower value of maximum layer depth
 real(dp),dimension(4)           :: zmax_upper          ! upper value of maximum layer depth
 real(dp)                        :: zmaxCheck           ! value of zmax for a given snow layer
 integer(i4b)                    :: nCheck              ! number of layers to check to divide
 logical(lgt)                    :: createLayer         ! flag to indicate we are creating a new snow layer
 real(dp)                        :: depthOriginal       ! original layer depth before sub-division (m)
 real(dp),parameter              :: fracTop=0.5_dp      ! fraction of old layer used for the top layer
 real(dp)                        :: surfaceLayerSoilTemp  ! temperature of the top soil layer (K)
 real(dp)                        :: maxFrozenSnowTemp   ! maximum temperature when effectively all water is frozen (K)
 real(dp),parameter              :: unfrozenLiq=0.01_dp ! unfrozen liquid water used to compute maxFrozenSnowTemp (-)
 real(dp)                        :: volFracWater        ! volumetric fraction of total water, liquid and ice (-)
 real(dp)                        :: fracLiq             ! fraction of liquid water (-)
 integer(i4b),parameter          :: ixVisible=1         ! named variable to define index in array of visible part of the spectrum
 integer(i4b),parameter          :: ixNearIR=2          ! named variable to define index in array of near IR part of the spectrum
 real(dp),parameter              :: verySmall=1.e-10_dp ! a very small number (used for error checking)
 ! --------------------------------------------------------------------------------------------------------
 ! initialize error control
 err=0; message="layerDivide/"
 ! --------------------------------------------------------------------------------------------------------
 ! associate variables in the data structures
 associate(&
 ! model decisions
 ix_snowLayers          => model_decisions(iLookDECISIONS%snowLayers)%iDecision, & ! decision for snow combination
 ! model parameters (compute layer temperature)
 fc_param               => mpar_data%var(iLookPARAM%snowfrz_scale)%dat(1),       & ! freezing curve parameter for snow (K-1)
 ! model parameters (new snow density)
 newSnowDenMin          => mpar_data%var(iLookPARAM%newSnowDenMin)%dat(1),       & ! minimum new snow density (kg m-3)
 newSnowDenMult         => mpar_data%var(iLookPARAM%newSnowDenMult)%dat(1),      & ! multiplier for new snow density (kg m-3)
 newSnowDenScal         => mpar_data%var(iLookPARAM%newSnowDenScal)%dat(1),      & ! scaling factor for new snow density (K)
 ! model parameters (control the depth of snow layers)
 zmax                   => mpar_data%var(iLookPARAM%zmax)%dat(1),                & ! maximum layer depth (m)
 zmaxLayer1_lower       => mpar_data%var(iLookPARAM%zmaxLayer1_lower)%dat(1),    & ! maximum layer depth for the 1st (top) layer when only 1 layer (m)
 zmaxLayer2_lower       => mpar_data%var(iLookPARAM%zmaxLayer2_lower)%dat(1),    & ! maximum layer depth for the 2nd layer when only 2 layers (m)
 zmaxLayer3_lower       => mpar_data%var(iLookPARAM%zmaxLayer3_lower)%dat(1),    & ! maximum layer depth for the 3rd layer when only 3 layers (m)
 zmaxLayer4_lower       => mpar_data%var(iLookPARAM%zmaxLayer4_lower)%dat(1),    & ! maximum layer depth for the 4th layer when only 4 layers (m)
 zmaxLayer1_upper       => mpar_data%var(iLookPARAM%zmaxLayer1_upper)%dat(1),    & ! maximum layer depth for the 1st (top) layer when > 1 layer (m)
 zmaxLayer2_upper       => mpar_data%var(iLookPARAM%zmaxLayer2_upper)%dat(1),    & ! maximum layer depth for the 2nd layer when > 2 layers (m)
 zmaxLayer3_upper       => mpar_data%var(iLookPARAM%zmaxLayer3_upper)%dat(1),    & ! maximum layer depth for the 3rd layer when > 3 layers (m)
 zmaxLayer4_upper       => mpar_data%var(iLookPARAM%zmaxLayer4_upper)%dat(1),    & ! maximum layer depth for the 4th layer when > 4 layers (m)
 ! diagnostic scalar variables
 scalarSnowfall         => flux_data%var(iLookFLUX%scalarSnowfall)%dat(1),       & ! snowfall flux (kg m-2 s-1)
 scalarSnowfallTemp     => diag_data%var(iLookDIAG%scalarSnowfallTemp)%dat(1),   & ! computed temperature of fresh snow (K)
 scalarSnowDepth        => prog_data%var(iLookPROG%scalarSnowDepth)%dat(1),      & ! total snow depth (m)
 scalarSWE              => prog_data%var(iLookPROG%scalarSWE)%dat(1)             & ! SWE (kg m-2)
 )  ! end associate statement

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

 ! initialize flag to denote that a layer was divided
 divideLayer=.false.

 ! identify algorithmic control parameters to syb-divide and combine snow layers
 zmax_lower = (/zmaxLayer1_lower, zmaxLayer2_lower, zmaxLayer3_lower, zmaxLayer4_lower/)
 zmax_upper = (/zmaxLayer1_upper, zmaxLayer2_upper, zmaxLayer3_upper, zmaxLayer4_upper/)

 ! initialize the number of snow layers
 nSnow   = indx_data%var(iLookINDEX%nSnow)%dat(1)
 nSoil   = indx_data%var(iLookINDEX%nSoil)%dat(1)
 nLayers = indx_data%var(iLookINDEX%nLayers)%dat(1)

 ! ***** special case of no snow layers
 if(nSnow==0)then

  ! check if create the first snow layer
  select case(ix_snowLayers)
   case(sameRulesAllLayers);    createLayer = (scalarSnowDepth > zmax)
   case(rulesDependLayerIndex); createLayer = (scalarSnowDepth > zmaxLayer1_lower)
   case default; err=20; message=trim(message)//'unable to identify option to combine/sub-divide snow layers'; return
  end select ! (option to combine/sub-divide snow layers)

  ! ** create a new snow layer
  if(createLayer)then

   ! flag that the layers have changed
   divideLayer=.true.

   ! add a layer to all model variables
   iLayer=0 ! (layer to divide: 0 is the special case of "snow without a layer")
   call addModelLayer(prog_data,prog_meta,iLayer,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if
   call addModelLayer(diag_data,diag_meta,iLayer,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if
   call addModelLayer(flux_data,flux_meta,iLayer,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if
   call addModelLayer(indx_data,indx_meta,iLayer,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if

   ! associate local variables to the information in the data structures
   ! NOTE: need to do this here, since state vectors have just been modified
   associate(&
   ! coordinate variables
   mLayerDepth      => prog_data%var(iLookPROG%mLayerDepth)%dat        ,& ! depth of each layer (m)
   ! model state variables
   mLayerTemp       => prog_data%var(iLookPROG%mLayerTemp)%dat         ,& ! temperature of each layer (K)
   mLayerVolFracIce => prog_data%var(iLookPROG%mLayerVolFracIce)%dat   ,& ! volumetric fraction of ice in each layer (-)
   mLayerVolFracLiq => prog_data%var(iLookPROG%mLayerVolFracLiq)%dat    & ! volumetric fraction of liquid water in each layer (-)
   ) ! (association of local variables to the information in the data structures)

   ! get the layer depth
   mLayerDepth(1) = scalarSnowDepth

   ! compute surface layer temperature
   surfaceLayerSoilTemp = mLayerTemp(2)    ! temperature of the top soil layer (K)
   maxFrozenSnowTemp    = templiquid(unfrozenLiq,fc_param)               ! snow temperature at fraction "unfrozenLiq" (K)
   mLayerTemp(1)        = min(maxFrozenSnowTemp,surfaceLayerSoilTemp)    ! snow temperature  (K)

   ! compute the fraction of liquid water associated with the layer temperature
   fracLiq      = fracliquid(mLayerTemp(1),fc_param)

   ! compute volumeteric fraction of liquid water and ice
   volFracWater = (scalarSWE/scalarSnowDepth)/iden_water  ! volumetric fraction of total water (liquid and ice)
   mLayerVolFracIce(1) = (1._dp - fracLiq)*volFracWater*(iden_water/iden_ice)   ! volumetric fraction of ice (-)
   mLayerVolFracLiq(1) =          fracLiq *volFracWater                         ! volumetric fraction of liquid water (-)

   ! end association with local variables to the information in the data structures)
   end associate

   ! initialize albedo
   ! NOTE: albedo is computed within the Noah-MP radiation routine
   if(model_decisions(iLookDECISIONS%canopySrad)%iDecision /= noah_mp)then
    select case(model_decisions(iLookDECISIONS%alb_method)%iDecision)
     ! (constant decay rate -- albedo the same for all spectral bands)
     case(constantDecay)
      prog_data%var(iLookPROG%scalarSnowAlbedo)%dat(1)          = mpar_data%var(iLookPARAM%albedoMax)%dat(1)
      prog_data%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(:) = mpar_data%var(iLookPARAM%albedoMax)%dat(1)
     ! (variable decay rate)
     case(variableDecay)
      prog_data%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(ixVisible) = mpar_data%var(iLookPARAM%albedoMaxVisible)%dat(1)
      prog_data%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(ixNearIR)  = mpar_data%var(iLookPARAM%albedoMaxNearIR)%dat(1)
      prog_data%var(iLookPROG%scalarSnowAlbedo)%dat(1)                  = (        mpar_data%var(iLookPARAM%Frad_vis)%dat(1))*mpar_data%var(iLookPARAM%albedoMaxVisible)%dat(1) + &
                                                                          (1._dp - mpar_data%var(iLookPARAM%Frad_vis)%dat(1))*mpar_data%var(iLookPARAM%albedoMaxNearIR)%dat(1)
     case default; err=20; message=trim(message)//'unable to identify option for snow albedo'; return
    end select  ! identify option for snow albedo
    ! set direct albedo to diffuse albedo
    diag_data%var(iLookDIAG%spectralSnowAlbedoDirect)%dat(:) = prog_data%var(iLookPROG%spectralSnowAlbedoDiffuse)%dat(:)
   end if  ! (if NOT using the Noah-MP radiation routine)

  end if  ! if creating a new layer

 ! end special case of nSnow=0
 ! ********************************************************************************************************************
 ! ********************************************************************************************************************

 ! ***** sub-divide snow layers, if necessary
 else ! if nSnow>0

  ! identify the number of layers to check for need for sub-division
  select case(ix_snowLayers)
   case(sameRulesAllLayers);    nCheck = nSnow
   case(rulesDependLayerIndex); nCheck = min(nSnow,4)  ! the depth of the 5th layer, if it exists, does not have a maximum value
   case default; err=20; message=trim(message)//'unable to identify option to combine/sub-divide snow layers'; return
  end select ! (option to combine/sub-divide snow layers)

  ! loop through all layers, and sub-divide a given layer, if necessary
  do iLayer=1,nCheck

   ! identify the maximum depth of the layer
   select case(ix_snowLayers)
    case(sameRulesAllLayers);    zmaxCheck = zmax
    case(rulesDependLayerIndex)
     if(iLayer == nSnow)then
      zmaxCheck = zmax_lower(iLayer)
     else
      zmaxCheck = zmax_upper(iLayer)
     end if
    case default; err=20; message=trim(message)//'unable to identify option to combine/sub-divide snow layers'; return
   end select ! (option to combine/sub-divide snow layers)

   ! check the need to sub-divide
   if(prog_data%var(iLookPROG%mLayerDepth)%dat(iLayer) > zmaxCheck)then

    ! flag that layers were divided
    divideLayer=.true.

    ! add a layer to all model variables
    call addModelLayer(prog_data,prog_meta,iLayer,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if
    call addModelLayer(diag_data,diag_meta,iLayer,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if
    call addModelLayer(flux_data,flux_meta,iLayer,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if
    call addModelLayer(indx_data,indx_meta,iLayer,err,cmessage); if(err/=0)then; message=trim(message)//trim(cmessage); return; end if

    ! define the layer depth
    layerSplit: associate(mLayerDepth => prog_data%var(iLookPROG%mLayerDepth)%dat)
    depthOriginal = mLayerDepth(iLayer)
    mLayerDepth(iLayer)   = fracTop*depthOriginal
    mLayerDepth(iLayer+1) = (1._dp - fracTop)*depthOriginal
    end associate layerSplit

    exit  ! NOTE: only sub-divide one layer per substep

   end if   ! (if sub-dividing layer)

  end do  ! (looping through layers)

 end if  ! if nSnow==0

 ! update coordinates
 if(divideLayer)then

  ! associate coordinate variables in data structure
  geometry: associate(&
  mLayerDepth      => prog_data%var(iLookPROG%mLayerDepth)%dat        ,& ! depth of the layer (m)
  mLayerHeight     => prog_data%var(iLookPROG%mLayerHeight)%dat       ,& ! height of the layer mid-point (m)
  iLayerHeight     => prog_data%var(iLookPROG%iLayerHeight)%dat       ,& ! height of the layer interface (m)
  layerType        => indx_data%var(iLookINDEX%layerType)%dat         ,& ! type of each layer (iname_snow or iname_soil)
  nSnow            => indx_data%var(iLookINDEX%nSnow)%dat(1)          ,& ! number of snow layers
  nSoil            => indx_data%var(iLookINDEX%nSoil)%dat(1)          ,& ! number of soil layers
  nLayers          => indx_data%var(iLookINDEX%nLayers)%dat(1)         & ! total number of layers
  )  ! (association of local variables with coordinate variab;es in data structures)

  ! update the layer type
  layerType(1:nSnow+1)         = iname_snow
  layerType(nSnow+2:nLayers+1) = iname_soil

  ! identify the number of snow and soil layers, and check all is a-OK
  nSnow   = count(layerType==iname_snow)
  nSoil   = count(layerType==iname_soil)
  nLayers = nSnow + nSoil

  ! re-set coordinate variables
  iLayerHeight(0) = -scalarSnowDepth
  do jLayer=1,nLayers
   iLayerHeight(jLayer) = iLayerHeight(jLayer-1) + mLayerDepth(jLayer)
   mLayerHeight(jLayer) = (iLayerHeight(jLayer-1) + iLayerHeight(jLayer))/2._dp
  end do

  ! check
  if(abs(sum(mLayerDepth(1:nSnow)) - scalarSnowDepth) > verySmall)then
   print*, 'nSnow = ', nSnow
   write(*,'(a,1x,f30.25,1x)') 'sum(mLayerDepth(1:nSnow)) = ', sum(mLayerDepth(1:nSnow))
   write(*,'(a,1x,f30.25,1x)') 'scalarSnowDepth           = ', scalarSnowDepth
   write(*,'(a,1x,f30.25,1x)') 'epsilon(scalarSnowDepth)  = ', epsilon(scalarSnowDepth)
   message=trim(message)//'sum of layer depths does not equal snow depth'
   err=20; return
  end if

  ! end association with coordinate variables in data structure
  end associate geometry

 end if  ! if dividing a layer

 ! end associate variables in data structure
 end associate

 end subroutine layerDivide

 ! ************************************************************************************************
 ! private subroutine addModelLayer: add an additional layer to all model vectors
 ! ************************************************************************************************
 subroutine addModelLayer(dataStruct,metaStruct,ix_divide,err,message)
 USE var_lookup,only:iLookVarType                  ! look up structure for variable typed
 USE get_ixName_module,only:get_varTypeName        ! to access type strings for error messages
 USE f2008funcs_module,only:cloneStruc             ! used to "clone" data structures -- temporary replacement of the intrinsic allocate(a, source=b)
 USE data_types,only:var_ilength,var_dlength       ! data vectors with variable length dimension
 USE data_types,only:var_info                      ! metadata structure
 implicit none
 ! ---------------------------------------------------------------------------------------------
 ! input/output: data structures
 class(*),intent(inout)          :: dataStruct     ! data structure
 type(var_info),intent(in)       :: metaStruct(:)  ! metadata structure
 ! input: snow layer indices
 integer(i4b),intent(in)         :: ix_divide      ! index of the layer to divide
 ! output: error control
 integer(i4b),intent(out)        :: err            ! error code
 character(*),intent(out)        :: message        ! error message
 ! ---------------------------------------------------------------------------------------------
 ! local variables
 integer(i4b)                    :: ivar           ! index of model variable
 integer(i4b)                    :: ix_lower       ! lower bound of the vector
 integer(i4b)                    :: ix_upper       ! upper bound of the vector
 logical(lgt)                    :: stateVariable  ! .true. if variable is a state variable
 real(dp),allocatable            :: tempVec_dp(:)  ! temporary vector (double precision)
 integer(i4b),allocatable        :: tempVec_i4b(:) ! temporary vector (integer)
 character(LEN=256)              :: cmessage       ! error message of downwind routine
 ! ---------------------------------------------------------------------------------------------
 ! initialize error control
 err=0; message='addModelLayer/'

 ! ***** add a layer to each model variable
 do ivar=1,size(metaStruct)

  ! define bounds
  select case(metaStruct(ivar)%vartype)
   case(iLookVarType%midSnow); ix_lower=1; ix_upper=nSnow
   case(iLookVarType%midToto); ix_lower=1; ix_upper=nLayers
   case(iLookVarType%ifcSnow); ix_lower=0; ix_upper=nSnow
   case(iLookVarType%ifcToto); ix_lower=0; ix_upper=nLayers
   case default; cycle
  end select

  ! identify whether it is a state variable
  select case(trim(metaStruct(ivar)%varname))
   case('mLayerDepth','mLayerTemp','mLayerVolFracIce','mLayerVolFracLiq'); stateVariable=.true.
   case default; stateVariable=.false.
  end select

  ! divide layers
  select type(dataStruct)

   ! ** double precision
   type is (var_dlength)
    ! check allocated
    if(.not.allocated(dataStruct%var(ivar)%dat))then; err=20; message='data vector is not allocated'; return; end if
    ! assign the data vector to the temporary vector
    call cloneStruc(tempVec_dp, ix_lower, source=dataStruct%var(ivar)%dat, err=err, message=cmessage)
    if(err/=0)then; message=trim(message)//trim(cmessage); return; end if
    ! reallocate space for the new vector
    deallocate(dataStruct%var(ivar)%dat,stat=err)
    if(err/=0)then; err=20; message='problem in attempt to deallocate memory for data vector'; return; end if
    allocate(dataStruct%var(ivar)%dat(ix_lower:ix_upper+1),stat=err)
    if(err/=0)then; err=20; message='problem in attempt to reallocate memory for data vector'; return; end if
    ! populate the state vector
    if(stateVariable)then
     if(ix_upper > 0)then  ! (only copy data if the vector exists -- can be a variable for snow, with no layers)
      if(ix_divide > 0)then
       dataStruct%var(ivar)%dat(1:ix_divide)            = tempVec_dp(1:ix_divide)  ! copy data
       dataStruct%var(ivar)%dat(ix_divide+1)            = tempVec_dp(ix_divide)    ! repeat data for the sub-divided layer
      end if
      if(ix_upper > ix_divide) &
       dataStruct%var(ivar)%dat(ix_divide+2:ix_upper+1) = tempVec_dp(ix_divide+1:ix_upper)  ! copy data
     end if  ! if the vector exists
    ! not a state variable
    else
     dataStruct%var(ivar)%dat(:) = missingDouble
    end if
    ! deallocate the temporary vector: strictly not necessary, but include to be safe
    deallocate(tempVec_dp,stat=err)
    if(err/=0)then; err=20; message='problem deallocating temporary data vector'; return; end if

   ! ** integer
   type is (var_ilength)
    ! check allocated
    if(.not.allocated(dataStruct%var(ivar)%dat))then; err=20; message='data vector is not allocated'; return; end if
    ! assign the data vector to the temporary vector
    call cloneStruc(tempVec_i4b, ix_lower, source=dataStruct%var(ivar)%dat, err=err, message=cmessage)
    if(err/=0)then; message=trim(message)//trim(cmessage); return; end if
    ! reallocate space for the new vector
    deallocate(dataStruct%var(ivar)%dat,stat=err)
    if(err/=0)then; err=20; message='problem in attempt to deallocate memory for data vector'; return; end if
    allocate(dataStruct%var(ivar)%dat(ix_lower:ix_upper+1),stat=err)
    if(err/=0)then; err=20; message='problem in attempt to reallocate memory for data vector'; return; end if
    ! populate the state vector
    if(stateVariable)then
     if(ix_upper > 0)then  ! (only copy data if the vector exists -- can be a variable for snow, with no layers)
      if(ix_divide > 0)then
       dataStruct%var(ivar)%dat(1:ix_divide)            = tempVec_i4b(1:ix_divide)  ! copy data
       dataStruct%var(ivar)%dat(ix_divide+1)            = tempVec_i4b(ix_divide)    ! repeat data for the sub-divided layer
      end if
      if(ix_upper > ix_divide) &
       dataStruct%var(ivar)%dat(ix_divide+2:ix_upper+1) = tempVec_i4b(ix_divide+1:ix_upper)  ! copy data
     end if  ! if the vector exists
    ! not a state variable
    else
     dataStruct%var(ivar)%dat(:) = missingInteger
    end if
    ! deallocate the temporary vector: strictly not necessary, but include to be safe
    deallocate(tempVec_i4b,stat=err)
    if(err/=0)then; err=20; message='problem deallocating temporary data vector'; return; end if

   ! check that we found the data type
   class default; err=20; message=trim(message)//'unable to identify the data type'; return

  end select ! dependence on data types

 end do  ! looping through variables

 end subroutine addModelLayer

end module layerDivide_module