!--------------------------------------------------------------------------------------
program HS_efficiencies
!
! This example program is part of HiggsSignals (TS 27/08/2013).
!--------------------------------------------------------------------------------------
! This example program demonstrates how models with different channel efficiencies
! of the Higgs searches can be treated in HiggsSignals (HS).
!--------------------------------------------------------------------------------------
! use theory_colliderSfunctions
! use usefulbits, only : vsmall
! use usefulbits_hs,only : analyses
! use pc_chisq, only : print_peaks_to_LaTeX
 use io, only : get_peakinfo_from_HSresults, get_number_of_observables,&
 &              get_ID_of_peakobservable, get_peak_channels

 implicit none
 integer :: nH,nHplus,ndf, jj, kk, ll, mm
 double precision :: Chisq, Chisq_mu, Chisq_mh, Pvalue
 double precision, allocatable :: dMh(:)
 double precision :: dCS(5),dBR(5),dggh, dbbh
  double precision :: SMGamma_h
  double precision :: Mh,GammaTotal,g2hjss_s,g2hjss_p,g2hjcc_s,g2hjcc_p,&
&                     g2hjbb_s,g2hjbb_p,g2hjtt_s,g2hjtt_p,&
&                     g2hjmumu_s,g2hjmumu_p,g2hjtautau_s,g2hjtautau_p,&
&                     g2hjWW,g2hjZZ,g2hjZga,g2hjgaga,g2hjgg,g2hjggZ,&
&                     g2hjhiZ,BR_hjhihi,BR_hjinvisible
  double precision :: mupred, etaZ, sf, mu_average
  integer :: domH, nHcomb
  integer :: ntotal, npeakmu, npeakmh, nmpred, nanalyses, ID, pID
  integer :: i,npoints
  character(len=8) :: istring
  character(len=300) :: inputfilename,outputfilename
  character(len=300) :: stem
  character(LEN=300) :: temp
  integer :: number_args, stat
  integer :: Nc
  integer, allocatable :: channel_IDs(:)
  double precision, allocatable :: efficiencies(:),eff_ratio(:)

!---Note here: We only run HiggsSignals on the lightest Higgs boson. This can be easily
!---extended to all 3 MSSM neutral Higgs bosons. In that case, the effective couplings
!---and mass uncertainties have to be given as arrays of size=nH (Cf. the Higgsbounds
!---manual for HB-3.x.x for how to call HiggsBounds_neutral_input_effC correctly!)
  nH=1
  nHplus=0

  allocate(dMh(nH))
!--n.b. have to set theoretical uncertainties on Higgs mass dMh (in GeV):
  dMh = (/ 0.0D0 /)
!-------------------------- HiggsSignals ------------------------------!

!---- Initialize HiggsSignals and pass the name of the experimental analysis folder  ----!
  call initialize_HiggsSignals(nH,nHplus,"latestresults")
!---- Set the Higgs mass parametrization (1: box, 2:gaussian, 3:box+gaussian)	 	 ----!
  call setup_pdf(2)
!---- Set the output level (0: silent, 1: screen output, 2: even more output,...) 	 ----!
  call setup_output_level(0)
!---- Pass the Higgs mass uncertainty to HiggsSignals							 	 ----!
  call HiggsSignals_neutral_input_MassUncertainty(dMh)
!---- Use symmetric rate errors? (0: original(default), 1: averaged-symmetrical)     ----!
 call setup_symmetricerrors(0)
!---- Allow anti-correlated signal strength measurements? (0: no, 1: yes(default) )  ----!
 call setup_anticorrelations_in_mu(0)
!---- Setup a wider assignment range                                                 ----!
 call setup_assignmentrange(10.0D0)

!----HiggsBounds/Signals effective couplings input.
!  	 These have to be inserted for the model which we want to test, i.e. we would have
!    to write an interface to set via arguments in the executables call, or reading
!    in a text file, etc.
!----For now, we set them by hand to the SM values except for the vector boson couplings,
!    where we set them to a scale factor sf (for demonstration):

 do mm=1,4
  select case(mm)
   case(1)
    outputfilename="results/HS_efficiencies_kv0p5.dat"
   case(2)
    outputfilename="results/HS_efficiencies_kv1p0.dat"
   case(3)
    outputfilename="results/HS_efficiencies_kv1p5.dat"
   case(4)
    outputfilename="results/HS_efficiencies_kv2p0.dat"
   case default
   end select
  open(21,file=outputfilename)

  sf = 0.0D0+(mm)*0.5D0
  g2hjss_s=1d0
  g2hjss_p=0d0
  g2hjcc_s=1d0
  g2hjcc_p=0d0
  g2hjbb_s=1d0
  g2hjbb_p=0d0
  g2hjtt_s=1d0
  g2hjtt_p=0d0
  g2hjmumu_s=1d0
  g2hjmumu_p=0d0
  g2hjtautau_s=1d0
  g2hjtautau_p=0d0
  g2hjWW=sf
  g2hjZZ=sf
  g2hjZga=sf
  g2hjgaga=1d0
  g2hjgg=1d0
  g2hjggZ=sf
  g2hjhiZ=0d0
  BR_hjhihi=0d0
  BR_hjinvisible=0d0
  Mh=dble(125.8)
  GammaTotal=SMGamma_h(Mh)

!-Set the HiggsSignals input
  call HiggsBounds_neutral_input_effC(Mh,GammaTotal,&
&    g2hjss_s,g2hjss_p,g2hjcc_s,g2hjcc_p,g2hjbb_s,g2hjbb_p,&
&    g2hjtt_s,g2hjtt_p,&
&    g2hjmumu_s,g2hjmumu_p,g2hjtautau_s,g2hjtautau_p,&
&    g2hjWW,g2hjZZ,g2hjZga,g2hjgaga,g2hjgg,g2hjggZ,&
&    g2hjhiZ, BR_hjinvisible,BR_hjhihi)

!-Run HS on the original experimental data in order to evaluate the model predictions
  call run_HiggsSignals(1, Chisq_mu, Chisq_mh, Chisq, ndf, Pvalue)

