     FUNCTION FACT(N)
     INTEGER N,I,FACT
     FACT=1
     DO 10 I=1,N
  10 FACT=FACT*I
     END


      SUBROUTINE guess_axis(r1, z1, ru0, zu0)
      USE vmec_main
      USE vmec_params, ONLY: nscale, signgs
      USE realspace, ONLY: sqrts
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      REAL(rprec), DIMENSION(ns,nzeta,ntheta3,0:1),
     1     INTENT(in) :: r1, z1
      REAL(rprec), DIMENSION(ns,nzeta,ntheta3), INTENT(in) :: ru0, zu0
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      INTEGER, PARAMETER :: limpts = 61
      REAL(rprec), PARAMETER :: p5 = 0.5_dp, two = 2
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: iv, iu, iu_r, ivminus, nlim, ns12, klim, n
      REAL(rprec), DIMENSION(nzeta) :: rcom, zcom
      REAL(rprec), DIMENSION(ntheta1) :: r1b, z1b, rub, zub
      REAL(rprec), DIMENSION(ntheta1) :: r12, z12
      REAL(rprec), DIMENSION(ntheta1) :: rs, zs, tau, ru12, zu12, tau0
      REAL(rprec) :: rlim(limpts), zlim
      REAL(rprec) :: rmax, rmin, zmax, zmin, dzeta
      REAL(rprec) :: ds, mintau, mintemp
C-----------------------------------------------
!
!     COMPUTES GUESS FOR MAGNETIC AXIS IF USER GUESS
!     LEADS TO INITIAL SIGN CHANGE OF JACOBIAN. DOES A GRID
!     SEARCH (irgrid, izgrid) IN EACH PHI-PLANE FOR POINTS WHICH
!     YIELD A VALUE FOR THE JACOBIAN WITH THE CORRECT SIGN (SIGNGS)
!     CHOOSES THE AXIS POSITION SO THE MIN VALUE OF THE JACOBIAN IS MAXIMIZED
!
      ns12 = (ns+1)/2

      planes: DO iv = 1, nzeta
         IF (.not.lasym .and. iv .gt. nzeta/2+1) THEN
            rcom(iv) = rcom(nzeta+2-iv)
            zcom(iv) =-zcom(nzeta+2-iv)
            CYCLE
         END IF
         r1b(:ntheta3) = r1(ns,iv,:,0) + r1(ns,iv,:,1)
         z1b(:ntheta3) = z1(ns,iv,:,0) + z1(ns,iv,:,1)
         r12(:ntheta3) = r1(ns12,iv,:,0) + r1(ns12,iv,:,1)*sqrts(ns12)
         z12(:ntheta3) = z1(ns12,iv,:,0) + z1(ns12,iv,:,1)*sqrts(ns12)
         rub(:ntheta3) = ru0(ns,iv,:)
         zub(:ntheta3) = zu0(ns,iv,:)
         ru12(:ntheta3) =  p5*(ru0(ns,iv,:) + ru0(ns12,iv,:))
         zu12(:ntheta3) =  p5*(zu0(ns,iv,:) + zu0(ns12,iv,:))

         IF (.not.lasym) THEN
!
!     USE Z(v,-u) = -Z(twopi-v,u), R(v,-u) = R(twopi-v,u)
!     TO DO EXTEND R,Z, etc. OVER ALL THETA (NOT JUST 0,PI)
!
         ivminus = MOD(nzeta + 1 - iv,nzeta) + 1           !!(twopi-v)
         DO iu = 1+ntheta2, ntheta1
            iu_r = ntheta1 + 2 - iu
            r1b(iu) = r1(ns,ivminus,iu_r,0) + r1(ns,ivminus,iu_r,1)
            z1b(iu) =-(z1(ns,ivminus,iu_r,0) + z1(ns,ivminus,iu_r,1))
            r12(iu) = r1(ns12,ivminus,iu_r,0) +
     1                r1(ns12,ivminus,iu_r,1)*sqrts(ns12)
            z12(iu) =-(z1(ns12,ivminus,iu_r,0) +
     1                z1(ns12,ivminus,iu_r,1)*sqrts(ns12))
            rub(iu) =-ru0(ns,ivminus,iu_r)
            zub(iu) = zu0(ns,ivminus,iu_r)
            ru12(iu)=-p5*(ru0(ns,ivminus,iu_r) + ru0(ns12,ivminus,iu_r))
            zu12(iu)= p5*(zu0(ns,ivminus,iu_r) + zu0(ns12,ivminus,iu_r))
         END DO

         END IF
!
!        Scan over r-z grid for interior point
!
         rmin = MINVAL(r1b);  rmax = MAXVAL(r1b)
         zmin = MINVAL(z1b);  zmax = MAXVAL(z1b)
         rcom(iv) = (rmax + rmin)/2; zcom(iv) = (zmax + zmin)/2

!
!        Estimate jacobian based on boundary and 1/2 surface
!
         ds = (ns - ns12)*hs
         DO iu = 1, ntheta1
            rs(iu) = (r1b(iu) - r12(iu))/ds + r1(1,iv,1,0)
            zs(iu) = (z1b(iu) - z12(iu))/ds + z1(1,iv,1,0)
            tau0(iu) = ru12(iu)*zs(iu) - zu12(iu)*rs(iu)
         END DO

         mintau = 0

         DO nlim = 1, limpts
            zlim = zmin + ((zmax - zmin)*(nlim-1))/(limpts-1)
            IF (.not.lasym .and. (iv.eq.1 .or. iv.eq.nzeta/2+1)) THEN
               zlim = 0
               IF (nlim .gt. 1) EXIT
            END IF
            rlim(:) = ( / ((rmin + ((klim-1)*(rmax - rmin))/(limpts-1)),
     1              klim = 1, limpts) / )

!
!           Find value of magnetic axis that maximizes the minimum jacobian value
!
            DO klim = 1, limpts
               tau = signgs*(tau0 - ru12(:)*zlim + zu12(:)*rlim(klim))
               mintemp = MINVAL(tau)
               IF (mintemp .gt. mintau) THEN
                  mintau = mintemp
                  rcom(iv) = rlim(klim)
                  zcom(iv) = zlim
!           If up-down symmetric and lasym=T, need this to pick z = 0
               ELSE IF (mintemp .eq. mintau) THEN
                  IF (ABS(zcom(iv)).gt.ABS(zlim)) zcom(iv) = zlim
               END IF
            END DO
         END DO

      END DO planes

!
!     FOURIER TRANSFORM RCOM, ZCOM
!
      dzeta = two/nzeta
      DO n = 0, ntor
         raxis_cc(n) = dzeta*SUM(cosnv(:,n)*rcom(:))/nscale(n)
         zaxis_cs(n) =-dzeta*SUM(sinnv(:,n)*zcom(:))/nscale(n)
         raxis_cs(n) =-dzeta*SUM(sinnv(:,n)*rcom(:))/nscale(n)
         zaxis_cc(n) = dzeta*SUM(cosnv(:,n)*zcom(:))/nscale(n)
         IF (n.eq.0 .or. n.eq.nzeta/2) THEN
            raxis_cc(n) = p5*raxis_cc(n)
            zaxis_cc(n) = p5*zaxis_cc(n)
         END IF
      END DO

!  100 FORMAT(' n = ',i4,' raxis = ',1pe10.3,' zaxis = ',1pe10.3)

      END SUBROUTINE guess_axis


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of rhocf in forward (tangent) mode:
!   variations   of useful results: rhocf
!   with respect to varying inputs: (global)*temp[_:_,_:_,_:_,_:_]
!                (global)*tsal[_:_,_:_,_:_,_:_] (global)*pres[_:_,_:_,_:_,_:_]
!   Plus diff mem management of: (global)temp:in (global)tsal:in
!                (global)pres:in
! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!> @brief calculates heat capacity times density of water.
!> @param[in] i cell index, direction I0
!> @param[in] j cell index, direction J0
!> @param[in] k cell index, direction K0
!> @param[in] ismpl local sample index
!> @return  rhoc [W/(m*K)]
!> @details
!> calculates volumetric heat capacity of the fluid [J/(K*m3)].\n
DOUBLE PRECISION FUNCTION g_RHOCF(i, j, k, ismpl, rhocf)
  IMPLICIT NONE
! Location indices
  INTEGER, INTENT(IN) :: i
  INTEGER, INTENT(IN) :: j
  INTEGER, INTENT(IN) :: k
! Sample index
  INTEGER :: ismpl
! Density of fluid [kg/m3]
  DOUBLE PRECISION :: rfluid
  DOUBLE PRECISION :: g_rfluid
  DOUBLE PRECISION, EXTERNAL :: RHOF
! Water isobaric head capacity [J/(K*kg)]
  DOUBLE PRECISION :: cfluid
  DOUBLE PRECISION :: g_cfluid
  DOUBLE PRECISION, EXTERNAL :: CPF
	double precision, external :: g_cpf
	double precision, external :: g_rhof
  DOUBLE PRECISION :: rhocf
! water density [kg/m**3]
  g_rfluid = g_RHOF(i, j, k, ismpl, rfluid)
! water isobaric heat capacity [J/(kg*K)]
  g_cfluid = g_CPF(i, j, k, ismpl, cfluid)
! water volumetric heat capacity [J/(K*m3)]
  g_rhocf = cfluid*g_rfluid + rfluid*g_cfluid
  rhocf = rfluid*cfluid
  RETURN
END FUNCTION g_RHOCF


      program testhbhstokesgreenid
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     This program tests the Green's identity for the
c     Helmholtz Stokes single and double layer kernels
c

      implicit real *8 (a-h,o-z)
      parameter (nmax = 100000)
      integer adjs(2,nmax)
      real *8 hs(nmax),xyin(10),xyout(10)
c
      real *8, allocatable :: chunks(:,:,:),ders(:,:,:),
     1     ders2(:,:,:),dsdt(:,:),rnorms(:,:,:),
     2     whts(:,:),taus(:,:,:)
      complex *16, allocatable :: smu(:,:,:), dmu(:,:,:)
      complex *16, allocatable :: smutau(:,:), dmutau(:,:)
      complex *16, allocatable :: smunu(:,:), dmunu(:,:)

      complex *16 :: veltemp(2), stresstemp(2,2), muexact(2)
      complex *16 :: veldertemp(2,2)
      complex *16 :: velsum(2), velexact(2), velsums(2), velsumd(2)
      complex *16 :: mu(2), nu(2)

      complex *16 :: zk

      real *8 pars(100), src(2), targ(2)
c
      external fcurve,fcurve2, fcurve3
c
      character trans

      trans = 'T'
      call prini(6,13)
      done=1
      pi=4*atan(done)
      ima=(0,1)

c
c
c     define points in exterior and interior of R.
c
      xout=-6.1d0
      yout=-7.2d0

      xin = 0.1d0
      yin = -0.21d0
c
      xyout(1)=xout
      xyout(2)=yout

      call prin2('xyout=*',xyout,2)

      xyin(1) = xin
      xyin(2) = yin

c
c     exact solution is a helmholtz stokes velocity
c     field induced by the vector density muexact
c

      zk = (1.0d0,0.0d0)

      muexact(1) = -0.5d0+hkrand(0)
      muexact(2) = -0.5d0+hkrand(0)

c
c     define then chunk up domain
c
      eps10=1.0d-12
      nover1=6
      k=16
c
      maxchunks=nmax
      allocate(chunks(2,k,maxchunks))
      allocate(ders(2,k,maxchunks))
      allocate(ders2(2,k,maxchunks))
c
      ifclosed=1
      chsmall=1000
      ta=0
      tb=2*pi

      t = 0.3d0

      pert = 0.2
      do i=1,100
         pars(i) = pert*hkrand(0)
      enddo
c
      call chunkfunc(eps10,ifclosed,chsmall,ta,tb,fcurve3,
     1     pars,nover1,k,nch,chunks,adjs,ders,ders2,hs)
      hsmax = 0
      do i=1,nch
         if(hsmax.le.hs(i)) hsmax=hs(i)
         do j=1,k
c     c              write(72,*) chunks(1,j,i), chunks(2,j,i)
         enddo
      enddo
      call prin2('hsmax=*',hsmax,1)

      nt = k*nch

c
c     set up densities for Green's identity
c

      allocate(dsdt(k,maxchunks))
      allocate(smu(2,k,maxchunks),dmu(2,k,maxchunks))
      allocate(smutau(k,maxchunks),dmutau(k,maxchunks))
      allocate(smunu(k,maxchunks),dmunu(k,maxchunks))
      allocate(rnorms(2,k,maxchunks))
      allocate(taus(2,k,maxchunks))

      do i=1,nch
         do j=1,k
            rnorm = sqrt(ders(1,j,i)**2 + ders(2,j,i)**2)
            rnorms(1,j,i) = ders(2,j,i)/rnorm
            rnorms(2,j,i) = -ders(1,j,i)/rnorm
            taus(1,j,i) = ders(1,j,i)/rnorm
            taus(2,j,i) = ders(2,j,i)/rnorm
c
            dsdt(j,i) = rnorm*hs(i)
c
            ifstress=1
            call zhelmstokeslet(zk,xyout,chunks(1,j,i),muexact,
     1           veltemp,ifstress,stresstemp)

c     density for single layer (normal component of stress)

            smu(1,j,i) = stresstemp(1,1)*rnorms(1,j,i)
     1           + stresstemp(1,2)*rnorms(2,j,i)
            smu(2,j,i) = stresstemp(2,1)*rnorms(1,j,i)
     1           + stresstemp(2,2)*rnorms(2,j,i)

            smutau(j,i) = smu(1,j,i)*taus(1,j,i)
     1           +smu(2,j,i)*taus(2,j,i)
            smunu(j,i) = smu(1,j,i)*rnorms(1,j,i)
     1           +smu(2,j,i)*rnorms(2,j,i)

c     density for double layer (velocity)

            dmu(1,j,i) = veltemp(1)
            dmu(2,j,i) = veltemp(2)

            dmutau(j,i) = dmu(1,j,i)*taus(1,j,i)
     1           +dmu(2,j,i)*taus(2,j,i)
            dmunu(j,i) = dmu(1,j,i)*rnorms(1,j,i)
     1           +dmu(2,j,i)*rnorms(2,j,i)

         enddo
      enddo

c
c     Compute velocity from Green's I.D.
c

      allocate(whts(k,nch))
      call chunkwhts(k,nch,chunks,ders,hs,whts)

      velsum(1) = 0.0d0
      velsum(2) = 0.0d0
      velsums(1) = 0.0d0
      velsums(2) = 0.0d0
      velsumd(1) = 0.0d0
      velsumd(2) = 0.0d0

      dmaxwht = 0.0d0
      sumwht = 0.0d0

      do i = 1,nch
         do j = 1,k
            ifder = 0
            ifstress=0
            src(1) = chunks(1,j,i)
            src(2) = chunks(2,j,i)
            mu(1) = smu(1,j,i)
            mu(2) = smu(2,j,i)
            call zhelmstokeslet(zk,src,xyin,mu,
     1           veltemp,ifstress,stresstemp)
            velsums(1) = velsums(1)+veltemp(1)*whts(j,i)
            velsums(2) = velsums(2)+veltemp(2)*whts(j,i)

            mu(1) = dmu(1,j,i)
            mu(2) = dmu(2,j,i)
            nu(1) = rnorms(1,j,i)
            nu(2) = rnorms(2,j,i)
            trans='T'
            call zhelmstresslet(zk,src,xyin,mu,
     1           nu,veltemp,trans)
            velsumd(1) = velsumd(1)+veltemp(1)*whts(j,i)
            velsumd(2) = velsumd(2)+veltemp(2)*whts(j,i)
         enddo
      enddo

      velsum(1) = -(velsums(1) + velsumd(1))
      velsum(2) = -(velsums(2) + velsumd(2))

      call zhelmstokeslet(zk,xyout,xyin,muexact,
     1     velexact,ifstress,stresstemp)

