SUBROUTINE simcoda(station)
!---------------------------------------------------------------------
!
! Description:
!
!   Simulate S-wave coda for synthetic Green's function using Zeng's
!   multiple S-to-S scattering theory
!
! Dependencies:
!
!   Subroutines fork, scoda, coda, ener2, evwi,four1d
!
! Fundamental input parameters:
!
!   nfcoda    - fft points for the coda envelope            m=mx
!   merr      - tolerance of the coda envelope              err=errx
!   abscoeff  - absorption coefficient                      gi=gix
!   scatcoeff - scattering coefficient  	                gs=gsx
!   fmax      - maximum frequency for coda waves
!   Q         - Q0 attenuation factor {Q(f)=Q0*f**fdec}
!   fdec      - frequency decay of Q(f) factor	            cn=cnx
!   iseed     - seed number
!   nscat     - number of scattering wavelets
!   hpass	  - highpass corner of the cosine filter        fl=flx
!   trans     - transition bandwidth of the filter          flb=flbx
!   t_len	  - length of time series                       twin=twinx
!   npts	  - number of points computed for coda envelope nt=ntx
!   t0	      - time of first arrival
!   kappa     - kappa factor akp=akpx
!   sr_hypo   - station-hypocenter distance          	    dist=distx
!   aveVs	  - average S-speed between S-R                 vs=vsx
!   siteVs    - S-wave velocity at the site	                vs0=vs0x
!   srcVs     - S-wave velocity at the source               vs1=vs1x
!   siteR     - density at the site                         rh0=rh0x
!   srcR      - density at the source                       rh1=rh1x
!
! References:
!
!   Zeng, Anderson and Su (1995).  Subevent rake and random
!   scattering effects in realistic strong ground motion
!   simulation, Geophy. Res. Lett., 22 17-20
!
! Note:
!
!   Allmost all needed parameters are passed by modules
!
! Authors: W. Imperatori, M. Mai, Y. Zeng
!
! Modified: July 2009 (v1.4)
!
! Updated: December 2012 (v1.4.1)
!    In scoda subroutine, the last do loop has changed
!    from srcV1.4_OLSEN
!
! Updated: March 2013 (v1.4.2)
!    Add chack if Fmax < Fnyq after calculating nw (Fnyq) and nwm (Fmax).
!    When fmax is a certain number, nwm will be larger than npts.
!    This leads u2, u1 and u having NaN or Infinity, generating NaN
!    in the horizontal components in the BroadBand-synthetics.
!    This has happened when fmax is 20Hz.
!
! Updated: April 2014 (v1.5.5)
!    tmp_npts and tmp_lf_len are in the module tmp_para.
!
! Updated: December 2014 (v1.5.5.2)
!    The dimension of p and t must be dimenstion(ncoda)
!    in coda and scoda
!
! Updated: February 2019 (v2.0)
!    Change dt and df computations using v_npts.

use constants; use def_kind; use scattering; use source_receiver
use waveform, only: lf_len, scattgram, v_npts
use interfaces, only: four1d
use tmp_para

implicit none

! local variables
integer(kind=i_single),intent(in)       :: station
!complex(kind=r_single),dimension(npts)  :: u2
!complex(kind=r_single),dimension(npts,3):: u1
!complex(kind=r_single),dimension(2*npts):: u
real(kind=r_single)                     :: kappa_local,dt,df,dw,w,x
real(kind=r_single)                     :: c1,c2,c3,tmp,band,db,Qt
integer(kind=i_single)                  :: k,nw,nwm,j,l,ml,mlb
integer(kind=i_single)                  :: mmb,i

! add
complex(kind=r_single),allocatable,dimension(:)   :: u2
complex(kind=r_single),allocatable,dimension(:,:) :: u1
complex(kind=r_single),allocatable,dimension(:)   :: u

!---------------------------------------------------------------------

! compute some parameters
kappa_local=kappa(station)*0.5
!dt = lf_len/(npts-1)
dt = lf_len/(v_npts-1)

! df is set to avoid time aliasing
!df = 1 / (2 * npts * dt)
df = 1 / (2 * v_npts * dt)
dw=pi_double*df

! index of Fnyq
nw = (npts) + 1

! index of Fmax   (Fmax < Fnyq, guaranteed by subroutine sampling_check)
nwm = nint(fmax/df) + 1

! check Fmax < Fnyq (nwm < nw)
if (npts .lt. nwm) then
   !nwm=npts
   print*,'change Fmax'
   print*,'fmax,npts,nw,df,nwm',fmax,npts,nw,df,nwm
endif

! allocate u2, u1, and u
if (.not. allocated(u2)) then
   allocate(u2(npts), u1(npts,3), u(npts*2))
endif

u2 = zero

do j=2,nwm
   w=(j-1)*dw
   Qt=1.0/(Q*(w/pi_double)**fdec)
   u2(j)=((w-w*log(w/pi_double)*Qt/pi)/aveVs)*cmplx(0.5*Qt,1.0)
enddo

u1 = zero

do l=1,nscat
   x=aveVs*(t0+random_array(1,l)*lf_len)
   c1=random_array(2,l)*2.0-1.0
   c2=random_array(3,l)*2.0-1.0
   c3=random_array(4,l)*2.0-1.0

   do j=1,nwm
      tmp=exp(-x*u2(j))
      u1(j,1)=u1(j,1)+c1*tmp
      u1(j,2)=u1(j,2)+c2*tmp
      u1(j,3)=u1(j,3)+c3*tmp
   enddo

enddo

!  filter the low frequency
ml = nint(hpass/df) + 1
mlb = nint((hpass-trans)/df) + 1

do i=1,3

   u = zero

   do j=mlb,ml-1
      w=(j-1)*dw
      c1 = cos(pi_half * ( (ml-j) / (ml-(mlb-1)) )) *df
      u(j)=u1(j,i)*exp(cmplx(-w*kappa_local,w*t0))*c1
   enddo

   do j=ml,nwm
      w=(j-1)*dw
      u(j)=u1(j,i)*exp(cmplx(-w*kappa_local,w*t0)) *df
   enddo

   do j=2,nw-1
      u(2*npts+2 - j) = conjg(u(j))
   enddo

   call four1d(u,-1)

   do j=1,npts
      scattgram(j,i)=real(u(j))
   enddo

enddo

dw=dw*0.5

! simulate strong motion coda waves for each subfaults
call scoda(sr_hypo(station),dt,station)

END SUBROUTINE simcoda

!=============================================================================

SUBROUTINE fork(lx,cx,signi)

use def_kind

implicit none

integer(kind=i_single),intent(in)                 :: lx
real(kind=r_single),intent(in)                    :: signi
complex(kind=r_single),dimension(lx),intent(inout):: cx

!local
complex(kind=r_single):: carg,cw,ctemp
integer(kind=i_single):: j,i,m,l,istep

j=1

do i=1,lx

   if(i.le.j) then
      ctemp=cx(j)
      cx(j)=cx(i)
      cx(i)=ctemp
   end if

   m=lx/2
20 if(j.le.m) goto 30
   j=j-m
   m=m/2
   if(m.ge.1) goto 20
30 j=j+m

enddo

l=1
40 istep=2*l

do m=1,l
   carg=(0.,1.)*(3.14159265*signi*float(m-1))/float(l)
   cw=cexp(carg)

   do i=m,lx,istep
      ctemp=cw*cx(i+l)
      cx(i+l)=cx(i)-ctemp
      cx(i)=cx(i)+ctemp
   enddo

enddo

l=istep
if(l.lt.lx) goto 40

END SUBROUTINE fork

!=============================================================================

SUBROUTINE scoda(dist,dt,station)

!  Program : scoda.f
!  Purpose : simulate strong motion S-wave coda
!                                by Yuehua Zeng at UNR, Oct 1993
!
! Updated: December 2014 (v1.5.5.2)
!    Add if (n1 .gt. ncoda) n1=ncoda
!    to check if n1 becomes greater than ncoda for p(n1)
!
! Updated: December 2016 (v1.6.2)
!    Change dt1 computation.
!    Add shifting scattgram by minimum initiation time,
!    (tinit, tmp_scatt, sft).
!
! Updated: February 2019 (v2.0)
!    Back to use the original calling coda routine, and no use tmp_para.
!
use constants; use def_kind; use scattering
use waveform, only: lf_len, scattgram
! use tmp_para
use vel_model, only: tinit

implicit none

real(kind=r_single),intent(in):: dist,dt
integer(kind=i_single),intent(in):: station

!local
real(kind=r_single),dimension(ncoda):: p,t
real(kind=r_single),dimension(npts) :: tmp_scatt ! for scattgram shifting, v162
real(kind=r_single):: c0,c1,dt1,t1,pp
integer(kind=i_single):: i1,i2,ii,i,i0,n1
integer(kind=i_single):: sft ! number of scattgram shifting, v162

!	parameter (mm1=8192,mm2=800)
!	dimension pcoda(mm1,3),t(mm2),p(mm2)
!	common/codaw/n,m,err,gi,gs,fl,flb,rh0,rh1,vs0,vs1,vs,twin,dt
!	pi=3.1415926

!  generate the coda waves (1.05 is to avoid noise at time-series end)

call coda(1.05*lf_len,dist,t,p,dt)

c0=0.85/(pi*4.*dist*aveVs)*sqrt(srcVs*srcR/(siteVs(station)*siteR(station)))

c1=sqrt(3.0*lf_len/float(nscat))*c0

! dt1=t(2)-t(1) ! change v162

i1=ifix(t0/dt+0.000001)
i2=ifix(t(1)/dt+0.000001)

do ii=1,3
   do i=1,ncoda
      if(t0.le.t(i))goto 65
   enddo

65 n1=i
   i0=0
   t1=float(i1-1)*dt

   do i=1,i2-i1+1
      i0=i0+1
      t1=t1+dt
      scattgram(i,ii)=0.0
   enddo

! ----- changed from srcV1.4_OLSEN ---------------------------------------------

   do i=i0+1,npts
       t1=t1+dt
       if(t1.gt.t(n1)) then
          n1=n1+1
          ! check if n1 <= ncoda (v1552)
          if (n1 .gt. ncoda) then
             ! n1=ncoda
             print*,'should be n1<=ncoda in scoda,n1,ncoda, STOP'
          endif
       endif
       if(n1>1) then
          dt1=t(n1)-t(n1-1) ! add v162
          pp=p(n1-1)+(p(n1)-p(n1-1))*(t1-t(n1-1))/dt1
       else
          pp=p(n1)
       endif
       scattgram(i,ii)=pp*(c1*scattgram(i,ii))
   enddo

!   do i=i0+1,npts
!      t1=t1+dt
!      if(t1.gt.t(n1))n1=n1+1
!      pp=p(n1-1)+(p(n1)-p(n1-1))*(t1-t(n1-1))/dt1
!      scattgram(i,ii)=pp*(c1*scattgram(i,ii))
!   enddo

! ----- end of change ----------------------------------------------------------

! scattgram shift by minimum initiation time (for multiple-segment-rupture)
   if(tinit > 0) then
      sft = nint(tinit/dt)
      tmp_scatt(1:npts)=0.
      tmp_scatt(sft+1:npts)=scattgram(1:npts-sft,ii)
      scattgram(:,ii)=tmp_scatt
   endif

enddo

END SUBROUTINE scoda

!=============================================================================

SUBROUTINE coda(tw,r,t,p,ddt)

use constants; use def_kind; use scattering

implicit none

real(kind=r_single),intent(in)                 :: tw,r
real(kind=r_single),dimension(ncoda),intent(out):: p,t
real(kind=r_single),intent(in)                 :: ddt

!  Program for calculating the scattered wave energy using equation
!  (24) of Zeng et al. (1991).  Written by Yuehua Zeng in May 1990
!  and updated by Yuehua Zeng on Feb. 9, 1993.
!
! Updated: December 2014 (v1.5.5.2)
!    change t(i) computation that "i" in t(i) must be ncoda
!    or less than ncoda.
!
! Updated: December 2016 (v1.6.2)
!    Use aveVp for dt and t(1) computations, instead of using aveVs.
!    Add c4 and ratio for a new coda energy computation.
!------------------------------------------------

! local variables
complex(kind=r_single):: atinv,atinv1,atinv3,akw,wg
complex(kind=r_single):: ei2,aker,Es,Es1,Es2
complex(kind=r_single),dimension(1024):: au

real(kind=r_single):: ep,g,dw,dk,dt,w,ak,sinkr,wi
real(kind=r_single):: c0,c1,c2,c3,gamma,r2,vt,tau
real(kind=r_single):: c4,ratio ! add v162
real(kind=r_single):: pd,di,coef

integer(kind=i_single):: nd,ni,m2,i,nk,ik,j,n1

!	subroutine coda(n,m,gs,gi,vs,tw,r,err,t,p,ddt)
!	dimension t(n),p(n)
!	complex au(1024),atinv,atinv1,atinv3,akw,wg,one,zero,ei,
!     +		ei2,aker,Es,Es1,Es2
!
!  compute parameters
!	pi=3.14159265
!	one=cmplx(1.0,0.0)
!	zero=cmplx(0.0,0.0)

ei2=0.5/zeta
ep=1.0e-20
g=scatcoeff+abscoeff
dw=2.0*pi/tw
nd=2*ifix(0.25*(r+aveVs*tw)/r+1)
dk=pi/(r*float(nd))
ni=ifix(20.0/nd+1)*nd+nd/2
m2=nfcoda/2
dt=(tw-r/aveVp)/float(ncoda)
t(1)=r/aveVp
!dt=(tw-r/(aveVs*sqrt(3.0)))/float(ncoda) ! change v162
!t(1)=r/(aveVs*sqrt(3.0)) ! change v162

