c
c
c    Subroutine library for shifting via projection
c
C***********************************************************************
      subroutine h3drescalemp(nd,nterms,lmp,mpole,
     1           radius,zk0,scale,fhs,fhder)
C***********************************************************************
C
C     This subroutine rescales a spherical harmonic expansion
C     on the surface by h_n(zk0 * radius), converting
C     a surface function to the corresponding Hankel expansion
C     in the exterior.
C
C---------------------------------------------------------------------
C     INPUT:
C
C           nd     = number of expansions
C           nterms = order of spherical harmonic expansion
C           mpole = coefficients of s.h. expansion
C           radius = sphere radius
C           zk0 = Helmholtz parameter
C           scale = scale parameter for expansions
C           w       = workspace of length lw
C
C---------------------------------------------------------------------
C     OUTPUT:
C
C           mpole = rescaled by 1/h_n(zk0* radius)
C
C---------------------------------------------------------------------
      implicit none
      integer lmp
      integer nterms,ier,nd,idim
      integer l,m,jj,kk
      integer lwfhs,ifder
      real *8 radius,scale
      complex *16 mpole(nd,0:lmp,-lmp:lmp)
      complex *16 ephi,imag,emul,sum,zmul
      complex *16 fhs(0:nterms),fhder(0:nterms)
      complex *16 zk0,z
      data imag/(0.0d0,1.0d0)/
C
      z = zk0*radius
      ifder = 0
      call h3dall(nterms,z,scale,fhs,
     1             ifder,fhder)
      do l=0,nterms
         do m=-l,l
            zmul = 1/fhs(l)
            do idim=1,nd
	          mpole(idim,l,m) = mpole(idim,l,m)*zmul
            enddo
         enddo
      enddo
      return
      end
c
C
C
C***********************************************************************
      subroutine h3drescaleloc(nd,nterms,lmp,local,localn,
     1           radius,zk0,scale,fjs,fjder)