c      write(*,*) velexact(1), velexact(2)
c      write(*,*) velsum(1), velsum(2)
      write(*,*) velexact(1)/velsum(1), velexact(2)/velsum(2)
c      write(*,*) velsums(1), velsums(2)
c      write(*,*) velsumd(1), velsumd(2)

      stop
      end
c
c
c
c
c
c
      subroutine fcurve3(t,pars,x,y,dxdt,dydt,dxdt2,dydt2)
      implicit real *8 (a-h,o-z)
      integer n
      real *8 pars(100), t, pert, x0,y0, r0,r,rp,rpp
c
      x0=0.0d0
      y0=0.0d0
      n = 6
      r0 = 5
c
      r = r0
      rp = 0
      rpp = 0
      do i=1,n
         r = r + pars(i)*dsin(t*i)
         rp = rp + pars(i)*dcos(t*i)*i
         rpp = rpp - pars(i)*dsin(t*i)*i*i
      enddo
      x=x0+r*cos(t)
      y=y0+r*sin(t)

c     call prin2('t=*',t,1)

      dxdt=-r*sin(t) + rp*cos(t)
      dydt=r*cos(t) + rp*sin(t)

      dxdt2= -r*cos(t) + rpp*cos(t) - 2*rp*sin(t)
      dydt2= -r*sin(t) + rpp*sin(t) + 2*rp*cos(t)
c
      return
      end
c
c


module Mod_SUPCauchyElement_lin_tools
   use typre
   use Mod_Element
   implicit none

contains

   subroutine sld_calculate_FdN_tensor_lin(e,nd,tn,inod,jnod,B)
       !-----------------------------------------------------------------------
       !
       ! This routine computes the elemental material matrix
       !              (F_jK*d(xi_ij)/dX_K,div(S_iq)_i)
       !
       !-----------------------------------------------------------------------
       implicit none
       class(FiniteElement), intent(in)   :: e
       integer(ip)         , intent(in)   :: inod,jnod,nd,tn
       real(rp)            , intent(inout):: B(tn,tn)
       real(rp)            :: dxi,dyi,dzi,dxj,dyj,dzj

       B=0.0_rp

       if (nd.eq.2) then

           dxi = e%cartd(1,inod)
           dyi = e%cartd(2,inod)

           dxj = e%cartd(1,jnod)
           dyj = e%cartd(2,jnod)

           B(1,1) = dxi*dxj
           B(1,2) = 0.0_rp
           B(1,3) = dxi*dyj

           B(2,1) = 0.0_rp
           B(2,2) = dyi*dyj
           B(2,3) = dyi*dxj

           B(3,1) = dyi*dxj
           B(3,2) = dxi*dyj
           B(3,3) = dyi*dyj&
           &     +  dxi*dxj

       else

           dxi = e%cartd(1,inod)
           dyi = e%cartd(2,inod)
           dzi = e%cartd(3,inod)

           dxj = e%cartd(1,jnod)
           dyj = e%cartd(2,jnod)
           dzj = e%cartd(3,jnod)

           B(1,1) = dxi*dxj
           B(1,2) = 0.0_rp
           B(1,3) = 0.0_rp
           B(1,4) = 0.0_rp
           B(1,5) = dxi*dzj
           B(1,6) = dxi*dyj

           B(2,1) = 0.0_rp
           B(2,2) = dyi*dyj
           B(2,3) = 0.0_rp
           B(2,4) = dyi*dzj
           B(2,5) = 0.0_rp
           B(2,6) = dyi*dxj

           B(3,1) = 0.0_rp
           B(3,2) = 0.0_rp
           B(3,3) = dzi*dzj
           B(3,4) = dzi*dyj
           B(3,5) = dzi*dxj
           B(3,6) = 0.0_rp

           B(4,1) = 0.0_rp
           B(4,2) = dzi*dyj
           B(4,3) = dyi*dzj
           B(4,4) = dzi*dzj &
                & + dyi*dyj
           B(4,5) = dyi*dxj
           B(4,6) = dzi*dxj

           B(5,1) = dzi*dxj
           B(5,2) = 0.0_rp
           B(5,3) = dxi*dzj
           B(5,4) = dxi*dyj
           B(5,5) = dzi*dzj &
                & + dxi*dxj
           B(5,6) = dzi*dyj

           B(6,1) = dyi*dxj
           B(6,2) = dxi*dyj
           B(6,3) = 0.0_rp
           B(6,4) = dxi*dzj
           B(6,5) = dyi*dzj
           B(6,6) = dyi*dyj &
                & + dxi*dxj

       endif

   end subroutine sld_calculate_FdN_tensor_lin

   subroutine sld_calculate_dqFinv_vector_lin(e,nd,tn,inod,jnod,B)
       !-----------------------------------------------------------------------
       !
       ! This routine computes
       !            -d/dX_K((Jp/lam)-1)*F^-1_Ki*q_h)*d(S_ij)/dx_j
       !-----------------------------------------------------------------------
       implicit none

       class(FiniteElement), intent(in) :: e
       integer(ip)         , intent(in)   :: inod,jnod,tn,nd
       real(rp)            , intent(inout):: B(tn)
       real(rp)            :: dxi,dyi,dzi,dxj,dyj,dzj

       B=0.0_rp

       if (nd.eq.2) then

           dxi = e%cartd(1,inod)
           dyi = e%cartd(2,inod)

           dxj = e%cartd(1,jnod)
           dyj = e%cartd(2,jnod)

           !-d(q)/dX_K*F^-1_Ki
           B(1) = dxi*dxj
           B(2) = dyi*dyj
           B(3) = dxi*dyj &
              & + dyi*dxj

       elseif (nd.eq.3) then

           dxi = e%cartd(1,inod)
           dyi = e%cartd(2,inod)
           dzi = e%cartd(3,inod)

           dxj = e%cartd(1,jnod)
           dyj = e%cartd(2,jnod)
           dzj = e%cartd(3,jnod)

           B(1) = dxi*dxj
           B(2) = dyi*dyj
           B(3) = dzi*dzj
           B(4) = dyi*dzj &
              & + dzi*dyj
           B(5) = dxi*dzj &
              & + dzi*dxj
           B(6) = dxi*dyj &
              & + dyi*dxj

       endif

   end subroutine sld_calculate_dqFinv_vector_lin

end module Mod_SUPCauchyElement_lin_tools


	SUBROUTINE AW_2CLG ( dlta, newnum, iret )
C************************************************************************
C* AW_2CLG                                                              *
C*                                                                      *
C* This subroutine calculates the two's complement for a long vector.   *
C* 								        *
C* AW_2CLG ( DLTA, NEWNUM, IRET )                                *
C*								        *
C* Input parameters: 						        *
C*	DLTA   		INTEGER*2	Input long vector               *
C*								        *
C* Output parameters:						        *
C*	NEWNUM          INTEGER		New vector value                *
C*	IRET	   	INTEGER		Return code                     *
C**								        *
C* Log:									*
C* A. Hardy/GSC          7/98                                           *
C* T. Piper/GSC		11/98	Updated prolog				*
C* A. Hardy/GSC         11/98   Added assignment for dlta               *
C************************************************************************
        INTEGER*2      dlta
        INTEGER        tmpbt, newnum, subnum
	INTEGER        sum(12)
        INTEGER        ibte
C------------------------------------------------------------------------
 	iret = 0
        ibte = dlta
C
C*      Subtracting 1 from the input delta value.
C*      Checking each bit position and resetting for 2's compliment.
C
	IF ( ibits ( ibte, 12, 1) .eq. 1 ) THEN
            subnum = ibits ( ibte, 0, 13) - 1
            DO i = 1, 12
                tmpbt = ibits( subnum, i-1, 1)
		IF ( tmpbt .eq. 0 ) THEN
		    tmpbt = 1
                  ELSE
		    tmpbt = 0
                END IF
		sum(i) = tmpbt
            END DO
            newnum = ( sum(1)*1 + sum(2)*2 + sum(3)*4 +
     +                sum(4)*8 + sum(5)*16 + sum(6)*32 +
     +                sum(7)*64 + sum(8)*128 + sum(9)*256 +
     +                sum(10)*512 + sum(11)*1024 +
     +                sum(12)*2048 ) * (-1)
	  ELSE
	      newnum = ibits ( ibte, 0, 13)
        END IF
C*
	RETURN
	END


module potential

  use precision
  use globals
  use mpi
  use interpreter
  use misc

  implicit none

contains

  subroutine s_setpotential(pot, nl, nu)

    !
    ! Define the electronic potential for use in propagation.  It
    ! reads in a scratch file which contains all the layout
    ! information for the potential
    !

    integer(idp), dimension(dim), intent(in) :: nl, nu
    complex(cdp), dimension(nl(1):nu(1), nl(2):nu(2)), intent(out) ::&
         & pot

    logical, dimension(:, :), allocatable :: mask
    character(len=20) :: object
    integer(idp) :: t_int1, i, j, nxmin, nxmax, nymin, nymax, nmin,&
         & smooth
    logical :: donecomponent
    complex(cdp) :: cmplxboundary, boundaryheight

    allocate(mask(nl(1):nu(1), nl(2):nu(2)))

    mask = .false.
    pot = 0.0d0

    do i=1, maxpotcomps

       if (parameters%potcomps(i)) then

          rewind(potdata)

          donecomponent = .false.

          do while(.not. donecomponent)

             read(potdata, '(a)', advance='no') object

             select case (trim(object))

             case('potfn')
                read(potdata, '(i)', advance='no') t_int1

                if (t_int1 == i) then

                   call s_potfn(pot, mask, nl, nu)

                   donecomponent = .true.

                end if

             case ('circle')
                read(potdata, '(i)', advance='no') t_int1

                if (t_int1 == i) then

                   call s_circle(pot, mask, nl, nu)

                   donecomponent = .true.

                end if

             case ('fillcircle')
                read(potdata, '(i)', advance='no') t_int1

                if (t_int1 == i) then

                   call s_fillcircle(pot, mask, nl, nu)

                   donecomponent = .true.

                end if

             case ('ellipse')
                read(potdata, '(i)', advance='no') t_int1

                if (t_int1 == i) then

                   call s_ellipse(pot, mask, nl, nu)

                   donecomponent = .true.

                end if

             case ('fillellipse')
                read(potdata, '(i)', advance='no') t_int1

                if (t_int1 == i) then

                   call s_fillellipse(pot, mask, nl, nu)

                   donecomponent = .true.

                end if

             case ('line')
                read(potdata, '(i)', advance='no') t_int1

                if (t_int1 == i) then

                   call s_line(pot, mask, nl, nu)

                   donecomponent = .true.

                end if

             case ('ramp')
                read(potdata, '(i)', advance='no') t_int1

                if (t_int1 == i) then

                   call s_ramp(pot, mask, nl, nu)

                   donecomponent = .true.

                end if

             case ('polygon')
                read(potdata, '(i)', advance='no') t_int1

                if (t_int1 == i) then

                   call s_polygon(pot, mask, nl, nu)

                   donecomponent = .true.

                end if

             case ('fillpolygon')
                read(potdata, '(i)', advance='no') t_int1

                if (t_int1 == i) then

                   call s_fillpolygon(pot, mask, nl, nu)

                   donecomponent = .true.

                end if

             case default

             end select

             read(potdata, '(a)')

          end do

       end if

    end do

    if (defined_parameters%potsmoothtype .and. f_arraymax(abs(pot),&
         & nl, nu) > 0.0d0) then

       select case (parameters%potsmoothtype)

!!$       case ('poisson')
!!$
!!$          !
!!$          ! Apply Poisson's equation
!!$          !
!!$
!!$          call s_display('applying poisson equation')
!!$
!!$          pot = real(pot)
!!$
!!$          call s_relaxpoisson(pot, mask, nl, nu, parameters
          !!%gridspacing)
!!$
!!$          pot = real(pot)

       case ('gaussblur')

          !
          ! Blur the potential
          !

          call s_display('applying gauss blur, smooth= ', intnums&
               &=parameters%smooth)

          pot = real(pot)

          call s_blur(pot, nl, nu)

          pot = real(pot)

       case('smooth')

          !
          ! Apply an averaging type smooth
          !

          call s_display('applying smooth, smooth= ', intnum&
               &=maxval(parameters%smooth))

          pot = real(pot)

          call s_smooth(pot, nl, nu, maxval(parameters%smooth))

          pot = real(pot)

       case default

       end select

    end if

    if (defined_parameters%optimisation) then

       cmplxboundary = cmplx(0.0d0, -(sum(parameters%pmax**2)/2.0d0 &
            &/parameters%mass)**(5.0d0/4.0d0))

       do j = nl(2), nu(2)

          do i = nl(1), nu(1)

             nxmin = abs(i-1)
             nxmax = abs(parameters%n(1)-i)
             nymin = abs(j-1)
             nymax = abs(parameters%n(2)-j)
             nmin = min(nxmin, nxmax, nymin, nymax)

             if (nmin == nxmin .or. nmin == nxmax) then

                smooth = parameters%smooth(1)

             else

                smooth = parameters%smooth(2)

             end if

             if (nmin < smooth) then

                if ((nmin == nxmin .and. parameters%comppotpos(1))&
                     & .or. (nmin == nxmax .and. parameters&
                     &%comppotpos(2)) .or. (nmin == nymin .and.&
                     & parameters%comppotpos(3)) .or. (nmin == nymax&
                     & .and. parameters%comppotpos(4))) then

                   select case (parameters%optimisation)

                   case ('exponential')

                      !
                      ! The optimal potential
                      !

                      boundaryheight = cmplxboundary*exp(&
                           &-dble(smooth)/dble(smooth - nmin))&
                           &*exp(1.0d0)

                   case ('gaussian')

                      !
                      ! Gaussian potential
                      !

                      boundaryheight = -cmplxboundary*(exp(-(2.0d0&
                           &*dble(smooth - nmin)/dble(smooth))**2)&
                           &-1.0d0)

                   case ('linear')

                      !
                      ! The linear ramp
                      !

                      boundaryheight = cmplxboundary*dble(smooth -&
                           & nmin)/dble(smooth)

                   case default
                      exit

                   end select

                   pot(i, j) = boundaryheight

                end if

             end if

          end do

       end do

    end if

    if (defined_parameters%externale) then

       do i = nl(1), nu(1)

          if (i <= f_gridpointx(parameters%potbound(1))) then

             pot(i, :) = pot(i, :) + parameters%externale

          elseif (i <= f_gridpointx(parameters%potbound(2))) then

             pot(i, :) = pot(i, :) + (1.0d0 - dble(i -&
                  & f_gridpointx(parameters%potbound(1)))&
                  &/dble(f_gridpointx(parameters%potbound(2)) -&
                  & f_gridpointx(parameters%potbound(1))))*parameters&
                  &%externale

          end if

       end do

    end if

    deallocate(mask)

  end subroutine s_setpotential

  subroutine s_fillmask(mask, nl, nu)

    !
    ! Fill in an object, given a mask
    !

    integer(idp), dimension(dim), intent(in) :: nl, nu
    logical, dimension(nl(1):nu(1), nl(2):nu(2)), intent(inout) ::&
         & mask

    integer(idp), dimension(:, :), allocatable :: potxl, potxr, potyu&
         &, potyd
    integer(idp) :: i, j