!-Get the number of the peak-observables (Don't care about ntotal, npeakmh, nmpred, nanalyses)
  call get_number_of_observables(ntotal, npeakmu, npeakmh, nmpred, nanalyses)

! We now want to set different efficiencies as evaluated e.g. from a MC analysis.
! Note that these are given as relative changes with respect to the SM efficiencies, i.e.
! in the MC you should both test your model and the SM with the analysis cuts and
! estimate the ratio eta = efficiency(model)/efficiency(SM) for each Higgs channel.
!
! As an example, we want to give all VBF,WH,ZH channels a factor of etaZ in all implemented
! searches where these channels are present.

 do ll=1,51
 etaZ = 0.0D0 + (ll-1)*0.05D0
!-Loop over the number of peak observables
  do kk=1,npeakmu
!--Get for each peak observable its unique ID:
   call get_ID_of_peakobservable(kk, ID)
!--Get the predicted signal strength modifier (mupred) for this peak observable:
!   call get_peakinfo_from_HSresults(ID, mupred, domH, nHcomb)
!--Get channel information
   call get_peak_channels(ID, Nc, channel_IDs, efficiencies)
!   write(*,*) ID, Nc
!   write(*,*) channel_IDs
!   write(*,*) efficiencies
   allocate(eff_ratio(Nc))
   eff_ratio = 1.0D0
   do jj=lbound(channel_IDs,dim=1),ubound(channel_IDs,dim=1)
!---Get the ID for the production mode (2:VBF, 3:WH, 4:ZH):
    pID = int((channel_IDs(jj)-modulo(channel_IDs(jj),10))/dble(10))
    if(pID.eq.2.or.pID.eq.3.or.pID.eq.4) then
     eff_ratio(jj)=etaZ
    endif
   enddo
!---Hand over the efficiency ratios:
   call assign_modelefficiencies_to_peak(ID, Nc, eff_ratio)
   deallocate(channel_IDs,efficiencies,eff_ratio)
  enddo

!-Set the HiggsSignals input (again!)
  call HiggsBounds_neutral_input_effC(Mh,GammaTotal,&
&    g2hjss_s,g2hjss_p,g2hjcc_s,g2hjcc_p,g2hjbb_s,g2hjbb_p,&
&    g2hjtt_s,g2hjtt_p,&
&    g2hjmumu_s,g2hjmumu_p,g2hjtautau_s,g2hjtautau_p,&
&    g2hjWW,g2hjZZ,g2hjZga,g2hjgaga,g2hjgg,g2hjggZ,&
&    g2hjhiZ, BR_hjinvisible,BR_hjhihi)

  call run_HiggsSignals(1, Chisq_mu, Chisq_mh, Chisq, ndf, Pvalue)

   mu_average = 0.0D0
  do kk=1,npeakmu
!--Get for each peak observable its unique ID:
   call get_ID_of_peakobservable(kk, ID)
!--Get the predicted signal strength modifier (mupred) for this peak observable:
   call get_peakinfo_from_HSresults(ID, mupred, domH, nHcomb)
   mu_average = mu_average + mupred
  enddo
  mu_average = mu_average / npeakmu

  write(21,*) g2hjWW, etaZ, Chisq_mu, mu_average

 enddo
 close(21)
 enddo

 call finish_HiggsSignals

!--------------------------------------------------------------------------------------
end program HS_efficiencies
!--------------------------------------------------------------------------------------


c This module/program is part of DaliLite (c) L. Holm 1999
c
	program seqfitz
c
c	f77 seqfitz.f subfitz.f u3b-8.f
c
	implicit none
	include 'parsizes.for'
	character*5 cd1,cd2
	character*80 dalidatpath_1,dalidatpath_2,findfile,filnam
	character seq1(maxres),seq2(maxres)
	integer nres1,nres2
	integer i,j,score,ali(maxres),lali,iter,maxiter
	integer*2 trace(maxres,maxres,2)
	integer*2 table0(maxres,maxres)
	real rms,rcut,u(3,3),t(3),ca1(3,maxres),ca2(3,maxres)
c
	write(*,*),'enter cd1, cd2, dalidatpath_1, _2, fitzrcut, fitzmaxiter'
	read(*,500) cd1
	read(*,500) cd2
	read(*,510) dalidatpath_1
	read(*,510) dalidatpath_2
	read(*,*) rcut
	read(*,*) maxiter
c
	call setup(cd1,nres1,ca1,99,dalidatpath_1,seq1)
	call setup(cd2,nres2,ca2,99,dalidatpath_2,seq2)
c
	call fillseq(nres1,nres2,seq1,seq2,table0)
	call nw_maxsim(nres1,nres2,table0,score,ali,trace)
	lali=0
	do i=1,nres1
		if(ali(i).gt.0) lali=lali+1
	end do
c
	if(lali.gt.2) then
		call getut(nres1,ali,ca1,ca2,u,t,lali,rms)
		call transrotate(ca1,nres1,u,t)
		call fitz(ca1,nres1,ca2,nres2,ali,rcut,maxiter,rms,lali,iter)
	end if
	write(*,520),cd1,cd2,(0,j=1,5),rms,lali,iter,nres1,(ali(j),j=1,nres1)

500	format(a5)
510	format(a80)
520	format('WOLFITZ ',2a5,5i5,f10.1,3i5,<maxres>i4)

	end
c
c-----------------------------------------------------------------------
c
 	subroutine fillseq(nres1,nres2,seq1,seq2,table0)
	implicit none
	integer nres1,nres2
	character seq1(nres1),seq2(nres2)
	integer*2 table0(nres1,nres2)
c
	integer i,j
	character c
c
	do i=1,nres1
		c=seq1(i)
		do j=1,nres2
			if(seq2(j).eq.c) then
				table0(i,j)=1
			else
				table0(i,j)=0
			end if
		end do
	end do

	return
	end
c
c-----------------------------------------------------------------------
c
      function distance(a1,a2,a3,b1,b2,b3)
        implicit none
        real distance,a1,a2,a3,b1,b2,b3
c
        distance=sqrt((a1-b1)*(a1-b1)+(a2-b2)*(a2-b2)+(a3-b3)*(a3-b3))
c
        return
        end
c
c----------------------------------------------------------------------
c
        subroutine setup(cd1,nres,ca,iunit,dalidatpath,seq)
        implicit none
        include 'parsizes.for'
        integer iunit,nres
        real ca(3,maxres)
        character*5 cd1
        character seq(maxres)
c
        character*80 filnam,line,constructfilnam,dalidatpath
        character node_type(maxdom)
        integer i,j,k,idom,nseg
c
        filnam=constructfilnam(cd1,dalidatpath,'.dat')
        open(iunit,file=filnam,status='old',err=219)
                i=0
200             read(iunit,530,end=219) line
		if(line(1:4).ne.'>>>>'.and.line(1:9).ne.'-sequence') goto 200
                i=i+1
                if(i.eq.1) then
                        read(line(11:20),*) nres,nseg
                        do j=1,nseg
                                read(iunit,530) line
                        end do
                        read(iunit,*) ((ca(k,j),k=1,3),j=1,nres)
			goto 200
                end if
		if(line(1:9).ne.'-sequence') goto 200
c               -sequence
                read(iunit,540,end=219) (seq(i),i=1,nres)
219     close(iunit)

500	format(10x,i5)
530	format(a80)
540     format(10x,1x,<maxres>a1)

	return
	end
c
c------------------------------------------------------------------------------
c


module micro_p3_iso_c
  use iso_c_binding
  implicit none

#include "scream_config.f"
#ifdef SCREAM_DOUBLE_PRECISION
# define c_real c_double
#else
# define c_real c_float
#endif

contains
  subroutine append_precision(string, prefix)
    use iso_c_binding

    character(kind=c_char, len=128), intent(inout) :: string
    character(*), intent(in) :: prefix
    real(kind=c_real) :: s

    write (string, '(a,i1,a1)') prefix, sizeof(s), C_NULL_CHAR
  end subroutine append_precision

  subroutine p3_init_c(lookup_file_dir_c, info) bind(c)
    use array_io_mod
    use micro_p3, only: p3_init_a, p3_init_b, p3_set_tables, p3_get_tables

    type(c_ptr), intent(in) :: lookup_file_dir_c
    integer(kind=c_int), intent(out) :: info

    real(kind=c_real), dimension(150), target :: mu_r_table
    real(kind=c_real), dimension(300,10), target :: vn_table, vm_table, revap_table

    character(len=256), pointer :: lookup_file_dir
    character(kind=c_char, len=128) :: mu_r_filename, revap_filename, vn_filename, vm_filename
    integer :: len
    logical :: ok

    call c_f_pointer(lookup_file_dir_c, lookup_file_dir)
    len = index(lookup_file_dir, C_NULL_CHAR) - 1
    call p3_init_a(lookup_file_dir(1:len))

    info = 0
    ok = .false.

    call append_precision(mu_r_filename, c_char_"mu_r_table.dat")
    call append_precision(revap_filename, c_char_"revap_table.dat")
    call append_precision(vn_filename, c_char_"vn_table.dat")
    call append_precision(vm_filename, c_char_"vm_table.dat")
    ok = array_io_file_exists(mu_r_filename) .and. &
         array_io_file_exists(revap_filename) .and. &
         array_io_file_exists(vn_filename) .and. &
         array_io_file_exists(vm_filename)
    if (ok) then
       ok = array_io_read(mu_r_filename, c_loc(mu_r_table), size(mu_r_table)) .and. &
            array_io_read(revap_filename, c_loc(revap_table), size(revap_table)) .and. &
            array_io_read(vn_filename, c_loc(vn_table), size(vn_table)) .and. &
            array_io_read(vm_filename, c_loc(vm_table), size(vm_table))
       if (.not. ok) then
          print *, 'micro_p3_iso_c::p3_init: One or more table files exists but gave a read error.'
          info = -1
       end if
    end if

    if (ok) then
       call p3_set_tables(mu_r_table, revap_table, vn_table, vm_table)
    else
       call p3_init_b()
       call p3_get_tables(mu_r_table, revap_table, vn_table, vm_table)
       ok = array_io_write(mu_r_filename, c_loc(mu_r_table), size(mu_r_table)) .and. &
            array_io_write(revap_filename, c_loc(revap_table), size(revap_table)) .and. &
            array_io_write(vn_filename, c_loc(vn_table), size(vn_table)) .and. &
            array_io_write(vm_filename, c_loc(vm_table), size(vm_table))
       if (.not. ok) then
          print *, 'micro_p3_iso_c::p3_init: Error when writing table files.'
          info = -1
       end if
    end if

  end subroutine p3_init_c

  subroutine p3_main_c(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,nitot,birim,ssat,   &
       pres,dzq,npccn,naai,it,prt_liq,prt_sol,its,ite,kts,kte,diag_ze,diag_effc,     &
       diag_effi,diag_vmi,diag_di,diag_rhoi,log_predictNc_in, &
       pdel,exner,cmeiout,prain,nevapr,prer_evap,rflx,sflx,rcldm,lcldm,icldm,p3_tend_out) bind(C)
    use micro_p3, only : p3_main

    real(kind=c_real), intent(inout), dimension(its:ite,kts:kte) :: qc, nc, qr, nr, ssat, qv, th, th_old, qv_old
    real(kind=c_real), intent(inout), dimension(its:ite,kts:kte) :: qitot, qirim, nitot, birim
    real(kind=c_real), intent(in), dimension(its:ite,kts:kte) :: pres, dzq
    real(kind=c_real), intent(in), dimension(its:ite,kts:kte) :: npccn,naai
    real(kind=c_real), value, intent(in) :: dt
    real(kind=c_real), intent(out), dimension(its:ite) :: prt_liq, prt_sol
    real(kind=c_real), intent(out), dimension(its:ite,kts:kte) :: diag_ze, diag_effc
    real(kind=c_real), intent(out), dimension(its:ite,kts:kte) :: diag_effi, diag_vmi, diag_di, diag_rhoi
    integer(kind=c_int), value, intent(in) :: its,ite, kts,kte, it
    logical(kind=c_bool), value, intent(in) :: log_predictNc_in

    real(kind=c_real), intent(in),    dimension(its:ite,kts:kte)      :: pdel
    real(kind=c_real), intent(in),    dimension(its:ite,kts:kte)      :: exner
    real(kind=c_real), intent(out),   dimension(its:ite,kts:kte)      :: cmeiout
    real(kind=c_real), intent(out),   dimension(its:ite,kts:kte)      :: prain
    real(kind=c_real), intent(out),   dimension(its:ite,kts:kte)      :: nevapr
    real(kind=c_real), intent(out),   dimension(its:ite,kts:kte)      :: prer_evap
    real(kind=c_real), intent(out),   dimension(its:ite,kts:kte+1)    :: rflx
    real(kind=c_real), intent(out),   dimension(its:ite,kts:kte+1)    :: sflx
    real(kind=c_real), intent(in),    dimension(its:ite,kts:kte)      :: icldm, lcldm, rcldm
    real(kind=c_real), intent(out),   dimension(its:ite,kts:kte,49)   :: p3_tend_out

    logical :: log_predictNc

    log_predictNc = log_predictNc_in

    call p3_main(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,nitot,birim,ssat,   &
         pres,dzq,npccn,naai,it,prt_liq,prt_sol,its,ite,kts,kte,diag_ze,diag_effc,     &
         diag_effi,diag_vmi,diag_di,diag_rhoi,log_predictNc, &
         pdel,exner,cmeiout,prain,nevapr,prer_evap,rflx,sflx,rcldm,lcldm,icldm,p3_tend_out)
  end subroutine p3_main_c

  subroutine micro_p3_utils_init_c(Cpair, Rair, RH2O, RhoH2O, &
                 MWH2O, MWdry, gravit, LatVap, LatIce,        &
                 CpLiq, Tmelt, Pi, iulog_in, masterproc_in) bind(C)

    use micro_p3_utils, only: micro_p3_utils_init
    real(kind=c_real), value, intent(in) :: Cpair
    real(kind=c_real), value, intent(in) :: Rair
    real(kind=c_real), value, intent(in) :: RH2O
    real(kind=c_real), value, intent(in) :: RhoH2O
    real(kind=c_real), value, intent(in) :: MWH2O
    real(kind=c_real), value, intent(in) :: MWdry
    real(kind=c_real), value, intent(in) :: gravit
    real(kind=c_real), value, intent(in) :: LatVap
    real(kind=c_real), value, intent(in) :: LatIce
    real(kind=c_real), value, intent(in) :: CpLiq
    real(kind=c_real), value, intent(in) :: Tmelt
    real(kind=c_real), value, intent(in) :: Pi
    integer(kind=c_int), value, intent(in)   :: iulog_in
    logical(kind=c_bool), value, intent(in)  :: masterproc_in

    logical :: masterproc
    integer :: iulog

    masterproc = masterproc_in
    iulog = iulog_in

    call micro_p3_utils_init(Cpair,Rair,RH2O,RhoH2O,MWH2O,MWdry,gravit,LatVap,LatIce, &
                   CpLiq,Tmelt,Pi,iulog,masterproc)
  end subroutine micro_p3_utils_init_c

end module micro_p3_iso_c


      program moog

      implicit real*8 (a-h,o-z)

      include 'mpif.h'
      include 'Atmos.com'
      include 'Dampdat.com'
      include 'Dummy.com'
      include 'Factor.com'
      include 'Kappa.com'
      include 'Linex.com'
      include 'Mol.com'
      include 'Quants.com'

c   The following parameters are set to rank = 0 and size = 1 for non-MPI version
      integer rank, size, ierr
c   A string version of the rank, used to define filenames
      character*3 srank
c   Based on the rank and size, determine the number of synthesis per core.
c   These variables loop through the various synthesis accordingly
      integer nsynths,nnn,mmm,nloop
c   Variables for determining how long it takes to synthesize a spectrum
      real :: cpustart, cpufinish

c   System parameters
      character*250 systemcall

c   Define paths to be used to point to directories
      character*99 moogpath,atmpath,synthpath,binpath,synth_run

c   These variables are for iterating over the various parameters for the
c   the atmospheric models
      integer tempindex
      integer iteff,ilogg,ifeh,ialpha
      real*8 teffarr(34),loggarr(11),feharr(51),alphaarr(21)
      real*8 teffi,loggi,fehi,alphai
      integer nteff,nlogg,nfeh,nalpha

c   Parameters such as filenames for strong line lists and
c   Barklem HI collisional broadening
      character*99 fslines,fbarklem
      integer nfslines,nfbarklem
      integer num, num2

c   Boolean variables
      logical test, replace

c   Variables for a test run, including output directory and a restrictive range
c   for the temperature
      synth_run = 'mpi_test'
      tempindex = 1

      test = .true.
      replace = .true.

      call cpu_time(cpustart)

c   Define the parameter ranges for effective temperature (K), surface gravity
c   (log cm s^(-2)), metallicity [Fe/H] (dex), and alpha to iron ratio [alpha/Fe](dex)

      data teffarr/3500, 3600, 3700, 3800, 3900,
     $             4000, 4100, 4200, 4300, 4400,
     $             4500, 4600, 4700, 4800, 4900,
     $             5000, 5100, 5200, 5300, 5400,
     $             5500, 5600, 5800, 6000, 6200,
     $             6400, 6600, 6800, 7000, 7200,
     $             7400, 7600, 7800, 8000/

      data loggarr/0.0, 0.5, 1.0, 1.5, 2.0, 2.5,
     $             3.0, 3.5, 4.0, 4.5, 5.0/

      data feharr/-5.0, -4.9, -4.8, -4.7, -4.6,
     $            -4.5, -4.4, -4.3, -4.2, -4.1,
     $            -4.0, -3.9, -3.8, -3.7, -3.6,
     $            -3.5, -3.4, -3.3, -3.2, -3.1,
     $            -3.0, -2.9, -2.8, -2.7, -2.6,
     $            -2.5, -2.4, -2.3, -2.2, -2.1,
     $            -2.0, -1.9, -1.8, -1.7, -1.6,
     $            -1.5, -1.4, -1.3, -1.2, -1.1,
     $            -1.0, -0.9, -0.8, -0.7, -0.6,
     $            -0.5, -0.4, -0.3, -0.2, -0.1, 0.0/

      data alphaarr/-0.8, -0.7, -0.6, -0.5, -0.4, -0.3, -0.2, -0.1, 0.0,
     $       0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9, 1.0, 1.1, 1.2/

c   Initialize the MPI execution environment, where ierr is an error return
c   Note that the communicator MPI_COMM_WORLD contains all of the processes
      call MPI_INIT(ierr)
c   Determines the rank of the calling processes in the communicator
c   Returns the rank of the calling processes in the group mpi_comm_world
      call MPI_COMM_RANK(MP_COMM_WORLD, rank, ierr)
c   Determines the size of the group associated with a communicator
c   Returns the number of processes in the group mpi_comm_world
      call MPI_COMM_SIZE(MPI_COMM_WORLD, size, ierr)
      write(*,*)"rank: ",rank," size: ",size," ierr: ",ierr

c******* clear path names
1001  format (99(' '))
1002  format (250(' '))
      write (systemcall,1002)
      write (fslines,1001)
      write (fbarklem,1001)
      write (moogpath,1001)
      write (synthpath,1001)
      write (binpath,1001)
      write (atmpath,1001)

c******* define paths
      moogpath =
     .  '/raid/iescala/moogie/'
      atmpath =
     .  '/raid/grid7/atmospheres'
      synthpath =
     .  '/raid/iescala/gridie/synths'
      binpath =
     .  '/raid/iescala/gridie/bin'

c******* open strong line list and barklem data on HI collisional broadening

      nfbarklem = rank*11+201
      nfslines = rank*11+202

      num=99
c   The subroutine getcount (Getcount.f) counts the number of characters in the
c   specified string, most useful for discovering the length of a filename
      call getcount (num,moogpath)
      if (moogpath(num:num) .ne. '/') then
         num = num + 1
         moogpath(num:num) = '/'
      endif

      write(srank, '(I03)') rank
      if (srank(1:1).eq.' ') srank(1:1)='0'
      if (srank(2:2).eq.' ') srank(2:2)='0'
      if (srank(3:3).eq.' ') srank(3:3)='0'

      num2=99
      call getcount (num2,synth_run)
      if (synth_run(num2:num2) .ne. '/') then
         num2 = num2 + 1
         synth_run(num2:num2) = '/'
      endif

      fslines(1:num+num2)=moogpath(1:num)//synth_run
      fslines(num+1+num2:num+15+num2)=srank//'/full.strong'

      fbarklem(1:num+num2) = moogpath(1:num)//synth_run
      fbarklem(num+1+num2:num+15+num2) = srank//'/Barklem.dat'

      write(*,*) fslines, fbarklem

      open (unit=nfslines,file=fslines,access='sequential',
     .   form='formatted',blank='null',status='old',
     .   iostat=jstat)
      open (unit=nfbarklem,file=fbarklem,access='sequential',
     .   form='formatted',blank='null',status='old',
     .   iostat=jstat)

c******* find total number of interations (nsynths)

      iteff1=tempindex
      iteff2=tempindex

      ilogg1=1
      ilogg2=11

      ifeh1=1
      ifeh2=51

      ialpha1=1
      ialpha2=21

      nsynths=0

      nteff=iteff2-iteff1+1
      nlogg=ilogg2-ilogg1+1
      nfeh=ifeh2-ifeh1+1
      nalpha=ialpha2-ialpha1+1

      do iteff=iteff1,iteff2
         do ilogg=ilogg1,ilogg2
            do ifeh=ifeh1,ifeh2
               do ialpha=ialpha1,ialpha2
                  nsynths=nsynths+1
               enddo
            enddo
         enddo
      enddo

      if (test .eqv. .true.) then
         nsynths=1
      endif
      nloop=floor(real(nsynths)/real(size))+1
      if (rank .eq. 0) then
         write(*,*) "Number of loops:",nloop
      endif

c********* call synth for each iteration

      do mmm=1,nloop
         if ((rank .eq. 0) .and. (replace .eqv. .true.)) then
            write(*,*) "Rank 0 is starting loop:",mmm
         endif
         nnn=((mmm-1)*size)+rank+1
         if (nnn.le.nsynths) then
            iteff=floor(real(nnn-1)/real(nlogg*nfeh*nalpha))
            ilogg=floor(real(nnn-1-iteff*nlogg*nfeh*nalpha)
     .           /real(nfeh*nalpha))
            ifeh=floor(real(nnn-1-iteff*nlogg*nfeh*nalpha-ilogg
     .           *nfeh*nalpha)/real(nalpha))
            ialpha=nnn-1-iteff*nlogg*nfeh*nalpha-ilogg
     .           *nfeh*nalpha-ifeh*nalpha
            iteff=iteff+iteff1
            ilogg=ilogg+ilogg1
            ifeh=ifeh+ifeh1
            ialpha=ialpha+ialpha1

c   Focus on effective temperature < 4200 K and log g < 3.5 cm s^(-2) to start
            if ((iteff .lt. 8) .or. (ilogg .lt. 8)) then
c              write(*,*) iteff, ilogg, ifeh, ialpha
               teffi=teffarr(iteff)
               loggi=loggarr(ilogg)
               fehi=feharr(ifeh)
               alphai=alphaarr(ialpha)

c   Now synthesize the spectrum by calling the subroutine synth (Synthie.f)
               call synth (teffi,loggi,fehi,alphai,rank,nfslines,
     $            nfbarklem,moogpath,atmpath,synthpath,binpath,test,
     $            synth_run,replace)
            endif
         endif
      enddo

c   Terminate the MPI execution environment
      call MPI_FINALIZE(ierr)

      call cpu_time(cpufinish)
      write(*,*)'Elapsed CPU time',cpufinish-cpustart,' seconds'

      end


c***********************************************************************
c
c     dl_poly utility for calculating bond angle statistics
c
c     copyright - daresbury laboratory
c     author    - w. smith
c
c     single processor version
c
c***********************************************************************

      implicit real*8(a-h,o-z)
      parameter(pi=3.1415926536d0)
      parameter(mxtheta=512,mxatms=1080,mxconf=3000,mxcell=2000)

      character*40   fname
      character*80   title
      character*8    name(mxatms)
      dimension lst(mxcell),lct(mxcell),ltype(mxatms)
      dimension nix(27),niy(27),link(mxatms),niz(27)
      dimension xxx(mxatms),yyy(mxatms),zzz(mxatms)
      dimension cell(9),rcell(9),cprp(10),theta(mxtheta)
      dimension latinx(mxatms),chge(mxatms),weight(mxatms)
      data nix/0,-1,-1,-1,0,0,-1,-1,-1,0,1,-1,0,1,
     x  1,1,1,0,0,1,-1,1,0,-1,1,0,-1/
      data niy/0,0,-1,1,1,0,0,0,-1,-1,-1,1,1,1,
     x  0,1,-1,-1,0,0,0,1,1,1,-1,-1,-1/
      data niz/0,0,0,0,0,1,1,1,1,1,1,1,1,1,
     x  0,0,0,0,-1,-1,-1,-1,-1,-1,-1,-1,-1/
c     name of the history
      fname="HISTORY"
c     total number of atoms in the history file configuration
      natms=1080
c     max number of configuration to sample
      nconf=1000
c     the length of theta array
      ncorr=100
      rcut=2.d0
      deltheta=pi/dble(ncorr)
      iflg=0
      keytrj=0
      do i=1,mxtheta
        theta(i)=0.d0
      enddo
      do iconf=0,nconf-1
        call hread(fname,title,name,iflg,imcon,keytrj,
     x    natms,nstep,timestp,cell,chge,weight,xxx,yyy,
     x    zzz,vxx,vyy,vzz,fxx,fyy,fzz)
        if(iflg.lt.0)go to 100

c     check for appropriate boundary conditions

        if(imcon.ge.1.and.imcon.le.3) then

          call invert(cell,rcell,det)
          call dcell(cell,cprp)

        endif

c     calculate link cell numbers

        nbx=int(cprp(7)/(rcut+1.d-6))
        nby=int(cprp(8)/(rcut+1.d-6))
        nbz=int(cprp(9)/(rcut+1.d-6))
        ncells=nbx*nby*nbz

c     transform atomic coodinates and construct link cells
        do i=1,ncells
          lct(i)=0
          lst(i)=0
        enddo
        xdc=dble(nbx)
        ydc=dble(nby)
        zdc=dble(nbz)
        do i=1,natms

          sxx=rcell(1)*xxx(i)+rcell(4)*yyy(i)+rcell(7)*zzz(i)
          syy=rcell(2)*xxx(i)+rcell(5)*yyy(i)+rcell(8)*zzz(i)
          szz=rcell(3)*xxx(i)+rcell(6)*yyy(i)+rcell(9)*zzz(i)
          xxx(i)=sxx
          yyy(i)=syy
          zzz(i)=szz
          ix=int(xdc*(sxx+0.5d0))
          iy=int(ydc*(syy+0.5d0))
          iz=int(zdc*(szz+0.5d0))
          k=1+ix+nbx*(iy+nby*iz)
          lst(k)=lst(k)+1
          link(i)=lct(k)
          lct(k)=i

        enddo

c     loop over central atoms of angles

        ix=0
        iy=1
        iz=1
        do icell=1,ncells
          ix=ix+1
          if(ix.gt.nbx)then
            ix=1
            iy=iy+1
            if(iy.gt.nby)then
              iy=1
              iz=iz+1
            endif
          endif

c     construct mini-list of neighbour cell contents

        k=0
        do kk=1,27

          jx=ix+nix(kk)
          jy=iy+niy(kk)
          jz=iz+niz(kk)
          if(jx.gt.nbx)jx=1
          if(jy.gt.nby)jy=1
          if(jz.gt.nbz)jz=1
          if(jx.lt.1)jx=jx+nbx
          if(jy.lt.1)jy=jy+nby
          if(jz.lt.1)jz=jz+nbz
          jcell=jx+nbx*(jy-1+nby*(jz-1))
          j=lct(jcell)

          do ii=1,lst(jcell)
            k=k+1
            latinx(k)=j
            j=link(j)
          enddo

        enddo
        limit=k

        do ii=1,lst(icell)

          i=latinx(ii)
          if(name(i).eq."Si4+") then
            last=limit
            do kk=1,limit/2

              if(kk.gt.(limit-1)/2)last=limit/2
              do jj=1,last
                j=latinx(jj)
                jk=jj+kk
                if(jk.gt.limit)jk=jk-limit
                k=latinx(jk)

c     make labels etc consistent with angfrc.f

                ia = j
                ib = i
                ic = k

                if(name(ia).eq."O2-")then
                  sxab = xxx(ia)-xxx(ib)
                  sxab = sxab-nint(sxab)
                  syab = yyy(ia)-yyy(ib)
                  syab = syab-nint(syab)
                  szab = zzz(ia)-zzz(ib)
                  szab = szab-nint(szab)
                  xab=cell(1)*sxab+cell(4)*syab+cell(7)*szab
                  if(abs(xab).lt.rcut)then
                    yab=cell(2)*sxab+cell(5)*syab+cell(8)*szab
                    if(abs(yab).lt.rcut)then
                      zab=cell(3)*sxab+cell(6)*syab+cell(9)*szab
                      if(name(ic).eq."O2-")then
                        if(abs(zab).lt.rcut)then
                          sxbc = xxx(ic)-xxx(ib)
                          sxbc = sxbc-nint(sxbc)
                          sybc = yyy(ic)-yyy(ib)
                          sybc = sybc-nint(sybc)
                          szbc = zzz(ic)-zzz(ib)
                          szbc = szbc-nint(szbc)
                          xbc=cell(1)*sxbc+cell(4)*sybc+cell(7)*szbc
                          if(abs(xbc).lt.rcut)then
                            ybc=cell(2)*sxbc+cell(5)*sybc+cell(8)*szbc
                            if(abs(ybc).lt.rcut)then
                              zbc=cell(3)*sxbc+cell(6)*sybc+cell(9)*szbc
                              if(abs(zbc).lt.rcut)then
                                rab=sqrt(xab*xab+yab*yab+zab*zab)
                                rbc=sqrt(xbc*xbc+ybc*ybc+zbc*zbc)
                                if(rcut.ge.max(rab,rbc))then

                                  rrab = 1.d0/rab
                                  rrbc = 1.d0/rbc

c     normalise direction vectors

                                  xab = xab*rrab
                                  yab = yab*rrab
                                  zab = zab*rrab

                                  xbc = xbc*rrbc
                                  ybc = ybc*rrbc
                                  zbc = zbc*rrbc

                                  thet=acos(xab*xbc+yab*ybc+zab*zbc)

                                  kkk=int(thet/deltheta)
                                  theta(kkk)=theta(kkk)+1.d0

                                endif
                              endif
                            endif
                          endif
                        endif
                      endif
                    endif
                  endif
                endif
              enddo
            enddo
          endif
        enddo
      enddo
      enddo
  100 continue
      nconf=iconf-1

c     normalise the angle

      rnorm=0
      do i=2,ncorr-1,2
        rnorm=rnorm+(theta(i-1)+4.d0*theta(i)+theta(i+1))/3.d0
      enddo
      do i=1,ncorr
        theta(i)=theta(i)/rnorm
      enddo
      open(8,file='output')
      do i=1,ncorr
        write(8,'(1p,2e14.6)')deltheta*(dble(i)-0.5d0),theta(i)
      enddo
      close(8)
      end
      subroutine dcell(aaa,bbb)

c
c***********************************************************************
c
c     dl_poly subroutine to calculate the dimensional properties of
c     a simulation cell specified by the input matrix aaa.
c     the results are returned in the array bbb, with :
c
c     bbb(1 to 3) - lengths of cell vectors
c     bbb(4 to 6) - cosines of cell angles
c     bbb(7 to 9) - perpendicular cell widths
c     bbb(10)     - cell volume
c
c     copyright daresbury laboratory 1992
c     author - w. smith         july 1992
c
c***********************************************************************
c

      implicit real*8 (a-h,o-z)

      dimension aaa(9),bbb(10)
c
c     calculate lengths of cell vectors

      bbb(1)=sqrt(aaa(1)*aaa(1)+aaa(2)*aaa(2)+aaa(3)*aaa(3))
      bbb(2)=sqrt(aaa(4)*aaa(4)+aaa(5)*aaa(5)+aaa(6)*aaa(6))
      bbb(3)=sqrt(aaa(7)*aaa(7)+aaa(8)*aaa(8)+aaa(9)*aaa(9))
c
c     calculate cosines of cell angles

      bbb(4)=(aaa(1)*aaa(4)+aaa(2)*aaa(5)+aaa(3)*aaa(6))/(bbb(1)*bbb(2))
      bbb(5)=(aaa(1)*aaa(7)+aaa(2)*aaa(8)+aaa(3)*aaa(9))/(bbb(1)*bbb(3))
      bbb(6)=(aaa(4)*aaa(7)+aaa(5)*aaa(8)+aaa(6)*aaa(9))/(bbb(2)*bbb(3))
c
c     calculate vector products of cell vectors

      axb1=aaa(2)*aaa(6)-aaa(3)*aaa(5)
      axb2=aaa(3)*aaa(4)-aaa(1)*aaa(6)
      axb3=aaa(1)*aaa(5)-aaa(2)*aaa(4)
      bxc1=aaa(5)*aaa(9)-aaa(6)*aaa(8)
      bxc2=aaa(6)*aaa(7)-aaa(4)*aaa(9)
      bxc3=aaa(4)*aaa(8)-aaa(5)*aaa(7)
      cxa1=aaa(8)*aaa(3)-aaa(2)*aaa(9)
      cxa2=aaa(1)*aaa(9)-aaa(3)*aaa(7)
      cxa3=aaa(2)*aaa(7)-aaa(1)*aaa(8)
c
c     calculate volume of cell

      bbb(10)=abs(aaa(1)*bxc1+aaa(2)*bxc2+aaa(3)*bxc3)
c
c     calculate cell perpendicular widths

      bbb(7)=bbb(10)/sqrt(bxc1*bxc1+bxc2*bxc2+bxc3*bxc3)
      bbb(8)=bbb(10)/sqrt(cxa1*cxa1+cxa2*cxa2+cxa3*cxa3)
      bbb(9)=bbb(10)/sqrt(axb1*axb1+axb2*axb2+axb3*axb3)

      return
      end
      subroutine invert(a,b,d)
c
c***********************************************************************
c
c     dl_poly subroutine to invert a 3 * 3 matrix using cofactors
c
c     copyright - daresbury laboratory 1992
c     author    - w. smith       april 1992
c
c***********************************************************************
c

      real*8 a,b,d,r

      dimension a(9),b(9)
c
c     calculate adjoint matrix
      b(1)=a(5)*a(9)-a(6)*a(8)
      b(2)=a(3)*a(8)-a(2)*a(9)
      b(3)=a(2)*a(6)-a(3)*a(5)
      b(4)=a(6)*a(7)-a(4)*a(9)
      b(5)=a(1)*a(9)-a(3)*a(7)
      b(6)=a(3)*a(4)-a(1)*a(6)
      b(7)=a(4)*a(8)-a(5)*a(7)
      b(8)=a(2)*a(7)-a(1)*a(8)
      b(9)=a(1)*a(5)-a(2)*a(4)
c
c     calculate determinant
      d=a(1)*b(1)+a(4)*b(2)+a(7)*b(3)
      r=0.d0
      if(abs(d).gt.0.d0)r=1.d0/d
c
c     complete inverse matrix
      b(1)=r*b(1)
      b(2)=r*b(2)
      b(3)=r*b(3)
      b(4)=r*b(4)
      b(5)=r*b(5)
      b(6)=r*b(6)
      b(7)=r*b(7)
      b(8)=r*b(8)
      b(9)=r*b(9)
      return
      end
      subroutine hread
     x  (history,cfgname,atmnam,iflg,imcon,keytrj,natms,nstep,tstep,
     x   cell,chge,weight,xxx,yyy,zzz,vxx,vyy,vzz,fxx,fyy,fzz)

c
c***********************************************************************
c
c     dl_poly subroutine for reading the formatted history file
c
c     copyright - daresbury laboratory 1996
c     author    - w. smith jan 1996.
c
c     single processor version
c
c***********************************************************************
c

      implicit real*8(a-h,o-z)

      logical new

      character*80 cfgname
      character*40 history
      character*8 atmnam(*),step

      dimension cell(9)
      dimension chge(*),weight(*)
      dimension xxx(*),yyy(*),zzz(*)
      dimension vxx(*),vyy(*),vzz(*)
      dimension fxx(*),fyy(*),fzz(*)

      save new

      data new/.true./,nhist/77/

      iflg=0

c     open history file if new job

      if(new)then

        open(nhist,file=history,status='old',err=100)

        read(nhist,'(a80)',err=200) cfgname
        write(*,'(a,a)')'# History file header: ',cfgname
        read(nhist,'(2i10)',end=200) ktrj,imcon
        if(keytrj.gt.ktrj)then

          if(ktrj.eq.0)write(*,'(a)')'# error - no velocities in file'
          if(keytrj.gt.1)write(*,'(a)')'# error - no forces in file'
          stop

        endif

        new=.false.

      endif

      read(nhist,'(a8,4i10,f12.6)',end=200)
     x    step,nstep,matms,ktrj,imcon,tstep

      if(natms.ne.matms)then

        write(*,'(a)')'# error - incorrect number of atoms in file'
        write(*,'(a,i6,a)')'# file contains',matms,' atoms'
        stop

      endif

      if(imcon.gt.0) read(nhist,'(3g12.4)',end=200) cell

      do i = 1,natms
        read(nhist,'(a8,i10,2f12.6)',end=200)
     x    atmnam(i),j,weight(i),chge(i)
        read(nhist,'(1p,3e12.4)',end=200) xxx(i),yyy(i),zzz(i)
        if(keytrj.ge.1)then
          read(nhist,'(1p,3e12.4)',end=200) vxx(i),vyy(i),vzz(i)
        else if(ktrj.ge.1)then
          read(nhist,'(1p,3e12.4)',end=200) vx,vy,vz
        endif
        if(keytrj.ge.2)then
          read(nhist,'(1p,3e12.4)',end=200) fxx(i),fyy(i),fzz(i)
        else if(ktrj.ge.2)then
          read(nhist,'(1p,3e12.4)',end=200) fx,fy,fz
        endif
      enddo

      iflg=1

      return

  100 continue

      write(*,'(a)')'# error - History file not found'
      stop

  200 continue
      write(*,'(a)')'# warning - end of History file encountered'
      close (nhist)
      iflg=-1

      return
      end


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!     subroutine calc_xi: calculate value as well as first and
!       second derivatives of the reaction coordinate Xi for
!       the different types of implemented reactions
!
!     Disclaimer (taken from with slightly changes):
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   RPMDrate - Bimolecular reaction rates via ring polymer molecular dynamics
!
!   Copyright (c) 2012 by Joshua W. Allen (jwallen@mit.edu)
!                         William H. Green (whgreen@mit.edu)
!                         Yury V. Suleimanov (ysuleyma@mit.edu, ysuleyma@princeton.edu)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
subroutine calc_xi(coords,xi_ideal,xi_act,dxi_act,d2xi_act,mode)
use general
use evb_mod
implicit none
integer::i,j,k,l,i1,i2,j1,j2  ! loop indices
integer::mode  ! if usual umbrella sampling or recrossing shall be calculated!
integer::s0_terms  ! number of interaction betweem sum_eds educt particles
real(kind=8)::coords(3,natoms) ! the actual coordinates
real(kind=8)::Red(3,sum_eds,sum_eds)  ! all possible educt-educt distances
real(kind=8)::r_eds(sum_eds,sum_eds) ! the actual distane between two educts
real(kind=8)::eds_avg  ! the average distance between two educts
real(kind=8)::R_f(3,form_num),R_b(3,break_num)  ! generalized vectors for all bonds
real(kind=8)::form_act(form_num),break_act(break_num)  ! actual bondlengths
real(kind=8)::xi_act  ! the calculated Xi value
real(kind=8)::dxi_act(3,natoms)  ! the calculated Xi derivative
real(kind=8)::d2xi_act(3,natoms,3,natoms)  ! the calculated Xi hessian
real(kind=8)::s0,s1   ! dividing surface values
real(kind=8)::ds0(3,natoms),ds1(3,natoms)  ! the calculated surface derivatives
real(kind=8)::d2s0(3,natoms,3,natoms),d2s1(3,natoms,3,natoms) ! the calculated surface hessians
real(kind=8)::com(sum_eds,3)   ! array with center of mass coordinates
real(kind=8)::Rinv ! the inverse bond length/distance (for derivatives)
real(kind=8)::r_factor(sum_eds,sum_eds)  ! modifying factor in s0 for different distances
real(kind=8)::correct ! local correction for ds0 and d2s0
real(kind=8)::massfactor ! for hessians: factor of two masses
real(kind=8)::dxx,dxy,dxz,dyy,dyz,dzz ! abbreviations for hessian elements
real(kind=8)::xi_ideal  ! the reference xi value (for recrossing)
integer::atom,atom1,atom2 ! the actual atomic indices
!
!    Here methods to calculate the Xi, dXi and d2Xi values/arrays are
!    listed for all supported types of reactions
!
!    Currently these are:
!    1. Bimolecular reaction (one forming, one breaking bond)
!    2. Cycloaddition (two forming bonds)
!    3. Addition (two forming, one breaking bonds)
!    4. Addition3 (three forming, two breaking bonds)
!
!    #############################################################################
!    1 THE BIMOLECULAR REACTION (ONE FORMING, ONE BREAKING)
!
if ((umbr_type .eq. "BIMOLEC") .or. (umbr_type .eq. "CYCLOADD") &
    & .or. (umbr_type .eq. "ADDITION") .or. (umbr_type .eq. "ADDITION3") &
    & .or. (umbr_type .eq. "ADDITION4") .or. (umbr_type .eq. "ADD3_SOLV") &
    & .or. (umbr_type .eq. "ADD4_SOLV") .or. (umbr_type .eq. "MERGING")) then
!
!    STEP1: calculate the bondlengths and then the Xi-value
!
!
!    the forming bonds (in total form_num bonds)
!
   do i=1,form_num
      atom1=bond_form(i,1)
      atom2=bond_form(i,2)
      R_f(1,i)=coords(1,atom1) - coords(1,atom2)
      R_f(2,i)=coords(2,atom1) - coords(2,atom2)
      R_f(3,i)=coords(3,atom1) - coords(3,atom2)
      form_act(i)=sqrt(R_f(1,i)*R_f(1,i)+R_f(2,i)*R_f(2,i)+R_f(3,i)*R_f(3,i))
   end do
!
!    the breaking bonds (in total break_num bonds)
!
   do i=1,break_num
      atom1=bond_break(i,1)
      atom2=bond_break(i,2)
      R_b(1,i)=coords(1,atom1) - coords(1,atom2)
      R_b(2,i)=coords(2,atom1) - coords(2,atom2)
      R_b(3,i)=coords(3,atom1) - coords(3,atom2)
      break_act(i)=sqrt(R_b(1,i)*R_b(1,i)+R_b(2,i)*R_b(2,i)+R_b(3,i)*R_b(3,i))
   end do

!
!    value of the TS dividing surface funtion: sum up all breaking
!    bond differences and divide this through the total number of
!    breaking and sum up all forming bond differences and divide this
!    through the total numbe of forming
!
   s1=0.d0
   do i=1,break_num
      s1=s1+(break_act(i)-break_ref(i))/real(break_num)
   end do
   do i=1,form_num
      s1=s1-(form_act(i)-form_ref(i))/real(form_num)
   end do

!
!    value of the reactant dividing surface function
!    calculate the difference between center of masses of both reactands
!    and compare it to the predefined R_inf distance (no interaction)
!
!   write(*,*) "coords2",coords
   call calc_com(coords,com)
!
!    calclate the R_ed matrix will all needed combination
!    (upper triangular matrix)
!    and apply its elements to the s0 coordinate
!
   r_eds=0.d0
   s0=0.d0
   do i=1,sum_eds
      do j=i+1,sum_eds
         Red(1,i,j)=com(j,1)-com(i,1)
         Red(2,i,j)=com(j,2)-com(i,2)
         Red(3,i,j)=com(j,3)-com(i,3)
         r_eds(i,j)=sqrt(Red(1,i,j)*Red(1,i,j) + Red(2,i,j)*Red(2,i,j) &
            & + Red(3,i,j)*Red(3,i,j))
         s0=s0+(R_inf-r_eds(i,j))
      end do
   end do
!   write(*,*) "s0 calculation",s0
!
!    divide the surface function through the number of interactions
!    (n_ed^2-n_ed)/2
!
   s0_terms=(sum_eds*sum_eds-sum_eds)/2
   s0=s0/real(s0_terms)
!
!     Try to enforce similar values for all possible educt-educt distances
!     calculate average and the deviation to it to correct the actual values
!
!   eds_avg=sum(r_eds)/real(s0_terms)
!   do i=1,sum_eds
!      do j=i+1,sum_eds
!          r_factor(i,j)=1/((2*r_eds(i,j)-eds_avg)/r_eds(i,j) )
!          write(*,*) i,j,eds_avg,r_eds(i,j),r_factor(i,j)
!         r_eds(i,j)=eds_avg !r_eds(i,j)+(-eds_avg+r_eds(i,j))
!      end do
!   end do
!   write(*,*) s0_terms,sum(r_eds)
!   write(*,*) "r12,r13,r23",r_eds(1,2),r_eds(1,3),r_eds(2,3),eds_avg
!   write(*,*) "s0,s1",s0,s1
!
!    calculate Xi value with the RPMDrate formula
!
!    for usual umbrella sampling
!
   if (mode .eq. 1) then
      xi_act=s0/(s0-s1)
!      write(*,*) "xi_act",xi_ideal,xi_act,s0,s1
!
!    for recrossing calculation
!
   else if (mode .eq. 2) then
      xi_act=xi_ideal*s1+(1-xi_ideal)*s0
!      write(*,*) "xi_act",xi_act,xi_ideal,s0,s1
   end if
!
!     STEP2: calculate the gradient of reaction coordinate
!
!
!     The transition state dividing surface
!
   ds1=0.d0
!
!     the forming bonds (in total, n_form forming bonds)
!
   do i=1,form_num
      atom1=bond_form(i,1)
      atom2=bond_form(i,2)
      Rinv=1.d0/form_act(i)
      ds1(1,atom1) = ds1(1,atom1) - R_f(1,i) * Rinv/real(form_num)
      ds1(2,atom1) = ds1(2,atom1) - R_f(2,i) * Rinv/real(form_num)
      ds1(3,atom1) = ds1(3,atom1) - R_f(3,i) * Rinv/real(form_num)
      ds1(1,atom2) = ds1(1,atom2) + R_f(1,i) * Rinv/real(form_num)
      ds1(2,atom2) = ds1(2,atom2) + R_f(2,i) * Rinv/real(form_num)
      ds1(3,atom2) = ds1(3,atom2) + R_f(3,i) * Rinv/real(form_num)
   end do
!
!     the breaking bonds (in total, n_break breaking bonds)
!
   do i=1,break_num
      atom1=bond_break(i,1)
      atom2=bond_break(i,2)
      Rinv=1.d0/break_act(i)
      ds1(1,atom1) = ds1(1,atom1) + R_b(1,i) * Rinv/real(break_num)
      ds1(2,atom1) = ds1(2,atom1) + R_b(2,i) * Rinv/real(break_num)
      ds1(3,atom1) = ds1(3,atom1) + R_b(3,i) * Rinv/real(break_num)
      ds1(1,atom2) = ds1(1,atom2) - R_b(1,i) * Rinv/real(break_num)
      ds1(2,atom2) = ds1(2,atom2) - R_b(2,i) * Rinv/real(break_num)
      ds1(3,atom2) = ds1(3,atom2) - R_b(3,i) * Rinv/real(break_num)
   end do

!
!     The educts dividing surface
!

   ds0=0.d0
   do i=1,sum_eds
      do j=i+1,sum_eds
         Rinv=1.d0/r_eds(i,j)
         do k=1,n_ed(i)
            atom=at_ed(i,k)
            ds0(1,atom)=ds0(1,atom)+Red(1,i,j)*Rinv*mass(atom)/mass_ed(i)/real(s0_terms)
            ds0(2,atom)=ds0(2,atom)+Red(2,i,j)*Rinv*mass(atom)/mass_ed(i)/real(s0_terms)
            ds0(3,atom)=ds0(3,atom)+Red(3,i,j)*Rinv*mass(atom)/mass_ed(i)/real(s0_terms)
         end do
         do k=1,n_ed(j)
            atom=at_ed(j,k)
            ds0(1,atom)=ds0(1,atom)-Red(1,i,j)*Rinv*mass(atom)/mass_ed(j)/real(s0_terms)
            ds0(2,atom)=ds0(2,atom)-Red(2,i,j)*Rinv*mass(atom)/mass_ed(j)/real(s0_terms)
            ds0(3,atom)=ds0(3,atom)-Red(3,i,j)*Rinv*mass(atom)/mass_ed(j)/real(s0_terms)
         end do
      end do
   end do
!
!     For usual umbrella sampling
!
   if (mode .eq. 1) then
      dxi_act=(s0*ds1-s1*ds0)/((s0-s1)*(s0-s1))
!
!     For recrossing calculation
!
   else if (mode .eq. 2) then
      dxi_act=xi_ideal*ds1+(1-xi_ideal)*ds0
   end if

!
!     STEP3: calculate the hessian of the reaction coordinate
!      (I don´t know why this is needed!)
!
!
!     The transition state dividing surface
!
   d2s1=0.d0
!
!     the forming bonds (in total form_num forming bonds)
!
   do i=1,form_num
      atom1=bond_form(i,1)
      atom2=bond_form(i,2)
      Rinv=1.d0/form_act(i)

      dxx = -(R_f(2,i) * R_f(2,i) + R_f(3,i) * R_f(3,i)) * (Rinv * Rinv * Rinv)
      dyy = -(R_f(3,i) * R_f(3,i) + R_f(1,i) * R_f(1,i)) * (Rinv * Rinv * Rinv)
      dzz = -(R_f(1,i) * R_f(1,i) + R_f(2,i) * R_f(2,i)) * (Rinv * Rinv * Rinv)
      dxy = R_f(1,i) * R_f(2,i) * (Rinv * Rinv * Rinv)
      dxz = R_f(1,i) * R_f(3,i) * (Rinv * Rinv * Rinv)
      dyz = R_f(2,i) * R_f(3,i) * (Rinv * Rinv * Rinv)

      d2s1(1,atom1,1,atom1) = d2s1(1,atom1,1,atom1) + dxx/real(form_num)
      d2s1(1,atom1,2,atom1) = d2s1(1,atom1,2,atom1) + dxy/real(form_num)
      d2s1(1,atom1,3,atom1) = d2s1(1,atom1,3,atom1) + dxz/real(form_num)
      d2s1(2,atom1,1,atom1) = d2s1(2,atom1,1,atom1) + dxy/real(form_num)
      d2s1(2,atom1,2,atom1) = d2s1(2,atom1,2,atom1) + dyy/real(form_num)
      d2s1(2,atom1,3,atom1) = d2s1(2,atom1,3,atom1) + dyz/real(form_num)
      d2s1(3,atom1,1,atom1) = d2s1(3,atom1,1,atom1) + dxz/real(form_num)
      d2s1(3,atom1,2,atom1) = d2s1(3,atom1,2,atom1) + dyz/real(form_num)
      d2s1(3,atom1,3,atom1) = d2s1(3,atom1,3,atom1) + dzz/real(form_num)

      d2s1(1,atom1,1,atom2) = d2s1(1,atom1,1,atom2) - dxx/real(form_num)
      d2s1(1,atom1,2,atom2) = d2s1(1,atom1,2,atom2) - dxy/real(form_num)
      d2s1(1,atom1,3,atom2) = d2s1(1,atom1,3,atom2) - dxz/real(form_num)
      d2s1(2,atom1,1,atom2) = d2s1(2,atom1,1,atom2) - dxy/real(form_num)
      d2s1(2,atom1,2,atom2) = d2s1(2,atom1,2,atom2) - dyy/real(form_num)
      d2s1(2,atom1,3,atom2) = d2s1(2,atom1,3,atom2) - dyz/real(form_num)
      d2s1(3,atom1,1,atom2) = d2s1(3,atom1,1,atom2) - dxz/real(form_num)
      d2s1(3,atom1,2,atom2) = d2s1(3,atom1,2,atom2) - dyz/real(form_num)
      d2s1(3,atom1,3,atom2) = d2s1(3,atom1,3,atom2) - dzz/real(form_num)

      d2s1(1,atom2,1,atom1) = d2s1(1,atom2,1,atom1) - dxx/real(form_num)
      d2s1(1,atom2,2,atom1) = d2s1(1,atom2,2,atom1) - dxy/real(form_num)
      d2s1(1,atom2,3,atom1) = d2s1(1,atom2,3,atom1) - dxz/real(form_num)
      d2s1(2,atom2,1,atom1) = d2s1(2,atom2,1,atom1) - dxy/real(form_num)
      d2s1(2,atom2,2,atom1) = d2s1(2,atom2,2,atom1) - dyy/real(form_num)
      d2s1(2,atom2,3,atom1) = d2s1(2,atom2,3,atom1) - dyz/real(form_num)
      d2s1(3,atom2,1,atom1) = d2s1(3,atom2,1,atom1) - dxz/real(form_num)
      d2s1(3,atom2,2,atom1) = d2s1(3,atom2,2,atom1) - dyz/real(form_num)
      d2s1(3,atom2,3,atom1) = d2s1(3,atom2,3,atom1) - dzz/real(form_num)

      d2s1(1,atom2,1,atom2) = d2s1(1,atom2,1,atom2) + dxx/real(form_num)
      d2s1(1,atom2,2,atom2) = d2s1(1,atom2,2,atom2) + dxy/real(form_num)
      d2s1(1,atom2,3,atom2) = d2s1(1,atom2,3,atom2) + dxz/real(form_num)
      d2s1(2,atom2,1,atom2) = d2s1(2,atom2,1,atom2) + dxy/real(form_num)
      d2s1(2,atom2,2,atom2) = d2s1(2,atom2,2,atom2) + dyy/real(form_num)
      d2s1(2,atom2,3,atom2) = d2s1(2,atom2,3,atom2) + dyz/real(form_num)
      d2s1(3,atom2,1,atom2) = d2s1(3,atom2,1,atom2) + dxz/real(form_num)
      d2s1(3,atom2,2,atom2) = d2s1(3,atom2,2,atom2) + dyz/real(form_num)
      d2s1(3,atom2,3,atom2) = d2s1(3,atom2,3,atom2) + dzz/real(form_num)
   end do
!
!    the breaking bonds (in total break_num breaking bonds)
!
   do i=1,break_num
      atom1=bond_break(i,1)
      atom2=bond_break(i,2)
      Rinv=1.d0/break_act(i)

      dxx = (R_b(2,i) * R_b(2,i) + R_b(3,i) * R_b(3,i)) * (Rinv * Rinv * Rinv)
      dyy = (R_b(3,i) * R_b(3,i) + R_b(1,i) * R_b(1,i)) * (Rinv * Rinv * Rinv)
      dzz = (R_b(1,i) * R_b(1,i) + R_b(2,i) * R_b(2,i)) * (Rinv * Rinv * Rinv)
      dxy = -R_b(1,i) * R_b(2,i) * (Rinv * Rinv * Rinv)
      dxz = -R_b(1,i) * R_b(3,i) * (Rinv * Rinv * Rinv)
      dyz = -R_b(2,i) * R_b(3,i) * (Rinv * Rinv * Rinv)

      d2s1(1,atom1,1,atom1) = d2s1(1,atom1,1,atom1) + dxx/real(break_num)
      d2s1(1,atom1,2,atom1) = d2s1(1,atom1,2,atom1) + dxy/real(break_num)
      d2s1(1,atom1,3,atom1) = d2s1(1,atom1,3,atom1) + dxz/real(break_num)
      d2s1(2,atom1,1,atom1) = d2s1(2,atom1,1,atom1) + dxy/real(break_num)
      d2s1(2,atom1,2,atom1) = d2s1(2,atom1,2,atom1) + dyy/real(break_num)
      d2s1(2,atom1,3,atom1) = d2s1(2,atom1,3,atom1) + dyz/real(break_num)
      d2s1(3,atom1,1,atom1) = d2s1(3,atom1,1,atom1) + dxz/real(break_num)
      d2s1(3,atom1,2,atom1) = d2s1(3,atom1,2,atom1) + dyz/real(break_num)
      d2s1(3,atom1,3,atom1) = d2s1(3,atom1,3,atom1) + dzz/real(break_num)

      d2s1(1,atom1,1,atom2) = d2s1(1,atom1,1,atom2) - dxx/real(break_num)
      d2s1(1,atom1,2,atom2) = d2s1(1,atom1,2,atom2) - dxy/real(break_num)
      d2s1(1,atom1,3,atom2) = d2s1(1,atom1,3,atom2) - dxz/real(break_num)
      d2s1(2,atom1,1,atom2) = d2s1(2,atom1,1,atom2) - dxy/real(break_num)
      d2s1(2,atom1,2,atom2) = d2s1(2,atom1,2,atom2) - dyy/real(break_num)
      d2s1(2,atom1,3,atom2) = d2s1(2,atom1,3,atom2) - dyz/real(break_num)
      d2s1(3,atom1,1,atom2) = d2s1(3,atom1,1,atom2) - dxz/real(break_num)
      d2s1(3,atom1,2,atom2) = d2s1(3,atom1,2,atom2) - dyz/real(break_num)
      d2s1(3,atom1,3,atom2) = d2s1(3,atom1,3,atom2) - dzz/real(break_num)

      d2s1(1,atom2,1,atom1) = d2s1(1,atom2,1,atom1) - dxx/real(break_num)
      d2s1(1,atom2,2,atom1) = d2s1(1,atom2,2,atom1) - dxy/real(break_num)
      d2s1(1,atom2,3,atom1) = d2s1(1,atom2,3,atom1) - dxz/real(break_num)
      d2s1(2,atom2,1,atom1) = d2s1(2,atom2,1,atom1) - dxy/real(break_num)
      d2s1(2,atom2,2,atom1) = d2s1(2,atom2,2,atom1) - dyy/real(break_num)
      d2s1(2,atom2,3,atom1) = d2s1(2,atom2,3,atom1) - dyz/real(break_num)
      d2s1(3,atom2,1,atom1) = d2s1(3,atom2,1,atom1) - dxz/real(break_num)
      d2s1(3,atom2,2,atom1) = d2s1(3,atom2,2,atom1) - dyz/real(break_num)
      d2s1(3,atom2,3,atom1) = d2s1(3,atom2,3,atom1) - dzz/real(break_num)

      d2s1(1,atom2,1,atom2) = d2s1(1,atom2,1,atom2) + dxx/real(break_num)
      d2s1(1,atom2,2,atom2) = d2s1(1,atom2,2,atom2) + dxy/real(break_num)
      d2s1(1,atom2,3,atom2) = d2s1(1,atom2,3,atom2) + dxz/real(break_num)
      d2s1(2,atom2,1,atom2) = d2s1(2,atom2,1,atom2) + dxy/real(break_num)
      d2s1(2,atom2,2,atom2) = d2s1(2,atom2,2,atom2) + dyy/real(break_num)
      d2s1(2,atom2,3,atom2) = d2s1(2,atom2,3,atom2) + dyz/real(break_num)
      d2s1(3,atom2,1,atom2) = d2s1(3,atom2,1,atom2) + dxz/real(break_num)
      d2s1(3,atom2,2,atom2) = d2s1(3,atom2,2,atom2) + dyz/real(break_num)
      d2s1(3,atom2,3,atom2) = d2s1(3,atom2,3,atom2) + dzz/real(break_num)
   end do
!
!     The educts dividing surface
!

   d2s0=0.d0
   do i=1,sum_eds
      do j=i+1,sum_eds
         Rinv=1.d0/r_eds(i,j)
         dxx = -(Red(2,i,j) * Red(2,i,j) + Red(3,i,j) * Red(3,i,j)) * (Rinv * Rinv * Rinv)
         dyy = -(Red(3,i,j) * Red(3,i,j) + Red(1,i,j) * Red(1,i,j)) * (Rinv * Rinv * Rinv)
         dzz = -(Red(1,i,j) * Red(1,i,j) + Red(2,i,j) * Red(2,i,j)) * (Rinv * Rinv * Rinv)
         dxy = Red(1,i,j) * Red(2,i,j) * (Rinv * Rinv * Rinv)
         dxz = Red(1,i,j) * Red(3,i,j) * (Rinv * Rinv * Rinv)
         dyz = Red(2,i,j) * Red(3,i,j) * (Rinv * Rinv * Rinv)

         do k=1,n_ed(i)
            atom1=at_ed(i,k)
            do l=1,n_ed(i)
               atom2=at_ed(i,l)
               massfactor=mass(atom1)/mass_ed(i)*mass(atom2)/mass_ed(i)
               d2s0(1,atom1,1,atom2) = d2s0(1,atom1,1,atom2)+dxx * massfactor/real(s0_terms)
               d2s0(1,atom1,2,atom2) = d2s0(1,atom1,2,atom2)+dxy * massfactor/real(s0_terms)
               d2s0(1,atom1,3,atom2) = d2s0(1,atom1,3,atom2)+dxz * massfactor/real(s0_terms)
               d2s0(2,atom1,1,atom2) = d2s0(2,atom1,1,atom2)+dxy * massfactor/real(s0_terms)
               d2s0(2,atom1,2,atom2) = d2s0(2,atom1,2,atom2)+dyy * massfactor/real(s0_terms)
               d2s0(2,atom1,3,atom2) = d2s0(2,atom1,3,atom2)+dyz * massfactor/real(s0_terms)
               d2s0(3,atom1,1,atom2) = d2s0(3,atom1,1,atom2)+dxz * massfactor/real(s0_terms)
               d2s0(3,atom1,2,atom2) = d2s0(3,atom1,2,atom2)+dyz * massfactor/real(s0_terms)
               d2s0(3,atom1,3,atom2) = d2s0(3,atom1,3,atom2)+dzz * massfactor/real(s0_terms)
            end do
            do l=1,n_ed(j)
               atom2=at_ed(j,l)
               massfactor=mass(atom1)/mass_ed(i)*mass(atom2)/mass_ed(j)
               d2s0(1,atom1,1,atom2) = d2s0(1,atom1,1,atom2)-dxx * massfactor/real(s0_terms)
               d2s0(1,atom1,2,atom2) = d2s0(1,atom1,2,atom2)-dxy * massfactor/real(s0_terms)
               d2s0(1,atom1,3,atom2) = d2s0(1,atom1,3,atom2)-dxz * massfactor/real(s0_terms)
               d2s0(2,atom1,1,atom2) = d2s0(2,atom1,1,atom2)-dxy * massfactor/real(s0_terms)
               d2s0(2,atom1,2,atom2) = d2s0(2,atom1,2,atom2)-dyy * massfactor/real(s0_terms)
               d2s0(2,atom1,3,atom2) = d2s0(2,atom1,3,atom2)-dyz * massfactor/real(s0_terms)
               d2s0(3,atom1,1,atom2) = d2s0(3,atom1,1,atom2)-dxz * massfactor/real(s0_terms)
               d2s0(3,atom1,2,atom2) = d2s0(3,atom1,2,atom2)-dyz * massfactor/real(s0_terms)
               d2s0(3,atom1,3,atom2) = d2s0(3,atom1,3,atom2)-dzz * massfactor/real(s0_terms)
            end do
         end do
         do k=1,n_ed(j)
            atom1=at_ed(j,k)
            do l=1,n_ed(i)
               atom2=at_ed(i,l)
               massfactor=mass(atom1)/mass_ed(j)*mass(atom2)/mass_ed(i)
               d2s0(1,atom1,1,atom2) = d2s0(1,atom1,1,atom2)-dxx * massfactor/real(s0_terms)
               d2s0(1,atom1,2,atom2) = d2s0(1,atom1,2,atom2)-dxy * massfactor/real(s0_terms)
               d2s0(1,atom1,3,atom2) = d2s0(1,atom1,3,atom2)-dxz * massfactor/real(s0_terms)
               d2s0(2,atom1,1,atom2) = d2s0(2,atom1,1,atom2)-dxy * massfactor/real(s0_terms)
               d2s0(2,atom1,2,atom2) = d2s0(2,atom1,2,atom2)-dyy * massfactor/real(s0_terms)
               d2s0(2,atom1,3,atom2) = d2s0(2,atom1,3,atom2)-dyz * massfactor/real(s0_terms)
               d2s0(3,atom1,1,atom2) = d2s0(3,atom1,1,atom2)-dxz * massfactor/real(s0_terms)
               d2s0(3,atom1,2,atom2) = d2s0(3,atom1,2,atom2)-dyz * massfactor/real(s0_terms)
               d2s0(3,atom1,3,atom2) = d2s0(3,atom1,3,atom2)-dzz * massfactor/real(s0_terms)
            end do
            do l=1,n_ed(j)
               atom2=at_ed(j,l)
               massfactor=mass(atom1)/mass_ed(j)*mass(atom2)/mass_ed(j)
               d2s0(1,atom1,1,atom2) = d2s0(1,atom1,1,atom2)+dxx * massfactor/real(s0_terms)
               d2s0(1,atom1,2,atom2) = d2s0(1,atom1,2,atom2)+dxy * massfactor/real(s0_terms)
               d2s0(1,atom1,3,atom2) = d2s0(1,atom1,3,atom2)+dxz * massfactor/real(s0_terms)
               d2s0(2,atom1,1,atom2) = d2s0(2,atom1,1,atom2)+dxy * massfactor/real(s0_terms)
               d2s0(2,atom1,2,atom2) = d2s0(2,atom1,2,atom2)+dyy * massfactor/real(s0_terms)
               d2s0(2,atom1,3,atom2) = d2s0(2,atom1,3,atom2)+dyz * massfactor/real(s0_terms)
               d2s0(3,atom1,1,atom2) = d2s0(3,atom1,1,atom2)+dxz * massfactor/real(s0_terms)
               d2s0(3,atom1,2,atom2) = d2s0(3,atom1,2,atom2)+dyz * massfactor/real(s0_terms)
               d2s0(3,atom1,3,atom2) = d2s0(3,atom1,3,atom2)+dzz * massfactor/real(s0_terms)
            end do
         end do
      end do
   end do
!
!     Determine Hessian of the reaction coordinate from dividing surface
!     hessians
!
!     for usual umbrella sampling
!
   if (mode .eq. 1) then
      do i1 = 1, 3
         do j1 = 1, Natoms
            do i2 = 1, 3
               do j2 = 1, Natoms
                   d2xi_act(i1,j1,i2,j2) = ((s0 * d2s1(i1,j1,i2,j2) + ds0(i2,j2) * ds1(i1,j1) &
                     &  - ds1(i2,j2) * ds0(i1,j1) - s1 * d2s0(i1,j1,i2,j2)) * (s0 - s1) &
                     &  - 2.0d0 * (s0 * ds1(i1,j1) - s1 * ds0(i1,j1)) &
                     &  * (ds0(i2,j2) - ds1(i2,j2))) &
                     &  / ((s0 - s1) * (s0 - s1) * (s0 - s1))
               end do
            end do
         end do
      end do
!
!     For recrossing factor calculation
!
   else if (mode .eq. 2) then
      d2xi_act=xi_ideal*d2s1+(1-xi_ideal)*d2s0
   end if
!   write(*,*) "Xiii values!",mode
!   write(*,*) "xi_act",xi_act,xi_ideal,s0,s1
!   write(*,*) xi_act
!   write(*,*) "dxi_act"
!   write(*,*) dxi_act
!            write(*,*) "d2s1!"
!            write(*,*) d2s1
!            write(*,*) "d2s0!"
!            write(*,*) d2s0
!
!   write(*,*) "d2xi_act"
!   write(*,*) d2xi_act
!   stop "gizfitcditucD"
!
!    #############################################################################
!    2 THE ATOM SHIFT (ONE COORDINATE RESTRAINT ON ONE ATOM)
!
!    These coordinate is rather simple: for s0, the expression is x_real-x_ideal,
!    the first derivative is 1 for the relevent coordinate, the second is zero
!
else if (umbr_type .eq. "ATOM_SHIFT") then
!
!    value of the TS dividing surface function: reference to shift_hi
!
   s1=coords(shift_coord,shift_atom)-shift_hi
!
!    value of the educts dividing surface function: reference to shift_lo
!
   s0=coords(shift_coord,shift_atom)-shift_lo
!
!    Calculate the actual Xi value:
!    for usual umbrella sampling
!
   if (mode .eq. 1) then
      xi_act=s0/(s0-s1)
!
!    for recrossing calculation
!
   else if (mode .eq. 2) then
      xi_act=xi_ideal*s1+(1-xi_ideal)*s0
!      write(*,*) "xi_act",xi_act,xi_ideal,s0,s1
   end if
!
!    gradient of the TS dividing surface function:
!
   ds1=0d0
   ds1(shift_coord,shift_atom)=1d0
!
!    gradient of the educts dividing surface function:
!
   ds0=0d0
   ds0(shift_coord,shift_atom)=1d0
!
!    calculate the actual Xi derivative:
!
!
!     For usual umbrella sampling
!
   if (mode .eq. 1) then
      dxi_act=(s0*ds1-s1*ds0)/((s0-s1)*(s0-s1))
!
!     For recrossing calculation
!
   else if (mode .eq. 2) then
      dxi_act=xi_ideal*ds1+(1-xi_ideal)*ds0
   end if
!
!     hession of reaction coordinate: both d2s0 and d2s1 are zero!
!
   d2s0=0.d0
   d2s1=0.d0
!
!     Determine Hessian of the reaction coordinate from dividing surface
!     hessians
!
!     for usual umbrella sampling
!
   if (mode .eq. 1) then
      do i1 = 1, 3
         do j1 = 1, Natoms
            do i2 = 1, 3
               do j2 = 1, Natoms
                   d2xi_act(i1,j1,i2,j2) = ((s0 * d2s1(i1,j1,i2,j2) + ds0(i2,j2) * ds1(i1,j1) &
                     &  - ds1(i2,j2) * ds0(i1,j1) - s1 * d2s0(i1,j1,i2,j2)) * (s0 - s1) &
                     &  - 2.0d0 * (s0 * ds1(i1,j1) - s1 * ds0(i1,j1)) &
                     &  * (ds0(i2,j2) - ds1(i2,j2))) &
                     &  / ((s0 - s1) * (s0 - s1) * (s0 - s1))
               end do
            end do
         end do
      end do
!
!     For recrossing factor calculation
!
   else if (mode .eq. 2) then
      d2xi_act=xi_ideal*d2s1+(1-xi_ideal)*d2s0
   end if

!    #############################################################################
!    3 UNIMOLECULAR REACTIONS (GENERAL)
!
!    Here, the s0 dividing surface is defined as the educt structure. Therefore,
!    both dividing surfaces are defined as a bunch of reference values for
!    the forming and breaking bonds of interest
!
!

else if ((umbr_type .eq. "CYCLOREVER") .or. (umbr_type .eq. "REARRANGE") .or. &
                  & (umbr_type .eq. "DECOM_1BOND") .or. (umbr_type .eq. "ELIMINATION")) then
!
!    STEP1: calculate the bondlengths and then the Xi-value
!
!    a) the s1 surface: reference to the TS
!
!    the forming bonds (in total form_num bonds)
!
!   write(*,*) "form",form_num,break_num
!   stop "hgpgu"
   do i=1,form_num
      atom1=bond_form(i,1)
      atom2=bond_form(i,2)
      R_f(1,i)=coords(1,atom1) - coords(1,atom2)
      R_f(2,i)=coords(2,atom1) - coords(2,atom2)
      R_f(3,i)=coords(3,atom1) - coords(3,atom2)
      form_act(i)=sqrt(R_f(1,i)*R_f(1,i)+R_f(2,i)*R_f(2,i)+R_f(3,i)*R_f(3,i))
   end do
