! Copyright (c) 1998-2004, University of California, Los Angeles, Emily A. Carter
!                       2004-2016, Princeton University, Emily A. Carter
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification, are
! permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice, this list of
!     conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice, this list
!     of conditions and the following disclaimer in the documentation and/or other
!     materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its contributors may be
!     used to endorse or promote products derived from this software without specific
!     prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
! CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
! NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
! STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
! OF THE POSSIBILITY OF SUCH DAMAGE.
!**************************************************************
  !//  TIME_VAR_MOD - THIS MODULE IS USED TO STORE THE TIMING VARIABLES
  !//
  !//  WRITTEN BY DEREK WALTER, 1999
  ! WARNING: THIS CODE DOES NOT CONFORM TO Y2K STANDARDS!!
!**************************************************************

module time_var_mod

  use global_var_mod

  implicit none

  real(real8)::sort_time               !// TIME SPENT SORTING INTEGRALS
  real(real8)::graph_time              !// TIME SPENT MAKING THE SPATIAL GRAPH AND INDEX VECTOR
  real(real8)::spin_time               !// TIME SPENT MAKING CYCLE BRANCHING DIAGRAM, SFT GRAPH, CYCLE MATRICES
  								     !// AND TRANSPOSITION MATRICES
  real(real8)::search_time             !// TIME SPENT SEARCHING
  real(real8)::diag_tot_time           !// TOTAL TIME SPENT IN ALL DIAGONALIZATION ROUTINES
  real(real8)::diag_element_time       !// TIME SPENT MAKING DIAGONAL ELEMENTS OF H.
  real(real8)::diagtimesc_time         !// TIME SPENT MUTLIPLYING DIAGONAL ELEMENTS BY CI VECTOR
  real(real8)::lp26_time               !// TIME SPENT TAKING CARE OF CONTRIBUTIONS FROM {26} LOOPS
  real(real8)::two_seg_time            !// TIME SPENT ON TWO SEGMENT LOOPS
  real(real8)::three_and_four_seg_time !// TIME SPENT ON THREE AND FOUR SEGEMNT LOOPS

  real(real8)::ijkl_time               !// TIME SPENT TREATING VARIOUS INTEGRALS
  real(real8)::aijk_time
  real(real8)::abij_time               !// THIS ALSO INCLUDES THE (IA|JA)
  real(real8)::ikjk_time
  real(real8)::abcd_time               !// THIS ALSO INCLUDES (AC|BC)
  real(real8)::iabc_time
  real(real8)::ijaj_time

  real(real8)::rc_time
  real(real8)::coulomb_time
  real(real8)::exchange_time
  real(real8)::qbrc_time
  real(real8)::aqbrc_time

end module time_var_mod


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   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 ff_neighbor: determine atom neighbors for the
!        QMDFF reference structure
!
!     part of QMDFF
!
!
subroutine ff_neighbor(natoms,xyz,wbo,at,nb,hyb,mclust,wbocut_in)
use qmdff
implicit none
integer::at(natoms),natoms,nb(20,natoms),hyb(natoms)
real(kind=8)::xyz(3,natoms),wbo(natoms,natoms),wbocut_in
logical::mclust

logical::da
character(len=40)::atmp
integer::iat,i,j,k,nn,ni,ii,jj,kk,ll
real(kind=8)::rb(20,natoms),valijkl,wbocut
real(kind=8)::dx,dy,dz,r,damp,xn,rr,rco,r2,f,aa1

write(10,*)
write(10,*)'======================'
write(10,*)'topology analysis:'
write(10,*)'find nearest neighbors'
write(10,*)'======================'
write(10,*)

nb=0
nn=min(natoms,2)-1
!
!write(10,*) "Topology analysis for molecule:"
!write(10,*) "1st  2nd  r_covalent  distance  bond-order bond-index"
do i=1,natoms
   f=1.3
   k=0
   100 continue
   do iat=1,natoms
      da=.false.
      do j=1,k
         if (nb(j,i).eq.iat) da=.true.
      end do
      if (iat.ne.i.and.(.not.da)) then
         dx=xyz(1,iat)-xyz(1,i)
         dy=xyz(2,iat)-xyz(2,i)
         dz=xyz(3,iat)-xyz(3,i)
         r2=dx*dx+dy*dy+dz*dz
         r=sqrt(r2)*0.52917726
         rco=rad(at(i))+rad(at(iat))
