       subroutine chipth(ampfef, phafef, qfeff, xlamb, realp, nfxpts,
     $      reffin,  nkpar, akpts, aamp,apha, mchiq,chiqr,chiqi)
c
c//////////////////////////////////////////////////////////////////////
c Copyright (c) 1997--2000 Matthew Newville, The University of Chicago
c Copyright (c) 1992--1996 Matthew Newville, University of Washington
c
c Permission to use and redistribute the source code or binary forms of
c this software and its documentation, with or without modification is
c hereby granted provided that the above notice of copyright, these
c terms of use, and the disclaimer of warranty below appear in the
c source code and documentation, and that none of the names of The
c University of Chicago, The University of Washington, or the authors
c appear in advertising or endorsement of works derived from this
c software without specific prior written permission from all parties.
c
c THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
c EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
c MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
c IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
c CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
c TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
c SOFTWARE OR THE USE OR OTHER DEALINGS IN THIS SOFTWARE.
c//////////////////////////////////////////////////////////////////////
c
c  evaluate the theoretical chi(k) for a scattering path given
c  information from feff arrays  (ampfef .. degen) and xafs path
c  parameters  (s02 .. apha)
c
c input:
c    ampfef   amplitude from feff for the path
c    phafef   phase shift from feff (w/o 2*k*r term) for the path
c    qfeff    k-values from feff for the other feff arrays
c    xlamb    mean-free-path from feff
c    realp    real part of p (momentum) from feff
c    nfxpts   number of data points in the feff arrays
c    reff     half path length for the path
c    nkpar    # of k-points for k, phase, and array path parameters
c    akpts    array of k-points for array path parameters
c    aamp     array of amplitude-points for array path parameters
c    apha     array of phase-points for array path parameters
c    mchiq    array dimension for chiqr and chiqi
c output:
c    chiqr    real  \   part of complex chi(k) for this path
c    chiqi    imag  /   with all path parameters applied
c **note measured chi(k) data corresponds to  chiqi **
c
c in param() (from pthpar.h):
c    degen    path degeneracy (# of equivalent paths)
c    s02      constant multiplicitive amplitude factor for the path
c    e0shft   e0 shift to use for the path
c    e0imag   imaginary e0 shift / broadening for the path
c    delpha   constant phase shift (delta phase )
c    deltar   delta r to add to reff for the path
c    sigma2   debye-waller factor for the path
c    third    third cumulant for the path
c    fourth   fourth cumulant for the path
c
c------------------------------------------------------------------
       implicit none
       include 'consts.h'
       include 'pthpar.h'
       integer     izero, ipos, i, nfxpts, nqdata, mchiq, nqffmx
       integer     nkpar, nkpos
       complex*16        coni, cp, cp2, cphshf, cdwf, cargu, cchi, ciei
       double precision  akpts(*), aamp(*), apha(*), tmpa, tmpp
       double precision  pparams(10)
       double precision  chiqr(mchiq), chiqi(mchiq)
       double precision  e0eff, s02r2n, degen, reffin, reff
       double precision  s02, e0shft, e0imag, delpha, deltar, sigma2
       double precision  first, fourth, r2m2,  energy, q, third
       double precision  small,  half, expmax, expmin
       double precision  rep, xlam, cxlam, pha, amp, car, x3rd, x4th
       double precision  ampfef(nfxpts), phafef(nfxpts), qpos
       double precision  qfeff(nfxpts), xlamb(nfxpts),  realp(nfxpts)
       logical  le0big, iskpar
       parameter (coni = (0.d0, 1.d0) )
       parameter (small=1.d-6, half =0.5d0)
       parameter (expmax= 85.d0, expmin = -expmax)
c------------------------------------------------------------------
       degen  = param(jfpdeg)
       s02    = param(jfps02)
       e0shft = param(jfpe0)
       e0imag = param(jfpei)
       delpha = param(jfppha)
       deltar = param(jfpdr)
       sigma2 = param(jfpss2)
       third  = param(jfp3rd)
       fourth = param(jfp4th)

c  combine path parameters and feff data to get theory chi
c  note: feff writes out the feffnnnn.dat files such that
c    phase = 2*q*r + phase_shifts. additional phase shifts and
c    all amplitude reduction terms use p, the complex momentum.
c    q is used only to reproduce chi(k) from feff
       nqffmx = int((qfeff(nfxpts) + 1.d0) / qgrid) + 1
       nqdata = min(nqffmx, mchiq)
c       print*, 'chipth: nqffmx, nqdata, nqvals, mchiq'
c       print*,  nqffmx, mchiq, nqdata

c tranquada correction
       reff   = max(small, reffin)
       first  = deltar - 2 * sigma2 / reff
       r2m2   =  1 / (reff + deltar)**2
       le0big = (abs(e0shft).ge.small)
       iskpar = nkpar.gt.0
cc       print*, ' CHIPTH ', nkpar, iskpar
c ipos is a place holder for the routine lintrp
c izero stores the index of the q = 0. location.
       ipos   = 1
       nkpos  = 1
       izero  = 0
c store some multiplications/divisions before the main loopa
       e0eff  = e0shft * etok
       ciei   = coni * e0imag * etok
       s02r2n = degen * s02 * r2m2
       x4th   = fourth / 3
       x3rd   = 2 * (third / 3)

c the official xafs calculation loop:
       do 500 i = 1, nqdata
c  e0-shift the value of q
          q   = (i - 1) * qgrid
          if (le0big) then
             energy = q*q - e0eff
             q      = sign(one,energy) * sqrt(abs(energy))
          end if
c  q = zero is special, and will be dealt with below
          if (abs(q).le.small) then
             izero = i
          else
c  cubic spline interpolatation of
c  amplitude, phase, realp and xlamb of feff chi
             call hunt(qfeff,nfxpts,q,ipos)
             qpos = 0
             if (abs(qfeff(ipos+1) - qfeff(ipos)).gt.small) then
                qpos = (q-qfeff(ipos))/(qfeff(ipos+1)-qfeff(ipos))
             endif
             pha = phafef(ipos) + qpos*(phafef(ipos+1) -phafef(ipos))
             amp = ampfef(ipos) + qpos*(ampfef(ipos+1) -ampfef(ipos))
             rep = realp(ipos)  + qpos*( realp(ipos+1) - realp(ipos))
             xlam= xlamb(ipos)  + qpos*( xlamb(ipos+1) - xlamb(ipos))
c  k-dependent path parameters
             if (iskpar) then
                call hunt(akpts,nkpar,q,nkpos)
                nkpos = min(nkpar-1,max(1,nkpos))
                qpos = 0
                if (abs(akpts(nkpos+1) - akpts(nkpos)).gt.small) then
                   qpos = (q - akpts(nkpos))/
     $                  (akpts(nkpos+1)-akpts(nkpos))
                endif
                tmpa = aamp(nkpos) + qpos*(aamp(nkpos+1) -aamp(nkpos))
                tmpp = apha(nkpos) + qpos*(apha(nkpos+1) -apha(nkpos))
                amp  = amp * tmpa
                pha  = pha + tmpp
             endif
c  evaluate complex momemtum
             cp2    =  (rep + coni/xlam)**2 + ciei
             cp     =  sqrt(cp2)
c  mean free path, complex debye-waller factor and phase shift
             cxlam  =  -2*reff* dimag(cp)
             cdwf   =  -2*cp2 * (sigma2 -  cp2 * x4th)
             cphshf =   2*cp  * (first  -  cp2 * x3rd) + delpha
c  create complex chi, first checking that the exponential won't crash
             cargu  =  cxlam + cdwf + coni*(2*q*reff + pha + cphshf)
             car    =  max(expmin, min(expmax, dble(cargu)))
             cchi   =  (amp * s02r2n / abs(q)) *
     $                     exp(dcmplx(car, dimag(cargu)))
c  save real and imag chi for this value of q
             chiqi(i) = dimag(cchi)
             chiqr(i) = -dble(cchi)
          end if
 500   continue
c  fill in guess for data at q = zero if needed
       if (izero.eq.1)  then
          chiqr(1) = 2*chiqr(2) - chiqr(3)
          chiqi(1) = 2*chiqi(2) - chiqi(3)
       elseif (izero.ge.2) then
          chiqr(izero) = (chiqr(izero-1) + chiqr(izero+1)) * half
          chiqi(izero) = (chiqi(izero-1) + chiqi(izero+1)) * half
       end if
       return
c end subroutine chipth
       end


! 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

#include "error.inc"

module Multipoles_module

use error_module
!use system_module, only : dp, print, inoutput, optional_default, system_timer, operator(//), print_warning
use system_module
use cinoutput_module
use units_module
use dictionary_module
use paramreader_module
use periodictable_module
use linearalgebra_module
use atoms_types_module
use atoms_module
use topology_module
use extendable_str_module
use table_module
use connection_module
use clusters_module
use structures_module
use multipole_interactions_module
use partridge_schwenke_dipole_module

#ifdef HAVE_GAP
use descriptors_module
#endif

use mpi_context_module
use QUIP_Common_module

implicit none
private
public :: multipole_sites_setup, atomic_forces_from_sites, electrostatics_calc,finalise, build_polarisation_matrix, calc_induced_dipoles,ewald_setup

integer, parameter :: Multipole_Position_Atomic = 1
integer, parameter :: Multipole_Position_Centre_of_Mass = 2
integer, parameter :: Multipole_Position_M_Site = 3

integer, parameter :: Charge_Method_None = 0
integer, parameter :: Charge_Method_Fixed = 1
integer, parameter :: Charge_Method_GAP = 2
integer, parameter :: Charge_Method_Partridge_Schwenke = 3

integer, parameter :: Dipole_Method_None = 0
integer, parameter :: Dipole_Method_Partridge_Schwenke = 1
integer, parameter :: Dipole_Method_GAP = 2

integer, parameter :: Polarisation_Method_None = 0
integer, parameter :: Polarisation_Method_FPI = 1
integer, parameter :: Polarisation_Method_GMRES = 2
integer, parameter :: Polarisation_Method_QR = 3

integer, parameter :: Damping_None = 0
integer, parameter :: Damping_Exp = 1
integer, parameter :: Damping_Erf = 2
integer, parameter :: Damping_Erf_Uniform = 3

integer, parameter :: Screening_None = 0
integer, parameter :: Screening_Yukawa = 1
integer, parameter :: Screening_Erfc_Uniform = 2

real(dp), parameter :: reciprocal_time_by_real_time = 1.0_dp / 3.0_dp

type Monomers
  type(Multipole_Interactions_Site), dimension(:), allocatable :: site_types ! this just a dummy list of site types with no actual positions
  integer, dimension(:), allocatable :: signature
  integer, dimension(:,:), allocatable :: excluded_pairs,monomer_indices
  real(dp), dimension(:), allocatable :: masses
  real(dp) :: monomer_cutoff = 0.0_dp, step ! step size (Angstroms) used for finite difference gradient calculations
  real(dp) :: gammaM = 0.426706882_dp ! param for determining M-site position in water models
end type Monomers

public :: Multipole_Moments
type Multipole_Moments
  real(dp) :: cutoff = 0.0_dp, dipole_tolerance=1e-7_dp
  type(Monomers), dimension(:), allocatable :: monomer_types
  type(Multipole_Calc_Opts) :: calc_opts
  type(Multipole_Interactions_Site), dimension(:), allocatable :: sites ! 1 to 1 correspondence w dummy atom sites
  logical ::  strict=.true., initialised=.false.,intermolecular_only = .true.

  integer, dimension(:), allocatable :: pol_idx
  logical, dimension(:), allocatable :: site_polarisable
  integer, dimension(:,:), allocatable :: exclude_list
end type Multipole_Moments

public :: Ewald_arrays
type Ewald_arrays
  real(dp), dimension(:,:), allocatable :: Q
  logical :: do_ewald = .false.
end type Ewald_arrays

interface Finalise
  module procedure Multipole_Moments_Finalise
  module procedure Monomers_Finalise
end interface Finalise

contains

subroutine Multipole_Moments_Finalise(this)

  type(Multipole_Moments),intent(inout) :: this
  integer::i

  if (allocated(this%monomer_types)) then
    do i=1,size(this%monomer_types)
      call finalise(this%monomer_types(i))
    end do
    deallocate(this%monomer_types)
  end if
  if (allocated(this%sites)) then
    do i=1,size(this%sites)
      call finalise(this%sites(i))
    end do
    deallocate(this%sites)
  end if

  if (allocated(this%pol_idx)) deallocate(this%pol_idx)
  if (allocated(this%site_polarisable)) deallocate(this%site_polarisable)
  if (allocated(this%exclude_list)) deallocate(this%exclude_list)

  this%initialised = .False.

end subroutine Multipole_Moments_Finalise

subroutine Monomers_Finalise(this)

  type(Monomers),intent(inout) :: this
  integer :: i

  this%monomer_cutoff = 0.0_dp
  if (allocated(this%site_types)) then
    do i=1,size(this%site_types)
      call finalise(this%site_types(i))
    end do
    deallocate(this%site_types)
  end if
  if (allocated(this%signature)) deallocate(this%signature)
  if (allocated(this%excluded_pairs)) deallocate(this%excluded_pairs)
  if (allocated(this%monomer_indices)) deallocate(this%monomer_indices)
  if (allocated(this%masses)) deallocate(this%masses)

end subroutine Monomers_Finalise

subroutine clear_sites(this)
  type(Multipole_Moments),intent(inout) :: this
  integer::i

  if (allocated(this%monomer_types)) then
    do i=1,size(this%monomer_types)
      if (allocated(this%monomer_types(i)%monomer_indices)) deallocate(this%monomer_types(i)%monomer_indices)
    end do
  end if

  if (allocated(this%sites)) then
    do i=1,size(this%sites)
      call finalise(this%sites(i))
    end do
    deallocate(this%sites)
  end if

  if (allocated(this%pol_idx)) deallocate(this%pol_idx)
  if (allocated(this%site_polarisable)) deallocate(this%site_polarisable)
  if (allocated(this%exclude_list)) deallocate(this%exclude_list)

end subroutine clear_sites

subroutine multipole_sites_setup(at,multipoles,dummy_atoms,do_grads,strict)
  type(Atoms)             :: at,dummy_atoms
  type(Multipole_Moments) :: multipoles
  logical, optional       :: do_grads,strict

  logical,dimension(:), allocatable :: associated_to_monomer
  integer, dimension(3) :: shift
  integer :: n_sites, n_mono_types, cursor,i,j
  logical :: my_do_grads,my_strict

  my_do_grads=optional_default(.false.,do_grads)
  my_strict=optional_default(.true.,strict)

  call clear_sites(multipoles)

  call reallocate(associated_to_monomer,at%N,zero=.true.)
  n_sites=0
  n_mono_types=size(multipoles%monomer_types)
  do i=1,n_mono_types     ! can introduce a case switch here if want to support more monomer finding routines
    if(allocated(multipoles%monomer_types(i)%monomer_indices))deallocate(multipoles%monomer_types(i)%monomer_indices)
    call find_general_monomer(at,multipoles%monomer_types(i)%monomer_indices,multipoles%monomer_types(i)%signature,associated_to_monomer,multipoles%monomer_types(i)%monomer_cutoff)
    n_sites = n_sites + size(multipoles%monomer_types(i)%site_types) * size(multipoles%monomer_types(i)%monomer_indices,2)
  end do

!   if (.not. all(associated_to_monomer)) then
!     RAISE_ERROR('Multipoles: Not all atoms are assigned to a monomer', error)
!   end if
  allocate(multipoles%sites(n_sites))

  cursor=0
  do i=1,n_mono_types    ! fill in list of sites and exclude list
    do j=1,size(multipoles%monomer_types(i)%monomer_indices,2)
      call add_sites_for_monomer(at,multipoles%sites,cursor,multipoles%exclude_list,multipoles%monomer_types(i),multipoles%monomer_types(i)%monomer_indices(:,j),my_do_grads)
    end do
  end do

  call initialise(dummy_atoms,0,at%lattice)   ! set up dummy atoms obj
  do i=1,n_sites
    call add_atoms(dummy_atoms,multipoles%sites(i)%position,1) ! all dummy atoms are Hydrogens
  end do
  call set_cutoff(dummy_atoms,multipoles%cutoff)
  call calc_connect(dummy_atoms)

  !call write(dummy_atoms, 'stdout', prefix='DUMMY',real_format='%16.8f')

  ! if want to implement this way for efficiency, will probably have to create a second Connection object, which doesn't contain excluded interactions
  ! this is because for calculated induced dipoles we typically don't ignore intramolecular interactions, so we shuold ignore the exclude list.
!!$
!!$  do i=1,size(exclude_list,2)   ! delete bonds in exclude list
!!$    call distance_min_image(dummy_atoms,exclude_list(1,i),exclude_list(2,i),shift=shift)
!!$    call remove_bond(dummy_atoms%connection,exclude_list(1,i),exclude_list(2,i),shift=shift)
!!$  end do

  deallocate(associated_to_monomer)

end subroutine multipole_sites_setup

subroutine ewald_setup(dummy_atoms,multipoles,ewald,my_ewald_error)
  type(Atoms) :: dummy_atoms
  type(Multipole_Moments) :: multipoles
  type(Ewald_arrays) :: ewald

  real(dp) :: r_ij, erfc_ar, arg, my_ewald_error, alpha, kmax, kmax2, prefac, infac, two_alpha_over_sqrt_pi, v, &
   & ewald_precision, ewald_cutoff, my_cutoff, my_smooth_coulomb_cutoff, smooth_arg, smooth_f, dsmooth_f

  ewald_precision = -log(my_ewald_error)
  ewald_cutoff = sqrt(ewald_precision/PI) * reciprocal_time_by_real_time**(1.0_dp/6.0_dp) * &
  & minval(sqrt( sum(dummy_atoms%lattice(:,:)**2,dim=1) )) / dummy_atoms%N**(1.0_dp/6.0_dp)
  call print('Ewald cutoff = '//ewald_cutoff,PRINT_ANALYSIS)
  multipoles%cutoff = ewald_cutoff

  write(*,*) "more to do to fill these arrays"

end subroutine ewald_setup

subroutine add_sites_for_monomer(at,sites,offset,exclude_list,monomer_type,atom_indices,do_grads)
  type(Atoms) :: at
  type(Multipole_Interactions_Site), dimension(:) :: sites
  integer :: offset
  integer, dimension(:,:), allocatable :: exclude_list
  type(Monomers) :: monomer_type
  integer, dimension(:) :: atom_indices
  logical :: do_grads

  real(dp),dimension(:,:),allocatable :: atomic_positions
  integer :: monomer_size,sites_per_mono,exclude_offset,n_exclude
  integer :: i_atom_site,i_site_glob,i_atom,i_site,i
  integer, dimension(3) :: water_signature = (/1,1,8/)
  real(dp), dimension(3,3) :: identity3x3
  real(dp), dimension(3)   :: com_pos

  real(dp) :: monomer_mass
  integer,dimension(:), allocatable :: signature_copy,site_atom_map

  identity3x3 = 0.0_dp
  call add_identity(identity3x3)

  monomer_size = size(monomer_type%signature)
  sites_per_mono = size(monomer_type%site_types)

  allocate(atomic_positions(3,monomer_size))
  do i=1,monomer_size
    monomer_type%masses(i) =ElementMass(monomer_type%signature(i))
  end do
  monomer_mass = sum(monomer_type%masses)

  allocate(site_atom_map(sites_per_mono))
  allocate(signature_copy(monomer_size))
  signature_copy = monomer_type%signature
  site_atom_map=0

  do i_site=1,sites_per_mono
    if (monomer_type%site_types(i_site)%pos_type .eq. Multipole_Position_Atomic) then
      i_atom_site=find_in_array(signature_copy,monomer_type%site_types(i_site)%atomic_number)
      signature_copy(i_atom_site)=0 ! make sure we don't put two sites on the same atom
      site_atom_map(i_site) =i_atom_site
    end if
  end do

  atomic_positions=0.0_dp
  com_pos=0.0_dp

  ! find positions of atoms and centre of mass
  do i=1,monomer_size
    i_atom = atom_indices(i)
    atomic_positions(:,i) = at%pos(:,i_atom)
    com_pos = com_pos + monomer_type%masses(i) * at%pos(:,i_atom)
  end do

  com_pos = com_pos * (1.0_dp/monomer_mass)

  do i_site=1,sites_per_mono

    i_site_glob=offset+i_site

    sites(i_site_glob) = monomer_type%site_types(i_site) ! copy info from template site

    sites(i_site_glob)%charge = 0.0_dp
    sites(i_site_glob)%dipole = 0.0_dp

    allocate(sites(i_site_glob)%atom_indices(monomer_size))
    sites(i_site_glob)%atom_indices = atom_indices

    selectcase(monomer_type%site_types(i_site)%pos_type) ! assign positions
      case(Multipole_Position_Centre_of_Mass)
        sites(i_site_glob)%position = com_pos
      case(Multipole_Position_Atomic)
        sites(i_site_glob)%position = atomic_positions(:,site_atom_map(i_site))
      case(Multipole_Position_M_Site)
        call m_site_position(atomic_positions,monomer_type%gammaM,sites(i_site_glob)%position)
      case default
        call print("site position param : "//sites(i_site_glob)%pos_type)
        call system_abort("Multipole_Moments_Assign doesn't know where to put this multipole moment")
    end select

    selectcase(sites(i_site_glob)%charge_method) ! assign charges
      case(Charge_Method_Fixed)
        sites(i_site_glob)%charge = monomer_type%site_types(i_site)%charge
      case(Charge_Method_GAP)
          call system_abort("GAP moments not yet implemented")  ! call charge_GAP()
      case(Charge_Method_Partridge_Schwenke)
!#ifndef HAVE_FX
!  RAISE_ERROR('Multipoles: PS water as charges requested but FX model was not compiled in. Check the HAVE_FX flag in the Makefiles.', error)
!#endif
        call charges_PS(atomic_positions,sites(i_site_glob)%charge,i_site,monomer_type%gammaM)
        call test_charge_grads_PS(atomic_positions,monomer_type%gammaM)
    end select
    selectcase(sites(i_site_glob)%dipole_method) ! assign dipoles
      case(Dipole_Method_GAP)
        continue     ! call dipole_moment_GAP()
      case(Dipole_Method_Partridge_Schwenke)
        if (any(monomer_type%signature .ne. water_signature)) then
          call system_abort(" Signature of water monomer must be "//water_signature)
        end if
        call dipole_moment_PS(atomic_positions,sites(i_site_glob)%dipole)
        !call print("PS dipole : "//sites(i_site_glob)%dipole)
    end select

    if (do_grads) then

      allocate(sites(i_site_glob)%pos_grad_positions(3,3,monomer_size)) !  gradients of position of site wrt atomic positions
      allocate(sites(i_site_glob)%charge_grad_positions(1,3,monomer_size)) !  gradients of charge wrt atomic positions
      allocate(sites(i_site_glob)%dipole_grad_positions(3,3,monomer_size)) !  gradients of dipole components wrt atomic positions

      sites(i_site_glob)%e_grad_pos = 0.0_dp
      sites(i_site_glob)%e_grad_charge = 0.0_dp
      sites(i_site_glob)%e_grad_dipole = 0.0_dp

      sites(i_site_glob)%charge_grad_positions = 0.0_dp
      sites(i_site_glob)%dipole_grad_positions = 0.0_dp
      sites(i_site_glob)%pos_grad_positions=0.0_dp

      ! calc gradient of this site's multipole components with respect to atomic positions
      selectcase(sites(i_site_glob)%charge_method) ! assign charge gradients
        case(Charge_Method_Fixed)
          continue ! gradients are zero
        case(Charge_Method_GAP)
          call system_abort("GAP moments not yet implemented")
          ! something like call charge_gradients_GAP()
        case(Charge_Method_Partridge_Schwenke)
          call charge_gradients_PS(atomic_positions,sites(i_site_glob)%charge_grad_positions,monomer_type%gammaM,i_site)
      end select
      selectcase(sites(i_site_glob)%dipole_method)
        case(Dipole_Method_Partridge_Schwenke)
          call dipole_moment_gradients_PS(atomic_positions,sites(i_site_glob)%dipole_grad_positions,step=monomer_type%step)
        case(Dipole_Method_GAP)
          call system_abort("GAP moments not yet implemented")
          ! something like call dipole_gradients_GAP()
      end select

      ! calc gradients of this site's position with respect to atomic positions
      selectcase(sites(i_site_glob)%pos_type)
        case(Multipole_Position_Centre_of_Mass)
          do i=1,monomer_size
            sites(i_site_glob)%pos_grad_positions(:,:,i) =  ( monomer_type%masses(i) / monomer_mass) * identity3x3
          end do
        case(Multipole_Position_Atomic)
          sites(i_site_glob)%pos_grad_positions(:,:,site_atom_map(i_site)) = identity3x3
        case(Multipole_Position_M_Site)
          call m_site_position_grads(monomer_type%gammaM,sites(i_site_glob)%pos_grad_positions)
        case default
          call system_abort("Multipole_Moments_Assign doesn't know how multipole position varies with atomic positions")
      end select
    end if

  end do

  exclude_offset=0
  if(allocated(exclude_list)) then
    exclude_offset=size(exclude_list,2)
  end if
  if(allocated(monomer_type%excluded_pairs)) then
    n_exclude=size(monomer_type%excluded_pairs,2)
    call reallocate(exclude_list,2,exclude_offset+n_exclude,copy=.true.)
    do i=1,n_exclude
      exclude_list(1,exclude_offset+i)=offset+monomer_type%excluded_pairs(1,i)
      exclude_list(2,exclude_offset+i)=offset+monomer_type%excluded_pairs(2,i)
    end do
  end if
  offset = offset+sites_per_mono

  deallocate(atomic_positions)

end subroutine add_sites_for_monomer

subroutine electrostatics_calc(at,multipoles,ewald,do_pot,do_field,do_force,e)
  type(Atoms) :: at
  type(Multipole_Moments) :: multipoles
  type(Ewald_arrays) :: ewald
  logical,optional :: do_pot,do_field,do_force
  real(dp),optional :: e

  real(dp) :: my_energy,r_ij,site_site_energy
  integer :: i_site,n,j_site
  real(dp), dimension(3) :: diff
  type(Multipole_Interactions_Site) :: site1,site2

  multipoles%calc_opts%do_pot = optional_default(.false.,do_pot)
  multipoles%calc_opts%do_field = optional_default(.false.,do_field)
  multipoles%calc_opts%do_force = optional_default(.false.,do_force)

  if(.not. allocated(multipoles%exclude_list)) allocate(multipoles%exclude_list(2,0))
!call print("doing calc w cutoff "//multipoles%cutoff)
!call print("exclude list ")
!call print(multipoles%exclude_list)
  ! real space part
  do i_site=1,at%N

    multipoles%sites(i_site)%e_field=0.0_dp
    multipoles%sites(i_site)%potential=0.0_dp
    multipoles%sites(i_site)%e_grad_pos=0.0_dp
    multipoles%sites(i_site)%e_grad_charge=0.0_dp
    multipoles%sites(i_site)%e_grad_dipole=0.0_dp

    site1 = multipoles%sites(i_site)
    do n = 1, n_neighbours(at,i_site)
      j_site = neighbour(at,i_site,n,distance=r_ij,diff=diff)

      if( r_ij > multipoles%cutoff )  cycle

      if ( find_in_array(multipoles%exclude_list,(/i_site,j_site/)) + find_in_array(multipoles%exclude_list,(/j_site,i_site/)) .gt. 0 ) cycle

      site2 = multipoles%sites(j_site)
      site2%position = site1%position + diff         ! make a copy of neighbour site and move it to the correct position

      call Multipole_Moments_Site_Site_Interaction(site_site_energy,site1,site2, multipoles%calc_opts, cutoff=multipoles%cutoff)

      my_energy = my_energy + 0.5_dp * site_site_energy ! double counting

      multipoles%sites(i_site)%e_field       =  multipoles%sites(i_site)%e_field         + site1%e_field
      multipoles%sites(i_site)%potential     =  multipoles%sites(i_site)%potential       + site1%potential
      multipoles%sites(i_site)%e_grad_pos    =  multipoles%sites(i_site)%e_grad_pos      + site1%e_grad_pos
      multipoles%sites(i_site)%e_grad_charge =  multipoles%sites(i_site)%e_grad_charge   + site1%e_grad_charge
      multipoles%sites(i_site)%e_grad_dipole =  multipoles%sites(i_site)%e_grad_dipole   + site1%e_grad_dipole

    end do
  end do

call print("real space energy "//my_energy)
  ! if ewald
  ! recip part
  ! self part

  if (present(e))e=e+my_energy

end subroutine electrostatics_calc

subroutine atomic_forces_from_sites(sites,f)
  type(Multipole_Interactions_Site), dimension(:) :: sites
  real(dp), intent(out), dimension(:,:),optional :: f

  integer :: i, j, k, a, n_atoms,i_site,i_atom

  do i_site=1,size(sites)  ! add up force contributions in most transparent way possible

    n_atoms = size(sites(i_site)%atom_indices)

    do a=1,n_atoms ! a is atom number, i component of atomic position, j component of dipole, k component of site position
      i_atom=sites(i_site)%atom_indices(a)
      do i=1,3
        f(i,i_atom) = f(i,i_atom) - sites(i_site)%e_grad_charge * sites(i_site)%charge_grad_positions(1,i,a) ! NB force is minus grad
        do j=1,3
          f(i,i_atom) = f(i,i_atom) - sites(i_site)%e_grad_dipole(j) * sites(i_site)%dipole_grad_positions(j,i,a)
        end do
        do k=1,3
          f(i,i_atom) = f(i,i_atom) - sites(i_site)%e_grad_pos(k) * sites(i_site)%pos_grad_positions(k,i,a)
        end do
      end do
    end do

  end do

end subroutine atomic_forces_from_sites

subroutine build_polarisation_matrix(at,multipoles,pol_matrix,ewald)
  type(Atoms) :: at
  type(Multipole_Moments) :: multipoles
  real(dp), dimension(:,:),allocatable :: pol_matrix
  type(Ewald_arrays) :: ewald

  integer :: N_pol,i,i_pol,j_pol,i_site,j_site,n,ii
  type(Multipole_Interactions_Site) :: site1,site2

  real(dp), dimension(3,3) :: prop_mat ! temporary storage of dipole field tensor
  real(dp), dimension(3) :: diff
  real(dp)               :: r_ij

  N_pol=0
  call reallocate(multipoles%pol_idx,at%N,zero=.true.)
  do i_site=1,at%N
    if(multipoles%sites(i_site)%polarisable) then
      N_pol=N_pol+1
      multipoles%pol_idx(i_site)=N_pol
    end if
  end do

  call reallocate(pol_matrix,3*N_pol,3*N_pol,zero=.true.)

  do i_site=1,at%N
    i_pol=multipoles%pol_idx(i_site)
    if(i_pol .eq. 0) cycle
    do ii=3*i_pol-2,3*i_pol
      pol_matrix(ii,ii) = 1.0_dp / multipoles%sites(i_site)%alpha
    end do
  end do

  do i_site=1,at%N
    i_pol=multipoles%pol_idx(i_site)
    if(i_pol .eq. 0) cycle
    site1 = multipoles%sites(i_site)

    do n = 1, n_neighbours(at,i_site)
      j_site = neighbour(at,i_site,n,distance=r_ij,diff=diff)
      j_pol = multipoles%pol_idx(j_site)
      if( r_ij > multipoles%cutoff .or. j_pol .eq. 0)  cycle
!prop_mat=T_rank_two(diff,multipoles%calc_opts,site1%damp_rad,site2%damp_rad,cutoff=multipoles%cutoff)
!call print(prop_mat)
      pol_matrix(3*i_pol-2:3*i_pol,3*j_pol-2:3*j_pol) =  - T_rank_two(diff,multipoles%calc_opts,site1%damp_rad,site2%damp_rad,cutoff=multipoles%cutoff)
    end do

  end do

end subroutine build_polarisation_matrix

subroutine  calc_induced_dipoles(pol_matrix,multipoles,polarisation,pol_energy)
  real(dp), dimension(:,:) :: pol_matrix
  type(Multipole_Moments) :: multipoles
  integer :: polarisation
  real(dp),intent(out) :: pol_energy

  type(LA_Matrix) :: la_pol_matrix
  real(dp),dimension(:),allocatable :: perm_field,induced_dipoles
  integer:: i_pol,i_site,N_pol,N_sites,ii

  N_sites=size(multipoles%pol_idx)
  N_pol=count(multipoles%pol_idx .ne. 0)

  call reallocate(perm_field,3*N_pol,zero=.true.)
  call reallocate(induced_dipoles,3*N_pol,zero=.true.)
  call initialise(la_pol_matrix,pol_matrix)

  ! extract permanent fields from sites
  do i_site=1,N_sites
    i_pol=multipoles%pol_idx(i_site)
    if(i_pol .eq. 0) cycle
    ii=3*i_pol-2
    perm_field(ii:ii+2) = multipoles%sites(i_site)%e_field
  end do
!call print("perm_field")
!call print(perm_field)

  ! solve system with QR or GMRES
  if ( polarisation == Polarisation_Method_QR) then
    call LA_Matrix_QR_Factorise(la_pol_matrix)
    call LA_Matrix_QR_Solve_Vector(la_pol_matrix,perm_field,induced_dipoles)
  end if

  pol_energy=0.0_dp
  ! update dipoles on sites and sum induction energy
  do i_site=1,N_sites
    i_pol=multipoles%pol_idx(i_site)
    if(i_pol .eq. 0) cycle
    ii=3*i_pol-2
    multipoles%sites(i_site)%dipole =  multipoles%sites(i_site)%dipole + induced_dipoles(ii:ii+2)
    pol_energy = pol_energy + 0.5_dp*(normsq(induced_dipoles(ii:ii+2))/multipoles%sites(i_site)%alpha)
  end do
call print("polarisation energy "//pol_energy)
!call print("dipoles")
!call print(induced_dipoles)

end subroutine  calc_induced_dipoles

end module Multipoles_module


C$Procedure      CKFXFM ( C-kernel, find transformation )

      SUBROUTINE CKFXFM ( INST, ET, XFORM, REF, FOUND )

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

      IMPLICIT NONE
      INTEGER               INST
      DOUBLE PRECISION      ET
      DOUBLE PRECISION      XFORM  ( 6, 6 )
      INTEGER               REF
      LOGICAL               FOUND

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     INST       I   NAIF instrument ID.
C     ET         I   Epoch measured in seconds past J2000.
C     XFORM      O   Transformation from CK platform to frame REF.
C     REF        O   Reference frame.
C     FOUND      O   True when requested pointing is available.
C
C$ Detailed_Input
C
C     INST       is the unique NAIF integer ID for the spacecraft
C                instrument for which data is being requested.
C
C     ET         is the epoch for which the state transformation
C                is desired. ET should be given in seconds past the
C                epoch of J2000.
C
C
C$ Detailed_Output
C
C     XFORM      is a state transformation matrix that converts
C                states relative to the input frame (given by INST)
C                to states relative to the frame REF.
C
C
C                Thus, if a state S has components x,y,z,dx,dy,dz
C                in the frame of INST, frame, then S has components
C                x', y', z', dx', dy', dz' in frame REF.
C
C                     [  x' ]     [           ] [  x ]
C                     |  y' |  =  |           | |  y |
C                     |  z' |     |           | |  z |
C                     | dx' |     [   XFORM   ] | dx |
C                     | dy' |  =  |           | | dy |
C                     [ dz' ]     [           ] [ dz ]
C
C
C     REF        is the id-code reference frame to which XFORM will
C                transform states.
C
C     FOUND      is true if a record was found to satisfy the pointing
C                request.  FOUND will be false otherwise.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If a C-kernel file is not loaded using CKLPF prior to calling
C         this routine, an error is signalled by a routine that this
C         routine calls.
C
C
C$ Files
C
C     CKFXFM searches through files loaded by CKLPF to locate a segment
C     that can satisfy the request for state transformation
C     for instrument INST at time ET.  You must load a C-kernel
C     file using CKLPF before calling this routine.
C
C$ Particulars
C
C     CKFXFM searches through files loaded by CKLPF to satisfy a
C     pointing request. Last-loaded files are searched first, and
C     individual files are searched in backwards order, giving
C     priority to segments that were added to a file later than the
C     others. CKFXFM considers only those segments that contain
C     angular velocity data.
C
C     The search ends when a segment is found that can give pointing
C     and angular velocity for the specified instrument at the request
C     time.
C
C$ Examples
C
C     Suppose that you want to determine how fast an instrument
C     is rotating with respect to the frame used to store the
C     instrument's attitude.  First look up the transformation
C     from the instrument frame specified by ID to the reference
C     frame (returned by CKFXFM).
C
C        INST = id_code of the instrument of interest
C        ET   = epoch of interest in seconds past J2000.
C
C        CALL CKFXFM ( INST, ET, XFORM, REF, FOUND )
C
C     Next determine the angular velocity of the transformation from
C
C        CALL XF2RAV ( XFORM, ROT, AV )
C
C     The angular rate of change (in radians/second) is just the
C     magnitude of AV.
C
C        RATE  = VNORM ( AV )
C
C$ Restrictions
C
C     A C-kernel file should have been loaded by CKLPF.
C
C     In addition is helpful to load a CK-info file into the
C     Kernel pool.  This file should have the following variables
C     defined.
C
C       CK_<INST>_SCLK = SCLK idcode that yields SCLK mapping for INST.
C       CK_<INST>_SPK  = SPK idcode  that yields ephemeris for INST.
C
C     where <INST> is the integer string corresponding to INST.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber (JPL)
C
C$ Version
C
C-    SPICELIB Version 2.2.0, 17-FEB-2000 (WLT)
C
C        The routine now checks to make sure convert ET to TICKS
C        and that at least one C-kernel is loaded before trying
C        to look up the transformation.
C
C-    SPICELIB Version 2.1.0, 09-MAR-1999 (NJB)
C
C        A call to SCE2T has been replaced by a call to SCE2C.
C
C-    SPICELIB Version 2.0.0, 28-JUL-1997 (WLT)
C
C        The previous edition did not correctly compute the derivative
C        block of the state transformation matrix.
C
C        The routine incorrectly computed the state transformation
C        matrix using the rotation from INST to REF together with
C        the angular velocity from REF to INST.  Now it computes
C        the state transformation matrix from REF to INST and then
C        inverts the result to get the correct matrix.
C
C        Moved the assignment of FOUND to just before the check
C        of the SPICELIB function RETURN.  That way if the routine
C        exits immediately via a check of the function RETURN(),
C        FOUND will have an appropriate value.
C
C-    SPICELIB Version 1.0.0, 3-OCT-1994 (WLT)
C
C-&

C$ Index_Entries
C
C     get instrument frame transformation and reference frame
C
C-&

C$ Revisions
C
C-    SPICELIB Version 2.1.0, 09-MAR-1999 (NJB)
C
C        A call to SCE2T has been replaced by a call to SCE2C.  This
C        routine performs conversion of ET to continuous ticks,
C        reducing truncation error in the representation of the input
C        time value.
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN
      LOGICAL               FAILED
      LOGICAL               ZZSCLK

C
C     Local parameters
C
C        NDC        is the number of double precision components in an
C                   unpacked C-kernel segment descriptor.
C
C        NIC        is the number of integer components in an unpacked
C                   C-kernel segment descriptor.
C
C        NC         is the number of components in a packed C-kernel
C                   descriptor.  All DAF summaries have this formulaic
C                   relationship between the number of its integer and
C                   double precision components and the number of packed
C                   components.
C
C        IDLEN      is the length of the C-kernel segment identifier.
C                   All DAF names have this formulaic relationship
C                   between the number of summary components and
C                   the length of the name (You will notice that
C                   a name and a summary have the same length in bytes.)
C

      INTEGER               NDC
      PARAMETER           ( NDC = 2 )

      INTEGER               NIC
      PARAMETER           ( NIC = 6 )

      INTEGER               NC
      PARAMETER           ( NC = NDC + ( NIC + 1 )/2 )

      INTEGER               IDLEN
      PARAMETER           ( IDLEN = NC * 8 )

C
C     Local variables
C
      INTEGER               HANDLE
      INTEGER               ICD      ( NIC  )
      INTEGER               SCLKID

      DOUBLE PRECISION      AV       ( 3    )
      DOUBLE PRECISION      CLKOUT
      DOUBLE PRECISION      DESCR    ( NC   )
      DOUBLE PRECISION      DCD      ( NDC  )
      DOUBLE PRECISION      ROT      ( 3, 3 )
      DOUBLE PRECISION      REF2IN   ( 6, 6 )
      DOUBLE PRECISION      TIME
      DOUBLE PRECISION      TOL

      CHARACTER*(IDLEN)     SEGID

      LOGICAL               NEEDAV
      LOGICAL               SFND
      LOGICAL               PFND
      LOGICAL               HAVE
C
C     Set FOUND to FALSE right now in case we end up
C     returning before doing any work.
C
      FOUND = .FALSE.
      REF   =  0

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

C
C     Need angular velocity data.
C     Assume the segment won't be found until it really is.
C
      NEEDAV = .TRUE.
      TOL    =  0.0D0

C
C     Begin a search for this instrument and time, and get the first
C     applicable segment.
C
      CALL CKMETA ( INST,  'SCLK', SCLKID )
      CALL CKHAVE ( HAVE )

      IF ( .NOT. HAVE ) THEN
         CALL CHKOUT ( 'CKFXFM' )
         RETURN
      ELSE IF ( .NOT. ZZSCLK ( INST, SCLKID ) ) THEN
         CALL CHKOUT ( 'CKFXFM' )
         RETURN
      END IF

      CALL SCE2C  ( SCLKID, ET,            TIME   )
      CALL CKBSS  ( INST,   TIME,   TOL,   NEEDAV )
      CALL CKSNS  ( HANDLE, DESCR,  SEGID, SFND   )

C
C     Keep trying candidate segments until a segment can produce a
C     pointing instance within the specified time tolerance of the
C     input time.
C
C     Check FAILED to prevent an infinite loop if an error is detected
C     by a SPICELIB routine and the error handling is not set to abort.
C
      DO WHILE ( ( SFND ) .AND. ( .NOT. FAILED () ) )

         CALL CKPFS ( HANDLE, DESCR, TIME,   TOL, NEEDAV,
     .                ROT,    AV,    CLKOUT, PFND          )

         IF ( PFND ) THEN
C
C           Found one. Fetch the ID code of the reference frame
C           from the descriptor.
C
            CALL DAFUS  ( DESCR, NDC, NIC, DCD, ICD )
            REF   =  ICD( 2 )
            FOUND = .TRUE.
C
C           We now have the transformation matrix from
C           REF to INST immediately. Using the angular velocity
C           we compute the state transformation matrix from REF to INST
C
            CALL RAV2XF ( ROT, AV, REF2IN )

C
C           Finally, we invert REF2IN to get the state transformation
C           from INST to REF.
C
            CALL INVSTM ( REF2IN, XFORM )

            CALL CHKOUT ( 'CKFXFM' )
            RETURN

         END IF

         CALL CKSNS ( HANDLE, DESCR, SEGID, SFND )

      END DO

      CALL CHKOUT ( 'CKFXFM' )
      RETURN
      END


      subroutine  dpdpfh
!***********************************************************************
!  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.
C***********************************************************************
CD1
CD1  PURPOSE
CD1
CD1  To load the double porosity/double permeability solution into the
CD1  solution matrix for a heat, water, water vapor simulation.
CD1
C***********************************************************************
CD2
CD2  REVISION HISTORY
CD2
CD2 $Log:   /pvcs.config/fehm90/src/dpdpfh.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:42:54   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:03:02   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:08:34   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:23:22   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 11:59:50   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:40:52 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
CD2
CD2    Rev 1.5   Thu Feb 15 09:50:46 1996   zvd
CD2 Corrected purpose and requirements.
CD2
CD2    Rev 1.4   Wed Jan 10 11:10:16 1996   hend
CD2 Corrected ECD Number
CD2
CD2    Rev 1.3   Wed Jan 10 09:34:44 1996   hend
CD2 Added Prolog
CD2
CD2    Rev 1.2   03/23/94 14:41:04   robinson
CD2 Additional cleanup of memory management
CD2
CD2    Rev 1.1   03/18/94 15:47:24   gaz
CD2 Added solve_new and cleaned up memory management.
CD2
CD2    Rev 1.0   01/20/94 10:23:12   pvcs
CD2 original version in process of being certified
CD2
C***********************************************************************
CD3
CD3  REQUIREMENTS TRACEABILITY
CD3
CD3 2.3.2 Heat- and mass-transfer equations
CD3 2.4.9 Double-porosity/double-permeability formulation
CD3 2.5.2  Solve nonlinear equation set at each time step
CD3
C***********************************************************************
CD4
CD4  SPECIAL COMMENTS AND REFERENCES
CD4
CD4 Requirements from SDN: 10086-RD-2.20-00
CD4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
CD4   FEHM Application Version 2.20
CD4
C***********************************************************************

      use davidi
      use comji
      use comhi
      use comgi
      use comfi
      use comei
      use comdi
      use comci
      use combi
      use comdti
      use comai
      implicit none

      integer i, ial, iau, id, idg, idl, idum, isl, iz, jm, jml
      integer kb, kz, neighc, neq2, neqp1, nmat2avw
      real*8  aexy, aexyf, alen, al0, al1, area, athkb
      real*8  axkb, axy, axyd, axyf
      real*8  coef1, coefmx
      real*8  delci, delckb, delei, delekb, deli, delkb
      real*8  devci, devckb, devei, devekb, devi, devkb
      real*8  devmci, devmei, devmpi
      real*8  dfmlis, dfmlkbs, dfmvis, dfmvkbs
      real*8  dilci, dilckb, dili, dilei, dilekb, dilkb, dilpi, dilpkb
      real*8  divci, divckb, divei, divekb, divi, divkb, divpi, divpkb
      real*8  dist01
      real*8  dlaei, dlaekb, dlapi, dlapkb
      real*8  dleei, dleekb, dlei, dlekb, dlepi, dlepkb
      real*8  dlpi, dlpkb, dpvti
      real*8  dvaei, dvaekb, dvapi, dvapkb
      real*8  dveei, dveekb, dvei, dvekb, dvepi, dvepkb, dvpi, dvpkb
      real*8  fid, fid1, fmkb, fmli, fmlkb, fmvi, fmvkb, frac0, frac1
      real*8  heatc, enli, enlkb, envi, envkb
      real*8  phii, phikb, pvii, pvikb, pvxy, pxy, pxyh, pxyi
      real*8  radi, radkb
      real*8  swi, sx2c, sx2t, sx4d, sx4h
      real*8  thxi, thxkb, thyi, thzi, ti, tot
      real*8  vexy, vexyf, vxy, vxyd, vxyf
      parameter (coefmx=1000000000.0)

      neq2   =  neq+neq
      neqp1  =  neq+1
c
c zero out transfer terms
c
      do i=1,nmat(2)
         a(i+nmat(3))=0.
         a(i+nmat(4))=0.
         a(i+nmat(7))=0.
         a(i+nmat(8))=0.
         a(i+nmat(9))=0.
         a(i+nmat(10))=0.
         a(i+nmat(13))=0.
         a(i+nmat(14))=0.
      enddo
c
c     compute the fracture-matrix transfer terms
c
c     loop on nodes
      do id=1,neq
c     identify diagonal member
         idg =  nelmdg(id)
         idum =  idg-neqp1
c     identify matrix node
         i=id
         idl=id+neq
         tot=sx1(id)+sx1(idl)
         frac0=sx1(id)/tot
         frac1=sx1(idl)/tot
         alen=apuv1(id)
         al0=frac0*alen
         al1=frac1*alen
c
c     determine contribution to node id
c
c
         dist01=0.5*(al0+al1)
         if(dist01.le.1.e-15) dist01=1.e-15
         area=tot/alen
         pvii=phi(i)
         phii=pvii-pcp(i)
         dpvti=dpcef(i)
         enli=enlf(i)
         deli=delf(i)
         delei=delef(i)
         envi=envf(i)
         devi=devf(i)
         devei=devef(i)
         dili=dil(i)
         divi=div(i)
         dilpi=dilp(i)
         dilei=dile(i)
         divpi=divp(i)
         divei=dive(i)
         thxi=thx(i)
         thyi=thy(i)
         thzi=thz(i)
         ti=t(i)
         swi=s(i)
c
c     form constants for i>neq
c
         iz=i
         coef1=-area/dist01
         if(coef1.lt.-coefmx) coef1=coefmx
         if(iupk.ne.0) then
            axkb=max(pny(idl),zero_t)*pnx(idl)
         else
          if(idpdp.eq.1) then
            axkb =  max( pnx(idl),zero_t)
          else if(idpdp.eq.2) then
            axkb =  max( pny(idl),zero_t)
          else if(idpdp.eq.3) then
            axkb =  max( pnz(idl),zero_t)
          else
            axkb =  max( pnx(idl  ),pny(idl  ),
     *           pnz(idl  ),zero_t )
          endif
         endif
          if(idpdp.eq.1) then
            athkb =  max( thx(idl),zero_t)
          else if(idpdp.eq.2) then
            athkb =  max( thy(idl),zero_t)
          else if(idpdp.eq.3) then
            athkb =  max( thz(idl),zero_t)
          else
            athkb =  max( thx(idl  ),thy(idl  ),
     *        thz(idl  ),zero_t )
          endif
c
c     2-d geometry
c
         if (icnl.ne.0) then
            radi=cord(iz,3)
         elseif (icnl.eq.0) then
            radi=1.0
         endif
         jm=1
         kb=idl
         kz=kb
         neighc=1
         perml(1)=axkb
         permv(1)=perml(1)
         radkb=radi
         sx2c=radkb*coef1
c     sx4d=-radkb*perml(igrav)*sx(iw,igrav)*grav
c     sx4h=-radkb*permv(igrav)*sx(iw,igrav)*grav
         thxkb=athkb
         sx2t=sx2c*thxkb
         pvikb=phi(kb)
         phikb=pvikb-pcp(kb)
         pxy=sx2c*perml(1)
         pvxy=sx2c*permv(1)
         pxyi=pxy*(phikb-phii)
         pxyh=pvxy*(pvikb-pvii)
         t1(neighc)=pxyi
         t2(neighc)=pxyh
         t3(neighc)=pxy
         t4(neighc)=pvxy
         t5(neighc)=sx2t
         t6(neighc)=0.0
         t7(neighc)=0.0
c
c     liquid phase calculations
c
         jm=1
         kb=idl
         kz=kb
         neighc=1
         pxyi=t1(neighc)
         sx4d=t6(neighc)
         axyd=pxyi+0.5*sx4d*(rolf(i)+rolf(kb))
     *        *(cord(kz,igrav)-cord(iz,igrav))
         t8(neighc)=axyd
c
c     determine upwind nodes and if liquid phase exists
c
         isl=0
         jm=1
         kb=idl
         kz=kb
         neighc=1
         fid=.5
         axyd=t8(neighc)
         if(axyd.lt.0.0) fid=dnwgt
         if(axyd.gt.0.0) fid=upwgt
         if(t3(neighc).lt.0.0) t9(neighc)=fid
         if(t3(neighc).gt.0.0) t9(neighc)=fid
         if(swi+s(kb).ne.0.0) isl=1
c
c     form equations
c
         if(isl.ne.0) then
            jm=1
            kb=idl
            kz=kb
            neighc=1
            axyd=t8(neighc)
            fid=t9(neighc)
            fid1=1.0-fid
            pxyi=t1(neighc)
            pxy=t3(neighc)
            sx4d=t6(neighc)
            dilkb=dil(kb)
            dilpkb=dilp(kb)
            dilekb=dile(kb)
            enlkb=enlf(kb)
            delkb=delf(kb)
            delekb=delef(kb)
            dilekb=dile(kb)
            dlpi=-pxy+0.5*sx4d*dglp(i)*(cord(kz,igrav)-cord(iz,igrav))
            dlpkb=pxy+0.5*sx4d*dglp(kb)*(cord(kz,igrav)-cord(iz,igrav))
            dlei=pxy*dpvti+0.5*sx4d*dgle(i)*(cord(kz,igrav)-
     &           cord(iz,igrav))
            dlekb=-pxy*dpcef(kb)+0.5*sx4d*dgle(kb)
     *           *(cord(kz,igrav)-cord(iz,igrav))
            axyf=(fid*dilkb+fid1*dili)
            aexyf=(fid*dilkb*enlkb+fid1*dili*enli)
            axy=axyd*axyf
            aexy=axyd*aexyf
            dlapi=dlpi*axyf+axyd*fid1*dilpi
            dlapkb=dlpkb*axyf+axyd*fid*dilpkb
            dlaei=dlei*axyf+axyd*fid1*dilei
            dlaekb=dlekb*axyf+axyd*fid*dilekb
            dlepi=dlpi*aexyf+axyd*fid1*(dilpi*enli+dili*deli)
            dlepkb=dlpkb*aexyf+axyd*fid*(dilpkb*enlkb+dilkb*delkb)
            dleei=dlei*aexyf+axyd*fid1*(dilei*enli+dili*delei)
            dleekb=dlekb*aexyf+axyd*fid*(dilekb*enlkb+dilkb*delekb)

            bp(i+nrhs(1))=bp(i+nrhs(1))+axy
            bp(i+nrhs(3))=bp(i+nrhs(3))-axy
            a(idum+nmat(1))=a(idum+nmat(1))+dlapi
            a(idum+nmat(2))=a(idum+nmat(2))+dlaei
            a(idum+nmat(9))=a(idum+nmat(9))-dlapi
            a(idum+nmat(10))=a(idum+nmat(10))-dlaei
            a(idum+nmat(3))=a(idum+nmat(3))+dlapkb
            a(idum+nmat(4))=a(idum+nmat(4))+dlaekb
            a(idum+nmat(11))=a(idum+nmat(11))-dlapkb
            a(idum+nmat(12))=a(idum+nmat(12))-dlaekb

            bp(i+nrhs(2))=bp(i+nrhs(2))+aexy
            bp(i+nrhs(4))=bp(i+nrhs(4))-aexy
            a(idum+nmat(5))=a(idum+nmat(5))+dlepi
            a(idum+nmat(6))=a(idum+nmat(6))+dleei
            a(idum+nmat(13))=a(idum+nmat(13))-dlepi
            a(idum+nmat(14))=a(idum+nmat(14))-dleei
            a(idum+nmat(7))=a(idum+nmat(7))+dlepkb
            a(idum+nmat(8))=a(idum+nmat(8))+dleekb
            a(idum+nmat(15))=a(idum+nmat(15))-dlepkb
            a(idum+nmat(16))=a(idum+nmat(16))-dleekb
         endif
c
c     vapour phase calculations
c
         jm=1
         kb=idl
         kz=kb
         neighc=1
         pxyh=t2(neighc)
         sx4h=t7(neighc)
         vxyd=pxyh+0.5*sx4h*(rovf(i)+rovf(kb))
     *        *(cord(kz,igrav)-cord(iz,igrav))
         t8(neighc)=vxyd
c
c     determine upwind nodes and if vapour phase exists
c
c     isl=0
         jm=1
         kb=idl
         kz=kb
         neighc=1
         fid=.5
         vxyd=t8(neighc)
         if(vxyd.lt.0.0) fid=dnwgt
         if(vxyd.gt.0.0) fid=upwgt
         if(t4(neighc).lt.0.0) t9(neighc)=fid
         if(t4(neighc).gt.0.0) t9(neighc)=fid
c     if(swi+s(kb).ne.2.0) isl=1
c
c     form equations
c
         if(isl.ne.0) then
            jm=1
            kb=idl
            kz=kb
            neighc=1
            fid=t9(neighc)
            fid1=1.0-fid
            pxyh=t2(neighc)
            pvxy=t4(neighc)
            sx4h=t7(neighc)
            vxyd=t8(neighc)
            divkb=div(kb)
            divpkb=divp(kb)
            divekb=dive(kb)
            envkb=envf(kb)
            devkb=devf(kb)
            devekb=devef(kb)
            divekb=dive(kb)
            dvpi=-pvxy+0.5*sx4h*dgvp(i)*(cord(kz,igrav)-cord(iz,igrav))
            dvpkb=pvxy+0.5*sx4h*dgvp(kb)*(cord(kz,igrav)-cord(iz,igrav))
            dvei=0.5*sx4h*dgve(i)*(cord(kz,igrav)-cord(iz,igrav))
            dvekb=0.5*sx4h*dgve(kb)
     *           *(cord(kz,igrav)-cord(iz,igrav))
            vxyf=(fid*divkb+fid1*divi)
            vexyf=(fid*divkb*envkb+fid1*divi*envi)
            vxy=vxyd*vxyf
            vexy=vxyd*vexyf
            dvapi=dvpi*vxyf+vxyd*fid1*divpi
            dvapkb=dvpkb*vxyf+vxyd*fid*divpkb
            dvaei=dvei*vxyf+vxyd*fid1*divei
            dvaekb=dvekb*vxyf+vxyd*fid*divekb
            dvepi=dvpi*vexyf+vxyd*fid1*(divpi*envi+divi*devi)
            dvepkb=dvpkb*vexyf+vxyd*fid*(divpkb*envkb+divkb*devkb)
            dveei=dvei*vexyf+vxyd*fid1*(divei*envi+divi*devei)
            dveekb=dvekb*vexyf+vxyd*fid*(divekb*envkb+divkb*devekb)
            bp(i+nrhs(1))=bp(i+nrhs(1))+vxy
            bp(i+nrhs(3))=bp(i+nrhs(3))-vxy
            a(idum+nmat(1))=a(idum+nmat(1))+dvapi
            a(idum+nmat(2))=a(idum+nmat(2))+dvaei
            a(idum+nmat(9))=a(idum+nmat(9))-dvapi
            a(idum+nmat(10))=a(idum+nmat(10))-dvaei
            a(idum+nmat(3))=a(idum+nmat(3))+dvapkb
            a(idum+nmat(4))=a(idum+nmat(4))+dvaekb
            a(idum+nmat(11))=a(idum+nmat(11))-dvapkb
            a(idum+nmat(12))=a(idum+nmat(12))-dvaekb

            bp(i+nrhs(2))=bp(i+nrhs(2))+vexy
            bp(i+nrhs(4))=bp(i+nrhs(4))-vexy
            a(idum+nmat(5))=a(idum+nmat(5))+dvepi
            a(idum+nmat(6))=a(idum+nmat(6))+dveei
            a(idum+nmat(13))=a(idum+nmat(13))-dvepi
            a(idum+nmat(14))=a(idum+nmat(14))-dveei
            a(idum+nmat(7))=a(idum+nmat(7))+dvepkb
            a(idum+nmat(8))=a(idum+nmat(8))+dveekb
            a(idum+nmat(15))=a(idum+nmat(15))-dvepkb
            a(idum+nmat(16))=a(idum+nmat(16))-dveekb
         endif
c
c     add heat conduction
c
         jm=1
         kb=idl
         kz=kb
         neighc=1
         heatc=t5(neighc)
         iau=it11(jm)
         ial=it12(jm)
         jml=nelmdg(kb)-neqp1
         heatc=t5(neighc)
         bp(i+nrhs(2))=bp(i+nrhs(2))+heatc*(t(kb)-ti)
         bp(i+nrhs(4))=bp(i+nrhs(4))-heatc*(t(kb)-ti)
         a(idum+nmat(5))=a(idum+nmat(5))-heatc*dtpa(i)
         a(idum+nmat(6))=a(idum+nmat(6))-heatc*dtpae(i)
         a(idum+nmat(13))=a(idum+nmat(13))+heatc*dtpa(i)
         a(idum+nmat(14))=a(idum+nmat(14))+heatc*dtpae(i)
         a(idum+nmat(7))=a(idum+nmat(7))+heatc*dtpa(kb)
         a(idum+nmat(8))=a(idum+nmat(8))+heatc*dtpae(kb)
         a(idum+nmat(15))=a(idum+nmat(15))-heatc*dtpa(kb)
         a(idum+nmat(16))=a(idum+nmat(16))-heatc*dtpae(kb)
      enddo

      return
      end


subroutine control2state_ad(rval,bval,grad)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    control2state_ad
!   prgmmr: tremolet
!
! abstract:  Converts variables from physical space to control space
!            This is also the adjoint of control2state
!
! program history log:
!   2007-04-16  tremolet - initial code
!   2008-11-28  todling  - update to GSI May 2008: add tsen and p3d
!   2009-01-15  todling  - handle predictors in quad precision
!   2009-04-21  derber   - modify call to getstvp to call to getuv
!   2009-06-15  parrish  - add call to strong_bk_ad when l_hyb_ens=.true. (hybrid ensemble run)
!   2009-08-12  lueken   - update documentation
!   2009-11-27  parrish  - for uv_hyb_ens=.true., then ensemble perturbations contain u,v instead of st,vp
!                            so introduce extra code to handle this case.
!   2010-02-20  parrish  - introduce modifications to allow dual resolution capability when running
!                            in hybrid ensemble mode.
!   2010-03-24  zhu      - use cstate for generalizing control variable
!   2010-04-29  todling  - update to use gsi_bundle; rename cstate to wbundle
!   2010-05-31  todling  - better consistency checks; add co/co2
!                        - ready to bypass analysis of (any) meteorological fields
!   2010-06-15  todling  - generalized handling of chemistry
!   2011-02-22  zhu      - add gust,vis,pblh
!   2011-05-15  auligne/todling - generalized cloud handling
!   2011-07-12  zhu      - add do_cw_to_hydro_ad and cw2hydro_ad
!   2011-11-01  eliu     - generalize the use of do_cw_to_hydro_ad
!   2012-02-08  kleist   - remove strong_bk_ad and ensemble_forward_model_ad and related parameters
!   2013-05-23  zhu      - add ntclen and predt for aircraft temperature bias correction
!   2013-10-25  todling  - nullify work pointers
!   2013-10-28  todling  - rename p3d to prse
!   2014-01-31  mkim     - add support for when ql and qi are CVs for all-sky mw radiance DA
!   2014-03-19  pondeca  - add wspd10m
!   2014-04-10  pondeca  - add td2m,mxtm,mitm,pmsl
!   2014-05-07  pondeca  - add howv
!   2014-06-16  carley/zhu - add tcamt and lcbas
!   2014-12-03  derber   - introduce parallel regions for optimization
!   2015-07-10  pondeca  - add cloud ceiling height (cldch)
!   2016-05-03  pondeca  - add uwnd10m, and vwnd10m
!   2017-05-12  Y. Wang and X. Wang - add w as state variable for rw DA, POC: xuguang.wang@ou.edu
!   2016-08-12  lippi    - add vertical velocity (w) to mycvars and mysvars.
!   2016-05-03  pondeca  - add uwnd10m, and vwnd10m
!
!   input argument list:
!     rval - State variable
!     bval
!   output argument list:
!     grad - Control variable
!
!$$$
use kinds, only: i_kind,r_kind
use control_vectors, only: control_vector
use control_vectors, only: cvars3d,cvars2d
use bias_predictors, only: predictors
use gsi_4dvar, only: nsubwin, lsqrtb
use gridmod, only: regional,lat2,lon2,nsig,twodvar_regional
use jfunc, only: nsclen,npclen,ntclen
use cwhydromod, only: cw2hydro_ad
use cwhydromod, only: cw2hydro_ad_hwrf
use gsi_bundlemod, only: gsi_bundlecreate
use gsi_bundlemod, only: gsi_bundle
use gsi_bundlemod, only: gsi_bundlegetpointer
use gsi_bundlemod, only: gsi_bundlegetvar
use gsi_bundlemod, only: gsi_bundleputvar
use gsi_bundlemod, only: gsi_bundledestroy
use gsi_chemguess_mod, only: gsi_chemguess_get
use gsi_metguess_mod, only: gsi_metguess_get
use mpeu_util, only: getindex
use constants, only: max_varname_length,zero
use gridmod, only: nems_nmmb_regional

implicit none

! Declare passed variables
type(gsi_bundle)    , intent(inout) :: rval(nsubwin)
type(predictors)    , intent(in   ) :: bval
type(control_vector), intent(inout) :: grad

! Declare local variables
character(len=*),parameter::myname='control2state_ad'
character(len=max_varname_length),allocatable,dimension(:) :: gases
character(len=max_varname_length),allocatable,dimension(:) :: clouds
integer(i_kind) :: ii,jj,ic,id,ngases,nclouds,istatus,istatus_oz
type(gsi_bundle) :: wbundle ! work bundle

! Note: The following does not aim to get all variables in
!       the state and control vectors, but rather the ones
!       this routines knows how to handle.
integer(i_kind), parameter :: ncvars = 9
integer(i_kind) :: icps(ncvars)
integer(i_kind) :: icpblh,icgust,icvis,icoz,icwspd10m,icw
integer(i_kind) :: ictd2m,icmxtm,icmitm,icpmsl,ichowv
integer(i_kind) :: ictcamt,iclcbas,icsfwter,icvpwter
integer(i_kind) :: iccldch,icuwnd10m,icvwnd10m
character(len=3), parameter :: mycvars(ncvars) = (/  &
                'sf ', 'vp ', 'ps ', 't  ', 'q  ', 'cw ', 'ql ', 'qi ', 'w  ' /)
logical :: lc_sf,lc_vp,lc_w,lc_ps,lc_t,lc_rh,lc_cw,lc_ql,lc_qi
real(r_kind),pointer,dimension(:,:)   :: cv_ps=>NULL()
real(r_kind),pointer,dimension(:,:)   :: cv_lcbas=>NULL()
real(r_kind),pointer,dimension(:,:,:) :: cv_sf=>NULL()
real(r_kind),pointer,dimension(:,:,:) :: cv_vp=>NULL()
!real(r_kind),pointer,dimension(:,:,:) :: cv_w=>NULL()
real(r_kind),pointer,dimension(:,:,:) :: cv_t=>NULL()
real(r_kind),pointer,dimension(:,:,:) :: cv_rh=>NULL()
real(r_kind),pointer,dimension(:,:,:) :: cv_sfwter=>NULL()
real(r_kind),pointer,dimension(:,:,:) :: cv_vpwter=>NULL()

! Declare required local state variables
integer(i_kind), parameter :: nsvars = 12
integer(i_kind) :: isps(nsvars)
character(len=4), parameter :: mysvars(nsvars) = (/  &  ! vars from ST needed here
                'u   ', 'v   ', 'prse', 'q   ', 'tsen', 'ql  ', 'qi  ', 'w   ', &
                'qr  ', 'qs  ', 'qg  ', 'qh  ' /)
logical :: ls_u,ls_v,ls_w,ls_prse,ls_q,ls_tsen,ls_ql,ls_qi
logical :: ls_qr,ls_qs,ls_qg,ls_qh
real(r_kind),pointer,dimension(:,:)   :: rv_ps=>NULL(),rv_sst=>NULL()
real(r_kind),pointer,dimension(:,:)   :: rv_gust=>NULL(),rv_vis=>NULL(),rv_pblh=>NULL()
real(r_kind),pointer,dimension(:,:)   :: rv_wspd10m=>NULL(),rv_tcamt,rv_lcbas=>NULL()
real(r_kind),pointer,dimension(:,:)   :: rv_td2m=>NULL(),rv_mxtm=>NULL(),rv_mitm=>NULL()
real(r_kind),pointer,dimension(:,:)   :: rv_pmsl=>NULL(),rv_howv=>NULL(),rv_cldch=>NULL()
real(r_kind),pointer,dimension(:,:)   :: rv_uwnd10m=>NULL(),rv_vwnd10m=>NULL()
real(r_kind),pointer,dimension(:,:,:) :: rv_u=>NULL(),rv_v=>NULL(),rv_w=>NULL(),rv_dw=>NULL(),rv_prse=>NULL()
real(r_kind),pointer,dimension(:,:,:) :: rv_q=>NULL(),rv_tsen=>NULL(),rv_tv=>NULL(),rv_oz=>NULL()
real(r_kind),pointer,dimension(:,:,:) :: rv_rank3=>NULL()
real(r_kind),pointer,dimension(:,:)   :: rv_rank2=>NULL()

real(r_kind),allocatable,dimension(:,:,:):: uland,vland,uwter,vwter

logical :: do_getuv,do_tv_to_tsen_ad,do_normal_rh_to_q_ad,do_getprs_ad,do_cw_to_hydro_ad
logical :: do_cw_to_hydro_ad_hwrf

!******************************************************************************

if (lsqrtb) then
   write(6,*)trim(myname),': not for sqrt(B)'
   call stop2(311)
end if

! Inquire about clouds
call gsi_metguess_get ('clouds::3d',nclouds,istatus)
if (nclouds>0) then
   allocate(clouds(nclouds))
   call gsi_metguess_get ('clouds::3d',clouds,istatus)
endif

! Inquire about chemistry
call gsi_chemguess_get('dim',ngases,istatus)
if (ngases>0) then
    allocate(gases(ngases))
    call gsi_chemguess_get('gsinames',gases,istatus)
endif

! Since each internal vector [step(jj)] of grad has the same structure, pointers are
! the same independent of the subwindow jj
call gsi_bundlegetpointer (grad%step(1),mycvars,icps,istatus)
lc_sf =icps(1)>0; lc_vp =icps(2)>0; lc_ps =icps(3)>0
lc_t  =icps(4)>0; lc_rh =icps(5)>0; lc_cw =icps(6)>0
lc_ql =icps(7)>0; lc_qi =icps(8)>0; lc_w  =icps(9)>0

! Since each internal vector of xhat has the same structure, pointers are
! the same independent of the subwindow jj
call gsi_bundlegetpointer (rval(1),mysvars,isps,istatus)
ls_u  =isps(1)>0; ls_v   =isps(2)>0; ls_prse=isps(3)>0
ls_q  =isps(4)>0; ls_tsen=isps(5)>0; ls_ql  =isps(6)>0
ls_qi =isps(7)>0; ls_w   =isps(8)>0
ls_qr  =isps(9)>0; ls_qs =isps(10)>0
ls_qg =isps(11)>0; ls_qh =isps(12)>0

! Define what to do depending on what's in CV and SV
do_getuv            =lc_sf.and.lc_vp.and.ls_u  .and.ls_v
do_tv_to_tsen_ad    =lc_t .and.ls_q .and.ls_tsen
do_normal_rh_to_q_ad=lc_t .and.lc_rh.and.ls_prse.and.ls_q
do_getprs_ad        =lc_t .and.lc_ps.and.ls_prse

do_cw_to_hydro_ad=.false.
do_cw_to_hydro_ad_hwrf=.false.
if (regional) then
   do_cw_to_hydro_ad=lc_cw.and.ls_ql.and.ls_qi
   do_cw_to_hydro_ad_hwrf=lc_cw.and.ls_ql.and.ls_qi.and.ls_qr.and.ls_qs.and.ls_qg.and.ls_qh
else
   do_cw_to_hydro_ad=lc_cw.and.ls_tsen.and.ls_ql.and.ls_qi.and.(.not.lc_ql) !ncep global
endif

call gsi_bundlegetpointer (grad%step(1),'oz',icoz,istatus)
call gsi_bundlegetpointer (grad%step(1),'gust',icgust,istatus)
call gsi_bundlegetpointer (grad%step(1),'vis',icvis,istatus)
call gsi_bundlegetpointer (grad%step(1),'pblh',icpblh,istatus)
call gsi_bundlegetpointer (grad%step(1),'wspd10m',icwspd10m,istatus)
call gsi_bundlegetpointer (grad%step(1),'td2m',ictd2m,istatus)
call gsi_bundlegetpointer (grad%step(1),'mxtm',icmxtm,istatus)
call gsi_bundlegetpointer (grad%step(1),'mitm',icmitm,istatus)
call gsi_bundlegetpointer (grad%step(1),'pmsl',icpmsl,istatus)
call gsi_bundlegetpointer (grad%step(1),'howv',ichowv,istatus)
call gsi_bundlegetpointer (grad%step(1),'sfwter',icsfwter,istatus)
call gsi_bundlegetpointer (grad%step(1),'vpwter',icvpwter,istatus)
call gsi_bundlegetpointer (grad%step(1),'w',icw,istatus)
call gsi_bundlegetpointer (grad%step(1),'tcamt',ictcamt,istatus)
call gsi_bundlegetpointer (grad%step(1),'lcbas',iclcbas,istatus)
call gsi_bundlegetpointer (grad%step(1),'cldch',iccldch,istatus)
call gsi_bundlegetpointer (grad%step(1),'uwnd10m',icuwnd10m,istatus)
call gsi_bundlegetpointer (grad%step(1),'vwnd10m',icvwnd10m,istatus)

! Loop over control steps
do jj=1,nsubwin

!  Create a work bundle similar to grad control vector's bundle
   call gsi_bundlecreate ( wbundle, grad%step(jj), 'control2state_ad work', istatus )
   if (istatus/=0) then
      write(6,*) trim(myname),': trouble creating work bundle'
      call stop2(999)
   endif

!$omp parallel sections private(istatus,ii,ic,id,istatus_oz,rv_u,rv_v,rv_prse,rv_q,rv_tsen,uland,vland,uwter,vwter)

!$omp section

   call gsi_bundlegetpointer (wbundle,'sf' ,cv_sf ,istatus)
   call gsi_bundlegetpointer (wbundle,'vp' ,cv_vp ,istatus)
   call gsi_bundlegetpointer (rval(jj),'u'   ,rv_u,   istatus)
   call gsi_bundlegetpointer (rval(jj),'v'   ,rv_v,   istatus)
   call gsi_bundleputvar ( wbundle, 'sf',  zero,   istatus )
   call gsi_bundleputvar ( wbundle, 'vp',  zero,   istatus )
!  Convert RHS calculations for u,v to st/vp for application of
!  background error
   if (do_getuv) then
       if (twodvar_regional .and. icsfwter>0 .and. icvpwter>0) then
           call gsi_bundlegetpointer (wbundle,'sfwter', cv_sfwter,istatus)
           call gsi_bundlegetpointer (wbundle,'vpwter', cv_vpwter,istatus)
           allocate(uland(lat2,lon2,nsig),vland(lat2,lon2,nsig), &
                    uwter(lat2,lon2,nsig),vwter(lat2,lon2,nsig))

           uland=zero ; uwter=zero
           vland=zero ; vwter=zero

           call landlake_uvmerge(rv_u,rv_v,uland,vland,uwter,vwter,0)

           call getuv(uwter,vwter,cv_sfwter,cv_vpwter,1)
           call getuv(uland,vland,cv_sf,cv_vp,1)
           deallocate(uland,vland,uwter,vwter)
         else
           call getuv(rv_u,rv_v,cv_sf,cv_vp,1)
       endif
   endif

   if(jj == 1)then
      do ii=1,nsclen
        grad%predr(ii)=bval%predr(ii)
      enddo
      do ii=1,npclen
        grad%predp(ii)=bval%predp(ii)
      enddo
      if (ntclen>0) then
         do ii=1,ntclen
           grad%predt(ii)=bval%predt(ii)
         enddo
      end if
   end if

!$omp section

!  Get pointers to required control variables
   call gsi_bundlegetpointer (wbundle,'ps' ,cv_ps ,istatus)
   call gsi_bundlegetpointer (wbundle,'t'  ,cv_t,  istatus)
   call gsi_bundlegetpointer (wbundle,'q'  ,cv_rh ,istatus)

!  Get pointers to this subwin require state variables
   call gsi_bundlegetpointer (rval(jj),'ps'  ,rv_ps,  istatus)
   call gsi_bundlegetpointer (rval(jj),'prse',rv_prse,istatus)
   call gsi_bundlegetpointer (rval(jj),'tv'  ,rv_tv,  istatus)
   call gsi_bundlegetpointer (rval(jj),'tsen',rv_tsen,istatus)
   call gsi_bundlegetpointer (rval(jj),'q'   ,rv_q ,  istatus)

!  Adjoint of control to initial state
   call gsi_bundleputvar ( wbundle, 't' ,  rv_tv,  istatus )
   call gsi_bundleputvar ( wbundle, 'q' ,  zero,   istatus )
   call gsi_bundleputvar ( wbundle, 'ps',  rv_ps,  istatus )

   if (do_cw_to_hydro_ad .and. .not.do_cw_to_hydro_ad_hwrf) then
!     Case when cloud-vars do not map one-to-one
!     e.g. cw-to-ql&qi
      call cw2hydro_ad(rval(jj),wbundle,clouds,nclouds)
   elseif (do_cw_to_hydro_ad_hwrf) then
!     Case when cloud-vars do not map one-to-one
!     e.g. cw-to-ql&qi&qr&qs&qg&qh
      call cw2hydro_ad_hwrf(rval(jj),wbundle,rv_tsen)
   else
!     Case when cloud-vars map one-to-one, take care of them together
!     e.g. cw-to-cw
      do ic=1,nclouds
         id=getindex(cvars3d,clouds(ic))
         if (id>0) then
            call gsi_bundlegetpointer (rval(jj),clouds(ic),rv_rank3,istatus)
            call gsi_bundleputvar     (wbundle, clouds(ic),rv_rank3,istatus)
         endif
      enddo
   end if
!  Calculate sensible temperature
   if(do_tv_to_tsen_ad) call tv_to_tsen_ad(cv_t,rv_q,rv_tsen)

!  Adjoint of convert input normalized RH to q to add contribution of moisture
!  to t, p , and normalized rh
   if(do_normal_rh_to_q_ad) call normal_rh_to_q_ad(cv_rh,cv_t,rv_prse,rv_q)

!  Adjoint to convert ps to 3-d pressure
   if(do_getprs_ad) call getprs_ad(cv_ps,cv_t,rv_prse)

!$omp section

   call gsi_bundlegetpointer (rval(jj),'sst' ,rv_sst, istatus)
   call gsi_bundleputvar ( wbundle, 'sst', rv_sst, istatus )

!  call gsi_bundlegetpointer (rval(jj),'oz'  ,rv_oz , istatus)
   call gsi_bundlegetpointer (rval(jj),'oz'  ,rv_oz , istatus_oz)

   if (icoz>0) then
      call gsi_bundleputvar ( wbundle, 'oz',  rv_oz,  istatus )
   else
      if(istatus_oz==0) rv_oz=zero
   end if

!  Same one-to-one map for chemistry-vars; take care of them together
   do ic=1,ngases
      id=getindex(cvars3d,gases(ic))
      if (id>0) then
          call gsi_bundlegetpointer (rval(jj),gases(ic),rv_rank3,istatus)
          call gsi_bundleputvar     (wbundle, gases(ic),rv_rank3,istatus)
      endif
      id=getindex(cvars2d,gases(ic))
      if (id>0) then
          call gsi_bundlegetpointer (rval(jj),gases(ic),rv_rank2,istatus)
          call gsi_bundleputvar     (wbundle, gases(ic),rv_rank2,istatus)
      endif
   enddo

   if (icgust>0) then
      call gsi_bundlegetpointer (rval(jj),'gust' ,rv_gust, istatus)
      call gsi_bundleputvar ( wbundle, 'gust', rv_gust, istatus )
   end if
   if (icvis >0) then
      call gsi_bundlegetpointer (rval(jj),'vis'  ,rv_vis , istatus)
      call gsi_bundleputvar ( wbundle, 'vis' , rv_vis   , istatus )
   end if
   if (icpblh>0)then
      call gsi_bundlegetpointer (rval(jj),'pblh' ,rv_pblh, istatus)
      call gsi_bundleputvar ( wbundle, 'pblh', rv_pblh, istatus )
   end if
   if (icwspd10m>0) then
      call gsi_bundlegetpointer (rval(jj),'wspd10m' ,rv_wspd10m, istatus)
      call gsi_bundleputvar ( wbundle, 'wspd10m', rv_wspd10m, istatus )
   end if
   if (ictd2m>0) then
      call gsi_bundlegetpointer (rval(jj),'td2m' ,rv_td2m, istatus)
      call gsi_bundleputvar ( wbundle, 'td2m', rv_td2m, istatus )
   end if
   if (icmxtm>0) then
      call gsi_bundlegetpointer (rval(jj),'mxtm' ,rv_mxtm, istatus)
      call gsi_bundleputvar ( wbundle, 'mxtm', rv_mxtm, istatus )
   end if
   if (icmitm>0) then
      call gsi_bundlegetpointer (rval(jj),'mitm' ,rv_mitm, istatus)
      call gsi_bundleputvar ( wbundle, 'mitm', rv_mitm, istatus )
   end if
   if (icpmsl>0) then
      call gsi_bundlegetpointer (rval(jj),'pmsl' ,rv_pmsl, istatus)
      call gsi_bundleputvar ( wbundle, 'pmsl', rv_pmsl, istatus )
   end if
   if (ichowv>0) then
      call gsi_bundlegetpointer (rval(jj),'howv' ,rv_howv, istatus)
      call gsi_bundleputvar ( wbundle, 'howv', rv_howv, istatus )
   end if
   if (icw>0) then
      call gsi_bundlegetpointer (rval(jj),'w' ,rv_w, istatus)
      call gsi_bundleputvar ( wbundle, 'w', rv_w, istatus )
      if(nems_nmmb_regional)then
         call gsi_bundlegetpointer (rval(jj),'dw' ,rv_dw, istatus)
         call gsi_bundleputvar ( wbundle, 'dw', rv_dw, istatus )
       end if
   end if
   if (ictcamt>0) then
      call gsi_bundlegetpointer (rval(jj),'tcamt',rv_tcamt, istatus)
      call gsi_bundleputvar ( wbundle, 'tcamt', rv_tcamt, istatus )
   end if
   if (iclcbas>0) then
      call gsi_bundlegetpointer (wbundle,'lcbas',cv_lcbas,istatus)
      call gsi_bundlegetpointer (rval(jj),'lcbas',rv_lcbas, istatus)
      call gsi_bundleputvar ( wbundle, 'lcbas', zero, istatus )
      !  Adjoint of convert loglcbas to lcbas
      call loglcbas_to_lcbas_ad(cv_lcbas,rv_lcbas)
   end if
   if (iccldch >0) then
      call gsi_bundlegetpointer (rval(jj),'cldch' ,rv_cldch , istatus)
      call gsi_bundleputvar ( wbundle, 'cldch' , rv_cldch  , istatus )
   end if
   if (icuwnd10m>0) then
      call gsi_bundlegetpointer (rval(jj),'uwnd10m' ,rv_uwnd10m, istatus)
      call gsi_bundleputvar ( wbundle, 'uwnd10m', rv_uwnd10m, istatus )
   end if
   if (icvwnd10m>0) then
      call gsi_bundlegetpointer (rval(jj),'vwnd10m' ,rv_vwnd10m, istatus)
      call gsi_bundleputvar ( wbundle, 'vwnd10m', rv_vwnd10m, istatus )
   end if

!$omp end parallel sections

!  Adjoint of transfer variables

   do ii=1,wbundle%ndim
      grad%step(jj)%values(ii)=wbundle%values(ii)+grad%step(jj)%values(ii)
   enddo
   call gsi_bundledestroy(wbundle,istatus)
   if (istatus/=0) then
      write(6,*) trim(myname),': trouble destroying work bundle'
      call stop2(999)
   endif

end do

! Clean up
if (ngases>0) deallocate(gases)

if (nclouds>0) deallocate(clouds)

return
end subroutine control2state_ad


*
*     -------------------------------------------------------------
*      T W O 2 A
*     -------------------------------------------------------------
*                                                                  *
*                                                                  *
*     THIS PACKAGE DETERMINES THE VALUES OF MATRIX ELEMENTS        *
*     OF ONE PARTICLE OPERATOR IN CASE :           N'1 = N1        *
*                                                                  *
*                                                                  *
*     Written by G. Gaigalas,                                      *
*     Vanderbilt University,  Nashville             October 1996   *
*
      SUBROUTINE TWO2A(IA,IB)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
      COMMON/MEDEFN/IHSH,NJ(16),LJ(16),NOSH1(16),NOSH2(16),J1QN1(31,3),
     :     J1QN2(31,3),IJFUL(16)
      COMMON/TRK/BD1(3),BD2(3),BK1(3),BK2(3),
     *ID1(7),ID2(7),IK1(7),IK2(7)
      COMMON/PERMAT/IRS(2,2),IRL(20,20),RS(2,2),RL(20,20)
      COMMON/KAMPAS/ IW1(2,20),IW2(2,20),IWAA(2,2,20,20),
     :RW1(2,20),RW2(2,20),RWAA(2,2,20,20)
      COMMON /CASEOP/ IOCASE
      EXTERNAL TWO2
      IF(IHSH.LE.1)RETURN
*
      IF(IOCASE.EQ.1) THEN
* Spin - spin      operator
	KGAL=2
      ELSEIF(IOCASE.EQ.2) THEN
* Spin-other-orbit operator
	KGAL=1
      ENDIF
*
      IIA=MIN0(IA,IB)
      IIB=MAX0(IA,IB)
      CALL RLSP0(1,IIA,IIB,0,IAT)
      IF(IAT.EQ.0) RETURN
      CALL RLSP0(2,IIA,IIB,2*KGAL,IAT)
      IF(IAT.EQ.0) RETURN
      CALL RLSP0(3,IIA,IIB,2*KGAL,IAT)
      IF(IAT.EQ.0) RETURN
      CALL HIBFF(IA,IB,IA,IA,2)
      IF(IABS(IK1(6)-ID1(6)).GT.2) RETURN
      IF(IABS(IK2(6)-ID2(6)).GT.2) RETURN
      IF(IABS(IK1(5)-ID1(5)).GT.4*IK1(3)) RETURN
      IF(IABS(IK2(5)-ID2(5)).GT.4*IK2(3)) RETURN
      DO 3 I1=1,2
        DO 4 I2=1,2
          IRS(I1,I2)=0
    4   CONTINUE
    3 CONTINUE
      DO 5 I1=1,20
        IW1(1,I1)=0
        IW1(2,I1)=0
        IW2(1,I1)=0
        IW2(2,I1)=0
        DO 6 I2=1,20
          IRL(I1,I2)=0
    6   CONTINUE
    5 CONTINUE
      IP=IABS(LJ(IB)-LJ(IA))+1
      IG=LJ(IB)+LJ(IA)+1
      DO 1 I=IP,IG,2
        KL=I-1
        IF(IOCASE.EQ.1) THEN
* Spin-spin operator
          CALL SS1122(IG,KL,IA,IB)
        ELSEIF(IOCASE.EQ.2) THEN
* Spin-other-orbit operator
	  CALL SOO1122P(IG,KL,IA,IB,IB,IB,IA,IA,IB,IB,KL,TWO2)
C          CALL SOO1122(IG,KL,IA,IB,TWO2)
        ENDIF
    1 CONTINUE
      RETURN
      END