!
!    the breaking bonds (in total break_num bonds)
!
   do i=1,break_num
      atom1=bond_break(i,1)
      atom2=bond_break(i,2)
      R_b(1,i)=coords(1,atom1) - coords(1,atom2)
      R_b(2,i)=coords(2,atom1) - coords(2,atom2)
      R_b(3,i)=coords(3,atom1) - coords(3,atom2)
      break_act(i)=sqrt(R_b(1,i)*R_b(1,i)+R_b(2,i)*R_b(2,i)+R_b(3,i)*R_b(3,i))
   end do
!
!    value of the TS dividing surface funtion: sum up all breaking
!    bond differences and divide this through the total number of
!    breaking and sum up all forming bond differences and divide this
!    through the total numbe of forming
!
   s1=0.d0
   do i=1,break_num
      s1=s1+(break_act(i)-break_ref(i))/real(break_num)
   end do
   do i=1,form_num
      s1=s1-(form_act(i)-form_ref(i))/real(form_num)
   end do
!
!    value of the educts dividing surface: analogous to TS dividing surface
!
   s0=0.d0
   do i=1,break_num
      s0=s0+(break_act(i)-break_ed(i))/real(break_num)
   end do
   do i=1,form_num
      s0=s0-(form_act(i)-form_ed(i))/real(form_num)
   end do
