      module vdw_module

c***********************************************************************
c
c     dl_poly module for defining van der waals potential arrays
c     copyright - daresbury laboratory
c     author    - w. smith    sep 2003
c     adapted   - p.-a. cazade oct 2007: solvation, free energy etc
c     adapted   - d. quigley : metadynamics
c
c***********************************************************************

      use config_module
      use error_module
      use metafreeze_module
      use pair_module
      use parse_module
      use setup_module
      use site_module
      use solvation_module
      use utility_module

      implicit none

      integer, allocatable :: ltpvdw(:),lstvdw(:)
      real(8), allocatable :: vvv(:,:),ggg(:,:),prmvdw(:,:)

      save ltpvdw,lstvdw,prmvdw,vvv,ggg

      contains

      subroutine alloc_vdw_arrays(idnode,mxnode)

      implicit none

      integer, parameter :: nnn=5

      logical safe
      integer i,fail,idnode,mxnode
      dimension fail(nnn)

      safe=.true.

c     allocate arrays

      fail(:)=0

      allocate (ltpvdw(mxvdw),stat=fail(1))
      allocate (lstvdw(mxvdw),stat=fail(2))
      allocate (prmvdw(mxvdw,mxpvdw),stat=fail(3))
      allocate (vvv(mxgrid,mxvdw),stat=fail(4))
      allocate (ggg(mxgrid,mxvdw),stat=fail(5))

      if(any(fail.gt.0))safe=.false.
      if(mxnode.gt.1)call gstate(safe)
      if(.not.safe)call error(idnode,1014)

      end subroutine alloc_vdw_arrays

      subroutine define_van_der_waals
     x  (safe,ltable,lunits,lmols,idnode,ntpvdw,
     x  ntpatm,keyfce,dlrpot,rvdw,engunit)

c***********************************************************************
c
c     dl_poly subroutine for defining van der Waals potentials
c
c     copyright - daresbury laboratory
c     author    - w. smith    aug 2003
c
c***********************************************************************

      implicit none

      logical safe,ltable,lunits,lmols
      character*1 message(80)
      character*8 atom1,atom2,keyword

      integer ntpvdw,ntpatm,keyfce,fail,idum,ivdw
      integer itpvdw,keypot,numpar,katom1,katom2,jtpatm,keyvdw,i
      integer ntab,idnode,j
      real(8) dlrpot,rvdw,engunit
      real(8), allocatable :: parpot(:)

      allocate (parpot(mxpvdw),stat=fail)

      ntpvdw=intstr(record,lenrec,idum)

      ltable=findstring('table',record,idum)

      if(idnode.eq.0) then

        write(nrite,"(/,/,1x,'number of specified pair ',
     x    'potentials',i10)") ntpvdw
        write(nrite,"(/,/,16x,'atom 1  ','atom 2  ',3x,
     x    ' key',30x,'parameters'/,/)")

      endif

      if(ntpvdw.gt.mxvdw) call error(idnode,80)
      if(.not.lunits) call error(idnode,6)
      if(.not.lmols) call error(idnode,13)

      do ivdw=1,mxvdw

        lstvdw(ivdw)=0
        ltpvdw(ivdw)=-1

      enddo

      do itpvdw=1,ntpvdw

        do i=1,mxpvdw
          parpot(i)=0.d0
        enddo

        call getrec(safe,idnode,nfield)
        if(.not.safe)return

        call copystring(record,message,80)
        call getword(atom1,record,8,lenrec)
        call getword(atom2,record,8,lenrec)
        call lowcase(record,lenrec-16)
        call getword(keyword,record,4,lenrec)

        if(keyword(1:4).eq.'12-6') then
          keypot=1
          numpar=2
        elseif(keyword(1:4).eq.'lj  ') then
          keypot=2
          numpar=2
        elseif(keyword(1:4).eq.'nm  ') then
          keypot=3
          numpar=4
        elseif(keyword(1:4).eq.'buck') then
          keypot=4
          numpar=3
        elseif(keyword(1:4).eq.'bhm ') then
          keypot=5
          numpar=5
        elseif(keyword(1:4).eq.'hbnd') then
          keypot=6
          numpar=2
        elseif(keyword(1:4).eq.'snm ') then
          keypot=7
          numpar=5
        elseif(keyword(1:4).eq.'mors') then
          keypot=8
          numpar=3
        elseif(keyword(1:4).eq.'wca ') then
          keypot=9
          numpar=3
        elseif(keyword(1:4).eq.'gaus') then
          keypot=10
          numpar=6
        elseif(keyword(1:4).eq.'tab ') then
          keypot=0
          numpar=0
        else
          if(idnode.eq.0) write(nrite,*) message
          call error(idnode,452)
        endif

        parpot(1)=dblstr(record,lenrec,idum)
        parpot(2)=dblstr(record,lenrec,idum)
        parpot(3)=dblstr(record,lenrec,idum)
        parpot(4)=dblstr(record,lenrec,idum)
        parpot(5)=dblstr(record,lenrec,idum)
        parpot(6)=dblstr(record,lenrec,idum)

        if(idnode.eq.0)
     x    write(nrite,"(16x,2a8,2x,a4,3x,1p,9e13.5)")
     x    atom1,atom2,keyword(1:4),(parpot(j),j=1,numpar)

        katom1=0
        katom2=0

        do jtpatm=1,ntpatm

          if(atom1.eq.unqatm(jtpatm))katom1=jtpatm
          if(atom2.eq.unqatm(jtpatm))katom2=jtpatm

        enddo

        if(katom1.eq.0.or.katom2.eq.0) then
          call  error(idnode,81)
        endif

        keyvdw=loc2(katom1,katom2)

c     convert energies to internal unit

        if(keyvdw.gt.mxvdw) call error(idnode,82)

        parpot(1)=parpot(1)*engunit

        if(keypot.eq.1) then

          parpot(2)=parpot(2)*engunit

        else if(keypot.eq.4) then

          parpot(3)=parpot(3)*engunit

        else if(keypot.eq.5) then

          parpot(4)=parpot(4)*engunit
          parpot(5)=parpot(5)*engunit

        else if(keypot.eq.6) then

          parpot(2)=parpot(2)*engunit

        else if(keypot.eq.10) then

          parpot(3)=parpot(3)*engunit
          parpot(5)=parpot(5)*engunit

        endif

        ltable=(ltable.or.(keypot.eq.0))

        if(lstvdw(keyvdw).ne.0) call error(idnode,15)
        lstvdw(keyvdw)=itpvdw
        ltpvdw(itpvdw)=keypot

        do i=1,mxpvdw

          prmvdw(itpvdw,i)=parpot(i)

        enddo

      enddo

c     generate nonbonded force arrays

      if((ntpvdw.gt.0.and.mod(keyfce,2).eq.1).or.(keyfce.eq.2))
     x  then

        call forgen(ltable,idnode,ntpvdw,dlrpot,rvdw)

        if(ltable)then

          call fortab
     x      (idnode,ntpvdw,ntpatm,dlrpot,rvdw,engunit)

        endif

      endif

c     check for unspecified atom-atom potentials

      ntab=(ntpatm*(ntpatm+1))/2

      if(ntpvdw.lt.ntab) then

        call warning(idnode,110,0.d0,0.d0,0.d0)

        if(mxvdw.le.ntpvdw) call error(idnode,82)

        do i=1,ntab

          if(lstvdw(i).eq.0)then

            lstvdw(i)=ntpvdw+1

          endif

        enddo

c     define zero potential for undefined interactions

        do i=1,mxgrid

          ggg(i,ntpvdw+1)=0.d0
          vvv(i,ntpvdw+1)=0.d0

        enddo

      endif

      deallocate (parpot,stat=fail)

      return
      end subroutine define_van_der_waals

      subroutine forgen(ltable,idnode,ntpvdw,dlrpot,rcut)

c***********************************************************************
c
c     dl_poly subroutine for generating potential energy and
c     force arrays for van der waals forces only
c
c     copyright - daresbury laboratory 1992
c     author    - w. smith may 1992.
c
c***********************************************************************

      implicit none

      logical ltable
      integer i,ivdw,ntpvdw,idnode
      real(8) dlrpot,rcut,rrr,ann,amm,gam,bet,eps,rr0,aaa,bbb
      real(8) ccc,ddd,eee,sig,rho,rrc,aa1,aa2,aa3,ee1,ee2,ee3
      real(8) rsq,ex1,ex2,ex3

c     define grid resolution for potential arrays

      dlrpot=rcut/dble(mxgrid-4)

c     construct arrays for all types of short ranged  potential

      do ivdw=1,ntpvdw

        if(ltpvdw(ivdw).eq.1)then

c       12 - 6 potential

          aaa=prmvdw(ivdw,1)
          bbb=prmvdw(ivdw,2)

          do i=1,mxgrid

            rrr=dble(i)*dlrpot
            vvv(i,ivdw)=(aaa/rrr**6-bbb)/rrr**6
            ggg(i,ivdw)=6.d0*(2.d0*aaa/rrr**6-bbb)/rrr**6

          enddo

        else if(ltpvdw(ivdw).eq.2)then

c       lennard-jones potential

          eps=prmvdw(ivdw,1)
          sig=prmvdw(ivdw,2)

          do i=1,mxgrid

            rrr=dble(i)*dlrpot
            vvv(i,ivdw)=4.d0*eps*(sig/rrr)**6*((sig/rrr)**6-1.d0)
            ggg(i,ivdw)=24.d0*eps*(sig/rrr)**6*(2.d0*(sig/rrr)**6-1.d0)

          enddo

        else if(ltpvdw(ivdw).eq.3)then

c       n - m potential

          eps=prmvdw(ivdw,1)
          ann=max(prmvdw(ivdw,2),prmvdw(ivdw,3))
          amm=min(prmvdw(ivdw,2),prmvdw(ivdw,3))
          rr0=prmvdw(ivdw,4)

          do i=1,mxgrid

            rrr=dble(i)*dlrpot
            vvv(i,ivdw)=eps/(ann-amm)*(amm*(rr0/rrr)**ann-
     x        ann*(rr0/rrr)**amm)
            ggg(i,ivdw)=eps*amm*ann/(ann-amm)*((rr0/rrr)**ann-
     x        (rr0/rrr)**amm)

          enddo

        else if(ltpvdw(ivdw).eq.4)then

c       buckingham exp - 6 potential

          aaa=prmvdw(ivdw,1)
          rho=prmvdw(ivdw,2)
          ccc=prmvdw(ivdw,3)

          do i=1,mxgrid

            rrr=dble(i)*dlrpot
            vvv(i,ivdw)=aaa*exp(-rrr/rho)-ccc/rrr**6
            ggg(i,ivdw)=rrr*aaa*exp(-rrr/rho)/rho-6.d0*ccc/rrr**6

          enddo

        else if(ltpvdw(ivdw).eq.5)then

c       born-huggins-meyer exp - 6 - 8 potential

          aaa=prmvdw(ivdw,1)
          bbb=prmvdw(ivdw,2)
          ccc=prmvdw(ivdw,3)
          ddd=prmvdw(ivdw,4)
          eee=prmvdw(ivdw,5)

          do i=1,mxgrid

            rrr=dble(i)*dlrpot
            vvv(i,ivdw)=aaa*exp(bbb*(ccc-rrr))-ddd/rrr**6-eee/rrr**8
            ggg(i,ivdw)=rrr*aaa*bbb*exp(bbb*(ccc-rrr))-6.d0*ddd/rrr**6
     x        -8.d0*eee/rrr**8

          enddo

        else if(ltpvdw(ivdw).eq.6) then

c       Hydrogen-bond 12 - 10 potential

          aaa=prmvdw(ivdw,1)
          bbb=prmvdw(ivdw,2)

          do i=1,mxgrid

            rrr=dble(i)*dlrpot
            vvv(i,ivdw)=aaa/rrr**12-bbb/rrr**10
            ggg(i,ivdw)=12.0d0*aaa/rrr**12-10.d0*bbb/rrr**10

          enddo

        else if(ltpvdw(ivdw).eq.7) then

c       shifted and force corrected n - m potential (w. smith)

          eps=prmvdw(ivdw,1)
          ann=prmvdw(ivdw,2)
          amm=prmvdw(ivdw,3)
          rr0=prmvdw(ivdw,4)
          rrc=prmvdw(ivdw,5)
          if(rrc.lt.1.d-6)rrc=rcut

          if(ann.le.amm) call error(idnode,470)

          gam=rrc/rr0
          if(gam.lt.1.d0) call error(idnode,468)
          bet=gam*((gam**(amm+1.d0)-1.d0)/(gam**(ann+1.d0)-1.d0))
     x      **(1.d0/(ann-amm))
          eps=-eps*(ann-amm)/(amm*(bet**ann)*(1.d0+(ann/gam-ann-1.d0)
     x      /gam**ann)-ann*(bet**amm)*(1.d0+(amm/gam-amm-1.d0)
     x      /gam**amm))

          do i=1,mxgrid

            rrr=dble(i)*dlrpot
            if(rrr.gt.rrc)then

              vvv(i,ivdw)=0.d0
              ggg(i,ivdw)=0.d0

            else

              vvv(i,ivdw)=eps/(ann-amm)*(amm*(bet**ann)*((rr0/rrr)**ann-
     x          (1.d0/gam)**ann)-ann*(bet**amm)*((rr0/rrr)**amm-
     x          (1.d0/gam)**amm)+ann*amm*((rrr/(gam*rr0)-1.d0)*
     x          ((bet/gam)**ann-(bet/gam)**amm)))
              ggg(i,ivdw)=eps*amm*ann/(ann-amm)*((bet**ann)*
     x          (rr0/rrr)**ann-(bet**amm)*(rr0/rrr)**amm-rrr/
     x          (gam*rr0)*((bet/gam)**ann-(bet/gam)**amm))

            endif

          enddo

        else if(ltpvdw(ivdw).eq.8) then