do i=2,ncoda
   t(i)=t(i-1)+dt
enddo

! check i in t(i) must be ncoda or less than ncoda (v1552)
i=ifix((r/aveVs-t(1))/dt)+1
!t(i+1)=r/aveVs+ddt
!t(i)=r/aveVs-ddt
if (i .lt. ncoda) then
   t(i+1)=r/aveVs+ddt
   t(i)=r/aveVs-ddt
elseif (i .ge. ncoda) then
   t(ncoda)=r/aveVs+ddt
   t(ncoda-1)=r/aveVs-ddt
endif

!  calculate the power spectrum for scattering order higher than two
call evwi

w=-dw

do i=1,m2
   w=w+dw
   wg=cmplx(g+wi/aveVs,w/aveVs)
   ak=0.0
   Es=zero
   Es1=zero
   Es2=zero
   nk=ni
   ik=0

   do j=1,10000
      ak=ak+dk
      akw=cmplx(0.0,ak)/wg
      atinv=ei2*clog((one+akw)/(one-akw))
      atinv1=scatcoeff*atinv/ak
      atinv3=atinv1*atinv1*atinv1
      aker=atinv3*atinv/(one-atinv1)
      sinkr=sin(ak*r)
      Es=Es+sinkr*aker
      if(cabs(aker/(Es+ep)).lt.merr.and.j.gt.20) goto 25
      if(j.eq.nk)then
         ik=ik+1
         Es2=Es2+Es-sinkr*aker*0.5
         if(ik.eq.6)then
            if(cabs((Es2-Es1)/(Es2+ep)).lt.merr)then
               Es=(Es1+Es2)/12.0
               goto 25
            endif
            ik=0
            Es1=Es2
            Es2=zero
         endif
         nk=nk+nd
      endif
   enddo

25 au(i)=Es*dk

enddo

n1=nfcoda+2

do i=1,m2
   au(n1-i)=conjg(au(i))
enddo

au(m2+1)=zero

call fork(nfcoda,au,1.0)

w=0.0
dw=wi*tw/float(nfcoda-1)

do i=2,nfcoda
   w=w+dw
   au(i)=au(i)*exp(w)
enddo

!  loop for calculating time domain scattering energy decay
dt=tw/float(nfcoda)
 c0=0.25/(aveVs*pi*r*r)
 c1=0.25*scatcoeff/(aveVs*r*pi*c0)
 c2=scatcoeff*scatcoeff/(16.0*r*pi*c0)
 c3=0.5/(aveVs*r*pi*pi*tw*c0)
gamma=2.0/(9.0*sqrt(3.0))
r2=r*r
! add c4 as (Vs/Vp)**4, eta_sp = 0.11*eta_s by Zeng et al., 1995, v162
c4=(aveVs/aveVp)
c4=c4**4
! 19.88 km is a reference distance for a new tau, v162
ratio=7.5*r/19.88

do i=1,ncoda
   vt=aveVs*t(i)
   if(vt.lt.r)then
      !tau=exp(-g*vt) ! original
      !p(i)=gamma*c1*alog((vt+r)/(r-vt))/t(i)*tau ! original
      tau=exp(g*vt)/ratio ! v162
      p(i)=c4*gamma*c1*alog((vt+r)/(r-vt))/t(i)*tau ! v162
      goto 55
   endif
   tau=r/vt

   call ener2(0.01)

   n1=ifix(t(i)/dt)+1
   pd=(real(au(n1))+(real(au(n1+1))-real(au(n1)))  &
      *(t(i)-dt*float(n1-1))/dt)*exp(abscoeff*vt)
   tau=exp(-scatcoeff*vt)
   p(i)=c1*alog((vt+r)/(vt-r))/t(i)*tau+c2*coef*tau+c3*pd
   p(i)=p(i)*exp(-(0.03-abscoeff)*vt)
55 p(i)=sqrt(abs(p(i))) ! avoid negative p(i) in sqrt()

enddo

!..........................................................................

CONTAINS

   SUBROUTINE ener2(dd)
   !  calculate coefficient of the second-order scattered energy term

   implicit none

   real(kind=r_single),intent(in):: dd
   !local
   integer(kind=i_single)        :: n,i
   real(kind=r_single)           :: dt,t,aux

   n=ifix(tau/dd)+1
   dt=tau/float(n)
   coef=0.0
   t=0.0

   do i=1,n
      t=t+dt
      aux=alog((1.0+t)/(1.0-t))
      aux=aux*aux
      coef=coef+aux
   enddo

   coef=3.0*(0.5*aux-coef)*dt
   coef=coef+tau*pi*pi

   END SUBROUTINE ener2
!.....................................................

   SUBROUTINE evwi
   !  estimating the value of imaginery frequency wi

   implicit none

   real(kind=r_single)   :: dd,vt,ud,du,coef,u
   real(kind=r_single)   :: aux,di,dimax
   integer(kind=i_single):: i,m,j

   dd=0.01
   vt=r

   do i=1,2
      vt=vt+(aveVs*tw-r)*(i-1)
      ud=sqrt(0.75*scatcoeff*vt)
      m=ifix(ud/dd)+1
      du=ud/float(m)
      coef=0.5
      u=0.0

      do j=1,m
         u=u+du
         aux=exp(-u*u)
         coef=coef+aux
      enddo

      coef=(coef-0.5*aux)*du-ud*exp(-ud*ud)
      u=0.75*scatcoeff/vt
      aux=(1.-exp(-scatcoeff*vt)*(1.+scatcoeff*vt))/coef
      di=aux*exp(1.5*alog(u/real(pi))-u*r*r-abscoeff*vt)

      if(i.eq.1)then
         dimax=di
      end if

   enddo

   wi=alog(500*di/dimax)/tw

   END SUBROUTINE evwi

END SUBROUTINE coda


      subroutine shortcircuit
c     uninitialzied variables
      logical l
      integer i
      real    r

c     check points
      logical logical1, logical2, logical3, logical4
      integer int1, int2
      real real1, real2, real3, real4, real5, real6

c    logical short circuiting
      logical1 =   l1 .AND. .FALSE.
      logical2 =   .FALSE. .AND. l1
      logical3 =   .TRUE. .OR. l1
      logical4 =   l1 .OR. .TRUE.

c    multiplication short circuiting
      int1 = 0 * i
      int2 = i * 0
      real1 = r * 0.0
      real2 = 0.0 * r

c    exponentiation short circuiting
      real3 = 1 ** i
      real4 = 1.0 ** r
      real5 = r ** 0
      real6 = r ** 0.0

      end


c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine proc_grid

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      implicit none

      include 'mpinpb.h'
      include 'applu.incl'

c---------------------------------------------------------------------
c  local variables
c---------------------------------------------------------------------
      integer xdim0, ydim0, IERROR

c---------------------------------------------------------------------
c
c   set up a two-d grid for processors: column-major ordering of unknowns
c
c---------------------------------------------------------------------

      xdim0  = nnodes_xdim
      ydim0  = nnodes_compiled/xdim0

      ydim   = dsqrt(dble(num))+0.001d0
      xdim   = num/ydim
      do while (ydim .ge. ydim0 .and. xdim*ydim .ne. num)
         ydim = ydim - 1
         xdim = num/ydim
      end do

      if (xdim .lt. xdim0 .or. ydim .lt. ydim0 .or.
     &    xdim*ydim .ne. num) then
         if (id .eq. 0) write(*,2000) num
2000     format(' Error: couldn''t determine proper proc_grid',
     &          ' for nprocs=', i6)
         CALL MPI_ABORT( MPI_COMM_WORLD, MPI_ERR_OTHER, IERROR )
      endif

      if (id .eq. 0 .and. num .ne. 2**ndim)
     &   write(*,2100) num, xdim, ydim
2100  format(' Proc_grid for nprocs =',i6,':',i5,' x',i5)

      row    = mod(id,xdim) + 1
      col    = id/xdim + 1

      return
      end


program designed_to_terminate_normally
  !! Test assertions expected to succeed
  use assert_m, only : assert
  use intrinsic_array_m, only : intrinsic_array_t
  implicit none

  scalar_diagnostic_data: &
  block
    complex, parameter :: z = (1.,1.)
    integer, parameter :: n = 1
    logical, parameter :: bool = .true.
    real, parameter :: x = 1.

    call assert(abs(z)>0, "main: z>0", diagnostic_data = z)
    call assert(n>0, "main: i>0")
    call assert(n>0, "main: n>0", n)
    call assert(x>0., "main: x>0", x)
    call assert(bool, "main: z>0", bool)

  end block scalar_diagnostic_data

  array_diagnostic_data: &
  block
    complex, parameter :: complex_array(*) = [(1.,0.), (0.,1.)]
    integer, parameter :: integer_array(*) = [1, 2]
    logical, parameter :: logical_array(*) = [.true., .true.]
    real, parameter :: real_array(*) = [1., 2.]

    call assert(all(abs(complex_array) < 2.), "main: all(abs(complex_array) < 2.)", intrinsic_array_t(complex_array))
    call assert(all(integer_array < 3), "main: all(int_array < 3)", intrinsic_array_t(integer_array))
    call assert(all(logical_array), "main: all(logical_array)", intrinsic_array_t(logical_array))
    call assert(all(real_array < 3.), "main: all(real_array < 3.)", intrinsic_array_t(real_array))

  end block array_diagnostic_data

  sync all

  if (this_image()==1) print *, "----> All tests designed to terminate normally pass. <----"

end program designed_to_terminate_normally


!==============================================================================!
  subroutine Surf_Mod_Calculate_Nodal_Values(surf, phi)
!------------------------------------------------------------------------------!
!   Calculates nodal values of variable phi                                    !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Work_Mod, only: phi_n => r_node_01,  &  ! value at the (static) grid nodes
                      ncn   => i_node_01      ! number of cells around nodes
!------------------------------------------------------------------------------!
!   Be careful with the above variables from Work_Mod.  They are used by       !
!   two subroutines in Surf_Mod, hence values shouldn't be changed elsewhere.  !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Surf_Type), target :: surf
  type(Var_Type),  target :: phi
!-----------------------------------[Locals]-----------------------------------!
  type(Grid_Type), pointer :: grid
  integer                  :: c, ni, n
  real                     :: xc, yc, zc
!==============================================================================!

  ! Take aliases
  grid => surf % pnt_grid

  !-------------------------------------------------------!
  !   Find number of inside cells surrounding each node   !
  !-------------------------------------------------------!
  do n = 1, grid % n_nodes
    ncn(n) = 0
  end do
  do c = 1, grid % n_cells
    do ni = 1, grid % cells_n_nodes(c)  ! local node number
      n = grid % cells_n(ni, c)         ! global node number

      ! Increase number of cells surrounding the this node by one
      ncn(n) = ncn(n) + 1
    end do
  end do

  !-------------------------------------------------!
  !   Compute values of variable phi on the nodes   !
  !-------------------------------------------------!

  do n = 1, grid % n_nodes
    phi_n(n) = 0.0
  end do

  ! Add them up for all nodes from cells ...
  do c = 1, grid % n_cells ! think about it: - grid % comm % n_buff_cells
    xc = grid % xc(c)
    yc = grid % yc(c)
    zc = grid % zc(c)
    do ni = 1, grid % cells_n_nodes(c)
      n = grid % cells_n(ni, c)
      phi_n(n) = phi_n(n) + phi % n(c)
    end do
  end do

  ! ... and divide by number of cells surrounding each node
  do n = 1, grid % n_nodes
    phi_n(n) = phi_n(n) / ncn(n)
  end do

  end subroutine