#ifdef MPI
    integer(idp), dimension(:), allocatable :: buffer
    logical :: yusent, ydsent
    integer, dimension(4) :: mpirequests
    integer, dimension(MPI_STATUS_SIZE, 4) :: mpistatuss
    integer :: mpiindex
#endif

    allocate(potxl(nl(1):nu(1), nl(2):nu(2)), potxr(nl(1):nu(1),&
         & nl(2):nu(2)), potyu(nl(1):nu(1), nl(2):nu(2)),&
         & potyd(nl(1):nu(1), nl(2):nu(2)))

    potxl = 0
    potxr = 0
    potyu = 0
    potyd = 0

    do j = nl(2), nu(2)

       do i = nl(1), nu(1)

          if (i > nl(1)) then

             if (mask(i, j) /= mask(i-1, j)) then

                potxl(i, j) = modulo(potxl(i-1, j)+1, 4)

             else

                potxl(i, j) = potxl(i-1, j)

             end if

          elseif (mask(i, j)) then

             potxl(i, j) = 1

          end if

          if (nu(1)-i+nl(1) < nu(1)) then

             if (mask(nu(1)-i+nl(1), j) /= mask(nu(1)-i+nl(1)+1, j))&
                  & then

                potxr(nu(1)-i+nl(1), j) = modulo(potxr(nu(1)-i+nl(1)&
                     &+1, j)+1, 4)

             else

                potxr(nu(1)-i+nl(1), j) = potxr(nu(1)-i+nl(1)+1, j)

             end if

          elseif (mask(nu(1)-i+nl(1), j)) then

             potxr(nu(1)-i+nl(1), j) = 1

          end if

          if (j > nl(2)) then

             if(mask(i, j) /= mask(i, j-1)) then

                potyu(i, j) = modulo(potyu(i, j-1)+1, 4)

             else

                potyu(i, j) = potyu(i, j-1)

             end if

          elseif (mask(i, j)) then

             potyu(i, j) = 1

          end if

          if (nu(2)-j+nl(2) < nu(2)) then

             if (mask(i, nu(2)-j+nl(2)) /= mask(i, nu(2)-j+nl(2)+1))&
                  & then

                potyd(i, nu(2)-j+nl(2)) = modulo(potyd(i, nu(2)-j&
                     &+nl(2)+1)+1, 4)

             else

                potyd(i, nu(2)-j+nl(2)) = potyd(i, nu(2)-j+nl(2)+1)

             end if

          elseif (mask(i, nu(2)-j+nl(2))) then

             potyd(i, nu(2)-j+nl(2)) = 1

          end if

        end do

    end do

#ifdef MPI
    mpirequests = MPI_REQUEST_NULL
    mpistatuss = 0
    yusent = .false.
    ydsent = .false.

    allocate(buffer(nl(1):nu(1)))

    if (mpirank == mpistart) then

       call s_mpisendint(potyu(nl(1), nu(2)), size(potyu(:, nu(2))),&
            & mpirank+1, mpirequests(1))

       yusent = .true.

    elseif (mpirank == mpiend) then

       call s_mpisendint(potyd(nl(1), nl(2)), size(potyd(:, nl(2))),&
            & mpirank-1, mpirequests(1))

       ydsent = .true.

    end if

    do while (.not. (yusent .and. ydsent))

       call s_mpirecvint(buffer(1), size(buffer), MPI_ANY_SOURCE,&
            & mpirequests(2))

       call s_mpiwaitall(size(mpirequests), mpirequests(1),&
            & mpistatuss(1, 1))

       if (mpistatuss(MPI_SOURCE, 2) == mpirank-1) then

          do j = nl(2), nu(2)

             do i = nl(1), nu(1)

                potyu(i, j) = modulo(potyu(i, j)+buffer(i), 4)

             end do

          end do

          if (mpirank < mpiend) then

             call s_mpisendint(potyu(nl(1), nu(2)), size(potyu(:,&
                  & nu(2))), mpirank+1, mpirequests(3))

          end if

          yusent = .true.

       elseif (mpistatuss(MPI_SOURCE, 2) == mpirank+1) then

          do j = nl(2), nu(2)

             do i = nl(1), nu(1)

                potyd(i, j) = modulo(potyd(i, j)+buffer(i), 4)

             end do

          end do

          if (mpirank > mpistart) then

             call s_mpisendint(potyd(nl(1), nl(2)), size(potyd(:,&
                  & nl(2))), mpirank-1, mpirequests(4))

          end if

          ydsent = .true.

       end if

    end do

    call s_mpiwaitall(size(mpirequests), mpirequests(1), mpistatuss(1&
         &, 1))

    deallocate(buffer)