!
!     important cut-off for small BE bonds
!
         wbocut=wbocut_in
         if (metal(at(i)).eq.1.or.metal(at(iat)).eq.1) then
            wbocut=-1
!
!     this makes high CN (coordination number?)
!
            if (mclust) f=1.4
         end if
!
!     critical step: set Wiberg bond orders and coordinatiom numbers
!     together (only if they are lower than 19!)
!
         if (r.lt.f*rco.and.wbo(iat,i).gt.wbocut.and.k.lt.19) then
            k=k+1
            nb(k,i)=iat
            rb(k,i)=r
         end if
!         write(10,'(2i4,3f10.5,i5)') i,iat,rco,r,wbo(i,iat),k
      end if
   end do
!
!     Rescale f factor to gain success and go back
!
   if (k.lt.1.and.f.lt.1.5) then
      f=f*1.1
      goto 100
   end if
   nb(20,i)=k
!
!     sort atoms and bonds to them (?)
!
   call sort(1,k,rb(1,i),nb(1,i))
end do
!
!     For lonely atoms (no coordination and WBO)
!
do i=1,natoms
   if(nb(20,i).eq.0)then
      write(atmp,'(''no bond partners for atom'',i4)')i
      call warn(atmp)
   endif
enddo
!
!     tag atoms in linear coordination
!
do i=1,natoms
   ni=nb(20,i)
   if(ni.eq.2)then
      k=nb(1,i)
      j=nb(2,i)
      call bangle(XYZ,k,i,j,aa1)
      aa1=aa1*180./pi
      if(aa1.lt.athr.or.180-aa1.lt.athr) nb(19,i)=1
   endif
enddo
!
!     tag atoms bonded to metals
!
do i=1,natoms
   ni=nb(20,i)
   do j=1,ni
      k=nb(j,i)
      if (metal(at(k)).eq.1) nb(18,i)=1
   end do
end do
!
!     hybridization state for group 3-7 elements
!     first main group: sp2 hybridization etc.
!     and for their heavier homologes depending on the
!     number of bond partners
!
do i=1,natoms
   hyb(i)=0
!     B (Bor)
   if (at(i).eq.5.or.at(i).eq.13.or.at(i) &
      &  .eq.31.or.at(i).eq.49.or.at(i).eq.81) then
      if (nb(20,i).eq.4) hyb(i)=3
      if (nb(20,i).eq.3) then
         hyb(i)=3
         ll=nb(1,i)
         jj=nb(2,i)
         kk=nb(3,i)
         r=valijkl(natoms,xyz,ll,i,jj,kk)
         if (abs(r*180./pi-180.).lt.athr) hyb(i)=2
      end if
   end if
!
!     C (Carbon)
!
   if(at(i).eq.6.or.at(i).eq.14.or.at(i) &
      &   .eq.32.or.at(i).eq.50.or.at(i).eq.82) then
      if (nb(20,i).eq.4) hyb(i)=3
      if (nb(20,i).eq.3) hyb(i)=2
      if (nb(20,i).eq.2) hyb(i)=1
      if (nb(20,i).eq.4.and.at(i).eq.6.and.nb(18,i).eq.1) hyb(i)=2
   end if
!
!     N (Nitrogen)
!
   if (at(i).eq.7.or.at(i).eq.15.or.at(i) &
      &   .eq.33.or.at(i).eq.51.or.at(i).eq.83) then
      if (nb(20,i).eq.4) hyb(i)=3
      if (nb(20,i).eq.3) then
         hyb(i)=3
         ll=nb(1,i)
         jj=nb(2,i)
         kk=nb(3,i)
         r=valijkl(natoms,xyz,ll,i,jj,kk)
         if (abs(r*180./pi-180.).lt.athr) hyb(i)=2
      end if
      if (nb(20,i).eq.2) hyb(i)=2
      if (nb(20,i).eq.1) hyb(i)=1
   endif