c       morse potential

          eps=prmvdw(ivdw,1)
          rr0=prmvdw(ivdw,2)
          sig=prmvdw(ivdw,3)

          do i=1,mxgrid

            rrr=dble(i)*dlrpot
            vvv(i,ivdw)=eps*((1.d0-exp(-sig*(rrr-rr0)))**2-1.d0)
            ggg(i,ivdw)=-2.d0*rrr*eps*sig*(1.d0-exp(-sig*(rrr-rr0)))*
     x        exp(-sig*(rrr-rr0))

          enddo

        else if(ltpvdw(ivdw).eq.9) then

c       weeks-chandler-anderson potential

          eps=prmvdw(ivdw,1)
          sig=prmvdw(ivdw,2)
          rr0=prmvdw(ivdw,3)
          ddd=sig*2.d0**(1.d0/6.d0)

          do i=1,mxgrid

            rrr=dble(i)*dlrpot-rr0
            if(rrr.gt.ddd)then

              vvv(i,ivdw)=0.d0
              ggg(i,ivdw)=0.d0

            else if(rrr.gt.0.d0)then

              vvv(i,ivdw)=4.d0*eps*(sig/rrr)**6*
     x          ((sig/rrr)**6-1.d0)+eps
              ggg(i,ivdw)=24.d0*eps*(1.d0+rr0/rrr)*(sig/rrr)**6*
     x          (2.d0*(sig/rrr)**6-1.d0)

            endif

          enddo

        else if(ltpvdw(ivdw).eq.10)then

c       gaussian potential

          aa1=prmvdw(ivdw,1)
          ee1=prmvdw(ivdw,2)
          aa2=prmvdw(ivdw,3)
          ee2=prmvdw(ivdw,4)
          aa3=prmvdw(ivdw,5)
          ee3=prmvdw(ivdw,6)

          do i=1,mxgrid

            rsq=(dble(i)*dlrpot)**2
            ex1=aa1*exp(-rsq*ee1)
            ex2=aa2*exp(-rsq*ee2)
            ex3=aa3*exp(-rsq*ee3)
            vvv(i,ivdw)=ex1+ex2+ex3
            ggg(i,ivdw)=2.d0*rsq*(ee1*ex1+ee2*ex2+ee3*ex3)

          enddo

        else if(ltpvdw(ivdw).lt.100) then

          if(.not.ltable)call error(idnode,150)

        endif

      enddo

      return
      end subroutine forgen

      subroutine fortab
     x  (idnode,ntpvdw,ntpatm,dlrpot,rcut,engunit)

c***********************************************************************
c
c     dl_poly subroutine for reading potential energy and
c     force arrays for van der waals forces only
c
c     copyright - daresbury laboratory 1994
c     author    - w. smith march 1994
c
c***********************************************************************

      implicit none

      logical safe
      character*8 atom1,atom2
      integer idnode,ntpvdw,ntpatm,idum,ngrid
      integer ivdw,katom1,katom2,jtpatm,l,i,j,k,keyvdw
      real(8) dlrpot,rcut,engunit,delpot,cutpot,rdr,rrr,ppp
      real(8) vk0,vk1,vk2,t1,t2

      if(idnode.eq.0)open (ntable,file='TABLE')

c     skip header record

      call getrec(safe,idnode,ntable)
      if(.not.safe)call abort_table_read(idnode,ntable)

c     read mesh resolution

      call getrec(safe,idnode,ntable)
      if(.not.safe)call abort_table_read(idnode,ntable)
      delpot=dblstr(record,lenrec,idum)
      cutpot=dblstr(record,lenrec,idum)
      ngrid=intstr(record,lenrec,idum)

      dlrpot=rcut/dble(mxgrid-4)

      if (abs(delpot-dlrpot) <= 1.0d-8) delpot=dlrpot
      if ((delpot>dlrpot) .or. (ngrid-4 /= nint(cutpot/delpot))) then

         if (idnode == 0) write(nrite,"(
     x    'expected radial increment : ',1p,e15.7,/,
     x    'TABLE    radial increment : ',1p,e15.7,/,/,
     x    'expected number of grid points : ',0p,i10,/,
     x    'grid points in TABLE           : ',i10)")
     x    dlrpot, delpot, mxgrid, ngrid

         call error(idnode,22)

      endif

      if(cutpot.lt.rcut) call error(idnode,504)
      if(abs(1.d0-(delpot/dlrpot)).gt.1.0d-8) then
        if(idnode.eq.0) write(nrite,
     x    "(/,' TABLE arrays resized for mxgrid=',i10)") mxgrid
      endif

c     read potential arrays for all pairs

      do ivdw=1,ntpvdw

c     read potential arrays if potential not already defined

        if(ltpvdw(ivdw).eq.0)then

c     read pair potential labels and long range corrections

          call getrec(safe,idnode,ntable)
          if(.not.safe)call abort_table_read(idnode,ntable)

          call getword(atom1,record,8,lenrec)
          call getword(atom2,record,8,lenrec)
          prmvdw(ivdw,1)=dblstr(record,lenrec,idum)
          prmvdw(ivdw,2)=dblstr(record,lenrec,idum)

          katom1=0
          katom2=0

          do jtpatm=1,ntpatm

            if(atom1.eq.unqatm(jtpatm))katom1=jtpatm
            if(atom2.eq.unqatm(jtpatm))katom2=jtpatm

          enddo

          if(katom1.eq.0.or.katom2.eq.0)then
            if(idnode.eq.0)
     x        write(nrite,'(a)') '****',atom1,'***',atom2,'****'
            call  error(idnode,81)
          endif

          keyvdw=loc2(katom1,katom2)

          if(lstvdw(keyvdw).ne.ivdw) call error(idnode,23)

c     read potential arrays

          if(mxbuff.lt.ngrid)  then

            if(idnode.eq.0)
     x         write(nrite,*) 'mxbuff must be >=',ngrid,' in fortab'
            call error(idnode,48)

          endif

c     read in potential arrays

          do i=1,(ngrid+3)/4

             l=min(4,ngrid-(i-1)*4)
             if (idnode == 0) then
                read(unit=ntable, fmt=*, end=100)
     x              (buffer((i-1)*4+j),j=1,l)
             else
                buffer((i-1)*4+1:(i-1)*4+l)=0.0d0
             endif

          enddo
          call gdsum(buffer(1:ngrid),ngrid,buffer(ngrid+1:2*ngrid))

c     reconstruct arrays using 3pt interpolation

          rdr=1.d0/delpot
          vvv(1,ivdw)=1.d0
          ggg(1,ivdw)=0.d0
          do i=2,mxgrid

            rrr=dble(i)*dlrpot
            l=int(rrr*rdr)
            ppp=rrr*rdr-dble(l)
            vk0=buffer(l)
            vk1=buffer(l+1)
            vk2=buffer(l+2)

            t1=vk0+(vk1-vk0)*ppp
            t2=vk1+(vk2-vk1)*(ppp-1.0d0)
            vvv(i,ivdw)=t1+(t2-t1)*ppp*0.5d0

          enddo

c     read in force arrays

          do i=1,(ngrid+3)/4

             l=min(4,ngrid-(i-1)*4)
             if (idnode == 0) then
                read(unit=ntable, fmt=*, end=100)
     x              (buffer((i-1)*4+j),j=1,l)
             else
                buffer((i-1)*4+1:(i-1)*4+l)=0.0d0
             endif

          enddo
          call gdsum(buffer(1:ngrid),ngrid,buffer(ngrid+1:2*ngrid))

c     reconstruct ggg arrays using 3pt interpolation

          do i=2,mxgrid

            rrr=dble(i)*dlrpot
            l=int(rrr*rdr)
            ppp=rrr*rdr-dble(l)
            vk0=buffer(l)
            vk1=buffer(l+1)
            vk2=buffer(l+2)

            t1=vk0+(vk1-vk0)*ppp
            t2=vk1+(vk2-vk1)*(ppp-1.0d0)

            ggg(i,ivdw)=t1+(t2-t1)*ppp*0.5d0

          enddo

        endif

      enddo

c     convert to internal units

      do k=1,ntpvdw

        if(ltpvdw(k).eq.0)then

          do i=1,mxgrid

            vvv(i,k)=vvv(i,k)*engunit
            ggg(i,k)=ggg(i,k)*engunit

          enddo

        endif

      enddo

      if(idnode.eq.0)close (ntable)

      if(idnode.eq.0)write(nrite,'(/,/,1x,a)')
     x  'potential tables read from TABLE file'

      return

c     end of file error exit

  100 call abort_table_read(idnode,ntable)

      end subroutine fortab

      subroutine abort_table_read(idnode,ntable)

c***********************************************************************
c
c     dl_poly error exit subroutine for reading TABLE file
c
c     copyright - daresbury laboratory
c     author    - w. smith   sept 2005
c
c***********************************************************************

      implicit none
      integer idnode,ntable

      if(idnode.eq.0)close (ntable)

      call error(idnode,24)

      end subroutine abort_table_read

      subroutine srfrce
     x  (lsolva,lfree,lghost,iatm,ik,engsrp,virsrp,rcut,dlrpot)

c***********************************************************************
c
c     dl_poly subroutine for calculating short range force and
c     potential energy terms using verlet neighbour list
c
c     parallel replicated data version
c
c     copyright - daresbury laboratory 1992
c     author    - w. smith       march 1992
c
c     version 3
c     author    - t. forester    june  1993
c     stress tensor added t.forester may 1994
c     adapted   - p.-a. cazade oct 2007: solvation, free energy etc
c     adapted   - d. quigley - metadynamics
c
c***********************************************************************

      implicit none

      logical lsolva,lfree,lghost,lselect,lskip,idrive,jdrive
      integer iatm,ik,m,jatm,k,l,kkk
      real(8) engsrp,virsrp,rcut,dlrpot
      real(8) ab,rrr,rsq,ppp,t1,t2,vk0,vk1,vk2,gk0,gk1,gk2,gamma
      real(8) fi,rcsq,rdr,ai,aj,fx,fy,fz,omega
      real(8) strs(6),strs_loc(6)

      dimension fi(3)

CDIR$ CACHE_ALIGN fi

      lskip=(lfree.or.lghost)
      if(lmetadyn)idrive=driven(ltype(iatm))

c     set cutoff condition for pair forces

      rcsq=rcut**2

c     interpolation spacing

      rdr=1.d0/dlrpot

c     initialise stress tensor accumulators

      strs(:)=0.d0
      strs_loc(:)=0.d0

c     initialise potential energy and virial

      engsrp=0.d0
      virsrp=0.d0

c     store forces for iatm

      ai=dble(ltype(iatm))
      fi(1)=fxx(iatm)
      fi(2)=fyy(iatm)
      fi(3)=fzz(iatm)

c     start of primary loop for forces evaluation

      do m=1,ik

c     atomic and potential function indices

        jatm=ilist(m)
        if(lmetadyn)jdrive=driven(ltype(jatm))

        if(lskip)then
          if(atm_fre(iatm)*atm_fre(jatm).eq.2)cycle
        endif

        aj=dble(ltype(jatm))

        if(ai.gt.aj) then
          ab=ai*(ai-1.d0)*0.5d0+aj+0.5d0
        else
          ab=aj*(aj-1.d0)*0.5d0+ai+0.5d0
        endif

        k=lstvdw(int(ab))

        if((ltpvdw(k).lt.100).and.(abs(vvv(1,k)).gt.1.d-10))then

c     apply truncation of potential

          rsq=rsqdf(m)

          if(rcsq.gt.rsq)then

            rrr=sqrt(rsq)
            l=int(rrr*rdr)
            ppp=rrr*rdr-dble(l)

            if(l.eq.0)then

              omega=vvv(1,k)
              gamma=ggg(1,k)

            else

c     calculate interaction energy using 3-point interpolation

              vk0=vvv(l,k)
              vk1=vvv(l+1,k)
              vk2=vvv(l+2,k)
              t1=vk0+(vk1-vk0)*ppp
              t2=vk1+(vk2-vk1)*(ppp-1.0d0)
              omega=t1+(t2-t1)*ppp*0.5d0

c     calculate forces using 3-point interpolation

              gk0=ggg(l,k)
              gk1=ggg(l+1,k)
              gk2=ggg(l+2,k)
              t1=gk0+(gk1-gk0)*ppp
              t2=gk1+(gk2-gk1)*(ppp-1.0d0)
              gamma=(t1+(t2-t1)*ppp*0.5d0)/rsq

            endif

c     set selection control

            lselect=.true.

c     set double index

            if(lsolva)kkk=loc2(atmolt(iatm),atmolt(jatm))

            if(lghost)then

c     selected excitation option

              if((atm_fre(iatm).ne.1).and.(atm_fre(jatm).ne.1))then

c     reset selection control

                lselect=(atm_fre(iatm)+atm_fre(jatm).eq.0)

                if(lsolva)vdw_exc(kkk)=vdw_exc(kkk)+omega

              endif

            elseif(lfree)then

c     selected free energy option

              if((atm_fre(iatm).eq.1).or.(atm_fre(jatm).eq.1))then

c     set hamiltonian mixing parameter

                vdw_fre=vdw_fre-omega
                vdw_vir=vdw_vir+gamma*rsq
                omega=lambda1*omega
                gamma=lambda1*gamma

              elseif((atm_fre(iatm).eq.2).or.(atm_fre(jatm).eq.2))then