!
!    calculate Xi value with the RPMDrate formula
!
!    for usual umbrella sampling
!
   if (mode .eq. 1) then
      xi_act=s0/(s0-s1)
!
!    for recrossing calculation
!
   else if (mode .eq. 2) then
      xi_act=xi_ideal*s1+(1-xi_ideal)*s0
   end if
!
!     STEP2: calculate the gradient of reaction coordinate
!
!
!     The transition state dividing surface
!
   ds1=0.d0
!
!     the forming bonds (in total, n_form forming bonds)
!
   do i=1,form_num
      atom1=bond_form(i,1)
      atom2=bond_form(i,2)
      Rinv=1.d0/form_act(i)
      ds1(1,atom1) = ds1(1,atom1) - R_f(1,i) * Rinv/real(form_num)
      ds1(2,atom1) = ds1(2,atom1) - R_f(2,i) * Rinv/real(form_num)
      ds1(3,atom1) = ds1(3,atom1) - R_f(3,i) * Rinv/real(form_num)
      ds1(1,atom2) = ds1(1,atom2) + R_f(1,i) * Rinv/real(form_num)
      ds1(2,atom2) = ds1(2,atom2) + R_f(2,i) * Rinv/real(form_num)
      ds1(3,atom2) = ds1(3,atom2) + R_f(3,i) * Rinv/real(form_num)
   end do