!
!     O (Oxygen)
!
   if(at(i).eq.8.or.at(i).eq.16.or.at(i) &
      &   .eq.34.or.at(i).eq.52.or.at(i).eq.84) then
      if (nb(20,i).eq.3) hyb(i)=3
      if (nb(20,i).eq.2) hyb(i)=3
      if (nb(20,i).eq.1) hyb(i)=2
   end if
end do

return
end subroutine ff_neighbor


      subroutine rburn(plant)
c
c     + + + PURPOSE + + +
c     Updates range vegetation attributes as the result of burning.
c     (Burning may only be done once a year.)
c
c     Called from RANGE
c     Author(s): Weltz
c     Reference in User Guide: Chapter 8
c
c     Changes:
c           1) Dereferenced the following common blocks:
c              CRPVR3, CRPVR5, COVER, CRPOUT, CRPPRM, ENDS,
c              PARAME, RINPT2, RINPT6, UPDATE.
c           2) Dereferenced: PTILTY.INC & PMXPND.INC.
c           3) Changed:
c                nowres = 1
c                rmogt(nowres,iplane) = rmogt(nowres,iplane) * reduce(iplane)
c              to:
c                rmogt(1,iplane) = rmogt(1,iplane) * reduce(iplane)
c           4) Removed generic SAVE of all local variables.
c           5) Changed PLIVE(PLANT) to PLIVE(PLANT,IPLANE). -- CRM -- 5/14/93.
c           6) PROOT was altered analogous to PLIVE. -- CRM -- 5/14/93.
c
c     Version: This module recoded from WEPP Version 92.25.
c     Date recoded: 01/28/93.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
      include 'pntype.inc'
      include 'pmxelm.inc'
      include 'pmxnsl.inc'
      include 'pmxpln.inc'
      include 'pmxres.inc'
      include 'pmxgrz.inc'
      include 'pmxcrp.inc'
      include 'pmxtls.inc'
      include 'pmxtil.inc'
      include 'pmxhil.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
      integer plant
c
c     + + + ARGUMENT DEFINITIONS + + +
c     plant  - current plant type; set to itype(nowcrp,iplane) in RANGE
c
c     + + + COMMON BLOCKS + + +
      include 'ccrpvr1.inc'
c      modify: rmogt(mxres,mxplan), rmagt(mxplan)
c
      include 'ccrpvr2.inc'
c       write: vdmt(mxplan)
c
      include 'chydrol.inc'
c        read: rain(mxplan)
c
      include 'crinpt1.inc'
c      modify: plive(ntype,mxplan), proot(ntype,iplane)
c       write: access(mxplan)
c
      include 'crinpt3.inc'
c        read: alter(mxplan),burned(mxplan),change(mxplan),
c              hurt(mxplan),reduce(mxplan)
c      modify: jfdate(mxplan),shgt(ntype),spop(ntype)
c
      include 'crinpt4.inc'
c      modify: xlive(mxplan), dwood(mxplan)
c
      include 'crinpt5.inc'
c      modify: tpop(ntype),thgt(ntype)
c
      include 'crout.inc'
c      modify: tlive(mxplan)
c
      include 'cstruc.inc'
c        read: iplane
c
      include 'cclim.inc'
c        read: am2(mxplan)
c
c     + + + END SPECIFICATIONS + + +
c
c
c      *** L0 IF ***
c      If rainfall is <= 7.5 mm, AND five day antecedent moisture for
c      submerged residue <= 25 mm, proceed with burning.
c
c XXX NOTE - may want to change "rain(iplane)" to "rain+melt+irdept"
c XXX        so that impact of snow melt and irrigation can also be
c XXX        accounted for.   dcf  12/19/94
c
      if (rain(iplane).le.0.0075.and.am2(iplane).le.0.025) then
c
c       *** L1 IF ***
c       ------ (EVERGREENS PRESENT)
        if (xlive(iplane).gt.0.0) then
c         -------- (MIXED POPULATION)
          if (tlive(iplane).gt.xlive(iplane)) then