#endif

    do j = nl(2), nu(2)

       do i = nl(1), nu(1)

          if (mask(i, j) .or. (potxl(i, j) == potxr(i, j) .and.&
               & potxl(i, j) > 0 .and. (potyu(i, j) > 0 .or. potyd(i,&
               & j) > 0)) .or. (potyu(i, j) == potyd(i, j) .and.&
               & potyu(i, j) > 0 .and. (potxl(i, j) > 0 .or. potxr(i,&
               & j) > 0))) then

             mask(i, j) = .true.

          else

             mask(i, j) = .false.

          end if

       end do

    end do

    deallocate(potxl, potxr, potyu, potyd)

 end subroutine s_fillmask

  subroutine s_circlemask(mask, nl, nu, centre, radius, width)

    !
    ! Define a circle mask
    !

    integer(idp), dimension(dim), intent(in) :: nl, nu
    logical, dimension(nl(1):nu(1), nl(2):nu(2)), intent(inout) ::&
         & mask
    real(fdp), dimension(dim), intent(in) :: centre
    real(fdp), intent(in) :: radius, width

    real(fdp), dimension(dim) :: position
    real(fdp) :: d
    integer(idp) :: i, j

    do j = nl(2), nu(2)

       do i = nl(1), nu(1)

          position = f_position( (/ i, j /) )

          d = abs(sqrt(sum((centre-position)**2))-radius)

          if (d <= width) then

             mask(i, j) = .true.

          end if

       end do

    end do

  end subroutine s_circlemask

  subroutine s_ellipsemask(mask, nl, nu, centre, xylen, width)

    !
    ! Define an ellipse mask
    !

    integer(idp), dimension(dim), intent(in) :: nl, nu
    logical, dimension(nl(1):nu(1), nl(2):nu(2)), intent(inout) ::&
         & mask
    real(fdp), dimension(dim), intent(in) :: centre, xylen
    real(fdp), intent(in) :: width

    real(fdp), dimension(dim) :: position
    real(fdp) :: d
    integer(idp) :: i, j

    do j = nl(2), nu(2)

       do i = nl(1), nu(1)

          position = f_position( (/ i, j /) )

          d =  abs(sqrt(sum((centre-position)**2))*(1.0d0-xylen(1)&
               &*xylen(2)/sqrt(sum(xylen**2*(centre-position)**2))))

          if (d <= width) then

             mask(i, j) = .true.

          end if

       end do

    end do

  end subroutine s_ellipsemask

  subroutine s_linemask(mask, nl, nu, point1, point2, width)

    !
    ! Define a line mask
    !

    integer(idp), dimension(dim), intent(in) :: nl, nu
    logical, dimension(nl(1):nu(1), nl(2):nu(2)), intent(inout) ::&
         & mask
    real(fdp), dimension(dim), intent(in) :: point1, point2
    real(fdp), intent(in) :: width

    real(fdp), dimension(dim) :: position
    real(fdp) :: a, b, c, d
    integer(idp) :: i, j

    c = sqrt(sum((point1-point2)**2))

    do j = nl(2), nu(2)

       do i = nl(1), nu(1)

          position = f_position( (/ i, j /) )

          a = sqrt(sum((point1-position)**2))

          b = sqrt(sum((point2-position)**2))

          d = sqrt(abs(-a**4+2*(b**2+c**2)*a**2-(b**2-c**2)**2))&
               &/2.0d0/c

          if (abs(a-d)/nm < sqrt(cutoff)) then

             d = a

          end if

          if (abs(b-d)/nm < sqrt(cutoff)) then

             d = b

          end if

          if ( abs(sqrt(a**2-d**2)+sqrt(b**2-d**2)-c)/nm <=&
               & sqrt(cutoff) .and. d <= width .or. a <= width .or. b&
               & <= width) then

             mask(i, j) = .true.

          end if

       end do

    end do

  end subroutine s_linemask

  subroutine s_circle(pot, mask, nl, nu)

    !
    ! Define a circle component in the potential
    !

    integer(idp), dimension(dim), intent(in) :: nl, nu
    complex(cdp), dimension(nl(1):nu(1), nl(2):nu(2)), intent(inout)&
         & :: pot
    logical, dimension(nl(1):nu(1), nl(2):nu(2)), intent(inout) ::&
         & mask

    logical, dimension(:, :), allocatable :: t_mask
    real(fdp), dimension(dim) :: centre, position
    real(fdp) :: radius, width, height

    allocate(t_mask(nl(1):nu(1), nl(2):nu(2)))

    t_mask = .false.

    read(potdata, '(2f, f, f, f)', advance='no') centre, radius,&
         & width, height

    call s_circlemask(t_mask, nl, nu, centre, radius, width)

    where (t_mask)

       pot = height

       mask = .true.

    end where

    deallocate(t_mask)

  end subroutine s_circle

  subroutine s_fillcircle(pot, mask, nl, nu)

    !
    ! Define a filled circle component in the potential
    !

    integer(idp), dimension(dim), intent(in) :: nl, nu
    complex(cdp), dimension(nl(1):nu(1), nl(2):nu(2)), intent(inout)&
         & :: pot
    logical, dimension(nl(1):nu(1), nl(2):nu(2)), intent(inout) ::&
         & mask

    logical, dimension(:, :), allocatable :: t_mask
    real(fdp), dimension(dim) :: centre
    real(fdp) :: radius, height

    allocate(t_mask(nl(1):nu(1), nl(2):nu(2)))

    t_mask = .false.

    read(potdata, '(f, f, 2f)', advance='no') centre, radius, height

    call s_circlemask(t_mask, nl, nu, centre, radius,&
         & sqrt(sum(parameters%gridspacing**2)))

    call s_fillmask(t_mask, nl, nu)

    where (t_mask)

       pot = height

       mask = .true.

    end where

    deallocate(t_mask)

  end subroutine s_fillcircle

  subroutine s_ellipse(pot, mask, nl, nu)

    !
    ! Define an ellipse component in the potential
    !

    integer(idp), dimension(dim), intent(in) :: nl, nu
    complex(cdp), dimension(nl(1):nu(1), nl(2):nu(2)), intent(inout)&
         & :: pot
    logical, dimension(nl(1):nu(1), nl(2):nu(2)), intent(inout) ::&
         & mask

    logical, dimension(:, :), allocatable :: t_mask
    real(fdp), dimension(dim) :: centre, xylen, position
    real(fdp) :: width, height

    allocate(t_mask(nl(1):nu(1), nl(2):nu(2)))

    t_mask = .false.

    read(potdata, '(2f, 2f, f, f)', advance='no') centre, xylen,&
         & width, height

    call s_ellipsemask(t_mask, nl, nu, centre, xylen, width)

    where (t_mask)

       pot = height

       mask = .true.

    end where

    deallocate(t_mask)

  end subroutine s_ellipse

  subroutine s_fillellipse(pot, mask, nl, nu)

    !
    ! Define a filled ellipse component in the potential
    !

    integer(idp), dimension(dim), intent(in) :: nl, nu
    complex(cdp), dimension(nl(1):nu(1), nl(2):nu(2)), intent(inout)&
         & :: pot
    logical, dimension(nl(1):nu(1), nl(2):nu(2)), intent(inout) ::&
         & mask

    logical, dimension(:, :), allocatable :: t_mask
    real(fdp), dimension(dim) :: centre, xylen
    real(fdp) :: height

    allocate(t_mask(nl(1):nu(1), nl(2):nu(2)))

    t_mask = .false.

    read(potdata, '(2f, 2f, f)', advance='no') centre, xylen, height

    call s_ellipsemask(t_mask, nl, nu, centre, xylen,&
         & sqrt(sum(parameters%gridspacing**2)))

    call s_fillmask(t_mask, nl, nu)

    where (t_mask)

       pot = height

       mask = .true.

    end where

    deallocate(t_mask)

  end subroutine s_fillellipse

  subroutine s_line(pot, mask, nl, nu)

    !
    ! Define a line component in the potential
    !

    integer(idp), dimension(dim), intent(in) :: nl, nu
    complex(cdp), dimension(nl(1):nu(1), nl(2):nu(2)), intent(inout)&
         & :: pot
    logical, dimension(nl(1):nu(1), nl(2):nu(2)), intent(inout) ::&
         & mask

    logical, dimension(:, :), allocatable :: t_mask
    real(fdp), dimension(dim) :: point1, point2, position
    real(fdp) :: width, height

    allocate(t_mask(nl(1):nu(1), nl(2):nu(2)))

    t_mask = .false.

    read(potdata, '(2f, 2f, f, f)', advance='no') point1, point2,&
         & width, height

    call s_linemask(t_mask, nl, nu, point1, point2, width)

    where (t_mask)

       pot = height

       mask = .true.

    end where

    deallocate(t_mask)

  end subroutine s_line

  subroutine s_ramp(pot, mask, nl, nu)

    !
    ! Define a straight line ramp component in the potential
    !

    integer(idp), dimension(dim), intent(in) :: nl, nu
    complex(cdp), dimension(nl(1):nu(1), nl(2):nu(2)), intent(inout)&
         & :: pot
    logical, dimension(nl(1):nu(1), nl(2):nu(2)), intent(inout) ::&
         & mask

    real(fdp), dimension(dim) :: point1, point2, position
    real(fdp) :: width, a, b, c, d, height_to, height_from
    integer(idp) :: i, j

    read(potdata, '(2f, 2f, f, f, f)', advance='no') point1, point2,&
         & width, height_from, height_to

    c = sqrt(sum((point1-point2)**2))

    do j = nl(2), nu(2)

       do i = nl(1), nu(1)

          position = f_position( (/ i, j /) )

          a = sqrt(sum((point1-position)**2))

          b = sqrt(sum((point2-position)**2))

          d = sqrt(abs(-a**4+2*(b**2+c**2)*a**2-(b**2-c**2)**2))&
               &/2.0d0/c

          if (abs(a-d)/nm < sqrt(cutoff)) then

             d = a

          end if

          if (abs(b-d)/nm < sqrt(cutoff)) then

             d = b

          end if

          if ( abs(sqrt(a**2-d**2)+sqrt(b**2-d**2)-c)/nm <=&
               & sqrt(cutoff) .and. (d <= width .or. a <= width .or.&
               & b <= width)) then

             pot(i, j) = (height_to-height_from)*sqrt(a**2-d**2)/c&
                  &+height_from

             mask(i, j) = .true.

          end if

       end do

    end do

  end subroutine s_ramp

  subroutine s_polygon(pot, mask, nl, nu)

    !
    ! Define an arbitrary shaped polygone component in the potential
    !

    integer(idp), dimension(dim), intent(in) :: nl, nu
    complex(cdp), dimension(nl(1):nu(1), nl(2):nu(2)), intent(inout)&
         & :: pot
    logical, dimension(nl(1):nu(1), nl(2):nu(2)), intent(inout) ::&
         & mask

    logical, dimension(:, :), allocatable :: t_mask
    real(fdp) :: height, width
    real(fdp), dimension(dim) :: point1, point2, point3

    allocate(t_mask(nl(1):nu(1), nl(2):nu(2)))

    t_mask = .false.

    read(potdata, '(f, f, 2f)', advance='no') width, height, point1

    point2 = point1

    point3 = point1 + 1.0d0

    do while(sum(abs(point1-point3))/nm > sqrt(cutoff))

       read(potdata, '(2f)', advance='no') point3

       call s_linemask(t_mask, nl, nu, point2, point3, width)

       point2 = point3

    end do

    where (t_mask)

       pot = height

       mask = .true.

    end where

    deallocate(t_mask)

  end subroutine s_polygon

  subroutine s_fillpolygon(pot, mask, nl, nu)

    !
    ! Define a filled arbitrary shaped polygon component in the
    ! potential
    !

    integer(idp), dimension(dim), intent(in) :: nl, nu
    complex(cdp), dimension(nl(1):nu(1), nl(2):nu(2)), intent(inout)&
         & :: pot
    logical, dimension(nl(1):nu(1), nl(2):nu(2)), intent(inout) ::&
         & mask

    logical, dimension(:, :), allocatable :: t_mask
    real(fdp) :: height
    real(fdp), dimension(dim) :: point1, point2, point3

    allocate(t_mask(nl(1):nu(1), nl(2):nu(2)))

    t_mask = .false.

    read(potdata, '(f, 2f)', advance='no') height, point1

    point2 = point1

    point3 = point1 + 1.0d0

    do while(sum(abs(point1-point3))/nm > sqrt(cutoff))

       read(potdata, '(2f)', advance='no') point3

       call s_linemask(t_mask, nl, nu, point2, point3,&
            & sqrt(sum(parameters%gridspacing**2)))

       point2 = point3

    end do

    call s_fillmask(t_mask, nl, nu)

    where (t_mask)

       pot = height

       mask = .true.

    end where

    deallocate(t_mask)

  end subroutine s_fillpolygon

  subroutine s_potfn(pot, mask, nl, nu)

    !
    ! Define an arbitrary mathematical function component in the
    ! potential
    !

    integer(idp), dimension(dim), intent(in) :: nl, nu
    complex(cdp), dimension(nl(1):nu(1), nl(2):nu(2)), intent(inout)&
         & :: pot
    logical, dimension(nl(1):nu(1), nl(2):nu(2)), intent(inout) ::&
         & mask

    integer(idp) :: i, j
    character(len = maxstringlength) :: func, func_t
    real(fdp), dimension(2+size(constantvalues)) :: t_vals

    read(potdata, '(a)', advance='no') func

    t_vals(3:) = constantvalues

    do j=nl(2), nu(2)

       do i=nl(1), nu(1)

          t_vals(1:2) = f_position( (/ i, j/) )

          pot(i, j) = f_evaluatefn(func, 'X Y'//' '//constants,&
               & t_vals )

       end do

    end do

    where (real(pot*conjg(pot))/nm > sqrt(cutoff))

       mask = .true.

    end where

  end subroutine s_potfn

  subroutine s_bpoty(delx, vecpotfny, vecpotfn2, nl, nu)

    !
    ! Define the vector potential function such that
    !
    ! A = b*(-y, 0, 0)
    ! B = curl A = (0, 0, b)
    !

    integer(idp), dimension(dim), intent(in) :: nl, nu
    complex(cdp), dimension(nl(1):nu(1), nl(2):nu(2)) :: delx,&
         & vecpotfn2
    real(fdp), dimension(nl(1):nu(1), nl(2):nu(2)) :: vecpotfny

    complex(cdp), dimension(:, :), allocatable :: tmp
    integer(idp) :: i, j
    real(fdp) :: x, y

    allocate(tmp(nl(1):nu(1), nl(2):nu(2)))

    vecpotfny = 0.0d0

    do j = nl(2), nu(2)

       y = f_positiony(j) - parameters%position(2)

       do i = nl(1), nu(1)

          x = f_positionx(i) - parameters%position(1)

          vecpotfny(i, j) = - y*parameters%externalb

       end do

    end do

    !
    ! Blur the vector potential function
    !

    tmp = vecpotfny

    call s_smoothedge(tmp, nl, nu, parameters%smooth)

    vecpotfny = real(tmp)

    !
    ! Define the vector potential function squared
    !

    vecpotfn2 = vecpotfny**2

    !
    ! Compute the actual magnetic field from the above vector
    ! potential.  This is done just for a check.
    !

    if (parameters%plotpot) then

       !
       ! Define the first derivatives d/dy and temporarily store it
       ! in delx
       !

       call s_momentumfac(delx, nl, nu, (/ 0.0d0, 1.0d0 /)&
            &/dble(product(parameters%n)), (/ 0, 1 /))

       tmp = vecpotfny

       call s_c2dfft(tmp, nl, nu, fftfor)

       tmp = tmp*delx

       call s_c2dfft(tmp, nl, nu, fftbac)

       call s_write2drarray(real(-tmp), nl, nu, filename='bfield',&
            & incboundary=.true.)
       call s_write2drarray(vecpotfny, nl, nu, filename='vecpoty',&
            & incboundary=.true.)

    end if

    !
    ! Define the first derivatives d/dx
    !

    call s_momentumfac(delx, nl, nu, (/ 1.0d0, 0.0d0 /)&
         &/dble(product(parameters%n)), (/ 1, 0 /))

    !
    ! Compute the cross terms
    !

    tmp = vecpotfny

    call s_c2dfft(tmp, nl, nu, fftfor)

    tmp = tmp*delx

    call s_c2dfft(tmp, nl, nu, fftbac)

    !
    ! Include terms for speed
    !

    delx = delx*ii*hbar
    vecpotfny = vecpotfny/parameters%mass*chargee
    vecpotfn2 = vecpotfn2/2.0d0/parameters%mass*chargee**2+tmp/2.0d0/parameters%mass*ii*chargee*hbar

    deallocate(tmp)

  end subroutine s_bpoty

  subroutine s_bpotyx(delx, dely, vecpotfnx, vecpotfny, vecpotfn2, nl&
       &, nu)

    !
    ! Define the vector potential function such that
    !
    ! A = b/2*(-y, x, 0)
    ! B = curl A = (0, 0, b)
    !

    integer(idp), dimension(dim), intent(in) :: nl, nu
    complex(cdp), dimension(nl(1):nu(1), nl(2):nu(2)) :: delx, dely,&
         & vecpotfn2
    real(fdp), dimension(nl(1):nu(1), nl(2):nu(2)) :: vecpotfnx, &
         & vecpotfny

    complex(cdp), dimension(:, :), allocatable :: tmpx, tmpy
    integer(idp) :: i, j
    real(fdp) :: norm, x, y

    allocate(tmpx(nl(1):nu(1), nl(2):nu(2)), tmpy(nl(1):nu(1),&
         & nl(2):nu(2)))

    vecpotfnx = 0.0d0
    vecpotfny = 0.0d0

    do j = nl(2), nu(2)

       y = f_positiony(j) - parameters%position(2)

       do i = nl(1), nu(1)

          x = f_positionx(i) - parameters%position(1)

          vecpotfny(i, j) = -y*parameters%externalb/2.0d0
          vecpotfnx(i, j) = x*parameters%externalb/2.0d0

       end do

    end do

    !
    ! Blur the vector potential function
    !

    tmpy = vecpotfny
    tmpx = vecpotfnx

    call s_smoothedge(tmpy, nl, nu, parameters%smooth)
    call s_smoothedge(tmpx, nl, nu, parameters%smooth)

    vecpotfny = real(tmpy)
    vecpotfnx = real(tmpx)

    !
    ! Define the vector potential function squared
    !

    vecpotfn2 = vecpotfnx**2 + vecpotfny**2

    !
    ! Define the first derivatives d/dx and d/dy
    !

    call s_momentumfac(delx, nl, nu, (/ 1.0d0, 0.0d0 /)&
         &/dble(product(parameters%n)), (/ 1, 0 /))
    call s_momentumfac(dely, nl, nu, (/ 0.0d0, 1.0d0 /)&
         &/dble(product(parameters%n)), (/ 0, 1 /))

    !
    ! Compute the actual magnetic field from the above vector
    ! potential.  This is done just for a check.
    !

    if (parameters%plotpot) then

       tmpy = vecpotfny
       tmpx = vecpotfnx

       call s_c2dfft(tmpy, nl, nu, fftfor)
       call s_c2dfft(tmpx, nl, nu, fftfor)

       tmpy = tmpy*dely
       tmpx = tmpx*delx

       call s_c2dfft(tmpy, nl, nu, fftbac)
       call s_c2dfft(tmpx, nl, nu, fftbac)

       call s_write2drarray(real(tmpx-tmpy), nl, nu, filename&
            &='bfield', incboundary=.true.)
       call s_write2drarray(vecpotfny, nl, nu, filename='vecpoty',&
            & incboundary=.true.)
       call s_write2drarray(vecpotfnx, nl, nu, filename='vecpotx',&
            & incboundary=.true.)

    end if

    !
    ! Compute the cross terms
    !

    tmpy = vecpotfny
    tmpx = vecpotfnx

    call s_c2dfft(tmpy, nl, nu, fftfor)
    call s_c2dfft(tmpx, nl, nu, fftfor)

    tmpy = tmpy*delx
    tmpx = tmpx*dely

    call s_c2dfft(tmpy, nl, nu, fftbac)
    call s_c2dfft(tmpx, nl, nu, fftbac)

    !
    ! Include terms for speed
    !

    delx = delx*ii*hbar
    dely = dely*ii*hbar
    vecpotfnx = vecpotfnx/parameters%mass*chargee
    vecpotfny = vecpotfny/parameters%mass*chargee
    vecpotfn2 = vecpotfn2/2.0d0/parameters%mass*chargee**2 + (tmpx&
         &+tmpy)/2.0d0/parameters%mass*ii*chargee*hbar

    deallocate(tmpx, tmpy)

  end subroutine s_bpotyx

  subroutine s_bpotxyxy(delxy, vecpotfn, vecpotfn2, nl, nu)

    !
    ! Define the vector potential function such that
    !
    ! A = b/2*(x-y, x-y, 0)
    ! B = curl A = (0, 0, b)
    !

    integer(idp), dimension(dim), intent(in) :: nl, nu
    complex(cdp), dimension(nl(1):nu(1), nl(2):nu(2)) :: delxy,&
         & vecpotfn2
    real(fdp), dimension(nl(1):nu(1), nl(2):nu(2)) :: vecpotfn

    complex(cdp), dimension(:, :), allocatable :: tmp
    integer(idp) :: i, j
    real(fdp) :: x, y

    allocate(tmp(nl(1):nu(1), nl(2):nu(2)))

    vecpotfn = 0.0d0

    do j = nl(2), nu(2)

       y = f_positiony(j) - parameters%position(2)

       do i = nl(1), nu(1)

          x = f_positionx(i) - parameters%position(1)

          vecpotfn(i, j) = (x - y)*parameters%externalb/2.0d0

       end do

    end do

    !
    ! Blur the vector potential function
    !

    tmp = vecpotfn

    call s_smoothedge(tmp, nl, nu, parameters%smooth)

    vecpotfn = real(tmp)

    !
    ! Define the vector potential function squared
    !

    vecpotfn2 = vecpotfn**2

    !
    ! Compute the actual magnetic field from the above vector
    ! potential.  This is done just for a check.
    !

    if (parameters%plotpot) then

       !
       ! Define the first derivatives d/dx-d/dy
       !

       call s_momentumfac(delxy, nl, nu, (/ 1.0d0, -1.0d0 /)&
            &/dble(product(parameters%n)), (/ 1, 1 /))

       !
       ! Include normlaisation for speed
       !

       tmp = vecpotfn

       call s_c2dfft(tmp, nl, nu, fftfor)

       tmp = tmp*delxy

       call s_c2dfft(tmp, nl, nu, fftbac)

       call s_write2drarray(real(tmp), nl, nu, filename='bfield',&
            & incboundary=.true.)
       call s_write2drarray(vecpotfn, nl, nu, filename='vecpot',&
            & incboundary=.true.)

    end if

    !
    ! Define the first derivatives d/dx+d/dy
    !

    call s_momentumfac(delxy, nl, nu, (/ 1.0d0, 1.0d0 /)&
         &/dble(product(parameters%n)), (/ 1, 1 /))

    !
    ! Compute derivative of vector potential function
    !

    tmp = vecpotfn

    call s_c2dfft(tmp, nl, nu, fftfor)

    tmp = tmp*delxy

    call s_c2dfft(tmp, nl, nu, fftbac)

    !
    ! Include terms for speed
    !

    delxy = delxy*ii*hbar
    vecpotfn = vecpotfn/parameters%mass*chargee
    vecpotfn2 = vecpotfn2/parameters%mass*chargee**2 + tmp*ii*hbar&
         &*chargee/2.0d0/parameters%mass

    deallocate(tmp)

  end subroutine s_bpotxyxy

  subroutine s_bpotfft(delf, vecpotfn, vecpotfn2, nl, nu)

    !
    ! Define the vector potential function such that
    !
    ! A = b/2*(f, f, 0)
    ! B = curl A = (0, 0, b)
    !
    ! by direct solution using fft's.
    !

    integer(idp), dimension(dim), intent(in) :: nl, nu
    complex(cdp), dimension(nl(1):nu(1), nl(2):nu(2)) :: delf,&
         & vecpotfn2
    real(fdp), dimension(nl(1):nu(1), nl(2):nu(2)) :: vecpotfn

    complex(cdp), dimension(:, :), allocatable :: tmp

    allocate(tmp(nl(1):nu(1), nl(2):nu(2)))

    !
    ! Compute the actual magnetic field with the smoothed boundary
    !

    tmp = parameters%externalb

    call s_smoothedge(tmp, nl, nu, parameters%smooth)

    !
    ! Compute the momentum factor representation for grad operator
    !

    call s_momentumfac(delf, nl, nu, (/ 1.0d0, -1.0d0 /)&
         &/dble(product(parameters%n)), (/ 1, 1 /))

    !
    ! Solve for vector potential
    !

    call s_c2dfft(tmp, nl, nu, fftfor)

    where(abs(delf) < cutoff)

       tmp = cutoff

    elsewhere

       tmp = tmp/delf

    end where

    call s_c2dfft(tmp, nl, nu, fftbac)

    vecpotfn = real(tmp)
    vecpotfn2 = vecpotfn**2

    !
    ! Plot potential if required
    !

    if (parameters%plotpot) then

       !
       ! Define the first derivatives d/dx-d/dy
       !

       call s_momentumfac(delf, nl, nu, (/ 1.0d0, -1.0d0 /)&
            &/dble(product(parameters%n)), (/ 1, 1 /))

       !
       ! Include normlaisation for speed
       !

       tmp = vecpotfn

       call s_c2dfft(tmp, nl, nu, fftfor)

       tmp = tmp*delf

       call s_c2dfft(tmp, nl, nu, fftbac)

       call s_write2drarray(real(tmp), nl, nu, filename='bfield',&
            & incboundary=.true.)
       call s_write2drarray(vecpotfn, nl, nu, filename='vecpot',&
            & incboundary=.true.)

    end if

    !
    ! Define the first derivatives d/dx+d/dy
    !

    call s_momentumfac(delf, nl, nu, (/ 1.0d0, 1.0d0 /)&
         &/dble(product(parameters%n)), (/ 1, 1 /))

    !
    ! Compute derivative of vector potential function
    !

    tmp = vecpotfn

    call s_c2dfft(tmp, nl, nu, fftfor)

    tmp = tmp*delf

    call s_c2dfft(tmp, nl, nu, fftbac)

    !
    ! Include terms for speed
    !

    delf = delf*ii*hbar
    vecpotfn = vecpotfn/parameters%mass*chargee
    vecpotfn2 = vecpotfn2/parameters%mass*chargee**2 + tmp*ii*hbar&
         &*chargee/2.0d0/parameters%mass

    deallocate(tmp)

  end subroutine s_bpotfft