c=======================================================================
c
c     subroutine OPMV
c
c     Optimization utility for ALLOCMV - Mean-Variance (Markowitz)
c
c-----------------------------------------------------------------------
      SUBROUTINE opmv ( n, cov, rmean, mu, neq, nin, ccst, bcst,
     &                  cinf, csup,
     &                  iwork, dwork, wopt, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : size of portfolio                          integer
c            cov    : covariance matrix (n*n)                     double
c            rmean  : mean returns vector (n)                     double
c            mu     : performance target                          double
c            neq    : number of initial equality constraints     integer
c            nin    : number of initial inequality constraints   integer
c            ccst   : matrix of constraints (n*(neq + nin))       double
c            bcst   : vector of constraints (neq + nin)           double
c            cinf   : assets inferior limit (n)                   double
c            csup   : assets superior limit (n)                   double
c
c     WORKSPACE
c       iwork  : 3*n+2*nin+neq+6                                 integer
c       dwork  : 2*n*(neq+nin+n+8)+4*neq+6*nin+2*n+15             double
c
c     OUTPUT
c       wopt   : optimal portfolio (n)                            double
c       info   : = 0 successful exit                             integer
c
c     CALL
c       CTMV : Mean-Variance utility function
c       QP   : quadratic solver (vectorized version)
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info, neq, nin
      DOUBLE PRECISION mu
      DOUBLE PRECISION cov(*), rmean(*), cinf(*), csup(*), wopt(*),
     &                 ccst(n,*), bcst(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER neqtot, nintot, piw, pdlin, pdw, pdlagr, pdbcs, pdccs
c
c     external subroutines
      EXTERNAL ctmv, initfeas, qp
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      piw  = 1
c     piw    : pointer for initfeas
c               needs 3*n1 + 2*nin + neq + 1
c               so 3*n+2*nin+neq+6
c     piw  : pointer for QP internal workspace, who needs
c            ( 3*n + 2*nintot + neqtot + 1 )
c             with neqtot = neq
c                  nintot = nin + 1
c
c     Total size of iwork array = ( 3*n + 2*nin + neq + 3 )
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdlin  = 1
c     pdlin  : pointer for linear part vector, so ( n ) more
      pdlagr = pdlin + ( n )
c     pdlagr : pointer for Lagrange multipliers ( n + nin + 1 + neq ) more
      pdbcs  = pdlagr +  ( n + nin + 1 + neq )
c     pdbcs  : pointer for the constraints vector ( nintot + neqtot ),
c              so ( nin + 1 + neq ) more
      pdccs  = pdbcs +  ( nin + 1 + neq )
c     pdccs  : pointer for the constraints matrix
c              n*( nintot + neqtot ),
c           so n*( nin + 1 + neq ) more
      pdw    = pdccs + ( n*( nin + 1 + neq ) )
c     pdw    : pointer for initfeas
c               needs (n+1)*(neq+nin+2*(n+1)+11)+neq+3*nin
c     pdw    : pointer for QP internal workspace who needs
c              (n*n + 6*n + 2*nintot)
c               so pdw needs (n+1)*(neq+nin+2*(n+1)+11)+neq+3*nin
c
c     Total size of dwork array = n
c                               + n + nin + 1 + neq
c                               + nin + 1 + neq
c                               + n*( nin + 1 + neq )
c                               + (n+1)*(neq+nin+2*(n+1)+11)+neq+3*nin
c                               = n*(2*neq+2*nin+2*n+16)+neq+3*nin
c                               + 2*n + 2*nin + 2*neq +2
c                               = 2*n*(neq+nin+n+9)+4*neq+6*nin+2*n+15
c
c      = 2*n*(neq+nin+n+9)+4*neq+6*nin+2*n+15
c
c-----------------------------------------------------------------------
c
c     construction of the constraints matrix and vector, and linear part
      CALL ctmv ( n, rmean, mu, neq, nin, ccst, bcst, neqtot, nintot,
     &            dwork(pdccs), dwork(pdbcs), dwork(pdlin))
c
c     Initialization and feasibility check of the allocation problem
      CALL initfeas ( n, cinf, csup, neqtot, nintot,
     &                dwork(pdccs), dwork(pdbcs),
     &                iwork(piw), dwork(pdw),
     &                wopt, info)
      IF (info .NE. 0) THEN
        info = -100
        RETURN
      ENDIF
c
c     quadratic solver
      CALL qp ( n, cov, dwork(pdlin), neqtot, nintot,
     &          dwork(pdccs), dwork(pdbcs), cinf, csup,
     &          iwork(piw), dwork(pdw), dwork(pdlagr),
     &          wopt, info)
      RETURN
      END


      SUBROUTINE slPLNE (DATE, JFORM, EPOCH, ORBINC, ANODE, PERIH,
     :                       AORQ, E, AORL, DM, PV, JSTAT)
*+
*     - - - - - - -
*      P L N L
*     - - - - - - -
*
*  Heliocentric position and velocity of a planet, asteroid or comet,
*  starting from orbital elements.
*
*  Given:
*     DATE     d     date, Modified Julian Date (JD - 2400000.5, Note 1)
*     JFORM    i     choice of element set (1-3; Note 3)
*     EPOCH    d     epoch of elements (TT MJD, Note 4)
*     ORBINC   d     inclination (radians)
*     ANODE    d     longitude of the ascending node (radians)
*     PERIH    d     longitude or argument of perihelion (radians)
*     AORQ     d     mean distance or perihelion distance (AU)
*     E        d     eccentricity
*     AORL     d     mean anomaly or longitude (radians, JFORM=1,2 only)
*     DM       d     daily motion (radians, JFORM=1 only)
*
*  Returned:
*     PV       d(6)  heliocentric x,y,z,xdot,ydot,zdot of date,
*                                     J2000 equatorial triad (AU,AU/s)
*     JSTAT    i     status:  0 = OK
*                            -1 = illegal JFORM
*                            -2 = illegal E
*                            -3 = illegal AORQ
*                            -4 = illegal DM
*                            -5 = numerical error
*
*  Called:  slELUE, slUEPV
*
*  Notes
*
*  1  DATE is the instant for which the prediction is required.  It is
*     in the TT timescale (formerly Ephemeris Time, ET) and is a
*     Modified Julian Date (JD-2400000.5).
*
*  2  The elements are with respect to the J2000 ecliptic and equinox.
*
*  3  A choice of three different element-set options is available:
*
*     Option JFORM = 1, suitable for the major planets:
*
*       EPOCH  = epoch of elements (TT MJD)
*       ORBINC = inclination i (radians)
*       ANODE  = longitude of the ascending node, big omega (radians)
*       PERIH  = longitude of perihelion, curly pi (radians)
*       AORQ   = mean distance, a (AU)
*       E      = eccentricity, e (range 0 to <1)
*       AORL   = mean longitude L (radians)
*       DM     = daily motion (radians)
*
*     Option JFORM = 2, suitable for minor planets:
*
*       EPOCH  = epoch of elements (TT MJD)
*       ORBINC = inclination i (radians)
*       ANODE  = longitude of the ascending node, big omega (radians)
*       PERIH  = argument of perihelion, little omega (radians)
*       AORQ   = mean distance, a (AU)
*       E      = eccentricity, e (range 0 to <1)
*       AORL   = mean anomaly M (radians)
*
*     Option JFORM = 3, suitable for comets:
*
*       EPOCH  = epoch of elements and perihelion (TT MJD)
*       ORBINC = inclination i (radians)
*       ANODE  = longitude of the ascending node, big omega (radians)
*       PERIH  = argument of perihelion, little omega (radians)
*       AORQ   = perihelion distance, q (AU)
*       E      = eccentricity, e (range 0 to 10)
*
*     Unused arguments (DM for JFORM=2, AORL and DM for JFORM=3) are not
*     accessed.
*
*  4  Each of the three element sets defines an unperturbed heliocentric
*     orbit.  For a given epoch of observation, the position of the body
*     in its orbit can be predicted from these elements, which are
*     called "osculating elements", using standard two-body analytical
*     solutions.  However, due to planetary perturbations, a given set
*     of osculating elements remains usable for only as long as the
*     unperturbed orbit that it describes is an adequate approximation
*     to reality.  Attached to such a set of elements is a date called
*     the "osculating epoch", at which the elements are, momentarily,
*     a perfect representation of the instantaneous position and
*     velocity of the body.
*
*     Therefore, for any given problem there are up to three different
*     epochs in play, and it is vital to distinguish clearly between
*     them:
*
*     . The epoch of observation:  the moment in time for which the
*       position of the body is to be predicted.
*
*     . The epoch defining the position of the body:  the moment in time
*       at which, in the absence of purturbations, the specified
*       position (mean longitude, mean anomaly, or perihelion) is
*       reached.
*
*     . The osculating epoch:  the moment in time at which the given
*       elements are correct.
*
*     For the major-planet and minor-planet cases it is usual to make
*     the epoch that defines the position of the body the same as the
*     epoch of osculation.  Thus, only two different epochs are
*     involved:  the epoch of the elements and the epoch of observation.
*
*     For comets, the epoch of perihelion fixes the position in the
*     orbit and in general a different epoch of osculation will be
*     chosen.  Thus, all three types of epoch are involved.
*
*     For the present routine:
*
*     . The epoch of observation is the argument DATE.
*
*     . The epoch defining the position of the body is the argument
*       EPOCH.
*
*     . The osculating epoch is not used and is assumed to be close
*       enough to the epoch of observation to deliver adequate accuracy.
*       If not, a preliminary call to slPRTL may be used to update
*       the element-set (and its associated osculating epoch) by
*       applying planetary perturbations.
*
*  5  The reference frame for the result is with respect to the mean
*     equator and equinox of epoch J2000.
*
*  6  The algorithm was originally adapted from the EPHSLA program of
*     D.H.P.Jones (private communication, 1996).  The method is based
*     on Stumpff's Universal Variables.
*
*  Reference:  Everhart, E. & Pitkin, E.T., Am.J.Phys. 51, 712, 1983.
*
*  P.T.Wallace   Starlink   31 December 2002
*
*  Copyright (C) 2002 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION DATE
      INTEGER JFORM
      DOUBLE PRECISION EPOCH,ORBINC,ANODE,PERIH,AORQ,E,AORL,DM,PV(6)
      INTEGER JSTAT

      DOUBLE PRECISION U(13)
      INTEGER J

*  Validate elements and convert to "universal variables" parameters.
      CALL slELUE(DATE,JFORM,
     :               EPOCH,ORBINC,ANODE,PERIH,AORQ,E,AORL,DM,U,J)

*  Determine the position and velocity.
      IF (J.EQ.0) THEN
         CALL slUEPV(DATE,U,PV,J)
         IF (J.NE.0) J=-5
      END IF

*  Wrap up.
      JSTAT = J

      END


!
! Copyright (c) 2006-2007      University of Houston. All rights reserved.
! $COPYRIGHT$
!
! Additional copyrights may follow
!
! $HEADER$
!
        subroutine System_Set ( ierror )

!...Diskretisieren der Gleichung, belegen der Matrix und der
!   rechten Seite. Dieses File diskretisiert eine Konvektions-Diffusions-Gleichung,
!   wobei ein Einheitsquader in n1g,n2g,n3g Punkte
!   unterteilt wird. Diskretisiert wird mit einer Zentralen-Differenz.

        USE globale_daten
        USE matrix
        USE rechte_seite
        USE numerik_daten

        implicit none

        integer :: ierror
        integer :: i, j, k

        double precision :: hauptdiag, xdiag_1, xdiag_2, ydiag, zdiag

        set_text = ' Set: Beispiel 2 '
!...Berechnen des Abstandes zwischen zwei Punkten bei der
!   Diskretisierung

        deltax = 1/(n1g - 1.0 )
        deltay = 1/(n2g - 1.0 )
        deltaz = 1/(n3g - 1.0 )

        deltaquadx = deltax * deltax
        deltaquady = deltay * deltay
        deltaquadz = deltaz * deltaz

        hauptdiag = (1.0/deltaquadx + 1.0/deltaquady + 1.0/deltaquadz)*2.0
        xdiag_1   = -(1.0/deltaquadx + 1000.0/(2.0*deltax) )
        xdiag_2   = -(1.0/deltaquadx - 1000.0/(2.0*deltax) )
        ydiag = -1.0/deltaquady
        zdiag = -1.0/deltaquadz

!...Kurze Darstellung der Gleichung:
!   - d^2 u / dx^2 - d^2 u / dy^2 - d^u / dz^2 + 1000 * du/dx = rhs
!
!   Aus der Zentralen Differenz folgt, dass auf der Hauptdiagonalen
!   immer 6/deltaquad steht, und auf den Nebendiagonalen -1/deltaquad,

        do k = dmku, dmko
           do j = dmju, dmjo
              do i = dmiu, dmio
                 rm000(i, j, k, 1, 1 ) = hauptdiag
                 rmb00(i, j, k, 1, 1 ) = xdiag_1
                 rmf00(i, j, k, 1, 1 ) = xdiag_2
                 rm0b0(i, j, k, 1, 1 ) = ydiag
                 rm0f0(i, j, k, 1, 1 ) = ydiag
                 rm00b(i, j, k, 1, 1 ) = zdiag
                 rm00f(i, j, k, 1, 1 ) = zdiag
              end do
           end do
        end do

!...Korriegieren der Raender

        if ( rand_sing ) then
           do k = dmku, dmko
              do j = dmju, dmjo
                 rm000 ( dmiu, j, k, 1, 1 ) = 1.0
                 rmb00 ( dmiu, j, k, 1, 1 ) = 0.0
                 rmf00 ( dmiu, j, k, 1, 1 ) = 0.0
                 rm0b0 ( dmiu, j, k, 1, 1 ) = 0.0
                 rm0f0 ( dmiu, j, k, 1, 1 ) = 0.0
                 rm00b ( dmiu, j, k, 1, 1 ) = 0.0
                 rm00f ( dmiu, j, k, 1, 1 ) = 0.0
              end do
           end do
        end if

        if ( rand_ab ) then
           do k = dmku, dmko
              do j = dmju, dmjo
                 rm000 ( dmio, j, k, 1, 1 ) = 1.0
                 rmb00 ( dmio, j, k, 1, 1 ) = 0.0
                 rmf00 ( dmio, j, k, 1, 1 ) = 0.0
                 rm0b0 ( dmio, j, k, 1, 1 ) = 0.0
                 rm0f0 ( dmio, j, k, 1, 1 ) = 0.0
                 rm00b ( dmio, j, k, 1, 1 ) = 0.0
                 rm00f ( dmio, j, k, 1, 1 ) = 0.0
              end do
           end do
        end if

        if ( rand_festk ) then
           do k = dmku, dmko
              do i = dmiu, dmio
                 rm000 ( i, dmju, k, 1, 1 ) = 1.0
                 rmb00 ( i, dmju, k, 1, 1 ) = 0.0
                 rmf00 ( i, dmju, k, 1, 1 ) = 0.0
                 rm0b0 ( i, dmju, k, 1, 1 ) = 0.0
                 rm0f0 ( i, dmju, k, 1, 1 ) = 0.0
                 rm00b ( i, dmju, k, 1, 1 ) = 0.0
                 rm00f ( i, dmju, k, 1, 1 ) = 0.0
              end do
           end do
        end if

        if ( rand_zu ) then
           do k = dmku, dmko
              do i = dmiu, dmio
                 rm000 ( i, dmjo, k, 1, 1 ) = 1.0
                 rmb00 ( i, dmjo, k, 1, 1 ) = 0.0
                 rmf00 ( i, dmjo, k, 1, 1 ) = 0.0
                 rm0b0 ( i, dmjo, k, 1, 1 ) = 0.0
                 rm0f0 ( i, dmjo, k, 1, 1 ) = 0.0
                 rm00b ( i, dmjo, k, 1, 1 ) = 0.0
                 rm00f ( i, dmjo, k, 1, 1 ) = 0.0
              end do
           end do
        end if

        if ( rand_symu ) then
           do j = dmju, dmjo
              do i = dmiu, dmio
                 rm000 ( i, j, dmku, 1, 1 ) = 1.0
                 rmb00 ( i, j, dmku, 1, 1 ) = 0.0
                 rmf00 ( i, j, dmku, 1, 1 ) = 0.0
                 rm0b0 ( i, j, dmku, 1, 1 ) = 0.0
                 rm0f0 ( i, j, dmku, 1, 1 ) = 0.0
                 rm00b ( i, j, dmku, 1, 1 ) = 0.0
                 rm00f ( i, j, dmku, 1, 1 ) = 0.0
              end do
           end do
        end if

        if ( rand_symo ) then
           do j = dmju, dmjo
              do i = dmiu, dmio
                 rm000 ( i, j, dmko, 1, 1 ) = 1.0
                 rmb00 ( i, j, dmko, 1, 1 ) = 0.0
                 rmf00 ( i, j, dmko, 1, 1 ) = 0.0
                 rm0b0 ( i, j, dmko, 1, 1 ) = 0.0
                 rm0f0 ( i, j, dmko, 1, 1 ) = 0.0
                 rm00b ( i, j, dmko, 1, 1 ) = 0.0
                 rm00f ( i, j, dmko, 1, 1 ) = 0.0
              end do
           end do
        end if

!...Setzen der rechten Seite

        call System_Set_rhs ( ierror )

        ierror = 0

        return
      end subroutine System_Set

!***********************************************************************
!***********************************************************************
!***********************************************************************
!***********************************************************************
!***********************************************************************

        subroutine System_Set_rhs ( ierror )

!...Setzen der rechten Seite so, dass man die zum Schluss die
!   erwuenschte Loesung kennt.

          USE globale_daten
          USE matrix
          USE rechte_seite
          USE loesung
          USE constants

          implicit none
          include 'mpif.h'

          integer :: ierror, dummy, i, j, k
          integer :: size, rank
          integer, dimension(3) :: coords
          double precision, parameter :: my_pi = 3.1415926535897932384
          double precision :: x, y, z, xoffset, yoffset, zoffset
          double precision :: skalar_1, skalar_2, skalar_3

          call MPI_Comm_rank ( MPI_COMM_WORLD, rank, ierror )
          call MPI_Comm_size ( MPI_COMM_WORLD, size, ierror )

!...Die korrekte Loesung ist in diesem Fall bekannt:

          loesung_bekannt = .true.

!...Bestimmen der eigenen Position im globalen Feld:
          call MPI_Cart_coords ( cart_comm, rank, 3, coords, ierror )

          xoffset = coords(1) * n1
          yoffset = coords(2) * n2
          zoffset = coords(3) * n3

!...Die Loesung soll spaeter folgender Funktion entsprechen
!   u(x, y, z ) = exp (xyz) * sin (pi*x) * sin(pi*y) * sin(pi*z)

          do k = dmku, dmko
             z = ( zoffset + k - 1) * deltaz
             if ( z.gt.1.0) then
                z = 1.0
             end if
             do j = dmju, dmjo
                y = ( yoffset + j - 1) * deltay
                if ( y.gt.1.0) then
                   y = 1.0
                end if
                do i = dmiu, dmio
                   x = ( xoffset + i - 1) * deltax
                   if ( x.gt.1.0) then
                      x = 1.0
                   end if
                   loes (i, j, k, 1 ) = dexp (x*y*z) * &
                        dsin (my_pi*x) * dsin(my_pi*y) * &
                        dsin (my_pi*z)
                end do
             end do
          end do
18        format (3i3, 2x, f12.5)

          call System_Matmul ( adcl_req_loes, loes, rhs, ierror )

!...Korriegieren der Raender

        if ( rand_sing ) then
           do k = dmku, dmko
              do j = dmju, dmjo
                 rhs ( dmiu, j, k, 1 ) = 0.0
                 loes ( dmiu, j, k, 1 ) = 0.0
              end do
           end do
        end if

        if ( rand_ab ) then
           do k = dmku, dmko
              do j = dmju, dmjo
                 rhs ( dmio, j, k, 1 ) = 0.0
                 loes ( dmio, j, k, 1 ) = 0.0
              end do
           end do
        end if

        if ( rand_festk ) then
           do k = dmku, dmko
              do i = dmiu, dmio
                 rhs ( i, dmju, k, 1 ) = 0.0
                 loes ( i, dmju, k, 1 ) = 0.0
              end do
           end do
        end if

        if ( rand_zu ) then
           do k = dmku, dmko
              do i = dmiu, dmio
                 rhs ( i, dmjo, k, 1 ) = 0.0
                 loes ( i, dmjo, k, 1 ) = 0.0
              end do
           end do
        end if

        if ( rand_symu ) then
           do j = dmju, dmjo
              do i = dmiu, dmio
                 rhs  ( i, j, dmku, 1 ) = 0.0
                 loes ( i, j, dmku, 1 ) = 0.0
              end do
           end do
        end if

        if ( rand_symo ) then
           do j = dmju, dmjo
              do i = dmiu, dmio
                 rhs  ( i, j, dmko, 1 ) = 0.0
                 loes ( i, j, dmko, 1 ) = 0.0
              end do
           end do
        end if

        ierror = 0

        return
        end subroutine System_Set_rhs


       subroutine tillfactor(jj,bmix,emix,dtil,sol_thick)
	!!!!!!!!!!!!!!!!!!!!!!!
	! Armen 16 January 2008
	! This procedure increases tillage factor (tillagef(l,jj) per layer for each operation
	! The tillage factor settling will depend of soil moisture (tentatively) and must be called every day
	! For simplicity the settling is calculated now at the soil carbon sub because soil water content is available

	! The tillage factor depends on the cumulative soil disturbance rating = csdr
	! For simplicity, csdr is a function of emix
	! First step is to calculate "current" csdr by inverting tillage factor function
	! The effect of texture on tillage factor (ZZ) is removed first (and recovered at the end of the procedure)
	! YY = tillagef(l,jj) / ZZ
	! Since the tillage factor function is non linear, iterations are needed
	! XX = 0.5 is the initial value that works OK for the range of values observed
	! If a layer is only partially tilled then emix is corrected accordingly
      use parm

	integer, intent (in) :: jj
      real, intent (in) :: bmix
      integer :: l, m1, m2
      real :: emix, dtil
	real :: sol_thick(sol_nly(jj))

	emix = emix - bmix ! this is to avoid affecting tillage factor with biological mixing

	if (emix > 0.) then

	  do l=1, sol_nly(jj)

	    if (sol_z(l,jj) <= dtil) then
		emix = emix
	    else if (sol_z(l,jj) > dtil .AND. sol_z(l-1,jj) < dtil) then
		emix = emix * (dtil - sol_z(l-1,jj)) / sol_thick(l)
	    else
		emix = 0.
	    end if

	    ! to save computation time if emix = 0 here then the other layers can be avoided
	    ! tillage always proceeds from top to bottom
	    if (emix == 0.) exit

	    xx = 0.
	    zz = 3. + (8. - 3.) * exp(-5.5 * sol_clay(l,jj)/100.)
	    yy = tillagef(l,jj) / zz
	    m1 = 1
	    m2 = 2

	    ! empirical solution for x when y is known and y=x/(x+exp(m1-m2*x))
	    if (yy > 0.01) then
		 xx1 = yy ** exp(-0.13 + 1.06 * yy)
		 xx2 = exp(0.64 + 0.64 * yy ** 100.)
		 xx = xx1 * xx2
	    end if

	    csdr = xx + emix
	    tillagef(l,jj) = zz * (csdr / (csdr + exp(m1 - m2 * csdr)))

	  end do

	end if

	return
	end subroutine


c---------------------------------------------------------------------
c---------------------------------------------------------------------

       subroutine x_solve

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c this function performs the solution of the approximate factorization
c step in the x-direction for all five matrix components
c simultaneously. The Thomas algorithm is employed to solve the
c systems for the x-lines. Boundary conditions are non-periodic
c---------------------------------------------------------------------

       include 'header.h'

       integer i, j, k, n, i1, i2, m
       double precision  ru1, fac1, fac2

c---------------------------------------------------------------------
c---------------------------------------------------------------------

       if (timeron) call timer_start(t_xsolve)
!hpf$ independent, new(ru1,cv,rhon,fac1,fac2,lhs,lhsp,lhsm)
       do  k = 1, nz2
          do  j = 1, ny2

c---------------------------------------------------------------------
c Computes the left hand side for the three x-factors
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c      first fill the lhs for the u-eigenvalue
c---------------------------------------------------------------------
             do  i = 0, grid_points(1)-1
                ru1 = c3c4*rho_i(i,j,k)
                cv(i) = us(i,j,k)
                rhon(i) = dmax1(dx2+con43*ru1,
     >                          dx5+c1c5*ru1,
     >                          dxmax+ru1,
     >                          dx1)
             end do

        do i = 0, grid_points(1)-1, grid_points(1)-1
          do   n = 1, 5
             lhs (n,i) = 0.0d0
             lhsp(n,i) = 0.0d0
             lhsm(n,i) = 0.0d0
          end do
          lhs (3,i) = 1.0d0
          lhsp(3,i) = 1.0d0
          lhsm(3,i) = 1.0d0
        end do
             do  i = 1, nx2
                lhs(1,i) =   0.0d0
                lhs(2,i) = - dttx2 * cv(i-1) - dttx1 * rhon(i-1)
                lhs(3,i) =   1.0d0 + c2dttx1 * rhon(i)
                lhs(4,i) =   dttx2 * cv(i+1) - dttx1 * rhon(i+1)
                lhs(5,i) =   0.0d0
             end do

c---------------------------------------------------------------------
c      add fourth order dissipation
c---------------------------------------------------------------------

             i = 1
             lhs(3,i) = lhs(3,i) + comz5
             lhs(4,i) = lhs(4,i) - comz4
             lhs(5,i) = lhs(5,i) + comz1

             lhs(2,i+1) = lhs(2,i+1) - comz4
             lhs(3,i+1) = lhs(3,i+1) + comz6
             lhs(4,i+1) = lhs(4,i+1) - comz4
             lhs(5,i+1) = lhs(5,i+1) + comz1

             do   i=3, grid_points(1)-4
                lhs(1,i) = lhs(1,i) + comz1
                lhs(2,i) = lhs(2,i) - comz4
                lhs(3,i) = lhs(3,i) + comz6
                lhs(4,i) = lhs(4,i) - comz4
                lhs(5,i) = lhs(5,i) + comz1
             end do

             i = grid_points(1)-3
             lhs(1,i) = lhs(1,i) + comz1
             lhs(2,i) = lhs(2,i) - comz4
             lhs(3,i) = lhs(3,i) + comz6
             lhs(4,i) = lhs(4,i) - comz4

             lhs(1,i+1) = lhs(1,i+1) + comz1
             lhs(2,i+1) = lhs(2,i+1) - comz4
             lhs(3,i+1) = lhs(3,i+1) + comz5

c---------------------------------------------------------------------
c      subsequently, fill the other factors (u+c), (u-c) by adding to
c      the first
c---------------------------------------------------------------------
             do   i = 1, nx2
                lhsp(1,i) = lhs(1,i)
                lhsp(2,i) = lhs(2,i) -
     >                            dttx2 * speed(i-1,j,k)
                lhsp(3,i) = lhs(3,i)
                lhsp(4,i) = lhs(4,i) +
     >                            dttx2 * speed(i+1,j,k)
                lhsp(5,i) = lhs(5,i)
                lhsm(1,i) = lhs(1,i)
                lhsm(2,i) = lhs(2,i) +
     >                            dttx2 * speed(i-1,j,k)
                lhsm(3,i) = lhs(3,i)
                lhsm(4,i) = lhs(4,i) -
     >                            dttx2 * speed(i+1,j,k)
                lhsm(5,i) = lhs(5,i)
             end do

c---------------------------------------------------------------------
c                          FORWARD ELIMINATION
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c      perform the Thomas algorithm; first, FORWARD ELIMINATION
c---------------------------------------------------------------------

             do    i = 0, grid_points(1)-3
                i1 = i  + 1
                i2 = i  + 2
                fac1      = 1.d0/lhs(3,i)
                lhs(4,i)  = fac1*lhs(4,i)
                lhs(5,i)  = fac1*lhs(5,i)
                do    m = 1, 3
                   rhs(m,i,j,k) = fac1*rhs(m,i,j,k)
                end do
                lhs(3,i1) = lhs(3,i1) -
     >                         lhs(2,i1)*lhs(4,i)
                lhs(4,i1) = lhs(4,i1) -
     >                         lhs(2,i1)*lhs(5,i)
                do    m = 1, 3
                   rhs(m,i1,j,k) = rhs(m,i1,j,k) -
     >                         lhs(2,i1)*rhs(m,i,j,k)
                end do
                lhs(2,i2) = lhs(2,i2) -
     >                         lhs(1,i2)*lhs(4,i)
                lhs(3,i2) = lhs(3,i2) -
     >                         lhs(1,i2)*lhs(5,i)
                do    m = 1, 3
                   rhs(m,i2,j,k) = rhs(m,i2,j,k) -
     >                         lhs(1,i2)*rhs(m,i,j,k)
                end do
             end do

c---------------------------------------------------------------------
c      The last two rows in this grid block are a bit different,
c      since they do not have two more rows available for the
c      elimination of off-diagonal entries
c---------------------------------------------------------------------

             i  = grid_points(1)-2
             i1 = grid_points(1)-1
             fac1      = 1.d0/lhs(3,i)
             lhs(4,i)  = fac1*lhs(4,i)
             lhs(5,i)  = fac1*lhs(5,i)
             do    m = 1, 3
                rhs(m,i,j,k) = fac1*rhs(m,i,j,k)
             end do
             lhs(3,i1) = lhs(3,i1) -
     >                      lhs(2,i1)*lhs(4,i)
             lhs(4,i1) = lhs(4,i1) -
     >                      lhs(2,i1)*lhs(5,i)
             do    m = 1, 3
                rhs(m,i1,j,k) = rhs(m,i1,j,k) -
     >                      lhs(2,i1)*rhs(m,i,j,k)
             end do
c---------------------------------------------------------------------
c            scale the last row immediately
c---------------------------------------------------------------------
             fac2             = 1.d0/lhs(3,i1)
             do    m = 1, 3
                rhs(m,i1,j,k) = fac2*rhs(m,i1,j,k)
             end do

c---------------------------------------------------------------------
c      do the u+c and the u-c factors
c---------------------------------------------------------------------

             do    i = 0, grid_points(1)-3
                i1 = i  + 1
                i2 = i  + 2
		m = 4
                fac1       = 1.d0/lhsp(3,i)
                lhsp(4,i)  = fac1*lhsp(4,i)
                lhsp(5,i)  = fac1*lhsp(5,i)
                rhs(m,i,j,k) = fac1*rhs(m,i,j,k)
                lhsp(3,i1) = lhsp(3,i1) -
     >                        lhsp(2,i1)*lhsp(4,i)
                lhsp(4,i1) = lhsp(4,i1) -
     >                        lhsp(2,i1)*lhsp(5,i)
                rhs(m,i1,j,k) = rhs(m,i1,j,k) -
     >                        lhsp(2,i1)*rhs(m,i,j,k)
                lhsp(2,i2) = lhsp(2,i2) -
     >                        lhsp(1,i2)*lhsp(4,i)
                lhsp(3,i2) = lhsp(3,i2) -
     >                        lhsp(1,i2)*lhsp(5,i)
                rhs(m,i2,j,k) = rhs(m,i2,j,k) -
     >                        lhsp(1,i2)*rhs(m,i,j,k)
		m = 5
                fac1       = 1.d0/lhsm(3,i)
                lhsm(4,i)  = fac1*lhsm(4,i)
                lhsm(5,i)  = fac1*lhsm(5,i)
                rhs(m,i,j,k) = fac1*rhs(m,i,j,k)
                lhsm(3,i1) = lhsm(3,i1) -
     >                        lhsm(2,i1)*lhsm(4,i)
                lhsm(4,i1) = lhsm(4,i1) -
     >                        lhsm(2,i1)*lhsm(5,i)
                rhs(m,i1,j,k) = rhs(m,i1,j,k) -
     >                        lhsm(2,i1)*rhs(m,i,j,k)
                lhsm(2,i2) = lhsm(2,i2) -
     >                        lhsm(1,i2)*lhsm(4,i)
                lhsm(3,i2) = lhsm(3,i2) -
     >                        lhsm(1,i2)*lhsm(5,i)
                rhs(m,i2,j,k) = rhs(m,i2,j,k) -
     >                        lhsm(1,i2)*rhs(m,i,j,k)
             end do

c---------------------------------------------------------------------
c         And again the last two rows separately
c---------------------------------------------------------------------
             i  = grid_points(1)-2
             i1 = grid_points(1)-1
	     m = 4
             fac1       = 1.d0/lhsp(3,i)
             lhsp(4,i)  = fac1*lhsp(4,i)
             lhsp(5,i)  = fac1*lhsp(5,i)
             rhs(m,i,j,k) = fac1*rhs(m,i,j,k)
             lhsp(3,i1) = lhsp(3,i1) -
     >                      lhsp(2,i1)*lhsp(4,i)
             lhsp(4,i1) = lhsp(4,i1) -
     >                      lhsp(2,i1)*lhsp(5,i)
             rhs(m,i1,j,k) = rhs(m,i1,j,k) -
     >                      lhsp(2,i1)*rhs(m,i,j,k)
	     m = 5
             fac1       = 1.d0/lhsm(3,i)
             lhsm(4,i)  = fac1*lhsm(4,i)
             lhsm(5,i)  = fac1*lhsm(5,i)
             rhs(m,i,j,k) = fac1*rhs(m,i,j,k)
             lhsm(3,i1) = lhsm(3,i1) -
     >                      lhsm(2,i1)*lhsm(4,i)
             lhsm(4,i1) = lhsm(4,i1) -
     >                      lhsm(2,i1)*lhsm(5,i)
             rhs(m,i1,j,k) = rhs(m,i1,j,k) -
     >                      lhsm(2,i1)*rhs(m,i,j,k)
c---------------------------------------------------------------------
c               Scale the last row immediately
c---------------------------------------------------------------------
             rhs(4,i1,j,k) = rhs(4,i1,j,k)/lhsp(3,i1)
             rhs(5,i1,j,k) = rhs(5,i1,j,k)/lhsm(3,i1)

c---------------------------------------------------------------------
c                         BACKSUBSTITUTION
c---------------------------------------------------------------------

             i  = grid_points(1)-2
             i1 = grid_points(1)-1
             do   m = 1, 3
                rhs(m,i,j,k) = rhs(m,i,j,k) -
     >                             lhs(4,i)*rhs(m,i1,j,k)
             end do

             rhs(4,i,j,k) = rhs(4,i,j,k) -
     >                          lhsp(4,i)*rhs(4,i1,j,k)
             rhs(5,i,j,k) = rhs(5,i,j,k) -
     >                          lhsm(4,i)*rhs(5,i1,j,k)

c---------------------------------------------------------------------
c      The first three factors
c---------------------------------------------------------------------
             do    i = grid_points(1)-3, 0, -1
                i1 = i  + 1
                i2 = i  + 2
                do   m = 1, 3
                   rhs(m,i,j,k) = rhs(m,i,j,k) -
     >                          lhs(4,i)*rhs(m,i1,j,k) -
     >                          lhs(5,i)*rhs(m,i2,j,k)
                end do

c---------------------------------------------------------------------
c      And the remaining two
c---------------------------------------------------------------------
                rhs(4,i,j,k) = rhs(4,i,j,k) -
     >                          lhsp(4,i)*rhs(4,i1,j,k) -
     >                          lhsp(5,i)*rhs(4,i2,j,k)
                rhs(5,i,j,k) = rhs(5,i,j,k) -
     >                          lhsm(4,i)*rhs(5,i1,j,k) -
     >                          lhsm(5,i)*rhs(5,i2,j,k)
             end do
          end do
       end do
       if (timeron) call timer_stop(t_xsolve)

c---------------------------------------------------------------------
c      Do the block-diagonal inversion
c---------------------------------------------------------------------
       if (timeron) call timer_start(t_ninvr)
       call ninvr
       if (timeron) call timer_stop(t_ninvr)

       return
       end


      double complex function F42mhF(psq,qsq,s,t)
      implicit none
c      include 'scale.f'
c      include 'epinv.f'
      double precision s,t,psq,qsq
c      double precision den
c      double complex qlI4,qlI3
      double complex Lsm1_2mht
c      integer ep

c      den=s*t
c--- note: added a factor of 1/2 here
c      F42mhF=
c     . +den*qlI4(0d0,0d0,psq,qsq,s,t,0d0,0d0,0d0,0d0,musq,0)/2d0
c     . -  s*qlI3(0d0,0d0,s,0d0,0d0,0d0,musq,0)/2d0
c     . -  t*qlI3(0d0,0d0,t,0d0,0d0,0d0,musq,0)
c     . +psq*qlI3(0d0,0d0,psq,0d0,0d0,0d0,musq,0)/2d0
c     . +qsq*qlI3(0d0,0d0,qsq,0d0,0d0,0d0,musq,0)/2d0

c--- NOTE: checked on 8/30/09 that Lsm1_2mht == (expression above)
      F42mhF=Lsm1_2mht(s,t,psq,qsq)

      return
      end


subroutine trid2(lundia    ,s1        ,kcs       ,mmax      ,nmax      , &
               & nmmax     ,icx       ,icy       ,j         ,nmmaxj    , &
               & a         ,b         ,c         ,d         ,e         , &
               & f         ,c2        ,d2        ,gdp       )
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This program is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation version 3.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: trid2.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/engines_gpl/flow2d3d/packages/kernel/src/compute/trid2.f90 $
!!--description-----------------------------------------------------------------
!
!    Function: TRID2 solves tridiagonal systems of equations
!              for whole computational area.
! Method used: Thomas algorithm
!
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
    use precision
    use globaldata
    !
    implicit none
    !
    type(globdat),target :: gdp
    !
    ! The following list of pointer parameters is used to point inside the gdp structure
    !
!
! Global variables
!
    integer                                   , intent(in)  :: icx    !!  Increment in the X-dir., if ICX= NMAX
                                                                      !!  then computation proceeds in the X-
                                                                      !!  dir. If icx=1 then computation pro-
                                                                      !!  ceeds in the Y-dir.
    integer                                   , intent(in)  :: icy    !!  Increment in the Y-dir. (see ICX)
    integer                                   , intent(in)  :: j      !!  Begin pointer for arrays which have
                                                                      !!  been transformed into 1D arrays.
                                                                      !!  Due to the shift in the 2nd (M-)
                                                                      !!  index, J = -2*NMAX + 1
    integer                                                 :: lundia !  Description and declaration in inout.igs
    integer                                   , intent(in)  :: mmax   !  Description and declaration in esm_alloc_int.f90
    integer                                   , intent(in)  :: nmax   !  Description and declaration in esm_alloc_int.f90
    integer                                   , intent(in)  :: nmmax  !  Description and declaration in dimens.igs
    integer                                   , intent(in)  :: nmmaxj !  Description and declaration in dimens.igs
    integer , dimension(gdp%d%nmlb:gdp%d%nmub)              :: kcs    !  Description and declaration in esm_alloc_int.f90
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub), intent(in)  :: a
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub), intent(in)  :: b
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub), intent(in)  :: c      !  Description and declaration in esm_alloc_real.f90
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub), intent(in)  :: d
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub), intent(in)  :: e
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub), intent(in)  :: f
    real(fp), dimension(gdp%d%nmlb:gdp%d%nmub)              :: s1     !  Description and declaration in esm_alloc_real.f90
    real(fp), dimension(j:nmmaxj)                           :: c2
    real(fp), dimension(j:nmmaxj)                           :: d2