c     set hamiltonian mixing parameter

                vdw_fre=vdw_fre+omega
                vdw_vir=vdw_vir-gamma*rsq
                omega=lambda2*omega
                gamma=lambda2*gamma

              endif

            endif

            if(lselect)then

c     calculate potential and virial

              engsrp=engsrp+omega
              virsrp=virsrp-gamma*rsq

              if(lsolva)vdw_sol(kkk)=vdw_sol(kkk)+omega

c     calculate forces

              fx=gamma*xdf(m)
              fy=gamma*ydf(m)
              fz=gamma*zdf(m)

              fi(1)=fi(1)+fx
              fi(2)=fi(2)+fy
              fi(3)=fi(3)+fz

              fxx(jatm)=fxx(jatm)-fx
              fyy(jatm)=fyy(jatm)-fy
              fzz(jatm)=fzz(jatm)-fz

c     calculate stress tensor

              strs(1)=strs(1)+xdf(m)*fx
              strs(2)=strs(2)+xdf(m)*fy
              strs(3)=strs(3)+xdf(m)*fz
              strs(4)=strs(4)+ydf(m)*fy
              strs(5)=strs(5)+ydf(m)*fz
              strs(6)=strs(6)+zdf(m)*fz

            endif

            if(lmetadyn.and.(idrive.or.jdrive))then

              eng_loc=eng_loc+omega
              vir_loc=vir_loc-gamma*rsq

              fxx_loc(iatm)=fxx_loc(iatm)+fx
              fyy_loc(iatm)=fyy_loc(iatm)+fy
              fzz_loc(iatm)=fzz_loc(iatm)+fz

              fxx_loc(jatm)=fxx_loc(jatm)-fx
              fyy_loc(jatm)=fyy_loc(jatm)-fy
              fzz_loc(jatm)=fzz_loc(jatm)-fz

              strs_loc(1)=strs_loc(1)+xdf(m)*fx
              strs_loc(2)=strs_loc(2)+xdf(m)*fy
              strs_loc(3)=strs_loc(3)+xdf(m)*fz
              strs_loc(4)=strs_loc(4)+ydf(m)*fy
              strs_loc(5)=strs_loc(5)+ydf(m)*fz
              strs_loc(6)=strs_loc(6)+zdf(m)*fz

            endif

          endif

        endif

      enddo

c     load temps back to fxx(iatm) etc

      fxx(iatm)=fi(1)
      fyy(iatm)=fi(2)
      fzz(iatm)=fi(3)

c     complete stress tensor

      stress(1)=stress(1)+strs(1)
      stress(2)=stress(2)+strs(2)
      stress(3)=stress(3)+strs(3)
      stress(4)=stress(4)+strs(2)
      stress(5)=stress(5)+strs(4)
      stress(6)=stress(6)+strs(5)
      stress(7)=stress(7)+strs(3)
      stress(8)=stress(8)+strs(5)
      stress(9)=stress(9)+strs(6)

      if(lmetadyn)then

        stress_loc(1)=stress_loc(1)+strs_loc(1)
        stress_loc(2)=stress_loc(2)+strs_loc(2)
        stress_loc(3)=stress_loc(3)+strs_loc(3)
        stress_loc(4)=stress_loc(4)+strs_loc(2)
        stress_loc(5)=stress_loc(5)+strs_loc(4)
        stress_loc(6)=stress_loc(6)+strs_loc(5)
        stress_loc(7)=stress_loc(7)+strs_loc(3)
        stress_loc(8)=stress_loc(8)+strs_loc(5)
        stress_loc(9)=stress_loc(9)+strs_loc(6)

      endif

      return
      end subroutine srfrce

      subroutine lrcorrect
     x  (lsolva,lfree,lghost,idnode,imcon,keyfce,natms,
     x  ntpatm,ntpvdw,elrc,engunit,virlrc,rcut,volm)

c*************************************************************************
c
c     DL_POLY subroutine to evaluate long-range corrections to
c     pressure and energy in a periodic system.
c
c     copyright daresbury laboratory 1993
c     author    - t. forester may 1993
c     adapted   - p.-a. cazade oct 2007: solvation, free energy etc
c
c***************************************************************************

      implicit none

      integer, parameter :: nnn=10
      logical lsolva,lfree,lghost
      integer idnode,imcon,keyfce,natms,ntpatm,i,ka,ntpvdw
      integer ivdw,j,k,it,jt,kt,fail
      real(8) natyp,nbtyp,nctyp,ndtyp,nafrz,nbfrz,ncfrz,ndfrz
      real(8) elrc,engunit,virlrc,rcut,volm,twopi,eadd,padd
      real(8) denprd,aaa,bbb,ccc,ddd,eee,eps,sig,rr0,ann,amm
      real(8) denprd1,denprd2,denprd3,denprdf
      integer, allocatable :: numtyp_sol0(:,:),numfrz_sol0(:,:)
      integer, allocatable :: numtyp_sol1(:,:),numfrz_sol1(:,:)
      integer, allocatable :: numtyp_sol2(:,:),numfrz_sol2(:,:)
      integer, allocatable :: numtyp_fre(:,:),numfrz_fre(:,:)
      real(8), allocatable :: elrc_sol0(:),elrc_exc0(:)

      dimension fail(nnn)

      twopi=2.0d0*pi

c     allocate working arrays

      do i=1,nnn
        fail(i)=0
      enddo

      if(lfree.or.lghost)then

        allocate (numtyp_fre(mxatyp,0:2),stat=fail(1))
        allocate (numfrz_fre(mxatyp,0:2),stat=fail(2))
        allocate (elrc_exc0(mxtmls_exc2),stat=fail(3))

      endif

      if(lsolva)then

        allocate (elrc_sol0(mxtmls_sol2),stat=fail(4))
        allocate (numtyp_sol0(mxatyp,mxtmls),stat=fail(5))
        allocate (numfrz_sol0(mxatyp,mxtmls),stat=fail(6))

        if(lghost)then

          allocate (numtyp_sol1(mxatyp,mxtmls),stat=fail(7))
          allocate (numfrz_sol1(mxatyp,mxtmls),stat=fail(8))
          allocate (numtyp_sol2(mxatyp,mxtmls),stat=fail(9))
          allocate (numfrz_sol2(mxatyp,mxtmls),stat=fail(10))

        endif

      endif

      do i=1,nnn
        if(fail(i).ne.0)call error(idnode,1015)
      enddo

c     initalise counter arrays

      do i=1,ntpatm

        numtyp(i)=0
        numfrz(i)=0

      enddo

      if(lfree.or.lghost)then

        numtyp_fre(:,:)=0
        numfrz_fre(:,:)=0

      endif

      if(lsolva)then

        numtyp_sol0(:,:)=0
        numfrz_sol0(:,:)=0

        if(lghost)then

          numtyp_sol1(:,:)=0
          numfrz_sol1(:,:)=0
          numtyp_sol2(:,:)=0
          numfrz_sol2(:,:)=0

        endif

      endif

c     evaluate number density in system

      do i=1,natms

        ka=ltype(i)
        numtyp(ka)=numtyp(ka)+1
        if(lstfrz(i).ne.0)numfrz(ka)=numfrz(ka)+1

      enddo

      if(lfree.or.lghost)then

        do i=1,natms

          ka=ltype(i)
          numtyp_fre(ka,atm_fre(i))=numtyp_fre(ka,atm_fre(i))+1
          if(lstfrz(i).ne.0)
     x      numfrz_fre(ka,atm_fre(i))=numfrz_fre(ka,atm_fre(i))+1

        enddo

      endif

      if(lsolva)then

        if(lghost)then

          do i=1,natms

            ka=ltype(i)

            if(atm_fre(i).eq.0)then

              numtyp_sol0(ka,atmolt(i))=numtyp_sol0(ka,atmolt(i))+1
              if(lstfrz(i).ne.0)
     x          numfrz_sol0(ka,atmolt(i))=numfrz_sol0(ka,atmolt(i))+1

            elseif(atm_fre(i).eq.1)then

              numtyp_sol1(ka,atmolt(i))=numtyp_sol1(ka,atmolt(i))+1
              if(lstfrz(i).ne.0)
     x          numfrz_sol1(ka,atmolt(i))=numfrz_sol1(ka,atmolt(i))+1

            elseif(atm_fre(i).eq.2)then

              numtyp_sol2(ka,atmolt(i))=numtyp_sol2(ka,atmolt(i))+1
              if(lstfrz(i).ne.0)
     x          numfrz_sol2(ka,atmolt(i))=numfrz_sol2(ka,atmolt(i))+1

            endif

          enddo

        else

          do i=1,natms

            ka=ltype(i)
            numtyp_sol0(ka,atmolt(i))=numtyp_sol0(ka,atmolt(i))+1
            if(lstfrz(i).ne.0)
     x        numfrz_sol0(ka,atmolt(i))=numfrz_sol0(ka,atmolt(i))+1

          enddo

        endif

      endif

c     number densities

      do i=1,ntpatm
        dens(i)=dble(numtyp(i))/volm
      enddo

c     long range corrections to energy and pressure

      elrc=0.d0
      elrc2=0.d0
      virlrc=0.d0
      virlrc2=0.d0
      denprdf=0.d0
      volm_sav=0.d0
      elrc_fre=0.d0
      vlrc_fre=0.d0

      if(imcon.ne.0.and.imcon.ne.6.and.ntpvdw.gt.0) then

        if(mod(keyfce,2).eq.1) then

          ivdw=0

          do i=1,ntpatm

            do j=1,i

              eadd=0.d0
              padd=0.d0

              ivdw=ivdw+1
              k=lstvdw(ivdw)

              if(ltpvdw(k).eq.0) then

c     tabulated potential

                eadd=prmvdw(k,1)
                padd=-prmvdw(k,2)

              else if(ltpvdw(k).eq.1) then

c     12-6 potential

                aaa=prmvdw(k,1)
                bbb=prmvdw(k,2)

                eadd=aaa/(9.d0*rcut**9)-bbb/(3.d0*rcut**3)
                padd=12.d0*aaa/(9.d0*rcut**9)-6.d0*bbb/(3.d0*rcut**3)

              else if(ltpvdw(k).eq.2) then

c     Lennard Jones potential

                eps=prmvdw(k,1)
                sig=prmvdw(k,2)

                eadd=4.d0*eps*(sig**12/(9.d0*rcut**9)-
     x            sig**6/(3.d0*rcut**3))
                padd=4.d0*eps*(12.d0*sig**12/(9.d0*rcut**9)-
     x            2.d0*sig**6/(rcut**3))

              else if(ltpvdw(k).eq.3) then

c     n - m potential

                eps=prmvdw(k,1)
                ann=prmvdw(k,2)
                amm=prmvdw(k,3)
                rr0=prmvdw(k,4)

                eadd=eps/(ann-amm)*(amm*rr0**ann/((ann-3.d0)*
     x            rcut**(ann-3.d0))-ann*rr0**amm/((amm-3.0d0)*
     x            rcut**(amm-3.d0)))
                padd=eps/(ann-amm)*ann*amm*(rr0**ann/((ann-3.d0)*
     x            rcut**(ann-3.d0))-rr0**amm/((amm-3.0d0)*
     x            rcut**(amm-3.d0)))

              else if(ltpvdw(k).eq.4) then

c     buckingham exp - 6 potential

                ccc=prmvdw(k,3)

                eadd=-ccc/(3.d0*rcut**3)
                padd=-2.d0*ccc/(rcut**3)

              else if(ltpvdw(k).eq.5) then

c     born huggins meyer exp -6 - 8  potential

                ddd=prmvdw(k,4)
                eee=prmvdw(k,5)

                eadd=-ddd/(3.d0*rcut**3)-eee/(5.d0*rcut**5)
                padd=-2.d0*ddd/(rcut**3)-8.d0*eee/(5.d0*rcut**5)

              else if(ltpvdw(k).eq.6) then