end module potential


c program bestscale

      include 'VICMAIN_FOR'
      subroutine main44

      parameter (nlmax=1100,nsmax=1100)
      real*4 inbuf(nsmax,nlmax),obuf(nsmax,nlmax)
      real*4 scale(2),refbuf(nsmax,nlmax)
      real*4 cor(100),sc(100)
      integer*4 count,def,status,unit,ounit
      real*8 r,sumx,sumy,sumx2,sumy2,sumxy

      call xvpcnt('INP',nin)
      call xvpcnt('OUT',nout)

c parameters
      call xveaction('SA',' ')
      call xvpcnt('INP',nin)
      call xvpcnt('OUT',nout)
      if(nin.ne.nout)then
        write(*,*)'inputs must match outputs in number'
        call abend
      endif
      call xvparm('SCALE',scale,count,def,2)

c open input1
      call xvunit(unit,'INP',1,status,' ')
      call xvopen(unit,status,'U_FORMAT','REAL',' ')
      call xvget(unit,status,'NL',nl,'NS',ns,' ')
      if(ns.gt.nsmax)then
          call xvmessage('Line length too long',' ')
          call abend
      endif
      if(nl.gt.nlmax)then
          call xvmessage('Line column too long',' ')
          call abend
      endif

c open output1
      call xvunit(ounit,'OUT',1,status,' ')
      call xvopen(ounit,status,'U_FORMAT','REAL',
     +              'OP','WRITE',' ')

c copy first input to first output
      do j=1,nl
        call xvread(unit,refbuf(1,j),status,'LINE',j,' ')
        call xvwrit(ounit,refbuf(1,j),status,' ')
      enddo
      call xvclose(unit,status,'CLOS_ACT','FREE',' ')
      call xvclose(ounit,status,'CLOS_ACT','FREE',' ')

      sinc=(scale(2)-scale(1))/50. ! can go to 100
      cx=ns/2.0
      cy=nl/2.0
      inc=5
      mode=0 ! bilinear
      write(*,*)'Image   scale   correlation'
      write(*,*)1,1.0,1.0
      inp=1
10    inp=inp+1

c read next image
      call xvselpi(inp) ! use this input label for the output.
      call xvunit(unit,'INP',inp,status,' ')
      call xvopen(unit,status,'U_FORMAT','REAL',' ')
      do j=1,nl
        call xvread(unit,inbuf(1,j),status,'LINE',j,' ')
      enddo

c compute correlations between each image and refimage
c as a function of scale.
      k=0
      do s=scale(1),scale(2),sinc
        k=k+1
        n=0
        sumx=0.d0
        sumx2=0.d0
        sumy=0.d0
        sumy2=0.d0
        sumxy=0.d0
        do j=1,nl,inc
          y=(j-cy)*s+cy
          do i=1,ns,inc
            x=(i-cx)*s+cx
            call interpolate(inbuf,nlmax,nsmax,nl,ns,mode,
     +                         x,y,dn,ind)
            if(ind.eq.0)then
              n=n+1
              sumx=sumx+refbuf(i,j)
              sumx2=sumx2+refbuf(i,j)*refbuf(i,j)
              sumy=sumy+dn
              sumy2=sumy2+dn*dn
              sumxy=sumxy+refbuf(i,j)*dn
            endif
          enddo
        enddo
        r=(sumxy-sumx*sumy/n)**2/
     +    ((sumx2-sumx**2/n)*(sumy2-sumy**2/n))
        cor(k)=dsqrt(r)
        sc(k)=s
c        write(*,*)k,sc(k),cor(k)
      enddo

c obtain the best estimate for the scale
      best=-1.0
      do i=1,k
        if(cor(i).gt.best)then
          best=cor(i)
          n=i
        endif
      enddo
      if(n.eq.1)then
        s=sc(1)
      else if(n.eq.k)then
        s=sc(k)
      else
        s=sc(n)-0.5*
     +    ((sc(n)-sc(n-1))**2*(cor(n)-cor(n+1))-(sc(n)-sc(n+1))**2*
     +    (cor(n)-cor(n-1)))  /
     +    ((sc(n)-sc(n-1))*(cor(n)-cor(n+1))-(sc(n)-sc(n+1))*
     +    (cor(n)-cor(n-1)))
      endif
      write(*,*)inp,s,cor(n)

c generate image at best scale
      do j=1,nl
        y=(j-cy)*s+cy
        do i=1,ns
          x=(i-cx)*s+cx
          call interpolate(inbuf,nlmax,nsmax,nl,ns,mode,
     +                         x,y,dn,ind)
          obuf(i,j)=dn
        enddo
      enddo

c write next output
      call xvunit(ounit,'OUT',inp,status,' ')
      call xvopen(ounit,status,'U_FORMAT','REAL',
     +              'OP','WRITE',' ')
      do j=1,nl
        call xvwrit(ounit,obuf(1,j),status,' ')
      enddo
      call xvclose(unit,status,'CLOS_ACT','FREE',' ')
      call xvclose(ounit,status,'CLOS_ACT','FREE',' ')

      if(inp.lt.nin)goto 10

      return
      end

      subroutine interpolate(inbuf,nlbuf,nsbuf,nl,ns,mode,
     +  x,y,dn,ind)
c inbuf of dimension nsbuf by nlbuf, input , real, ns by nl data.
c mode is the interpolation mode.
c mode=0 bilinear interpolation, 4 neighbors.
c mode=1 nearest neighbor.
c mode=2 2nd order, 6 neighbors.
c mode=3 sampling theorem, 15 by 15 convolution.
c mode=4 bicubic spline
c x,y are real coordinates of input point, input, real.
c dn is interpolated intensity, returned, real.
c ind=0 if dn computed ok. ind=1 if x,y out of bounds.
c    returned, integer.
c If ind=0 on return, dn is set to zero.

      parameter (kerw=9)
      real*4 inbuf(nsbuf,nlbuf),tw,bw,lw,rw
      real*4 kerx(-kerw:kerw),kery(-kerw:kerw)
      real*4 ya(4),y1(4),y2(4),y12(4),c(4,4),cl(16),xa(16)
      real*4 wt(16,16)
      DATA WT/1.,0.,-3.,2.,4*0.,-3.,0.,9.,-6.,2.,0.,-6.,
     *  4.,8*0.,3.,0.,-9.,6.,-2.,0.,6.,-4.,10*0.,9.,-6.,
     *  2*0.,-6.,4.,2*0.,3.,-2.,6*0.,-9.,6.,2*0.,6.,-4.,
     *  4*0.,1.,0.,-3.,2.,-2.,0.,6.,-4.,1.,0.,-3.,2.,8*0.,
     *  -1.,0.,3.,-2.,1.,0.,-3.,2.,10*0.,-3.,2.,2*0.,3.,
     *  -2.,6*0.,3.,-2.,2*0.,-6.,4.,2*0.,3.,-2.,0.,1.,-2.,
     *  1.,5*0.,-3.,6.,-3.,0.,2.,-4.,2.,9*0.,3.,-6.,3.,0.,
     *  -2.,4.,-2.,10*0.,-3.,3.,2*0.,2.,-2.,2*0.,-1.,1.,
     *  6*0.,3.,-3.,2*0.,-2.,2.,5*0.,1.,-2.,1.,0.,-2.,4.,
     *  -2.,0.,1.,-2.,1.,9*0.,-1.,2.,-1.,0.,1.,-2.,1.,10*0.,
     *  1.,-1.,2*0.,-1.,1.,6*0.,-1.,1.,2*0.,2.,-2.,2*0.,-1.,1./

      ind=1
      dn=0.0

      if(mode.eq.0)then ! bilinear
        i=x
        j=y
        if(i.lt.1)return
        if(j.lt.1)return
        if(i.ge.ns)return
        if(j.ge.nl)return
        ind=0
        lw=x-i
        rw=1.0-lw
        tw=y-j
        bw=1.0-tw
        top=lw*inbuf(i+1,j)+rw*inbuf(i,j)
        bot=lw*inbuf(i+1,j+1)+rw*inbuf(i,j+1)
        dn=bw*top+tw*bot

      else if(mode.eq.1)then ! nearest neighbor
        i=nint(x)
        j=nint(y)
        if(i.lt.1)return
        if(j.lt.1)return
        if(i.gt.ns)return
        if(j.gt.nl)return
        ind=0
        dn=inbuf(i,j)

      else if(mode.eq.2)then ! second order
        i=nint(x)
        j=nint(y)
        if(i.lt.2)return
        if(j.lt.2)return
        if(i.ge.ns)return
        if(j.ge.nl)return
        ind=0
        p=x-i
        q=y-j
        dn=q*(q-1.0)*0.5*inbuf(i,j-1)+
     +     p*(p-1.0)*0.5*inbuf(i-1,j)+
     +    (1.0+p*q-p*p-q*q)*inbuf(i,j)+
     +    p*(p-2.0*q+1.0)*0.5*inbuf(i+1,j)+
     +    q*(q-2.0*p+1.0)*0.5*inbuf(i,j+1)+
     +    p*q*inbuf(i+1,j+1)

      else if(mode.eq.3)then ! Sampling Theorem
        ii=nint(x)
        jj=nint(y)
        if(ii-kerw.lt.1)return
        if(jj-kerw.lt.1)return
        if(ii+kerw.gt.ns)return
        if(jj+kerw.gt.nl)return
        pi=3.14159
        ind=0
        xx=x-ii
        do i=-kerw,kerw
          d=pi*(i-xx)
          if(d.ne.0.0)then
            kerx(i)=sin(d)/d
          else
            kerx(i)=1.0
          endif
        enddo
        yy=y-jj
        do j=-kerw,kerw
          d=pi*(j-yy)
          if(d.ne.0.0)then
            kery(j)=sin(d)/d
          else
            kery(j)=1.0
          endif
        enddo
        dn=0.0
        do j=-kerw,kerw
          do i=-kerw,kerw
            dn=dn+kery(j)*kerx(i)*inbuf(ii+i,jj+j)
          enddo
        enddo

      else if(mode.eq.4)then ! bicubic spline
        i=x
        j=y
        if(i.lt.2)return
        if(j.lt.2)return
        if(i.gt.ns-2)return
        if(j.gt.nl-2)return
        ind=0
        ya(1)=inbuf(i,j)
        ya(2)=inbuf(i+1,j)
        ya(3)=inbuf(i+1,j+1)
        ya(4)=inbuf(i,j+1)
        y1(1)=(inbuf(i+1,j)-inbuf(i-1,j))/2.0
        y1(2)=(inbuf(i+2,j)-inbuf(i,j))/2.0
        y1(3)=(inbuf(i+2,j+1)-inbuf(i,j+1))/2.0
        y1(4)=(inbuf(i+1,j+1)-inbuf(i-1,j+1))/2.0
        y2(1)=(inbuf(i,j+1)-inbuf(i,j-1))/2.0
        y2(2)=(inbuf(i+1,j+1)-inbuf(i+1,j-1))/2.0
        y2(3)=(inbuf(i+1,j+2)-inbuf(i+1,j))/2.0
        y2(4)=(inbuf(i,j+2)-inbuf(i,j))/2.0
        y12(1)=(inbuf(i+1,j+1)-inbuf(i+1,j-1)-
     +          inbuf(i-1,j+1)+inbuf(i-1,j-1))/4.0
        y12(2)=(inbuf(i+2,j+1)-inbuf(i+2,j-1)-
     +          inbuf(i,j+1)+inbuf(i,j-1))/4.0
        y12(3)=(inbuf(i+2,j+2)-inbuf(i+2,j)-
     +          inbuf(i,j+2)+inbuf(i,j))/4.0
        y12(4)=(inbuf(i+1,j+2)-inbuf(i+1,j)-
     +          inbuf(i-1,j+2)+inbuf(i-1,j))/4.0
        ii=i
        jj=j
        DO 11 I=1,4
          Xa(I)=Ya(I)
          Xa(I+4)=Y1(I)
          Xa(I+8)=Y2(I)
          Xa(I+12)=Y12(I)
11      CONTINUE
        DO 13 I=1,16
          XX=0.
          DO 12 K=1,16
            XX=XX+WT(I,K)*Xa(K)
12        CONTINUE
          CL(I)=XX
13      CONTINUE
        L=0
        DO 15 I=1,4
          DO 14 J=1,4
            L=L+1
            C(I,J)=CL(L)
14        CONTINUE
15      CONTINUE
        T=x-ii
        U=y-jj
        dn=0.
        DO 16 I=4,1,-1
          dn=T*dn+((C(I,4)*U+C(I,3))*U+C(I,2))*U+C(I,1)
16      CONTINUE

      else
        write(*,*)'INTERPOLATE: invalid mode'
        stop
      endif
      return
      end


! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! The Reaction Rates File
!
! Generated by KPP-2.1 symbolic chemistry Kinetics PreProcessor
!       (http://www.cs.vt.edu/~asandu/Software/KPP)
! KPP is distributed under GPL, the general public licence
!       (http://www.gnu.org/copyleft/gpl.html)
! (C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa
! (C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech
!     With important contributions from:
!        M. Damian, Villanova University, USA
!        R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany
!
! File                 : racmpm_Rates.f90
! Time                 : Wed Jun 14 17:35:27 2017
! Working directory    : /data/ksetigui/setigui/WRFnew/chem/KPP/mechanisms/racmpm
! Equation file        : racmpm.kpp
! Output root filename : racmpm
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

MODULE racmpm_Rates

  USE racmpm_Parameters
  USE racmpm_Global
  IMPLICIT NONE

CONTAINS

! Begin Rate Law Functions from KPP_HOME/util/UserRateLaws

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!  User-defined Rate Law functions
!  Note: the default argument type for rate laws, as read from the equations file, is single precision
!        but all the internal calculations are performed in double precision
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

!~~~>  Arrhenius
   REAL(kind=dp) FUNCTION ARR( A0,B0,C0 )
      REAL A0,B0,C0
      ARR =  DBLE(A0) * EXP(-DBLE(B0)/TEMP) * (TEMP/300.0_dp)**DBLE(C0)
   END FUNCTION ARR

!~~~> Simplified Arrhenius, with two arguments
!~~~> Note: The argument B0 has a changed sign when compared to ARR
   REAL(kind=dp) FUNCTION ARR2( A0,B0 )
      REAL A0,B0
      ARR2 =  DBLE(A0) * EXP( DBLE(B0)/TEMP )
   END FUNCTION ARR2

   REAL(kind=dp) FUNCTION EP2(A0,C0,A2,C2,A3,C3)
      REAL A0,C0,A2,C2,A3,C3
      REAL(dp) K0,K2,K3
      K0 = DBLE(A0) * EXP(-DBLE(C0)/TEMP)
      K2 = DBLE(A2) * EXP(-DBLE(C2)/TEMP)
      K3 = DBLE(A3) * EXP(-DBLE(C3)/TEMP)
      K3 = K3*CFACTOR*1.0E6_dp
      EP2 = K0 + K3/(1.0_dp+K3/K2 )
   END FUNCTION EP2

   REAL(kind=dp) FUNCTION EP3(A1,C1,A2,C2)
      REAL A1, C1, A2, C2
      REAL(dp) K1, K2
      K1 = DBLE(A1) * EXP(-DBLE(C1)/TEMP)
      K2 = DBLE(A2) * EXP(-DBLE(C2)/TEMP)
      EP3 = K1 + K2*(1.0E6_dp*CFACTOR)
   END FUNCTION EP3

   REAL(kind=dp) FUNCTION FALL ( A0,B0,C0,A1,B1,C1,CF)
      REAL A0,B0,C0,A1,B1,C1,CF
      REAL(dp) K0, K1
      K0 = DBLE(A0) * EXP(-DBLE(B0)/TEMP)* (TEMP/300.0_dp)**DBLE(C0)
      K1 = DBLE(A1) * EXP(-DBLE(B1)/TEMP)* (TEMP/300.0_dp)**DBLE(C1)
      K0 = K0*CFACTOR*1.0E6_dp
      K1 = K0/K1
      FALL = (K0/(1.0_dp+K1))*   &
           DBLE(CF)**(1.0_dp/(1.0_dp+(LOG10(K1))**2))
   END FUNCTION FALL

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

  ELEMENTAL REAL(dp) FUNCTION k_3rd(temp,cair,k0_300K,n,kinf_300K,m,fc)

    INTRINSIC LOG10

    REAL(dp), INTENT(IN) :: temp      ! temperature [K]
    REAL(dp), INTENT(IN) :: cair      ! air concentration [molecules/cm3]
    REAL,     INTENT(IN) :: k0_300K   ! low pressure limit at 300 K
    REAL,     INTENT(IN) :: n         ! exponent for low pressure limit
    REAL,     INTENT(IN) :: kinf_300K ! high pressure limit at 300 K
    REAL,     INTENT(IN) :: m         ! exponent for high pressure limit
    REAL,     INTENT(IN) :: fc        ! broadening factor (usually fc=0.6)
    REAL                 :: zt_help, k0_T, kinf_T, k_ratio

    zt_help = 300._dp/temp
    k0_T    = k0_300K   * zt_help**(n) * cair ! k_0   at current T
    kinf_T  = kinf_300K * zt_help**(m)        ! k_inf at current T
    k_ratio = k0_T/kinf_T
    k_3rd   = k0_T/(1._dp+k_ratio)*fc**(1._dp/(1._dp+LOG10(k_ratio)**2))

  END FUNCTION k_3rd

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

  ELEMENTAL REAL(dp) FUNCTION k_arr (k_298,tdep,temp)
    ! Arrhenius function

    REAL,     INTENT(IN) :: k_298 ! k at T = 298.15K
    REAL,     INTENT(IN) :: tdep  ! temperature dependence
    REAL(dp), INTENT(IN) :: temp  ! temperature

    INTRINSIC EXP

    k_arr = k_298 * EXP(tdep*(1._dp/temp-3.3540E-3_dp)) ! 1/298.15=3.3540e-3

  END FUNCTION k_arr

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!  End of User-defined Rate Law functions
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

! End Rate Law Functions from KPP_HOME/util/UserRateLaws

! Begin INLINED Rate Law Functions

REAL(KIND=dp) FUNCTION k46( TEMP, C_M )
    REAL(KIND=dp), INTENT(IN) :: temp, c_m
    REAL(KIND=dp) :: k0, k2, k3

   k0=7.2E-15_dp * EXP(785._dp/TEMP)
   k2=4.1E-16_dp * EXP(1440._dp/TEMP)
   k3=1.9E-33_dp * EXP(725._dp/TEMP)

   k46=k0+k3/(1+k3/k2)

END FUNCTION k46

! End INLINED Rate Law Functions

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! Update_SUN - update SUN light using TIME
!   Arguments :
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  SUBROUTINE Update_SUN()
      !USE racmpm_Parameters
      !USE racmpm_Global

    IMPLICIT NONE

    REAL(kind=dp) SunRise, SunSet
    REAL(kind=dp) Thour, Tlocal, Ttmp

    SunRise = 4.5_dp
    SunSet  = 19.5_dp
    Thour = TIME/3600.0_dp
    Tlocal = Thour - (INT(Thour)/24)*24

    IF ((Tlocal>=SunRise).AND.(Tlocal<=SunSet)) THEN
       Ttmp = (2.0*Tlocal-SunRise-SunSet)/(SunSet-SunRise)
       IF (Ttmp.GT.0) THEN
          Ttmp =  Ttmp*Ttmp
       ELSE
          Ttmp = -Ttmp*Ttmp
       END IF
       SUN = ( 1.0_dp + COS(PI*Ttmp) )/2.0_dp
    ELSE
       SUN = 0.0_dp
    END IF

 END SUBROUTINE Update_SUN

! End of Update_SUN function
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! Update_RCONST - function to update rate constants
!   Arguments :
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

SUBROUTINE Update_RCONST ( )

! Begin INLINED RCONST

! End INLINED RCONST

  RCONST(1) = (j(Pj_no2))
  RCONST(2) = (j(Pj_o31d))
  RCONST(3) = (j(Pj_o33p))
  RCONST(4) = (j(Pj_hno2))
  RCONST(5) = (j(Pj_hno3))
  RCONST(6) = (j(Pj_hno4))
  RCONST(7) = (j(Pj_no3o2))
  RCONST(8) = (j(Pj_no3o))
  RCONST(9) = (j(Pj_h2o2))
  RCONST(10) = (j(Pj_ch2om))
  RCONST(11) = (j(Pj_ch2or))
  RCONST(12) = (j(Pj_ch3cho))
  RCONST(13) = (j(Pj_ch3o2h))
  RCONST(14) = (j(Pj_ch3coch3))
  RCONST(15) = (j(Pj_ch3coo2h))
  RCONST(16) = (j(Pj_ch3coc2h5))
  RCONST(17) = (j(Pj_hcocho))
  RCONST(18) = (j(Pj_hcochob))
  RCONST(19) = (j(Pj_ch3cocho))
  RCONST(20) = (j(Pj_hcochest))
  RCONST(21) = (j(Pj_ch3ono2))
  RCONST(22) = (j(Pj_macr))
  RCONST(23) = (j(Pj_ch3coc2h5))
  RCONST(24) = ((C_M*6.00D-34*(TEMP/300.0_dp)**(-2.3)))
  RCONST(25) = (ARR2(8.00D-12,2060.0_dp,TEMP))
  RCONST(26) = (.78084*ARR2(1.8D-11,-110._dp,TEMP))
  RCONST(27) = (.20946*ARR2(3.20D-11,-70.0_dp,TEMP))
  RCONST(28) = (2.20D-10)
  RCONST(29) = (ARR2(1.60D-12,940.0_dp,TEMP))
  RCONST(30) = (ARR2(1.10D-14,500.0_dp,TEMP))
  RCONST(31) = (ARR2(4.80D-11,-250.0_dp,TEMP))
  RCONST(32) = (ARR2(2.90D-12,160.0_dp,TEMP))
  RCONST(33) = ((2.3D-13*EXP(600./TEMP)+1.7D-33*C_M*EXP(1000./TEMP)))
  RCONST(34) = ((3.22D-34*EXP(2800./TEMP)+2.38D-54*C_M*EXP(3200./TEMP)))
  RCONST(35) = (TROE(9.00D-32,1.5_dp,3.00D-11,0.0_dp,TEMP,C_M))
  RCONST(36) = (ARR2(6.50D-12,-120.0_dp,TEMP))
  RCONST(37) = (TROE(9.00D-32,2.0_dp,2.20D-11,0.0_dp,TEMP,C_M))
  RCONST(38) = (TROE(7.00D-31,2.6_dp,1.50D-11,0.5_dp,TEMP,C_M))
  RCONST(39) = (TROE(2.60D-30,3.2_dp,2.40D-11,1.3_dp,TEMP,C_M))
  RCONST(40) = (2.20D-11)
  RCONST(41) = (ARR2(3.70D-12,-250.0_dp,TEMP))
  RCONST(42) = (TROE(1.80D-31,3.2_dp,4.70D-12,1.4_dp,TEMP,C_M))
  RCONST(43) = (TROEE(4.76D26,10900.0_dp,1.80D-31,3.2_dp,4.70D-12,1.4_dp,TEMP,C_M))
  RCONST(44) = (3.50D-12)
  RCONST(45) = (ARR2(1.80D-11,390.0_dp,TEMP))
  RCONST(46) = (k46(TEMP,C_M))
  RCONST(47) = (ARR2(1.30D-12,-380.0_dp,TEMP))
  RCONST(48) = (ARR2(2.00D-12,1400.0_dp,TEMP))
  RCONST(49) = (ARR2(1.20D-13,2450.0_dp,TEMP))
  RCONST(50) = ((.20946e0*ARR2(3.30D-39,-530.0_dp,TEMP)))
  RCONST(51) = (ARR2(1.50D-11,-170.0_dp,TEMP))
  RCONST(52) = (ARR2(4.50D-14,1260.0_dp,TEMP))
  RCONST(53) = (TROE(2.20D-30,3.9_dp,1.50D-12,0.7_dp,TEMP,C_M))
  RCONST(54) = (TROEE(3.70D26,11000.0_dp,2.20D-30,3.9_dp,1.50D-12,0.7_dp,TEMP,C_M))
  RCONST(55) = (ARR2(8.50D-13,2450.0_dp,TEMP))
  RCONST(56) = ((5.31D-7*ARR2(5.50D-12,2000.0_dp,TEMP)))
  RCONST(57) = (TROE(3.00D-31,3.3_dp,1.50D-12,0.0_dp,TEMP,C_M))
  RCONST(58) = (1.5D-13*(1.0_dp+2.439D-20*C_M))
  RCONST(59) = (6.0D-11)
  RCONST(60) = (ARR2(1.59D-11,-13.0_dp,TEMP))
  RCONST(61) = ((THERMAL_T2(7.44D-18,1361.0_dp,TEMP)))
  RCONST(62) = ((THERMAL_T2(1.51D-17,492.0_dp,TEMP)))
  RCONST(63) = (ARR2(5.26D-12,260.0_dp,TEMP))
  RCONST(64) = (ARR2(8.02D-12,155.0_dp,TEMP))
  RCONST(65) = (ARR2(1.64D-11,125.0_dp,TEMP))
  RCONST(66) = (ARR2(1.96D-12,-438.0_dp,TEMP))
  RCONST(67) = (ARR2(5.72D-12,-500.0_dp,TEMP))
  RCONST(68) = (ARR2(1.33D-11,-500.0_dp,TEMP))
  RCONST(69) = (ARR2(1.48D-11,-448.0_dp,TEMP))
  RCONST(70) = (ARR2(2.54D-11,-410.0_dp,TEMP))
  RCONST(71) = (ARR2(1.21D-11,-444.0_dp,TEMP))
  RCONST(72) = (1.71D-10)
  RCONST(73) = (ARR2(1.81D-12,-355.0_dp,TEMP))
  RCONST(74) = (ARR2(7.30D-12,-355.0_dp,TEMP))
  RCONST(75) = (6.00D-11)
  RCONST(76) = (1.00D-11)
  RCONST(77) = (ARR2(5.55D-12,-331.0_dp,TEMP))
  RCONST(78) = ((THERMAL_T2(5.68D-18,-92.0_dp,TEMP)))
  RCONST(79) = (3.00D-12)
  RCONST(80) = (1.14D-11)
  RCONST(81) = (1.72D-11)
  RCONST(82) = (ARR2(1.86D-11,-175.0_dp,TEMP))
  RCONST(83) = (ARR2(2.80D-11,-175.0_dp,TEMP))
  RCONST(84) = (2.70D-10)
  RCONST(85) = (ARR2(2.93D-12,-190.0_dp,TEMP))
  RCONST(86) = (ARR2(3.40D-12,-190.0_dp,TEMP))
  RCONST(87) = (ARR2(2.93D-12,-190.0_dp,TEMP))
  RCONST(88) = (4.00D-14)
  RCONST(89) = (ARR2(3.25D-13,-500.0_dp,TEMP))
  RCONST(90) = (ARR2(5.31D-12,260.0_dp,TEMP))
  RCONST(91) = (ARR2(3.40D-13,1900.0_dp,TEMP))
  RCONST(92) = (ARR2(1.40D-12,1900.0_dp,TEMP))
  RCONST(93) = (ARR2(2.90D-12,1900.0_dp,TEMP))
  RCONST(94) = (ARR2(1.40D-12,1900.0_dp,TEMP))
  RCONST(95) = (ARR2(8.27D-15,150.0_dp,TEMP))
  RCONST(96) = (ARR2(2.87D-13,1000.0_dp,TEMP))
  RCONST(97) = (2.20D-11)
  RCONST(98) = ((THERMAL_T2(4.88D-18,2282.0_dp,TEMP)))
  RCONST(99) = (ARR2(1.79D-13,450.0_dp,TEMP))
  RCONST(100) = (ARR2(8.64D-13,-450.0_dp,TEMP))
  RCONST(101) = (1.00D-13)
  RCONST(102) = (ARR2(4.0D-12,446.0_dp,TEMP))
  RCONST(103) = (ARR2(1.19D-12,-490.0_dp,TEMP))
  RCONST(104) = (1.22D-11)
  RCONST(105) = (ARR2(2.20D-14,500.0_dp,TEMP))
  RCONST(106) = (ARR2(9.14D-15,2580.0_dp,TEMP))
  RCONST(107) = (ARR2(4.33D-15,1800.0_dp,TEMP))
  RCONST(108) = (ARR2(4.40D-15,845.0_dp,TEMP))
  RCONST(109) = (ARR2(1.34D-14,2283.0_dp,TEMP))
  RCONST(110) = (ARR2(7.86D-15,1913.0_dp,TEMP))
  RCONST(111) = (ARR2(1.01D-15,732.0_dp,TEMP))
  RCONST(112) = (2.00D-16)
  RCONST(113) = (ARR2(1.36D-15,2112.0_dp,TEMP))
  RCONST(114) = (2.00D-18)
  RCONST(115) = (ARR2(2.46D-15,1700.0_dp,TEMP))
  RCONST(116) = (2.00D-11)
  RCONST(117) = (1.00D-11)
  RCONST(118) = (3.60D-11)
  RCONST(119) = ((.20946e0*ARR2(1.66D-17,-1044.0_dp,TEMP)))
  RCONST(120) = (5.00D-11)
  RCONST(121) = (3.60D-11)
  RCONST(122) = ((.20946e0*ARR2(1.66D-17,-1044.0_dp,TEMP)))
  RCONST(123) = (1.00D-11)
  RCONST(124) = (3.60D-11)
  RCONST(125) = ((.20946e0*ARR2(1.66D-17,-1044.0_dp,TEMP)))
  RCONST(126) = (5.00D-11)
  RCONST(127) = (TROE(9.70D-29,5.6_dp,9.30D-12,1.5_dp,TEMP,C_M))
  RCONST(128) = (TROEE(1.16D28,13954.0_dp,9.70D-29,5.6_dp,9.30D-12,1.5_dp,TEMP,C_M))
  RCONST(129) = (TROE(9.70D-29,5.6_dp,9.30D-12,1.5_dp,TEMP,C_M))
  RCONST(130) = (TROEE(1.16D28,13954.0_dp,9.70D-29,5.6_dp,9.30D-12,1.5_dp,TEMP,C_M))
  RCONST(131) = (ARR2(4.20D-12,-180.0_dp,TEMP))
  RCONST(132) = (8.70D-12)
  RCONST(133) = (4.00D-12)
  RCONST(134) = (4.00D-12)
  RCONST(135) = (4.00D-12)
  RCONST(136) = (9.00D-12)
  RCONST(137) = (4.00D-12)
  RCONST(138) = (4.00D-12)
  RCONST(139) = (4.0D-12)
  RCONST(140) = (4.00D-12)
  RCONST(141) = (4.00D-12)
  RCONST(142) = (4.00D-12)
  RCONST(143) = (4.00D-12)
  RCONST(144) = (4.00D-12)
  RCONST(145) = (2.00D-11)
  RCONST(146) = (2.00D-11)
  RCONST(147) = (4.00D-12)
  RCONST(148) = (4.00D-12)
  RCONST(149) = (4.00D-12)
  RCONST(150) = (ARR2(3.80D-13,-800.0_dp,TEMP))
  RCONST(151) = (ARR2(7.50D-13,-700.0_dp,TEMP))
  RCONST(152) = (ARR2(1.66D-13,-1300.0_dp,TEMP))
  RCONST(153) = (ARR2(1.66D-13,-1300.0_dp,TEMP))
  RCONST(154) = (ARR2(1.66D-13,-1300.0_dp,TEMP))
  RCONST(155) = (ARR2(1.90D-13,-1300.0_dp,TEMP))
  RCONST(156) = (ARR2(1.66D-13,-1300.0_dp,TEMP))
  RCONST(157) = (ARR2(1.66D-13,-1300.0_dp,TEMP))
  RCONST(158) = (ARR2(1.28D-13,-1300.0_dp,TEMP))
  RCONST(159) = (1.50D-11)
  RCONST(160) = (1.50D-11)
  RCONST(161) = (ARR2(3.75D-13,-980.0_dp,TEMP))
  RCONST(162) = (ARR2(3.75D-13,-980.0_dp,TEMP))
  RCONST(163) = (ARR2(3.75D-13,-980.0_dp,TEMP))
  RCONST(164) = (ARR2(1.15D-12,-550.0_dp,TEMP))
  RCONST(165) = (ARR2(3.86D-16,-2640.0_dp,TEMP))
  RCONST(166) = (ARR2(1.15D-12,-550.0_dp,TEMP))
  RCONST(167) = (ARR2(3.86D-16,-2640.0_dp,TEMP))
  RCONST(168) = (ARR2(1.15D-13,-1300.0_dp,TEMP))
  RCONST(169) = (ARR2(1.66D-13,-1300.0_dp,TEMP))
  RCONST(170) = (ARR2(1.66D-13,-1300.0_dp,TEMP))
  RCONST(171) = (ARR2(9.10D-14,-416.0_dp,TEMP))
  RCONST(172) = (ARR2(1.18D-13,-158.0_dp,TEMP))
  RCONST(173) = (ARR2(9.46D-14,-431.0_dp,TEMP))
  RCONST(174) = (ARR2(1.00D-13,-467.0_dp,TEMP))
  RCONST(175) = (ARR2(4.34D-14,-633.0_dp,TEMP))
  RCONST(176) = (ARR2(1.71D-13,-708.0_dp,TEMP))
  RCONST(177) = (ARR2(1.46D-13,-708.0_dp,TEMP))
  RCONST(178) = (ARR2(9.18D-14,-708.0_dp,TEMP))
  RCONST(179) = (ARR2(1.36D-13,-708.0_dp,TEMP))
  RCONST(180) = (ARR2(3.56D-14,-708.0_dp,TEMP))
  RCONST(181) = (ARR2(3.56D-14,-708.0_dp,TEMP))
  RCONST(182) = (ARR2(3.56D-14,-708.0_dp,TEMP))
  RCONST(183) = (ARR2(3.56D-14,-708.0_dp,TEMP))
  RCONST(184) = (ARR2(3.56D-14,-708.0_dp,TEMP))
  RCONST(185) = (ARR2(3.21D-11,440.0_dp,TEMP))
  RCONST(186) = (ARR2(2.68D-16,-2510.0_dp,TEMP))
  RCONST(187) = (ARR2(3.21D-11,440.0_dp,TEMP))
  RCONST(188) = (ARR2(2.68D-16,-2510.0_dp,TEMP))
  RCONST(189) = (ARR2(6.91D-13,-508.0_dp,TEMP))
  RCONST(190) = (ARR2(1.60D-13,-708.0_dp,TEMP))
  RCONST(191) = (ARR2(9.68D-14,-708.0_dp,TEMP))
  RCONST(192) = (ARR2(1.03D-12,-211.0_dp,TEMP))
  RCONST(193) = (ARR2(6.90D-13,-460.0_dp,TEMP))
  RCONST(194) = (ARR2(5.59D-13,-522.0_dp,TEMP))
  RCONST(195) = (ARR2(2.47D-13,-683.0_dp,TEMP))
  RCONST(196) = (ARR2(9.48D-13,-765.0_dp,TEMP))
  RCONST(197) = (ARR2(8.11D-13,-765.0_dp,TEMP))
  RCONST(198) = (ARR2(5.09D-13,-765.0_dp,TEMP))
  RCONST(199) = (ARR2(7.60D-13,-765.0_dp,TEMP))
  RCONST(200) = (ARR2(7.40D-13,-765.0_dp,TEMP))
  RCONST(201) = (ARR2(7.40D-13,-765.0_dp,TEMP))
  RCONST(202) = (ARR2(7.40D-13,-765.0_dp,TEMP))
  RCONST(203) = (ARR2(7.40D-13,-765.0_dp,TEMP))
  RCONST(204) = (ARR2(7.40D-13,-765.0_dp,TEMP))
  RCONST(205) = (ARR2(2.80D-12,-530.0_dp,TEMP))
  RCONST(206) = (ARR2(2.80D-12,-530.0_dp,TEMP))
  RCONST(207) = (ARR2(7.51D-13,-565.0_dp,TEMP))
  RCONST(208) = (ARR2(8.85D-13,-765.0_dp,TEMP))
  RCONST(209) = (ARR2(5.37D-13,-765.0_dp,TEMP))
  RCONST(210) = (ARR2(7.00D-14,-1000.0_dp,TEMP))
  RCONST(211) = (ARR2(4.25D-14,-1000.0_dp,TEMP))
  RCONST(212) = (ARR2(2.96D-14,-1000.0_dp,TEMP))
  RCONST(213) = (1.20D-12)
  RCONST(214) = (1.20D-12)
  RCONST(215) = (1.20D-12)
  RCONST(216) = (1.20D-12)
  RCONST(217) = (1.20D-12)
  RCONST(218) = (1.20D-12)
  RCONST(219) = (1.20D-12)
  RCONST(220) = (1.20D-12)
  RCONST(221) = (1.20D-12)
  RCONST(222) = (1.20D-12)
  RCONST(223) = (1.20D-12)
  RCONST(224) = (1.20D-12)
  RCONST(225) = (1.20D-12)
  RCONST(226) = (1.20D-12)
  RCONST(227) = (4.00D-12)
  RCONST(228) = (4.00D-12)
  RCONST(229) = (1.20D-12)
  RCONST(230) = (1.20D-12)
  RCONST(231) = (1.20D-12)
  RCONST(232) = (ARR2(1.66D-13,-1300.0_dp,TEMP))
  RCONST(233) = (ARR2(5.99D-15,-1510.0_dp,TEMP))
  RCONST(234) = (ARR2(3.40D-14,-1560.0_dp,TEMP))
  RCONST(235) = (ARR2(7.13D-17,-2950.0_dp,TEMP))
  RCONST(236) = (4.00D-12)
  RCONST(237) = (1.20D-12)

END SUBROUTINE Update_RCONST

! End of Update_RCONST function
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! Update_PHOTO - function to update photolytical rate constants
!   Arguments :
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

SUBROUTINE Update_PHOTO ( )

   USE racmpm_Global

  RCONST(1) = (j(Pj_no2))
  RCONST(2) = (j(Pj_o31d))
  RCONST(3) = (j(Pj_o33p))
  RCONST(4) = (j(Pj_hno2))
  RCONST(5) = (j(Pj_hno3))
  RCONST(6) = (j(Pj_hno4))
  RCONST(7) = (j(Pj_no3o2))
  RCONST(8) = (j(Pj_no3o))
  RCONST(9) = (j(Pj_h2o2))
  RCONST(10) = (j(Pj_ch2om))
  RCONST(11) = (j(Pj_ch2or))
  RCONST(12) = (j(Pj_ch3cho))
  RCONST(13) = (j(Pj_ch3o2h))
  RCONST(14) = (j(Pj_ch3coch3))
  RCONST(15) = (j(Pj_ch3coo2h))
  RCONST(16) = (j(Pj_ch3coc2h5))
  RCONST(17) = (j(Pj_hcocho))
  RCONST(18) = (j(Pj_hcochob))
  RCONST(19) = (j(Pj_ch3cocho))
  RCONST(20) = (j(Pj_hcochest))
  RCONST(21) = (j(Pj_ch3ono2))
  RCONST(22) = (j(Pj_macr))
  RCONST(23) = (j(Pj_ch3coc2h5))

END SUBROUTINE Update_PHOTO

! End of Update_PHOTO function
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

END MODULE racmpm_Rates


module fft_work

  use constants, only: kind_id

  implicit none

  include "fftw3.f"

  public :: fft_type, delete_fft
  public :: init_ccfftw, init_crfftw, init_rcfftw
  public :: FFT_BACKWARD, FFT_FORWARD

  private

  integer, parameter :: FFT_BACKWARD = FFTW_BACKWARD
  integer, parameter :: FFT_FORWARD  = FFTW_FORWARD

  type :: fft_type
     integer :: n, is, type
     integer (kind_id) :: plan
     real :: scale
  end type fft_type

contains

  subroutine init_ccfftw (fft, is, n, data_in, data_out)

    use mp, only: mp_abort

    type (fft_type), intent (out) :: fft
    integer, intent (in) :: is, n
    complex, dimension(:), intent(inout) :: data_in, data_out

    integer :: j

    fft%n = n
    fft%is = is
    fft%scale = 1./real(n)
    if (is > 0) fft%scale = 1.
    fft%type = 1

    j = FFTW_PATIENT
    call dfftw_plan_dft_1d(fft%plan, n, data_in, data_out, is, j)

  end subroutine init_ccfftw

  subroutine init_crfftw (fft, is, n, data_in, data_out)

    use mp, only: mp_abort

    type (fft_type), intent (out) :: fft
    integer, intent (in) :: is, n
    complex, dimension(:), intent(in out) :: data_in
    real, dimension (:), intent (in out) :: data_out

    integer :: j

    fft%n = n
    fft%is = is
    fft%scale = 1./real(n)
    if (is > 0) fft%scale = 1.
    fft%type = 1

    j = FFTW_PATIENT
    call dfftw_plan_dft_c2r_1d(fft%plan, n, data_in, data_out, j)

  end subroutine init_crfftw

  subroutine init_rcfftw (fft, is, n, data_in, data_out)

    use mp, only: mp_abort

    type (fft_type), intent (out) :: fft
    integer, intent (in) :: is, n
    real, dimension(:), intent(in out) :: data_in
    complex, dimension (:), intent (in out) :: data_out

    integer :: j

    fft%n = n
    fft%is = is
    fft%scale = 1./real(n)
    if (is > 0) fft%scale = 1.
    fft%type = 1

    j = FFTW_PATIENT
    call dfftw_plan_dft_r2c_1d(fft%plan, n, data_in, data_out, j)

  end subroutine init_rcfftw

  subroutine delete_fft(fft)

    type (fft_type), intent (in out) :: fft

    call dfftw_destroy_plan(fft%plan)

  end subroutine delete_fft

end module fft_work


!< Borges alpha coefficients object.
module wenoof_alpha_coefficients_z
!< Borges alpha coefficients object.
!<
!< @note The provided WENO alpha coefficients implements the alpha coefficients defined in *An improved weighted essentially
!< non-oscillatory scheme for hyperbolic conservation laws*, Rafael Borges, Monique Carmona, Bruno Costa and Wai Sun Don, JCP, 2008,
!< vol. 227, pp. 3191-3211, doi: 10.1016/j.jcp.2007.11.038.

use penf, only : I_P, R_P
use wenoof_alpha_coefficients

implicit none
private
public :: alpha_coefficients_z
public :: alpha_coefficients_z_constructor
public :: create_alpha_coefficients_z_constructor

type, extends(alpha_coefficients_constructor) :: alpha_coefficients_z_constructor
  !< Borges WENO alpha coefficients object constructor.
endtype alpha_coefficients_z_constructor

type, extends(alpha_coefficients) :: alpha_coefficients_z
  !< Borges WENO alpha coefficients object.
  !<
  !< @note The provided WENO alpha coefficients implements the alpha coefficients defined in *An improved weighted essentially
  !< non-oscillatory scheme for hyperbolic conservation laws*, Rafael Borges, Monique Carmona, Bruno Costa and Wai Sun Don, JCP,
  !< 2008, vol. 227, pp. 3191-3211, doi: 10.1016/j.jcp.2007.11.038.
  contains
    ! deferred public methods
    procedure, pass(self) :: compute     !< Compute coefficients.
    procedure, nopass     :: description !< Return string-description of coefficients.
endtype alpha_coefficients_z
contains
  ! public non TBP
  subroutine create_alpha_coefficients_z_constructor(S, constructor)
  !< Create alpha coefficients constructor.
  !<
  !< #TODO add actual Z support (this is a copy of simple JS).
  integer(I_P),                                       intent(in)  :: S           !< Stencils dimension.
  class(alpha_coefficients_constructor), allocatable, intent(out) :: constructor !< Alpha coefficients constructor.

  allocate(alpha_coefficients_z_constructor :: constructor)
  constructor%S = S
  endsubroutine create_alpha_coefficients_z_constructor

  ! deferred public methods
  pure subroutine compute(self, S, weight_opt, IS, eps, f1, f2)
  !< Compute alpha coefficients.
  class(alpha_coefficients_z), intent(inout) :: self                        !< Alpha coefficients.
  integer(I_P),                intent(in)    :: S                           !< Number of stencils used.
  real(R_P),                   intent(in)    :: weight_opt(1: 2, 0 : S - 1) !< Optimal weight of the stencil.
  real(R_P),                   intent(in)    :: IS(1: 2, 0 : S - 1)         !< Smoothness indicators of the stencils.
  real(R_P),                   intent(in)    :: eps                         !< Parameter for avoiding divided by zero.
  integer(I_P),                intent(in)    :: f1, f2                      !< Faces to be computed.
  integer(I_P)                               :: f, s1                       !< Counters.

  self%alpha_tot = 0._R_P
  do s1=0, S - 1 ! stencil loops
    do f=f1, f2 ! 1 => left interface (i-1/2), 2 => right interface (i+1/2)
      self%alpha_coef(f, s1) = weight_opt(f, s1) * ((1._R_P + (tau(S,IS)/(eps+IS(f, s1)))) ** (weno_exp(S)))
      self%alpha_tot(f) = self%alpha_tot(f) + self%alpha_coef(f, s1)
    enddo
  enddo
  endsubroutine compute

  pure function description() result(string)
  !< Return alpha coefficients string-descripition.
  character(len=:), allocatable :: string           !< String-description.
  character(len=1), parameter   :: nl=new_line('a') !< New line character.

  string = 'WENO alpha coefficients'//nl
  string = string//'  Based on the work by Borges, Carmona, Costa and Don "An improved weighted essentially non-oscillatory '// &
           'scheme for hyperbolic conservation laws", see '// &
           'JCP, 2008, vol. 227, pp. 3191--3211, doi:10.1016/j.jcp.2007.11.038'//nl
  string = string//'  The "compute" method has the following public API'//nl
  string = string//'    compute(S, weigt_opt, IS, eps, f1, f2)'//nl
  string = string//'  where:'//nl
  string = string//'    S: integer(I_P), intent(in), the number of the stencils used'//nl
  string = string//'    weight_opt: real(R_P), intent(in), the optimal weight of the actual stencil'//nl
  string = string//'    IS: real(R_P), intent(in), the smoothness indicator of the actual stencil'//nl
  string = string//'    eps: real(R_P), intent(in), the coefficient to avoid zero division used'//nl
  string = string//'    f1, f2: integer(I_P), intent(in), the faces to be computed (1 => left interface, 2 => right interface)'
  return
  !---------------------------------------------------------------------------------------------------------------------------------
  endfunction description

  ! private non TBP
  pure function tau(S, IS) result(w_tau)
  !< Compute the tau coefficient used in the WENO-Z alpha coefficients.
  integer(I_P), intent(in) :: S           !< Number of stencils used.
  real(R_P),    intent(in) :: IS(0:S - 1) !< Smoothness indicators.
  real(R_P)                :: w_tau       !< Tau coefficient.

  w_tau = abs(IS(0) - (1-weno_odd(S))*IS(1) - (1-weno_odd(S))*IS(S-2_I_P) + (1-2*weno_odd(S))*IS(S-1_I_P))
  endfunction tau

  pure function weno_exp(S) result(w_exp)
  !< Compute the exponent used in the alpha function.
  integer(I_P), intent(in) :: S     !< Number of stencils used.
  integer(I_P)             :: w_exp !< Exponent used in the alpha function.

  w_exp = int(S, I_P)
  endfunction weno_exp

  pure function weno_odd(S) result(w_odd)
  !< Compute the distinguisher between odd and even number of stencils.
  integer(I_P), intent(in) :: S     !< Number of stencils used.
  integer(I_P)             :: w_odd !< Distinguishing between odd and even number of stencils.

  w_odd = int(mod(S, 2_I_P), I_P)
  endfunction weno_odd
endmodule wenoof_alpha_coefficients_z


c ======================================================================
      subroutine admissibleq(theta,h,hu,hm,p,u,m,iflag)
c     !evaluate a potential solution and return the nearest admissible one
c ======================================================================

      implicit none

*     !i/o
      integer iflag(4)
      double precision theta,h,hu,hm,p,u,m

*     !local
      integer i
      double precision rho
      double precision pmax,mlo,mhi,phi,plo,hlo

      include "digparamsdec.i"
      include "digparamscommon.i"

      do i = 1,4
         iflag(i) = 0
      enddo

      if (h.le.dry_tol) then
         iflag(1) = 1
         h = max(0.d0,h)
         hu = 0.d0
         hm = h*m0
         p  = h*rho_f*grav*cos(theta)
         u = 0.d0
         m = m0
         return
      endif

      hlo = 2.d0*dry_tol
      if (h.lt.hlo) then
         h = (h**2 + hlo**2)/(2.d0*hlo)
      endif

      u  = hu/h
      m = hm/h
      m = min(m,1.d0)
      m = max(m,0.d0)
      !mlo =  phys_tol
      mlo = m_min
      mhi = 1.d0 - 0.5d0*mlo
      if (m.le.mlo) then
         iflag(3) = 1
         !write(*,*) 'mbefore',m
         m = (m**2 + mlo**2)/(2.d0*mlo)
         hm = h*m
         !write(*,*) 'm,mlo:',m,mlo
      elseif (m.ge.mhi) then
         iflag(3) = 1
         m = 1.d0 - ((1.d0-mhi)**2 + (1.d0-m)**2)/(2.d0*(1.d0-mhi))
         hm = h*m
      endif

      rho = (rho_s*m + (1.d0-m)*rho_f)
      pmax = rho*grav*h*cos(theta)
      p = min(pmax,p)
      p = max(0.d0,p)
      plo = phys_tol*rho*h*grav*cos(theta)
      phi = pmax - plo
      !write(*,*) 'p,pmax,phi,plo',p,pmax,phi,plo
      if (p.lt.plo) then
         iflag(4) = 1
         p = (p**2 + plo**2)/(2.d0*plo)
      elseif (p.gt.phi) then
         iflag(4) = 1
         p = pmax - ((pmax-p)**2+ (pmax-phi)**2)/(2.d0*(pmax-phi))
      endif
      if (p.gt.pmax) write(*,*) 'pnew,pmax',p
      return
      end

c ======================================================================
      subroutine auxeval(h,u,m,p,kappa,theta,
     &              S,rho,tanpsi,D,tau,phi,sigbed,kperm,compress,pm)
c     !evaluate the aux variables for this single grid cell
c ======================================================================
      implicit none

*     !i/o
      double precision, intent(in)  :: h,u,m,p,theta,pm
      double precision, intent(out) :: S,rho,tanpsi,D,tau,kappa
      double precision, intent(out) :: phi,sigbed,kperm,compress

*     !local
      double precision g,m_eqn,hdel,hpos,sqrtarg
      double precision sigmin,SN,SNN,S0,s02,m_eqnS,m_eqnN,m_eqnC,sigpos
      double precision m_eqncrit,m_eqnboyer,mpos

      include "digparamsdec.i"
      include "digparamscommon.i"

      g=grav

      rho = rho_s*m + rho_f*(1.d0-m)
      sigbed = max(0.d0,rho*g*h*cos(theta) - p)
      SN = mu*abs(u)/((h**2)*(rho_s-rho_f)*m*g*cos(theta))
      SNN = mu*abs(u)/(h*sigbed)
      S = SNN

      m_eqncrit = m_crit*(1.d0 - tanh(c2*SN))
      !m_eqnboyer = m_crit/(1.d0+sqrt(S))
      if (h*sigbed.gt.0.d0) then
         m_eqnboyer = sqrt(h*sigbed)*m_crit/
     &       (sqrt(h*sigbed)+ sqrt(mu*abs(u)))
      else
         m_eqnboyer = 0.d0
      endif
      m_eqn = m_eqnboyer
      tanpsi = c1*(m-m_eqn)
      tau = max(0.d0,sigbed*tan(phi))!+atan(tanpsi))
      !kperm = (kappita**2*(1.d0-m)**3)/(180.d0*m**2)
      kperm = kappita**2*exp(max(0.d0,m-m_min)/(-0.03))/40.0
      compress = alpha/((m)*(sigbed + 1.d5))
      if (p_initialized.gt.0) then
         D = (2.d0*kperm/(h*mu))*(rho_f*g*h*cos(theta)-p)
      else
         D = 0.d0
      endif

c----------------------------------------------------------------
      kappa = 1.d0 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

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

      return
      end

c ======================================================================
      subroutine psieval(theta,tau,rho,D,tanpsi,kappa,kperm,
     &                       compress,h,u,m,psi)
c     !evaluate the source term that is being integrated
c ======================================================================

      implicit none

*     !i/o
      double precision psi(4)
      double precision theta,tau,rho,D,tanpsi,kappa,kperm,compress
      double precision h,u,m,drytol

*     !local
      double precision taushear,zeta

      include "digparamsdec.i"
      include "digparamscommon.i"
      drytol = 2.d0*dry_tol
      taushear = (tau/rho)*sign(1.d0,u)
      if (h.gt.drytol) then
         taushear = taushear + (1.d0-m)*mu*u/(h*rho)
      endif

      !psi(2) = grav*h*sin(theta) - taushear + u*D*(rho-rho_f)/rho
      if (h.gt.drytol) then
         psi(1) = D*(rho-rho_f)/rho
         psi(2) = grav*h*sin(theta) - taushear + u*D*(rho-rho_f)/rho
         psi(3) = -D*m*(rho_f/rho)
         zeta = 6.d0/(compress*h*(1.d0+kappa))  +
     &        1.5d0*(rho-rho_f)*rho_f*grav*sin(theta)/(6.d0*rho)
         psi(4) = - 3.d0*abs(u)*tanpsi/(h*compress*(1.d0+kappa))
      else
         psi(1) = 0.d0
         psi(2) = 0.d0
         psi(3) = 0.d0
         psi(4) = 0.d0
      endif

      return
      end

c ======================================================================
      subroutine auxeval_old(h,u,m,p,kappa,theta,
     &              S,rho,tanpsi,D,tau,phi,sigbed,kperm,compress,pm)
c     !evaluate the aux variables for this single grid cell
c ======================================================================
      implicit none

*     !i/o
      double precision, intent(in)  :: h,u,m,p,theta,pm
      double precision, intent(out) :: S,rho,tanpsi,D,tau,kappa
      double precision, intent(out) :: phi,sigbed,kperm,compress

*     !local
      double precision g,m_eqn,hdel,hpos,sqrtarg
      double precision sigmin,SN,SNN,S0,s02,m_eqnS,m_eqnN,m_eqnC,sigpos
      double precision m_eqncrit,mpos

      include "digparamsdec.i"
      include "digparamscommon.i"

      g=grav

      rho = rho_s*m + rho_f*(1.d0-m)
      sigbed = max(0.d0,rho*g*h*cos(theta) - p)
c      if (h.ge.phys_tol.and.sigbed.gt.0.d0) then
c         S = 2.d0*(rho_s/sigbed)*(u*delta/h)**2
c      elseif (h.lt.phys_tol.and.sigbed.gt.0.d0) then
c         S = 2.d0*(rho_s/sigbed)*u**2
c      else
c         S = 1.d16
c      endif
c      S = 2.d0*(rho_s/(sigbed+delta))*(u*delta/(h+delta))**2
c      S = 2.d0*(rho_s/(sigbed+p+delta))*(u*delta/(h+delta))**2 !!!
c      S = 2.d0*(rho_s/(sigbed + p))*(u*delta/(h+delta))**2 !!!!
      hdel = 2.d0*delta
      !hdel = dry_tol
      mpos = max(m,1.d-6)
      if (h.gt.hdel) then
         hpos= h
      else
         hpos = (h**2 + hdel**2)/(2.d0*hdel)
      endif
c            hpos = 1.d0
      sigmin = rho_f*hdel*grav*cos(theta)
      if (sigbed.gt.sigmin) then
         sigpos = sigbed
      else
         sigpos = (sigbed**2 + sigmin**2)/(2.d0*sigmin)
      endif

      sigpos = sigbed + delta
      hpos = h + delta
      SN = mu*abs(u)/((hpos**2)*(rho_s-rho_f)*mpos*g*cos(theta))
c      SNN = mu*abs(u)/((hpos**2)*(sigpos))
c      S0 = 2.d0*(rho_s/(sigpos))*(u*delta/(hpos))**2
c      S02 = 2.d0*(rho_s/(sigpos+p))*(u*delta)**2
      S = SN

      m_eqnS = m_crit - (m_crit - m_min)*tanh(S)
      m_eqnN = m_crit - c2*S
      m_eqnC = ((rho - rho_f)/(rho_s - rho_f))*(1.d0 - c2*tanh(S))
      m_eqncrit = m_crit*(1.d0 - tanh(c2*S))
      m_eqn = m_eqncrit

      tanpsi = c1*(m-m_eqn)
      !phi = max(1.d0,phi + atan(tanpsi))
      tau = max(0.d0,sigbed*tan(phi))!+atan(tanpsi))
      kperm = (kappita**2*max(1.d0-m,1.d-6)**3)/(180.d0*max(m,1.d-6)**2)
      compress = alpha/(max(1.d-16,m)*
     &               (max(rho*grav*cos(theta)*h - p,0.d0) + 1.d5))
      if (h.gt.dry_tol.and.p_initialized.gt.0) then
         D = (2.d0*kperm/(h*mu))*(rho_f*g*h*cos(theta)-p)
      else
         D = 0.d0
      endif
      if (phi_int.eq.phi_bed) then
         sqrtarg = 0.d0
      else
         sqrtarg = 1.d0-(cos(phi_int)**2)*(1.d0 + tan(phi_bed)**2)
      endif

      kappa = (2.d0 - pm*2.d0*sqrt(sqrtarg))/(cos(phi_int)**2)
      kappa = kappa - 1.d0
c----------------------------------------------------------------
      kappa = 1.d0 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      !D = 0.d0
      !kperm = 1.d-8
      !compress = 5.d-5
c-----------------------------------------------------------------

      return
      end

c ======================================================================
      subroutine admissibleq_old(theta,h,hu,hm,p,u,m,iflag)
c     !evaluate a potential solution and return the nearest admissible one
c ======================================================================

      implicit none

*     !i/o
      integer iflag(4)
      double precision theta,h,hu,hm,p,u,m

*     !local
      integer i
      double precision pmax,rho

      include "digparamsdec.i"
      include "digparamscommon.i"

      do i = 1,4
         iflag(i) = 0
         enddo

      if (h.le.dry_tol) then
         iflag(1) = 1
         !if (h.lt.0.d0) write(*,*) 'h',h
         h = max(0.d0,h)
         hu = 0.d0
         hm = h*m0 !max(0.d0,min(hm,h))
         p  = h*rho_f*grav*cos(theta) !max(0.d0,min(p,rho_f*grav*h*cos(theta)))
         u = 0.d0
         m = m0
      else
         if (hm.gt.h.or.hm.lt.0.d0) then
            iflag(3) = 1
            hm = max(hm,0.d0)
            hm = min(hm,h)
            endif
         u  = hu/h
         m  = hm/h
         pmax = (rho_s*m + (1.d0-m)*rho_f)*grav*h*cos(theta)
         if (p.lt.0.d0.or.p.gt.pmax) then
             iflag(4) = 1
             p = max(p,0.d0)
             p  = min(p,pmax)
            endif
         endif
      return
      end