!
!     the breaking bonds (in total, n_break breaking bonds)
!
   do i=1,break_num
      atom1=bond_break(i,1)
      atom2=bond_break(i,2)
      Rinv=1.d0/break_act(i)
      ds1(1,atom1) = ds1(1,atom1) + R_b(1,i) * Rinv/real(break_num)
      ds1(2,atom1) = ds1(2,atom1) + R_b(2,i) * Rinv/real(break_num)
      ds1(3,atom1) = ds1(3,atom1) + R_b(3,i) * Rinv/real(break_num)
      ds1(1,atom2) = ds1(1,atom2) - R_b(1,i) * Rinv/real(break_num)
      ds1(2,atom2) = ds1(2,atom2) - R_b(2,i) * Rinv/real(break_num)
      ds1(3,atom2) = ds1(3,atom2) - R_b(3,i) * Rinv/real(break_num)
   end do
!
!     educts dividing surface: derivatives are equal!
!
   ds0=ds1
!
!     Calculate the derivative of the Xi coordinate
!
!     For usual umbrella sampling
!
   if (mode .eq. 1) then
      dxi_act=(s0*ds1-s1*ds0)/((s0-s1)*(s0-s1))
!
!     For recrossing calculation
!
   else if (mode .eq. 2) then
      dxi_act=xi_ideal*ds1+(1-xi_ideal)*ds0
   end if