!
! Local variables
!
    integer  :: icxy
    integer  :: m
    integer  :: mmaxddb
    integer  :: n
    integer  :: nm
    integer  :: nmaxddb
    integer  :: nmf
    integer  :: nmlu
    real(fp) :: bi
!
!! executable statements -------------------------------------------------------
!
    ! INITIALISATION
    !
    nmaxddb = nmax + 2*gdp%d%ddbound
    mmaxddb = mmax + 2*gdp%d%ddbound
    icxy    = max(icx, icy)
    !
    ! EXPLICIT PART
    !
    do nm = 1, nmmax
       d2(nm) = d(nm) - e(nm)*s1(nm - icy) - f(nm)*s1(nm + icy)
    enddo
    !
    !
    ! SOLUTION TRIDIAGONAL SYSTEM FOR THE WATERLEVELS
    !
    ! DOUBLE SWEEP RECURSION
    !
    nmf = icx - icxy
    do n = 1, nmaxddb
       nmf     = nmf + icy
       bi      = 1./b(nmf)
       c2(nmf) = c(nmf)*bi
       d2(nmf) = d2(nmf)*bi
    enddo
    do m = 2, mmaxddb
       nm = m*icx - icxy
       do n = 1, nmaxddb
          nm     = nm + icy
          bi     = 1./(b(nm) - a(nm)*c2(nm - icx))
          c2(nm) = c2(nm)*bi
          d2(nm) = (d2(nm) - a(nm)*d2(nm - icx))*bi
       enddo
    enddo
    !
    ! BACK SWEEP  c
    !
    nmlu = mmaxddb*icx - icxy
    do n = 1, nmaxddb
       nmlu     = nmlu + icy
       s1(nmlu) = d2(nmlu)
    enddo
    do m = mmaxddb - 1, 1, -1
       nm = m*icx - icxy
       do n = 1, nmaxddb
          nm     = nm + icy
          d2(nm) = d2(nm) - c2(nm)*d2(nm + icx)
          s1(nm) = d2(nm)
       enddo
    enddo
