! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
! H0 X
! H0 X   libAtoms+QUIP: atomistic simulation library
! H0 X
! H0 X   Portions of this code were written by
! H0 X     Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode,
! H0 X     Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield.
! H0 X
! H0 X   Copyright 2006-2010.
! H0 X
! H0 X   These portions of the source code are released under the GNU General
! H0 X   Public License, version 2, http://www.gnu.org/copyleft/gpl.html
! H0 X
! H0 X   If you would like to license the source code under different terms,
! H0 X   please contact Gabor Csanyi, gabor@csanyi.net
! H0 X
! H0 X   Portions of this code were written by Noam Bernstein as part of
! H0 X   his employment for the U.S. Government, and are not subject
! H0 X   to copyright in the USA.
! H0 X
! H0 X
! H0 X   When using this software, please cite the following reference:
! H0 X
! H0 X   http://www.libatoms.org
! H0 X
! H0 X  Additional contributions by
! H0 X    Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras
! H0 X
! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

!X
!X IPModel_BOP module
!X
!% Module for Bond-Order potential
!%
!X
!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
#include "error.inc"

module IPModel_BOP_module

use error_module
use system_module, only : dp, inoutput, print, PRINT_VERBOSE, PRINT_NERD, current_verbosity, initialise, OUTPUT, verbosity_push_decrement, verbosity_pop, operator(//)
use dictionary_module
use paramreader_module
use linearalgebra_module
use table_module
use atoms_types_module
use connection_module
use atoms_module
use clusters_module
use structures_module
use cinoutput_module

use mpi_context_module
use QUIP_Common_module

implicit none
private

include 'IPModel_interface.h'

public :: IPModel_BOP
type IPModel_BOP
  integer :: n_types = 0
  integer, allocatable :: atomic_num(:), type_of_atomic_num(:)

  real(dp) :: cutoff = 0.0_dp

  integer     ::  n
  type(Atoms) :: at
  integer, allocatable, dimension(:)  :: aptr
  integer, allocatable, dimension(:)  :: bptr
  integer     :: bptr_num

  character(len=STRING_LENGTH) :: label

end type IPModel_BOP

logical, private :: parse_in_ip, parse_matched_label
type(IPModel_BOP), private, pointer :: parse_ip

interface Initialise
  module procedure IPModel_BOP_Initialise_str
end interface Initialise

interface Finalise
  module procedure IPModel_BOP_Finalise
end interface Finalise

interface Print
  module procedure IPModel_BOP_Print, IPModel_BOP_Print_ptr
end interface Print

interface Calc
  module procedure IPModel_BOP_Calc
end interface Calc

contains

subroutine IPModel_BOP_Initialise_str(this, args_str, param_str)
  type(IPModel_BOP), intent(inout) :: this
  character(len=*), intent(in) :: args_str, param_str

  type(Dictionary) :: params

  call Finalise(this)

  call initialise(params)
  this%label=''
  call param_register(params, 'label', '', this%label, help_string="No help yet.  This source file was $LastChangedBy$")
  if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_BOP_Initialise_str args_str')) then
    call system_abort("IPModel_BOP_Initialise_str failed to parse label from args_str="//trim(args_str))
  endif
  call finalise(params)

  call IPModel_BOP_read_params_xml(this, param_str)

end subroutine IPModel_BOP_Initialise_str

subroutine IPModel_BOP_Finalise(this)
  type(IPModel_BOP), intent(inout) :: this

  if (allocated(this%atomic_num)) deallocate(this%atomic_num)
  if (allocated(this%type_of_atomic_num)) deallocate(this%type_of_atomic_num)

  this%n_types = 0
  this%label = ''
end subroutine IPModel_BOP_Finalise

! nat is the number of atoms whose energy and forces have to be computed with bop library
subroutine IPModel_BOP_Calc(this, at, e, local_e, f, virial, local_virial, args_str, mpi, error)
   type(IPModel_BOP), intent(inout):: this
   type(Atoms), intent(inout)      :: at   !Active + buffer atoms
   real(dp), intent(out), optional :: e, local_e(:)
   real(dp), intent(out), optional :: f(:,:), local_virial(:,:)   !% Forces, dimensioned as \texttt{f(3,at%N)}, local virials, dimensioned as \texttt{local_virial(9,at%N)}
   real(dp), intent(out), optional :: virial(3,3)
   character(len=*), optional      :: args_str
   type(MPI_Context), intent(in), optional :: mpi
   integer, intent(out), optional :: error

   real(dp), allocatable, dimension(:,:) :: f_bop
!   real(dp), allocatable, dimension(:)   :: local_e_bop
   integer, allocatable, dimension(:)    :: map_tobop
   type(Atoms)                     :: at_bop   !Active + buffer atoms
   type(Atoms)                     :: at_tmp
   real(dp)                        :: e_bop
   integer                         :: nat  !Number of active atoms, the first nat of at
   type(Dictionary)                :: params
   integer                         :: i, nreplicate_x, nreplicate_y, nreplicate_z
   logical                         :: lpbc, lreplicate_cell, lprint_xyz, lcrack,latoms
   integer, pointer, dimension(:)  :: map,map_bop, active, original_cell, hybrid
   real(dp), pointer, dimension(:,:):: forces_bop
!   real(dp), pointer, dimension(:) :: local_energy
   integer :: nsafe, natoms_active

   logical :: has_atom_mask_name
   character(STRING_LENGTH) :: atom_mask_name
   real(dp) :: r_scale, E_scale
   logical :: do_rescale_r, do_rescale_E

   INIT_ERROR(error)

   if (present(e)) e = 0.0_dp
   if (present(local_e)) then
      call check_size('Local_E',local_e,(/at%N/),'IPModel_BOP_Calc', error)
      local_e = 0.0_dp
   endif
   if (present(f)) then
      call check_size('Force',f,(/3,at%Nbuffer/),'IPModel_BOP_Calc', error)
      f = 0.0_dp
   end if
   if (present(virial)) virial = 0.0_dp
   if (present(local_virial)) then
      call check_size('Local_virial',local_virial,(/9,at%Nbuffer/),'IPModel_BOP_Calc', error)
      local_virial = 0.0_dp
      RAISE_ERROR("IPModel_BOP_Calc: local_virial calculation requested but not supported yet.", error)
   endif

   lpbc = .false.
   if (present(args_str)) then
     call initialise(params)
     call param_register(params, 'nat', '0', nat, help_string="No help yet.  This source file was $LastChangedBy$")
     call param_register(params, 'pbc', '.false.', lpbc, help_string="No help yet.  This source file was $LastChangedBy$")
     call param_register(params, 'replicate_x', '1', nreplicate_x, help_string="No help yet.  This source file was $LastChangedBy$")
     call param_register(params, 'replicate_y', '1', nreplicate_y, help_string="No help yet.  This source file was $LastChangedBy$")
     call param_register(params, 'replicate_z', '1', nreplicate_z, help_string="No help yet.  This source file was $LastChangedBy$")
     call param_register(params, 'print_xyz', 'F', lprint_xyz, help_string="No help yet.  This source file was $LastChangedBy$")
     call param_register(params, 'crack', 'F', lcrack, help_string="No help yet.  This source file was $LastChangedBy$")
     call param_register(params, 'all_atoms', 'F', latoms, help_string="No help yet.  This source file was $LastChangedBy$")
     call param_register(params, 'atom_mask_name', 'NONE', atom_mask_name, has_value_target=has_atom_mask_name, help_string="No help yet.  This source file was $LastChangedBy$")
     call param_register(params, 'r_scale', '1.0',r_scale, has_value_target=do_rescale_r, help_string="Recaling factor for distances. Default 1.0.")
     call param_register(params, 'E_scale', '1.0',E_scale, has_value_target=do_rescale_E, help_string="Recaling factor for energy. Default 1.0.")

     if (.not. param_read_line(params, args_str, ignore_unknown=.true.,task='IPModel_BOP_Calc args_str')) then
       call system_abort("IPModel_BOP_Calc failed to parse args_str='"//trim(args_str)//"'")
     endif
     call finalise(params)

     if(has_atom_mask_name) then
        RAISE_ERROR('IPModel_BOP_Calc: atom_mask_name found, but not supported', error)
     endif
     if (do_rescale_r .or. do_rescale_E) then
        RAISE_ERROR("IPModel_BOP_Calc: rescaling of potential with r_scale and E_scale not yet implemented!", error)
     end if

   else
     nat = 1
   endif

   if(latoms.and.lcrack) call system_abort('IPModel_BOP: all_atoms ' // latoms// " and crack " // lcrack)

   if(nat.eq.0) then
     if(lcrack) then
       if (.not. assign_pointer(at, 'hybrid', hybrid)) &
         call system_abort('IPModel_BOP: atoms structure is missing hybrid property')
       natoms_active = count(hybrid/=0)
       this%n = at%N
     elseif(latoms) then
       this%n = at%N
     else
       this%n = 1
     endif
   else
      this%n = nat
   endif

   lreplicate_cell = .false.
   if(nreplicate_x.ne.1.or.nreplicate_y.ne.1.or.nreplicate_z.ne.1) then
      lreplicate_cell = .true.
   endif

   if(lreplicate_cell.and.lpbc) then
        call system_abort("IPModel_BOP_Calc: or PBC or replicates the unit cell")
   endif

   at_tmp = at
   call add_property(at_tmp, 'map', 0)
   if (.not. assign_pointer(at_tmp, 'map', map)) &
       call system_abort('active pointer assignment failed')
   do i=1,at_tmp%N
      map(i) = i
   enddo

   if(lreplicate_cell) then
      nsafe = 1
      call print("Replicate cell : "//nreplicate_x//" "// nreplicate_y //" "// nreplicate_z, PRINT_NERD)
!      call supercell_minus_plus(at_bop, at_tmp, nreplicate_x, nsafe, nsafe)
!      call supercell_minus_plus(at_tmp, at_bop, nsafe, nreplicate_y, nsafe)
!      call supercell_minus_plus(at_bop, at_tmp, nsafe, nsafe,nreplicate_z)
      call supercell(at_bop, at_tmp, nreplicate_x, nsafe, nsafe)
      call supercell(at_tmp, at_bop, nsafe, nreplicate_y, nsafe)
      call supercell(at_bop, at_tmp, nsafe, nsafe,nreplicate_z)
   elseif(lpbc) then
      call print ("Periodic boundary condition applied", PRINT_NERD)
      call IPModel_BOP_compute_buffer(this,at,at_bop)
      at_bop = at_tmp
   else   ! no pbc
      at_bop = at_tmp
   endif
!  Assign map property for computing forces with BOP library
   if (.not. has_property(at_bop, 'map')) &
         call system_abort('IPModel_BOP: atoms structure has no "map" property')
   if (.not. assign_pointer(at_bop, 'map', map_bop)) &
         call system_abort('IPModel_BOP passed atoms structure with no map property')
   allocate(map_tobop(at_bop%N))
   map_tobop = map_bop

!  A vacuum region surrounding the cluster has to be applied before computing the connecting
   at_bop%lattice = at_bop%lattice * 3.0_dp
!  Cutoff set to the potential value in order to reduce the number of neighbours for the BOP library
   call set_cutoff(at_bop, this%cutoff)
!  Recompute connectivity
   call print('IPModel_BOP : cutoff used for connectivity' // at_bop%cutoff, PRINT_NERD)
   call set_lattice(at_bop,at_bop%lattice,scale_positions=.false., remap=.true.,reconnect=.true.)

!  Atoms to be passed to the Bop library
   this%at = at_bop

   if(this%n.gt.this%at%N) then
     call system_abort("IPModel_BOP_Calc: number of atoms for BOP library "// this%n // " > at%N = " // this%at%N)
   endif

   if (present(e)) e = 0.0_dp
   if (present(local_e)) then
      local_e = 0.0_dp
      if(size(local_e).gt.this%at%N) then
        call system_abort("IPModel_BOP_Calc: reallocate local_e to the right value = (" // this%n // ") !")
      endif
   endif
   if (present(f)) then
     f = 0.0_dp
     if(size(f,2).gt.this%at%N) then
        call system_abort("IPModel_BOP_Calc: reallocate f to the right value = (3," // this%n // ") !")
     endif
   endif
   if (present(virial)) virial = 0.0_dp

!  Compute the two pointer vectors required by the BOP library for the at_bop object
   call print('Computing pointers for BOP library', PRINT_NERD)
   call IPModel_BOP_Calc_ptr(this)

   if(allocated(f_bop)) deallocate(f_bop)
   allocate(f_bop(3,this%n))
!   if(allocated(local_e_bop)) deallocate(local_e_bop)
!   allocate(local_e_bop(this%n))
   f_bop = 0.0_dp
   e_bop = 0.0_dp

!  Compute forces and energy with BOP library
#ifdef HAVE_BOP
   call print('Calling BOP library : active atoms='// this%n// " on "//this%at%N )
   call system_timer('BOP')
   call bop(this%n,this%at%N,this%at%pos,this%aptr,this%bptr_num,this%bptr,map_tobop,e_bop,f_bop)
   call system_timer('BOP')
   call print('BOP energy : ' // e_bop)
#else
   call print('No BOP library!!!')
#endif

!  Print properties if print_xyz=T is passed in args_str
   if(lprint_xyz) then
     call add_property(at_bop, 'active', 0)
     if (.not. assign_pointer(at_bop, 'active', active)) &
         call system_abort('active pointer assignment failed')
     active(1:this%n) = 1
     call add_property(at_bop, 'original_cell', 0)
     if (.not. assign_pointer(at_bop, 'original_cell', original_cell)) &
         call system_abort('original_cell pointer assignment failed')
     original_cell(1:at%n) = 1
     call add_property(at_bop, 'forces_bop', 0.0_dp, n_cols=3)
     if (.not. assign_pointer(at_bop, 'forces_bop', forces_bop)) &
         call system_abort('forces_bop: failed to assign pointer to forces_bop')
     forces_bop(:,1:this%n) = f_bop(:,1:this%n)
!     call add_property(at_bop, 'local_energy', 0.0_dp)
!     if (.not. assign_pointer(at_bop, 'local_energy', local_energy)) &
!         call system_abort('local_energy: failed to assign pointer to local_bop')
!     local_energy(1:this%n) = local_e_bop(1:this%n)
     call write(at_bop, "bop_cell.xyz", properties='active:original_cell:map:forces_bop')
   endif

   if(present(f)) then
!     if (present(mpi)) call sum_in_place(mpi, f_bop)
     if(lcrack) then
       f(:,1:natoms_active) = f_bop(:,1:natoms_active)
     else
       f(:,1:this%n) = f_bop(:,1:this%n)
     endif
   endif
   if(present(e)) e = e_bop
!   if (present(mpi) .and. present(e)) e = sum(mpi, e_bop)
   call print('Energy computed with BOP library : ' // e_bop // " eV ",PRINT_NERD)
   if (present(mpi)) then
      if (present(local_e)) call sum_in_place(mpi, local_e)
   endif
   if(current_verbosity()  >= PRINT_NERD) then
     do i =1, this%n
       call print('Forces computed with BOP library on atom ' // i // " : " // f_bop(1,i) // " "// f_bop(2,i) // " " // f_bop(3,i) )
     enddo
   endif

   call finalise(at_bop)
   call finalise(at_tmp)

end subroutine IPModel_BOP_Calc

! compute aptr and bptr vectors required by the BOP library.
subroutine IPModel_BOP_Calc_ptr(this)
   type(IPModel_BOP), intent(inout) :: this
   integer                          :: nn, iat
   integer                          :: ik, k, itemp
   real(dp)                         :: rik

   if(allocated(this%aptr)) deallocate(this%aptr)
   allocate(this%aptr(this%at%N))
   if(allocated(this%bptr)) deallocate(this%bptr)
   nn = 0
   do iat = 1, this%at%N
     nn = nn + n_neighbours(this%at, iat) + 2
   enddo
   nn = nn + 1
   this%bptr_num = nn
   allocate(this%bptr(this%bptr_num))

   itemp =  -1000000
   nn = 0
   do iat = 1, this%at%N
      nn = nn + 1
      this%bptr(nn) = iat
      this%aptr(iat) = nn
      if(nn.ge.this%bptr_num) then
         call system_abort("IPModel_BOP_Calc_ptr: nn > this%bptr_num")
      endif
      do ik = 1, n_neighbours(this%at, iat)
         nn = nn + 1
         k = neighbour(this%at, iat, ik, rik)
         this%bptr(nn) = k
         if(nn.ge.this%bptr_num) then
           call system_abort("IPModel_BOP_Calc_ptr: nn > this%bptr_num")
         endif
      enddo
      nn = nn + 1
      this%bptr(nn) = itemp
      if(nn.ge.this%bptr_num) then
         call system_abort("IPModel_BOP_Calc_ptr: nn > this%bptr_num")
      endif
   enddo
   this%bptr(this%bptr_num) = 0
   if(current_verbosity()  >= PRINT_VERBOSE) then
     call print(this,this%aptr,this%bptr)
   endif

end subroutine IPModel_BOP_Calc_ptr

subroutine IPModel_BOP_Print(this, file)
  type(IPModel_BOP), intent(in) :: this
  type(Inoutput), intent(inout),optional :: file

  integer :: ti

  call Print("IPModel_BOP : Bond-Order-Potential", file=file)
  call Print("IPModel_BOP : n_types = " // this%n_types // " cutoff = " // this%cutoff, file=file)

  do ti=1, this%n_types
    call Print ("IPModel_BOP : type " // ti // " atomic_num " // this%atomic_num(ti), file=file)
    call verbosity_push_decrement()
    call Print ("IPModel_BOP : " // &
        "cutoff " // this%cutoff , &
         file=file)
    call verbosity_pop()
  end do

end subroutine IPModel_BOP_Print

subroutine IPModel_BOP_Print_ptr(this, aptr, bptr)
  type(IPModel_BOP), intent(in) :: this
  integer, intent(inout), dimension(:)  :: aptr
  integer, intent(inout), dimension(:)  :: bptr
  type(inoutput)   :: file_a
  type(inoutput)   :: file_b
  integer          :: i

  call print("Printing aptr and bptr")
  call initialise(file_a,'aptr.in', OUTPUT)
  call initialise(file_b,'bptr.in', OUTPUT)
  call print(this%at%N, file=file_a)
  do i = 1, this%at%N
    call print("  " // i // "    " // this%aptr(i), file=file_a)
  enddo
  call print(this%bptr_num, file=file_b)
  do i = 1, this%bptr_num
    call print("  " // i // "    " // this%bptr(i), file=file_b)
  enddo
  call finalise(file_a)
  call finalise(file_b)

end subroutine IPModel_BOP_Print_ptr

subroutine IPModel_BOP_read_params_xml(this, param_str)
  type(IPModel_BOP), intent(inout), target :: this
  character(len=*), intent(in) :: param_str

  type(xml_t) :: fxml

  if (len(trim(param_str)) <= 0) return

  parse_in_ip = .false.
  parse_matched_label = .false.
  parse_ip => this

  call open_xml_string(fxml, param_str)
  call parse(fxml,  &
    startElement_handler = IPModel_startElement_handler, &
    endElement_handler = IPModel_endElement_handler)
  call close_xml_t(fxml)

  if (this%n_types == 0) then
    call system_abort("IPModel_BOP_read_params_xml parsed file, but n_types = 0")
  endif

end subroutine IPModel_BOP_read_params_xml

!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
!X
!% XML param reader functions
!X
!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
subroutine IPModel_startElement_handler(URI, localname, name, attributes)
  character(len=*), intent(in)   :: URI
  character(len=*), intent(in)   :: localname
  character(len=*), intent(in)   :: name
  type(dictionary_t), intent(in) :: attributes

  integer :: status
  character(len=STRING_LENGTH) :: value

  integer ti

  if (name == 'BOP_params') then ! new BOP stanza

    if (parse_matched_label) return ! we already found an exact match for this label

    call QUIP_FoX_get_value(attributes, 'label', value, status)
    if (status /= 0) value = ''

    if (len(trim(parse_ip%label)) > 0) then ! we were passed in a label
      if (value == parse_ip%label) then ! exact match
        parse_matched_label = .true.
        parse_in_ip = .true.
      else ! no match
        parse_in_ip = .false.
      endif
    else ! no label passed in
      parse_in_ip = .true.
    endif

    if (parse_in_ip) then
      if (parse_ip%n_types /= 0) then
        call finalise(parse_ip)
      endif

      call QUIP_FoX_get_value(attributes, 'n_types', value, status)
      if (status == 0) then
        read (value, *) parse_ip%n_types
      else
        call system_abort("Can't find n_types in BOP_params")
      endif

      allocate(parse_ip%atomic_num(parse_ip%n_types))
      parse_ip%atomic_num = 0

      call QUIP_FoX_get_value(attributes, "cutoff", value, status)
      if (status /= 0) call system_abort ("IPModel_BOP_read_params_xml cannot find cutoff")
      read (value, *) parse_ip%cutoff
    endif

  elseif (parse_in_ip .and. name == 'per_type_data') then

    call QUIP_FoX_get_value(attributes, "type", value, status)
    if (status /= 0) call system_abort ("IPModel_BOP_read_params_xml cannot find type")
    read (value, *) ti

    call QUIP_FoX_get_value(attributes, "atomic_num", value, status)
    if (status /= 0) call system_abort ("IPModel_BOP_read_params_xml cannot find atomic_num")
    read (value, *) parse_ip%atomic_num(ti)

    if (allocated(parse_ip%type_of_atomic_num)) deallocate(parse_ip%type_of_atomic_num)
    allocate(parse_ip%type_of_atomic_num(maxval(parse_ip%atomic_num)))
    parse_ip%type_of_atomic_num = 0
    do ti=1, parse_ip%n_types
      if (parse_ip%atomic_num(ti) > 0) &
        parse_ip%type_of_atomic_num(parse_ip%atomic_num(ti)) = ti
    end do

  endif

end subroutine IPModel_startElement_handler

subroutine IPModel_endElement_handler(URI, localname, name)
  character(len=*), intent(in)   :: URI
  character(len=*), intent(in)   :: localname
  character(len=*), intent(in)   :: name

  if (parse_in_ip) then
    if (name == 'BOP_params') then
      parse_in_ip = .false.
    end if
  endif

end subroutine IPModel_endElement_handler

subroutine IPModel_BOP_compute_buffer(this,at,at_bop)
  type(IPModel_BOP), intent(inout):: this
  type(Atoms), intent(inout)  :: at
  type(Atoms), intent(inout) :: at_bop
  integer                  :: cellsNa,cellsNb,cellsNc, n_atom
  integer                  :: cellsNa2,cellsNb2,cellsNc2
  real(dp)                 :: cutoff
  integer                  :: i_atom, i, j, k
  type(table)              :: list

  cutoff = this%cutoff
  call print("calc_connect: cutoff calc_connect " // cutoff)
  cellsNa = at%connect%cellsNa
  cellsNb = at%connect%cellsNb
  cellsNc = at%connect%cellsNc
  cellsNa2 =  nint(real(cellsNa,dp) / 2.0_dp )
  cellsNb2 =  nint(real(cellsNb,dp) / 2.0_dp )
  cellsNc2 =  nint(real(cellsNc,dp) / 2.0_dp )
  call print("calc_connect: cells_N[abc] " // cellsNa // " " // cellsNb // " " // cellsNc)

  call calc_connect(at)

! pick an atom in the middle of the unit box
  i_atom = -1
  loop_c : do k = cellsNc2, cellsNc
    loop_b : do j = cellsNb2, cellsNb
       loop_a : do i = cellsNa2, cellsNa
!         n_atom =  at%connect%cell(i,j,k)%N
          n_atom = at%connect%cell_heads(i,j,k)
         if(n_atom.ne.0) then
!            i_atom = at%connect%cell(i,j,k)%int(1,1)
            i_atom = n_atom
            exit loop_c
         endif
       enddo  loop_a
    enddo  loop_b
  enddo loop_c
  if(i_atom == -1) call system_abort("IPModel_BOP_compute_buffer : no atom in the halved simulation cell")

  call append(list, (/i_atom,0,0,0/))
  call BFS_grow(at, list, 4)
  call print('---------------cluster--------------------', PRINT_NERD)
  call print(list, PRINT_NERD)
  call print('--------------end cluster-----------------', PRINT_NERD)

  call build_cluster(at, list, at_bop)

end subroutine IPModel_BOP_compute_buffer

subroutine  build_cluster(at, list, at_bop)
  type(Atoms), intent(inout) :: at
  type(Atoms), intent(inout) :: at_bop
  type(table)                :: list
  real(dp), dimension(3)     :: dist, rmax, length
  integer, dimension(3)      :: n_cell_rep
  integer                    :: iatom, jatom, i

  call print ('Number of atoms belonging to the cluster : ' // list%N )
  call print ('Cluster center atom                      : ' // list%int(1,1) )
  call print ('               shift                     : ' // list%int(2:4,1) )

! Find how many cells have to be added
  iatom = list%int(1,1)
  rmax = 0.0_dp
  do i = 2, list%N
    jatom = list%int(1,i)
    dist = abs( at%pos(:,iatom) -  pos_j(at, jatom, list%int(2:4,i)) )
    if(dist(1) .gt. rmax(1)) rmax(1) = dist(1)
    if(dist(2) .gt. rmax(2)) rmax(2) = dist(2)
    if(dist(3) .gt. rmax(3)) rmax(3) = dist(3)
  enddo
  length(1) = at%lattice(1,1) / real(at%connect%cellsNa,dp)
  length(2) = at%lattice(2,2) / real(at%connect%cellsNb,dp)
  length(3) = at%lattice(3,3) / real(at%connect%cellsNc,dp)

  n_cell_rep = int(rmax/length) + 1
  call print("Number of cell repeated along the three directions : " // n_cell_rep(1:3) )

! Add to the simulation cell the just computed number of cells
  call add_cells(at, n_cell_rep, at_bop)

end subroutine  build_cluster

subroutine add_cells(at, n_cell_rep, at_bop)
  type(Atoms), intent(inout) :: at
  type(Atoms), intent(inout) :: at_bop
  integer, dimension(3)      :: cells, n_cell_rep, periodicity
  integer                    :: i, j, k, ic, ic_right_p, ic_right_m, ii, iatom
  real(dp)                   :: pos(3), length

  cells(1) = at%connect%cellsNa
  cells(2) = at%connect%cellsNb
  cells(3) = at%connect%cellsNc

  at_bop = at
  do i = 1, 3    ! x, y, z
    if(n_cell_rep(i).eq.0) cycle  !skip this direction
    do ic = 1, n_cell_rep(i)
       ic_right_p = cells(i) - ic + 1 + int((ic - 1) / cells(i)) * cells(i)
       ic_right_m = ic - 1 - int((ic - 1) / cells(i)) * cells(i)

       periodicity    = 0
       periodicity(i) = int( (ic-1)/cells(i) + 1 )
       call print ("ic_right_p   " // ic_right_p  // "  ; ic    " // ic, PRINT_NERD)
       call print ("ic_right_m   " // ic_right_m  // "  ; ic    " // ic, PRINT_NERD)
       call print ("periodicity  " // periodicity, PRINT_NERD)

       if(i.eq.1) then
          do j = 1, cells(2)
           do k = 1, cells(3)
!            do ii = 1, at%connect%cell(ic_right_p,j,k)%N
!              iatom = at%connect%cell(ic_right_p,j,k)%int(1,ii)
              iatom = at%connect%cell_heads(ic_right_p,j,k)
             do while(iatom > 0)
              call print( j //" "// k // " atom : " // iatom // " " // cell_n(at%connect, ic_right_p,j,k))
              pos = at%pos(:,iatom) + real(periodicity,dp) * at%lattice(i,i)
              call add_atoms(at_bop, pos, at%Z(iatom))
              iatom = at%connect%next_atom_in_cell(iatom)
            enddo

!            do ii = 1, at%connect%cell(ic_right_m,j,k)%N
!              iatom = at%connect%cell(ic_right_m,j,k)%int(1,ii)
             iatom = at%connect%cell_heads(ic_right_m,j,k)
             do while (iatom > 0)
              call print( j //" "// k // " atom : " // iatom // " " // cell_n(at%connect, ic_right_m,j,k))
              pos = at%pos(:,iatom) + real(periodicity,dp) * at%lattice(i,i)
              call add_atoms(at_bop, pos, at%Z(iatom))
              iatom = at%connect%next_atom_in_cell(iatom)
             enddo
           enddo
          enddo
       elseif(i.eq.2) then

       elseif(i.eq.3) then

       endif

    enddo
    length = at%lattice(i,i) / cells(i)
    at_bop%lattice(i,i) = at_bop%lattice(i,i) + n_cell_rep(i) * length * 2.0_dp

  enddo

  stop

end subroutine add_cells

function pos_j(at, j, shift)
  type(Atoms), intent(inout) :: at
  real(dp), dimension(3)     :: pos_j
  integer,  dimension(3)     :: shift
  integer                    :: j

  pos_j = (at%lattice .mult. shift) + at%pos(:,j)

end function pos_j

!!$  subroutine supercell_minus_plus(aa, a, n1, n2, n3)
!!$    type(Atoms), intent(out)::aa  !% Output (big) cell
!!$    type(Atoms), intent(in)::a    !% Input cell
!!$    integer, intent(inout)::n1, n2, n3
!!$    real(dp)::lattice(3,3), p(3)
!!$    integer::i,j,k,n
!!$    type(Table) :: big_data
!!$    integer     :: nn1, n1save, n2save, n3save
!!$    integer, pointer, dimension(:)  :: map_new, map
!!$
!!$    n1save = n1
!!$    n2save = n2
!!$    n3save = n3
!!$    n1 = 2 * n1 - 1
!!$    n2 = 2 * n2 - 1
!!$    n3 = 2 * n3 - 1
!!$
!!$    call allocate(big_data,a%data%intsize,a%data%realsize,&
!!$         a%data%strsize, a%data%logicalsize, a%N*n1*n2*n3)
!!$
!!$    ! Replicate atomic data n1*n2*n3 times
!!$    do i=1,n1*n2*n3
!!$       call append(big_data,a%data)
!!$    end do
!!$
!!$    lattice(:,1) = a%lattice(:,1)*n1save
!!$    lattice(:,2) = a%lattice(:,2)*n2save
!!$    lattice(:,3) = a%lattice(:,3)*n3save
!!$    call atoms_initialise(aa, a%N*n1*n2*n3, lattice, data=big_data, properties=a%properties)
!!$    if (a%use_uniform_cutoff) then
!!$       call set_cutoff(aa, a%cutoff)
!!$    else
!!$       call set_cutoff_factor(aa, a%cutoff)
!!$    end if
!!$
!!$   if (.not. assign_pointer(a, 'map', map)) &
!!$       call system_abort('active pointer assignment failed')
!!$   if (.not. assign_pointer(aa, 'map', map_new)) &
!!$       call system_abort('active pointer assignment failed')
!!$
!!$    nn1 = 0
!!$    do i = 0,n1save-1
!!$       do j = 0,n2save-1
!!$          do k = 0,n3save-1
!!$             p = a%lattice .mult. (/i,j,k/)
!!$             do n = 1,a%N
!!$                ! overwrite position with shifted pos
!!$                nn1 = nn1 +  1
!!$                aa%pos(:,nn1) = a%pos(:,n)+p
!!$                map_new(nn1) = map(n)
!!$             end do
!!$             if(i.eq.0.and.j.eq.0.and.k.eq.0) cycle
!!$             do n = 1,a%N
!!$                ! overwrite position with shifted pos
!!$                nn1 = nn1 +  1
!!$                aa%pos(:,nn1) = a%pos(:,n)-p
!!$                map_new(nn1) = map(n)
!!$             end do
!!$          end do
!!$       end do
!!$    end do
!!$
!!$    call finalise(big_data)
!!$
!!$  end subroutine supercell_minus_plus

end module IPModel_BOP_module


!> Module container for `AbstractBedSedimentLayer` abstract superclass
module AbstractBedSedimentLayerModule
    use Globals
    use ResultModule, only: Result, Result0D                        ! error handling classes, required for
    use ErrorInstanceModule                                         ! generation of trace error messages
    use FineSedimentModule                                          ! USEs all subclasses of FineSediment
    implicit none                                                   ! force declaration of all variables

    !> Abstract superclass definition for `BedSedimentLayer`
    !! defines the properties and methods shared by all `BedSedimentLayer` objects
    !! objects of this class cannot be instantiated, only objects of its subclasses
    type, abstract, public :: AbstractBedSedimentLayer
        character(len=256) :: name                                  !! A name for the object
        integer :: l                                                !! Index of this layer. 1-based, so 1 is the top-most layer.
        real(dp), allocatable :: C_f_l(:)                           !! Capacity for fine sediment [m3 m-2]
        real(dp), allocatable :: C_w_l(:)                           !! Capacity for water [m3 m-2]
        type(FineSediment), allocatable :: colFineSediment(:)       !! Collection of `FineSediment` objects
        real(dp) :: C_total                                         !! Total capacity [m3 m-2]
        real(dp) :: V_c                                             !! Coarse material volume [m3 m-2]
        real(dp), allocatable :: pd_comp(:)                         !! Particle densities of sediment components [kg m-3]
        integer :: nSizeClasses                                     !! Number of sediment size classes
        integer :: nfComp                                           !! Number of fractional composition terms for sediment
    contains
                                                                    ! non-deferred methods: defined here. Can be overwritten in subclasses
        procedure, public :: A_f => GetAf                           ! available capacity for a fine sediment size fraction
        procedure, public :: A_w => GetAw                           ! available capacity for water associated with a fine sediment size fraction
        procedure, public :: C_f => GetCf                           ! return total capacity for a fine sediment size fraction
        procedure, public :: C_w => GetCw                           ! return total capacity for water associated with a fine sediment size fraction
        procedure, public :: volSLR => GetvolSLR                    ! return volumetric solid:liquid ratio for this layer; applies to all size classes
        procedure, public :: C_f_layer => GetCflayer                ! return total fine sediment capacity in the layer
        procedure, public :: M_f_layer => GetMflayer                ! return total fine sediment mass in the layer
        procedure, public :: V_f_layer => GetVflayer                ! return total fine sediment volume in the layer
        procedure, public :: V_w_layer => GetVwlayer                ! return total water volume in the layer
        procedure, public :: C_w_layer => GetCwlayer                ! return total water capacity in the layer
        procedure, public :: V_m_layer => GetVmlayer                ! return total fine sediment and water volume in the layer
        procedure, public :: V_layer => GetVlayer                   ! return sum of fine sediment, water and coarse material volumes in the layer
        ! procedure, public :: clearAll => clearAllBedSedimentLayer   ! clear all sediment and water in the layer
                                                                    ! deferred methods: must be defined in all subclasses
        procedure(createAbstractBedSedimentLayer), public, deferred :: &
        create                                                      ! constructor method
        procedure(destroyAbstractBedSedimentLayer), public, deferred :: &
        destroy                                                     ! finaliser method
        procedure(AddSedimentToLayer), public, deferred :: &
        AddSediment                                                 ! add fine sediment to the layer, outputting via intent(inout)
        procedure(RemoveSedimentFromLayer), public, deferred :: &
        RemoveSediment                                              ! remove fine sediment from layer, outputting via intent(inout)
        procedure(clearAllFromLayer), public, deferred :: clearAll  ! set all fine sediment masses, all water volume and all fractional compositions to zero
        procedure(ReportMassesToConsole), public, deferred :: &
            repmass                                                 ! report all fine sediment masses to the console
    end type
    abstract interface
        !> **Function purpose**

        !! Initialise a `AbstractBedSedimentLayer` object and its constituent
        !! `FineSediment` objects
        !!

        !!
sets number of particle size classes

        !!
reads in fixed layer volume

        !!
reads in masses of fine sediment in each size class

        !!
sets associated water volume for each size class

        !!
sets volume of coarse material

        !!

        !!

        !! **Function inputs**

        !! `layerGroup (NcGroup)` reference to the group holding this layer's data in the
        !!                        netCDF input file
        !!

        !! **Function outputs/outcomes**

        !! No specific outputs: results are initialisation of variables and objects
        function createAbstractBedSedimentLayer(Me, l) result(r)
            use ResultModule, only: Result
            import AbstractBedSedimentLayer, NcGroup
            class(AbstractBedSedimentLayer) :: Me                           !! The `AbstractBedSedimentLayer` instance
            integer :: l                                            !! Index for this bed sediment layer
            type(Result) :: r                                       !! The `Result` object.
        end function
        !> **Function purpose**

        !! Deallocate all allocated variables in this object.
        !!

        !! **Function outputs/outcomes**

        !! All allocated variables deallocated
        function destroyAbstractBedSedimentLayer(Me) result (r)
            use ResultModule, only: Result
            import AbstractBedSedimentLayer
            class(AbstractBedSedimentLayer) :: Me                            !! The `AbstractBedSedimentLayer` instance
            type(Result) :: r                                        !! The `Result` object
        end function
        !> **Function purpose**
        !!  Add fine sediment of a specified size fraction, and associated water,
        !!  to a bed sediment layer
        !!
        !! **Function inputs**
        !! `S (integer)`:       the size class to which sediment is to be added
        !! `F (FineSediment)`: object representing the FineSediment to be added
        !!
        !! **Function outputs/outcomes**
        !! `F (FineSediment)`: Returns the amounts of sediment and water that could not be added
        function addSedimentToLayer(Me, S, F) result(r)
            use ResultModule, only: Result, Result0D
            import AbstractBedSedimentLayer, FineSediment
            class(AbstractBedSedimentLayer) :: Me                            !! The `AbstractBedSedimentLayer` instance
            integer, intent(in) :: S                                 !! The particle size class
            type(FineSediment), intent(inout) :: F                  !! `FineSediment` - holds material to be added, returns material that could not be added
            type(Result) :: r                                        !! The `Result` object. Return data type = `FineSediment`
        end function

        !> **Function purpose**
        !! ALTERNATIVE REMOVESEDIMENT
        !! Remove sediment of a specified size fraction, and associated water,
        !! from a bed sediment layer
        !!
        !! **Function inputs**
        !! `S (integer)`:       the size class from which sediment is to be removed
        !! `G (FineSediment)`: sediment to be removed
        !!
        !! **Function outputs/outcomes**
        !! in this laternative version, both objects returned via inout
        !! `G (FineSediment)` returns the sediment that could not be removed
        !! `H (FineSediment)` returns the sediment that was removed
        function RemoveSedimentFromLayer(Me, S, G, H) result(r)
            use ResultModule, only: Result
            use Globals, only: dp
            import AbstractBedSedimentLayer, FineSediment
            class(AbstractBedSedimentLayer) :: Me                            !! The `AbstractBedSedimentLayer` instance
            integer, intent(in) :: S                                 !! The particle size class
            type(FineSediment), intent(inout) :: G                  !! Fine sediment to be removed, returns fine sediment that could not be removed
            type(FineSediment), intent(inout) :: H                  !! Returns fine sediment that was removed
            type(Result) :: r                                        !! The Result object = fine sediment that was removed AND fine sediment that could not be removed
        end function
        !> **Subroutine purpose**

        !! Remove sediment of a specified size fraction, and associated water,
        !! from a bed sediment layer
        !!

        !! **Subroutine inputs**

        !! `S (integer)`: the size class from which sediment is to be removed

        !! `G (FineSediment)`: sediment to be removed
        !!

        !! **Subroutine outcomes**

        !! Values of sediment mass, water volume and fractional composition set to zero
        !! for all sediments in this layer
        subroutine clearAllFromLayer(Me)
            import AbstractBedSedimentLayer
            class(AbstractBedSedimentLayer) :: Me                            !! This `AbstractBedSedimentLayer` object
        end subroutine
        !> **Function purpose**
        !! 1. Report the mass of fine sediment in each size fraction to the console
        !! 2. report the total mass of fine sediment in the layer to the console
        !!
        !! **Function inputs**
        !! none
        !!
        !! **Function outputs/outcomes**
        !!
        subroutine ReportMassesToConsole(Me)
            import AbstractBedSedimentLayer
            class(AbstractBedSedimentLayer) :: Me                            !! The `AbstractBedSedimentLayer` instance
            integer :: n                                             !! LOCAL loop counter
        end subroutine
    end interface
  contains
        !> **Function purpose**

        !! Return the available capacity for fine sediment of a specified size class
        !!

        !! **Function inputs**

        !! `S (integer)`: The size class
        !!

        !! **Function outputs/outcomes**

        !! `r (Result0D)` returns the result

        !! `r` returns critical error 103 if `A_f < 0`
        function GetAf(Me, s) result(A_f)
            class(AbstractBedSedimentLayer), intent(in) :: Me                !! the AbstractBedSedimentLayer instance
            integer, intent(in) :: s                                 !! size class for which to retrieve available capacity
            real(dp) :: A_f                                          !  LOCAL internal storage
            A_f = Me%C_f_l(s) - Me%colFineSediment(s)%V_f()          ! compute capacity
        end function
        !> **Function purpose**

        !! return the available capacity for water associated with a specified size class
        !!
        !! **Function inputs**

        !! `S (integer)`: the size class
        !!

        !! **Function outputs/outcomes**

        !! `r (Result0D)`: returns the result

        !! `r` returns critical error 103 if `A_w < 0`
        function GetAw(Me, s) result(A_w)
            class(AbstractBedSedimentLayer), intent(in) :: Me                !! The `AbstractBedSedimentLayer` instance
            integer, intent(in) :: s                                 !! Size class for which to retrieve available capacity
            ! type(Result0D) :: r                                      !! Return value
            real(dp) :: A_w                                          ! LOCAL internal storage
            A_w = Me%C_w_l(s) - Me%colFineSediment(s)%V_w()          ! compute capacity
        end function
        !> **Function purpose**

        !! Return the total capacity for fine sediment of a specified size class
        !!

        !! **Function inputs**

        !! `S (integer)`: the size class
        !!

        !! **Function outputs/outcomes**

        !! `r (Result0D)`: returns the result

        !! `r` returns critical error 103 if `C_f < 0`
        function GetCf(Me, s) result(C_f)
            class(AbstractBedSedimentLayer), intent(in) :: Me                !! The `AbstractBedSedimentLayer` instance
            integer, intent(in) :: s                                 !! Size class for which to retrieve available capacity
            ! type(Result0D) :: r                                      !! Return value
            real(dp) :: C_f                                          ! LOCAL internal storage
            C_f = Me%C_f_l(s)                                        ! compute capacity
        end function
        !> **Function purpose**

        !! Return the total capacity for water associated with fine sediment of a
        !! specified size class
        !!
        !! Function inputs

        !! `S (integer)`: the size class
        !!
        !! Function outputs/outcomes

        !! `r (Result0D)` returns the result

        !! `r` returns critical error 103 if `C_w < 0`
        function GetCw(Me, s) result(C_w)
            class(AbstractBedSedimentLayer), intent(in) :: Me                !! The `AbstractBedSedimentLayer` instance
            integer, intent(in) :: s                                 !! Size class for which to retrieve capacity
            ! type(Result0D) :: r                                      !! Return value
            real(dp) :: C_w                                          ! LOCAL internal storage
            C_w = Me%C_w_l(s)                                        ! compute capacity
        end function
        !> **Function purpose**

        !! Return the volumetric solid:liquid ratio for the layer
        !!

        !! **Function inputs**

        !! `S (integer)`: the size class
        !!

        !! **Function outputs/outcomes**

        !! `r (Result0D)` returns the result

        !! `r` returns critical error if ratio cannot be computed
        function GetvolSLR(Me, S) result(volSLR)
            class(AbstractBedSedimentLayer), intent(in) :: Me                !! The `AbstractBedSedimentLayer` instance
            integer :: S                                             !! size class for which volumetric SLR is to be computed
            real(dp) :: volSLR                                       ! LOCAL internal storage
            volSLR = Me%C_f_l(S) / Me%C_w_l(S)                   ! compute ratio
        end function

        !> Return the sediment mass in the layer across all size fractions
        function GetMflayer(me) result(Mf_layer)
            class(AbstractBedSedimentLayer), intent(in) :: me                !! The `AbstractBedSedimentLayer` instance
            real(dp) :: Mf_layer                                     !! Sediment mass in this layer
            integer :: i                                             ! Iterator over SPM size classes
            Mf_layer = 0
            do i = 1, me%nSizeClasses
                Mf_layer = Mf_layer + Me%colFineSediment(i)%M_f_l
            end do
        end function

        !> **Function purpose**

        !! Return the sediment capacity in the layer across all size fractions
        !!

        !! **Function inputs**

        !! `S (integer)`: the size class
        !!

        !! **Function outputs/outcomes**

        !! `r (Result0D)` returns the result
        function GetCflayer(Me) result(Cf_layer)
            class(AbstractBedSedimentLayer), intent(in) :: Me                !! The `AbstractBedSedimentLayer` instance
            ! type(Result0D) :: r                                      !! Return value
            real(dp) :: Cf_layer                                     ! LOCAL internal storage
            integer :: S                                             ! LOCAL loop counter
            Cf_layer = 0
            do S = 1, Me%nSizeClasses
                Cf_layer = Cf_layer + Me%C_f(S)                 ! sum across all size classes
            end do
            ! r = Result(data = Cf_layer)
        end function
        !> **Function purpose**

        !! Return the sediment volume in the layer across all size fractions
        !!

        !! **Function inputs**

        !! `S (integer)`: the size class
        !!

        !! **Function outputs/outcomes**

        !! `r (Result0D)` returns the result
        function GetVflayer(Me) result(Vf_layer)
            class(AbstractBedSedimentLayer), intent(in) :: Me                !! The `AbstractBedSedimentLayer` instance
            ! type(Result0D) :: r                                      !! Return value
            real(dp) :: Vf_layer                                     ! LOCAL internal storage
            integer :: S                                             ! LOCAL loop counter
            Vf_layer = 0                                             ! initialise local variable
            do S = 1, Me%nSizeClasses
                Vf_layer = Vf_layer + Me%colFineSediment(S)%V_f()              ! sum across all size classes
            end do
            ! r = Result(data = Vf_layer)
        end function
        !> **Function purpose**

        !! Return the water volume in the layer across all sediment size fractions
        !!

        !! **Function inputs**
        !! `S (integer)`: the size class
        !!

        !! **Function outputs/outcomes**

        !! `r (Result0D)` returns the result
        function GetVwlayer(Me) result(Vw_layer)
            class(AbstractBedSedimentLayer), intent(in) :: Me                !! The `AbstractBedSedimentLayer` instance
            ! type(Result0D) :: r                                      !! Return value
            real(dp) :: Vw_layer                                     ! LOCAL internal storage
            integer :: S                                             ! LOCAL loop counter
            Vw_layer = 0
            do S = 1, Me%nSizeClasses
                Vw_layer = Vw_layer + Me%colFineSediment(S)%V_w()   ! sum across all size classes
            end do
            ! r = Result(data = Vw_layer)
        end function
        !> **Function purpose**

        !! Return the water capacity in the layer across all sediment size fractions
        !!

        !! **Function inputs**
        !! `S (integer)`: the size class
        !!

        !! **Function outputs/outcomes**

        !! `r (Result0D)` returns the result
        function GetCwlayer(Me) result(Cw_layer)
            class(AbstractBedSedimentLayer), intent(in) :: Me                !! The `AbstractBedSedimentLayer` instance
            ! type(Result0D) :: r                                      !! Return value
            real(dp) :: Cw_layer                                     ! LOCAL internal storage
            integer :: S                                             ! loop counter
            Cw_layer = 0
            do S = 1, Me%nSizeClasses
                Cw_layer = Cw_layer + Me%C_w_l(S)                    ! sum across all size classes
            end do
            ! r = Result(data = Cw_layer)
        end function
        !> **Function purpose**

        !! Return the fine sediment & water volume in the layer across all size fractions
        !!

        !! **Function inputs**

        !! `S (integer)`: the size class
        !!

        !! **Function outputs/outcomes**

        !! `r (Result0D)` returns the result
        function GetVmlayer(Me) result(Vm_layer)
            class(AbstractBedSedimentLayer), intent(in) :: Me                !! The `AbstractBedSedimentLayer` instance
            ! type(Result0D) :: r                                      !! Return value
            real(dp) :: Vm_layer                                     ! LOCAL internal storage
            integer :: S                                             ! loop counter
            Vm_layer = 0                                             ! initialise local variable
            do S = 1, Me%nSizeClasses
                Vm_layer = Vm_layer + &
                           Me%colFineSediment(S)%V_f() + &
                           Me%colFineSediment(S)%V_w()                ! sum across all size classes
            end do
            !  r = Result(data = Vm_layer)
        end function
        !> **Function purpose**

        !! Return the total volume of the layer
        !!

        !! **Function inputs**

        !! `S (integer)`: the size class
        !!

        !! Function outputs/outcomes

        !! `r (Result0D)` returns the result
        function GetVlayer(Me) result (V_layer)
            class(AbstractBedSedimentLayer), intent(in) :: Me                !! The `AbstractBedSedimentLayer` instance
            type(Result0D) :: r                                      !! Return value
            real(dp) :: V_layer                                      ! LOCAL internal storage
            integer :: S                                             ! loop counter
            V_layer = Me%V_c                                         ! start by adding coarse material volume
            do S = 1, Me%nSizeClasses
                V_layer = V_layer + &
                          Me%colFineSediment(S)%V_f() + &
                          Me%colFineSediment(S)%V_w()                ! sum across all size classes
            end do
              r = Result(data = V_layer)
        end function
end module


      subroutine channel_control

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine simulates channel routing

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    bankst(:)   |m^3 H2O       |bank storage
!!    inum1       |none          |reach number
!!    inum2       |none          |inflow hydrograph storage location number
!!    pet_ch      |mm H2O        |potential evapotranspiration on day
!!    rchdep      |m             |depth of flow on day
!!    rttlc       |m^3 H2O       |transmission losses from reach on day
!!    rtwtr       |m^3 H2O       |water leaving reach on day
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    revapday    |m^3 H2O       |amount of water moving from bank storage
!!                               |into the soil profile or being taken
!!                               |up by plant roots in the bank storage zone
!!    rtwtr       |m^3 H2O       |water leaving reach on day
!!    qdbank      |m^3 H2O       |streamflow contribution from bank storage
!!    sedrch      |metric tons   |sediment transported out of reach on day
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ii          |none          |counter
!!    jrch        |none          |reach number
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Min
!!    SWAT: rchinit, rtover, rtday, rtmusk, rthourly, rtsed, rthsed, watqual
!!    SWAT: noqual, hhwatqual, hhnoqual, rtpest, rthpest
!!    SWAT: rchuse, reachout

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use climate_module
      use hydrograph_module
      use basin_module
      use channel_data_module
      use time_module
      use channel_module
      use constituent_mass_module

      implicit none

      integer :: ii       !units         |description
      real :: qdbank      !m^3 H2O       |streamflow contribution from bank storage
      real :: revapday    !m^3 H2O       |amount of water moving from bank storage
                          !              |into the soil profile or being taken
                          !              |up by plant roots in the bank storage zone
      real :: sedcon      !g/m^3         |sediment concentration
      real :: reactw      !mg pst        |amount of pesticide in reach that is lost
                          !              |through reactions
      real :: volatpst    !mg pst        |amount of pesticide lost from reach by
                          !              |volatilization
      real :: setlpst     !mg pst        |amount of pesticide moving from water to
                          !              |sediment due to settling
      real :: resuspst    !mg pst        |amount of pesticide moving from sediment to
                          !              |reach due to resuspension
      real :: difus       !mg pst        |diffusion of pesticide from sediment to reach
      real :: reactb      !mg pst        |amount of pesticide in sediment that is lost
                          !              |through reactions
                          !              |up by plant roots in the bank storage zone
      real :: bury        !mg pst        |loss of pesticide from active sediment layer
                          !              |by burial
      real :: sedpest     !mg pst        |pesticide in river bed sediment
      real :: soxy             !mg O2/L       |saturation concetration of dissolved oxygen
      real :: chlin            !mg chl-a/L    |chlorophyll-a concentration in inflow
      real :: algin            !mg alg/L      |algal biomass concentration in inflow
      real :: orgnin           !mg N/L        |organic N concentration in inflow
      real :: ammoin           !mg N/L        |ammonium N concentration in inflow
      real :: nitratin         !mg N/L        |nitrate concentration in inflow
      real :: nitritin         !mg N/L        |nitrite concentration in inflow
      real :: orgpin           !mg P/L        |organic P concentration in inflow
      real :: dispin           !mg P/L        |soluble P concentration in inflow
      real :: cbodin           !mg/L          |carbonaceous biological oxygen demand
      real :: disoxin          !mg O2/L       |dissolved oxygen concentration in inflow
      real :: cinn             !mg N/L        |effective available nitrogen concentration
      real :: rttlc_d
      real :: rtdelt
      real :: rtevp_d
      integer :: inum1

      ch_d(jrch)%flo_out = 0.
      ch_d(jrch)%evap = 0.
      jhyd = ch_dat(jrch)%hyd
      jsed = ch_dat(jrch)%sed
      jnut = ch_dat(jrch)%nut

      iwst = ob(icmd)%wst
      pet_ch = wst(iwst)%weat%pet
      qdbank = 0.
      revapday = 0.

      !! initialize variables for route command loop
      call ch_rchinit

      !! zero flow out variables
      ob(icmd)%hd(1) = hz
      if (time%step > 0) then
        do ii = 1, time%step
          ob(icmd)%ts(1,ii) = hz
        end do
      end if

      ch(jrch)%vel_chan = 0.
      ch(jrch)%dep_chan = 0.
	  sedrch = 0.
	  rch_san = 0.
	  rch_sil = 0.
	  rch_cla = 0.
	  rch_sag = 0.
	  rch_lag = 0.
	  rch_gra = 0.
      wtrin = 0.
      chlin = 0.
         algin = 0.
         orgnin = 0.
         ammoin = 0.
         nitritin = 0.
         nitratin = 0.
         orgpin = 0.
         dispin = 0.
         cbodin = 0.
         disoxin = 0.
         cinn = 0.
!! route water through reach
        rtwtr_d=0.
        rttlc_d=0.
        rtevp_d =0.

!! route water through reach
      if (time%step == 0) then
          rt_delt = 1.
        wtrin = ob(icmd)%hin%flo
        if ( ob(icmd)%hin%flo > 0.001) then
         chlin = 1000. * ob(icmd)%hin%chla * rt_delt / wtrin
         algin = 1000. * chlin / ch_nut(jnut)%ai0        !! QUAL2E equation III-1
         orgnin = 1000. * ob(icmd)%hin%orgn  *rt_delt/ wtrin
         ammoin = 1000. * ob(icmd)%hin%nh3 * rt_delt / wtrin
         nitritin = 1000. * ob(icmd)%hin%no2 * rt_delt / wtrin
         nitratin = 1000. * ob(icmd)%hin%no3 * rt_delt  / wtrin
         orgpin = 1000. * ob(icmd)%hin%sedp *rt_delt / wtrin
         dispin = 1000. * ob(icmd)%hin%solp* rt_delt  / wtrin
         cbodin = 1000. * ob(icmd)%hin%cbod * rt_delt / wtrin
         disoxin = 1000. * ob(icmd)%hin%dox  * rt_delt / wtrin
        end if

!! initialize inflow concentrations

        if (bsn_cc%rte == 0) call ch_rtday
        if (bsn_cc%rte == 1) call ch_rtmusk

        ben_area = ch_hyd(jhyd)%l *ch_hyd(jhyd)%w
        if (bsn_cc%wq == 1)  call ch_watqual3

        ob(icmd)%hd(1)%orgn = ch(jrch)%organicn * rtwtr /1000.
        ob(icmd)%hd(1)%sedp = ch(jrch)%organicp * rtwtr /1000.
        ob(icmd)%hd(1)%no3 = ch(jrch)%nitraten * rtwtr / 1000.
        ob(icmd)%hd(1)%solp = ch(jrch)%disolvp * rtwtr / 1000.
        ob(icmd)%hd(1)%chla = ch(jrch)%chlora * rtwtr / 1000.
        ob(icmd)%hd(1)%nh3 = ch(jrch)%ammonian * rtwtr / 1000.
        ob(icmd)%hd(1)%no2 = ch(jrch)%nitriten * rtwtr / 1000.
        ob(icmd)%hd(1)%cbod = ch(jrch)%rch_cbod *  rtwtr/ 1000.
        ob(icmd)%hd(1)%dox = ch(jrch)%rch_dox *  rtwtr/ 1000.

        if (ch_sed(jsed)%eqn == 0) call ch_rtsed
        if (ch_sed(jsed)%eqn == 1) call ch_rtsed_bagnold
        if (ch_sed(jsed)%eqn == 2) call ch_rtsed_kodatie
        if (ch_sed(jsed)%eqn == 3) call ch_rtsed_Molinas_Wu
        if (ch_sed(jsed)%eqn == 4) call ch_rtsed_yangsand

!        if (cs_db%num_pests > 0) then
!          call ch_rtpest
!        end if

        rtwtr_d = rtwtr
        rttlc_d = rttlc
        rtevp_d = rtevp
      else
        rt_delt = 1. / time%step
        wtrin = ob(icmd)%hin%flo * rt_delt
        if (ob(icmd)%hin%flo > 0.001) then
         chlin = 1000. * ob(icmd)%hin%chla * rt_delt / wtrin
         algin = 1000. * chlin / ch_nut(jnut)%ai0        !! QUAL2E equation III-1
         orgnin = 1000. * ob(icmd)%hin%orgn  * rt_delt/ wtrin
         ammoin = 1000. * ob(icmd)%hin%nh3 * rt_delt / wtrin
         nitritin = 1000. * ob(icmd)%hin%no2 * rt_delt / wtrin
         nitratin = 1000. * ob(icmd)%hin%no3 * rt_delt  / wtrin
         orgpin = 1000. * ob(icmd)%hin%sedp *rt_delt / wtrin
         dispin = 1000. * ob(icmd)%hin%solp * rt_delt  / wtrin
         cbodin = 1000. * ob(icmd)%hin%cbod * rt_delt / wtrin
         disoxin = 1000. * ob(icmd)%hin%dox  * rtdelt / wtrin
        end if

        rtwtr = 0.
        do ii = 1, time%step
        ! wtrin = ob(icmd)%ts(1,ii)%flo
        call ch_rtday
        if (bsn_cc%wq == 1)  call ch_watqual3
!        call ch_rthpest
               rtwtr_d=rtwtr_d+rtwtr
               rttlc_d=rttlc_d+ rttlc
               rtevp_d =rtevp_d+ rtevp

        ob(icmd)%hd(1)%orgn = ob(icmd)%hd(1)%orgn+ ch(jrch)%organicn  * rtwtr /1000.
        ob(icmd)%hd(1)%sedp = ob(icmd)%hd(1)%sedp + ch(jrch)%organicp * rtwtr /1000.
       ob(icmd)%hd(1)%no3 = ob(icmd)%hd(1)%no3+ ch(jrch)%nitraten * rtwtr / 1000.
       ob(icmd)%hd(1)%solp = ob(icmd)%hd(1)%solp+ ch(jrch)%disolvp * rtwtr / 1000.
       ob(icmd)%hd(1)%chla = ob(icmd)%hd(1)%chla + ch(jrch)%chlora * rtwtr / 1000.
       ob(icmd)%hd(1)%nh3 =  ob(icmd)%hd(1)%nh3+ ch(jrch)%ammonian * rtwtr / 1000.
       ob(icmd)%hd(1)%no2 = ob(icmd)%hd(1)%no2 + ch(jrch)%nitriten * rtwtr / 1000.
       ob(icmd)%hd(1)%cbod = ob(icmd)%hd(1)%cbod + ch(jrch)%rch_cbod *  rtwtr/ 1000.
       ob(icmd)%hd(1)%dox = ob(icmd)%hd(1)%dox + ch(jrch)%rch_dox *  rtwtr/ 1000.

!       hsedyld(ii) = ob(icmd)%ts(1,ii)%sed
!       sedrch = sedrch + hsedyld(ii)
        rch_san = 0.
!       rch_sil = rch_sil + hsedyld(ii)  !!All are assumed to be silt type particles
        rch_cla = 0.
        rch_sag = 0.
        rch_lag = 0.
        rch_gra = 0.
        call ch_rthsed

        end do

      endif

!! average daily water depth for sandi doty 09/26/07
      ch(jrch)%dep_chan = rchdep

!! add transmission losses to bank storage/deep aquifer in subbasin
      if (rttlc > 0.) then
        ch(jrch)%bankst = ch(jrch)%bankst + rttlc * (1.-bsn_prm%trnsrch)
!!!! Jeff add to hydrograph -----------------------------
        rchsep(jrch) = rttlc * bsn_prm%trnsrch
      end if

!! compute revap from bank storage
      revapday = 0.6 * pet_ch *ch_hyd(jhyd)%l *ch_hyd(jhyd)%w
      revapday = Min(revapday, ch(jrch)%bankst)
      ch(jrch)%bankst = ch(jrch)%bankst - revapday

!! compute contribution of water in bank storage to streamflow
      qdbank = ch(jrch)%bankst * (1. - ch_hyd(jhyd)%alpha_bnk)
      ch(jrch)%bankst = ch(jrch)%bankst - qdbank
      rtwtr_d = rtwtr_d + qdbank
      if (time%step > 0) then
        do ii = 1, time%step
          hrtwtr(ii) = hrtwtr(ii) + qdbank / real(time%step)
        end do
      end if

!! perform in-stream sediment calculations

!! perform in-stream pesticide calculations
!!      call ch_biofilm

!! perform in-stream pathogen calculations
      ! call ch_rtbact  dont merge

!! remove water from reach for consumptive water use
      call ch_rchuse

!! summarize output/determine loadings to next routing unit
      call ch_rtout

!   output_channel
      ch_d(jrch)%flo_in = ob(icmd)%hin%flo / 10000.     !m^3 -> ha-m
      ch_d(jrch)%flo_out = rtwtr_d / 10000.               !m^3 -> ha-m
      ch_d(jrch)%evap =rtevp_d / 10000.                  !m^3 -> ha-m
      ch_d(jrch)%tloss = rttlc_d / 10000.
      ch_d(jrch)%sed_in = ob(icmd)%hin%sed
      ch_d(jrch)%sed_out = sedrch
      ch_d(jrch)%sed_conc = sedrch / (ch_d(jrch)%flo_in + .01)
      ch_d(jrch)%orgn_in = ob(icmd)%hin%orgn
      ch_d(jrch)%orgn_out = ob(icmd)%hd(1)%orgn
      ch_d(jrch)%orgp_in = ob(icmd)%hin%sedp
      ch_d(jrch)%orgp_out = ob(icmd)%hd(1)%sedp
      ch_d(jrch)%no3_in = ob(icmd)%hin%no3
      ch_d(jrch)%no3_out = ob(icmd)%hd(1)%no3
      ch_d(jrch)%nh4_in = ob(icmd)%hin%nh3
      ch_d(jrch)%nh4_out = ob(icmd)%hd(1)%nh3
      ch_d(jrch)%no2_in = ob(icmd)%hin%no2
      ch_d(jrch)%no2_out = ob(icmd)%hd(1)%no2
      ch_d(jrch)%solp_in = ob(icmd)%hin%solp
      ch_d(jrch)%solp_out = ob(icmd)%hd(1)%solp
      ch_d(jrch)%chla_in = ob(icmd)%hin%chla
      ch_d(jrch)%chla_out = ob(icmd)%hd(1)%chla
      ch_d(jrch)%cbod_in = ob(icmd)%hin%cbod
      ch_d(jrch)%cbod_out = ob(icmd)%hd(1)%cbod
      ch_d(jrch)%dis_in = ob(icmd)%hin%dox
      ch_d(jrch)%dis_out = ob(icmd)%hd(1)%dox
      ch_d(jrch)%sand_in = ob(icmd)%hin%san
      ch_d(jrch)%sand_out = ob(icmd)%hd(1)%san
      ch_d(jrch)%silt_in = ob(icmd)%hin%sil
      ch_d(jrch)%silt_out = ob(icmd)%hd(1)%sil
      ch_d(jrch)%clay_in = ob(icmd)%hin%cla
      ch_d(jrch)%clay_out = ob(icmd)%hd(1)%cla
      ch_d(jrch)%smag_in = ob(icmd)%hin%sag
      ch_d(jrch)%smag_out = ob(icmd)%hd(1)%sag
      ch_d(jrch)%lag_in = ob(icmd)%hin%lag
      ch_d(jrch)%lag_out = ob(icmd)%hd(1)%lag
      ch_d(jrch)%grvl_in = ob(icmd)%hin%grv
      ch_d(jrch)%grvl_out = ob(icmd)%hd(1)%grv
      ch_d(jrch)%bnk_ero = bnkrte
      ch_d(jrch)%ch_deg = degrte
!!    Channel Deposition (Only new deposits during the current time step)
      if (ch(jrch)%depch >= ch(jrch)%depprch) then
	    ch_d(jrch)%ch_dep = ch(jrch)%depch - ch(jrch)%depprch
	  else
	    ch_d(jrch)%ch_dep = 0.
	  end if
!!    Floodplain Deposition (Only new deposits during the current time step)
      if (ch(jrch)%depfp >= ch(jrch)%depprfp) then
	    ch_d(jrch)%fp_dep = ch(jrch)%depfp - ch(jrch)%depprfp
	  else
	    ch_d(jrch)%fp_dep = 0.
	  end if
!!    Total suspended sediments (only silt and clay)
      if (ch_sed(jsed)%eqn == 0) then
        ch_d(jrch)%tot_ssed = sedrch
      else
        ch_d(jrch)%tot_ssed = rch_sil + rch_cla
      endif

      return

      end subroutine channel_control


cdis    Forecast Systems Laboratory
cdis    NOAA/OAR/ERL/FSL
cdis    325 Broadway
cdis    Boulder, CO     80303
cdis
cdis    Forecast Research Division
cdis    Local Analysis and Prediction Branch
cdis    LAPS
cdis
cdis    This software and its documentation are in the public domain and
cdis    are furnished "as is."  The United States government, its
cdis    instrumentalities, officers, employees, and agents make no
cdis    warranty, express or implied, as to the usefulness of the software
cdis    and documentation for any purpose.  They assume no responsibility
cdis    (1) for the use of the software and documentation; or (2) to provide
cdis     technical support to users.
cdis
cdis    Permission to use, copy, modify, and distribute this software is
cdis    hereby granted, provided that the entire disclaimer notice appears
cdis    in all copies.  All modifications to this software must be clearly
cdis    documented, and are solely the responsibility of the agent making
cdis    the modifications.  If significant modifications or enhancements
cdis    are made to this software, the FSL Software Policy Manager
cdis    (softwaremgr@fsl.noaa.gov) should be notified.
cdis
cdis
cdis
cdis
cdis
cdis
cdis

      subroutine get_sfm_1d(nll,zcb,zctop,ityp,zlevel,
     1               plevel,tlevel,ql,qi,prob,mode)
      dimension zlevel(nll),plevel(nll),tlevel(nll),
     1          ql(nll),prob(nll),calw(200),cali(200),qi(nll)
cc   --------------------------------------------------------------
cc
cc         this is the streamlined version of the Smith-Feddes
cc         and Temperature Adjusted LWC calculation methodologies
cc         produced at Purdue University under sponsorship
cc         by the FAA Technical Center
cc
cc         currently, this subroutine will only use the Smith-
cc         Feddes and will only do so as if there are solely
cc         stratiform clouds present, however, it is very easy
cc         to switch so that only the Temperature Adjusted
cc         method is used
cc
cc         dilution by glaciation is also included, it is a
cc         linear function of in cloud temperature going from
cc         all liquid water at -10 C to all ice at -30 C
cc         as such the amount of ice is also calculated
cc
cc   --------------------------------------------------------------
      real dz,rv,rair,grav,cp,rlvo,rlso,dlvdt,eso,c,a1,b1,c1,a2,b2,c2
      parameter(
     +   dz=100.0
     +,  rv=461.5
     +,  rair=287.04
     +,  grav=9.81
     +,  cp=1004.
     +,  rlvo=2.5003e+6
     +,  rlso=2.8339e+6
     +,  dlvdt=-2.3693e+3
     +,  eso=610.78
     +,  c=0.01
     +,  a1=8.4897
     +,  b1=-13.2191
     +,  c1=4.7295
     +,  a2=10.357
     +,  b2=-28.2416
     +,  c2=8.8846)

!     Set ramp going from liquid to ice
      if(ityp .eq. 3 .OR. ityp .eq. 10)then ! convective
        temp1_c = -10.
        temp2_c = -30.
      else
        temp1_c = -10. ! -00.
        temp2_c = -30. ! -05.
      endif

      temp1_k = c_to_k(temp1_c)
      temp2_k = c_to_k(temp2_c)

cc    -------------------------------------------------------------
cc
cc   calculate indices of cloud top and base
cc
cc   -------------------------------------------------------------
      nll_index = nll - 1
      do 100 ilevel=1,nll_index
        kcb = 0
        kctop = 0
        if(zlevel(ilevel).lt.zcb.and.
     1     zlevel(ilevel+1).gt.zcb) then
            kcb=ilevel
            kcb1=kcb+1
        endif
        if(zlevel(ilevel).lt.zctop.and.
     1     zlevel(ilevel+1).gt.zctop) then
            kctop=ilevel
            kctop1=kctop+1
        endif
100   continue

      if(kctop .eq. 0)then
        istatus = 0
        return
      endif
cc   -------------------------------------------------------------
cc
cc   obtain cloud base and top conditions
cc
cc   -------------------------------------------------------------
      delz=zlevel(kcb+1)-zlevel(kcb)
      delt=tlevel(kcb+1)-tlevel(kcb)
      cldbtm=delt*(zcb-zlevel(kcb))/delz+tlevel(kcb)
      tbar=(cldbtm+tlevel(kcb))/2.
      arg=-grav*(zcb-zlevel(kcb))/rair/tbar
      cldbp=plevel(kcb)*exp(arg)
      delz=zlevel(kctop+1)-zlevel(kctop)
      delt=tlevel(kctop+1)-tlevel(kctop)
      cldtpt=delt*(zctop-zlevel(kctop))/delz+tlevel(kctop)
cc   ---------------------------------------------------------------
cc
cc   calculate cloud lwc profile for cloud base/top pair
cc
cc   ---------------------------------------------------------------
        temp=cldbtm
        press=cldbp*100.0
        zbase=zcb
        nlevel=(zctop-zcb)/100.0
        if(nlevel.le.0) nlevel=1
        alw=0.0
        calw(1)=0.0
        nlm1=nlevel-1
        if(nlm1.lt.1) nlm1=1
        zht=zbase
        do 400 j=1,nlm1
          rl=rlvo+(273.15-temp)*dlvdt
          arg=rl*(temp-273.15)/273.15/temp/rv
          es=eso*exp(arg)
          qvs1=0.622*es/(press-es)
          rho1=press/(rair*temp)
          arg=-grav*dz/rair/temp
          p=press*exp(arg)
cc
cc   calculate saturated adiabatic lapse rate
cc
          des=es*rl/temp/temp/rv
          dtz=-grav*((1.0+0.621*es*rl/(press*rair*temp))/
     1        (cp+0.621*rl*des/press))
          zht=zht+dz
          press=p
          temp=temp+dtz*dz
          rl=rlvo+(273.15-temp)*dlvdt
          arg=rl*(temp-273.15)/273.15/temp/rv
          es2=eso*exp(arg)
          qvs2=0.622*es2/(press-es2)
          rho2=press/(rair*temp)
          alw=alw+(qvs1-qvs2)*(rho1+rho2)/2.
          calw(j+1)=alw
cc          write(6,9015) j,calw(j+1),zht
cc   ------------------------------------------------------------------
cc
cc   reduction of lwc by entrainment
cc
cc   ------------------------------------------------------------------
      ht=(zht-zbase)*.001
cc   ------------------------------------------------------------------
cc
cc                          skatskii's curve(convective)
cc
cc   ------------------------------------------------------------------
cc    if(ht.lt.0.3) then
cc      y=-1.667*(ht-0.6)
cc    elseif(ht.lt.1.0) then
cc      arg1=b1*b1-4.0*a1*(c1-ht)
cc      y=(-b1-sqrt(arg1))/(2.0*a1)
cc    elseif(ht.lt.2.9) then
cc      arg2=b2*b2-4.0*a2*(c2-ht)
cc      y=(-b2-sqrt(arg2))/(2.0*a2)
cc    else
cc      y=0.26
cc    endif
cc   ------------------------------------------------------------------
cc
cc                         warner's curve(stratiform)
cc
cc   ------------------------------------------------------------------
      if(ht.lt.0.032) then
        y=-11.0*ht+1.0
      elseif(ht.le.0.177) then
        y=-1.4*ht+0.6915
      elseif(ht.le.0.726) then
        y=-0.356*ht+0.505
      elseif(ht.le.1.5) then
        y=-0.0608*ht+0.2912
      else
        y=0.20
      endif
cc   -----------------------------------------------------------------
cc
cc                 calculate reduced lwc by entrainment
cc                             and dilution
cc
cc   -----------------------------------------------------------------
          ffrac=1.0
          if(temp.lt.temp1_k) then
            if(temp.gt.temp2_k) then
              ffrac=(temp-temp2_k)/(temp1_k-temp2_k)
            else
              ffrac=0.0
            endif
          endif
          if(ffrac.lt.0.0) ffrac=0.0
      tlwc=calw(j+1)
      calw(j+1)=calw(j+1)*y*1000.0*ffrac
      cali(j+1)=tlwc*y*1000.0-calw(j+1)
      if(cali(j+1).lt.0.0) cali(j+1)=0.0
 400  continue
cc
cc   -----------------------------------------------------------------
cc
cc   alternative calculation procedure using the observed or
cc   inferred in cloud temperature profile
cc
cc   ----------------------------------------------------------------
cc
ccc      if(.true.) go to 455
ccc        nlevel=(zctop-zcb)/100.0
ccc        temp=cldbtm
ccc        press=cldbp*100.0
ccc        if(nlevel.le.0) nlevel=0
ccc        alw=0.0
ccc        calw(1)=0.0
ccc        nlm1=nlevel-1
ccc        if(nlm1.lt.1) nlm1=1
ccc        dtdz=(cldtpt-cldbtm)/(zctop-zcb)
ccc        zht=zbase
ccc        do 450 j=1,nlm1
ccc          rl=rlvo+(temp-273.15)*dlvdt
ccc          arg=rl*(273.15-temp)/273.15/temp/rv
ccc          es=eso*exp(arg)
ccc          qvs1=0.622*es/(press-es)
ccc          rho1=press/(rair*temp)
ccc          arg=-grav*dz/rair/temp
ccc          p=press*exp(arg)
ccc          des=es*rl/temp/temp/rv
ccc          dtz=-grav*((1.0+0.621*es*rl/(press*rair*temp))/
ccc     1        (cp+0.621*rl*des/press))
ccc          if(dtdz.lt.dtz) then
ccc            dttdz=dtz-(dtdz-dtz)
ccc          else
ccc            dttdz=dtdz
ccc          endif
ccc          zht=zht+dz
ccc          press=p
ccc          temp=temp+dttdz*dz
ccc          rl=rlvo+(273.15-temp)*dlvdt
ccc          arg=rl*(temp-273.15)/273.15/temp/rv
ccc          es2=eso*exp(arg)
ccc          qvs2=0.622*es2/(press-es2)
ccc          rho2=press/(rair*temp)
ccc          alw=alw+(qvs1-qvs2)*(rho1+rho2)/2.
ccc          if(alw.lt.0.0) alw=0.0
cc   ----------------------------------------------------------------
cc
cc   application of a simple linear glaciation
cc         all liquid T > -15 C
cc         partially liquid -15 C > T > -25 C
cc         all ice    T < -25 C
cc
cc   ---------------------------------------------------------------
ccc          ffrac=1.0
ccc          if(cldtpt.lt.258.15) then
ccc            if(cldtpt.gt.248.15) then
ccc              ffrac=(cldtpt-248.15)/10
ccc            else
ccc              ffrac=0.0
ccc            endif
ccc          endif
ccc          if(ffrac.lt.0.0) ffrac=0.0
ccc          calw(j+1)=alw*ffrac*1000.0
ccc            write(6,9015) j,calw(j+1),zht
ccc 450   continue
ccc 455   continue
cc   -----------------------------------------------------------------
cc
cc                 obtain LAPS profile of LWCs
cc
cc   -----------------------------------------------------------------
      do 500 ip=1,nll
        if(zlevel(ip).lt.zcb.or.
     1     zlevel(ip).gt.zctop) then
            ql(ip)=0.0
            qi(ip)=0.0
        else
          ql(1)=calw(1)
          qi(1)=cali(1)
          do 600 j=2,nlevel
            zcloud=zcb+(j-1)*dz
            if(zcloud.ge.zlevel(ip)) then
              ql(ip)=(zlevel(ip)-zcloud+100.)*(calw(j)-
     1                    calw(j-1))/100.+calw(j-1)
              qi(ip)=(zlevel(ip)-zcloud+100.)*(cali(j)-
     1                    cali(j-1))/100.+cali(j-1)
              go to 650
            endif
 600      continue
 650      continue
        endif
 500  continue
cc   -----------------------------------------------------------------
cc
cc               write out file of lwc comparisons
cc
cc   -----------------------------------------------------------------
 9001 format(i7)
 9002 format(1x,3i2,1x,14f8.2,i2,i3)
 9004 format(1x,2e15.8,'ihr, imin, isec=',3(i8,1x))
 9005 format(2x,'Predicted LWC',8x,'Observed LWC',/)
 9014 format(1x,8e15.8)
 9015 format(1x,'j=',i3,'adiabatic lwc =',f12.6,'altitude =',f8.1)
      istatus = 1
      return
      end