!
!     STEP3: calculate the hessian of the reaction coordinate
!      (I don´t know why this is needed!)
!
!
!     The transition state dividing surface
!
   d2s1=0.d0
!
!     the forming bonds (in total form_num forming bonds)
!
   do i=1,form_num
      atom1=bond_form(i,1)
      atom2=bond_form(i,2)
      Rinv=1.d0/form_act(i)

      dxx = -(R_f(2,i) * R_f(2,i) + R_f(3,i) * R_f(3,i)) * (Rinv * Rinv * Rinv)
      dyy = -(R_f(3,i) * R_f(3,i) + R_f(1,i) * R_f(1,i)) * (Rinv * Rinv * Rinv)
      dzz = -(R_f(1,i) * R_f(1,i) + R_f(2,i) * R_f(2,i)) * (Rinv * Rinv * Rinv)
      dxy = R_f(1,i) * R_f(2,i) * (Rinv * Rinv * Rinv)
      dxz = R_f(1,i) * R_f(3,i) * (Rinv * Rinv * Rinv)
      dyz = R_f(2,i) * R_f(3,i) * (Rinv * Rinv * Rinv)

      d2s1(1,atom1,1,atom1) = d2s1(1,atom1,1,atom1) + dxx/real(form_num)
      d2s1(1,atom1,2,atom1) = d2s1(1,atom1,2,atom1) + dxy/real(form_num)
      d2s1(1,atom1,3,atom1) = d2s1(1,atom1,3,atom1) + dxz/real(form_num)
      d2s1(2,atom1,1,atom1) = d2s1(2,atom1,1,atom1) + dxy/real(form_num)
      d2s1(2,atom1,2,atom1) = d2s1(2,atom1,2,atom1) + dyy/real(form_num)
      d2s1(2,atom1,3,atom1) = d2s1(2,atom1,3,atom1) + dyz/real(form_num)
      d2s1(3,atom1,1,atom1) = d2s1(3,atom1,1,atom1) + dxz/real(form_num)
      d2s1(3,atom1,2,atom1) = d2s1(3,atom1,2,atom1) + dyz/real(form_num)
      d2s1(3,atom1,3,atom1) = d2s1(3,atom1,3,atom1) + dzz/real(form_num)

      d2s1(1,atom1,1,atom2) = d2s1(1,atom1,1,atom2) - dxx/real(form_num)
      d2s1(1,atom1,2,atom2) = d2s1(1,atom1,2,atom2) - dxy/real(form_num)
      d2s1(1,atom1,3,atom2) = d2s1(1,atom1,3,atom2) - dxz/real(form_num)
      d2s1(2,atom1,1,atom2) = d2s1(2,atom1,1,atom2) - dxy/real(form_num)
      d2s1(2,atom1,2,atom2) = d2s1(2,atom1,2,atom2) - dyy/real(form_num)
      d2s1(2,atom1,3,atom2) = d2s1(2,atom1,3,atom2) - dyz/real(form_num)
      d2s1(3,atom1,1,atom2) = d2s1(3,atom1,1,atom2) - dxz/real(form_num)
      d2s1(3,atom1,2,atom2) = d2s1(3,atom1,2,atom2) - dyz/real(form_num)
      d2s1(3,atom1,3,atom2) = d2s1(3,atom1,3,atom2) - dzz/real(form_num)

      d2s1(1,atom2,1,atom1) = d2s1(1,atom2,1,atom1) - dxx/real(form_num)
      d2s1(1,atom2,2,atom1) = d2s1(1,atom2,2,atom1) - dxy/real(form_num)
      d2s1(1,atom2,3,atom1) = d2s1(1,atom2,3,atom1) - dxz/real(form_num)
      d2s1(2,atom2,1,atom1) = d2s1(2,atom2,1,atom1) - dxy/real(form_num)
      d2s1(2,atom2,2,atom1) = d2s1(2,atom2,2,atom1) - dyy/real(form_num)
      d2s1(2,atom2,3,atom1) = d2s1(2,atom2,3,atom1) - dyz/real(form_num)
      d2s1(3,atom2,1,atom1) = d2s1(3,atom2,1,atom1) - dxz/real(form_num)
      d2s1(3,atom2,2,atom1) = d2s1(3,atom2,2,atom1) - dyz/real(form_num)
      d2s1(3,atom2,3,atom1) = d2s1(3,atom2,3,atom1) - dzz/real(form_num)

      d2s1(1,atom2,1,atom2) = d2s1(1,atom2,1,atom2) + dxx/real(form_num)
      d2s1(1,atom2,2,atom2) = d2s1(1,atom2,2,atom2) + dxy/real(form_num)
      d2s1(1,atom2,3,atom2) = d2s1(1,atom2,3,atom2) + dxz/real(form_num)
      d2s1(2,atom2,1,atom2) = d2s1(2,atom2,1,atom2) + dxy/real(form_num)
      d2s1(2,atom2,2,atom2) = d2s1(2,atom2,2,atom2) + dyy/real(form_num)
      d2s1(2,atom2,3,atom2) = d2s1(2,atom2,3,atom2) + dyz/real(form_num)
      d2s1(3,atom2,1,atom2) = d2s1(3,atom2,1,atom2) + dxz/real(form_num)
      d2s1(3,atom2,2,atom2) = d2s1(3,atom2,2,atom2) + dyz/real(form_num)
      d2s1(3,atom2,3,atom2) = d2s1(3,atom2,3,atom2) + dzz/real(form_num)
   end do