end subroutine trid2


!============================================================================
      SUBROUTINE grid_construction_TPM()
!============================================================================
! Region two-phase (TP)
!
! The specific internal energy along from critical point to triple
! point. The region is bounded by the saturation line LH and the triple
! pressure line, the critical internal, point E energy.
!
!
! The bilinear mapping is used for the interpolation from physical (v,e)
! doamin to the transformed domaine (X,Y).(Bicubic can be
! considered later by using also the derivatives)
!========================================================================
!
     USE def_constants, ONLY: pr,ord_spline,e_tri_R,e_cr,x_mesh_max,x_mesh_min,&
&                             e_tri_R,e_tri_L,v_tri_R,v_tri_L,P_tri,T_tri,c_cr,MMM_TPM,NNN_TPM,NNN_sat_TPM,&
&                             P_cr,T_cr,rho_cr
     USE def_variables, ONLY: x_mesh_TPM,y_mesh_TPM,y_mesh_sat_TPM,v_right_TPM,v_left_TPM,&
&        spline_right_TPM,spline_left_TPM,saturP,ppp_TPM,vvv_TPM,xxx_TPM,ccc_TPM,TTT_TPM
!&        vL_psat_spline, vV_psat_spline,uL_psat_spline, uV_psat_spline, Tsat_psat_spline
     USE non_linear_solvers,ONLY: New_Rap3D, BrentRoots
     USE properties, ONLY: pressure,sound_speed,satderiv,satprop
     USE grid_functions,ONLY: polyfit