c           **************************************************************
c           * Note: The amount of live material is reduced by the same   *
c           *       fractions as the dead material.  The accuracy to be  *
c           *       gained, did not seem worth the complexity it would   *
c           *       cost to handle them separately. -- CRM -- 3/17/93.   *
c           **************************************************************
c           -----------total live plant material
c           (WEPP Equation 8.6.14)
            tlive(iplane) = ((tlive(iplane)-xlive(iplane))*
     1          reduce(iplane)) + (xlive(iplane)*hurt(iplane))
c         -------- (ONLY EVERGREENS)
          else
            xlive(iplane) = xlive(iplane) * hurt(iplane)
c           (WEPP Equation 8.6.13)
            tlive(iplane) = tlive(iplane) * hurt(iplane)
          end if
c
c       *** L1 ELSE ***
c       ------ (NO EVERGREENS PRESENT)
        else
          tlive(iplane) = tlive(iplane) * reduce(iplane)
c       *** L1 ENDIF ***
        end if
c
c       ------ update on-ground residue by non-evergreen reduction fraction
c       **************************************************************
c       * Note: If present, evergreen residue is reduced by the same *
c       *       fraction as non-evergreen.  The accuracy to be       *
c       *       gained, did not seem worth the complexity required   *
c       *       to handle them separately. -- CRM -- 3/17/93.        *
c       **************************************************************
c       -- XXX -- We are assuming evergreen residue (if present) is reduced
c       at the same rate as non-evergreens. -- CRM 1/28/93.
c       (WEPP Equation 8.6.16)
        rmogt(1,iplane) = rmogt(1,iplane) * reduce(iplane)
c       ------ update standing herbaceous residue by non-evergreen reduction fraction
c       (WEPP Equation 8.6.15)
        rmagt(iplane) = rmagt(iplane) * reduce(iplane)
c       ------ standing woody biomass
c       (WEPP Equation 8.6.10)
        dwood(iplane) = dwood(iplane) * burned(iplane)
c       ------ update fraction of forage available for consumption, to coefficient
c       of increase in availability
c       ------ replace the fraction of forage available, with fraction available
c       after burning
        access(iplane) = alter(iplane)
c       ------ update maximum [potential] standing live biomass, using fraction
c       change in above and below ground biomass
c       (WEPP Equation 8.6.13)
        plive(plant,iplane) = plive(plant,iplane) * change(iplane)
c       ------ update peak root biomass, using fraction change in above and
c       below ground biomass
c       (WEPP Equation 8.6.12)
        proot(plant,iplane) = proot(plant,iplane) * change(iplane)
c       ------ update total above ground dry weight (VDMT), using updated:
c       total live plant material on day of simulation (TLIVE),
c       surface residue mass above ground today (RMAGT), and standing
c       dead biomass left after burning or herbicide (DWOOD).
        vdmt(iplane) = tlive(iplane) + rmagt(iplane) + dwood(iplane)
c       **************************************************************
c       * Note: The average shrub & tree heights, and the average    *
c       *       shrub & tree populations are reduced by the factor   *
c       *       for reduction of woody biomass (BURNED).  It was     *
c       *       decided that this simplification would give adequate *
c       *       accuracy.  -- CRM -- 3/17/93.                        *
c       **************************************************************
c       ------ update average shrub height, using reduction in standing dead
c       wood after burning
c       (WEPP Equation 8.6.11)
        shgt(plant) = shgt(plant) * burned(iplane)
c       ------ average tree height
        thgt(plant) = thgt(plant) * burned(iplane)
c       ------ average number of shrubs along a 100 m transect
        spop(plant) = spop(plant) * burned(iplane)
c       ------ average number of trees along a 100 m transect
        tpop(plant) = tpop(plant) * burned(iplane)
c
c     *** L0 ELSE ***
c     If rainfall is > 7.5 mm, or five day antecedent moisture for
c     submerged residue > 25 mm, set day of burning 1 day later; ie,
c     delay burning 1 day.
c
      else
        jfdate(iplane) = jfdate(iplane) + 1
c
c     *** L0 ENDIF ***
      end if
c
      return
      end