c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine ehal  --  buffered 14-7 van der Waals energy  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "ehal" calculates the buffered 14-7 van der Waals energy
c
c
      subroutine ehal
      implicit none
      real*8 elrc
      include 'cutoff.i'
      include 'energi.i'
      include 'vdwpot.i'
c
c
c     choose the method for summing over pairwise interactions
c
      if (use_lights) then
         call ehal0b
      else if (use_vlist) then
         call ehal0c
      else
         call ehal0a
      end if
c
c     apply long range van der Waals correction if desired
c
      if (use_vcorr) then
         call evcorr (elrc)
         ev = ev + elrc
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ehal0a  --  buffered 14-7 vdw via double loop  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ehal0a" calculates the buffered 14-7 van der Waals energy
c     using a pairwise double loop
c
c
      subroutine ehal0a
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'mutant.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k
      integer ii,iv,it
      integer kk,kv,kt
      integer, allocatable :: iv14(:)
      real*8 e,rv,rv7
      real*8 eps,rdn,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rho,tau,taper
      real*8 scal,t1,t2
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,rik7
      real*8, allocatable :: xred(:)
      real*8, allocatable :: yred(:)
      real*8, allocatable :: zred(:)
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      logical muti,mutk
      character*6 mode
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (xred(n))
      allocate (yred(n))
      allocate (zred(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         vscale(i) = 1.0d0
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     find the van der Waals energy via double loop search
c
      do ii = 1, nvdw-1
         i = ivdw(ii)
         iv = ired(i)
         it = jvdw(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
         muti = mut(i)
c
c     set interaction scaling coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii+1, nvdw
            k = ivdw(kk)
            kv = ired(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = jvdw(k)
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rik = sqrt(rik2)
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
c
c     get the interaction energy, via soft core if necessary
c
                  if ((muti .and. .not.mutk) .or.
     &                (mutk .and. .not.muti)) then
                     rho = rik / rv
                     eps = eps * vlambda**scexp
                     scal = scalpha * (1.0d0-vlambda)**2
                     t1 = (1.0d0+dhal)**7 / (scal+(rho+dhal)**7)
                     t2 = (1.0d0+ghal) / (scal+rho**7+ghal)
                     e = eps * t1 * (t2-2.0d0)
                  else
                     rv7 = rv**7
                     rik7 = rik**7
                     rho = rik7 + ghal*rv7
                     tau = (dhal+1.0d0) / (rik + dhal*rv)
                     e = eps * rv7 * tau**7
     &                      * ((ghal+1.0d0)*rv7/rho-2.0d0)
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  ev = ev + e
               end if
            end if
         end do
c
c     reset interaction scaling coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     for periodic boundary conditions with large cutoffs
c     neighbors must be found by the replicates method
c
      if (.not. use_replica)  return
c
c     calculate interaction energy with other unit cells
c
      do ii = 1, nvdw
         i = ivdw(ii)
         iv = ired(i)
         it = jvdw(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
c
c     set interaction scaling coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = ii, nvdw
            k = ivdw(kk)
            kv = ired(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = jvdw(k)
               do j = 1, ncell
                  xr = xi - xred(k)
                  yr = yi - yred(k)
                  zr = zi - zred(k)
                  call imager (xr,yr,zr,j)
                  rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
                  if (rik2 .le. off2) then
                     rik = sqrt(rik2)
                     rv = radmin(kt,it)
                     eps = epsilon(kt,it)
                     if (use_polymer) then
                        if (rik2 .le. polycut2) then
                           if (iv14(k) .eq. i) then
                              rv = radmin4(kt,it)
                              eps = epsilon4(kt,it)
                           end if
                           eps = eps * vscale(k)
                        end if
                     end if
c
c     get the interaction energy, via soft core if necessary
c
                     if ((muti .and. .not.mutk) .or.
     &                   (mutk .and. .not.muti)) then
                        rho = rik / rv
                        eps = eps * vlambda**scexp
                        scal = scalpha * (1.0d0-vlambda)**2
                        t1 = (1.0d0+dhal)**7 / (scal+(rho+dhal)**7)
                        t2 = (1.0d0+ghal) / (scal+rho**7+ghal)
                        e = eps * t1 * (t2-2.0d0)
                     else
                        rv7 = rv**7
                        rik7 = rik**7
                        rho = rik7 + ghal*rv7
                        tau = (dhal+1.0d0) / (rik + dhal*rv)
                        e = eps * rv7 * tau**7
     &                         * ((ghal+1.0d0)*rv7/rho-2.0d0)
                     end if
c
c     use energy switching if near the cutoff distance
c
                     if (rik2 .gt. cut2) then
                        rik3 = rik2 * rik
                        rik4 = rik2 * rik2
                        rik5 = rik2 * rik3
                        taper = c5*rik5 + c4*rik4 + c3*rik3
     &                             + c2*rik2 + c1*rik + c0
                        e = e * taper
                     end if
c
c     scale the interaction based on its group membership
c
                     if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy component;
c     interaction of an atom with its own image counts half
c
                     if (i .eq. k)  e = 0.5d0 * e
                     ev = ev + e
                  end if
               end do
            end if
         end do
c
c     reset interaction scaling coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (xred)
      deallocate (yred)
      deallocate (zred)
      deallocate (vscale)
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine ehal0b  --  buffered 14-7 vdw energy via lights  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "ehal0b" calculates the buffered 14-7 van der Waals energy
c     using the method of lights
c
c
      subroutine ehal0b
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'boxes.i'
      include 'cell.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'light.i'
      include 'mutant.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k
      integer ii,iv,it
      integer kk,kv,kt
      integer kgy,kgz
      integer start,stop
      integer, allocatable :: iv14(:)
      real*8 e,rv,rv7
      real*8 eps,rdn,fgrp
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rho,tau,taper
      real*8 scal,t1,t2
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,rik7
      real*8, allocatable :: xred(:)
      real*8, allocatable :: yred(:)
      real*8, allocatable :: zred(:)
      real*8, allocatable :: vscale(:)
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical proceed,usei
      logical muti,mutk
      logical prime,repeat
      character*6 mode
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (xred(n))
      allocate (yred(n))
      allocate (zred(n))
      allocate (vscale(n))
      allocate (xsort(8*n))
      allocate (ysort(8*n))
      allocate (zsort(8*n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         vscale(i) = 1.0d0
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     apply any reduction factor to the atomic coordinates
c
      do j = 1, nvdw
         i = ivdw(j)
         iv = ired(i)
         rdn = kred(i)
         xred(j) = rdn*(x(i)-x(iv)) + x(iv)
         yred(j) = rdn*(y(i)-y(iv)) + y(iv)
         zred(j) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     transfer the interaction site coordinates to sorting arrays
c
      do i = 1, nvdw
         xsort(i) = xred(i)
         ysort(i) = yred(i)
         zsort(i) = zred(i)
      end do
c
c     use the method of lights to generate neighbors
c
      call lights (off,nvdw,xsort,ysort,zsort)
c
c     loop over all atoms computing the interactions
c
      do ii = 1, nvdw
         i = ivdw(ii)
         iv = ired(i)
         it = jvdw(i)
         xi = xsort(rgx(ii))
         yi = ysort(rgy(ii))
         zi = zsort(rgz(ii))
         usei = (use(i) .or. use(iv))
         muti = mut(i)
c
c     set interaction scaling coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     loop over method of lights neighbors of current atom
c
         if (kbx(ii) .le. kex(ii)) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = kex(ii)
         else
            repeat = .true.
            start = 1
            stop = kex(ii)
         end if
   10    continue
         do j = start, stop
            kk = locx(j)
            kgy = rgy(kk)
            if (kby(ii) .le. key(ii)) then
               if (kgy.lt.kby(ii) .or. kgy.gt.key(ii))  goto 20
            else
               if (kgy.lt.kby(ii) .and. kgy.gt.key(ii))  goto 20
            end if
            kgz = rgz(kk)
            if (kbz(ii) .le. kez(ii)) then
               if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii))  goto 20
            else
               if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii))  goto 20
            end if
            k = ivdw(kk-((kk-1)/nvdw)*nvdw)
            kv = ired(k)
            mutk = mut(k)
            prime = (kk .le. nvdw)
c
c     decide whether to compute the current interaction
c
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = jvdw(k)
               xr = xi - xsort(j)
               yr = yi - ysort(kgy)
               zr = zi - zsort(kgz)
               if (use_bounds) then
                  if (abs(xr) .gt. xcell2)  xr = xr - sign(xcell,xr)
                  if (abs(yr) .gt. ycell2)  yr = yr - sign(ycell,yr)
                  if (abs(zr) .gt. zcell2)  zr = zr - sign(zcell,zr)
                  if (monoclinic) then
                     xr = xr + zr*beta_cos
                     zr = zr * beta_sin
                  else if (triclinic) then
                     xr = xr + yr*gamma_cos + zr*beta_cos
                     yr = yr*gamma_sin + zr*beta_term
                     zr = zr * gamma_term
                  end if
               end if
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rik = sqrt(rik2)
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (prime) then
                     if (iv14(k) .eq. i) then
                        rv = radmin4(kt,it)
                        eps = epsilon4(kt,it)
                     end if
                     eps = eps * vscale(k)
                  end if
c
c     get the interaction energy, via soft core if necessary
c
                  if ((muti .and. .not.mutk) .or.
     &                (mutk .and. .not.muti)) then
                     rho = rik / rv
                     eps = eps * vlambda**scexp
                     scal = scalpha * (1.0d0-vlambda)**2
                     t1 = (1.0d0+dhal)**7 / (scal+(rho+dhal)**7)
                     t2 = (1.0d0+ghal) / (scal+rho**7+ghal)
                     e = eps * t1 * (t2-2.0d0)
                  else
                     rv7 = rv**7
                     rik7 = rik**7
                     rho = rik7 + ghal*rv7
                     tau = (dhal+1.0d0) / (rik + dhal*rv)
                     e = eps * rv7 * tau**7
     &                      * ((ghal+1.0d0)*rv7/rho-2.0d0)
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                             + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  ev = ev + e
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(ii) + 1
            stop = nlight
            goto 10
         end if
c
c     reset interaction scaling coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (xred)
      deallocate (yred)
      deallocate (zred)
      deallocate (vscale)
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ehal0c  --  buffered 14-7 vdw energy via list  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ehal0c" calculates the buffered 14-7 van der Waals energy
c     using a pairwise neighbor list
c
c
      subroutine ehal0c
      implicit none
      include 'sizes.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'bound.i'
      include 'couple.i'
      include 'energi.i'
      include 'group.i'
      include 'mutant.i'
      include 'neigh.i'
      include 'shunt.i'
      include 'usage.i'
      include 'vdw.i'
      include 'vdwpot.i'
      integer i,j,k
      integer ii,iv,it
      integer kk,kv,kt
      integer, allocatable :: iv14(:)
      real*8 e,eps,rdn,evt
      real*8 fgrp,rv,rv7
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 rho,tau,taper
      real*8 scal,t1,t2
      real*8 rik,rik2,rik3
      real*8 rik4,rik5,rik7
      real*8, allocatable :: xred(:)
      real*8, allocatable :: yred(:)
      real*8, allocatable :: zred(:)
      real*8, allocatable :: vscale(:)
      logical proceed,usei
      logical muti,mutk
      character*6 mode
c
c
c     zero out the van der Waals energy contribution
c
      ev = 0.0d0
c
c     perform dynamic allocation of some local arrays
c
      allocate (iv14(n))
      allocate (xred(n))
      allocate (yred(n))
      allocate (zred(n))
      allocate (vscale(n))
c
c     set arrays needed to scale connected atom interactions
c
      do i = 1, n
         vscale(i) = 1.0d0
         iv14(i) = 0
      end do
c
c     set the coefficients for the switching function
c
      mode = 'VDW'
      call switch (mode)
c
c     apply any reduction factor to the atomic coordinates
c
      do k = 1, nvdw
         i = ivdw(k)
         iv = ired(i)
         rdn = kred(i)
         xred(i) = rdn*(x(i)-x(iv)) + x(iv)
         yred(i) = rdn*(y(i)-y(iv)) + y(iv)
         zred(i) = rdn*(z(i)-z(iv)) + z(iv)
      end do
c
c     transfer global to local copies for OpenMP calculation
c
      evt = ev
c
c     set OpenMP directives for the major loop structure
c
!$OMP PARALLEL default(private) shared(nvdw,ivdw,ired,kred,
!$OMP& jvdw,xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15,
!$OMP& i12,i13,i14,i15,v2scale,v3scale,v4scale,v5scale,
!$OMP& use_group,off2,radmin,epsilon,radmin4,epsilon4,ghal,dhal,
!$OMP& vlambda,scalpha,scexp,mut,cut2,c0,c1,c2,c3,c4,c5)
!$OMP& firstprivate(vscale,iv14) shared(evt)
!$OMP DO reduction(+:evt) schedule(dynamic)
c
c     find the van der Waals energy via neighbor list search
c
      do ii = 1, nvdw
         i = ivdw(ii)
         iv = ired(i)
         it = jvdw(i)
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         usei = (use(i) .or. use(iv))
         muti = mut(i)
c
c     set interaction scaling coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = v2scale
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = v3scale
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = v4scale
            iv14(i14(j,i)) = i
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = v5scale
         end do
c
c     decide whether to compute the current interaction
c
         do kk = 1, nvlst(ii)
            k = ivdw(vlst(kk,ii))
            kv = ired(k)
            mutk = mut(k)
            proceed = .true.
            if (use_group)  call groups (proceed,fgrp,i,k,0,0,0,0)
            if (proceed)  proceed = (usei .or. use(k) .or. use(kv))
c
c     compute the energy contribution for this interaction
c
            if (proceed) then
               kt = jvdw(k)
               xr = xi - xred(k)
               yr = yi - yred(k)
               zr = zi - zred(k)
               call image (xr,yr,zr)
               rik2 = xr*xr + yr*yr + zr*zr
c
c     check for an interaction distance less than the cutoff
c
               if (rik2 .le. off2) then
                  rik = sqrt(rik2)
                  rv = radmin(kt,it)
                  eps = epsilon(kt,it)
                  if (iv14(k) .eq. i) then
                     rv = radmin4(kt,it)
                     eps = epsilon4(kt,it)
                  end if
                  eps = eps * vscale(k)
c
c     get the interaction energy, via soft core if necessary
c
                  if ((muti .and. .not.mutk) .or.
     &                (mutk .and. .not.muti)) then
                     rho = rik / rv
                     eps = eps * vlambda**scexp
                     scal = scalpha * (1.0d0-vlambda)**2
                     t1 = (1.0d0+dhal)**7 / (scal+(rho+dhal)**7)
                     t2 = (1.0d0+ghal) / (scal+rho**7+ghal)
                     e = eps * t1 * (t2-2.0d0)
                  else
                     rv7 = rv**7
                     rik7 = rik**7
                     rho = rik7 + ghal*rv7
                     tau = (dhal+1.0d0) / (rik + dhal*rv)
                     e = eps * rv7 * tau**7
     &                      * ((ghal+1.0d0)*rv7/rho-2.0d0)
                  end if
c
c     use energy switching if near the cutoff distance
c
                  if (rik2 .gt. cut2) then
                     rik3 = rik2 * rik
                     rik4 = rik2 * rik2
                     rik5 = rik2 * rik3
                     taper = c5*rik5 + c4*rik4 + c3*rik3
     &                          + c2*rik2 + c1*rik + c0
                     e = e * taper
                  end if
c
c     scale the interaction based on its group membership
c
                  if (use_group)  e = e * fgrp
c
c     increment the overall van der Waals energy components
c
                  evt = evt + e
               end if
            end if
         end do
c
c     reset interaction scaling coefficients for connected atoms
c
         do j = 1, n12(i)
            vscale(i12(j,i)) = 1.0d0
         end do
         do j = 1, n13(i)
            vscale(i13(j,i)) = 1.0d0
         end do
         do j = 1, n14(i)
            vscale(i14(j,i)) = 1.0d0
         end do
         do j = 1, n15(i)
            vscale(i15(j,i)) = 1.0d0
         end do
      end do
c
c     end OpenMP directives for the major loop structure
c
!$OMP END DO
!$OMP END PARALLEL
c
c     transfer local to global copies for OpenMP calculation
c
      ev = evt
c
c     perform deallocation of some local arrays
c
      deallocate (iv14)
      deallocate (xred)
      deallocate (yred)
      deallocate (zred)
      deallocate (vscale)
      return
      end


!******************************************************************************
! Copyright c 2013, The Ames Laboratory, Iowa State University, and Rutgers
! University*.  All rights reserved.
!
! This software was authored by Yongxin Yao, Nicola Lanata*, Gabriel Kotliar*,
! Cai-Zhuang Wang, and Kai-Ming Ho, at The Ames Laboratory and
! Rutgers University and was supported by the U.S.
! Department of Energy (DOE), Office of Science,
! Basic Energy Sciences, Materials Science and Engineering Division.
! The Ames Laboratory is operated by Iowa State University for DOE
! under U.S. Government contract DE-AC02-07CH11358.
! The U.S. Government has the rights to use, reproduce, and
! distribute this software.
! NEITHER THE GOVERNMENT, THE AMES LABORATORY, IOWA STATE UNIVERSITY,
! NOR RUTGERS UNIVERSITY MAKES ANY WARRANTY,
! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE.
! If software is modified to produce derivative works,
! such modified software should be clearly marked,
! so as to not confuse it with the version available from
! The Ames Laboratory and Rutgers University.
!
! Additionally, redistribution and use in source and binary forms,
! with or without modification,
! are permitted provided that the following conditions are met:
!
!     Redistribution of source code must retain the above copyright notice,
!     this list of conditions, and the following disclaimer.
!
!     Redistribution in binary form must reproduce the above copyright notice,
!     this list of conditions, and the following disclaimer
!     in the documentation and/or other materials provided with distribution.
!
!     Neither the name of The Ames Laboratory, Iowa State University,
!     Rutgers University, the U.S. Government, nor the names of
!     its contributors may be used to endorse or promote products derived
!     from this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE AMES LABORATORY, IOWA STATE UNIVERSITY,
! RUTGERS UNIVERSITY, AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
! THE IMPLIED WARRANTIES OF MERCHANTABILITY
! AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
! IN NO EVENT SHALL THE GOVERNMENT, THE AMES LABORATORY,
! IOWA STATE UNIVERSITY, RUTGERS UNIVERSITY, OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
! HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
! OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
! EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!******************************************************************************

module ghfscf
    use gprec
    use gdiis
    use gutil
    use gparam
    implicit none

    type density_matrix
        complex(q),pointer::a(:,:)=>null()
    end type density_matrix

    type(density_matrix),allocatable::dm_list(:)

    contains

    subroutine ghf_init(nhf)
    integer,intent(in)::nhf

    allocate(dm_list(nhf))
    return

    end subroutine ghf_init

    ! with HF specific error vectors.
    subroutine ghf_scf(ihf,norbs,h1e,v2e,dm,e_tot,iter,flevelshift)
    integer,intent(in)::norbs,ihf
    integer,intent(out)::iter
    real(q),intent(out)::e_tot
    real(q),intent(in)::flevelshift
    complex(q),intent(in)::h1e(norbs,norbs),v2e(norbs,norbs,norbs,norbs)
    complex(q),target,intent(out)::dm(norbs,norbs)

    integer,parameter::max_cycle=7000
    real(q),parameter::conv_tol=1.d-5
    integer norb,i
    type(diis_mem) :: dmem
    real(q) mo_energy(norbs),e_tot_last
    logical lconverge
    complex(q) mo_coef(norbs,norbs),dm_last(norbs,norbs),vhf(norbs,norbs),&
            &v_j2e(norbs,norbs,norbs,norbs),errvec(norbs,norbs)

    lconverge=.false.
    norb=norbs/2

    if(.not.associated(dm_list(ihf)%a))then
        ! Get initial guess by 1e
        mo_coef=h1e
        call hermev('v','l',mo_coef,mo_energy,norbs)

        if(g_write>=5)then
            write(0,'(" mo_energy:")')
            write(0,'(4x,5f12.6)')mo_energy
        endif

        ! Get density matrix, dm_{i,j} = <c_j^\dagger c_i>
        call zgemm('n','c',norbs,norbs,norb,z1,mo_coef,norbs,mo_coef,norbs, &
                &z0,dm,norbs)
    else
        dm = dm_list(ihf)%a
    endif
    call get_coul_exchange(norbs,v2e,v_j2e)
    vhf=0
    call get_veff(norbs,vhf,dm,v_j2e)
    call get_energy_tot(e_tot,norbs,h1e,vhf,dm)
    call diis_vector_init(dmem,norbs*norbs)
    ! begin scf cycles
    iter=1
    do
        dm_last=dm
        e_tot_last=e_tot
        mo_coef=h1e+vhf
        if(iter>1.and.(.not.lconverge))then
            ! J. Mol. Struct. 114, 31-34
            ! PCCP, 4, 11
            ! GEDIIS, JCTC, 2, 835
            ! C2DIIS, IJQC, 45, 31
            ! SCF-EDIIS, JCP 116, 8255
            ! error vector = SDF-FDS
            ! = F_ai ~ (S-SDS)*S^{-1}FDS = FDS - SDFDS ~ FDS-SDF in converge
            errvec=dm
            call annxb('n','n',errvec,mo_coef,norbs,1)
            errvec=conjg(transpose(errvec))-errvec
            call gdiis_update(dmem,mo_coef(1,1),errvec(1,1))
        endif

        ! level shift
        if(flevelshift>1.e-4_q.and.(.not.lconverge))then
            mo_coef=mo_coef-dm*flevelshift
            forall(i=1:norbs)mo_coef(i,i)=mo_coef(i,i)+flevelshift
        endif

        call hermev('v','l',mo_coef,mo_energy,norbs)
        ! Get density matrix, dm_{i,j} = <c_j^\dagger c_i>
        call zgemm('n','c',norbs,norbs,norb,z1,mo_coef,norbs,mo_coef, &
                &norbs,z0,dm,norbs)
        call get_veff(norbs,vhf,dm,v_j2e,dm_last)
        call get_energy_tot(e_tot,norbs,h1e,vhf,dm)

        if(g_write>=5)then
            write(0,'(" mo_energy:")')
            write(0,'(4x,5f12.6)')mo_energy
            write(0,'(" Iter = ",I4," HF dm error =",f16.10," etot =",f16.8)') &
                    &iter,maxval(abs(dm-dm_last)),e_tot
        endif

        if(lconverge)exit
        if(abs(e_tot-e_tot_last)<conv_tol.or.iter==max_cycle)then
            lconverge=.true. ! One more iteration without fixing.
        else
            iter=iter+1
        endif
    enddo
    if(iter==max_cycle)then
        stop ' hf does not converge!'
    endif
    if(.not.associated(dm_list(ihf)%a))then
        allocate(dm_list(ihf)%a(norbs,norbs))
    endif
    dm_list(ihf)%a=dm
    ! Transpose to dm_{i,j}=<c_i^\dagger c_j>
    dm=transpose(dm)
    return

    end subroutine ghf_scf

    ! with density matrix difference as the error vector.
    subroutine ghf_scf1(norbs,h1e,h1e_init,v2e,dm,e_tot,iter)
    integer,intent(in)::norbs
    integer,intent(out)::iter
    real(q),intent(out)::e_tot
    complex(q),intent(in)::h1e(norbs,norbs),v2e(norbs,norbs,norbs,norbs), &
            &h1e_init(norbs,norbs)
    complex(q),target,intent(out)::dm(norbs,norbs)

    integer,parameter::max_cycle=7000
    real(q),parameter::conv_tol=1.d-10
    integer norb
    type(diis_mem) :: dmem
    real(q) mo_energy(norbs),e_tot_last
    complex(q) mo_coef(norbs,norbs),dm_last(norbs,norbs),vhf(norbs,norbs),&
            &v_j2e(norbs,norbs,norbs,norbs),errvec(norbs,norbs)

    norb=norbs/2
    ! Get initial guess by 1e
    mo_coef=h1e_init
    call hermev('v','l',mo_coef,mo_energy,norbs)
    ! Get density matrix, dm_{i,j} = <c_j^\dagger c_i>
    call zgemm('n','c',norbs,norbs,norb,z1,mo_coef,norbs,mo_coef,norbs, &
            &z0,dm,norbs)
    call get_coul_exchange(norbs,v2e,v_j2e)
    vhf=0
    call get_veff(norbs,vhf,dm,v_j2e)
    call get_energy_tot(e_tot,norbs,h1e,vhf,dm)
    call diis_vector_init(dmem,norbs*norbs)
    ! begin scf cycles
    do iter=1,max_cycle
        dm_last=dm
        e_tot_last=e_tot
        mo_coef=h1e+vhf
        call hermev('v','l',mo_coef,mo_energy,norbs)
        ! Get density matrix, dm_{i,j} = <c_j^\dagger c_i>
        call zgemm('n','c',norbs,norbs,norb,z1,mo_coef,norbs,mo_coef, &
                &norbs,z0,dm,norbs)
        errvec=dm-dm_last
        call gdiis_update(dmem,dm(1,1),errvec(1,1))
        call get_veff(norbs,vhf,dm,v_j2e,dm_last)
        call get_energy_tot(e_tot,norbs,h1e,vhf,dm)

        if(g_write>=5)then
            write(0,'(" Iter =",I4," HF dm error =",f16.10," etot =",f16.8)')&
                    &iter,maxval(abs(errvec)),e_tot
        endif

        if(abs(e_tot-e_tot_last)<conv_tol)exit
    enddo
    ! Transpose to dm_{i,j}=<c_i^\dagger c_j>
    dm=transpose(dm)
    return

    end subroutine ghf_scf1

    subroutine get_veff(norbs,vhf,dm,vj2e,dm_last)
    integer,intent(in)::norbs
    complex(q),intent(in)::dm(norbs,norbs),vj2e(norbs,norbs,norbs,norbs)
    complex(q),intent(inout)::vhf(norbs,norbs)
    complex(q),optional,intent(in)::dm_last(norbs,norbs)

    complex(q) dm_t(norbs,norbs)

    if(present(dm_last))then
        dm_t=transpose(dm-dm_last)
    else
        dm_t=transpose(dm)
    endif
    call get_hf_pot(norbs,dm_t,vj2e,vhf)
    return

    end subroutine get_veff

    subroutine get_energy_tot(e_tot,norbs,h1e,vhf,dm)
    real(q),intent(out)::e_tot
    integer,intent(in)::norbs
    complex(q),intent(in)::h1e(norbs,norbs),vhf(norbs,norbs), &
            &dm(norbs,norbs)

    complex(q) dm_t(norbs,norbs),tmp(norbs,norbs)

    dm_t=transpose(dm)
    e_tot=sum(h1e*dm_t)+sum(vhf*dm_t)/2.d0
    return

    end subroutine get_energy_tot

end module ghfscf


module mesa_interface
    use star_lib
    use star_def
    use const_def
    use const_lib
    use math_lib
    use chem_def
    use eos_lib
    use eos_def
    use kap_lib
    use run_star_support
    use run_star_extras, rse_extras_controls => extras_controls

    implicit none

    integer, parameter :: MESA_FAIL=-1, MESA_SUCESS=0
    logical :: use_gyre=.false.

    integer, parameter :: M_CENTER=0
    integer, parameter :: R_CENTER=1
    integer, parameter :: L_CENTER=2
    integer, parameter :: V_CENTER=3

    character(len=256),dimension(max_star_handles) :: restart_name = ''

    contains

! ***********************************************************************
! Routines for making a new model
! ***********************************************************************

    subroutine allocate_star(id, ierr)
        use ctrls_io, only: set_default_controls, store_controls
        use star_job_ctrls_io, only: set_default_star_job_controls, store_star_job_controls
        integer, intent(out) :: id
        integer, intent(out) :: ierr
        integer :: i
        type (star_info), pointer :: s

        call alloc_star(id, ierr)

        if (failed('alloc_star',ierr)) return

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        call set_default_star_job_controls()
        call store_star_job_controls(s, ierr)
        if (failed('store_star_job_controls',ierr)) return

        call set_default_controls()
        call store_controls(s, ierr)
        if (failed('store_controls',ierr)) return

        s% inlist_fname = ''

        call init_starting_star_data(s, ierr)

    end subroutine allocate_star

    subroutine load_inlist(id, inlist, ierr)
        use ctrls_io, only: read_controls_file
        use star_job_ctrls_io, only: read_star_job_file, check_star_job_controls
        integer, intent(in) :: id
        character (len=*), intent(in) :: inlist
        integer, intent(out) :: ierr
        type (star_info), pointer :: s

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        s% inlist_fname = inlist

        call read_star_job_file(s, s% inlist_fname, 1, ierr)
        if (failed('read_star_job_file',ierr)) return

        call check_star_job_controls(s, ierr)
        if (failed('check_star_job_controls',ierr)) return

        call read_controls_file(s, s% inlist_fname, 1, ierr)
        if (failed('read_controls_file',ierr)) return

    end subroutine load_inlist

    subroutine create_pre_main_sequence(id, ierr)
        integer, intent(in) :: id
        integer, intent(out) :: ierr

        type (star_info), pointer :: s

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        s% job% create_pre_main_sequence_model = .true.
        s% job% load_saved_model = .false.

    end subroutine create_pre_main_sequence

    subroutine load_saved_model(id, filename, ierr)
        integer, intent(in) :: id
        character (len=*), intent(in) :: filename
        integer, intent(out) :: ierr

        type (star_info), pointer :: s

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        s% job% load_saved_model = .true.
        s% job% saved_model_name = trim(filename)

        s% job% create_pre_main_sequence_model = .false.

    end subroutine load_saved_model

    subroutine load_zams_model(id, ierr)
        integer, intent(in) :: id
        integer, intent(out) :: ierr

        type (star_info), pointer :: s

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        s% job% load_saved_model = .false.
        s% job% create_pre_main_sequence_model = .false.

    end subroutine load_zams_model

    subroutine load_mesa_photo(id, filename, ierr)
        integer, intent(in) :: id
        character(len=*), intent(in) :: filename
        integer, intent(out) :: ierr
        type (star_info), pointer :: s

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        s% photo_directory = '.'
        restart_name(id) = trim(filename)

    end subroutine load_mesa_photo

    subroutine save_mesa_photo(id, filename, ierr)
        integer, intent(in) :: id
        character(len=*), intent(in) :: filename
        integer, intent(out) :: ierr

        call star_save_for_restart(id, filename, ierr)

    end subroutine save_mesa_photo

    subroutine save_mesa_model(id, filename, ierr)
        integer, intent(in) :: id
        character(len=*), intent(in) :: filename
        integer, intent(out) :: ierr

        call star_write_model(id, filename, ierr)

    end subroutine save_mesa_model

    subroutine create_he_star(id, ierr)
        integer, intent(in) :: id
        integer, intent(out) :: ierr

        type (star_info), pointer :: s

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        s% job% create_pre_main_sequence_model = .true.

        s% initial_he3 = 0d0

        s% job% relax_initial_y = .true.
        s% job% new_Y = 1d0 - s% initial_z

        s% job% relax_initial_z = .true.
        s% job% new_Z = s% initial_z

    end subroutine create_he_star

    subroutine finish_init_star(id, init_callback, ierr)
        integer, intent(inout) :: id
        interface
            subroutine init_callback(x)
                integer, intent(in) :: x
            end subroutine init_callback
        end interface
        integer, intent(out) :: ierr
        logical :: restart
        type (star_info), pointer :: s
        logical, parameter :: dbg=.true.

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        call init_callback(id) ! Call here and in evolve_controls as there are options that
                               ! need to be set before and after the other inlist options get set
        id_from_read_star_job = id

        call before_evolve_loop(.true., .true., restart, &
            null_binary_controls, extras_controls, &
            id_from_read_star_job, s% inlist_fname, restart_name(id), &
            dbg, 0, id, ierr)

        if (failed('before_evolve_loop',ierr)) return

        contains

        subroutine extras_controls(id, ierr)
            integer, intent(in) :: id
            integer, intent(out) :: ierr
            type (star_info), pointer :: s
            ierr = 0
            call star_ptr(id, s, ierr)
            if (ierr /= 0) return

           ! This is a local copy of extras_controls,
           ! Plese add your changes to the version in run_star_extras.f90 not this one

            s% doing_timing = .true.
            s% job% check_before_step_timing = 0
            s% job% check_step_loop_timing = 0
            s% job% check_after_step_timing = 0
            s% job% time0_initial = 0
            s% calculate_Brunt_N2 = .true.

            call init_callback(id)

            ! Set zbase if its not been set yet
            if(s%kap_rq% zbase == -1) s%kap_rq% zbase = s%initial_z

            ! Override photo_directory otherwise we look in photos/ instead of ./
            ! This does nothing for 15140 but later versions can use this to set
            ! the folder for the restart photo to the current directory.
            if(len_trim(restart_name(id)) > 0) then
                s%photo_directory = '.'
            end if

            call rse_extras_controls(id, ierr)

         end subroutine extras_controls

    end subroutine finish_init_star

    subroutine remove_star(id, ierr)
        integer, intent(in) :: id
        integer, intent(out) :: ierr

        call free_star(id, ierr)
        if (failed('free_star',ierr)) return

    end subroutine remove_star

    subroutine max_num_stars(num)
        integer, intent(out) :: num

        num =  max_star_handles

    end subroutine max_num_stars

    integer function how_many_allocated_star_ids()
        integer :: id
        how_many_allocated_star_ids = 0
        if (have_initialized_star_handles) then
            do id = 1, max_star_handles
                if (star_handles(id)% in_use .eqv. .true.) &
                    how_many_allocated_star_ids = how_many_allocated_star_ids+1
            end do
        end if
    end function how_many_allocated_star_ids

! ***********************************************************************
! Routines for setting stellar parameters
! ***********************************************************************

    subroutine  set_init_options(id, &
                                mass, &
                                mesa_dir_in, &
                                output_folder, &
                                inlist, &
                                metallicity,&
                                max_age_stop_condition, &
                                min_timestep_stop_condition, &
                                max_iter_stop_condition, &
                                gyre_in, &
                                temp_dir &
                                )
        integer, intent(in) :: id
        character(len=*), intent(in) :: mesa_dir_in, output_folder, inlist, gyre_in, temp_dir
        real(dp), intent(in) :: mass, metallicity,&
                                max_age_stop_condition, &
                                min_timestep_stop_condition
        integer,intent(in) :: max_iter_stop_condition

        type (star_info), pointer :: s
        integer :: ierr

        ! Needs work as it breaks things
        !call chdir(output_folder)

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        mesa_dir = mesa_dir_in

        call const_init(mesa_dir_in, ierr)
        if (failed('const_init',ierr)) return

        s% inlist_fname = inlist

        s% job% mesa_dir = mesa_dir_in
        s% initial_mass = mass
        s% initial_z = metallicity
        s% max_age = max_age_stop_condition
        s% min_timestep_limit = min_timestep_stop_condition
        s% max_model_number = max_iter_stop_condition

        ! Disable for now
        s% do_history_file = .false.
        s% write_profiles_flag = .false.
        s% history_interval = -1
        s% profile_interval = -1
        s% photo_interval = -1
        s% terminal_interval = -1
        s% write_header_frequency =-1

        mesa_temp_caches_dir = trim(temp_dir)

        s% report_ierr = .false.

        if(len_trim(gyre_in) > 0) then
            call setup_gyre(gyre_in)
            use_gyre = .true.
        end if

    end subroutine set_init_options

    subroutine update_star_job(id, ierr)
        integer, intent(in) :: id
        integer, intent(out) :: ierr
        type (star_info), pointer :: s

        ierr = MESA_SUCESS

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        call do_star_job_controls_after(id, s, .false., ierr)

    end subroutine update_star_job

    subroutine get_net_name(id, net_name, ierr)
        integer, intent(in) :: id
        character(len=*), intent(out) :: net_name
        integer, intent(out) :: ierr
        type (star_info), pointer :: s

        ierr = MESA_SUCESS

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        net_name = s%net_name

    end subroutine get_net_name

    subroutine set_net_name(id, net_name, ierr)
        integer, intent(in) :: id
        character(len=*), intent(in) :: net_name
        integer, intent(out) :: ierr
        type (star_info), pointer :: s

        ierr = MESA_SUCESS

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        call star_change_to_new_net(id, .true., net_name, ierr)

        if (failed('change_net',ierr)) return

    end subroutine set_net_name

    subroutine set_new_age(id, age, ierr)
        integer, intent(in) :: id
        real(dp) :: age ! in years
        integer, intent(out) :: ierr

        ierr = MESA_SUCESS

        call star_set_age(id, age, ierr)

    end subroutine set_new_age

    subroutine get_star_control_nml(id, name, val, ierr)
        integer, intent(in) :: id
        character(len=*) :: name, val
        integer, intent(out) :: ierr
        ierr = 0
        call star_get_control_namelist(id, name, val, ierr)
    end subroutine get_star_control_nml

    subroutine set_star_control_nml(id, name, val, ierr)
        integer, intent(in) :: id
        character(len=*) :: name, val
        integer, intent(out) :: ierr
        ierr = 0
        call star_set_control_namelist(id, name, val, ierr)
    end subroutine set_star_control_nml

    subroutine get_star_job_nml(id, name, val, ierr)
        integer, intent(in) :: id
        character(len=*) :: name, val
        integer, intent(out) :: ierr
        ierr = 0
        call star_get_star_job_namelist(id, name, val, ierr)
    end subroutine get_star_job_nml

    subroutine set_star_job_nml(id, name, val, ierr)
        integer, intent(in) :: id
        character(len=*) :: name, val
        integer, intent(out) :: ierr
        ierr = 0
        call star_set_star_job_namelist(id, name, val, ierr)
    end subroutine set_star_job_nml

    subroutine get_eos_nml(id, name, val, ierr)
        integer, intent(in) :: id
        character(len=*) :: name, val
        integer, intent(out) :: ierr
        ierr = 0
        call eos_get_control_namelist(id, name, val, ierr)
    end subroutine get_eos_nml

    subroutine set_eos_nml(id, name, val, ierr)
        integer, intent(in) :: id
        character(len=*) :: name, val
        integer, intent(out) :: ierr
        ierr = 0
        call eos_set_control_namelist(id, name, val, ierr)
    end subroutine set_eos_nml

    subroutine get_kap_nml(id, name, val, ierr)
        integer, intent(in) :: id
        character(len=*) :: name, val
        integer, intent(out) :: ierr
        ierr = 0
        call kap_get_control_namelist(id, name, val, ierr)
    end subroutine get_kap_nml

    subroutine set_kap_nml(id, name, val, ierr)
        integer, intent(in) :: id
        character(len=*) :: name, val
        integer, intent(out) :: ierr
        ierr = 0
        call kap_set_control_namelist(id, name, val, ierr)
    end subroutine set_kap_nml

! ***********************************************************************
! Routines for evovling a star
! ***********************************************************************

    subroutine do_evolve_one_step(id, result, ierr)
        integer, intent(in) :: id
        integer, intent(out) :: result, ierr
        type (star_info), pointer :: s

        integer :: model_number
        logical :: continue_evolve_loop, first_try
        logical,parameter :: dbg=.true.

        ierr = MESA_SUCESS

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        call before_step_loop(s% id, ierr)
        if (failed('before_step_loop',ierr)) return

        result = s% extras_start_step(id)
        if (result /= keep_going) return

        first_try = .true.

        step_loop: do ! may need to repeat this loop

           if (stop_is_requested(s)) then
              continue_evolve_loop = .false.
              result = terminate
              exit
           end if

           result = star_evolve_step(id, first_try)
           if (result == keep_going) result = star_check_model(id)
           if (result == keep_going) result = s% extras_check_model(id)
           if (result == keep_going) result = star_pick_next_timestep(id)
           if (result == keep_going) exit step_loop

           model_number = get_model_number(id, ierr)
           if (failed('get_model_number',ierr)) return

           if (result == retry .and. s% job% report_retries) then
              write(*,'(i6,3x,a,/)') model_number, &
                 'retry reason ' // trim(result_reason_str(s% result_reason))
           end if

           if (result == redo) then
              result = star_prepare_to_redo(id)
           end if
           if (result == retry) then
              result = star_prepare_to_retry(id)
           end if
           if (result == terminate) then
              continue_evolve_loop = .false.
              exit step_loop
           end if
           first_try = .false.
        end do step_loop
        s% doing_first_model_of_run = .false.

        call after_step_loop(s% id, s% inlist_fname, &
            dbg, result, ierr)
        if (failed('after_step_loop',ierr)) return

        call do_saves(id, ierr)
        if (failed('do_saves',ierr)) return

        call flush()

    end subroutine do_evolve_one_step

    subroutine evolve_until(id, delta_t, ierr)
        integer, intent(in) :: id
        real(dp), intent(in) :: delta_t
        integer, intent(out) :: ierr
        type (star_info), pointer :: s
        integer :: result
        logical,parameter :: dbg=.false.
        real(dp) :: old_age

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        old_age = s% max_age

        s% max_age = s% star_age + delta_t
        s% num_adjusted_dt_steps_before_max_age =  -1

        s%dt_next = delta_t * secyer
        evolve_loop: do
            call do_evolve_one_step(id, result, ierr)
            if (result /= keep_going) then
                if (s% result_reason == result_reason_normal) then
                    exit evolve_loop
                else
                    ierr = -1
                    exit evolve_loop
                end if
            end if
            s% doing_first_model_of_run = .false.
        end do evolve_loop

        ! In case you want to evolve further
        s% max_age = old_age

        s% doing_first_model_of_run = .false.

    end subroutine evolve_until

! ***********************************************************************
! Routines for modifying a star
! ***********************************************************************

    subroutine set_initial_mass(id, new_mass, ierr)
        integer, intent(in) :: id
        real(dp), intent(in) :: new_mass
        integer, intent(out) :: ierr
        type (star_info), pointer :: s

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        s% initial_mass = new_mass

    end subroutine set_initial_mass

    subroutine set_model_number(id, new_number, ierr)
        integer, intent(in) :: id
        integer, intent(in) :: new_number
        integer, intent(out) :: ierr
        type (star_info), pointer :: s

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        s% model_number = new_number

    end subroutine set_model_number
    subroutine set_timestep(id, dt_next, ierr)
        integer, intent(in) :: id
        real(dp), intent(in) :: dt_next
        integer, intent(out) :: ierr

        call set_dt_next(id, dt_next, ierr)
        if (failed('set_dt_next',ierr)) return

    end subroutine set_timestep

    subroutine set_new_mass(id, new_mass, ierr)
        integer, intent(in) :: id
        real(dp), intent(in) :: new_mass
        integer, intent(out) :: ierr
        type (star_info), pointer :: s

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        call star_relax_mass(id, new_mass, s% job% lg_max_abs_mdot, ierr)
        if (failed('star_relax_mass',ierr)) return

    end subroutine set_new_mass

    subroutine set_new_metallicity(id, new_z, ierr)
        integer, intent(in) :: id
        real(dp), intent(in) :: new_z
        integer, intent(out) :: ierr
        type (star_info), pointer :: s

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        call star_relax_z(id, new_z, s% relax_dlnZ, 0d0, 1d0, ierr)
        if (failed('star_relax_z',ierr)) return

    end subroutine set_new_metallicity

    subroutine relax_to_new_comp(id, xa, xqs, ierr)
        integer, intent(in) :: id
        real(dp), intent(in) :: xa(:,:), xqs(:)
        type (star_info), pointer :: s
        integer, intent(out) :: ierr
        integer :: k
        real(dp) :: max_age
        ierr=0
        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        if(s%species /= size(xa,dim=1)) then
            ierr = -50
            return
        end if

        call star_relax_composition(id, s% job% num_steps_to_relax_composition, &
                                    size(xqs),size(xa,dim=1) ,xa, xqs, ierr )

    end subroutine relax_to_new_comp

    subroutine relax_to_new_entropy(id, xqs, temperature, rho, ierr)
        integer, intent(in) :: id
        real(dp), intent(in) :: xqs(:), temperature(:), rho(:)
        type (star_info), pointer :: s
        integer, intent(out) :: ierr
        real(dp), allocatable, dimension(:) :: entropy
        real(dp), dimension(num_eos_basic_results) :: res,d_dlnd, d_dlnT, d_dabar, d_dzbar
        integer :: num_pts, k
        ierr=0
        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        s% doing_first_model_of_run = .false.
        num_pts = size(xqs)

        allocate(entropy(num_pts))

        do k = 1, num_pts
            ! get entropy
            call eosDT_get( &
                s% eos_handle, 1 - s% X(k) - s% Y(k), s% X(k), s% abar(k), s% zbar(k), &
                s% species, s% chem_id, s% net_iso, s% xa(:,k), &
                rho(k), log10(rho(k)), temperature(k), log10(temperature(k)), &
                res, d_dlnd, d_dlnT, d_dabar, d_dzbar, ierr)
            if (ierr /= 0) then
                write(*,*) "failed in eosDT_get"
                return
            end if
            entropy(k) = exp(res(i_lnS))
        end do

        s% min_timestep_limit = 1d-15

        call star_relax_entropy(id, s% job% max_steps_to_relax_entropy, num_pts, entropy, xqs, ierr)
        deallocate(entropy)

    end subroutine relax_to_new_entropy

    subroutine set_star_center_value(id, boundary, val, ierr)
        integer, intent(in) :: id,boundary
        real(dp),intent(in) :: val
        integer, intent(out) :: ierr
        type (star_info), pointer :: s

        ierr = MESA_SUCESS
        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        select case (boundary)
            case(M_CENTER)
                call star_relax_m_center(id,  val, s% job% dlgm_per_step, s% job% relax_M_center_dt,ierr)
            case(R_CENTER)
                call star_relax_r_center(id, val, s% job% dlgR_per_step, s% job% relax_R_center_dt,ierr)
            case(L_CENTER)
                call star_relax_l_center(id,  val, s% job% dlgL_per_step, s% job% relax_L_center_dt,ierr)
            case(V_CENTER)
                call star_relax_v_center(id,  val, s% job% dv_per_step, s% job% relax_v_center_dt,ierr)
            case default
                ierr = MESA_FAIL
        end select

    end subroutine set_star_center_value

    subroutine get_star_center_value(id, boundary, val, ierr)
        integer, intent(in) :: id, boundary
        real(dp),intent(out) :: val
        integer, intent(out) :: ierr
        type (star_info), pointer :: s

        ierr = MESA_SUCESS
        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        select case (boundary)
            case(M_CENTER)
                val = s% m_center
            case(R_CENTER)
                val = s% r_center
            case(L_CENTER)
                val = s% l_center
            case(V_CENTER)
                val = s% v_center
            case default
                ierr = MESA_FAIL
        end select

    end subroutine get_star_center_value

    subroutine change_species_one_zone(id, zone, species, value, ierr)
        integer, intent(in) :: id, species, zone
        real(dp),intent(in) :: value
        integer, intent(out) :: ierr
        type (star_info), pointer :: s
        integer :: net_id

        ierr = MESA_SUCESS
        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        call set_abundance_in_section(id, s% chem_id(species), value,zone, zone, ierr)
        if (failed('star_set_abundance',ierr)) return

    end subroutine change_species_one_zone

! ***********************************************************************
! Routines for acessing stellar properites
! ***********************************************************************

    subroutine get_history_value(id, name, val, ierr)
        integer, intent(in) :: id
        character(*),intent(in) :: name

        real(dp),intent(out) :: val
        integer, intent(out) :: ierr
        integer,dimension(1) :: specs
        type (star_info), pointer :: s

        ierr = MESA_FAIL

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return
        ! Check name exists
        call star_history_specs(s, 1, (/name/), specs, .false.)
        if(specs(1)==-1) then
            ierr = MESA_FAIL
            return
        end if

        val = star_get_history_output_by_id(id, name)
        if(val == -HUGE(val)) then
            ierr = MESA_FAIL
        else
            ierr = MESA_SUCESS
        end if

    end subroutine get_history_value

    subroutine get_profile_value_zone(id, name, k, val, ierr)
        integer, intent(in) :: id, k
        character(*),intent(in) :: name

        real(dp),intent(out) :: val
        integer, intent(out) :: ierr
        integer :: profile_id
        type (star_info), pointer :: s

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        if(k<=0 .or. k > s%nz)then
            ierr = MESA_FAIL
            return
        end if

        ! Check it exists
        call star_get_profile_id(s, name, profile_id)
        if(profile_id<0) then
            val = -HUGE(val)
            ierr = MESA_FAIL
            return
        end if

        val = star_get_profile_output_by_id(id, name, k)

        if(val == -HUGE(val)) then
            ierr = MESA_FAIL
        else
            ierr = MESA_SUCESS
        end if

    end subroutine get_profile_value_zone

    subroutine get_profile_values(id, name, val, ierr)
        integer, intent(in) :: id
        character(*),intent(in) :: name

        real(dp),dimension(:),intent(out) :: val
        integer, intent(out) :: ierr
        integer :: i, profile_id
        type(star_info), pointer :: s

        call star_ptr(id, s, ierr)
        if (ierr /= 0) then
            ierr = MESA_FAIL
            val = -1
            return
        end if

        if (size(val)/=s%nz) then
            ierr = MESA_FAIL
            val = -1
            return
        end if

        ! Check it exists
        call star_get_profile_id(s, name, profile_id)

        if(profile_id<0) then
            ierr = MESA_FAIL
            return
        end if

        ierr = MESA_SUCESS
        val = -1
        do i=1, s%nz
            val(i) = star_get_profile_output_by_id(id, name, i)

            if(val(i) == -HUGE(val)) then
                ierr = MESA_FAIL
                exit
            end if
        end do

    end subroutine get_profile_values

    subroutine get_next_timestep(id, dt_next, ierr)
        integer, intent(in) :: id
        real(dp), intent(out) :: dt_next
        integer, intent(out) :: ierr

        call get_dt_next(id, dt_next, ierr)

    end subroutine get_next_timestep

    integer function reverse_zone_id(id, zone, ierr)
        integer, intent(in) :: id, zone
        integer, intent(out) :: ierr
        type (star_info), pointer :: s

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        reverse_zone_id = s%nz - zone

        if(reverse_zone_id < 0 .or. reverse_zone_id > s%nz) then
            ierr = MESA_FAIL
            reverse_zone_id = -1
        end if

    end function reverse_zone_id

    subroutine get_species_name(id, net_id, name, ierr)
        use chem_def
        integer, intent(in) :: id, net_id
        character(*), intent(out) :: name
        integer, intent(out) :: ierr
        type (star_info), pointer :: s

        name=''

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        if(net_id < 0 .or. net_id > s%species) then
            ierr = -2
            return
        end if

        name = chem_isos% name(s% chem_id(net_id))

    end subroutine get_species_name

    subroutine get_species_id(id, iso_name, net_id, ierr)
        use chem_lib, only: chem_get_iso_id
        integer, intent(in) :: id
        integer, intent(out) :: net_id
        character(len=*), intent(in) :: iso_name
        integer, intent(out) :: ierr
        type (star_info), pointer :: s
        integer :: k

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        ierr = -2
        do k=1,s%species
            if(chem_isos% name(s% chem_id(k)) == trim(iso_name)) then
                ierr = 0
                net_id = k
                exit
            end if
        end do

    end subroutine get_species_id

    subroutine get_mass_number_species(id, net_id, mass, ierr)
        integer, intent(in) :: id
        integer, intent(in) :: net_id
        real(dp), intent(out) :: mass
        integer, intent(out) :: ierr
        type (star_info), pointer :: s
        integer :: species_id

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        if(net_id < 1 .or. net_id > s% species) then
            ierr =-2
            return
        end if

        mass = chem_isos% W(s% chem_id(net_id))

    end subroutine get_mass_number_species

    subroutine get_total_mass_species(id, net_id, mass, ierr)
        integer, intent(in) :: id
        integer, intent(in) :: net_id
        real(dp), intent(out) :: mass
        integer, intent(out) :: ierr
        type (star_info), pointer :: s
        integer :: species_id

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        if(net_id < 1 .or. net_id > s% species) then
            ierr =-2
            return
        end if

        mass = dot_product(s% xa(net_id,1:s% nz),s% dq(1:s% nz))/sum(s% dq(1:s% nz))
        mass = mass*s% xmstar/Msun

    end subroutine get_total_mass_species

    subroutine get_species_at_zone(id, net_id, zone, mass, ierr)
        integer, intent(in) :: id, zone
        integer, intent(in) :: net_id
        real(dp), intent(out) :: mass
        integer, intent(out) :: ierr
        type (star_info), pointer :: s
        integer :: species_id

        mass = -1

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        if(zone<0 .or. zone> s%nz) then
            ierr = -2
            return
        end if

        if(net_id < 1 .or. net_id > s% species) then
            ierr =-3
            return
        end if

        mass  = s% xa(net_id, zone)

    end subroutine get_species_at_zone

    subroutine time_of_step(id, time, ierr)
        integer, intent(in) :: id
        integer, intent(out) :: time
        integer, intent(out) :: ierr
        type (star_info), pointer :: s

        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        time = s% job% after_step_timing

    end subroutine time_of_step

    ! Routines for setting/getting MESA varaibles that are not available via history/profile output
    subroutine get_value(id, name, val, k, ierr)
        integer, intent(in) :: id, k
        character(len=*), intent(in) :: name
        real(dp), intent(out) :: val
        integer, intent(out) :: ierr
        type (star_info), pointer :: s

        ierr = 0
        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        if(k<1 .or. k> s% nz) then
            ierr = -2
            return
        end if

        select case(name)
            case('extra_heat')
                val = s% extra_heat(k)
            case default
                ierr = -3
        end select

    end subroutine get_value

    subroutine set_value(id, name, val, k, ierr)
        integer, intent(in) :: id, k
        character(len=*), intent(in) :: name
        real(dp), intent(in) :: val
        integer, intent(out) :: ierr
        type (star_info), pointer :: s

        ierr = 0
        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        if(k<1 .or. k> s% nz) then
            ierr = -2
            return
        end if

        select case(name)
            case('extra_heat')
                s% extra_heat(k) = val
            case default
                ierr = -3
        end select

    end subroutine set_value

! ***********************************************************************
! Routines for GYRE
! ***********************************************************************

    subroutine setup_gyre(gyre_in)
        use gyre_lib
        use const_def
        character(len=*), intent(in) :: gyre_in

        ! Initialize GYRE

        call gyre_init(gyre_in)

        ! Set constants

        call gyre_set_constant('G_GRAVITY', standard_cgrav)
        call gyre_set_constant('C_LIGHT', clight)
        call gyre_set_constant('A_RADIATION', crad)

        call gyre_set_constant('M_SUN', Msun)
        call gyre_set_constant('R_SUN', Rsun)
        call gyre_set_constant('L_SUN', Lsun)

        call gyre_set_constant('GYRE_DIR', TRIM(mesa_dir)//'/gyre/gyre')

    end subroutine setup_gyre

    subroutine get_gyre_data(id, mode_l, &
         add_center_point, keep_surface_point, add_atmosphere, &
         fileout, ierr)
        use gyre_lib
        integer, intent(in) :: id, mode_l
        integer, intent(out) :: ierr
        logical, intent(in) :: add_center_point, keep_surface_point, add_atmosphere
        type (star_info), pointer :: s
        real(dp), allocatable     :: global_data(:)
        real(dp), allocatable     :: point_data(:,:)
        integer                   :: ipar(1)
        real(dp)                  :: rpar(1)
        character(len=*),intent(in) :: fileout

        ierr = 0
        call star_ptr(id, s, ierr)
        if (failed('star_ptr',ierr)) return

        if(.not.use_gyre) then
            ierr = -99
            return
        end if

        call star_get_pulse_data(s%id, 'GYRE', &
            add_center_point, keep_surface_point, add_atmosphere, &
            global_data, point_data, ierr)

        if (ierr /= 0) return

        call gyre_set_model(global_data, point_data, 101)

        call gyre_get_modes(mode_l, process_mode_, ipar, rpar)

        ierr = ipar(1)

    contains

        subroutine process_mode_ (md, ipar, rpar, retcode)

         type(mode_t), intent(in) :: md
         integer, intent(inout)   :: ipar(:)
         real(dp), intent(inout)  :: rpar(:)
         integer, intent(out)     :: retcode

         integer               :: k, unit
         complex(dp)           :: cfreq
         real(dp)              :: freq, growth
         type(grid_t)          :: gr

         retcode= 0
         ipar(1) = 0
         cfreq = md% freq('HZ')
         gr = md%grid()

         open(newunit=unit,file=fileout,action='write',status='old',position="append")

         write(unit,*) md%n_pg,md%n_p,md%n_g,md%n_k,REAL(cfreq),IMAG(cfreq)

         do k=1,md%n_k
            write(unit,'(I8,6(1X,E24.16))') k, gr%pt(k)%x, &
                                            md%xi_r(k), md%xi_h(k), md%dW_dx(k)
         end do
         flush(unit)
         close(unit)

        end subroutine process_mode_

    end subroutine get_gyre_data

end module mesa_interface