C***********************************************************************
C
C     This subroutine takes as input the potential and its normal
C     derivative on a sphere of radius RADIUS and returns the
C     j-expansion coefficients consist with the data (in a least
C     squares sense). That is
C
C           phi  = sum local(n,m) j_n Y_n^m  ->
C           phin = sum local(n,m) zk0 *j_n' Y_n^m and
C
C           local(n,m) * j_n        = phi_n^m
C           local(n,m) * j_n' *zk0  = phin_n^m
C
C     The 1x1 normal equations are:
C
C           local(n,m)* ( j_n**2 + (zk0* j_n')**2) =
C
C                          j_n * phi_n^m + zk0 * j_n' * phin_n^m.
C
C---------------------------------------------------------------------
C     INPUT:
C
C           nd     = number of local expansions
C           nterms = order of spherical harmonic expansion
C           local = coefficients of s.h. expansion of phi
C           localn = coefficients of s.h. expansion of dphi/dn
C           radius = sphere radius
C           zk0 = Helmholtz parameter
C           scale = scale parameter for expansions
C
C---------------------------------------------------------------------
C     OUTPUT:
C
C           local = computed as above.
C
C---------------------------------------------------------------------
      implicit none
      integer nterms,ier,nd,idim
      integer lmp
      integer l,m,jj,kk
      integer lwfhs,ifder
      real *8 radius,scale
      complex *16 fjs(0:nterms)
      complex *16 fjder(0:nterms)
      complex *16 local(nd,0:lmp,-lmp:lmp)
      complex *16 localn(nd,0:lmp,-lmp:lmp)
      complex *16 ephi,imag,emul,sum,zmul
      complex *16 zk0,z,zh,zhn
      data imag/(0.0d0,1.0d0)/
C
C
      z = zk0*radius
      ifder = 1
      call besseljs3d(nterms,z,scale,fjs,ifder,fjder)
c
      do l=0,nterms
        do m=-l,l
          zh = fjs(l)
          zhn = fjder(l)*zk0
          zmul = 1/(zh*zh + zhn*zhn)
          do idim=1,nd
            local(idim,l,m) = (zh*local(idim,l,m) +
     1           zhn*localn(idim,l,m))*zmul
          enddo
        enddo
      enddo

      return
      end
c
C
C
C
C
C
C
C
C***********************************************************************
      subroutine h3dlocevalsphere(nd,local,zk,scale,zshift,radius,
     1           nterms,nterms2,lmp,ynm,ynmd,phitemp,phitempn,
     2           nquad,xnodes,fjs,fjder,rat1,rat2)
C***********************************************************************
C
C     This subroutine evaluates a local expansion on a target
C     sphere at a distance (0,0,zshift) from the origin of radius
C     "radius".
C
C---------------------------------------------------------------------
C     INPUT:
C
C     nd       : number of local expansions
C     local    : coefficients of original multipole exp.
C     zk       : Helmholtz parameter
C     scale    : scaling parameter
C     zshift   : shift distance along z-axis.
C     radius   : radius of sphere about (0,0,zshift)
C                              where phival is computed.
C     nterms   : number of terms in the orig. expansion
C     nterms2  : number of terms in exp on target sphere
C     lmp      : dimension param for local expansion
C     ynm      : storage for Ynm out to nterms.
C     nquad    : number of quadrature nodes
C                              on target sphere is nquad*nquad.
C     xnodes   : Legendre nodes x_j = cos theta_j.
C
C---------------------------------------------------------------------
C     OUTPUT:
C
C     phitemp(k,i,j)  : jth mode of phi at ith quad node, for kth expansion
C     phitempn(k,i,j) : jth mode of phi at ith quad node, for kth expansion
C
C***********************************************************************
      implicit none
      integer lmp,ier
      integer nterms,nd,idim,nterms2,nquad
      integer l,m,jnew,knew,jj,n,ifder,iffld
      real *8 radius,scale
      real *8 zshift, targ(3), center(3)
      real *8 xnodes(nquad)
      real *8 ynm(0:nterms,0:nterms)
      real *8 ynmd(0:nterms,0:nterms)
      real *8 ctheta,cthetaj,rj,rn,stheta,pi,sthetaj
      real *8 thetan
      complex *16 local(nd,0:lmp,-lmp:lmp)
      complex *16 phitemp(nd,nquad,-nterms2:nterms2)
      complex *16 phitempn(nd,nquad,-nterms2:nterms2)
      complex *16 imag,pot,fld(3), zk,z,uval,unval,ur,utheta
      complex *16 ephi1,ephik,ephi,fjs(0:nterms),fjder(0:nterms),ztmp1
      complex *16 ut1,ut2,ut3
      real *8 rat1(0:nterms,0:nterms),rat2(0:nterms,0:nterms)
      data imag/(0.0d0,1.0d0)/
C
C----- shift along z-axis.
C      note that everything is scaled.
C
      ier = 0
      pi = 4.0d0*datan(1.0d0)
      center(1) = 0.0d0
      center(2) = 0.0d0
      center(3) = 0.0d0
      iffld = 1
      ifder = 1
      do jj=1,nquad
        do m=-nterms2,nterms2
          do idim=1,nd
            phitemp(idim,jj,m) = 0.0d0
            phitempn(idim,jj,m) = 0.0d0
          enddo
        enddo
      enddo
      call ylgndrini(nterms,rat1,rat2)
      do jj=1,nquad
        ctheta = xnodes(jj)
        stheta = dsqrt(1.0d0 - ctheta**2)
        rj = (zshift+ radius*ctheta)**2 + (radius*stheta)**2
        rj = dsqrt(rj)
        cthetaj = (zshift+radius*ctheta)/rj
        sthetaj = dsqrt(1.0d0-cthetaj**2)
        rn = sthetaj*stheta + cthetaj*ctheta
        thetan = (cthetaj*stheta - sthetaj*ctheta)/rj
        z = zk*rj
        call ylgndr2sf(nterms,cthetaj,ynm,ynmd,rat1,rat2)
        call besseljs3d(nterms,z,scale,fjs,ifder,fjder)
	    do n = 0,nterms
	      fjder(n) = fjder(n)*zk
        enddo
	    do n = 1,nterms
	      do m = 1,n
	        ynm(n,m) = ynm(n,m)*sthetaj
          enddo
        enddo

        ztmp1 = fjder(0)*rn
        do idim=1,nd
          phitemp(idim,jj,0) = local(idim,0,0)*fjs(0)
          phitempn(idim,jj,0) = local(idim,0,0)*ztmp1
        enddo

        do n=1,nterms
          ztmp1 = fjs(n)*ynm(n,0)
          ut1 = fjder(n)*rn
          ut2 = fjs(n)*thetan
          ut3 = ut1*ynm(n,0)-ut2*ynmd(n,0)*sthetaj

          do idim=1,nd
            phitemp(idim,jj,0) = phitemp(idim,jj,0) +
     1                  local(idim,n,0)*ztmp1
            phitempn(idim,jj,0) = phitempn(idim,jj,0)+
     1          ut3*local(idim,n,0)
          enddo
c
          do m=1,min(n,nterms2)
c
            ztmp1 = fjs(n)*ynm(n,m)
            ut3 = ut1*ynm(n,m)-ut2*ynmd(n,m)

            do idim=1,nd
              phitemp(idim,jj,m) = phitemp(idim,jj,m) +
     1                local(idim,n,m)*ztmp1
              phitemp(idim,jj,-m) = phitemp(idim,jj,-m) +
     1                local(idim,n,-m)*ztmp1
              phitempn(idim,jj,m) = phitempn(idim,jj,m) +
     1             ut3*local(idim,n,m)
              phitempn(idim,jj,-m) = phitempn(idim,jj,-m) +
     1             ut3*local(idim,n,-m)
            enddo
          enddo
        enddo
      enddo
c
      return
      end
C
C
C
C
c
c
c
C***********************************************************************
      subroutine h3dmpevalsphere(nd,mpole,zk,scale,zshift,
     1           radius,nterms,lmp,ynm,ynmd,phitemp,phitempn,
     2           nquad,xnodes,fhs,fhder,rat1,rat2)
C***********************************************************************
C
C     This subroutine evaluates a multipole expansion on a target
C     sphere at a distance (0,0,zshift) from the origin of radius
C     "radius".
C
C---------------------------------------------------------------------
C     INPUT:
C
C     nd       : number of multipole expansions
C     mpole    : coefficients of original multipole exp.
C     zk       : Helmholtz parameter
C     scale    : mpole scaling parameter
C     zshift   : shift distance along z-axis.
C     radius   : radius of sphere about (0,0,zshift)
C                              where phival is computed.
C     nterms   : number of terms in the orig. expansion
C     lmp      : dimension param for mpole
C     ynm      : storage for assoc Legendre functions
C     ynmd     : storage for derivs of assoc Legendre functions
C     nquad    : number of quadrature nodes in theta
C     xnodes   : Legendre nodes x_j = cos theta_j.
C
C---------------------------------------------------------------------
C     OUTPUT:
C
C     phitemp  : nquad by (-nterms,nterms)
C     phitempn : nquad by (-nterms,nterms)
C
C---------------------------------------------------------------------
      implicit none
      integer lmp,n
      integer nterms,nd,idim
      integer l,m,jnew,knew,nquad
      integer ifder,iffld,i,jj
      real *8 zshift, targ(3), center(3)
      real *8 xnodes(nquad)
      real *8 ynm(0:nterms,0:nterms)
      real *8 ynmd(0:nterms,0:nterms)
      real *8 radius,scale
      real *8 ctheta,cthetaj,pi,rj,rn,stheta,sthetaj,thetan
      complex *16 mpole(nd,0:lmp,-lmp:lmp)
      complex *16 phitemp(nd,nquad,-nterms:nterms)
      complex *16 phitempn(nd,nquad,-nterms:nterms)
      complex *16 imag,pot,fld(3), zk,z,uval,unval,ur,utheta,ut1,ut2
      complex *16 ut3,ephi1,ephik,ephi,fhs(0:nterms),fhder(0:nterms)
      complex *16 ztmp1
      real *8 rat1(0:nterms,0:nterms),rat2(0:nterms,0:nterms)
      data imag/(0.0d0,1.0d0)/
C
C----- shift along z-axis.
C      note that everything is scaled.
C
      pi = 4.0d0*datan(1.0d0)
      center(1) = 0.0d0
      center(2) = 0.0d0
      center(3) = 0.0d0
      iffld = 1
      ifder = 1
      do jj=1,nquad
        do m=-nterms,nterms
          do idim=1,nd
            phitemp(idim,jj,m) = 0.0d0
            phitempn(idim,jj,m) = 0.0d0
          enddo
        enddo
      enddo
      call ylgndrini(nterms,rat1,rat2)
      do jj=1,nquad
	    ctheta = xnodes(jj)
	    stheta = dsqrt(1.0d0 - ctheta**2)
        rj = (zshift+ radius*ctheta)**2 + (radius*stheta)**2
        rj = dsqrt(rj)
	    cthetaj = (zshift+radius*ctheta)/rj
	    sthetaj = dsqrt(1.0d0 - cthetaj**2)
	    rn = sthetaj*stheta + cthetaj*ctheta
	    thetan = (cthetaj*stheta - ctheta*sthetaj)/rj
	    z = zk*rj
	    call ylgndr2sf(nterms,cthetaj,ynm,ynmd,rat1,rat2)
	    call h3dall(nterms,z,scale,fhs,ifder,fhder)
        do i = 0,nterms
	      fhder(i) = fhder(i)*zk
        enddo
        do n=1,nterms
	      do m = 1,n
  	        ynm(n,m) = ynm(n,m)*sthetaj
          enddo
        enddo

        ztmp1 = fhder(0)*rn

        do idim=1,nd
          phitemp(idim,jj,0) = mpole(idim,0,0)*fhs(0)
          phitempn(idim,jj,0) = mpole(idim,0,0)*ztmp1
        enddo
	    do n=1,nterms
          ztmp1 = fhs(n)*ynm(n,0)
	      ut1 = fhder(n)*rn
	      ut2 = fhs(n)*thetan
	      ut3 = ut1*ynm(n,0)-ut2*ynmd(n,0)*sthetaj

          do idim=1,nd
            phitemp(idim,jj,0) = phitemp(idim,jj,0) +
     1                  mpole(idim,n,0)*ztmp1
	        phitempn(idim,jj,0) = phitempn(idim,jj,0) +
     1          ut3*mpole(idim,n,0)
          enddo
          do m=1,n
	        ztmp1 = fhs(n)*ynm(n,m)
	        ut3 = ut1*ynm(n,m)-ut2*ynmd(n,m)
            do idim=1,nd
  	          phitemp(idim,jj,m) = phitemp(idim,jj,m) +
     1                   mpole(idim,n,m)*ztmp1
	          phitemp(idim,jj,-m) = phitemp(idim,jj,-m) +
     1                   mpole(idim,n,-m)*ztmp1
	          phitempn(idim,jj,m) = phitempn(idim,jj,m) +
     1            ut3*mpole(idim,n,m)
	          phitempn(idim,jj,-m) = phitempn(idim,jj,-m) +
     1             ut3*mpole(idim,n,-m)
             enddo
	      enddo
	    enddo
      enddo
c
      return
      end
C
C
C
C
C
C
C***********************************************************************
      subroutine h3dprojloc(nd,nterms,ldl,nquadn,ntold,xnodes,wts,
     1           phitemp,phitempn,local,local2,ynm,rat1,rat2)
C***********************************************************************
C
C     compute spherical harmonic expansion on unit sphere
C     of function tabulated at nquadn*nquadm grid points.
C
C---------------------------------------------------------------------
C     INPUT:
C
C           nd = number of expansions
C           nterms = order of spherical harmonic expansion
C           ldl = order of spherical harmonic expansion
C           nquadn = number of quadrature nodes in polar angle (theta).
C           ntold = number of modes in azimuthal direction.
C           xnodes = quad nodes in theta (polar angle) - nquadn of them
C           wts  = quad weights in theta (polar angle)
C           phitemp, phitempn = tabulated function and normal deriv
C                    phitemp(i,j) = jth mode of phi at ith quad node.
C                    phivaln(i,j) = jth mode of phi at ith quad node.
C
C           marray  = workspace
C           ynm     = workspace for assoc Legendre functions
C
C---------------------------------------------------------------------
C     OUTPUT:
C
C           local  = coefficients of s.h. expansion for phi
C           local2 = coefficients of s.h. expansion for dphi/dn
C
C    NOTE:
C
C    yrecursion.f produces Ynm with a nonstandard scaling:
C    (without the 1/sqrt(4*pi)). Thus the orthogonality relation
C    is
C             \int_S  Y_nm Y_n'm'*  dA = delta(n) delta(m) * 4*pi.
C
C   In the first loop below, you see
C
C	    marray(jj,m) = sum/(2*nquad)
C
C   The latter has incorporated the 1/(4*pi) normalization factor
C   into the azimuthal quadrature weight (2*pi/nquad).
C
C---------------------------------------------------------------------
      implicit none
      integer nterms,nquadn,nquadm,ier,nd,idim
      integer l,m,jj,kk,ntold,ldl,n
      real *8 wts(nquadn),xnodes(nquadn)
      real *8 ynm(0:nterms,0:nterms)
      real *8 cthetaj,pi
      complex *16 zk
      complex *16 local(nd,0:ldl,-ldl:ldl)
      complex *16 local2(nd,0:ldl,-ldl:ldl)
      complex *16 phitemp(nd,nquadn,-ntold:ntold)
      complex *16 phitempn(nd,nquadn,-ntold:ntold)
      complex *16 ephi,imag,emul,sum,emul1
      complex *16, allocatable :: zmul(:),zmul2(:)
      real *8 rat1(0:nterms,0:nterms),rat2(0:nterms,0:nterms)
      data imag/(0.0d0,1.0d0)/
C
      pi = 4.0d0*datan(1.0d0)

      allocate(zmul(nd),zmul2(nd))
c
c     initialize local exp to zero
c
      do l = 0,ldl
        do m = -l,l
          do idim=1,nd
            local(idim,l,m) = 0.0d0
            local2(idim,l,m) = 0.0d0
          enddo
        enddo
      enddo
c
c     get local exp
c
c
      call ylgndrini(nterms,rat1,rat2)
      do jj=1,nquadn
	    cthetaj = xnodes(jj)
	    call ylgndrf(nterms,cthetaj,ynm,rat1,rat2)
        do m=-ntold,ntold
          do idim=1,nd
            zmul(idim) = phitemp(idim,jj,m)*wts(jj)/2.0d0
	        zmul2(idim) = phitempn(idim,jj,m)*wts(jj)/2.0d0
          enddo
          do l=abs(m),nterms
            do idim=1,nd
              local(idim,l,m) = local(idim,l,m) +
     1            zmul(idim)*ynm(l,abs(m))
              local2(idim,l,m) = local2(idim,l,m) +
     1            zmul2(idim)*ynm(l,abs(m))
            enddo
          enddo
        enddo
      enddo
c
      return
      end
c
c
c
C
C
c
c
c
c


! extends MESA constants; checked against CODATA 2018

module constants_def
    use const_def

    implicit none

    ! mathematical constants
    real(dp), parameter :: twopi            = 2.0_dp*pi
    real(dp), parameter :: threepi          = 3.0_dp*pi
    real(dp), parameter :: fourpi           = pi4
    real(dp), parameter :: onethird         = one_third
    real(dp), parameter :: twothird         = two_thirds
    real(dp), parameter :: fivethird        = five_thirds
    real(dp), parameter :: seventhird       = 7.0_dp*onethird
    real(dp), parameter :: threepisquare    = (3.0_dp*pi**2)

    ! physical and astronomical constants, in cgs units
    real(dp), parameter :: boltzmann = kerg
    real(dp), parameter :: avogadro = avo
    real(dp), parameter :: clight2 = clight**2
    real(dp), parameter :: sigma_SB = boltz_sigma
    real(dp), parameter :: arad = crad
    real(dp), parameter :: si_charge = 1.602176634e-19_dp
    real(dp), parameter :: finestructure  = fine
    real(dp), parameter :: electroncharge2 = finestructure*hbar*clight
    real(dp), parameter :: electroncharge = sqrt(electroncharge2)
    real(dp), parameter :: Gnewton = standard_cgrav
    real(dp), parameter :: Mneutron = mn
    real(dp), parameter :: Mproton = mp
    real(dp), parameter :: Melectron = me
    real(dp), parameter :: Mmuon = 1.883531627e-25_dp
    real(dp), parameter :: theta_weak = 0.22290_dp  ! sin(theta_weak)**2
    real(dp), parameter :: Thomson = 8.0_dp*pi*onethird*(electroncharge2/Melectron/clight2)**2

    ! astronomical constants -- see http://ssd.jpl.nasa.gov/?constants
    real(dp), parameter :: julian_day = 86400_dp
    real(dp), parameter :: julian_year = 365.25_dp * julian_day
    real(dp), parameter :: GMsun = mu_sun

    ! some conversion factors
    real(dp), parameter :: fm_to_cm = 1.0e-13_dp
    real(dp), parameter :: ergs_to_mev = 1.0_dp/mev_to_ergs
    real(dp), parameter :: cm_to_fm = 1.0_dp/fm_to_cm

    ! atomic units (length in Bohr radii for hydrogen, energy in Rydberg)
    real(dp), parameter :: a_Bohr = hbar**2/electroncharge2/Melectron
    real(dp), parameter :: Rydberg = 0.5_dp*electroncharge2/a_Bohr

    ! nuclear units (c = 1, hbar = 197 MeV fm; energy is expressed in MeV, length in fm)
    real(dp), parameter :: hbarc_n = hbar*clight/mev_to_ergs/fm_to_cm
    real(dp), parameter :: mass_n = mev_to_ergs/clight2
    real(dp), parameter :: length_n = fm_to_cm
    real(dp), parameter :: density_n = 1.0_dp/fm_to_cm**3
    real(dp), parameter :: pressure_n= mev_to_ergs*density_n
    real(dp), parameter :: temperature_n = mev_to_ergs/boltzmann
    real(dp), parameter :: Mn_n = Mneutron*clight2*ergs_to_mev
    real(dp), parameter :: Mp_n = Mproton*clight2*ergs_to_mev
    real(dp), parameter :: Me_n = Melectron*clight2*ergs_to_mev
    real(dp), parameter :: amu_n = amu*clight2*ergs_to_mev

    ! gravitational units (G = c = 1; unit of mass is Msun)
    real(dp), parameter :: mass_g = Msun
    real(dp), parameter :: potential_g = clight2
    real(dp), parameter :: length_g = Gnewton*mass_g/potential_g
    real(dp), parameter :: density_g = mass_g/length_g**3
    real(dp), parameter :: pressure_g = density_g*potential_g
    real(dp), parameter :: time_g = length_g/clight

end module constants_def


	SUBROUTINE GAUSSIAN_V_DISP(X,Y,N,SIGMA)

!	Applies a gaussian filter to the sed in (X,Y) to reproduce
!	the effect of the velocity dispersion of stars in a galaxy
!	Enter sigma in Km/s

!	Array declaration
	real x(n),y(n),z(50000),u(10000),g(10000)

!	If sigma = 0, return
	if (sigma.le.0.) return

!	Speed of light in Km/s
	c=3.00E5

!	Number of sigmas to deviate from v=0
	m=6

!	Copy array y to array z
	if (n.gt.50000) then
		write (6,*) 'Too many data points in GAUSSIAN_V_DISP:',n
		stop
	endif
	do i=1,n
	z(i)=y(i)
	enddo

	do i=1,n
	xmax=c*x(i)/(c-m*sigma)
	m2 = min(1 + ilocate(x,n,xmax),n)
	m1 = max(2*i-m2,1)
	mt = m2-m1+1
	if (mt > 10000) then
		write (6,*) 'Too many data points in GAUSSIAN_V_DISP:',m1,m2,mt
		stop
	elseif (m1 > 1 .and. x(m2) <= 8750.) then
		k=0
		do j=m2,m1,-1
		v=(x(i)/x(j)-1.)*c
		k=k+1
		u(k)=v
		g(k)=z(j)*gauss(v,0.,sigma)
		enddo
		y(i)=trapz1(u,g,k)
	endif
	enddo
	return
	end


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of tk in forward (tangent) mode:
!   variations   of useful results: tk
!   with respect to varying inputs: *temp *propunit *pres
!   Plus diff mem management of: temp:in propunit:in pres:in
!>    @brief harmonic mean Kz on cell faces in z direction over delz*
!>    @param[in] i grid indices
!>    @param[in] j grid indices
!>    @param[in] k grid indices
!>    @param[in] ismpl local sample index
!>    @return z hydraulic conductivity over delz*  (1/s)
!>    @details
!>    Compute the harmonic mean of Kz on the cell face in positive
!>    z-direction from the current node (i, j, k) divided by the
!>    z-distance of the current node (i, j, k) to the neighboring node
!>    (i, j, k+1).
!>
!>    delz* = 0.5 ( delz(k) + delz(k+1) )
!>
!>    Kz / delz* = [ 0.5*delz(k+1)/K(k+1) + 0.5*delz(k)/K(k) ]**-1
!>
!>               = [ ( 0.5* K(k)* delz(k+1) + 0.5*K(k+1)* delz(k) ) / ( K(k)*K(k+1) ) ]**-1
!>
!>               = [ ( 0.5 * summ ) / (prod) ]**-1 = 2.0*prod/summ
DOUBLE PRECISION FUNCTION g_TK(i, j, k, ismpl, tk)
  USE ARRAYS

  USE g_ARRAYS

  USE MOD_GENRL
  USE MOD_FLOW
  IMPLICIT NONE
  INTEGER :: ismpl
  INTEGER :: i, j, k
  EXTERNAL KZ, RHOF, VISF
  EXTERNAL g_KZ, g_RHOF, g_VISF
  DOUBLE PRECISION :: f1, f2, prod, summ, KZ, RHOF, &
& VISF
  DOUBLE PRECISION :: g_f1, g_f2, g_prod, g_summ, g_KZ, &
& g_RHOF, g_VISF
  DOUBLE PRECISION :: result1
  DOUBLE PRECISION :: g_result1
  DOUBLE PRECISION :: result2
  DOUBLE PRECISION :: g_result2
  DOUBLE PRECISION :: result3
  DOUBLE PRECISION :: g_result3
  DOUBLE PRECISION :: temp0
  DOUBLE PRECISION :: tk
  tk = 0.d0
  IF (k0 .GT. 1 .AND. k .LT. k0) THEN
    g_result1 = g_KZ(i, j, k, ismpl, result1)
    g_result2 = g_RHOF(i, j, k, ismpl, result2)
    g_result3 = g_VISF(i, j, k, ismpl, result3)
    temp0 = result1*result2/result3
    g_f1 = grav*(result2*g_result1+result1*g_result2-temp0*&
&     g_result3)/result3
    f1 = grav*temp0
    g_result1 = g_KZ(i, j, k + 1, ismpl, result1)
    g_result2 = g_RHOF(i, j, k + 1, ismpl, result2)
    g_result3 = g_VISF(i, j, k + 1, ismpl, result3)
    temp0 = result1*result2/result3
    g_f2 = grav*(result2*g_result1+result1*g_result2-temp0*&
&     g_result3)/result3
    f2 = grav*temp0
    g_prod = f2*g_f1 + f1*g_f2
    prod = f1*f2
    g_summ = delz(k+1)*g_f1 + delz(k)*g_f2
    summ = f1*delz(k+1) + f2*delz(k)
    IF (summ .GT. 0.d0) THEN
      g_tk = 2.d0*(g_prod-prod*g_summ/summ)/summ
      tk = 2.d0*prod/summ
    ELSE
      g_tk = 0.D0
    END IF
  ELSE
    g_tk = 0.D0
  END IF
  RETURN
END FUNCTION g_TK