!
!    the breaking bonds (in total break_num breaking bonds)
!
   do i=1,break_num
      atom1=bond_break(i,1)
      atom2=bond_break(i,2)
      Rinv=1.d0/break_act(i)

      dxx = (R_b(2,i) * R_b(2,i) + R_b(3,i) * R_b(3,i)) * (Rinv * Rinv * Rinv)
      dyy = (R_b(3,i) * R_b(3,i) + R_b(1,i) * R_b(1,i)) * (Rinv * Rinv * Rinv)
      dzz = (R_b(1,i) * R_b(1,i) + R_b(2,i) * R_b(2,i)) * (Rinv * Rinv * Rinv)
      dxy = -R_b(1,i) * R_b(2,i) * (Rinv * Rinv * Rinv)
      dxz = -R_b(1,i) * R_b(3,i) * (Rinv * Rinv * Rinv)
      dyz = -R_b(2,i) * R_b(3,i) * (Rinv * Rinv * Rinv)

      d2s1(1,atom1,1,atom1) = d2s1(1,atom1,1,atom1) + dxx/real(break_num)
      d2s1(1,atom1,2,atom1) = d2s1(1,atom1,2,atom1) + dxy/real(break_num)
      d2s1(1,atom1,3,atom1) = d2s1(1,atom1,3,atom1) + dxz/real(break_num)
      d2s1(2,atom1,1,atom1) = d2s1(2,atom1,1,atom1) + dxy/real(break_num)
      d2s1(2,atom1,2,atom1) = d2s1(2,atom1,2,atom1) + dyy/real(break_num)
      d2s1(2,atom1,3,atom1) = d2s1(2,atom1,3,atom1) + dyz/real(break_num)
      d2s1(3,atom1,1,atom1) = d2s1(3,atom1,1,atom1) + dxz/real(break_num)
      d2s1(3,atom1,2,atom1) = d2s1(3,atom1,2,atom1) + dyz/real(break_num)
      d2s1(3,atom1,3,atom1) = d2s1(3,atom1,3,atom1) + dzz/real(break_num)

      d2s1(1,atom1,1,atom2) = d2s1(1,atom1,1,atom2) - dxx/real(break_num)
      d2s1(1,atom1,2,atom2) = d2s1(1,atom1,2,atom2) - dxy/real(break_num)
      d2s1(1,atom1,3,atom2) = d2s1(1,atom1,3,atom2) - dxz/real(break_num)
      d2s1(2,atom1,1,atom2) = d2s1(2,atom1,1,atom2) - dxy/real(break_num)
      d2s1(2,atom1,2,atom2) = d2s1(2,atom1,2,atom2) - dyy/real(break_num)
      d2s1(2,atom1,3,atom2) = d2s1(2,atom1,3,atom2) - dyz/real(break_num)
      d2s1(3,atom1,1,atom2) = d2s1(3,atom1,1,atom2) - dxz/real(break_num)
      d2s1(3,atom1,2,atom2) = d2s1(3,atom1,2,atom2) - dyz/real(break_num)
      d2s1(3,atom1,3,atom2) = d2s1(3,atom1,3,atom2) - dzz/real(break_num)

      d2s1(1,atom2,1,atom1) = d2s1(1,atom2,1,atom1) - dxx/real(break_num)
      d2s1(1,atom2,2,atom1) = d2s1(1,atom2,2,atom1) - dxy/real(break_num)
      d2s1(1,atom2,3,atom1) = d2s1(1,atom2,3,atom1) - dxz/real(break_num)
      d2s1(2,atom2,1,atom1) = d2s1(2,atom2,1,atom1) - dxy/real(break_num)
      d2s1(2,atom2,2,atom1) = d2s1(2,atom2,2,atom1) - dyy/real(break_num)
      d2s1(2,atom2,3,atom1) = d2s1(2,atom2,3,atom1) - dyz/real(break_num)
      d2s1(3,atom2,1,atom1) = d2s1(3,atom2,1,atom1) - dxz/real(break_num)
      d2s1(3,atom2,2,atom1) = d2s1(3,atom2,2,atom1) - dyz/real(break_num)
      d2s1(3,atom2,3,atom1) = d2s1(3,atom2,3,atom1) - dzz/real(break_num)

      d2s1(1,atom2,1,atom2) = d2s1(1,atom2,1,atom2) + dxx/real(break_num)
      d2s1(1,atom2,2,atom2) = d2s1(1,atom2,2,atom2) + dxy/real(break_num)
      d2s1(1,atom2,3,atom2) = d2s1(1,atom2,3,atom2) + dxz/real(break_num)
      d2s1(2,atom2,1,atom2) = d2s1(2,atom2,1,atom2) + dxy/real(break_num)
      d2s1(2,atom2,2,atom2) = d2s1(2,atom2,2,atom2) + dyy/real(break_num)
      d2s1(2,atom2,3,atom2) = d2s1(2,atom2,3,atom2) + dyz/real(break_num)
      d2s1(3,atom2,1,atom2) = d2s1(3,atom2,1,atom2) + dxz/real(break_num)
      d2s1(3,atom2,2,atom2) = d2s1(3,atom2,2,atom2) + dyz/real(break_num)
      d2s1(3,atom2,3,atom2) = d2s1(3,atom2,3,atom2) + dzz/real(break_num)
   end do
!
!     The Hessian of the educts dividing surface: equal to the TS one!
!
   d2s0=d2s1
!
!     Determine Hessian of the reaction coordinate from dividing surface
!     hessians
!
!     for usual umbrella sampling
!
   if (mode .eq. 1) then
      do i1 = 1, 3
         do j1 = 1, Natoms
            do i2 = 1, 3
               do j2 = 1, Natoms
                   d2xi_act(i1,j1,i2,j2) = ((s0 * d2s1(i1,j1,i2,j2) + ds0(i2,j2) * ds1(i1,j1) &
                     &  - ds1(i2,j2) * ds0(i1,j1) - s1 * d2s0(i1,j1,i2,j2)) * (s0 - s1) &
                     &  - 2.0d0 * (s0 * ds1(i1,j1) - s1 * ds0(i1,j1)) &
                     &  * (ds0(i2,j2) - ds1(i2,j2))) &
                     &  / ((s0 - s1) * (s0 - s1) * (s0 - s1))
               end do
            end do
         end do
      end do
!
!     For recrossing factor calculation
!
   else if (mode .eq. 2) then
      d2xi_act=xi_ideal*d2s1+(1-xi_ideal)*d2s0
   end if

end if
return
end subroutine calc_xi