c     hydrogen bond  12 - 10 potential

                aaa=prmvdw(k,1)
                bbb=prmvdw(k,2)

                eadd=aaa/(9.d0*rcut**9)-bbb/(7.d0*rcut**7)
                padd=12.d0*aaa/(9.d0*rcut**9)-1.d1*bbb/(7.d0*rcut**7)

              endif

              if(i.ne.j) then

                eadd=eadd*2.d0
                padd=padd*2.d0

              endif

              if(.not.(lfree.or.lghost))then

                denprd=twopi*(dble(numtyp(i))*dble(numtyp(j))-
     x            dble(numfrz(i))*dble(numfrz(j)))/volm**2

              else

                nafrz=dble(numfrz_fre(i,0)+numfrz_fre(i,1))
                natyp=dble(numtyp_fre(i,0)+numtyp_fre(i,1))
                nbfrz=dble(numfrz_fre(j,0)+numfrz_fre(j,1))
                nbtyp=dble(numtyp_fre(j,0)+numtyp_fre(j,1))
                ncfrz=dble(numfrz_fre(i,0)+numfrz_fre(i,2))
                nctyp=dble(numtyp_fre(i,0)+numtyp_fre(i,2))
                ndfrz=dble(numfrz_fre(j,0)+numfrz_fre(j,2))
                ndtyp=dble(numtyp_fre(j,0)+numtyp_fre(j,2))

                if(lghost)then

                  denprd=twopi*(natyp*nbtyp-nafrz*nbfrz)/volm**2
                  denprd3=twopi*(nctyp*ndtyp-ncfrz*ndfrz)/volm**2

                elseif(lfree)then

                  denprd1=twopi*(natyp*nbtyp-nafrz*nbfrz)/volm**2
                  denprd2=twopi*(nctyp*ndtyp-ncfrz*ndfrz)/volm**2
                  denprd=lambda1*denprd1+lambda2*denprd2
                  denprd3=lambda2*denprd1+lambda1*denprd2
                  denprdf=denprd2-denprd1

                endif

              endif

              elrc=elrc+volm*denprd*eadd
              virlrc=virlrc-denprd*padd*volm

              if(lfree.or.lghost)then

                elrc2=elrc2+volm*denprd3*eadd
                virlrc2=virlrc2-denprd3*padd*volm
                if(lfree)then
                  elrc_fre=elrc_fre+volm*denprdf*eadd
                  vlrc_fre=vlrc_fre-denprdf*padd*volm
                endif

              endif

              if(lsolva)then

                elrc_sol0(:)=0.d0
                if(lghost)elrc_exc0(:)=0.d0

                do it=1,mxtmls

                  do jt=1,mxtmls

                    kt=loc2(it,jt)

                    if(lghost)then

                      natyp=dble(numtyp_sol0(i,it)+numtyp_sol1(i,it))
                      nbtyp=dble(numtyp_sol0(j,jt)+numtyp_sol1(j,jt))
                      nafrz=dble(numfrz_sol0(i,it)+numfrz_sol1(i,it))
                      nbfrz=dble(numfrz_sol0(j,jt)+numfrz_sol1(j,jt))

                      elrc_sol0(kt)=elrc_sol0(kt)+twopi*(natyp*
     x                nbtyp-nafrz*nbfrz)/volm**2

                      nctyp=dble(numtyp_sol0(i,it)+numtyp_sol2(i,it))
                      ndtyp=dble(numtyp_sol0(j,jt)+numtyp_sol2(j,jt))
                      ncfrz=dble(numfrz_sol0(i,it)+numfrz_sol2(i,it))
                      ndfrz=dble(numfrz_sol0(j,jt)+numfrz_sol2(j,jt))

                      elrc_exc0(kt)=elrc_exc0(kt)+twopi*(nctyp*
     x                ndtyp-ncfrz*ndfrz)/volm**2

                    else

                      natyp=dble(numtyp_sol0(i,it))
                      nbtyp=dble(numtyp_sol0(j,jt))
                      nafrz=dble(numfrz_sol0(i,it))
                      nbfrz=dble(numfrz_sol0(j,jt))

                      elrc_sol0(kt)=elrc_sol0(kt)+twopi*(natyp*
     x                nbtyp-nafrz*nbfrz)/volm**2

                    endif

                  enddo

                enddo

                if(lghost)then

                  elrc_sol(:)=elrc_sol(:)+volm*eadd*elrc_sol0(:)
                  elrc_exc(:)=elrc_exc(:)+volm*eadd*elrc_exc0(:)

                else

                  elrc_sol(:)=elrc_sol(:)+volm*eadd*elrc_sol0(:)

                endif

              endif

            enddo

          enddo

          if(lfree.or.lghost)then

            elrc_sav=elrc
            elrc2_sav=elrc2
            virlrc_sav=virlrc
            virlrc2_sav=virlrc2
            elrc_fre_sav=elrc_fre
            vlrc_fre_sav=vlrc_fre

          endif

          volm_sav=volm

          if(lghost)then

            elrc_sol_sav(:)=elrc_sol(:)
            elrc_exc_sav(:)=elrc_exc(:)

          elseif(lsolva)then

            elrc_sol_sav(:)=elrc_sol(:)

          endif

        endif

      endif

      if(idnode.eq.0)then

        write(nrite,
     x    "(/,/,'long range correction for: vdw energy  ',e15.6,/,
     x    25x,': vdw pressure',e15.6)")elrc/engunit,
     x    prsunt*virlrc/(-3.d0*volm)

        if(lghost)
     x    write(nrite,
     x    "(/,/,'long range correction for: vdw energy  ',e15.6,/,
     x    25x,': vdw pressure',e15.6)")elrc2/engunit,
     x    prsunt*virlrc2/(-3.d0*volm)

      endif

c     deallocate work arrays

      if(lfree.or.lghost)
     x  deallocate (elrc_exc0,numtyp_fre,numfrz_fre,stat=fail(1))

      if(lsolva)then

        deallocate (elrc_sol0,numtyp_sol0,numfrz_sol0,stat=fail(2))

        if(lghost)then

          deallocate (numtyp_sol1,numfrz_sol1,stat=fail(3))
          deallocate (numtyp_sol2,numfrz_sol2,stat=fail(4))

        endif

      endif

      return
      end subroutine lrcorrect

      subroutine srfrceneu
     x  (lsolva,lfree,lghost,ik,engsrp,virsrp,dlrpot,rcut)

c***********************************************************************
c
c     dl_poly subroutine for calculating short range force and
c     potential energy terms using verlet neighbour list
c     neutral group implementation
c
c     parallel replicated data version
c
c     copyright - daresbury laboratory 1992
c     author    - w. smith       march 1992
c
c     neutral groups
c     author    - t. forester    march  1994
c
c     adapted   - p.-a. cazade oct 2007: solvation, free energy etc
c
c***********************************************************************

      implicit none

      logical lsolva,lfree,lghost,lselect,lskip,idrive,jdrive
      integer ik,m,iatm,jatm,l,k,kkk
      real(8) engsrp,virsrp,dlrpot,rcut,rcsq,fx,fy,fz,omega,omega_exc
      real(8) rrr,ppp,vk0,vk1,vk2,t1,t2,gk0,gk1,gk2,rdlpot,gamma
      real(8) ai,aj,ak,rsq,strs(6),strs_loc(6)

      lskip=(lfree.or.lghost)

c     set cutoff condition for pair forces

      rcsq=rcut**2

c     reciprocal of interpolation spacing

      rdlpot=1.d0/dlrpot

c     initialise stress tensor accumulators

      strs(:)=0.d0
      strs_loc(:)=0.d0

c     initialise potential energy and virial

      engsrp=0.d0
      virsrp=0.d0

c     start of primary loop for forces evaluation

      do m=1,ik

c     atomic and potential function indices

        iatm=ilist(m)
        jatm=jlist(m)

c     metadynamics local definitions

        if(lmetadyn)then

          idrive=driven(ltype(iatm))
          jdrive=driven(ltype(jatm))

        endif

        if(lskip)then
          if(atm_fre(iatm)*atm_fre(jatm).eq.2)cycle
        endif

        aj=ltype(jatm)
        ai=ltype(iatm)

        if(ai.gt.aj) then
          ak=(ai*(ai-1.d0)*0.5d0+aj+0.5d0)
        else
          ak=(aj*(aj-1.d0)*0.5d0+ai+0.5d0)
        endif
        k=lstvdw(int(ak))

        if(abs(vvv(1,k)).gt.1.d-10)then

          rsq=rsqdf(m)

          if(rsq.lt.rcsq) then

            rrr=sqrt(rsq)

c     determine interpolation panel for force arrays

            l=int(rrr*rdlpot)
            ppp=rrr*rdlpot-dble(l)

c     calculate interaction energy using 3-point interpolation

            vk0=vvv(l,k)
            vk1=vvv(l+1,k)
            vk2=vvv(l+2,k)
            t1=vk0+(vk1-vk0)*ppp
            t2=vk1+(vk2-vk1)*(ppp-1.0d0)
            omega=t1+(t2-t1)*ppp*0.5d0

c     calculate forces using 3-point interpolation

            gk0=ggg(l,k)
            gk1=ggg(l+1,k)
            gk2=ggg(l+2,k)
            t1=gk0+(gk1-gk0)*ppp
            t2=gk1+(gk2-gk1)*(ppp-1.0d0)
            gamma=(t1+(t2-t1)*ppp*0.5d0)/rsq

c     set selection control

            lselect=.true.

c     set double index

            if(lsolva)kkk=loc2(atmolt(iatm),atmolt(jatm))

            if(lghost)then

c     selected excitation option

              if((atm_fre(iatm).ne.1).and.(atm_fre(jatm).ne.1))then

c     reset selection control

                lselect=(atm_fre(iatm)+atm_fre(jatm).eq.0)

                if(lsolva)vdw_exc(kkk)=vdw_exc(kkk)+omega

              endif

            elseif(lfree)then

c     selected free energy option

              if((atm_fre(iatm).eq.1).or.(atm_fre(jatm).eq.1))then

c     set hamiltonian mixing parameter

                omega=lambda1*omega
                gamma=lambda1*gamma

              elseif((atm_fre(iatm).eq.2).or.(atm_fre(jatm).eq.2))then

c     set hamiltonian mixing parameter

                omega=lambda2*omega
                gamma=lambda2*gamma

              endif

            endif

            if(lselect)then

c     calculate potential energy and virial

              engsrp=omega+engsrp
              virsrp=virsrp-gamma*rsq

              if(lsolva)vdw_sol(kkk)=vdw_sol(kkk)+omega

              fx=gamma*xdf(m)
              fy=gamma*ydf(m)
              fz=gamma*zdf(m)

              fxx(iatm)=fxx(iatm)+fx
              fyy(iatm)=fyy(iatm)+fy
              fzz(iatm)=fzz(iatm)+fz

              fxx(jatm)=fxx(jatm)-fx
              fyy(jatm)=fyy(jatm)-fy
              fzz(jatm)=fzz(jatm)-fz

c     calculate stress tensor

              strs(1)=strs(1)+xdf(m)*fx
              strs(2)=strs(2)+xdf(m)*fy
              strs(3)=strs(3)+xdf(m)*fz
              strs(4)=strs(4)+ydf(m)*fy
              strs(5)=strs(5)+ydf(m)*fz
              strs(6)=strs(6)+zdf(m)*fz

            endif

c     metadynamics local parameters

            if(lmetadyn.and.(idrive.or.jdrive))then

c     local energy and virial

              eng_loc=eng_loc+omega
              vir_loc=vir_loc-gamma*rsq

c     local forces

              fxx_loc(iatm)=fxx_loc(iatm)+fx
              fyy_loc(iatm)=fyy_loc(iatm)+fy
              fzz_loc(iatm)=fzz_loc(iatm)+fz

              fxx_loc(jatm)=fxx_loc(jatm)-fx
              fyy_loc(jatm)=fyy_loc(jatm)-fy
              fzz_loc(jatm)=fzz_loc(jatm)-fz

c     local stress tensor

              strs_loc(1)=strs_loc(1)+xdf(m)*fx
              strs_loc(2)=strs_loc(2)+xdf(m)*fy
              strs_loc(3)=strs_loc(3)+xdf(m)*fz
              strs_loc(4)=strs_loc(4)+ydf(m)*fy
              strs_loc(5)=strs_loc(5)+ydf(m)*fz
              strs_loc(6)=strs_loc(6)+zdf(m)*fz

            endif

          endif

        endif

      enddo

c     complete stress tensor

      stress(1)=stress(1)+strs(1)
      stress(2)=stress(2)+strs(2)
      stress(3)=stress(3)+strs(3)
      stress(4)=stress(4)+strs(2)
      stress(5)=stress(5)+strs(4)
      stress(6)=stress(6)+strs(5)
      stress(7)=stress(7)+strs(3)
      stress(8)=stress(8)+strs(5)
      stress(9)=stress(9)+strs(6)

      if(lmetadyn)then

        stress_loc(1)=stress_loc(1)+strs_loc(1)
        stress_loc(2)=stress_loc(2)+strs_loc(2)
        stress_loc(3)=stress_loc(3)+strs_loc(3)
        stress_loc(4)=stress_loc(4)+strs_loc(2)
        stress_loc(5)=stress_loc(5)+strs_loc(4)
        stress_loc(6)=stress_loc(6)+strs_loc(5)
        stress_loc(7)=stress_loc(7)+strs_loc(3)
        stress_loc(8)=stress_loc(8)+strs_loc(5)
        stress_loc(9)=stress_loc(9)+strs_loc(6)

      endif

      return
      end subroutine srfrceneu

      end module vdw_module


      real*8 sand(360),silt(360),clay(360),bulk(360),satw(360),xxx(10)
      real*8 lat,lon,dep,orgc(360),wilt(360),field(360),wp,fc,swc
      real*8 sdgvm_wilt(360),sdgvm_field(360),sdgvm_satw(360),topsl
      REAL*8 nupc,awl(4),kd,kx,nci(4),nfix,adp(4),sfc(4),sw(4),sswc(4)

      integer i,j,ii(360)

      open(11,file='islscp2_soils_1deg/soil_bulk_dens0-30_1d.asc')
      open(12,file='islscp2_soils_1deg/soil_sand_perc0-30_1d.asc')
      open(13,file='islscp2_soils_1deg/soil_silt_perc0-30_1d.asc')
      open(14,file='islscp2_soils_1deg/soil_clay_perc0-30_1d.asc')
      open(15,file='islscp2_soils_1deg/soil_org_carb_perc0-30_1d.asc')
      open(16,file='islscp2_soils_1deg/soil_wilting_point0-30_1d.asc')
      open(17,file='islscp2_soils_1deg/soil_field_cap0-30_1d.asc')
      open(18,file='islscp2_soils_1deg/soil_sat_wat_cont0-30_1d.asc')
      open(19,file='islscp2_soils_1deg/soil_pawc0-30_1d.asc')
      open(20,file='islscp2_soils_1deg/soil_res_wat_cont0-30_1d.asc')
      open(21,file='islscp2_soils_1deg/soil_ksat0-30_1d.asc')
      open(22,file='islscp2_soils_1deg/soil_org_carb_dens0-30_1d.asc')
      open(23,file='islscp2_soils_1deg/soil_nitrogen_dens0-30_1d.asc')
      open(24,file='islscp2_soils_1deg/soil_therm_cap0_0-30_1d.asc')
      open(25,file='islscp2_soils_1deg/soil_therm_cap10_0-30_1d.asc')
      open(26,file='islscp2_soils_1deg/soil_therm_cap50_0-30_1d.asc')
      open(27,file='islscp2_soils_1deg/soil_therm_cap100_0-30_1d.asc')
      open(28,file='islscp2_soils_1deg/soil_texture0-30_1d.asc')

      open(29,file='../../../islscp/1deg_new/data.dat',status='old')

      open(31,file='../0-30/data.dat')
      open(32,file='../0-30/data_sdgvm.dat')

      dep =-99.0d0

      DO i=1,180
        read(11,*) bulk
        read(12,*) sand
        read(13,*) silt
        read(14,*) clay
        read(15,*) orgc
        read(16,*) wilt
        read(17,*) field
        read(18,*) satw
        DO j=1,360
          IF (wilt(j).GT.0.0d0) THEN
            wilt(j) = wilt(j)/300.0d0
            field(j) = field(j)/300.0d0
          ENDIF
        ENDDO

        lat =  90.5d0 - real(i)

        DO j=1,360
          lon = -180.5d0 + real(j)
          read(29,*) xxx
          write(31,'(f7.3,f9.3,14f10.4)') lat,lon,sand(j),silt(j),
     &bulk(j),orgc(j),wilt(j),field(j),satw(j),xxx(10)
        ENDDO

        DO j=1,360
          if (sand(j).gt.0.0d0) then
      CALL WSPARAM(nupc,awl,kd,kx,nci,nfix,adp,sfc,sw,sswc,sand(j),
     &clay(j),silt(j),bulk(j)*1000000.0d0,100,topsl,fc,wp,swc,orgc(j))
          sdgvm_wilt(j) = wp
          sdgvm_field(j) = fc
          sdgvm_satw(j) = swc