!
      IMPLICIT NONE
!
      REAL(pr) :: u_max, u_min , delta, deltap, vvv_TPM_log
      REAL(pr) :: ev,el,vv,vl,qual,sound,pp,ratio,press,temp,Tsat
      INTEGER  :: i,k,j_tpl, Niter, flag,j
      REAL(pr) :: duL_dp, duV_dp, dvL_dp, dvV_dp,du_dp_x,dv_dp_x
      REAL(pr) :: pguess,res, T_guess,v_six,in_2,out_2,v_guess,vliq,vliq_guess,pguess1,&
&                 Tguess,vvguess,vlguess, res1,dummy,upper, lower

!--------------------------------------------------------------------------
!
! Construct vector y_mesh_TPM(physical domain), x_mesh_TPM(tansformed
! domain)
!
!-------------------------------------------------------------------------
        u_max = e_tri_R
        u_min = e_cr
!
        delta = (u_max - u_min) / (NNN_TPM - 1)
        y_mesh_TPM = u_min + (/(i*delta,i=0,NNN_TPM-1)/)
!
        delta = (x_mesh_max - x_mesh_min) / (MMM_TPM -1)
        x_mesh_TPM = x_mesh_min + (/(i*delta, i=0,MMM_TPM-1)/)
!
        delta             = (u_max - u_min)/(NNN_sat_TPM-1)
        y_mesh_sat_TPM   = u_min + (/(i*delta, i=0,NNN_sat_TPM-1)/)
!

! Right boundary = iso triple pressure line
!print*, 'stat right'
        ev = e_tri_R
        el = e_tri_L
        vv = v_tri_R
        vl = v_tri_L
        ppp_TPM(:,MMM_TPM) = P_tri
        TTT_TPM(:,MMM_TPM) = T_tri
!
        DO k=1,NNN_TPM
!
           xxx_TPM(k,MMM_TPM) = (y_mesh_TPM(k) - el) / (ev - el)
           qual = (y_mesh_TPM(k) - el) / (ev - el)
           vvv_TPM(k,MMM_TPM) = qual*vv + (1_pr-qual)*vl
! Speed of sound
!
           CALL satderiv(3, ppp_TPM(k,MMM_TPM), duL_dp, duV_dp, dvL_dp, dvV_dp)
!
           ratio = ((ev - el)/(vv - vl))   ! (J/kg)/(m3/kg)
           du_dp_x = qual * duV_dp + (1_pr - qual) * duL_dp
           dv_dp_x = qual * dvV_dp + (1_pr - qual) * dvL_dp
!
           sound = SQRT((P_tri + ratio)/(du_dp_x - ratio * dv_dp_x)) * vvv_TPM(k,MMM_TPM)
!
           ccc_TPM(k,MMM_TPM) = sound
!        print*,k,'v', vvv_TPM(k,MMM_TPM),'x',qual,'sound',ccc_TPM(k,MMM_TPM),y_mesh_TPM(k)
        END DO
!stop
!        vvv_TPM(1,MMM_TPM) = v_D
!        xxx_TPM(1,MMM_TPM) = (e_cr - el) / (ev - el)
!
! Left boundary == a part of right boundary of LH
!print*, 'stat left'
        vvv_TPM(1,1) = 1_pr/rho_cr
        ppp_TPM(1,1) = P_cr
        TTT_TPM(1,1) = T_cr
        ccc_TPM(1,1) = c_cr
        xxx_TPM(:,1) = 1_pr
!
!        v_six = 2.2530239912767237e-3_pr
!        DO i = 2, 18
!        ! Calculation of the volumes in the linear part for 100*100 mesh
!          vvv_TPM(i,1) = (y_mesh_TPM(i) - e_cr) / ( y_mesh_TPM(19) - e_cr) * &
!     &    (v_six - 1d0 / rho_cr) + 1d0 / rho_cr
!
!          CALL New_Rap1D(1, TTT_TPM(i,1), out_2, res, Niter, &
!     &         flag, y_mesh_TPM(i), T_cr-0.01,&
!     &         vvv_TPM(i,1), out_2)
!
!          CALL pressure(TTT_TPM(i,1),vvv_TPM(i,1),press)
!          ppp_TPM(i,1) = press
!!
!          CALL sound_speed(TTT_TPM(i,1),vvv_TPM(i,1), sound)
!          ccc_TPM(i,1) = sound
!
!          IF (res > 1e-12) THEN
!             print*, "Left in TPM", res, "iter", Niter,i
!             STOP
!          ENDIF
!
!  print*, i, vvv_TPM(i,1), ppp_TPM(i,1),TTT_TPM(i,1),ccc_TPM(i,1)
!        ENDDO
             T_guess = T_cr-0.001_pr
             v_guess = 1_pr / rho_cr + 1e-4_pr
             vliq_guess = 1_pr / rho_cr - 1e-4_pr
!             T_guess = TTT_TPM(18,1)
!             v_guess = vvv_TPM(18,1)
!             vliq_guess = 1_pr / rho_cr - 2e-4_pr
        DO i=2, NNN_TPM
!
         CALL New_Rap3D(4,vliq,vvv_TPM(i,1),TTT_TPM(i,1),&
     &        res, Niter, flag, y_mesh_TPM(i),in_2,&
     &        vliq_guess,v_guess,T_guess)
!
         v_guess = vvv_TPM(i,1)
         vliq_guess = vliq
         T_guess = TTT_TPM(i,1)
!
         CALL pressure(TTT_TPM(i,1),vvv_TPM(i,1),press)
         ppp_TPM(i,1) = press
!
         CALL sound_speed(TTT_TPM(i,1),vvv_TPM(i,1), sound)
         ccc_TPM(i,1) = sound
!
         IF (res > 1e-7) THEN
            print*, "Left in TPM", res, "iter", Niter
            STOP
         ENDIF
!      print*, i, vvv_TPM(i,1), ppp_TPM(i,1),TTT_TPM(i,1),ccc_TPM(i,1)
        END DO
!STOP
!
!
! Middle points
!
!
!print*, 'stat middle'
!         DO j=2,MMM_TPM-1
          DO i=1, NNN_TPM
!             pguess = ppp_TPM(i,1)
!          DO i=1, NNN_TPM
             DO j=2,MMM_TPM-1
!
!           vvv_TPM(i,j) = ((x_mesh_TPM(j) - x_mesh_min) /&
!     &    (x_mesh_max - x_mesh_min)) *(vvv_TPM(i,MMM_TPM)-vvv_TPM(i,1))&
!     &     +vvv_TPM(i,1)
           vvv_TPM_log = ((x_mesh_TPM(j) - x_mesh_min) /&
     &     (x_mesh_max - x_mesh_min)) *(log10(vvv_TPM(i,MMM_TPM))-log10(vvv_TPM(i,1)))+&
     &     log10(vvv_TPM(i,1))
           vvv_TPM(i,j) = 10_pr**vvv_TPM_log
!
!      print*, vvv_TPL(i,MMM_TPL), vvv_TPL(i,1)
!      print*, y_mesh_TPL(i),vvv_TPL(i,j),pguess
!           CALL New_Rap1D(2, press, qual, res1, Niter, flag,&
!     &           y_mesh_TPM(i), pguess, vvv_TPM(i,j), temp)
!
           lower = P_tri
           upper = P_cr - 0.01e6_pr
!           upper = pguess+2.0e6_pr
!print*, i,j,'lower',lower,'upper',upper
           CALL BrentRoots(1, press, temp, res, Niter, y_mesh_TPM(i), lower, upper, vvv_TPM(i,j), dummy)
!
!print*, 'v',vvv_TPM(i,j),'e',y_mesh_TPM(i), 'p,T',press,temp
!print*, ' '
           ppp_TPM(i,j) = press
           TTT_TPM(i,j) = temp
!           pguess       = press !- 1e4_pr
!
           IF (res  > 1e-10_pr) THEN
             print*, "middle points TPM", res, "iter", Niter,i,j
             STOP
           ENDIF
!
! Speed of sound
!
           CALL satprop(3, press, dummy, vv, vl, ev, el)
           CALL satderiv(3, press, duL_dp, duV_dp, dvL_dp, dvV_dp)
!
           qual = (vvv_TPM(i,j)-vl) / (vv-vl)
!
           ratio = ((ev - el)/(vv - vl))   ! (J/kg)/(m3/kg)
           du_dp_x = qual * duV_dp + (1_pr - qual) * duL_dp
           dv_dp_x = qual * dvV_dp + (1_pr - qual) * dvL_dp
!
           sound = SQRT((press + ratio)/(du_dp_x - ratio * dv_dp_x)) * vvv_TPM(i,j)
!
           ccc_TPM(i,j) = sound
           xxx_TPM(i,j) = qual
!
!      print*,j,i, ppp_TPM(i,j), TTT_TPM(i,j), xxx_TPM(i,j)
          END DO
         END DO
!STOP
!  print*, 'TPM','1,1', y_mesh_TPM(1),  vvv_TPM(1,1),&
!&                          TTT_TPM   (1,1),ppp_TPM(1,1),ccc_TPM(1,1)
!  print*, 'TPM','2,1   ', y_mesh_TPM(2),  vvv_TPM(2,1),&
!&                          TTT_TPM   (2,1),ppp_TPM(2,1),ccc_TPM(2,1)
!  print*, 'TPM','1,2   ', y_mesh_TPM(1),  vvv_TPM(1,2),&
!&                          TTT_TPM   (1,2),ppp_TPM(1,2),ccc_TPM(1,2)
!
! Spline line coefficient right boundary
!
!print*, 'stat spline right'
        ev = e_tri_R
        el = e_tri_L
        vv = v_tri_R
        vl = v_tri_L
       DO i=1,NNN_sat_TPM
           qual = (y_mesh_sat_TPM(i) - el) / (ev - el)
           v_right_TPM(i) = qual*vv + (1_pr-qual)*vl
       ENDDO
       DO i = 1, NNN_TPM-1
          j = ord_spline * (i-1) + 1
          CALL polyfit(spline_right_TPM(:,i), &
     &               y_mesh_sat_TPM(j:j+ord_spline),&
     &               v_right_TPM(j:j+ord_spline), ord_spline)
       ENDDO
!
! Spline line coefficient left boundary
!
!print*, 'stat spline left'
        v_left_TPM(1) = 1_pr/rho_cr

!        T_guess = T_cr - 0.0001_pr
!        v_guess =  1_pr/rho_cr + 1e-5_pr
!        vliq_guess = 1_pr/rho_cr - 1e-5_pr
!
! USE test_grid to compute T_guess, v_guess, vliq_guess
        T_guess = 304.1281
        v_guess =  2.1443612972628459E-003
        vliq_guess = 2.1322415401290890E-003

        DO i=2, NNN_sat_TPM
!              T_guess_sat = T_sat_sat(i-1)
!              v_guess_sat = v_Lsat_LH(i-1)
!              vliq_guess_sat = vliq_sat_LH(i-1)
!           IF( i == 2) THEN
!print*,i, 'in', y_mesh_sat_TPM(i),in_2,vliq_guess,v_guess, T_guess

          CALL New_Rap3D(4,vliq,v_left_TPM(i),Tsat,&
      &        res, Niter, flag, y_mesh_sat_TPM(i),in_2,&
      &        vliq_guess,v_guess, T_guess)
!
!print*, 'out', vliq,v_left_TPM(i),Tsat,res,Niter,flag

          CALL New_Rap3D(4,vliq,v_left_TPM(i),Tsat,&
      &        res,Niter,flag, y_mesh_sat_TPM(i),in_2,&
      &        vliq,v_left_TPM(i),Tsat)
!
!           ELSE
!
!               CALL New_Rap3D(4,vliq_sat_LH(i),v_Lsat_LH(i),T_sat_sat(i),&
!              & res_sat_LH(i), Niter, exitflag, y_mesh_sat_LH(i),in_2,&
!              & vliq_guess_sat,v_guess_sat, T_guess_sat)
!           ENDIF

              T_guess    = Tsat
              v_guess    = v_left_TPM(i)
              vliq_guess = vliq
!
              IF (res > 1e-8) THEN
               print*, "Left spline TPM", res, "i", i,&
               &        'T=',Tsat
               STOP
              ENDIF
!      print*, i, v_left_TPM(i)
        END DO
!
!
      DO i = 1, NNN_TPM-1
        j = 3 * (i-1) + 1
        CALL polyfit(spline_right_TPM(:,i), y_mesh_sat_TPM(j:j+3),v_right_TPM(j:j+3),ord_spline)
       CALL polyfit(spline_left_TPM(:,i), y_mesh_sat_TPM(j:j+3),v_left_TPM(j:j+3),ord_spline)