*          print*,wp,fc,swc
*          stop
          endif
        ENDDO

        DO j=1,360
          lon = -180.5d0 + real(j)
          if (sand(j).gt.0.0d0)
     &write(32,'(f7.3,f9.3,5f8.2,1x,3f8.4,1x,3f8.4)') lat,lon,
     &sand(j),silt(j),bulk(j),orgc(j),wilt(j),
     &field(j),satw(j),sdgvm_wilt(j),sdgvm_field(j),sdgvm_satw(j)
        ENDDO
      ENDDO

      stop
      end

*----------------------------------------------------------------------*
*                                                                      *
*                          SUBROUTINE WSPARAM                          *
*                          ******************                          *
*                                                                      *
* WSPARAM sets some system parameters for both the water and soils     *
* models.                                                              *
*                                                                      *
*----------------------------------------------------------------------*
      SUBROUTINE WSPARAM(nupc,awl,kd,kx,nci,nfix,adp,sfc,sw,sswc,sand,
     &clay,silt,bulk,dep,topsl,fc,wp,swc,org)
*----------------------------------------------------------------------*
      REAL*8 nupc,awl(4),kd,kx,nci(4),nfix,adp(4),sfc(4),sw(4),sswc(4)
      REAL*8 sand,clay,silt,bulk,dep,topsl,bc_wres,bc_wqs,ans1,fc,wp,swc
      REAL*8 bulkx,org

      bulkx = bulk*1.0e-6
      org = 0.0d0

      awl(1) = 0.05d0 ! Relative root density of the ith layer.
      awl(2) = 0.05d0 !                  "
      awl(3) = 0.03d0 !                  "
      awl(4) = 0.01d0 !                  "
      kd = 0.5d0    ! Fraction of excess water flowing to deep storage.
      kx = 0.2d0    !                   "                 stream.
      nci(1) = 0.04d0       ! NC ratio of litter pools.
      nci(2) = 0.06666667d0 !          "
      nci(3) = 0.04d0       !          "
      nci(4) = 0.06666667d0 !          "
      nupc = 1.0d0   ! Amount of nitrogen uptake ratio to litter.
      nfix = 0.5d0   ! Soil deposition plus N fixation (g/m2/y).

*************************************************************************
*                        Brookes Corey
*************************************************************************
      bc_wres = 0.0d0
      bc_wqs = 1.0-bulkx/2.65
      ans1 = -0.475662 +0.005165*sand + 0.002066*silt -
     &  0.023327*clay - 0.040628*bulkx +
     &  0.006824*org - 0.000136162*sand**2 -
     &  0.0000954716*silt**2 + 0.000298891*clay**2 -
     &  0.0637*bulkx**2 - 0.00031679*org**2 +
     &  0.0000010388*sand**3 + 0.0000010299*silt**3 -
     &  0.0000013251*clay**3

      bc_l = 10**ans1

      ans1 = 0.4104 + 0.002684*sand + 0.006354*silt +
     &0.17766*bulkx + 0.00013855*clay**2

      bc_a = 1/10**ans1

      wp = bc_wres + (bc_wqs - bc_wres)*(15300.0*bc_a)**(-bc_l)
      fc = bc_wres + (bc_wqs - bc_wres)*(51.0*bc_a)**(-bc_l)
      swc = 1.0-bulkx/2.65

*----------------------------------------------------------------------*
* Convert soil layer height into mm of water.                          *
*----------------------------------------------------------------------*
      adp(1) = topsl*10.0d0
      adp(2) = (dep/3.0d0 - topsl)*10.0d0
      adp(3) = dep*10.0d0/3.0d0
      adp(4) = dep*10.0d0/3.0d0
      sfc(1) = fc*adp(1)
*      sfc(1) = adp(1)
      sfc(2) = fc*adp(2)
      sfc(3) = fc*adp(3)
      sfc(4) = fc*adp(4)
      sw(1) = wp*adp(1)
      sw(2) = wp*adp(2)
      sw(3) = wp*adp(3)
      sw(4) = wp*adp(4)
      sswc(1) = swc*adp(1)
      sswc(2) = swc*adp(2)
      sswc(3) = swc*adp(3)
      sswc(4) = swc*adp(4)

*      CALL FCAP(ts,tc,adp,sfc,sw)

      RETURN
      END


module set_rxt_rates

  use rxt_mod, only : rxntot, cph_flg
  use io,      only : temp_path

  private
  public :: make_rate

contains

  subroutine make_rate( sym_rates, rxptab, rxpcnt, machine, vec_ftns, &
       model, march )
    !-----------------------------------------------------------------------
    !        ... write fortran "internal" reaction rates
    !-----------------------------------------------------------------------

    use rxt_mod, only : troecnt, troetab, troe_sym_rates, rxparm

    implicit none

    !-----------------------------------------------------------------------
    !        ... dummy arguments
    !-----------------------------------------------------------------------
    integer, intent(in)           ::    rxpcnt
    integer, intent(in)           ::    rxptab(*)
    character(len=16), intent(in) :: sym_rates(2,*)
    character(len=8), intent(in)  :: machine
    character(len=8), intent(in)  :: march
    character(len=8), intent(in)  :: model
    logical, intent(in)           :: vec_ftns

    !-----------------------------------------------------------------------
    !        ... local variables
    !-----------------------------------------------------------------------
    integer  ::   i, cnt, indp, inde, l, m, m1, pos
    integer  ::   ftn_lim
    integer  ::   ftn_mode
    integer  ::   cph_cnt
    integer  ::   match_cnt
    integer  ::   subs_lim
    integer  ::   subs
    integer  ::   match_ind(rxpcnt)
    real     ::   rate
    character(len=132) :: line
    character(len=32)  :: wrk, buff
    character(len=8)   :: vec_dim
    character(len=4)   :: num_suffix
    character(len=4)   :: dec_suffix
    character(len=3)   :: num
    character(len=3)   :: numa
    logical  ::  lexist
    logical  ::  vftns
    logical  ::  do_tmp
    logical  ::  do_rxt
    logical  ::  t_dependent(rxpcnt)

    inquire( file = trim( temp_path ) // 'mo_setrxt.F', exist = lexist )
    if( lexist ) then
       call system( 'rm ' // trim( temp_path ) // 'mo_setrxt.F' )
    end if
    open( unit = 30, file = trim( temp_path ) // 'mo_setrxt.F' )

    vec_dim = 'plnplv'
    if( model == 'CAM' ) then
       num_suffix = '_r8'
       dec_suffix = '(r8)'
       if( march == 'VECTOR' ) then
          vec_dim = 'chnkpnts'
       end if
    else
       num_suffix = ' '
       dec_suffix = ' '
    end if

    if( model == 'CAM' ) then
       subs_lim = 2
    else
       subs_lim = 1
    end if
    cph_cnt = count( cph_flg(:) )

    line = ' '
    write(30,100) trim(line)
    line(7:) = 'module mo_setrxt'
    write(30,100) trim(line)
    line = ' '
    write(30,100) trim(line)
    line = '      use shr_kind_mod, only : r8 => shr_kind_r8'
    write(30,100) trim(line)
    line = ' '
    write(30,100) trim(line)
    line(7:) = 'private'
    write(30,100) trim(line)
    line(7:) = 'public :: setrxt'
    write(30,100) trim(line)
    line(7:) = 'public :: setrxt_hrates'
    write(30,100) trim(line)
    line = ' '
    write(30,100) trim(line)
    line(7:) = 'contains'
    write(30,100) trim(line)
    line = ' '
    subs_loop : do subs = 1,subs_lim
       write(30,100) trim(line)
       if( march == 'VECTOR' ) then
          if( subs == 1 ) then
             line(7:) = 'subroutine setrxt( rate, temp, m, ' // trim(vec_dim) // ' )'
          else
             line(7:) = 'subroutine setrxt_hrates( rate, temp, m, ' // trim(vec_dim) // ' )'
          end if
          write(30,100) trim(line)
          line = ' '
          write(30,100) trim(line)
       else
          select case( model )
          case( 'MOZART' )
             line(7:) = 'subroutine setrxt( rate, temp, m, plonl )'
             write(30,100) trim(line)
             line = ' '
             write(30,100) trim(line)
             line = ' '
             line(7:) = 'use mo_grid,   only : plev, plnplv'
          case( 'CAM' )
             if( subs == 1 ) then
                line(7:) = 'subroutine setrxt( rate, temp, m, ncol )'
             else
                line(7:) = 'subroutine setrxt_hrates( rate, temp, m, ncol, kbot )'
             end if
             write(30,100) trim(line)
             line = ' '
             write(30,100) trim(line)
             line = ' '
             line(7:) = 'use ppgrid,       only : pver, pcols'
             write(30,100) trim(line)
             line(7:) = 'use shr_kind_mod, only : r8 => shr_kind_r8'
          case( 'WRF' )
             line(7:) = 'subroutine setrxt( rate, temp, m, n )'
             write(30,100) trim(line)
             line = ' '
             write(30,100) trim(line)
             line(7:) = 'use mo_jpl, only : jpl'
          end select
       end if
       write(30,100) trim(line)
       if( model /= 'WRF' ) then
          line(7:) = 'use chem_mods, only : rxntot'
          write(30,100) trim(line)
          line(7:) = 'use mo_jpl,    only : jpl'
          write(30,100) trim(line)
       end if
       line = ' '
       write(30,100) trim(line)
       line(7:) = 'implicit none '
       write(30,100) trim(line)
       line = ' '
       write(30,100) trim(line)
       line = '!-------------------------------------------------------'
       write(30,100) trim(line)
       line = '!       ... dummy arguments'
       write(30,100) trim(line)
       line = '!-------------------------------------------------------'
       write(30,100) trim(line)
       if( machine == 'NEC' .or. machine == 'FUJITSU' ) then
          line = '      integer, intent(in) :: ' // trim(vec_dim)
          write(30,100) trim(line)
          line = '      real' // trim(dec_suffix) // ', intent(in)    :: temp(' // trim(vec_dim) // ')'
          write(30,100) trim(line)
          line = '      real' // trim(dec_suffix) // ', intent(in)    :: m(' // trim(vec_dim) // ')'
          write(30,100) trim(line)
          line = '      real' // trim(dec_suffix) // ', intent(inout) :: rate(' // trim(vec_dim) // ',max(1,rxntot))'
       else
          select case( model )
          case( 'MOZART' )
             line = '      integer, intent(in) :: plonl'
             write(30,100) trim(line)
             line = '      real' // trim(dec_suffix) // ', intent(in)    :: temp(plonl,plev)'
             write(30,100) trim(line)
             line = '      real' // trim(dec_suffix) // ', intent(in)    :: m(plonl,plev)'
             write(30,100) trim(line)
             line = '      real' // trim(dec_suffix) // ', intent(inout) :: rate(plonl,plev,rxntot)'
          case( 'CAM' )
             line = '      integer, intent(in) :: ncol'
             write(30,100) trim(line)
             if( subs == 2 ) then
                line = '      integer, intent(in) :: kbot'
                write(30,100) trim(line)
             end if
             line = '      real' // trim(dec_suffix) // ', intent(in)    :: temp(pcols,pver)'
             write(30,100) trim(line)
             line = '      real' // trim(dec_suffix) // ', intent(in)    :: m(ncol,pver)'
             write(30,100) trim(line)
             line = '      real' // trim(dec_suffix) // ', intent(inout) :: rate(ncol,pver,rxntot)'
          case( 'WRF' )
             line = '      integer, intent(in)  :: n'
             write(30,100) trim(line)
             line = '      real' // trim(dec_suffix) // ', intent(in)    :: temp(:)'
             write(30,100) trim(line)
             line = '      real' // trim(dec_suffix) // ', intent(in)    :: m(:)'
             write(30,100) trim(line)
             line = '      real' // trim(dec_suffix) // ', intent(inout) :: rate(:,:)'
          end select
       end if
       write(30,100) trim(line)
       line = ' '
       write(30,100) trim(line)

       if( rxpcnt == 0 ) then
          if( subs == 1 ) then
             line(7:) = 'end subroutine setrxt'
          else
             line(7:) = 'end subroutine setrxt_hrates'
          end if
          write(30,100) trim(line)
          line = ' '
          write(30,100) trim(line)
          if( subs == 2 ) then
             line(7:) = 'end module mo_setrxt'
             write(30,100) trim(line)
          end if
          cnt = 0
          cycle subs_loop
       else
          t_dependent(:rxpcnt) = sym_rates(2,:rxpcnt) /= ' '
          cnt = count( t_dependent(:rxpcnt) )
       end if

       !-----------------------------------------------------------------------
       !        ... check for temp dependent rates
       !-----------------------------------------------------------------------
       temp_dep_rxts : if( cnt /= 0 .or. troecnt /= 0 ) then
          line = '!-------------------------------------------------------'
          write(30,100) trim(line)
          line = '!       ... local variables'
          write(30,100) trim(line)
          line = '!-------------------------------------------------------'
          write(30,100) trim(line)
          line = ' '
          if( model /= 'WRF' ) then
             line(7:) = 'integer  ::  n'
             write(30,100) trim(line)
          end if
          if( machine == 'NEC' .or. machine == 'FUJITSU' ) then
             line(7:) = 'real' // trim(dec_suffix) // '  ::  itemp(' // trim(vec_dim) // ')'
             write(30,100) trim(line)
             line(7:) = 'real' // trim(dec_suffix) // '  ::  exp_fac(' // trim(vec_dim) // ')'
          else
             select case( model )
             case( 'MOZART' )
                line(7:) = 'real' // trim(dec_suffix) // '  ::  itemp(plonl,plev)'
                write(30,100) trim(line)
                line(7:) = 'real' // trim(dec_suffix) // '  ::  exp_fac(plonl,plev)'
             case( 'CAM' )
                if( subs == 1 ) then
                   line(7:) = 'real' // trim(dec_suffix) // '  ::  itemp(ncol,pver)'
                   write(30,100) trim(line)
                   line(7:) = 'real' // trim(dec_suffix) // '  ::  exp_fac(ncol,pver)'
                else
                   line(7:) = 'real' // trim(dec_suffix) // '  ::  itemp(ncol,kbot)'
                   write(30,100) trim(line)
                   line(7:) = 'real' // trim(dec_suffix) // '  ::  exp_fac(ncol,kbot)'
                end if
             case( 'WRF' )
                line(7:) = 'real' // trim(dec_suffix) // '  ::  itemp(n)'
                write(30,100) trim(line)
                line(7:) = 'real' // trim(dec_suffix) // '  ::  exp_fac(n)'
             end select
          end if
          write(30,100) trim(line)
       end if temp_dep_rxts
       troe_rxts : if( troecnt /= 0 ) then
          if( machine == 'NEC' .or. machine == 'FUJITSU' ) then
             line(7:) = 'real' // trim(dec_suffix) // '  :: ko(' // trim(vec_dim) // ')'
             write(30,100) trim(line)
             line(7:) = 'real' // trim(dec_suffix) // '  :: kinf(' // trim(vec_dim) // ')'
          else
             select case( model )
             case( 'MOZART' )
                line(7:) = 'real' // trim(dec_suffix) // '  :: ko(plonl,plev)'
                write(30,100) trim(line)
                line(7:) = 'real' // trim(dec_suffix) // '  :: kinf(plonl,plev)'
             case( 'CAM' )
                if( subs == 1 ) then
                   line(7:) = 'real' // trim(dec_suffix) // '  :: ko(ncol,pver)'
                   write(30,100) trim(line)
                   line(7:) = 'real' // trim(dec_suffix) // '  :: kinf(ncol,pver)'
                else
                   line(7:) = 'real' // trim(dec_suffix) // '  :: ko(ncol,kbot)'
                   write(30,100) trim(line)
                   line(7:) = 'real' // trim(dec_suffix) // '  :: kinf(ncol,kbot)'
                   write(30,100) trim(line)
                   line(7:) = 'real' // trim(dec_suffix) // '  :: wrk(ncol,kbot)'
                end if
             case( 'WRF' )
                line(7:) = 'real' // trim(dec_suffix) // '  :: ko(n)'
                write(30,100) trim(line)
                line(7:) = 'real' // trim(dec_suffix) // '  :: kinf(n)'
             end select
          end if
          write(30,100) trim(line)
       end if troe_rxts
       line = ' '
       write(30,100) trim(line)

       !-----------------------------------------------------------------------
       !        ... first do all temperature independent rates
       !-----------------------------------------------------------------------
       const_rxts : if( rxpcnt > 0 .and. cnt /= rxpcnt ) then
          line = ' '
          do i = 1,rxpcnt
             if( sym_rates(2,i) == ' ' ) then
                if( subs == 2 ) then
                   if( .not. cph_flg(rxptab(i)) ) then
                      cycle
                   end if
                end if
                if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then
                   line(7:) = 'rate(:,'
                else
                   if( subs == 1 ) then
                      line(7:) = 'rate(:,:,'
                   else
                      line(7:) = 'rate(:,:kbot,'
                   end if
                end if
                write(num,'(i3)') rxptab(i)
                num = adjustl( num )
                l   = len_trim( sym_rates(1,i) )
                wrk = sym_rates(1,i)(:l)
                indp = scan( wrk(:l), '.' )
                inde = scan( wrk(:l), 'eE' )
                if( indp == 0 .and. inde == 0 ) then
                   l = l + 1
                   wrk(l:l) = '.'
                end if
                line(len_trim(line)+1:) = num(:len_trim(num)) // ') = ' // wrk(:l) // trim(num_suffix)
                write(30,100) trim(line)
             end if
          end do
       end if const_rxts

       !-----------------------------------------------------------------------
       !        ... now do temp dependent rxts
       !-----------------------------------------------------------------------
       do_tmp = cnt /= 0 .and. (subs == 1 .or. cph_cnt > 0)
       any_temp_dep :  if( do_tmp ) then
          if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then
             line(7:) = 'itemp(:) = 1.' // trim(num_suffix)// ' / temp(:)'
          else if( model == 'MOZART' ) then
             line(7:) = 'itemp(:,:) = 1.' // trim(num_suffix)// ' / temp(:,:)'
          else if( model == 'CAM' ) then
             if( subs == 1 ) then
                line(7:) = 'itemp(:ncol,:) = 1.' // trim(num_suffix)// ' / temp(:ncol,:)'
             else
                line(7:) = 'itemp(:ncol,:kbot) = 1.' // trim(num_suffix)// ' / temp(:ncol,:kbot)'
             end if
          end if
          write(30,100) trim(line)
          if( vec_ftns ) then
             if( model == 'MOZART' ) then
                line(7:) = 'n = plonl*plev'
             else if( model == 'CAM' ) then
                if( march /= 'VECTOR' ) then
                   if( subs == 1 ) then
                      line(7:) = 'n = ncol*pver'
                   else
                      line(7:) = 'n = ncol*kbot'
                   end if
                else
                   line(7:) = 'n = ' // trim(vec_dim)
                end if
             end if
             write(30,100) trim(line)
          else if( model == 'CAM' ) then
             if( march /= 'VECTOR' ) then
                if( subs == 1 ) then
                   line(7:) = 'n = ncol*pver'
                else
                   line(7:) = 'n = ncol*kbot'
                end if
             else
                line(7:) = 'n = ' // trim(vec_dim)
             end if
             write(30,100) trim(line)
          end if
          line = ' '
          if( model == 'CAM' .and. machine == 'IBM' ) then
             ftn_lim = 2
          else
             ftn_lim = 1
          end if
          ftn_mode_loop : do ftn_mode = 1,ftn_lim
             if( model == 'CAM' .and. machine == 'IBM' ) then
                vftns = ftn_mode == 2
                if( ftn_mode == 1 ) then
                   !                 line = '#ifndef AIX'
                   line = '#if ( !defined AIX || defined NO_VEXP )'
                else if( ftn_mode == 2 ) then
                   line = '#else'
                end if
                write(30,100) trim(line)
                line = ' '
             else
                vftns = vec_ftns
             end if
             if( ftn_mode == 2 ) then
                t_dependent(:rxpcnt) = sym_rates(2,:rxpcnt) /= ' '
             end if
             rxt_loop : do i = 1,rxpcnt
                do_rxt = t_dependent(i)
                if( subs == 2 ) then
                   if( do_rxt ) then
                      do_rxt = cph_flg(rxptab(i))
                   end if
                end if
                is_temp_dep : if( do_rxt ) then
                   match_cnt = 0
                   do m = i,rxpcnt
                      if( rxparm(2,i) == rxparm(2,m) ) then
                         if( subs == 1 ) then
                            match_cnt = match_cnt + 1
                            match_ind(match_cnt) = m
                            t_dependent(m) = .false.
                         else if( cph_flg(rxptab(m)) ) then
                            match_cnt = match_cnt + 1
                            match_ind(match_cnt) = m
                            t_dependent(m) = .false.
                         end if
                      end if
                   end do
                   multiple_matches : if( match_cnt > 1 ) then
                      if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then
                         line(7:) = 'exp_fac(:) = '
                      else if( .not. vftns ) then
                         line(7:) = 'exp_fac(:,:) = '
                      end if
                      l    = len_trim( sym_rates(2,i) )
                      wrk  = sym_rates(2,i)(:l)
                      indp = scan( wrk(:l), '.' )
                      inde = scan( wrk(:l), 'eE' )
                      if( indp == 0 .and. inde == 0 ) then
                         l = l + 1
                         wrk(l:l) = '.'
                      end if
                      pos = len_trim( line )
                      if( .not. vftns ) then
                         line(pos+1:) = ' exp( ' // wrk(:l) // trim(num_suffix)
                      else
                         line(7:) = 'call vexp( exp_fac, ' // wrk(:l) // trim(num_suffix)
                      end if
                      if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then
                         line(len_trim(line)+1:) = ' * itemp(:) )'
                      else if( .not. vftns ) then
                         line(len_trim(line)+1:) = ' * itemp(:,:) )'
                      else if( vftns ) then
                         line(len_trim(line)+1:) = ' * itemp, n )'
                      end if
                      write(30,100) trim(line)
                      do m = 1,match_cnt
                         if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then
                            line(7:) = 'rate(:,'
                         else
                            if( subs == 1 ) then
                               line(7:) = 'rate(:,:,'
                            else
                               line(7:) = 'rate(:,:kbot,'
                            end if
                         end if
                         m1 = match_ind(m)
                         write(num,'(i3)') rxptab(m1)
                         num = adjustl( num )
                         l = len_trim( sym_rates(1,m1) )
                         wrk = sym_rates(1,m1)(:l)
                         indp = scan( wrk(:l), '.' )
                         inde = scan( wrk(:l), 'eE' )
                         if( indp == 0 .and. inde == 0 ) then
                            l = l + 1
                            wrk(l:l) = '.'
                         end if
                         if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then
                            line(len_trim(line)+1:) = num(:len_trim(num)) // ') = ' // wrk(:l) // &
                                                      trim(num_suffix) // ' * exp_fac(:)'
                         else
                            line(len_trim(line)+1:) = num(:len_trim(num)) // ') = ' // wrk(:l) // &
                                                      trim(num_suffix) // ' * exp_fac(:,:)'
                         end if
                         write(30,100) trim(line)
                      end do
                   else multiple_matches
                      if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then
                         line(7:) = 'rate(:,'
                      else if( .not. vftns ) then
                         if( subs == 1 ) then
                            line(7:) = 'rate(:,:,'
                         else
                            line(7:) = 'rate(:,:kbot,'
                         end if
                      end if
                      write(num,'(i3)') rxptab(i)
                      num = adjustl( num )
                      l = len_trim( sym_rates(1,i) )
                      wrk  = sym_rates(1,i)(:l)
                      indp = scan( wrk(:l), '.' )
                      inde = scan( wrk(:l), 'eE' )
                      if( indp == 0 .and. inde == 0 ) then
                         l = l + 1
                         wrk(l:l) = '.'
                      end if
                      if( .not. vftns ) then
                         line(len_trim(line)+1:) = num(:len_trim(num)) // ') = ' // wrk(:l) // trim(num_suffix)
                      else
                         buff = wrk
                      end if
                      l = len_trim( sym_rates(2,i) )
                      wrk  = sym_rates(2,i)(:l)
                      indp = scan( wrk(:l), '.' )
                      inde = scan( wrk(:l), 'eE' )
                      if( indp == 0 .and. inde == 0 ) then
                         l = l + 1
                         wrk(l:l) = '.'
                      end if
                      if( vftns ) then
                         line(7:) = 'call vexp( exp_fac, ' // wrk(:l) // trim(num_suffix) // '*itemp, n )'
                         write(30,100) trim(line)
                         if( subs == 1 ) then
                            line(7:) = 'rate(:,:,' // trim(num) // ') = ' // trim(buff) // trim(num_suffix) // ' * exp_fac(:,:)'
                         else
                            line(7:) = 'rate(:,:kbot,' // trim(num) // ') = ' // trim(buff) // trim(num_suffix) // ' * exp_fac(:,:)'
                         end if
                      end if
                      if( .not. vftns ) then
                         pos = len_trim( line )
                         line(pos+1:) = ' * exp( ' // wrk(:l) // trim(num_suffix)
                         if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then
                            line(len_trim(line)+1:) = ' * itemp(:) )'
                         else
                            line(len_trim(line)+1:) = ' * itemp(:,:) )'
                         end if
                      end if
                      write(30,100) trim(line)
                   end if multiple_matches
                end if is_temp_dep
             end do rxt_loop
             if( model == 'CAM' .and. machine == 'IBM' .and. ftn_mode == 2 ) then
                line = '#endif'
                write(30,100) trim(line)
                line = ' '
             end if
          end do ftn_mode_loop
       end if any_temp_dep

       !-----------------------------------------------------------------------
       !        ... troe rates
       !-----------------------------------------------------------------------
       do_tmp = troecnt /= 0 .and. (subs == 1 .or. cph_cnt > 0)
       any_troe_rxts : if( do_tmp ) then
          line = ' '
          write(30,100) trim(line)
          if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then
             line(7:) = 'itemp(:) = 300.' // trim(num_suffix) // ' * itemp(:)'
          else
             line(7:) = 'itemp(:,:) = 300.' // trim(num_suffix) // ' * itemp(:,:)'
          end if
          write(30,100) trim(line)
          troe_rxt_loop : do i = 1,troecnt
             if( subs == 2 ) then
                m1 = troetab(i)
                do_rxt = cph_flg(m1)
             else
                do_rxt = .true.
             end if
             line = ' '
             write(30,100) trim(line)
             do_troe_rate : if( do_rxt ) then
                if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then
                   line(7:) = 'ko(:)'
                else
                   line(7:) = 'ko(:,:)'
                end if
                l    = len_trim( troe_sym_rates(1,i) )
                wrk  = troe_sym_rates(1,i)(:l)
                indp = scan( wrk(:l), '.' )
                inde = scan( wrk(:l), 'eE' )
                if( indp == 0 .and. inde == 0 ) then
                   l = l + 1
                   wrk(l:l) = '.'
                end if
                line(len_trim(line)+1:) =  ' = ' // wrk(:l) // trim(num_suffix)
                if( troe_sym_rates(2,i) /= ' ' ) then
                   l = len_trim( troe_sym_rates(2,i) )
                   read(troe_sym_rates(2,i)(:l),*) rate
                   wrk  = troe_sym_rates(2,i)(:l)
                   indp = scan( wrk(:l), '.' )
                   inde = scan( wrk(:l), 'eE' )
                   if( indp == 0 .and. inde == 0 ) then
                      l = l + 1
                      wrk(l:l) = '.'
                   end if
                   if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then
                      if( rate /= 0. ) then
                         if ( rate < 0. ) then
                            line(len_trim(line)+1:) = ' * itemp(:)**(' // wrk(:l) // trim(num_suffix)//')'
                         else
                            line(len_trim(line)+1:) = ' * itemp(:)**' // wrk(:l) // trim(num_suffix)
                         endif
                      end if
                   else
                      if( rate /= 0. ) then
                         if ( rate < 0. ) then
                            line(len_trim(line)+1:) = ' * itemp(:,:)**(' // wrk(:l) // trim(num_suffix)//')'
                         else
                            line(len_trim(line)+1:) = ' * itemp(:,:)**' // wrk(:l) // trim(num_suffix)
                         endif
                      end if
                   end if
                end if
                write(30,100) trim(line)
                if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then
                   line(7:) = 'kinf(:)'
                else
                   line(7:) = 'kinf(:,:)'
                end if
                l = len_trim( troe_sym_rates(3,i) )
                wrk = troe_sym_rates(3,i)(:l)
                indp = scan( wrk(:l), '.' )
                inde = scan( wrk(:l), 'eE' )
                if( indp == 0 .and. inde == 0 ) then
                   l = l + 1
                   wrk(l:l) = '.'
                end if
                line(len_trim(line)+1:) =  ' = ' // wrk(:l) // trim(num_suffix)
                if( troe_sym_rates(4,i) /= ' ' ) then
                   l = len_trim( troe_sym_rates(4,i) )
                   read(troe_sym_rates(4,i)(:l),*) rate
                   wrk = troe_sym_rates(4,i)(:l)
                   indp = scan( wrk(:l), '.' )
                   inde = scan( wrk(:l), 'eE' )
                   if( indp == 0 .and. inde == 0 ) then
                      l = l + 1
                      wrk(l:l) = '.'
                   end if
                   if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then
                      if( rate /= 0. ) then
                         if( rate /= 1. ) then
                            if ( rate < 0. ) then
                               line(len_trim(line)+1:) = ' * itemp(:)**(' // wrk(:l) // trim(num_suffix)//')'
                            else
                               line(len_trim(line)+1:) = ' * itemp(:)**' // wrk(:l) // trim(num_suffix)
                            endif
                         else
                            line(len_trim(line)+1:) = ' * itemp(:)'
                         end if
                      end if
                   else
                      if( rate /= 0. ) then
                         if( rate /= 1. ) then
                            if ( rate < 0. ) then
                               line(len_trim(line)+1:) = ' * itemp(:,:)**(' // wrk(:l) // trim(num_suffix)//')'
                            else
                               line(len_trim(line)+1:) = ' * itemp(:,:)**' // wrk(:l) // trim(num_suffix)
                            endif
                         else
                            line(len_trim(line)+1:) = ' * itemp(:,:)'
                         end if
                      end if
                   end if
                end if
                write(30,100) trim(line)
                if( model == 'WRF' .or. machine == 'NEC' .or. machine == 'FUJITSU' ) then
                   line(7:) = 'call jpl( rate(1,'
                else
                   if( subs == 1 ) then
                      line(7:) = 'call jpl( rate(1,1,'
                   else
                      line(7:) = 'call jpl( wrk'
                   end if
                end if
                write(numa,'(i3)') troetab(i)
                if( subs == 1 ) then
                   num = numa
                else
                   num = ' '
                end if
                num = adjustl( num )
                l = len_trim( troe_sym_rates(5,i) )
                wrk = troe_sym_rates(5,i)(:l)
                indp = scan( wrk(:l), '.' )
                inde = scan( wrk(:l), 'eE' )
                if( indp == 0 .and. inde == 0 ) then
                   l = l + 1
                   wrk(l:l) = '.'
                end if
                select case( model )
                case( 'MOZART' )
                   line(len_trim(line)+1:) = num(:len_trim(num)) // '), m, ' // wrk(:l) // &
                                             trim(num_suffix) // ', ko, kinf, plnplv )'
                case( 'CAM' )
                   if( subs == 1 ) then
                      line(len_trim(line)+1:) = num(:len_trim(num)) // '), m, ' // wrk(:l) // &
                                                trim(num_suffix) // ', ko, kinf, n )'
                   else
                      line(len_trim(line)+1:) = num(:len_trim(num)) // ', m, ' // wrk(:l) // &
                                                trim(num_suffix) // ', ko, kinf, n )'
                      write(30,100) trim(line)
                      line = '      rate(:,:kbot,' // numa(:len_trim(numa)) // ') = wrk(:,:)'
                   end if
                case( 'WRF' )
                   line(len_trim(line)+1:) = num(:len_trim(num)) // '), m, ' // wrk(:l) // &
                                             trim(num_suffix) // ', ko, kinf, n )'
                end select
                write(30,100) trim(line)
             end if do_troe_rate
          end do troe_rxt_loop
       end if any_troe_rxts

       line = ' '
       write(30,100) trim(line)
       if( subs == 1 ) then
          line(7:) = 'end subroutine setrxt'
       else
          line(7:) = 'end subroutine setrxt_hrates'
       end if
       write(30,100) trim(line)
       line = ' '
       write(30,100) trim(line)
       if( subs == 2 ) then
          line(7:) = 'end module mo_setrxt'
          write(30,100) trim(line)
       end if
    end do subs_loop

    close(30)

100 format(a)

  end subroutine make_rate

end module set_rxt_rates


cdis
cdis    Open Source License/Disclaimer, Forecast Systems Laboratory
cdis    NOAA/OAR/FSL, 325 Broadway Boulder, CO 80305
cdis
cdis    This software is distributed under the Open Source Definition,
cdis    which may be found at http://www.opensource.org/osd.html.
cdis
cdis    In particular, redistribution and use in source and binary forms,
cdis    with or without modification, are permitted provided that the
cdis    following conditions are met:
cdis
cdis    - Redistributions of source code must retain this notice, this
cdis    list of conditions and the following disclaimer.
cdis
cdis    - Redistributions in binary form must provide access to this
cdis    notice, this list of conditions and the following disclaimer, and
cdis    the underlying source code.
cdis
cdis    - All modifications to this software must be clearly documented,
cdis    and are solely the responsibility of the agent making the
cdis    modifications.
cdis
cdis    - If significant modifications or enhancements are made to this
cdis    software, the FSL Software Policy Manager
cdis    (softwaremgr@fsl.noaa.gov) should be notified.
cdis
cdis    THIS SOFTWARE AND ITS DOCUMENTATION ARE IN THE PUBLIC DOMAIN
cdis    AND ARE FURNISHED "AS IS."  THE AUTHORS, THE UNITED STATES
cdis    GOVERNMENT, ITS INSTRUMENTALITIES, OFFICERS, EMPLOYEES, AND
cdis    AGENTS MAKE NO WARRANTY, EXPRESS OR IMPLIED, AS TO THE USEFULNESS
cdis    OF THE SOFTWARE AND DOCUMENTATION FOR ANY PURPOSE.  THEY ASSUME
cdis    NO RESPONSIBILITY (1) FOR THE USE OF THE SOFTWARE AND
cdis    DOCUMENTATION; OR (2) TO PROVIDE TECHNICAL SUPPORT TO USERS.
cdis
cdis

	function pcon(p,t,tc)

c   this function returns the pressure pcon (mb) at the lifted condensa-
c   tion level, given the initial pressure p (mb) and temperature t
c   (celsius) of the parcel and the temperature tc (celsius) at the
c   lcl. the algorithm is exact.  it makes use of the formula for the
c   potential temperatures corresponding to t at p and tc at pcon.
c   these two potential temperatures are equal.

c	baker, schlatter  17-may-1982	  original version.

c
	data akapi/3.5037/

c   akapi = (specific heat at constant pressure for dry air) /
c	    (gas constant for dry air)

c   convert t and tc to kelvin temperatures.

	tk = t+273.15
	tck = tc+273.15
	pcon = p*(tck/tk)**akapi
	return
	end


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

MODULE m_types_oneD
  USE m_juDFT
  USE m_types_fleurinput_base
  IMPLICIT NONE
  PRIVATE
  ! types for 1D calculations
  TYPE od_dim
     LOGICAL :: d1=.FALSE.
     INTEGER :: mb=0, M=0, k3=0, m_cyl=0
     INTEGER :: chi=0, rot=0
     LOGICAL :: invs=.FALSE., zrfs=.FALSE.
     INTEGER :: n2d=0, nq2=0, nn2d=0
     INTEGER :: kimax2
     INTEGER :: nop=0, nat=0
  END TYPE od_dim

  TYPE od_inp
     LOGICAL :: d1
     INTEGER :: mb, M, k3, m_cyl
     INTEGER :: chi, rot
     LOGICAL :: invs, zrfs
     INTEGER :: n2d, nq2, nn2d
     INTEGER :: kimax2
     INTEGER, POINTER :: ig(:, :)  !(-k3:k3,-M:M)
     INTEGER, POINTER :: kv(:, :)        !(2,n2d)
     INTEGER, POINTER :: nst2(:)        !(n2d)
  END TYPE od_inp

  TYPE od_sym
     INTEGER :: nop, nat
     INTEGER, POINTER :: ngopr(:)     !(nat)
     REAL, POINTER :: mrot(:, :, :)  !(3,3,nop)
     REAL, POINTER :: tau(:, :)     !(3,nop)
     INTEGER, POINTER :: invtab(:)    !(nop)
     INTEGER, POINTER :: multab(:, :)  !(nop,nop)
  END TYPE od_sym

  TYPE od_lda
     INTEGER :: nn2d
     INTEGER, POINTER :: igf(:, :)  !(0:nn2d-1,2)
     REAL, POINTER :: pgf(:)    !(0:nn2d-1)
  END TYPE od_lda

  TYPE od_gga
     INTEGER          :: nn2d
     REAL, POINTER    :: pgfx(:)  ! (0:nn2d-1)
     REAL, POINTER    :: pgfy(:)
     REAL, POINTER    :: pgfxx(:)
     REAL, POINTER    :: pgfyy(:)
     REAL, POINTER    :: pgfxy(:)
  END TYPE od_gga
  TYPE,EXTENDS(t_fleurinput_base):: t_oneD
      TYPE(od_dim) :: odd
      TYPE(od_inp) :: odi
      TYPE(od_sym) :: ods
      TYPE(od_lda) :: odl
      TYPE(od_gga) :: odg
      INTEGER, POINTER :: ig1(:, :) => null()
      INTEGER, POINTER :: kv1(:, :) => null()
      INTEGER, POINTER :: nstr1(:) => null()
      INTEGER, POINTER :: ngopr1(:) => null()
      REAL, POINTER :: mrot1(:, :, :) => null()
      REAL, POINTER :: tau1(:, :) => null()
      INTEGER, POINTER :: invtab1(:) => null()
      INTEGER, POINTER :: multab1(:, :) => null()
      INTEGER, POINTER :: igfft1(:, :) => null()
      REAL, POINTER :: pgfft1(:) => null()
      REAL, POINTER :: pgft1x(:) => null()
      REAL, POINTER :: pgft1y(:) => null()
      REAL, POINTER :: pgft1xx(:) => null()
      REAL, POINTER :: pgft1yy(:) => null()
      REAL, POINTER :: pgft1xy(:) => null()
    contains
      procedure :: read_xml=>read_xml_oneD
      PROCEDURE :: mpi_bc=>mpi_bc_oneD
      procedure :: init=>init_oneD
   END TYPE t_oneD
   PUBLIC::t_oneD,od_dim,od_inp,od_gga,od_lda,od_sym
 CONTAINS
   SUBROUTINE mpi_bc_oneD(this,mpi_comm,irank)
    use m_mpi_bc_tool
    class(t_oneD),INTENT(INOUT)::this
    integer,INTENT(IN):: mpi_comm
    INTEGER,INTENT(IN),OPTIONAL::irank
    INTEGER ::rank
    if (present(irank)) THEN
       rank=irank
    else
       rank=0
    end if
    !Attention only few variables are broadcasted
    CALL mpi_bc(this%odd%d1 ,rank,mpi_comm)
    CALL mpi_bc(this%odd%M ,rank,mpi_comm)
    CALL mpi_bc(this%odd%mb ,rank,mpi_comm)
    CALL mpi_bc(this%odd%m_cyl ,rank,mpi_comm)
    CALL mpi_bc(this%odd%chi ,rank,mpi_comm)
    CALL mpi_bc(this%odd%rot ,rank,mpi_comm)
    CALL mpi_bc(this%odd%invs ,rank,mpi_comm)
    CALL mpi_bc(this%odd%zrfs ,rank,mpi_comm)

  END SUBROUTINE mpi_bc_oneD
   SUBROUTINE read_xml_oneD(this,xml)
     use m_types_xml
     class(t_oned),intent(inout)::this
     type(t_xml),intent(inout)   ::xml

      ! Read in optional 1D parameters if present
     character(len=100):: xpathA
     integer :: numberNodes

      xPathA = '/fleurInput/calculationSetup/oneDParams'
      numberNodes = xml%GetNumberOfNodes(xPathA)

      this%odd%d1 = .FALSE.

      IF (numberNodes.EQ.1) THEN
         this%odd%d1 = evaluateFirstBoolOnly(xml%GetAttributeValue(TRIM(ADJUSTL(xPathA))//'/@d1'))
         this%odd%M = evaluateFirstIntOnly(xml%GetAttributeValue(TRIM(ADJUSTL(xPathA))//'/@MM'))
         this%odd%mb = evaluateFirstIntOnly(xml%GetAttributeValue(TRIM(ADJUSTL(xPathA))//'/@vM'))
         this%odd%m_cyl = evaluateFirstIntOnly(xml%GetAttributeValue(TRIM(ADJUSTL(xPathA))//'/@m_cyl'))
         this%odd%chi = evaluateFirstIntOnly(xml%GetAttributeValue(TRIM(ADJUSTL(xPathA))//'/@chi'))
         this%odd%rot = evaluateFirstIntOnly(xml%GetAttributeValue(TRIM(ADJUSTL(xPathA))//'/@rot'))
         this%odd%invs = evaluateFirstBoolOnly(xml%GetAttributeValue(TRIM(ADJUSTL(xPathA))//'/@invs1'))
         this%odd%zrfs = evaluateFirstBoolOnly(xml%GetAttributeValue(TRIM(ADJUSTL(xPathA))//'/@zrfs1'))
      END IF

    END SUBROUTINE read_xml_oneD

    SUBROUTINE init_oneD(oneD,atoms)
      USE m_types_atoms
      CLASS(t_oned),INTENT(inout)::oneD
      TYPE(t_atoms),INTENT(in)::atoms
      oneD%odd%nq2 = oneD%odd%n2d
      oneD%odd%kimax2 = oneD%odd%nq2 - 1
      oneD%odd%nat = atoms%nat

      oneD%odi%d1 = oneD%odd%d1 ; oneD%odi%mb = oneD%odd%mb ; oneD%odi%M = oneD%odd%M
      oneD%odi%k3 = oneD%odd%k3 ; oneD%odi%chi = oneD%odd%chi ; oneD%odi%rot = oneD%odd%rot
      oneD%odi%invs = oneD%odd%invs ; oneD%odi%zrfs = oneD%odd%zrfs
      oneD%odi%n2d = oneD%odd%n2d ; oneD%odi%nq2 = oneD%odd%nq2 ; oneD%odi%nn2d = oneD%odd%nn2d
      oneD%odi%kimax2 = oneD%odd%kimax2 ; oneD%odi%m_cyl = oneD%odd%m_cyl
      oneD%odi%ig => oneD%ig1 ; oneD%odi%kv => oneD%kv1 ; oneD%odi%nst2 => oneD%nstr1

      oneD%ods%nop = oneD%odd%nop ; oneD%ods%nat = oneD%odd%nat
      oneD%ods%mrot => oneD%mrot1 ; oneD%ods%tau => oneD%tau1 ; oneD%ods%ngopr => oneD%ngopr1
      oneD%ods%invtab => oneD%invtab1 ; oneD%ods%multab => oneD%multab1

      oneD%odl%nn2d = oneD%odd%nn2d
      oneD%odl%igf => oneD%igfft1 ; oneD%odl%pgf => oneD%pgfft1

      oneD%odg%nn2d = oneD%odd%nn2d
      oneD%odg%pgfx => oneD%pgft1x ; oneD%odg%pgfy => oneD%pgft1y
      oneD%odg%pgfxx => oneD%pgft1xx ; oneD%odg%pgfyy => oneD%pgft1yy ; oneD%odg%pgfxy => oneD%pgft1xy
      oneD%odd%nq2 = oneD%odd%n2d
      ! Initialize missing 1D code arrays
      if (associated(oneD%ig1)) return
      ALLOCATE (oneD%ig1(-oneD%odd%k3:oneD%odd%k3,-oneD%odd%M:oneD%odd%M))
      ALLOCATE (oneD%kv1(2,oneD%odd%n2d),oneD%nstr1(oneD%odd%n2d))
      ALLOCATE (oneD%ngopr1(atoms%nat),oneD%mrot1(3,3,oneD%odd%nop),oneD%tau1(3,oneD%odd%nop))
      ALLOCATE (oneD%invtab1(oneD%odd%nop),oneD%multab1(oneD%odd%nop,oneD%odd%nop))
      ALLOCATE (oneD%igfft1(0:oneD%odd%nn2d-1,2),oneD%pgfft1(0:oneD%odd%nn2d-1))
    end subroutine init_oneD
 END MODULE m_types_oneD


C----------------------------------------------------------------------
      SUBROUTINE RCLOS()
C     DUMMY IF HBOOK IS USED
C----------------------------------------------------------------------
      END

C----------------------------------------------------------------------
      SUBROUTINE PYABEG(nnn,wwwi)
C     USER''S ROUTINE FOR INITIALIZATION
C----------------------------------------------------------------------
      INCLUDE 'HEPMC.INC'
      include 'reweight0.inc'
      integer j,kk,l,i,nnn
      character*5 cc(2)
      data cc/'     ','Born '/
      integer nwgt,max_weight,nwgt_analysis
      common/cnwgt/nwgt
      common/c_analysis/nwgt_analysis
      parameter (max_weight=maxscales*maxscales+maxpdfs+1)
      character*15 weights_info(max_weight),wwwi(max_weight)
      common/cwgtsinfo/weights_info
c
      call inihist
      weights_info(1)="central value  "
      do i=1,nnn+1
         weights_info(i+1)=wwwi(i)
      enddo
      nwgt=nnn+1
      nwgt_analysis=nwgt
      do i=1,1
      do kk=1,nwgt_analysis
      l=(kk-1)*2+(i-1)*1
      call mbook(l+ 1,'total rate '//cc(i)//weights_info(kk)
     &     ,1d0,0d0,2d0)
      enddo
      enddo
 999  END

C----------------------------------------------------------------------
      SUBROUTINE PYAEND(IEVTTOT)
C     USER''S ROUTINE FOR TERMINAL CALCULATIONS, HISTOGRAM OUTPUT, ETC
C----------------------------------------------------------------------
      INCLUDE 'HEPMC.INC'
      REAL*8 XNORM,IEVTTOT
      INTEGER I,J,KK,l,nwgt_analysis
      integer NPL
      parameter(NPL=15000)
      common/c_analysis/nwgt_analysis
      OPEN(UNIT=99,FILE='PYTHIA.TOP',STATUS='UNKNOWN')
C XNORM IS SUCH THAT THE CROSS SECTION PER BIN IS IN PB, SINCE THE HERWIG
C WEIGHT IS IN NB, AND CORRESPONDS TO THE AVERAGE CROSS SECTION
      XNORM=IEVTTOT/DFLOAT(NEVHEP)
      DO I=1,NPL
        CALL MFINAL3(I)
        CALL MCOPY(I,I+NPL)
        CALL MOPERA(I+NPL,'F',I+NPL,I+NPL,(XNORM),0.D0)
        CALL MFINAL3(I+NPL)
      ENDDO
C
      do i=1,1
      do kk=1,nwgt_analysis
      l=(kk-1)*2+(i-1)*1
      call multitop(NPL+l+ 1,NPL-1,3,2,'total rate ',' ','LIN')
      enddo
      enddo
      CLOSE(99)
      END

C----------------------------------------------------------------------
      SUBROUTINE PYANAL(nnn,xww)
C     USER''S ROUTINE TO ANALYSE DATA FROM EVENT
C----------------------------------------------------------------------
      INCLUDE 'HEPMC.INC'
      include 'reweight0.inc'
      INTEGER KK,i,l
      real*8 tot
      data tot/0.5d0/
      integer nwgt_analysis,max_weight
      common/c_analysis/nwgt_analysis
      parameter (max_weight=maxscales*maxscales+maxpdfs+1)
      double precision ww(max_weight),www(max_weight),xww(max_weight)
      common/cww/ww
c
      ww(1)=xww(2)
      if(nnn.eq.0)ww(1)=1d0
      do i=2,nnn+1
         ww(i)=xww(i)
      enddo
c
      IF (WW(1).EQ.0D0) THEN
         WRITE(*,*)'WW(1) = 0. Stopping'
         STOP
      ENDIF
c
C INCOMING PARTONS MAY TRAVEL IN THE SAME DIRECTION: IT''S A POWER-SUPPRESSED
C EFFECT, SO THROW THE EVENT AWAY
      IF(SIGN(1.D0,PHEP(3,1)).EQ.SIGN(1.D0,PHEP(3,2)))THEN
         WRITE(*,*)'WARNING 111 IN PYANAL'
        GOTO 999
      ENDIF
      DO I=1,nwgt_analysis
         WWW(I)=EVWGT*ww(i)/ww(1)
      ENDDO
C
      do i=1,1
         do kk=1,nwgt_analysis
            l=(kk-1)*2+(i-1)*1
            call mfill(l+1,tot,WWW(kk))
         enddo
      enddo
C
 999  END


C    @(#)ogetrat.f	20.3 2/13/96
C****************************************************************
C
C       File: ogetrat.for
C
C       Purpose: Routine to obtain the branch rating for branch index
C                PTR. If extended ratings are present, RATING is the
C                minimum non-zero extended rating.
C
C                If extended ratings are not present, RATING is the
C                nominal rating.
c
C       Note:    This applies to the ALTERNATE BASE CASE IN RESIDENCE
C
C       Input parameters:
C
C             PTR    - kx(), ky() index.
C       Output parameters:
C
C             RATING - branch rating
C             RATTAG - 'N' (Nominal)
C                      'T' (Thermal)
C                      'E' (Emergency, Transformer only)
C                      'B' (Bottleneck)
C             RATNOM - nominal branch rating
C             RATTHR - thermal branch rating
C             RATLLF - emergency branch rating
C             RATBTL - bottlenexk branch rating
C
C       Author: Walt Powell  Date: 12 November 1992
C       Called by: gtlnload, gtlfq
C
C****************************************************************
C
      subroutine ogetrat (ptr, rating, rattag, ratnom, ratthr,
     1                   ratllf, ratbtl)
      integer ptr
      character rattag * (*)

      include 'ipfinc/parametr.inc'

      include 'ipfinc/alt_case.inc'

      character typeln * 2, typetx * 3
      data typeln / 'TB' /
      data typetx / 'TEB' /

      nbr = iabs (obrnch_ptr(ptr))
      rating = 0.0
      ratnom = obrnch(4,nbr)
      ltype = obrtype(ptr)
      if (ltype .eq. 3 .or. ltype .eq. 8) then
         ratthr = orateln(1,nbr)
         ratbtl = orateln(2,nbr)
         ratllf = 0.0
         do i = 1,2
            if (orateln(i,nbr) .gt. 0.0) then
               if (rating .gt. 0.0) then
                  if (orateln(i,nbr) .lt. rating) then
                     rating = orateln(i,nbr)
                     rattag = typeln(i:i)
                  endif
               else
                  rating = orateln(i,nbr)
                  rattag = typeln(i:i)
               endif
            endif
         enddo
      else if (ltype .eq. 5 .or. ltype .eq. 6) then
         ratthr = orateln(1,nbr)
         ratllf = orateln(2,nbr)
         ratbtl = orateln(3,nbr)
         do i = 1,3
            if (orateln(i,nbr) .gt. 0.0) then
               if (rating .gt. 0.0) then
                  if (orateln(i,nbr) .lt. rating) then
                     rating = orateln(i,nbr)
                     rattag = typetx(i:i)
                  endif
               else
                  rating = orateln(i,nbr)
                  rattag = typetx(i:i)
               endif
            endif
          enddo
      endif
      if (rating .eq. 0.0) then
         rating = obrnch(4,nbr)
         rattag = 'N'
      endif

      return
      end