!        CALL polyfit(spline_left_TPM(:,i), y_mesh_sat_TPM(j:j+3),LOG10(v_left_TPM(j:j+3)),ord_spline)
      ENDDO
!
!     print*,'------------------------------------------------------'
     print*,           'TPM GRID FINISH'
!     print*,'------------------------------------------------------'
!
!
      END SUBROUTINE grid_construction_TPM


      subroutine wtrans(vd,r,nr,rab,l,ist,b)
c
c **********************************************************
c *
c *    This is a plotting routine; the user should adjust
c *  for their own needs.  The result
c *  is then printed to the current plot.dat file (unit=3)
c *  for later plotting of the data.  A marker (marker fw#)
c *  is placed at the end of each set of data.
c *
c **********************************************************
c
c  njtj
c  ###  Cray conversions
c  ###    1)Comment out implicit double precision.
c  ###    2)Switch double precision parameter
c  ###      to single precision parameter statement.
c  ###  Cray conversions
c  njtj
c
      implicit double precision (a-h,o-z)
c
      parameter (zero=0.D0,one=1.D0,big=17280.0D0,p5=.05D0)
Cray      parameter (zero=0.0,one=1.0,big=17280.0,p5=.05)
c
      dimension vd(nr),r(nr),rab(nr),b(nr),vql(48),vql2(48),
     1 a(2000),vdpp(2000),r2(2000),v(2000),w(4000)
c
      do 1 i=1,48
        vql(i)=zero
 1    continue
c
c  The wavefuncion(rR) times r times rab.
c
      if (abs(ist) .eq. 2) goto 400
      pi4=16*atan(one)
      do 10 k=2,nr
        if (r(k)-r(k-1).gt. p5) then
          nr2=k
          goto 20
        endif
 10   continue
 20   nr2=7*(nr2/7)+1
      nr3=nr2-7
      do 130 k=2,nr2
        b(k)=vd(k)*r(k)*rab(k)
 130  continue
      do 150 k=nr2,nr
        a(k-nr2+1)=vd(k)*r(k)
 150  continue
      isx = 0
      a1 = -p5*10
      an = -p5*10
      b1 = zero
      bn = zero
      nrm=nr-nr2+1
      call splift(r(nr2),a,r2,vdpp,nrm,w,ierr,isx,a1,b1,an,bn)
      if(ierr.ne.1) then
        stop
      endif
      nr4=0
      do 155 ak=r(nr2),100.0D0,0.05D0
        nr4=nr4+1
        r2(nr4)=ak
 155  continue
      call splint(r(nr2),a,vdpp,nrm,r2,v,w,w(2000),nr4,kerr)
c
c  Find the fourier transform-vql.
c
      do 140 j=1,48
        q=one/4*j
        vql(j)=zero
        a(1)=zero
        do 135 k=2,nr2
          a(k)=b(k)*sbessj(l,q*r(k))
 135    continue
c
c  Due to the high number of occilations in the intagrand,
c  an eight point Newton-Cotes intagration method is used.
c  See  Abramowitz and Stegun Eq. 25.4.17
c
        do 145 k=1,nr3,7
          vql(j)=vql(j)+751*(a(k)+a(k+7))+3577*(a(k+1)+a(k+6))+
     1     1323*(a(k+2)+a(k+5))+2989*(a(k+3)+a(k+4))
 145    continue
        vql(j)=pi4*7*vql(j)/big
        do 160 k=1,nr4
          a(k)=v(k)*sbessj(l,q*r2(k))
 160    continue
        vql2(j)=zero
        do 165 kk=8,nr4,7
          k=kk-7
          vql2(j)=vql2(j)+751*(a(k)+a(k+7))+3577*(a(k+1)+
     1     a(k+6))+1323*(a(k+2)+a(k+5))+2989*(a(k+3)+a(k+4))
 165    continue
        vql2(j)=0.35D0*pi4*vql2(j)/big
        vql(j)=vql(j)+vql2(j)
 140  continue
c
c  Print out the transform vql(q) to the current plot.dat
c  file (unit=3) for latter plotting.
c
 400  do 170 j=1,48
        write(3,6000)one/4*j,ist*vql(j)
 170  continue
      write(3,6001)l
      return
c
c  format statements
c
 6000 format(1x,f7.4,3x,f10.6)
 6001 format(1x,'marker fw',i1)
      end


!-----------------------------------------------------------------------
!     Module:        fieldlines_grid
!     Authors:       S. Lazerson (lazerson@pppl.gov)
!     Date:          02/21/2012
!     Description:   This module contains the FIELDLINES grid variables.
!-----------------------------------------------------------------------
      MODULE fieldlines_grid
!-----------------------------------------------------------------------
!     Libraries
!-----------------------------------------------------------------------
      USE stel_kinds, ONLY: rprec
      USE EZspline_obj
      USE EZspline

!-----------------------------------------------------------------------
!     Module Variables
!         nr             Number of radial gridpoints
!         nphi           Number of toroidal gridpoints
!         nz             Number of vertical gridpoints
!         rmin           Minimum radial extent of grid [m]
!         rmax           Maximum radial extent of grid [m]
!         phimin         Minimum toroidal extent of grid [radians]
!         phimax         Maximum toroidal extent of grid [radians]
!         zmin           Minimum vertical extent of grid [m]
!         zmax           Maximum vertical extent of grid [m]
!         delta_phi      Stepsize in toroidal angle [radians]
!         vc_adapt_tol   Adaptive Integration tolerance for virtual casing
!         raxis          Radial Grid
!         phiaxis        Toroidal Grid
!         zaxis          Vertical Grid
!         B_R            Radial Magnetic Field [T]
!         B_PHI          Toroidal Magnetic Field [T]
!         B_Z            Vertical Magnetic Field [T]
!         PRES_G         Plasma Pressure [Pa] on grid
!         BR_spl         EZSpline Object for B_R/B_PHI
!         BZ_spl         EZSpline Object for B_Z/B_PHI
!-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER  ::    nr, nphi, nz
      REAL(rprec) :: rmin, rmax, zmin, zmax, phimin, phimax, delta_phi,&
                     vc_adapt_tol
      INTEGER  ::    win_raxis, win_phiaxis, win_zaxis, win_B_R, win_B_PHI, win_B_Z, &
                     win_MU, win_BR4D, win_BPHI4D, win_BZ4D, win_MODB4D, win_MU4D, win_PRES
      REAL(rprec), POINTER :: raxis(:), zaxis(:), phiaxis(:)
      REAL(rprec), POINTER :: B_R(:,:,:), B_Z(:,:,:), B_PHI(:,:,:)
      REAL(rprec), POINTER :: MU3D(:,:,:), PRES_G(:,:,:)
      REAL(rprec), DIMENSION(:,:,:,:), POINTER :: BR4D, BPHI4D, BZ4D, MODB4D, MU4D
      TYPE(EZspline3_r8) :: BR_spl, BZ_spl, MU_spl, MODB_spl
      REAL*8 ::      eps1, eps2, eps3
      REAL*8, parameter :: small = 1.e-10_ezspline_r8

      ! For the boundary scaling routine
      INTEGER :: mnmax_m, nfp_m, isgn_m
      INTEGER, ALLOCATABLE :: ixm_m(:), ixn_m(:)
      REAL(rprec) ::  vb_ws, u0, v0, dr_m, rb_ws, zb_ws
      REAL(rprec), ALLOCATABLE :: rmnc_m(:), zmns_m(:), rmns_m(:), zmnc_m(:)

      END MODULE fieldlines_grid


module make_explicit_thermal_module

  use bl_types
  use multifab_module
  use ml_layout_module
  use define_bc_module
  use bl_constants_module

  implicit none

  private

  public :: make_explicit_thermal, make_thermal_coeffs

contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Compute the quantity: thermal = del dot kappa grad T
!
!  if temp_diffusion_formulation = 1, then we compute this directly.
!  if temp_diffusion_formulation = 2, then we compute the algebraically
!     equivalent form with grad h - grad X_k - grad p_0 formulation
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  subroutine make_explicit_thermal(mla,dx,thermal,s,Tcoeff,hcoeff,Xkcoeff,pcoeff, &
                                   p0,the_bc_tower)

    use bc_module
    use bl_prof_module
    use cc_stencil_module
    use cc_applyop_module
    use network, only: nspec
    use ml_cc_restriction_module, only : ml_cc_restriction
    use multifab_fill_ghost_module
    use bl_constants_module
    use variables, only: temp_comp, rho_comp, rhoh_comp, spec_comp, foextrap_comp
    use fill_3d_module
    use probin_module, only: temp_diffusion_formulation

    type(ml_layout), intent(inout) :: mla
    real(dp_t)     , intent(in   ) :: dx(:,:)
    type(multifab) , intent(inout) :: thermal(:)
    type(multifab) , intent(in   ) :: s(:)
    type(multifab) , intent(in   ) :: Tcoeff(:)
    type(multifab) , intent(in   ) :: hcoeff(:)
    type(multifab) , intent(in   ) :: Xkcoeff(:)
    type(multifab) , intent(in   ) :: pcoeff(:)
    real(kind=dp_t), intent(in   ) :: p0(:,0:)
    type(bc_tower) , intent(in   ) :: the_bc_tower

    ! Local
    type(multifab) :: phi(mla%nlevel),solver_alpha(mla%nlevel),solver_beta(mla%nlevel,mla%dim)
    type(multifab) :: resid(mla%nlevel)

    integer :: comp,i,n,stencil_order,dm,nlevs

    type(bl_prof_timer), save :: bpt

    call build(bpt, "make_explicit_thermal")

    dm = mla%dim
    nlevs = mla%nlevel

    stencil_order = 2

    do n=1,nlevs
       call setval(thermal(n), ZERO, all=.true.)
    end do

    ! for either diffusion formulation, we will use cc_applyop to
    ! construct the form of the conduction term.  cc_applyop forms
    ! the generic quantity:
    !
    !   (solver_alpha MINUS del dot solver_beta grad) phi = RHS

    if (temp_diffusion_formulation .eq. 1) then

       ! compute del dot (Tcoeff grad T) directly

       do n=1,nlevs
          call multifab_build(phi(n), mla%la(n), 1,  1)
          do i = 1,dm
             call multifab_build_edge(solver_beta(n,i),mla%la(n),1,1,i)
          end do
       end do

       do n=1,nlevs
          ! load T into phi
          call multifab_copy_c(phi(n),1,s(n),temp_comp,1,1)
       end do

       call put_data_on_faces(mla,Tcoeff,1,solver_beta,.true.)

       do n=1,nlevs
          call multifab_build(solver_alpha(n), mla%la(n), 1, 1)
          call multifab_build(resid(n), mla%la(n), 1, 0)
          call setval(solver_alpha(n), ZERO, all=.true.)
       end do

       ! applyop to compute resid = del dot Tcoeff grad T
       call cc_applyop(mla,resid,phi,solver_alpha,solver_beta,dx,the_bc_tower,dm+rhoh_comp, &
                       stencil_order)

       do n=1,nlevs
          call destroy(phi(n))
          call destroy(solver_alpha(n))
          do i = 1,dm
             call destroy(solver_beta(n,i))
          end do
       end do

       ! add residual to thermal
       do n=1,nlevs
          do i = 1,dm
             call multifab_plus_plus_c(thermal(n),1,resid(n),1,1,0)
          end do
       enddo

       do n = 1,nlevs
          call destroy(resid(n))
       enddo

    else ! if (temp_diffusion_formulation .eq. 2) case

       ! compute thermal = del dot ( hcoeff grad h) -
       !             sum_k del dot (Xkcoeff grad X_k) -
       !                   del dot ( pcoeff grad p_0)

       do n=1,nlevs
          call multifab_build(phi(n),  mla%la(n), 1,  1)
          do i = 1,dm
             call multifab_build_edge(solver_beta(n,i), mla%la(n), 1, 1, i)
          end do
       end do

       do n=1,nlevs
          ! load h into phi
          call multifab_copy_c(phi(n),1,s(n),rhoh_comp,1,1)
          call multifab_div_div_c(phi(n),1,s(n),rho_comp,1,1)
       end do

       call put_data_on_faces(mla,hcoeff,1,solver_beta,.true.)

       do n=1,nlevs
          call multifab_build(solver_alpha(n), mla%la(n), 1, 1)
          call multifab_build(resid(n), mla%la(n), 1, 0)
          call setval(solver_alpha(n), ZERO, all=.true.)
       end do

       ! applyop to compute resid = del dot hcoeff grad h
       call cc_applyop(mla,resid,phi,solver_alpha,solver_beta,dx,the_bc_tower,dm+rhoh_comp, &
                       stencil_order)

       ! add residual to thermal
       do n=1,nlevs
          call multifab_plus_plus_c(thermal(n),1,resid(n),1,1,0)
       enddo

       ! loop over species
       do comp=1,nspec
          do n=1,nlevs
             ! load X_k into phi
             call multifab_copy_c(phi(n),1,s(n),spec_comp+comp-1,1,1)
             call multifab_div_div_c(phi(n),1,s(n),rho_comp,1,1)
          end do

          call put_data_on_faces(mla,Xkcoeff,comp,solver_beta,.true.)

          ! applyop to compute resid = del dot Xkcoeff grad X_k
          call cc_applyop(mla,resid,phi,solver_alpha,solver_beta,dx,the_bc_tower,dm+spec_comp+comp-1, &
                          stencil_order)

          ! add residual to thermal
          do n=1,nlevs
             call multifab_plus_plus_c(thermal(n),1,resid(n),1,1,0)
          enddo
       enddo ! end loop over species

       call put_1d_array_on_cart(p0,phi,foextrap_comp,.false.,.false., &
                                 dx,the_bc_tower%bc_tower_array,mla)

       call put_data_on_faces(mla,pcoeff,1,solver_beta,.true.)

       ! applyop to compute resid = del dot pcoeff grad p0
       call cc_applyop(mla,resid,phi,solver_alpha,solver_beta,dx,the_bc_tower,foextrap_comp, &
                       stencil_order)

       do n=1,nlevs
          call destroy(phi(n))
          call destroy(solver_alpha(n))
          do i = 1,dm
             call destroy(solver_beta(n,i))
          end do
       end do

       ! add residual to thermal
       do n=1,nlevs
          call multifab_plus_plus_c(thermal(n),1,resid(n),1,1,0)
       enddo

       do n = 1,nlevs
          call destroy(resid(n))
       enddo

    endif ! end temp_diffusion_formulation logic

    call destroy(bpt)

  end subroutine make_explicit_thermal

  subroutine make_thermal_coeffs(s,Tcoeff,hcoeff,Xkcoeff,pcoeff)

    ! create the coefficients for grad{T}, grad{h}, grad{X_k}, and grad{p_0}
    ! for the thermal diffusion term in the enthalpy equation.
    !
    ! note: we explicitly fill the ghostcells by looping over them directly
    ! in the _2d and _3d routines below.
    type(multifab) , intent(in   ) :: s(:)
    type(multifab) , intent(inout) :: Tcoeff(:)
    type(multifab) , intent(inout) :: hcoeff(:)
    type(multifab) , intent(inout) :: Xkcoeff(:)
    type(multifab) , intent(inout) :: pcoeff(:)

    ! local
    integer :: n,i,dm,nlevs
    integer :: ng_s,ng_T,ng_h,ng_X,ng_p
    integer :: lo(get_dim(s(1))),hi(get_dim(s(1)))

    real(kind=dp_t), pointer    :: sp(:,:,:,:)
    real(kind=dp_t), pointer    :: Tcoeffp(:,:,:,:),hcoeffp(:,:,:,:)
    real(kind=dp_t), pointer    :: Xkcoeffp(:,:,:,:),pcoeffp(:,:,:,:)

    type(bl_prof_timer), save :: bpt

999 format('... Level ', i1, ' create thermal coeffs:')

    call build(bpt, "make_thermal_coeffs")

    dm = get_dim(s(1))
    nlevs = size(s)

    ng_s = nghost(s(1))
    ng_T = nghost(Tcoeff(1))
    ng_h = nghost(hcoeff(1))
    ng_X = nghost(Xkcoeff(1))
    ng_p = nghost(pcoeff(1))

    ! create Tcoeff = -kth,
    !        hcoeff = -kth/cp,
    !        Xkcoeff = xik*kth/cp,
    !        pcoeff = hp*kth/cp
    do n=1,nlevs
       if (parallel_IOProcessor()) write (6, 999) n

       do i=1,nfabs(s(n))
          sp       => dataptr(s(n),i)
          Tcoeffp  => dataptr(Tcoeff(n),i)
          hcoeffp  => dataptr(hcoeff(n),i)
          Xkcoeffp => dataptr(Xkcoeff(n),i)
          pcoeffp  => dataptr(pcoeff(n),i)
          lo = lwb(get_box(s(n),i))
          hi = upb(get_box(s(n),i))
          select case (dm)
          case (1)
             call make_thermal_coeffs_1d(lo,hi,sp(:,1,1,:),ng_s,Tcoeffp(:,1,1,1),ng_T, &
                                         hcoeffp(:,1,1,1),ng_h,Xkcoeffp(:,1,1,:),ng_X, &
                                         pcoeffp(:,1,1,1),ng_p)
          case (2)
             call make_thermal_coeffs_2d(lo,hi,sp(:,:,1,:),ng_s,Tcoeffp(:,:,1,1),ng_T, &
                                         hcoeffp(:,:,1,1),ng_h,Xkcoeffp(:,:,1,:),ng_X, &
                                         pcoeffp(:,:,1,1),ng_p)
          case (3)
             call make_thermal_coeffs_3d(lo,hi,sp(:,:,:,:),ng_s,Tcoeffp(:,:,:,1),ng_T, &
                                         hcoeffp(:,:,:,1),ng_h,Xkcoeffp(:,:,:,:),ng_X, &
                                         pcoeffp(:,:,:,1),ng_p)
          end select
       end do
    enddo

    call destroy(bpt)

  end subroutine make_thermal_coeffs

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! create Tcoeff = -kth,
!        hcoeff = -kth/cp,
!       Xkcoeff = xik*kth/cp,
!        pcoeff = hp*kth/cp
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine make_thermal_coeffs_1d(lo,hi,s,ng_s,Tcoeff,ng_T,hcoeff,ng_h, &
                                    Xkcoeff,ng_X,pcoeff,ng_p)

    use variables, only: rho_comp, temp_comp, spec_comp
    use eos_module, only: eos_input_rt, eos
    use eos_type_module
    use conductivity_module
    use network, only: nspec
    use probin_module, only: buoyancy_cutoff_factor, base_cutoff_density, limit_conductivity

    integer        , intent(in   ) :: lo(:),hi(:),ng_s,ng_T,ng_h,ng_X,ng_p
    real(kind=dp_t), intent(in   ) ::       s(lo(1)-ng_s:,:)
    real(kind=dp_t), intent(inout) ::  Tcoeff(lo(1)-ng_T:)
    real(kind=dp_t), intent(inout) ::  hcoeff(lo(1)-ng_h:)
    real(kind=dp_t), intent(inout) :: Xkcoeff(lo(1)-ng_X:,:)
    real(kind=dp_t), intent(inout) ::  pcoeff(lo(1)-ng_p:)

    ! local
    integer :: i,comp
    type (eos_t) :: eos_state

    do i=lo(1)-1,hi(1)+1

       ! if we are outside the star, turn off the conductivity
       if (limit_conductivity .and. &
            s(i,rho_comp) < buoyancy_cutoff_factor*base_cutoff_density) then

          Tcoeff(i) = ZERO
          hcoeff(i) = ZERO
          pcoeff(i) = ZERO
          Xkcoeff(i,:) = ZERO

       else

          eos_state%rho   = s(i,rho_comp)
          eos_state%T     = s(i,temp_comp)
          eos_state%xn(:) = s(i,spec_comp:spec_comp+nspec-1)/eos_state%rho

          ! dens, temp, and xmass are inputs
          call conducteos(eos_input_rt, eos_state)

          Tcoeff(i) = -eos_state % conductivity
          hcoeff(i) = -eos_state % conductivity/eos_state%cp
          pcoeff(i) = (eos_state % conductivity/eos_state%cp)* &
               ((1.0d0/eos_state%rho)* &
               (1.0d0-eos_state%p/(eos_state%rho*eos_state%dpdr))+ &
               eos_state%dedr/eos_state%dpdr)

          do comp=1,nspec
             Xkcoeff(i,comp) = (eos_state % conductivity/eos_state%cp)*eos_state%dhdX(comp)
          enddo

       endif

    enddo

  end subroutine make_thermal_coeffs_1d

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! create Tcoeff = -kth,
!        hcoeff = -kth/cp,
!       Xkcoeff = xik*kth/cp,
!        pcoeff = hp*kth/cp
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine make_thermal_coeffs_2d(lo,hi,s,ng_s,Tcoeff,ng_T,hcoeff,ng_h, &
                                    Xkcoeff,ng_X,pcoeff,ng_p)

    use variables, only: rho_comp, temp_comp, spec_comp
    use eos_module, only: eos_input_rt, eos
    use eos_type_module
    use conductivity_module
    use network, only: nspec
    use probin_module, only: buoyancy_cutoff_factor, base_cutoff_density, limit_conductivity

    integer        , intent(in   ) :: lo(:),hi(:),ng_s,ng_T,ng_h,ng_X,ng_p
    real(kind=dp_t), intent(in   ) ::       s(lo(1)-ng_s:,lo(2)-ng_s:,:)
    real(kind=dp_t), intent(inout) ::  Tcoeff(lo(1)-ng_T:,lo(2)-ng_T:)
    real(kind=dp_t), intent(inout) ::  hcoeff(lo(1)-ng_h:,lo(2)-ng_h:)
    real(kind=dp_t), intent(inout) :: Xkcoeff(lo(1)-ng_X:,lo(2)-ng_X:,:)
    real(kind=dp_t), intent(inout) ::  pcoeff(lo(1)-ng_p:,lo(2)-ng_p:)

    ! local
    integer :: i,j,comp
    type (eos_t) :: eos_state

    do j=lo(2)-1,hi(2)+1
       do i=lo(1)-1,hi(1)+1

          ! if we are outside the star, turn off the conductivity
          if (limit_conductivity .and. &
               s(i,j,rho_comp) < buoyancy_cutoff_factor*base_cutoff_density) then

             Tcoeff(i,j) = ZERO
             hcoeff(i,j) = ZERO
             pcoeff(i,j) = ZERO
             Xkcoeff(i,j,:) = ZERO

          else

             eos_state%rho   = s(i,j,rho_comp)
             eos_state%T     = s(i,j,temp_comp)
             eos_state%xn(:) = s(i,j,spec_comp:spec_comp+nspec-1)/eos_state%rho

             ! dens, temp, and xmass are inputs
             call conducteos(eos_input_rt, eos_state)

             Tcoeff(i,j) = -eos_state % conductivity
             hcoeff(i,j) = -eos_state % conductivity/eos_state%cp
             pcoeff(i,j) = (eos_state % conductivity/eos_state%cp)* &
                  ((1.0d0/eos_state%rho)* &
                  (1.0d0-eos_state%p/(eos_state%rho*eos_state%dpdr))+ &
                  eos_state%dedr/eos_state%dpdr)

             do comp=1,nspec
                Xkcoeff(i,j,comp) = (eos_state % conductivity/eos_state%cp)*eos_state%dhdX(comp)
             enddo

          endif
       enddo
    enddo

  end subroutine make_thermal_coeffs_2d

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! create Tcoeff = -kth,
!        hcoeff = -kth/cp,
!       Xkcoeff = xik*kth/cp,
!        pcoeff = hp*kth/cp
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine make_thermal_coeffs_3d(lo,hi,s,ng_s,Tcoeff,ng_T,hcoeff,ng_h, &
                                    Xkcoeff,ng_X,pcoeff,ng_p)

    use variables, only: rho_comp, temp_comp, spec_comp
    use eos_module, only: eos_input_rt, eos
    use eos_type_module
    use conductivity_module
    use network, only: nspec
    use fill_3d_module
    use probin_module, only: buoyancy_cutoff_factor, base_cutoff_density, limit_conductivity

    integer        , intent(in   ) :: lo(:),hi(:),ng_s,ng_T,ng_h,ng_X,ng_p
    real(kind=dp_t), intent(in   ) ::       s(lo(1)-ng_s:,lo(2)-ng_s:,lo(3)-ng_s:,:)
    real(kind=dp_t), intent(inout) ::  Tcoeff(lo(1)-ng_T:,lo(2)-ng_T:,lo(3)-ng_T:)
    real(kind=dp_t), intent(inout) ::  hcoeff(lo(1)-ng_h:,lo(2)-ng_h:,lo(3)-ng_h:)
    real(kind=dp_t), intent(inout) :: Xkcoeff(lo(1)-ng_X:,lo(2)-ng_X:,lo(3)-ng_X:,:)
    real(kind=dp_t), intent(inout) ::  pcoeff(lo(1)-ng_p:,lo(2)-ng_p:,lo(3)-ng_p:)

    ! local
    integer :: i,j,k,comp
    type (eos_t) :: eos_state

    !$OMP PARALLEL DO PRIVATE(i,j,k,comp,eos_state)
    do k=lo(3)-1,hi(3)+1
       do j=lo(2)-1,hi(2)+1
          do i=lo(1)-1,hi(1)+1

             ! if we are outside the star, turn off the conductivity
             if (limit_conductivity .and. &
                  s(i,j,k,rho_comp) < &
                  buoyancy_cutoff_factor*base_cutoff_density) then

                Tcoeff(i,j,k) = ZERO
                hcoeff(i,j,k) = ZERO
                pcoeff(i,j,k) = ZERO
                Xkcoeff(i,j,k,:) = ZERO

             else

                eos_state%rho   = s(i,j,k,rho_comp)
                eos_state%T     = s(i,j,k,temp_comp)
                eos_state%xn(:) = s(i,j,k,spec_comp:spec_comp+nspec-1)/eos_state%rho

                ! dens, temp, and xmass are inputs
                call conducteos(eos_input_rt, eos_state)

                Tcoeff(i,j,k) = -eos_state % conductivity
                hcoeff(i,j,k) = -eos_state % conductivity/eos_state%cp
                pcoeff(i,j,k) = (eos_state % conductivity/eos_state%cp)* &
                     ((1.0d0/eos_state%rho)* &
                     (1.0d0-eos_state%p/(eos_state%rho*eos_state%dpdr))+ &
                     eos_state%dedr/eos_state%dpdr)

                do comp=1,nspec
                   Xkcoeff(i,j,k,comp) = (eos_state % conductivity/eos_state%cp)*eos_state%dhdX(comp)
                enddo

             endif

          enddo
       enddo
    enddo
    !$OMP END PARALLEL DO

  end subroutine make_thermal_coeffs_3d

end module make_explicit_thermal_module