c     -------------------------------------------------------------------------
c     Potential temperature (TH)
c     -------------------------------------------------------------------------

      subroutine calc_TH (pt,t,p)

      implicit none

c     Argument declaration
      real  pt     ! Potential temperature [K]
      real  t      ! Temperature [either in C or in K]
      real  p      ! Pressure [hPa]

c     Physical parameters
      real      rdcp,tzero
      data      rdcp,tzero /0.286,273.15/

c     Calculation - distinction between temperature in C or in K
      if (t.lt.100.) then
         pt = (t+tzero) * ( (1000./p)**rdcp )
      else
         pt = t * ( (1000./p)**rdcp )
      endif

      end

c     -------------------------------------------------------------------------
c     Density (RHO)
c     -------------------------------------------------------------------------

      subroutine calc_RHO (rho,t,p)

      implicit none

c     Argument declaration
      real  rho    ! Density [kg/m^3]
      real  t      ! Temperature [either in C or in K]
      real  p      ! Pressure [hPa]

c     Physical parameters
      real      rd,tzero
      data      rd,tzero /287.05,273.15/

c     Auxiliary variables
      real      tk

c     Calculation - distinction between temperature in C or in K
      if (t.lt.100.) then
         tk = t + tzero
      else
         tk = t
      endif

      rho = 100.*p/( tk * rd )

      end

c     -------------------------------------------------------------------------
c     Relative humidity (RH)
c     -------------------------------------------------------------------------

      subroutine calc_RH (rh,t,p,q)

      implicit none

c     Argument declaration
      real  rh     ! Relative humidity [%]
      real  t      ! Temperature [either in C or in K]
      real  p      ! Pressure [hPa]
      real  q      ! Specific humidity [kg/kg]

c     Physical parameters
      real      rdcp,tzero
      data      rdcp,tzero /0.286,273.15/
      real      b1,b2w,b3,b4w,r,rd
      data      b1,b2w,b3,b4w,r,rd /6.1078, 17.2693882, 273.16, 35.86,
     &                              287.05, 461.51/

c     Auxiliary variables
      real      ge
      real      gqd
      real      tc
      real      pp,qk

c     Calculation - distinction between temperature in C or in K
      if (t.gt.100.) then
         tc = t - tzero
      else
         tc = t
      endif
      qk = q

      ge  = b1*exp(b2w*tc/(tc+b3-b4w))
      gqd = r/rd*ge/(p-(1.-r/rd)*ge)
      rh  = 100.*qk/gqd

      end

c     -------------------------------------------------------------------------
c     Equivalent potential temperature (THE)
c     -------------------------------------------------------------------------

      subroutine calc_THE (the,t,p,q)

      implicit none

c     Argument declaration
      real  the    ! Equivalent potential temperature [K]
      real  t      ! Temperature [either in C or in K]
      real  p      ! Pressure [hPa]
      real  q      ! Specific humidity [kg/kg]

c     Physical parameters
      real     rdcp,tzero
      data     rdcp,tzero /0.286,273.15/

c     Auxiliary variables
      real     tk,qk

c     Calculation - distinction between temperature in C or in K
      if (t.lt.100.) then
         tk = t + tzero
      else
         tk = t
      endif
      qk = q

      the = tk*(1000./p)
     +      **(0.2854*(1.0-0.28*qk))*exp(
     +      (3.376/(2840.0/(3.5*alog(tk)-alog(
     +      100.*p*max(1.0E-10,qk)/(0.622+0.378*
     +      q))-0.1998)+55.0)-0.00254)*1.0E3*
     +      max(1.0E-10,qk)*(1.0+0.81*qk))

      end

c     -------------------------------------------------------------------------
c     Latent heating rate (LHR)
c     -------------------------------------------------------------------------

      subroutine calc_LHR (lhr,t,p,q,omega,rh)

      implicit none

c     Argument declaration
      real  lhr    ! Latent heating rate [K/6h]
      real  t      ! Temperature [either in C or in K]
      real  p      ! Pressure [hPa]
      real  q      ! Specific humidity [kg/kg]
      real  omega  ! Vertical velocity [Pa/s]
      real  rh     ! Relative humidity [%]

c     Physical parameters
      real      p0,kappa,tzero
      data      p0,kappa,tzero /1000.,0.286,273.15/
      real      blog10,cp,r,lw,eps
      data      blog10,cp,r,lw,eps /.08006,1004.,287.,2.5e+6,0.622/

c     Auxiliary variables
      real      tk
      real      qk
      real      tt
      real      esat,c

c     Calculation - distinction between temperature in C or in K
      if (t.lt.100.) then
         tk = t + tzero
      else
         tk = t
      endif
      qk = q

      if (rh.lt.80.) then
         lhr = 0.
      else if (omega.gt.0.) then
         lhr = 0.
      else
         c   = lw/cp*eps*blog10*esat(tk)/p
         tt  = (tk*(p0/p)**kappa)
         lhr = 21600.*
     >        (1.-exp(.2*(80.-rh)))
     >        *(-c*kappa*tt*omega/(100.*p))/(1.+c)

      endif

      end

c     -------------------------------------------------------------------------
c     Wind speed (VEL)
c     -------------------------------------------------------------------------

      subroutine calc_VEL (vel,u,v)

      implicit none

c     Argument declaration
      real  vel    ! Wind speed [m/s]
      real  u      ! Zonal wind component [m/s]
      real  v      ! Meridional wind component [m/s]

      vel = sqrt ( u*u + v*v )

      end

c     -------------------------------------------------------------------------
c     Wind direction (DIR)
c     -------------------------------------------------------------------------

      subroutine calc_DIR (dir,u,v)

      implicit none

c     Argument declaration
      real  dir    ! Wind direction [deg]
      real  u      ! Zonal wind component [m/s]
      real  v      ! Meridional wind component [m/s]

      call getangle(1.,0.,u,v,dir)

      end

c     -------------------------------------------------------------------------
c     Zonal derivative of U (DUDX)
c     -------------------------------------------------------------------------

      subroutine calc_DUDX (dudx,u1,u0,lat)

      implicit none

c     Argument declaration
      real  dudx   ! Derivative of U in zonal direction [s^-1]
      real  u1     ! U @ LON + 1 DLON [m/s]
      real  u0     ! U @ LON - 1 DLON [m/s]
      real  lat    ! Latitude [deg]

c     Physical parameters
      real      pi180
      parameter (pi180=31.14159/180.)
      real      deltay
      parameter (deltay =1.11e5)

      dudx = (u1-u0) / ( 2. * deltay * cos(pi180 * lat) )

      end

c     -------------------------------------------------------------------------
c     Zonal derivative of V (DVDX)
c     -------------------------------------------------------------------------

      subroutine calc_DVDX (dvdx,v1,v0,lat)

c     Argument declaration
      real  dvdx   ! Derivative of V in zonal direction [s^-1]
      real  v1     ! V @ LON + 1 DLON [m/s]
      real  v0     ! V @ LON - 1 DLON [m/s]
      real  lat    ! Latitude [deg]

c     Physical parameters
      real      pi180
      parameter (pi180=3.14159/180.)
      real      deltay
      parameter (deltay =1.11e5)

      dvdx = (v1-v0) / ( 2. * deltay * cos(pi180 * lat) )

      end

c     -------------------------------------------------------------------------
c     Zonal derivative of T (DTDX)
c     -------------------------------------------------------------------------

      subroutine calc_DTDX (dtdx,t1,t0,lat)

      implicit none

c     Argument declaration
      real  dtdx   ! Derivative of T in zonal direction [K/m]
      real  t1     ! T @ LON + 1 DLON [K]
      real  t0     ! T @ LON - 1 DLON [K]
      real  lat    ! Latitude [deg]

c     Physical parameters
      real      pi180
      parameter (pi180=3.14159/180.)
      real      deltay
      parameter (deltay =1.11e5)

      dtdx = (t1-t0) / ( 2. * deltay * cos(pi180 * lat) )

      end

c     -------------------------------------------------------------------------
c     Zonal derivative of TH (DTHDX)
c     -------------------------------------------------------------------------

      subroutine calc_DTHDX (dthdx,t1,t0,p,lat)

      implicit none

c     Argument declaration
      real  dthdx  ! Derivative of TH in zonal direction [K/m]
      real  t1     ! T @ LON + 1 DLON [K]
      real  t0     ! T @ LON - 1 DLON [K]
      real  p      ! P [hPa]
      real  lat    ! Latitude [deg]

c     Physical parameters
      real      pi180
      parameter (pi180=3.14159/180.)
      real      deltay
      parameter (deltay =1.11e5)
      real      rdcp,pref
      data      rdcp,pref /0.286,1000./

      dthdx = (pref/p)**rdcp *
     >        (t1-t0) / ( 2. * deltay * cos(pi180 * lat) )

      end

c     -------------------------------------------------------------------------
c     Meridional derivative of U (DUDY)
c     -------------------------------------------------------------------------

      subroutine calc_DUDY (dudy,u1,u0)

      implicit none

c     Argument declaration
      real  dudy   ! Derivative of U in meridional direction [s^-1]
      real  u1     ! U @ LAT + 1 DLAT [m/s]
      real  u0     ! U @ LAT - 1 DLAT [m/s]

c     Physical parameters
      real      deltay
      parameter (deltay =1.11e5)

      dudy = (u1-u0) / ( 2. * deltay )

      end

c     -------------------------------------------------------------------------
c     Meridional derivative of V (DVDY)
c     -------------------------------------------------------------------------

      subroutine calc_DVDY (dvdy,v1,v0)

      implicit none

c     Argument declaration
      real  dvdy   ! Derivative of V in meridional direction [s^-1]
      real  v1     ! V @ LAT + 1 DLAT [m/s]
      real  v0     ! V @ LAT - 1 DLAT [m/s]

c     Physical parameters
      real      deltay
      parameter (deltay =1.11e5)

      dvdy = (v1-v0) / ( 2. * deltay )

      end

c     -------------------------------------------------------------------------
c     Meridional derivative of T (DTDY)
c     -------------------------------------------------------------------------

      subroutine calc_DTDY (dtdy,t1,t0)

      implicit none

c     Argument declaration
      real  dtdy   ! Derivative of T in meridional direction [K/m]
      real  t1     ! T @ LAT + 1 DLAT [K]
      real  t0     ! T @ LAT - 1 DLAT [K]

c     Physical parameters
      real      deltay
      parameter (deltay =1.11e5)

      dtdy = (t1-t0) / ( 2. * deltay )

      end

c     -------------------------------------------------------------------------
c     Meridional derivative of TH (DTHDY)
c     -------------------------------------------------------------------------

      subroutine calc_DTHDY (dthdy,t1,t0,p)

      implicit none

c     Argument declaration
      real  dthdy  ! Derivative of TH in meridional direction [K/m]
      real  t1     ! TH @ LAT + 1 DLAT [K]
      real  t0     ! TH @ LAT - 1 DLAT [K]
      real  p      ! P [hPa]

c     Physical parameters
      real      deltay
      parameter (deltay =1.11e5)
      real      rdcp,pref
      data      rdcp,pref /0.286,1000./

      dthdy = (pref/p)**rdcp * (t1-t0) / ( 2. * deltay )

      end

c     -------------------------------------------------------------------------
c     Wind shear of U (DUDP)
c     -------------------------------------------------------------------------

      subroutine calc_DUDP (dudp,u1,u0,p1,p0)

      implicit none

c     Argument declaration
      real  dudp   ! Wind shear [m/s per Pa]
      real  u1     ! U @ P + 1 DP [m/s]
      real  u0     ! U @ P - 1 DP [m/s]
      real  p1     ! P + 1 DP [hPa]
      real  p0     ! P - 1 DP [hPa]

      dudp = 0.01 * (u1-u0) / (p1-p0)

      end

c     -------------------------------------------------------------------------
c     Wind shear of V (DVDP)
c     -------------------------------------------------------------------------

      subroutine calc_DVDP (dvdp,v1,v0,p1,p0)

      implicit none

c     Argument declaration
      real  dvdp   ! Wind shear [m/s per Pa]
      real  v1     ! V @ P + 1 DP [m/s]
      real  v0     ! V @ P - 1 DP [m/s]
      real  p1     ! P + 1 DP [hPa]
      real  p0     ! P - 1 DP [hPa]

      dvdp = 0.01 * (v1-v0) / (p1-p0)

      end

c     -------------------------------------------------------------------------
c     Vertical derivative of T (DTDP)
c     -------------------------------------------------------------------------

      subroutine calc_DTDP (dtdp,t1,t0,p1,p0)

      implicit none

c     Argument declaration
      real  dtdp   ! Vertical derivative of T [K/Pa]
      real  t1     ! T @ P + 1 DP [K]
      real  t0     ! T @ P - 1 DP [K]
      real  p1     ! P + 1 DP [hPa]
      real  p0     ! P - 1 DP [hPa]

      dtdp = 0.01 * (t1-t0) / (p1-p0)

      end

c     -------------------------------------------------------------------------
c     Vertical derivative of TH (DTHDP)
c     -------------------------------------------------------------------------

      subroutine calc_DTHDP (dthdp,t1,t0,p1,p0,p,t)

      implicit none

c     Argument declaration
      real  dthdp  ! Vertical derivative of TH [K/Pa]
      real  t1     ! T @ P + 1 DP [K]
      real  t0     ! T @ P - 1 DP [K]
      real  t      ! T [K]
      real  p1     ! P + 1 DP [hPa]
      real  p0     ! P - 1 DP [hPa]
      real  p      ! P [hPa]

c     Physical parameters
      real      rdcp,tzero,pref
      data      rdcp,tzero,pref /0.286,273.15,1000./

c     Auxiliary variables
      real      tk1,tk0,tk

      if (t0.lt.100.) then
         tk0 = t0 + tzero
      endif
      if (t1.lt.100.) then
         tk1 = t1 + tzero
      endif
      if (t.lt.100.) then
         tk  = t  + tzero
      endif

      dthdp = 0.01*(pref/p)**rdcp *
     >      ( (tk1-tk0)/(p1-p0) - rdcp * tk/p )

      end

c     -------------------------------------------------------------------------
c     Squared Brunt-Vaisäla frequency (NSQ)
c     -------------------------------------------------------------------------

      subroutine calc_NSQ (nsq,dthdp,th,rho)

      implicit none

c     Argument declaration
      real  nsq    ! Squared Brunt-Vaisäla frequency [s^-1]
      real  dthdp  ! D(TH)/DP [K/Pa]
      real  th     ! K
      real  rho    ! Density [kg m^-3]

c     Physical parameters
      real      g
      parameter (g=9.81)

      nsq = -g**2/th * rho * dthdp

      end

c     -------------------------------------------------------------------------
c     Relative vorticity (RELVORT)
c     -------------------------------------------------------------------------

      subroutine calc_RELVORT (relvort,dudy,dvdx,u,lat)

      implicit none

c     Argument declaration
      real  relvort    ! Relative vorticity [s^-1]
      real  u          ! Zonal wind component [m/s]
      real  dudy       ! du/dy [s^-1]
      real  dvdx       ! dv/dx [s^-1]
      real  lat        ! Latitude [deg]

c     Physical parameters
      real      pi180
      parameter (pi180=3.14159/180.)
      real      deltay
      parameter (deltay =1.11e5)

      relvort = dvdx - dudy + u * pi180/deltay * tan(pi180 * lat)

      end

c     -------------------------------------------------------------------------
c     Absolute vorticity (ABSVORT)
c     -------------------------------------------------------------------------

      subroutine calc_ABSVORT (absvort,dudy,dvdx,u,lat)

      implicit none

c     Argument declaration
      real  absvort    ! Absolute vorticity [s^-1]
      real  u          ! Zonal wind component [m/s]
      real  dudy       ! du/dy [s^-1]
      real  dvdx       ! dv/dx [s^-1]
      real  lat        ! Latitude [deg]

c     Physical parameters
      real      pi180
      parameter (pi180=3.14159/180.)
      real      deltay
      parameter (deltay =1.11e5)
      real      omega
      parameter (omega=7.292e-5)

      absvort = dvdx - dudy + u * pi180/deltay * tan(pi180 * lat) +
     >          2. * omega * sin(pi180 * lat)

      end

c     -------------------------------------------------------------------------
c     Divergence (DIV)
c     -------------------------------------------------------------------------

      subroutine calc_DIV (div,dudx,dvdy,v,lat)

      implicit none

c     Argument declaration
      real  div        ! Divergence [s^-1]
      real  v          ! Meridional wind component [m/s]
      real  dudx       ! du/dx [s^-1]
      real  dvdy       ! dv/dy [s^-1]
      real  lat        ! Latitude [deg]

c     Physical parameters
      real      pi180
      parameter (pi180=3.14159/180.)
      real      deltay
      parameter (deltay =1.11e5)

      div = dudx + dvdy - v * pi180/deltay * tan(pi180 * lat)

      end

c     -------------------------------------------------------------------------
c     Deformation (DEF)
c     -------------------------------------------------------------------------

      subroutine calc_DEF (def,dudx,dvdx,dudy,dvdy)

      implicit none

c     Argument declaration
      real  def        ! Deformation [s^-1]
      real  dudx       ! du/dx [s^-1]
      real  dvdx       ! dv/dy [s^-1]
      real  dudy       ! du/dx [s^-1]
      real  dvdy       ! dv/dy [s^-1]

c     Physical parameters
      real      pi180
      parameter (pi180=3.14159/180.)

      def = sqrt( (dvdx+dudy)**2 + (dudx-dvdy)**2 )

      end

c     -------------------------------------------------------------------------
c     Potential Vorticity (PV)
c     -------------------------------------------------------------------------

      subroutine calc_PV (pv,absvort,dthdp,dudp,dvdp,dthdx,dthdy)

      implicit none

c     Argument declaration
      real  pv         ! Ertel-PV [PVU]
      real  absvort    ! Absolute vorticity [s^-1]
      real  dthdp      ! dth/dp [K/Pa]
      real  dudp       ! du/dp [m/s per Pa]
      real  dvdp       ! dv/dp [m/s per Pa]
      real  dthdx      ! dth/dx [K/m]
      real  dthdy      ! dth/dy [K/m]

c     Physical and numerical parameters
      real      scale
      parameter (scale=1.E6)
      real      g
      parameter (g=9.80665)

      pv = -scale * g * ( absvort * dthdp + dudp * dthdy - dvdp * dthdx)

      end

c     -------------------------------------------------------------------------
c     Richardson number (RI)
c     -------------------------------------------------------------------------

      subroutine calc_RI (ri,dudp,dvdp,nsq,rho)

      implicit none

c     Argument declaration
      real  ri         ! Richardson number
      real  dudp       ! Du/Dp [m/s per Pa]
      real  dvdp       ! Dv/Dp [m/s per Pa]
      real  nsq        ! Squared Brunt-Vailälä frequency [s^-1]
      real  rho        ! Density [kg/m^3]

c     Physical and numerical parameters
      real      g
      parameter (g=9.80665)

      ri = nsq / ( dudp**2 + dvdp**2 ) / ( rho * g )**2

      end

c     -------------------------------------------------------------------------
c     Ellrod and Knapp's turbulence indicator (TI)
c     -------------------------------------------------------------------------

      subroutine calc_TI (ti,def,dudp,dvdp,rho)

      implicit none

c     Argument declaration
      real  ti         ! Turbulence idicator
      real  def        ! Deformation [s^-1]
      real  dudp       ! Du/Dp [m/s per Pa]
      real  dvdp       ! Dv/Dp [m/s per Pa]
      real  rho        ! Density [kg/m^3]

c     Physical and numerical parameters
      real      g
      parameter (g=9.80665)

      ti = def * sqrt ( dudp**2 + dvdp**2 ) * ( rho * g )

      end

c     -------------------------------------------------------------------------
c     Distance from starting position
c     -------------------------------------------------------------------------

      subroutine calc_DIST0 (dist0,lon0,lat0,lon1,lat1)

      implicit none

c     Argument declaration
      real  dist0      ! Distance from starting position [km]
      real  lon0,lat0  ! Starting position
      real  lon1,lat1  ! New position

c     Externals
      real     sdis
      external sdis

      dist0 = sdis(lon0,lat0,lon1,lat1)

      end

c     -------------------------------------------------------------------------
c     Heading of the trajectory (HEAD)
c     -------------------------------------------------------------------------

      subroutine calc_HEAD (head,lon0,lat0,lon1,lat1)

      implicit none

c     Argument declaration
      real  head       ! Heading angle (in deg) relativ to zonal direction
      real  lon0,lat0  ! Starting position
      real  lon1,lat1  ! New position

c     Physical parameters
      real      pi180
      parameter (pi180=3.14159/180.)

c     Auixiliary variables
      real     dx,dy

      dx = (lon1-lon0) * cos(pi180*0.5*(lat0+lat1))
      dy = lat1-lat0

      call getangle(1.,0.,dx,dy,head)

      end

c
c     *************************************************************************
c     Auxiliary subroutines and functions
c     *************************************************************************

c     -------------------------------------------------------------------------
c     Saturation vapor pressure over water
c     -------------------------------------------------------------------------

      real function esat(t)

C     This function returns the saturation vapor pressure over water
c     (mb) given the temperature (Kelvin).
C     The algorithm is due to Nordquist, W. S. ,1973: "Numerical
C     Approximations of Selected Meteorological Parameters for Cloud
C     Physics Problems" ECOM-5475, Atmospheric Sciences Laboratory,
c     U. S. Army Electronics Command, White Sands Missile Range,
c     New Mexico 88002.

      real p1,p2,c1,t

      p1=11.344-0.0303998*t
      p2=3.49149-1302.8844/t
      c1=23.832241-5.02808*log10(t)
      esat=10.**(c1-1.3816e-7*10.**p1+8.1328e-3*10.**p2-2949.076/t)

      end

c     --------------------------------------------------------------------------
c     Angle between two vectors
c     --------------------------------------------------------------------------

      SUBROUTINE getangle (ux1,uy1,ux2,uy2,angle)

c     Given two vectors <ux1,uy1> and <ux2,uy2>, determine the angle (in deg)
c     between the two vectors.

      implicit none

c     Declaration of subroutine parameters
      real ux1,uy1
      real ux2,uy2
      real angle

c     Auxiliary variables and parameters
      real len1,len2,len3
      real val1,val2,val3
      real vx1,vy1
      real vx2,vy2
      real pi
      parameter (pi=3.14159265359)

      vx1 = ux1
      vx2 = ux2
      vy1 = uy1
      vy2 = uy2

      len1=sqrt(vx1*vx1+vy1*vy1)
      len2=sqrt(vx2*vx2+vy2*vy2)

      if ((len1.gt.0.).and.(len2.gt.0.)) then
         vx1=vx1/len1
         vy1=vy1/len1
         vx2=vx2/len2
         vy2=vy2/len2

         val1=vx1*vx2+vy1*vy2
         val2=-vy1*vx2+vx1*vy2

         len3=sqrt(val1*val1+val2*val2)

         if ( (val1.ge.0.).and.(val2.ge.0.) ) then
            val3=acos(val1/len3)
         else if ( (val1.lt.0.).and.(val2.ge.0.) ) then
            val3=pi-acos(abs(val1)/len3)
         else if ( (val1.ge.0.).and.(val2.le.0.) ) then
            val3=-acos(val1/len3)
         else if ( (val1.lt.0.).and.(val2.le.0.) ) then
            val3=-pi+acos(abs(val1)/len3)
         endif
      else
         val3=0.
      endif

      angle=180./pi*val3

      END

c     --------------------------------------------------------------------------
c     Spherical distance between lat/lon points
c     --------------------------------------------------------------------------

      real function sdis(xp,yp,xq,yq)
c
c     calculates spherical distance (in km) between two points given
c     by their spherical coordinates (xp,yp) and (xq,yq), respectively.
c
      real      re
      parameter (re=6370.)
      real      pi180
      parameter (pi180=3.14159/180.)
      real      xp,yp,xq,yq,arg

      arg=sin(pi180*yp)*sin(pi180*yq)+
     >    cos(pi180*yp)*cos(pi180*yq)*cos(pi180*(xp-xq))
      if (arg.lt.-1.) arg=-1.
      if (arg.gt.1.) arg=1.

      sdis=re*acos(arg)

      end


!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
! Two band model (3D)
module global_variables_ms
  use mpi_module

! mathematical parameters
  real(8),parameter :: pi = 4d0*atan(1d0)
  complex(8),parameter :: zI = (0d0,1d0)
  real(8),parameter :: a_B=0.529177d0,Ry=13.6058d0
  real(8),parameter :: c_light=137.03953250d0

! Material parameter
  integer :: NKr,NKz
  real(8) :: kr_max,kz_max,dkr,dkz
  real(8),allocatable :: kr(:),kz0(:),kz(:)
  real(8),parameter :: piz_vc = 0.9d0, mass_r = 0.5d0, eps_g = 9d0/(2d0*Ry)

! Time-propagation
  integer :: Nt
  real(8) :: dt
  real(8),allocatable :: deps_int(:,:,:),deps(:,:,:)
  complex(8),allocatable :: zCt(:,:,:,:)
  real(8),allocatable :: Act(:),Act_dt2(:),jtz(:),jtz_intra(:),jtz_inter(:)

! Laser parameters
  real(8) :: E0_1,omega_1,tpulse_1,omega_ev_1,tpulse_fs_1,Iwcm2_1
  real(8) :: E0_2,omega_2,tpulse_2,omega_ev_2,tpulse_fs_2,Iwcm2_2
  real(8) :: Tdelay_fs,Tdelay
  character(20) :: envelope_1,envelope_2

! FDTD
  integer :: Nx_L = -2000,Nx_R = 2000, Mx = 200
  real(8) :: Hx = 250d0
  real(8),allocatable :: xn(:), Az(:), Az_new(:), Az_old(:), jz(:)
  real(8),allocatable :: jz_store(:,:), Az_store(:,:)
  integer :: Mx_s,Mx_e

end module global_variables_ms


c
c-----------------------------------------------------------------------
c
c
c
      double precision function p18f(amu)
      implicit double precision (a-h,o-z)
      common/p18c/ delta,pmu0,theta
      p18f = delta*datan(delta*dtan(amu)) - amu - pmu0 - theta
      return
      end


      COMPLEX*16 FUNCTION C0IRF_Wdec(M12,M22,P2)
*------------------------------------------
      IMPLICIT NONE!
*-------------------
      REAL*8 P2,D2,DREAL,DABS
      COMPLEX*16 M12,M22,SQR,P2P,P2M,X1,X2,F1
      COMPLEX*16 LOG,SQRT,DCMPLX,XSPENZ_Wdec
      PARAMETER (D2=1.64493406684822618D0)
*-
      IF((DREAL(M12).EQ.DREAL(M22)).AND.DREAL(M12).LT.1d-6) THEN
       C0IRF_Wdec=1D0/P2
     &           *(1D0/2D0*(LOG((P2-DCMPLX(0D0,1D-20))/M12))**2-D2)
       RETURN
      ENDIF
*-
      SQR=SQRT(P2**2+2D0*P2*(M12+M22)+(M12-M22)**2)
        IF(DABS(DREAL(P2P)).GE.DABS(DREAL(P2M))) THEN
        P2P=P2-M12+M22+SQR
        P2M=P2-M12+M22-SQR
        IF(DREAL(P2P).GE.DREAL(P2M)) THEN
         X1=P2P/2D0/P2
         X2=-2D0*M12/P2P
        ELSE
         X2=P2M/2D0/P2
         X1=-2D0*M12/P2M
        ENDIF
      ELSE
        P2P=P2-M22+M12+SQR
        P2M=P2-M22+M12-SQR
        IF(DABS(DREAL(P2P)).GE.DABS(DREAL(P2M))) THEN
         X1=P2P/2D0/P2
         X2=-2D0*M22/P2P
        ELSE
         X2=P2M/2D0/P2
         X1=-2D0*M22/P2M
        ENDIF
      ENDIF
*-
      F1=1D0/SQR*(LOG(1D0-1D0/X2)-LOG(1D0-1D0/X1))
*-
      C0IRF_Wdec=1D0/2*F1*LOG((P2-DCMPLX(0D0,1D-20))/M22)
     &    +1D0/2*(1D0/SQR*(
     & +.5D0*LOG((1D0-X2)*(X1-X2))**2
     & -.5D0*LOG(   (-X2)*(X1-X2))**2
     & -.5D0*LOG((X1-1D0)*(X1-X2))**2
     & +.5D0*LOG( X1     *(X1-X2))**2
     & -XSPENZ_Wdec((1D0-X2)/(X1-X2))+XSPENZ_Wdec((-X2)/(X1-X2))
     & +XSPENZ_Wdec((1D0-X1)/(X2-X1))-XSPENZ_Wdec((-X1)/(X2-X1))
     &                    ))
*-
      RETURN
      END


MODULE complex

  USE ISO_C_BINDING
  IMPLICIT NONE

CONTAINS

  FUNCTION add_complex(x1, x2) RESULT(y)
    COMPLEX, INTENT(in) :: x1, x2
    COMPLEX :: y
    y = x1 + x2
  END FUNCTION add_complex

  FUNCTION add_complex4(x1, x2) RESULT(y)
    COMPLEX(4), INTENT(in) :: x1, x2
    COMPLEX(4) :: y
    y = x1 + x2
  END FUNCTION add_complex4

  FUNCTION add_complex8(x1, x2) RESULT(y)
    COMPLEX(8), INTENT(in) :: x1, x2
    COMPLEX(8) :: y
    y = x1 + x2
  END FUNCTION add_complex8

  FUNCTION add_complex_cfloat(x1, x2) RESULT(y)
    COMPLEX(C_FLOAT_COMPLEX), INTENT(in) :: x1, x2
    COMPLEX(C_FLOAT_COMPLEX) :: y
    y = x1 + x2
  END FUNCTION add_complex_cfloat

  FUNCTION add_complex_cdouble(x1, x2) RESULT(y)
    COMPLEX(C_DOUBLE_COMPLEX), INTENT(in) :: x1, x2
    COMPLEX(C_DOUBLE_COMPLEX) :: y
    y = x1 + x2
  END FUNCTION add_complex_cdouble

  FUNCTION add_complex_byval(x1, x2) RESULT(y)
    COMPLEX(C_FLOAT_COMPLEX), INTENT(in), VALUE :: x1, x2
    COMPLEX(C_FLOAT_COMPLEX) :: y
    y = x1 + x2
  END FUNCTION add_complex_byval

  FUNCTION complex_sum(n, x) RESULT(y)
    INTEGER(C_INT), INTENT(in) :: n
    COMPLEX(C_FLOAT_COMPLEX), INTENT(in) :: x(n)
    COMPLEX(C_FLOAT_COMPLEX) :: y
    y = SUM(x)
  END FUNCTION complex_sum

END MODULE complex


! stat.f90
!
!>  Statistics accumulators
!
!> @copyright
!> 2015 Lesley De Cruz & Jonathan Demaeyer.
!> See LICENSE.txt for license information.
!
!---------------------------------------------------------------------------!

MODULE stat
  USE params, only: ndim
  IMPLICIT NONE

! PRIVATE
  PUBLIC !STEVE

  INTEGER :: stat_i=0 !< Number of stats accumulated  !STEVE: changed "i" to "stat_i" after making this public
                      ! (change to public is needed to implement 'model_finalize' to deallocate these arrays

  ! Vectors holding the stats
  REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: m       !< Vector storing the inline mean
  REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: mprev   !< Previous mean vector
  REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: v       !< Vector storing the inline variance
  REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: mtmp

  PUBLIC :: acc,init_stat,mean,var,iter,reset

  CONTAINS

    !> Initialise the accumulators
    SUBROUTINE init_stat
      INTEGER :: AllocStat

      if (.not. allocated(m) .or. .not. allocated(mprev) .or. .not. allocated(v) .or. .not. allocated(mtmp)) then !STEVE: fixing init clash
        ALLOCATE(m(0:ndim),mprev(0:ndim),v(0:ndim),mtmp(0:ndim), STAT=AllocStat)
      endif
      IF (AllocStat /= 0) then
        print *, "init_stat:: AllocStat = ", AllocStat
        STOP '*** Not enough memory ***'
      ENDIF
      m=0.D0
      mprev=0.D0
      v=0.D0
      mtmp=0.D0

    END SUBROUTINE init_stat

    !> Accumulate one state
    SUBROUTINE acc(x)
      IMPLICIT NONE
      REAL(KIND=8), DIMENSION(0:ndim), INTENT(IN) :: x
      stat_i=stat_i+1
      mprev=m+(x-m)/stat_i
      mtmp=mprev
      mprev=m
      m=mtmp
      v=v+(x-mprev)*(x-m)
    END SUBROUTINE acc

    !> Function returning the mean
    FUNCTION mean()
      REAL(KIND=8), DIMENSION(0:ndim) :: mean
      mean=m
    END FUNCTION mean

    !> Function returning the variance
    FUNCTION var()
      REAL(KIND=8), DIMENSION(0:ndim) :: var
      var=v/(stat_i-1)
    END FUNCTION var

    !> Function returning the number of data accumulated
    FUNCTION iter()
      INTEGER :: iter
      iter=stat_i
    END FUNCTION iter

    !> Routine resetting the accumulators
    SUBROUTINE reset
      m=0.D0
      mprev=0.D0
      v=0.D0
      stat_i=0
    END SUBROUTINE reset

  END MODULE stat


MODULE nrtype
       INTEGER, PARAMETER :: I4B = SELECTED_INT_KIND(9)
       INTEGER, PARAMETER :: I2B = SELECTED_INT_KIND(4)
       INTEGER, PARAMETER :: I1B = SELECTED_INT_KIND(2)
       INTEGER, PARAMETER :: SP = KIND(1.0)
       INTEGER, PARAMETER :: DP = KIND(1.0D0)
       INTEGER, PARAMETER :: SPC = KIND((1.0,1.0))
       INTEGER, PARAMETER :: DPC = KIND((1.0D0,1.0D0))
       INTEGER, PARAMETER :: LGT = KIND(.true.)
       REAL(SP), PARAMETER :: PI=3.141592653589793238462643383279502884197_sp
       REAL(SP), PARAMETER :: PIO2=1.57079632679489661923132169163975144209858_sp
       REAL(SP), PARAMETER :: TWOPI=6.283185307179586476925286766559005768394_sp
       REAL(SP), PARAMETER :: SQRT2=1.41421356237309504880168872420969807856967_sp
       REAL(SP), PARAMETER :: EULER=0.5772156649015328606065120900824024310422_sp
       REAL(DP), PARAMETER :: PI_D=3.141592653589793238462643383279502884197_dp
       REAL(DP), PARAMETER :: PIO2_D=1.57079632679489661923132169163975144209858_dp
       REAL(DP), PARAMETER :: TWOPI_D=6.283185307179586476925286766559005768394_dp
       TYPE sprs2_sp
              INTEGER(I4B) :: n,len
              REAL(SP), DIMENSION(:), POINTER :: val
              INTEGER(I4B), DIMENSION(:), POINTER :: irow
              INTEGER(I4B), DIMENSION(:), POINTER :: jcol
       END TYPE sprs2_sp
       TYPE sprs2_dp
              INTEGER(I4B) :: n,len
              REAL(DP), DIMENSION(:), POINTER :: val
              INTEGER(I4B), DIMENSION(:), POINTER :: irow
              INTEGER(I4B), DIMENSION(:), POINTER :: jcol
       END TYPE sprs2_dp
END MODULE nrtype


program main
  use eigen_libs_mod
  use mpi
  implicit none
  integer, parameter :: n = 8
  integer :: provided, ierr, myrank, nprocs, nprow, npcol
  integer :: inod, x_inod, y_inod
  integer :: nm, ny, i, j
  integer :: il, jl, iloop_sta, iloop_end, jloop_sta, jloop_end
  double precision, allocatable :: a(:,:), z(:,:), w(:)

  call MPI_init_thread(MPI_THREAD_MULTIPLE, provided, ierr)
  call MPI_comm_rank(MPI_COMM_WORLD, myrank, ierr)
  call eigen_init(MPI_COMM_WORLD)
  call eigen_get_procs(nprocs, npcol, nprow)
  if (myrank == 0) then
     print *, "n =", n
     print *, "nprocs =", nprocs
     print *, "nprow =", nprow
     print *, "npcol =", npcol
  end if
  call eigen_get_id(inod, x_inod, y_inod)

  call eigen_get_matdims(n, nm, ny)
  allocate(a(nm, ny), z(nm, ny), w(n))

  jloop_sta = eigen_loop_start(1, nprow, y_inod)
  jloop_end = eigen_loop_end(n, nprow, y_inod)
  iloop_sta = eigen_loop_start(1, npcol, x_inod)
  iloop_end = eigen_loop_end(n, npcol, x_inod)
  if (jloop_sta <= jloop_end) then
     do jl = jloop_sta, jloop_end
        j = eigen_translate_l2g(jl, nprow, y_inod)
        do il = iloop_sta, iloop_end
           i = eigen_translate_l2g(il, npcol, x_inod)
           a(il, jl) = dble(min(i, j))
        end do
     end do
  end if

  call eigen_sx(n, n, a, nm, w, z, nm, 48, 128, 'A')
  if (myrank == 0) then
     print *, "eigenvalues:", w(:)
  end if

  deallocate(a, z, w)
  call eigen_free()
  call MPI_Finalize(ierr)
end program main


C  *********************************************************
C  *                                                       *
C  *    TEST NUMBER: 06.01.01/01                           *
C  *    TEST TITLE : Behavior of translations              *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      COMMON /GLOBNU/ CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT, DUMRL
      INTEGER         CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT(20), ERRIND
      REAL    DUMRL(20)

      COMMON /GLOBCH/ PIDENT,    GLBERR,    TSTMSG,     FUNCID,
     1                DUMCH
      CHARACTER       PIDENT*40, GLBERR*60, TSTMSG*900, FUNCID*80,
     1                DUMCH(20)*20

      REAL      ACT4X4(4,4), EXP4X4(4,4), DX,DY,DZ
      REAL      ACT3X3(3,3), EXP3X3(3,3)

      LOGICAL   TRNSEQ

      CALL INITGL ('06.01.01/01')

C open PHIGS
      CALL XPOPPH (ERRFIL, MEMUN)
      CALL SETMSG ('1 2 3', '<Translate 3> should return a '        //
     1             'correct representation for the transformation ' //
     2             'to translate a 3D point, with non-zero '        //
     3             'parameters.')

      DX = -33.3
      DY =   0.0076
      DZ =   2.2

C  <Translate 3> with dx,dy,dz returns act4x4 = actual array
      CALL PTR3   (DX,DY,DZ, ERRIND, ACT4X4)
      CALL CHKINQ ('ptr3', ERRIND)

C  Compute exp4x4 = expected array
      CALL ETR3   (DX,DY,DZ, EXP4X4)

C  pass if matrices represent same transformation
      CALL IFPF   (TRNSEQ(4, ACT4X4, EXP4X4))

      CALL SETMSG ('1 2 3', '<Translate 3> should return a '        //
     1             'correct representation for the transformation ' //
     2             'to translate a 3D point, with zero parameters.')

      DX = 0.0
      DY = 0.0076
      DZ = 0.0

C  <Translate 3> with dx,dy,dz returns act4x4 = actual array
      CALL PTR3   (DX,DY,DZ, ERRIND, ACT4X4)
      CALL CHKINQ ('ptr3', ERRIND)

C  Compute exp4x4 = expected array
      CALL ETR3   (DX,DY,DZ, EXP4X4)

C  pass if matrices represent same transformation
      CALL IFPF   (TRNSEQ(4, ACT4X4, EXP4X4))

      CALL SETMSG ('1 2 4', '<Translate> should return a '          //
     1             'correct representation for the transformation ' //
     2             'to translate a 2D point, with non-zero '        //
     3             'parameters.')

      DX = -33.3
      DY =   0.0076

C  <Translate> with dx,dy returns act3x3 = actual array
      CALL PTR    (DX,DY, ERRIND, ACT3X3)
      CALL CHKINQ ('ptr', ERRIND)

C  Compute exp3x3 = expected array
      CALL ETR   (DX,DY, EXP3X3)

C  pass if matrices represent same transformation
      CALL IFPF   (TRNSEQ(3, ACT3X3, EXP3X3))

      CALL SETMSG ('1 2 4', '<Translate> should return a '          //
     1             'correct representation for the transformation ' //
     2             'to translate a 2D point, with zero parameters.')

      DX = 0.0
      DY = 0.0

C  <Translate> with dx,dy returns act3x3 = actual array
      CALL PTR    (DX,DY, ERRIND, ACT3X3)
      CALL CHKINQ ('ptr', ERRIND)

C  Compute exp3x3 = expected array
      CALL ETR   (DX,DY, EXP3X3)

C  pass if matrices represent same transformation
      CALL IFPF  (TRNSEQ(3, ACT3X3, EXP3X3))

      CALL ENDIT
      END


      SUBROUTINE dFOUR1(DATA,NN,ISIGN)
!
! Double-precision version of Numerical recipes FOUR1 routine.
!
      implicit none
      integer nn,isign
      real*8 data(2*nn)
! Local variables
      integer i,istep,j,m,mmax,n
      REAL*8 WR,WI,WPR,WPI,WTEMP,THETA,tempi,tempr

      N=2*NN
      J=1
      DO 11 I=1,N,2
         IF(J.GT.I)THEN
            TEMPR=DATA(J)
            TEMPI=DATA(J+1)
            DATA(J)=DATA(I)
            DATA(J+1)=DATA(I+1)
            DATA(I)=TEMPR
            DATA(I+1)=TEMPI
         ENDIF
         M=N/2
 1       IF ((M.GE.2).AND.(J.GT.M)) THEN
            J=J-M
            M=M/2
            GO TO 1
         ENDIF
         J=J+M
 11   CONTINUE
      MMAX=2
 2    IF (N.GT.MMAX) THEN
         ISTEP=2*MMAX
         THETA=6.28318530717959D0/(ISIGN*MMAX)
         WPR=-2.D0*DSIN(0.5D0*THETA)**2
         WPI=DSIN(THETA)
         WR=1.D0
         WI=0.D0
         DO 13 M=1,MMAX,2
            DO 12 I=M,N,ISTEP
               J=I+MMAX
               TEMPR= (WR)*DATA(J)- (WI)*DATA(J+1)
               TEMPI= (WR)*DATA(J+1)+ (WI)*DATA(J)
               DATA(J)=DATA(I)-TEMPR
               DATA(J+1)=DATA(I+1)-TEMPI
               DATA(I)=DATA(I)+TEMPR
               DATA(I+1)=DATA(I+1)+TEMPI
 12         CONTINUE
            WTEMP=WR
            WR=WR*WPR-WI*WPI+WR
            WI=WI*WPR+WTEMP*WPI+WI
 13      CONTINUE
         MMAX=ISTEP
         GO TO 2
      ENDIF
      RETURN
      END SUBROUTINE dFOUR1


*DECK DPOFA
      SUBROUTINE DPOFA (A, LDA, N, INFO)
C***BEGIN PROLOGUE  DPOFA
C***PURPOSE  Factor a real symmetric positive definite matrix.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2B1B
C***TYPE      DOUBLE PRECISION (SPOFA-S, DPOFA-D, CPOFA-C)
C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION,
C             POSITIVE DEFINITE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     DPOFA factors a double precision symmetric positive definite
C     matrix.
C
C     DPOFA is usually called by DPOCO, but it can be called
C     directly with a saving in time if  RCOND  is not needed.
C     (time for DPOCO) = (1 + 18/N)*(time for DPOFA) .
C
C     On Entry
C
C        A       DOUBLE PRECISION(LDA, N)
C                the symmetric matrix to be factored.  Only the
C                diagonal and upper triangle are used.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C     On Return
C
C        A       an upper triangular matrix  R  so that  A = TRANS(R)*R
C                where  TRANS(R)  is the transpose.
C                The strict lower triangle is unaltered.
C                If  INFO .NE. 0 , the factorization is not complete.
C
C        INFO    INTEGER
C                = 0  for normal return.
C                = K  signals an error condition.  The leading minor
C                     of order  K  is not positive definite.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DDOT
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPOFA
      INTEGER LDA,N,INFO
      DOUBLE PRECISION A(LDA,*)
C
      DOUBLE PRECISION DDOT,T
      DOUBLE PRECISION S
      INTEGER J,JM1,K
C***FIRST EXECUTABLE STATEMENT  DPOFA
         DO 30 J = 1, N
            INFO = J
            S = 0.0D0
            JM1 = J - 1
            IF (JM1 .LT. 1) GO TO 20
            DO 10 K = 1, JM1
               T = A(K,J) - DDOT(K-1,A(1,K),1,A(1,J),1)
               T = T/A(K,K)
               A(K,J) = T
               S = S + T*T
   10       CONTINUE
   20       CONTINUE
            S = A(J,J) - S
            IF (S .LE. 0.0D0) GO TO 40
            A(J,J) = SQRT(S)
   30    CONTINUE
         INFO = 0
   40 CONTINUE
      RETURN
      END


!> Simple program to test the timing API
PROGRAM timer_test
  use dl_timer
  use dl_timer_constants_mod

  integer :: time0
  integer :: istep
  integer(i_def64), parameter :: nstep = 1000

  real(r_def) :: mysum
  !--------------------------------------------------------------
  ! Initialisation

  call timer_init()
  mysum = 0.0d0

  !--------------------------------------------------------------
  ! Time-stepping

  call timer_start(time0, label='Time-stepping', num_repeats=nstep)

  do istep = 1, nstep
     mysum = mysum + sqrt(5.0d0*istep*istep)
  end do

  call timer_stop(time0)

  !---------------------------------------------------------------
  ! Finalise

  ! Output the result to prevent the compiler optimising-out the loop
  write (*,*) 'Fake checksum = ', mysum

  call timer_report()

END PROGRAM timer_test


!======================
! 1D euler eq.
!=====================
program Euler

    use modValues
    use modPressure
    use modContinuity
    use modEnergy
    use modMomentum
    use modResidual
    use modEOS
    use modBC
    use modInput
    !use modFaceValues
    implicit none
    LOGICAL:: there

    INQUIRE (FILE = 'residual.txt', EXIST = there)
    IF (there) then
        OPEN(20, FILE = 'residual.txt', STATUS = 'REPLACE')
    ELSE
        OPEN(20, FILE = 'residual.txt', STATUS = 'NEW')
    END IF
    close(20)

    CALL getInput()

    CALL getAllocate()

    CALL getInputSpec()

    !-------- one-dimensional Mesh
    dx = len/real(ncell,8)
    do i=nTCellStr,nTCellEnd
      ! x value of cell center point
      cX(i) = 0.5d0*dx + (real(i,8)-1.d0)*dx
      cVol(i) = dx*1.d0*1.d0
    enddo
    do i=nFaceStr,nFaceEnd
      area(i) = 1.d0
    enddo

    !-------- initial condition
    ! w=(rho,u,p), primitive variables
    do i=nTCellStr,nTCellEnd
      !> sod shock condition
      if( cX(i) < 0.5d0 ) then
          cP(i)   = 1.000d0
          cU(i)   = 0.000d0
          cT(i)   = 0.003486055811614
      else
          cP(i)   = 0.100d0
          cU(i)   = 0.000d0
          cT(i)   = 0.002788844649291
      endif
    enddo
    !--------- BC
    CALL getBC(leftBC='supBC',rightBC='supBC')

    !--------- Ht, Et, T, c from EOS
    CALL getEOS(eosRho='on',eosHt='on',eosDRDP='on',eosDRDT='on',&
                eosDHDP='on',eosDHDT='on',eosC='on')
    time = 0.d0
    nstep = 0
    ntimestep=0

    do while( time <= time_max )

        ntimestep=ntimestep+1
        time = time + timestep

        !=======================================================
        !> Save old Consvervative Variables
        !> Save old Primitive Variables
        do i=nTCellStr,nTCellEnd
            oldCons(i,1) = cRho(i)
            oldCons(i,2) = cRho(i)*cU(i)
            oldCons(i,3) = cRho(i)*cHt(i)-cP(i)

            oldcRho(i) = cRho(i)
            oldcU(i)   = cU(i)
            oldcP(i)   = cP(i)
            oldcT(i)   = cT(i)
            oldcHt(i)  = cHt(i)
        enddo

        !======================== 1 ==========================
        !> Continuity Equation -> Density Prediction
        CALL getContinuity('explicit')

        SIMPLE: do iterSIMPLE = 1,iterMaxSIMPLE

            !======================== 2 ==========================
            !> Momentum Equation -> Velocity Prediction
            CALL getMomentum('impCoeff')

            PISO: do iterPISO = 1,iterMaxPISO

                nstep=nstep+1

                !======================== 3 ==========================
                !> Energy Equation -> Temperature Prediction
                CALL getEnergy('explicit')

                !======================== 4 ==========================
                !> Equation of State -> update Thermodynamic variables
                CALL getEOS(eosRho='on',eosHt='on',eosDRDP='on')

                !======================== 5 ==========================
                !> Pressure Equation (Continuity + Momentum)
                !> => update Pressure
                CALL getPressure('implicit')

                !======================== 7 ==========================
                !> Momentum Equation => update Velocity
                CALL getMomentum('dP_to_U')

                !======================== 6 ==========================
                !> Equation of State => update Density
                CALL getEOS(eosRho='on',eosHt='on',eosDHDT='on')

                !====================================================
                !> Monitor of Residuals
                CALL seeMonitor

            enddo PISO !> End iteration

            !====================================================
            CALL getEnergy('explicit')

            !====================================================
            CALL getContinuity('explicit')

        enddo SIMPLE !> End iteration

        !=======================================================
        !> Boundary Conditions
        CALL getBC(leftBC='supBC',rightBC='supBC')

        !=======================================================
        !> Equation of State => update thermodynamics
        CALL getEOS(eosHt='on',eosDRDP='on')

    enddo

    !/////////////////////////////////
    open(20,file='./plot/result.dat')!,status='old',position='append')
    do i=nCellStr,nCellEnd
        WRITE( 20, '(20(F20.9, 1X))' ) cX(i),cRho(i),cU(i),cP(i),cT(i)
    enddo
    close(20)
    !/////////////////////////////////

    print*,'   =================== program end ================='

end program Euler


      SUBROUTINE KTRMEM (NTYPE)
C
C     TRIANGULAR MEMBRANE ELEMENT
C
C     IF NTYPE = 0 COMPLETE MEMBRANE COMPUTATION IS PERFORMED
C     IF NTYPE = 1 RETURN 3 TRANSFORMED  3X3 MATRICES ONLY FOR THE PIVOT
C
C     CALLS FROM THIS ROUTINE ARE MADE TO -
C
C     MAT    - MATERIAL DATA ROUTINE
C     SMA1B  - INSERTION ROUTINE
C     TRANSD - DOUBLE PRECISION TRANSFORMATION SUPPLIER
C     GMMATD - DOUBLE PRECISION MATRIX MULTIPLY AND TRANSPOSE
C     MESAGE - ERROR MESSAGE WRITER
C
      LOGICAL          HEAT
      INTEGER          NECPT(6)
      REAL             ECPT(21),MATBUF
      DOUBLE PRECISION TEMPAR,C,E,TI,TEMP,G(9),XSUBC,VOL,XSUBB,YSUBC,
     1                 REELMU,FLAMDA,DELTA,KIJ,TT(2)
      COMMON /CONDAS/  CONSTS(5)
      COMMON /SMA1IO/  DUM1(10),IFKGG,DUM2(1),IF4GG,DUM3(23)
      COMMON /SMA1CL/  IOPT4,K4GGSW,NPVT,DUMCL(7),LINK(10),IDETCK,
     1                 DODET,NOGO
      COMMON /SMA1HT/  HEAT
      COMMON /SMA1ET/  MECPT(1),NGRID(3),ANGLE,MATID1,T,FMU,DUMMY1,X1,
     1                 Y1,Z1,DUMMY2,X2,Y2,Z2,DUMMY3,X3,Y3,Z3,DUMB(80)
      COMMON /MATIN /  MATID,INFLAG,ELTEMP,STRESS,SINTH,COSTH
      COMMON /MATOUT/  G11,G12,G13,G22,G23,G33,RHO,ALPHA1,ALPHA2,ALP12,
     1                 T SUB 0,G SUB E,SIGTEN,SIGCOM,SIGSHE,
     2                 G2X211,G2X212,G2X222
      COMMON /SMA1DP/  KIJ(36),C(18),E(9),TEMPAR(27),TI(9),TEMP,
     1                 XSUBB,XSUBC,YSUBC,VOL,REELMU,DELTA,FLAMDA,THETA,
     2                 KA,NPOINT,NSAVE,DUMMY(382)
      COMMON /HMTOUT/  MATBUF(4)
      EQUIVALENCE      (CONSTS(4),DEGRA),(G(1),TEMPAR(19)),
     1                 (ECPT(1),MECPT(1),NECPT(1))
C
C     ECPT LIST
C                                                      THIS
C     ECPT       DESCRIPTION                         ROUTINE    TYPE
C     ======================================         ========  =======
C     ECPT( 1) = ELEMENT ID                          NECPT(1)  INTEGER
C     ECPT( 2) = GRID POINT A                        NGRID(1)  INTEGER
C     ECPT( 3) = GRID POINT B                        NGRID(2)  INTEGER
C     ECPT( 4) = GRID POINT C                        NGRID(3)  INTEGER
C     ECPT( 5) = THETA = ANGLE OF MATERIAL           ANGLE     REAL
C     ECPT( 6) = MATERIAL ID                         MATID     INTEGER
C     ECPT( 7) = T                                   T         REAL
C     ECPT( 8) = NON-STRUCTURAL MASS                 FMU       REAL
C     ECPT( 9) = COORD. SYSTEM ID 1                  NECPT(9)  INTEGER
C     ECPT(10) = X1                                  X1        REAL
C     ECPT(11) = Y1                                  Y1        REAL
C     ECPT(12) = Z1                                  Z1        REAL
C     ECPT(13) = COORD. SYSTEM ID 2                  NECPT(13) INTEGER
C     ECPT(14) = X2                                  X2        REAL
C     ECPT(15) = Y2                                  Y2        REAL
C     ECPT(16) = Z2                                  Z2        REAL
C     ECPT(17) = COORD. SYSTEM ID 3                  NECPT(17) INTEGER
C     ECPT(18) = X3                                  X3        REAL
C     ECPT(19) = Y3                                  Y3        REAL
C     ECPT(20) = Z3                                  Z3        REAL
C     ECPT(21) = ELEMENT TEMPERATURE                 ELTEMP    REAL
C
C
C     SET UP THE E MATRIX WHICH IS (3X2) FOR THE TRI-MEMBRANE
C
C     E(1), E(3), E(5) WILL BE THE I-VECTOR
C     E(2), E(4), E(6) WILL BE THE J-VECTOR
C     E(7), E(8), E(9) WILL BE THE K-VECTOR NOT USED IN E FOR MEMBRANE
C
C     FIRST FIND I-VECTOR = RSUBB - RSUBA  (NON-NORMALIZED)
C
      E(1) = DBLE(X2) - DBLE(X1)
      E(3) = DBLE(Y2) - DBLE(Y1)
      E(5) = DBLE(Z2) - DBLE(Z1)
C
C     NOW FIND LENGTH = X-SUB-B   COORD. IN ELEMENT SYSTEM
C
      XSUBB = DSQRT(E(1)**2 + E(3)**2 + E(5)**2)
      IF (XSUBB .GT. 1.0D-06) GO TO 20
      CALL MESAGE (30,31,ECPT(1))
C
C     SET FLAG FOR FATAL ERROR WHILE ALLOWING ERROR MESSAGES TO
C     ACCUMULATE
C
      NOGO = 1
      RETURN
C
C     NOW NORMALIZE I-VECTOR WITH X-SUB-B
C
   20 E(1) = E(1)/XSUBB
      E(3) = E(3)/XSUBB
      E(5) = E(5)/XSUBB
C
C     HERE WE NOW TAKE RSUBC - RSUBA AND STORE TEMPORARILY IN
C     E(2), E(4), E(6) WHICH IS WHERE THE J-VECTOR WILL FIT LATER
C
      E(2) = DBLE(X3) - DBLE(X1)
      E(4) = DBLE(Y3) - DBLE(Y1)
      E(6) = DBLE(Z3) - DBLE(Z1)
C
C     X-SUB-C  =  I . (RSUBC - RSUBA),  THUS
C
      XSUBC = E(1)*E(2) + E(3)*E(4) + E(5)*E(6)
C
C     AND CROSSING THE I-VECTOR TO (RSUBC-RSUBA) GIVES THE K-VECTOR
C     (NON-NORMALIZED)
C
      E(7) = E(3)*E(6) - E(5)*E(4)
      E(8) = E(5)*E(2) - E(1)*E(6)
      E(9) = E(1)*E(4) - E(3)*E(2)
C
C     THE LENGTH OF THE K-VECTOR IS NOW FOUND AND EQUALS Y-SUB-C
C     COORD. IN ELEMENT SYSTEM
C
      YSUBC = DSQRT(E(7)**2 + E(8)**2 + E(9)**2)
      IF (YSUBC .GT. 1.0D-06) GO TO 25
      CALL MESAGE (30,32,ECPT(1))
C
C     SET FLAG FOR FATAL ERROR WHILE ALLOWING ERROR MESSAGES TO
C     ACCUMULATE
C
      NOGO = 1
      RETURN
C
C     NOW NORMALIZE K-VECTOR WITH YSUBC JUST FOUND
C
   25 E(7) = E(7)/YSUBC
      E(8) = E(8)/YSUBC
      E(9) = E(9)/YSUBC
C
C     J VECTOR = K CROSS I
C     STORE IN THE SPOT FOR J
C
      E(2) = E(5)*E(8) - E(3)*E(9)
      E(4) = E(1)*E(9) - E(5)*E(7)
      E(6) = E(3)*E(7) - E(1)*E(8)
C
C     AND JUST FOR COMPUTER EXACTNESS NORMALIZE J-VECTOR TO MAKE SURE.
C
      TEMP = DSQRT(E(2)**2 + E(4)**2 + E(6)**2)
      IF (TEMP .NE. 0.0D0) GO TO 26
      CALL MESAGE (30,26,ECPT(1))
C
C     SET FLAG FOR FATAL ERROR WHILE ALLOWING ERROR MESSAGES TO
C     ACCUMULATE
C
      NOGO = 1
      RETURN
C
   26 CONTINUE
      E(2) = E(2)/TEMP
      E(4) = E(4)/TEMP
      E(6) = E(6)/TEMP
C
C     VOLUME OF ELEMENT, THETA, MU, LAMDA, AND DELTA
C
      VOL = XSUBB*YSUBC*DBLE(T)/2.0D0
      REELMU = 1.0D0/XSUBB
      FLAMDA = 1.0D0/YSUBC
      DELTA  = XSUBC/XSUBB - 1.0D0
C
C     NOW FORM THE  C MATRIX   (3X6) PARTITIONED AS FOLLOWS HERE.
C         CSUBA = (3X2) STORED IN C( 1) THRU C( 6) BY ROWS
C         CSUBB = (3X2) STORED IN C( 7) THRU C(12) BY ROWS
C         CSUBC = (3X2) STORED IN C(13) THRU C(18) BY ROWS
C
      C(1)  = -REELMU
      C(2)  =  0.0D0
      C(3)  =  0.0D0
      C(4)  =  FLAMDA*DELTA
      C(5)  =  C(4)
      C(6)  = -REELMU
      C(7)  =  REELMU
      C(8)  =  0.0D0
      C(9)  =  0.0D0
      C(10) = -FLAMDA*REELMU*XSUBC
      C(11) =  C(10)
      C(12) =  REELMU
      C(13) =  0.0D0
      C(14) =  0.0D0
      C(15) =  0.0D0
      C(16) =  FLAMDA
      C(17) =  FLAMDA
      C(18) =  0.0D0
C
      IF (NTYPE .EQ. 1) GO TO 30
C
      THETA = ANGLE*DEGRA
      SINTH = SIN(THETA)
      COSTH = COS(THETA)
   30 IF (ABS(SINTH) .LT. 1.0E-06) SINTH = 0.0E0
C
C     BRANCH ON -HEAT- PROBLEM AT THIS POINT.
C
      IF (HEAT) GO TO 1010
      ELTEMP = ECPT(21)
      MATID  = MATID1
      INFLAG = 2
      CALL MAT (ECPT(1))
      IF (NOGO .EQ. 1) RETURN
C
C     FILL G-MATRIX WITH OUTPUT FROM MAT ROUTINE
C
      G(1) = G11
      G(2) = G12
      G(3) = G13
      G(4) = G12
      G(5) = G22
      G(6) = G23
      G(7) = G13
      G(8) = G23
      G(9) = G33
C
C     G, E, AND C MATRICES ARE COMPLETE
C
C     AT THIS POINT THE FOLLOWING EQUATION CAN BE SOLVED FOR K-SUB-IJ
C
C                    T         T     T
C       K   = VOL . T *E*C *G*C *E *T
C        IJ          I         I  J  J
C
C     T-SUB-I WILL BE USED IN THE ABOVE ONLY IF THE PIVOT COORDINATE
C     SYSTEM ID IS NOT ZERO, OTHERWISE IT IS ASSUMED TO BE THE
C     IDENTITY MATRIX.
C
C     THE I SUBSCRIPT IMPLIES THE PIVOT POINT  1,2, OR 3 (ELEMENT SYST)
C     THE J SUBSCRIPT IMPLIES  1 THRU 3  FOR EACH CALL TO THIS ROUTINE.
C
C
C     FIRST LOCATE WHICH POINT IS THE PIVOT
C
C
      DO 100 I = 1,3
      IF (NGRID(I) .NE. NPVT) GO TO 100
      KA = 4*I + 5
      NPOINT = 6*I - 5
      GO TO 150
  100 CONTINUE
C
C     FALLING THRU ABOVE LOOP INDICATES THE PIVOT POINT SPECIFIED BY
C     NPVT WAS NOT FOUND EQUAL TO ANY OF THE 3 GRID POINTS IN THE ECPT
C     THUS ERROR CONDITION.
C
      CALL MESAGE (-30,34,ECPT(1))
C
C                     T
C     COMPUTE   E*C *G       AND STORE IN TEMPAR (1 THRU 9)
C                  I
C
  150 CALL GMMATD (E,3,2,0, C(NPOINT),3,2,1, TEMPAR(10))
      CALL GMMATD (TEMPAR(10),3,3,0, G,3,3,0, TEMPAR(1))
C
C     NCOM WILL ALWAYS POINT TO THE COMMON 3 X 3 PRODUCT ABOVE
C     NPT1 WILL POINT TO FREE WORKING SPACE LENGTH 9
C
      NCOM = 1
      NPT1 = 10
C
C     MULTIPLY COMMON PRODUCT BY SCALER VOL
C
      DO 90 I = 1,9
   90 TEMPAR(I) = TEMPAR(I)*VOL
C
C     CHECK FOR PIVOT  CSID = 0,  IF ZERO SKIP TRANSFORMATION TSUBI.
C
      IF (NECPT(KA) .EQ. 0) GO TO 80
C
C     NOT-ZERO THUS GET TI
C
      CALL TRANSD (NECPT(KA),TI)
C
C     INTRODUCE TI INTO THE COMMON PRODUCT AND STORE AT
C     TEMPAR (10 THRU 18)
C
      CALL GMMATD (TI,3,3,1, TEMPAR(1),3,3,0, TEMPAR(10))
C
C     COMMON PRODUCT NOW STARTS AT TEMPAR(10) THUS CHANGE NCOM AND NPT1
C
      NCOM = 10
      NPT1 =  1
C
C     NOW HAVE COMMON PRODUCT STORED BEGINNING TEMPAR(NCOM),  (3X3).
C     NPT1 POINTS TO FREE WORKING SPACE LENGTH 9.
C
C     PROCEED NOW AND RUN OUT THE 3 6X6 MATRICES KIJ-SUB-1,2,3.
C
C     FIRST ZERO OUT (6 X 6) K
C                             IJ
C
   80 NSAVE = NPT1
      DO 700 I = 1,36
  700 KIJ(I) = 0.0D0
      NPOINT = 0
C
      DO 500 I = 1,3
      CALL GMMATD (C(6*I-5),3,2,0, E,3,2,1, TEMPAR(NSAVE))
C
C                                                                  T
C     NPT2 IS SET TO POINT TO THE BEGINNING OF THE PRODUCT  C *E *T
C                                                            J     J
      NPT2 = NSAVE
      NPT1 = 19
C
C     CHECK FOR ZERO CSID IN WHICH CASE TJ IS NOT NEEDED
C
      IF (NECPT(4*I+5) .EQ. 0) GO TO 60
C
C     COMMING HERE IMPLIES NEED FOR TJ
C     WILL STORE TJ IN TI
C
      CALL TRANSD (NECPT(4*I+5),TI)
      CALL GMMATD (TEMPAR(NPT2),3,3,0, TI,3,3,0, TEMPAR(19))
      NPT1 = NPT2
      NPT2 = 19
C
C     AT THIS POINT COMPLETE COMPUTATION FOR  K-SUB-I,J
C
   60 CALL GMMATD (TEMPAR(NCOM),3,3,0, TEMPAR(NPT2),3,3,0, TEMPAR(NPT1))
C
      IF (NTYPE .EQ. 0) GO TO 95
      DO 96 J = 1,9
      NPOINT = NPOINT + 1
      NPT2 = NPT1 + J - 1
   96 KIJ(NPOINT) = TEMPAR(NPT2)
      GO TO 500
C
   95 KIJ( 1) = TEMPAR(NPT1    )
      KIJ( 2) = TEMPAR(NPT1 + 1)
      KIJ( 3) = TEMPAR(NPT1 + 2)
      KIJ( 7) = TEMPAR(NPT1 + 3)
      KIJ( 8) = TEMPAR(NPT1 + 4)
      KIJ( 9) = TEMPAR(NPT1 + 5)
      KIJ(13) = TEMPAR(NPT1 + 6)
      KIJ(14) = TEMPAR(NPT1 + 7)
      KIJ(15) = TEMPAR(NPT1 + 8)
C
      CALL SMA1B (KIJ(1),NECPT(I+1),-1,IFKGG,0.0D0)
      TEMP = G SUB E
      IF (IOPT4) 501,500,501
  501 IF (GSUBE) 502,500,502
  502 CALL SMA1B (KIJ(1),NECPT(I+1),-1,IF4GG,TEMP)
      K4GGSW = 1
C
  500 CONTINUE
      RETURN
C
C     HEAT PROBLEM LOGIC PICKS UP HERE.  CALL HMAT FOR MATERIAL DATA.
C
 1010 INFLAG = 2
      MATID  = NECPT(6)
      ELTEMP = ECPT(21)
      CALL HMAT (NECPT)
      G(1) = MATBUF(1)
      G(2) = MATBUF(2)
      G(3) = MATBUF(2)
      G(4) = MATBUF(3)
C
C     CONDENSE C MATRIX FOR HEAT PROBLEM (FORMED ABOVE)  C IS (2X3)
C
      C(2) = C(4)
      C(3) = C(7)
      C(4) = C(10)
      C(5) = C(13)
      C(6) = C(16)
C
C     DETERMINE THE PIVOT POINT.
C
      DO 1030 I = 1,3
      IF (NGRID(I) .EQ. NPVT) GO TO 1060
 1030 CONTINUE
      CALL MESAGE (-30,34,ECPT(1))
C
C     PIVOT C MATRIX TIMES VOLUME (STORED INTO TT(1) AND TT(2).)
C
 1060 TT(1) = VOL*C(2*I-1)
      TT(2) = VOL*C(2*I  )
C
C     OUTPUT THE CONDUCTIVITY MATRICES
C
      K = 36
      IF (NTYPE .NE. 0) K = 27
      DO 1070 I = 1,K
 1070 KIJ(I) = 0.0D0
      NPOINT = 0
C
      DO 1100 I = 1,3
      N2 = 2*I
      N1 = N2 - 1
      TEMPAR(1) = (G(1)*C(N1) + G(2)*C(N2))*TT(1)  +
     1            (G(3)*C(N1) + G(4)*C(N2))*TT(2)
      IF (NTYPE) 1080,1090,1080
C
C     SUB-TRIANGLE (RETURN 3X3-S AS ABOVE IN STIFFNESS PORTION)
C
 1080 KIJ(NPOINT+1) = TEMPAR(1)
      NPOINT = NPOINT + 9
      GO TO 1100
C
C     TRIANGLE BY ITSELF
C
 1090 CALL SMA1B (TEMPAR(1),NECPT(I+1),NPVT,IFKGG,0.0D0)
 1100 CONTINUE
      RETURN
      END


*DECK DPCOEF
      SUBROUTINE DPCOEF (L, C, TC, A)
C***BEGIN PROLOGUE  DPCOEF
C***PURPOSE  Convert the DPOLFT coefficients to Taylor series form.
C***LIBRARY   SLATEC
C***CATEGORY  K1A1A2
C***TYPE      DOUBLE PRECISION (PCOEF-S, DPCOEF-D)
C***KEYWORDS  CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT
C***AUTHOR  Shampine, L. F., (SNLA)
C           Davenport, S. M., (SNLA)
C***DESCRIPTION
C
C     Abstract
C
C     DPOLFT  computes the least squares polynomial fit of degree  L  as
C     a sum of orthogonal polynomials.  DPCOEF  changes this fit to its
C     Taylor expansion about any point  C , i.e. writes the polynomial
C     as a sum of powers of (X-C).  Taking  C=0.  gives the polynomial
C     in powers of X, but a suitable non-zero  C  often leads to
C     polynomials which are better scaled and more accurately evaluated.
C
C     The parameters for  DPCOEF  are
C
C     INPUT -- All TYPE REAL variables are DOUBLE PRECISION
C         L -      Indicates the degree of polynomial to be changed to
C                  its Taylor expansion.  To obtain the Taylor
C                  coefficients in reverse order, input  L  as the
C                  negative of the degree desired.  The absolute value
C                  of L  must be less than or equal to NDEG, the highest
C                  degree polynomial fitted by  DPOLFT .
C         C -      The point about which the Taylor expansion is to be
C                  made.
C         A -      Work and output array containing values from last
C                  call to  DPOLFT .
C
C     OUTPUT -- All TYPE REAL variables are DOUBLE PRECISION
C         TC -     Vector containing the first LL+1 Taylor coefficients
C                  where LL=ABS(L).  If  L.GT.0 , the coefficients are
C                  in the usual Taylor series order, i.e.
C                    P(X) = TC(1) + TC(2)*(X-C) + ... + TC(N+1)*(X-C)**N
C                  If L .LT. 0, the coefficients are in reverse order,
C                  i.e.
C                    P(X) = TC(1)*(X-C)**N + ... + TC(N)*(X-C) + TC(N+1)
C
C***REFERENCES  L. F. Shampine, S. M. Davenport and R. E. Huddleston,
C                 Curve fitting by polynomials in one variable, Report
C                 SLA-74-0270, Sandia Laboratories, June 1974.
C***ROUTINES CALLED  DP1VLU
C***REVISION HISTORY  (YYMMDD)
C   740601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891006  Cosmetic changes to prologue.  (WRB)
C   891006  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPCOEF
C
      INTEGER I,L,LL,LLP1,LLP2,NEW,NR
      DOUBLE PRECISION A(*),C,FAC,SAVE,TC(*)
C***FIRST EXECUTABLE STATEMENT  DPCOEF
      LL = ABS(L)
      LLP1 = LL + 1
      CALL DP1VLU (LL,LL,C,TC(1),TC(2),A)
      IF (LL .LT. 2) GO TO 2
      FAC = 1.0D0
      DO 1 I = 3,LLP1
        FAC = FAC*(I-1)
 1      TC(I) = TC(I)/FAC
 2    IF (L .GE. 0) GO TO 4
      NR = LLP1/2
      LLP2 = LL + 2
      DO 3 I = 1,NR
        SAVE = TC(I)
        NEW = LLP2 - I
        TC(I) = TC(NEW)
 3      TC(NEW) = SAVE
 4    RETURN
      END


      SUBROUTINE PBCS(RXX,RYY,RZZ,RIX,RIY,RIZ)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!  periodic boundary condition for non-orthoganal boxes
!!  work in fractional space
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      USE header_file
      IMPLICIT NONE

      REAL(kind = double) :: RXX,RYY,RZZ,RIX,RIY,RIZ,RAI,RBI,RCI

      CALL CARTFRAC(RXX,RYY,RZZ,RAI,RBI,RCI)

      IF(RAI > 1.0d0) RAI = RAI - 1.0d0
      IF(RAI <  0.0d0) RAI = RAI + 1.0d0
      IF(RBI > 1.0d0) RBI = RBI - 1.0d0
      IF(RBI <  0.0d0) RBI = RBI + 1.0d0
      IF(RCI > 1.0d0) RCI = RCI - 1.0d0
      IF(RCI <  0.0d0) RCI = RCI + 1.0d0

      CALL FRACCART(RAI,RBI,RCI,RIX,RIY,RIZ)

      END SUBROUTINE


c
c***********************
c
      subroutine autocor(x,npts,nlag,nch,ich,r,rr)
c
c       computes autocorrlation matrix for a segment
c      of time series x; auto-correlations up to lags
c       of nlag are returned in r;
c       a guarranteed to be pos. semi-def. (but non-Toeplitz)
c       covariance matrix out to lag nlag-1 is returned in rr

      real x(nch,npts),r(*),rr(*)
c         damp controls damping of covariance matrix to increase
c        stability of pre-whitening and avoid the introduction of
c        spurious peaks in the whitened spectra

      parameter (damp = .01)

      do 20 j=1,nlag+1
      r(j)=0.
         do 10 k=1,npts
         r(j)=r(j)+x(ich,k)*x(ich,k+j-1)
10       continue
20    continue

c      make Toeplitz matrix from autocovariance
      ii = 0
      do 30 i=1,nlag
      do 30 j = 1,i
      ii = ii + 1
      rr(ii) = r(i-j+1)
30    continue

c      modify Toeplitz matrix to make pos. def matrix
      do 40 j=2,nlag
c       modify jth column
         do 40 i=j,nlag
         ij = (i*(i-1))/2+j
            do 35 k = 1,j-1
            rr(ij) = rr(ij) - x(ich,k)*x(ich,k+i-j)
     &                            + x(ich,npts+k)*x(ich,npts+k+i-j)
35          continue
40    continue

      do 45 j = 1,(nlag*(nlag+1))/2
45    rr(j) = rr(j)/npts

      do 50 j =1,nlag+1
50    r(j) = r(j)/npts

c       damp autocov coefficient matrix

      do 60 i = 1,nlag
      ii = (i*(i+1))/2
      rr(ii) = rr(ii) + r(1)*damp
60    continue
      return
      end


      SUBROUTINE ALG18 (BETA1,BETA2,I1,I2,FACT,X0,Y0,S0,XR,Y1,X1,Y2,RDI
     1US,S,C1)
C
      DIMENSION S(80)
C
      DELX=XR/FLOAT(I2-I1)
      XX=X0
      I3=I1+1
      IF (BETA1.EQ.BETA2) GO TO 20
      Y1=-COS(BETA1/C1)/(SIN(BETA1/C1)-SIN(BETA2/C1))
      X1=SIN(BETA1/C1)/(SIN(BETA1/C1)-SIN(BETA2/C1))
      Y2=TAN((BETA1+BETA2)/(2.0*C1))
      RDIUS=ABS(1.0/(SIN(BETA1/C1)-SIN(BETA2/C1)))
      Y2=Y2*FACT+Y0
      Y1=Y1*FACT+Y0
      X1=X1*FACT+X0
      RDIUS=RDIUS*FACT
      DO 10 J=I3,I2
      XX=XX+DELX
      PHI1=ATAN(-1./SQRT(RDIUS**2-(XX-X1)**2)*(XX-X1))
      IF ((BETA1-BETA2).LT.0.0) PHI1=-PHI1
      PHI2=ABS(BETA1/C1-PHI1)
10    S(J)=RDIUS*PHI2+S0
      RETURN
20    AM=TAN(BETA1/C1)
      DO 30 J=I3,I2
      XX=XX+DELX
30    S(J)=(XX-X0)*SQRT(AM*AM+1.0)+S0
      Y2=AM*(XX-X0)+Y0
      RETURN
      END


      function sedia(spg,eqfall)
c*******************************************************************
c                                                                  *
c  This function calculates the equivalent sand diameter of a      *
c  particle class. It called by SR PRTCMP.                         *
c                                                                  *
c*******************************************************************
c                                                                  *
c  Argumants                                                       *
c     spg                                                          *
c     eqfall                                                       *
c                                                                  *
c*******************************************************************
c
c*******************************************************************
c                                                                  *
c  Common Blocks                                                   *
c                                                                  *
c*******************************************************************
c
      include 'cconsta.inc'
c
      include 'cfall.inc'

      real eqfall, rey, rtsid, sedia, spg
      integer i
c
c*******************************************************************
c                                                                  *
c  Local Variables                                                 *
c    rtsid :                                                       *
c    i     :                                                       *
c    rey   :                                                       *
c    sedia :                                                       *
c                                                                  *
c*******************************************************************
c
      rtsid = 1.3333 * accgav * (spg-1.0) * kinvis / (eqfall**3)
      if (rtsid.le.2.0e+06) then
        rtsid = alog(rtsid)
        do 10 i = 1, 9
          if (cddre(i).lt.rtsid) then
            rey = exp((rtsid-cddre(i-1))/(cddre(i)-cddre(i-1))*(
     1          cdre(i)-cdre(i-1))+cdre(i-1))
            sedia = rey * kinvis / eqfall
            return
          end if
   10   continue
c
        sedia = exp(cdre(9)) * kinvis / eqfall
        return
c
c     ** Sediment diameter using Stokes equation for small spheres. **
c
      else
        sedia = sqrt(18.0*eqfall*kinvis/((spg-1.0)*accgav))
      end if
c
      return
      end


    subroutine lyso(omc0,tem,sal,dens,dplyc,dplysa)
!   ------------------------------------------------
    implicit none
    double precision omc0,tem,sal,dens,dplyc,dplysa
    double precision grav,tcel,rt,cc,dvc,dkc,aa,bb,reali,pratmc
    double precision pratma

    grav=9.806
    tcel=tem-273.15
    rt=82.056*tem
    cc=-dlog(omc0)
    dvc=-(48.76-0.5304*tcel)
    dkc=-1.e-3*(11.76-0.3692*tcel)
    aa=0.5*dkc/rt
    bb=-dvc/rt
    reali=bb*bb-4.*aa*cc
    pratmc=(-bb+dsqrt(reali))/(2.*aa)
    dplyc=1.e-3*pratmc*1.013e5/(dens*grav)
    cc=-dlog(omc0/1.5)
    dvc=-(48.76-0.5304*tcel-2.8)
    bb=-dvc/rt
    reali=bb*bb-4.*aa*cc
    pratma=(-bb+dsqrt(reali))/(2.*aa)
    dplysa=1.e-3*pratma*1.013e5/(dens*grav)

    return
    end


!================================================================================================
! This is the "toy" chemistry module.
!================================================================================================

MODULE Terminator

implicit none
private
save

public :: initial_value_Terminator       ! initialize cl and cl2
public :: tendency_Terminator             ! interface to tendency computation

!integer, parameter :: 8 = selected_real_kind (12)

real(8), parameter :: cly_constant = 4.e-6_8
real(8), parameter :: pi = 3.1415926535897932384626433832795028841971693993751058209749445923078164_8
real(8), parameter :: half_pi = pi*0.5_8
real(8), parameter :: degrees_to_radians = pi/180.0_8
real(8), parameter :: k1_lat_center =   20.d0*degrees_to_radians
real(8), parameter :: k1_lon_center =  300.d0*degrees_to_radians

contains

!===============================================================================
!  Solar photolysis rate and recombination rate
!===============================================================================

subroutine k_vals( lat, lon, k1, k2 )

!-----------------------------------------------------------------------
! Arguments:
!-----------------------------------------------------------------------
real(8), intent(in)    :: lat, lon  ! latitude and longitude, radians
real(8), intent(out)   :: k1, k2    ! reaction rates

k1 = 1.0_8*max(0.d0,sin(lat)*sin(k1_lat_center) + cos(lat)*cos(k1_lat_center)*cos(lon-k1_lon_center))
k2 = 1._8

return

end subroutine k_vals

!===============================================================================
!  Tendencies of cl and cl2
!===============================================================================

subroutine tendency_Terminator( lat, lon, cl, cl2, dt, cl_f, cl2_f )

!-----------------------------------------------------------------------
! Arguments:
!-----------------------------------------------------------------------

real(8), intent(in)    :: lat, lon  ! latitude and longitude, degrees
real(8), intent(in)    :: cl, cl2   ! molar mixing ratio of cl and cl2
real(8), intent(in)    :: dt        ! size of physics time step

real(8), intent(out)   :: cl_f, cl2_f  ! time rate of change of cl and cl2

!-----------------------------------------------------------------------
! Local variables
!-----------------------------------------------------------------------

real(8) :: r, det, expdt, el ! useful algebaic quantities used in the computation
real(8) :: k1, k2            ! reaction rates
real(8) :: cly               ! quantity that should be conseved

call k_vals( lat*degrees_to_radians, lon*degrees_to_radians, k1, k2 )

r = k1 / (4._8*k2)
cly = cl + 2._8* cl2

det = sqrt( r*r + 2._8*r*cly )
expdt = exp( -4._8*k2*det*dt )

if ( abs(det * k2 * dt) .gt. 1e-16 ) then
el = (1._8 - expdt) /det /dt
else
el = 4._8*k2
endif

cl_f  = -el * (cl - det + r)*(cl + det + r) / (1._8 + expdt + dt*el*(cl + r))
cl2_f = -cl_f / 2._8

return

end subroutine tendency_Terminator

!===============================================================================
!  Compute initial values
!===============================================================================

subroutine initial_value_Terminator( lat, lon, cl, cl2 )

!-----------------------------------------------------------------------
! Arguments:
!-----------------------------------------------------------------------

real(8), intent(in)  :: lat, lon  ! latitude and longitude, degrees
real(8), intent(out) :: cl, cl2   ! molar mixing ratio of cl and cl2

!-----------------------------------------------------------------------
! Local variables
!-----------------------------------------------------------------------

real(8) :: r, det  ! useful algebraic forms
real(8) :: k1, k2  ! reaction rates

call k_vals( lat*degrees_to_radians, lon*degrees_to_radians, k1, k2 )

r = k1 / (4._8*k2)
det = sqrt(r*r + 2._8*cly_constant*r)

cl  = (det-r)
cl2 = cly_constant/2._8 - (det-r)/2._8

return

end subroutine initial_value_Terminator

end module Terminator


c     program DRSCHOL2
c>> 1996-06-17 DRSCHOL2  Krogh  Minor format change for C conversion.
c>> 1996-05-28 DRSCHOL2  Krogh Added external statement.
c>> 1994-10-19 DRSCHOL2  Krogh  Changes to use M77CON
c>> 1993-02-18 DRSCHOL2  CLL.
c>> 1992-03-04 DRSCHOL2  Krogh Initial version.
c  Demonstration driver for SCHOL
c     ------------------------------------------------------------------
c--S replaces "?": DR?CHOL2, ?CHOL, ?DOT
c     ------------------------------------------------------------------
      integer LDPDU, M, N, NP1
      parameter (M = 3, N = 2, NP1 = N+1, LDPDU = 3)
      integer I, IERR, J
      real             AB(M,NP1)
      external SDOT
      real             PDU(LDPDU,LDPDU), SDOT
      data AB(1,1), AB(1,2), AB(1,3) /  0.7E0,  0.6E0,  1.726E0 /
      data AB(2,1), AB(2,2), AB(2,3) / -0.8E0,  0.5E0, -5.415E0 /
      data AB(3,1), AB(3,2), AB(3,3) /  0.6E0, -0.7E0,  5.183E0 /
c     ------------------------------------------------------------------
      do 20 I = 1, NP1
         do 10 J = 1, NP1
            PDU(I,J) = SDOT(M, AB(1,I), 1, AB(1, J), 1)
   10    continue
   20 continue
      call SCHOL(PDU, LDPDU, N, PDU(1,NP1), PDU(NP1,NP1), 0.0e0, IERR)
      print '('' X()   = '',2f15.6)', PDU(1,NP1), PDU(2,NP1)
      print '('' RNORM = '',f15.6)', PDU(NP1,NP1)
      if (IERR .ne. 0) print '(
     *  '' Matrix failed conditioning test in SCHOL, IERR = '',I3)',IERR
      end


      SUBROUTINE SFFT(AR, AI, S)
c>> 1997-03-28 SFFT  Krogh  KEDIM increased, removed assigned go to's.
C>> 1994-11-11 SFFT  Krogh  Declared all vars.
c>> 1994-10-20 SFFT  Krogh  Changes to use M77CON
c>> 1989-08-15 SFFT  FTK -- Parameter constants given to more precision.
c>> 1989-04-21 SFFT  FTK & CLL
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c
c     This subroutine computes one dimensional complex Fourier
c     transforms using the Cooley-Tukey algorithm. It is used by a
c     number of subroutines which compute Fourier transforms.
c
c     Programmed by Fred T. Krogh at the Jet Propulsion Laboratory,
c     Pasadena, Calif.   August 1, 1969.
c     Revised by Krogh at JPL -- January 19, 1988 -- For portability
c
      REAL             AR(*), AI(*), S(*)
c     Minimum dimensions are AR(ILAST), AI(ILAST), S(NT-1), where ILAST
c     and NT are defined in the common block below.
c
c AR and AI give the arrays used to hold the real and imaginary parts of
c     the Fourier coefficients and data.
c S   contains the sine table required in the calculations.
c
c     -----------------------------------------------------------------
c                Notes on COMMON, PARAMETER's, and local variables
c
c     SPI4 = SIN(PI/4) = .5 * SQRT(2)
c     PI4 = PI / 4
c     THE DIMENSION OF KE MUST BE AS LARGE AS THE MAXIMUM VALUE
c     PERMITTED FOR MM.
c
c     WHERE
c     NEEDST= .TRUE. if the sine table must be computed.
c     MT    = base 2 log(NT)
c     NT    = number of entries in the sine table
c     MM    = base 2 log(number of complex fourier coefficients)
c     KS    = distance in memory between successive points.  The i-th
c             coefficient, a(i) is given by AR((I+1)*KS)+AI((I+1)*KS)*
c             sqrt(-1), i=0, 1, ..., (2**MM)-1.
c     ILAST = KS * 2**MM
c     KE(L) = KS * 2**(MM-L), L=1, 2, ..., MM
c     -----------------------------------------------------------------
c--S replaces "?": ?FFT, C?FFTC
c     -----------------------------------------------------------------
      INTEGER I, I1, I2, I3, IJ
      INTEGER J, JDIF, JI, JI2, JJ, JR
      INTEGER K, KSI
      INTEGER L, L1, L4, LJ, LL
      INTEGER MTC

      REAL             HALF, PI4, SPI4
      REAL             T, T1, T1I, T2, T2I, T3, T3I, THETA
      REAL             TI, TP, TP1, TP1I, TPI
      REAL             WI1, WI2, WI3, WR1, WR2, WR3
      LOGICAL SPCASE

      PARAMETER (SPI4 = .70710 67811 86547 52440 08443 62104 8490E0)
      PARAMETER (PI4 = .78539 81633 97448 30961 56608 45819 8757E0)
      PARAMETER (HALF = .5E0)

c Common variables
      INTEGER KEDIM
      PARAMETER (KEDIM=30)
      LOGICAL NEEDST
      INTEGER MT, NT, MM, KS, ILAST, KE(KEDIM), KEE(KEDIM+1)
c Note that KEE(1) is equivalent to ILAST.
      EQUIVALENCE (KE(1), KEE(2))
      COMMON /CSFFTC/ NEEDST, MT, NT, MM, KS, ILAST, KE
      SAVE /CSFFTC/
c     -----------------------------------------------------------------
c
      if (NEEDST) then
c                      Compute the sine table
         NEEDST = .FALSE.
         MTC = MT
         NT = 2**MTC
         IF (MTC .GT. 0) THEN
c                            SET FOR L=1
            J = NT
            JJ = J / 2
            S(JJ) = SPI4
            IF (MTC .GT. 1) THEN
               THETA = PI4
               DO 20 L = 2, MTC
                  THETA = HALF * THETA
                  K = J
                  J = JJ
                  JJ = JJ / 2
c                       At this point J = 2**(MT-L+1) and JJ = 2**(MT-L)
                  S(JJ) = SIN(THETA)
                  L1 = NT - JJ
                  S(L1) = COS(THETA)
                  LL = NT - K
                  IF (LL .GE. J) THEN
                     DO 10 I = J, LL, J
                        I1 = NT - I
                        I2 = I + JJ
                        S(I2) = S(I) * S(L1) + S(JJ) * S(I1)
   10                CONTINUE
                  END IF
   20          CONTINUE
            END IF
         END IF
      ELSE
c                      Compute the transform
c                           Scramble A
c
         IJ = 1
         JI = 1
         L1 = KS
         IF (MM .GT. 1) THEN
   30       IJ = IJ + L1
            DO 40 I = 1, MM
               JI = JI + KE(I)
               KE(I) = -KE(I)
               IF (KE(I) .LT. 0) THEN
                  IF (IJ .LT. JI) THEN
c                       INTERCHANGE THE IJ-TH COEFFICIENT WITH THE JI-TH
                     T = AR(IJ)
                     AR(IJ) = AR(JI)
                     AR(JI) = T
                     T = AI(IJ)
                     AI(IJ) = AI(JI)
                     AI(JI) = T
                  END IF
                  GO TO 30
               END IF
   40       CONTINUE
         END IF
c                          END OF SCRAMBLING A
         JDIF = NT
         IF (MOD(MM, 2) .NE. 0) THEN
c                    SPECIAL CASE -- L = 1,  MM ODD  (RADIX 2 ALGORITHM)
            L1 = L1 + L1
            DO 50 I = 1, ILAST, L1
               KSI = I + KS
               T = AR(I)
               AR(I) = T + AR(KSI)
               AR(KSI) = T - AR(KSI)
               T = AI(I)
               AI(I) = T + AI(KSI)
               AI(KSI) = T - AI(KSI)
   50       CONTINUE
            JDIF = JDIF / 2
         END IF
c
         DO 140 L = 2, MM, 2
            L4 = 4 * L1
            LJ = L1 / 2
            SPCASE = .TRUE.
            J = 0
            JI = 0
c
c           START OF I LOOP  (RADIX 4 ALGORITHM)
   60       IJ = J + 1
            DO 120 I = IJ, ILAST, L4
               I1 = I + L1
               I2 = I1 + L1
               I3 = I2 + L1
               if (SPCASE) then
                  if (J .eq. 0) then
c                                   SPECIAL CASE -- J = 0
                     T = AR(I) + AR(I1)
                     T1 = AR(I) - AR(I1)
                     TI = AI(I) + AI(I1)
                     T1I = AI(I) - AI(I1)
                     T2 = AR(I2) + AR(I3)
                     T3 = AR(I2) - AR(I3)
                     T2I = AI(I2) + AI(I3)
                     T3I = AI(I2) - AI(I3)
                     GO TO 110
                  end if
c                                   SPECIAL CASE -- J = L1 / 2
                  T2 = SPI4 * AR(I2)
                  T2I = SPI4 * AI(I2)
                  T3 = SPI4 * AR(I3)
                  T3I = SPI4 * AI(I3)
                  TP = T2 - T2I
                  TPI = T2 + T2I
                  TP1 = -T3 - T3I
                  TP1I = T3 - T3I
                  T = AR(I) - AI(I1)
                  T1 = AR(I) + AI(I1)
                  TI = AI(I) + AR(I1)
                  T1I = AI(I) - AR(I1)
               else
c
c              USUAL CASE -- J .NE. 0  AND  J .NE. L1 / 2
c
c              WRK AND WIK (K = 1, 2, 3) ARE THE REAL AND IMAGINARY PART
c              RESP. OF EXP(SQRT(-1) * PI * K*(2**(-L-MOD(MM, 2)))*J/KS)
c                             =EXP(SQRT(-1) * PI * K * (J / (4 * L1)))
c
                  T2 = WR2 * AR(I1) - WI2 * AI(I1)
                  T2I = WI2 * AR(I1) + WR2 * AI(I1)
                  T = AR(I) + T2
                  T1 = AR(I) - T2
                  TI = AI(I) + T2I
                  T1I = AI(I) - T2I
                  TP = WR1 * AR(I2) - WI1 * AI(I2)
                  TPI = WI1 * AR(I2) + WR1 * AI(I2)
                  TP1 = WR3 * AR(I3) - WI3 * AI(I3)
                  TP1I = WI3 * AR(I3) + WR3 * AI(I3)
               end if
               T2 = TP + TP1
               T3 = TP - TP1
               T2I = TPI + TP1I
               T3I = TPI - TP1I
  110          AR(I) = T + T2
               AI(I) = TI + T2I
               AR(I1) = T1 - T3I
               AI(I1) = T1I + T3
               AR(I2) = T - T2
               AI(I2) = TI - T2I
               AR(I3) = T1 + T3I
               AI(I3) = T1I - T3
  120       CONTINUE
c           END OF I LOOP
c
            IF (J .LE. LJ) THEN
               IF (SPCASE) THEN
                  IF (J .NE. 0) go to 130
                  J = KS
                  SPCASE = .FALSE.
               ELSE
                  J = L1 - J
c                 COMPUTE WR-S AND WI-S FOR J REPLACED BY L1 - J
                  T = WI1
                  WI1 = WR1
                  WR1 = T
                  WR2 = -WR2
                  T = -WI3
                  WI3 = -WR3
                  WR3 = T
                  GO TO 60
               END IF
            ELSE
               J = L1 - J + KS
            END IF
            IF (J .LT. LJ) THEN
c                              COMPUTE WR-S AND WI-S
               JI = JI + JDIF
               JR = NT - JI
               WR1 = S(JR)
               WI1 = S(JI)
               JI2 = JI + JI
               WI2 = S(JI2)
               JR = NT - JI2
               WR2 = S(JR)
               JI2 = JI + JI2
               IF (JI2 .LE. NT) THEN
                  JR = NT - JI2
                  WR3 = S(JR)
                  WI3 = S(JI2)
                  GO TO 60
               END IF
               JR = JI2 - NT
               JI2 = NT - JR
               WI3 = S(JI2)
               WR3 = -S(JR)
               GO TO 60
            ELSE IF (J .EQ. LJ) THEN
               SPCASE = .TRUE.
               GO TO 60
            END IF
c           END OF COMPUTING WR-S AND WI-S
c
  130       L1 = L4
            JDIF = JDIF / 4
  140    CONTINUE
c        END OF L LOOP
      END IF
      RETURN
      END


PROGRAM lat_id_driver
  use find_kgrids, only: find_grid
  use kpointgeneration, only: generateIrredKpointList, mapKptsIntoBZ
  use control_file, only: get_inputs
  use vector_matrix_utilities, only: matrix_inverse, determinant, minkowski_reduce_basis
  use numerical_utilities, only: equal
  use num_types

  implicit none

  real(dp) :: lat_vecs(3,3), grid(3,3), offset(3), r_vecs(3,3), reduced_R(3,3)
  real(dp) :: Rinv(3,3), point(3), reps, aeps, best_offset(3)
  logical :: find_offset, min_kpts
  integer :: nkpts, i, symm_flag
  integer, allocatable :: at(:)
  real(dp), pointer :: IRKps(:,:)
  real(dp), allocatable :: B_vecs(:,:)
  integer, pointer :: weights(:)

  call get_inputs(nkpts, lat_vecs, at, B_vecs, offset, find_offset, symm_flag, &
       min_kpts, reps, aeps)
  call matrix_inverse(transpose(lat_vecs),r_vecs)
  call minkowski_reduce_basis(r_vecs, reduced_R, reps)

  call find_grid(lat_vecs, nkpts, B_vecs, at, offset, find_offset, grid, best_offset, &
       symm_flag_=symm_flag, min_kpts_=min_kpts, eps_=reps)
  call generateIrredKpointList(lat_vecs, B_vecs, at, grid, reduced_R, best_offset, &
       IRKps, weights, reps_=reps, aeps_=aeps, symm_=symm_flag)

  call mapKptsIntoBZ(r_vecs, IRKps, reps)

  open(4,file="KPOINTS")
  write(4,'("autoGR kpoint generation:",I6," (irred),  ",I8," (total),  ",f5.2," (folding), ",f6.4," (ratio)")') size(IRKps,1), sum(weights), 1._dp/size(IRKps,1)*sum(weights), 1._dp*size(IRKps,1)/sum(weights)
  write(4,*) size(IRKps,1)
  write(4,*) "Fractional"

  !! Write the folding ratio to the output file.
  write(5,'("# reducible K-points:  ",I6)') sum(weights)
  write(5,'("# irreducible K-points:",I6)') size(IRKps,1)
  write(5,'("folding ratio:  ",F5.2)') real(sum(weights),dp) / size(IRKps,1)
  close(5)

  call matrix_inverse(r_vecs,Rinv)
  do i = 1,size(IRKps,1)
     point = matmul(Rinv,IRKps(i,:))
     write(4,'(3(F15.12,1X),I5)') point(1), point(2), point(3), weights(i)
  end do
  close(4)

  open(4,file="autoGR.gen")
  write(4,'("autoGR kpoint generation:",I6," (irred),  ",I8," (total),  ",f5.2," (folding), ",f6.4," (ratio)")') size(IRKps,1), sum(weights), 1._dp/size(IRKps,1)*sum(weights), 1._dp*size(IRKps,1)/sum(weights)
  write(4,'(A)') "0"
  write(4,'(A)') "Cartesian"
  write(4,'(F15.12,X,F15.12,X,F15.12)') grid
  write(4,'(F15.12,X,F15.12,X,F15.12)') best_offset
  close(4)

end PROGRAM lat_id_driver


c     # ---------------------------------------------------
c     # Trace back solution to initial position
c     # Input arguments should be the coordinates
c     # for the canonical swirl mapping in terms of
c     # (x,y)
c     #
c     #   T = (R*cos(2*pi*x), R*sin(2*pi*x), r*sin(2*pi*y))
c     #
c     #        r = alpha*(1 + beta*sin(2*pi*x))
c     #        R = 1 + r*cos(2*pi*y)
c     #
c     # The solution proceeds in two steps. If we are
c     # solving an incompressible problem, we only need
c     # to evolve (x(t), y(t)).  If we have a compressible
c     # problem, we first evolve (x(t),y(t)) back to a starting
c     # location (x0,y0), and then evolve x, y and q from
c     # the starting location back to final position.
c     # --------------------------------------------------------

      double precision function qexact(blockno, x,y,tfinal)
      implicit none

      external swirl_rhs_divfree
      external swirl_rhs_nondivfree
      external solout

      double precision x,y,tfinal
      integer blockno

      double precision xc0, yc0
      double precision xc1, yc1

c      integer blockno_dummy
      double precision t0
      double precision xp,yp,zp

      double precision sigma(3), rtol, atol
      integer itol, iout

      integer Nmax, lwork,nrdens, liwork
      parameter(Nmax=3, nrdens=0)
      parameter(lwork=8*Nmax+5*nrdens+21)
      parameter(liwork=nrdens+21)

      double precision work(lwork), rpar
      double precision q0_physical, q0
      integer iwork(liwork), ipar(2), idid

      double precision tol

      logical evolve_q

      integer example
      common /example_comm/ example

      integer use_stream
      common /velocity_comm/ use_stream

      integer initchoice
      common /initchoice_comm/ initchoice

      integer*8 cont, get_context

      integer i

      cont = get_context()

c     # ------------------------------------------
c     # Numerical parameters
c     # ------------------------------------------
      itol = 0
      rtol = 1.d-12
      atol = 1.d-12
      iout = 0

      do i = 1,20
          work(i) = 0
          iwork(i) = 0
      enddo

c     # Evolve from t=t0 to t=tfinal
      t0 = 0

c     # Initial conditions for ODE
      sigma(1) = x
      sigma(2) = y

      ipar(1) = example
      ipar(2) = use_stream

      call dopri5(2,swirl_rhs_divfree,t0,sigma,tfinal,
     &            rtol,atol,itol,
     &            solout,iout, work,lwork,iwork,liwork,
     &            rpar,ipar,idid)

      if (idid .ne. 1) then
          write(6,*) 'DOPRI5 : idid .ne. 1'
          stop
      endif

c     # Initial position traced back from (xc1,yc1)
      xc0 = sigma(1)
      yc0 = sigma(2)

c     # Map to [-1,1]x[-1,1]
      call mapc2m_cart(blockno,xc0,yc0,xc1,yc1,zp)

c     # Map to [0,1]x[0,1]
c      xp = (1 + xc0)/2.d0
c      yp = (1 + yc0)/2.d0
      xp = xc0
      yp = yc0

      if (initchoice .eq. 0) then
          write(6,*) 'qexact.f : initchoice .eq. 0 not defined'
          stop
      elseif (initchoice .eq. 1) then
          q0 = q0_physical(xp,yp,zp)
      elseif (initchoice .eq. 2) then
          q0 = 1.d0
      endif

      evolve_q = .true.
      if (evolve_q) then
c         # We now need to evolve q along with (x,y), starting from
c         # from (xc0,yc0)
          sigma(1) = xc0
          sigma(2) = yc0
          sigma(3) = q0

          do i = 1,20
              work(i) = 0
              iwork(i) = 0
          enddo

          t0 = 0
          call dopri5(3,swirl_rhs_nondivfree,t0,sigma,tfinal,
     &                rtol,atol,itol,
     &                solout,iout, work,lwork,iwork,liwork,
     &                rpar,ipar,idid)

          if (idid .ne. 1) then
              write(6,*) 'DOPRI5 : idid .ne. 1'
              stop
          endif

          tol = 1e-8
          if (abs(sigma(1)-x) .gt. tol) then
              write(6,*) 'qexact.f : Did not evolve x correctly'
              write(6,100) xc0,yc0
              write(6,100) x,y
              write(6,100) sigma(1), sigma(2)
              write(6,105) abs(x-sigma(1)), abs(y-sigma(2))
              stop
          endif
          if (abs(sigma(2)-y) .gt. tol) then
              write(6,*) 'qexact.f : Did not evolve y correctly'
              write(6,100) xc0,yc0
              write(6,100) x,y
              write(6,100) sigma(1), sigma(2)
              write(6,105) abs(x-sigma(1)), abs(y-sigma(2))
              stop
          endif
100       format(2F24.16)
105       format(2E24.4)

          qexact = sigma(3)
      else
          qexact = q0
      endif

      end

c     # ---------------------------------------------------------------
      subroutine solout(nr,xold,x,y,n,con,icomp,nd,rpar,ipar,irtrn)
      dimension y(n),con(5*nd),icomp(nd)

c     # Dummy routine

      end

c     # ---------------------------------------------------------------
      double precision function q0_physical(xp,yp,zp)
      implicit none

      double precision xp, yp, zp

      double precision x0, y0, z0, q0, r0, r
      double precision xpp, ypp
      double precision Hsmooth

c     # Sphere centered at (0.5,0.5,0) on swirl
      x0 = 0.5
      y0 = 0.5
      z0 = 0
      r0 = 0.2   !! radius of sphere

c     # modulo(A,P) = A - floor(A/P)*P
c      write(6,*) 'mod(6.1,1.d0)  ', modulo(6.1d0,1.d0)
c      write(6,*) 'mod(0.5,1.d0)  ', modulo(0.5d0,1.d0)
c      write(6,*) 'mod(-0.5,1.d0) ', modulo(-0.5d0,1.d0)
c      write(6,*) 'mod(-1.3,1.d0) ', modulo(-1.3d0,1.d0)
c      write(6,*) ' '
c      write(6,*) 'mod(6.1,1.d0)  ', 6.1d0 - floor(6.1d0)
c      write(6,*) 'mod(0.5,1.d0)  ', 0.5d0 - floor(0.5d0)
c      write(6,*) 'mod(-0.5,1.d0) ', -0.5d0 - floor(-0.5d0)
c      write(6,*) 'mod(-1.3,1.d0) ', -1.3d0 - floor(-1.3d0)
c      stop

      xpp = modulo(xp,1.d0)
      ypp = modulo(yp,1.d0)

      r = sqrt((xpp - x0)**2 + (ypp-y0)**2)
      q0 = Hsmooth(r + r0) - Hsmooth(r - r0)

      q0_physical = q0

      end

c     # ---------------------------------------------------------------
      double precision function Hsmooth(r)
      implicit none

      double precision r

      Hsmooth = (tanh(r/0.02d0) + 1)/2.d0

      end


subroutine solid_node_volume(x_solid,nsd,nn_solid,ien_solid,ne,nen,snvolume,adist)
! evaluate the nodal solid volume, to get snvolume which is equalivent to dwjp in RKPM initialize
! And the support radius of every solid node
use solid_variables, only: wq_solid, nquad_solid, xq_solid
implicit none

real(8) x_solid(nsd,nn_solid) ! solid coordinates
integer nsd ! # of dimension
integer nn_solid ! # of solid
integer ien_solid(ne,nen) ! connectivity of solid mesh
integer ne ! # of solid elements
integer nen ! # of nodes per solid element
real(8) snvolume(nn_solid) ! solid nodal volume
real(8) adist(nsd,nn_solid) ! support region of solid node
real(8) vol ! for *.fi
real(8) :: xr(nsd,nsd), cf(nsd,nsd)
real(8) det
integer iq
!------------------------
real(8) xn(nsd,nen)
integer ie
integer inl
integer isd
integer nnum
real(8) toxj(nsd,nsd)
real(8) toxji(nsd,nsd)
real(8) rs(nsd)
real(8) tot_vol
real(8) coef
real(8) xmax(nsd)

coef=1.0
snvolume(:)=0.0d0
tot_vol=0.0d0
do ie=1,ne
	do inl=1,nen
		do isd=1,nsd
			nnum=ien_solid(ie,inl)
			xn(isd,inl)=x_solid(isd,nnum)
		end do
	end do
	!...Calulate radius
	do isd=1,nsd
                xmax(isd) = coef*(maxval(xn(isd,1:nen)) - minval(xn(isd,1:nen)))
        enddo
	do inl = 1,nen
        nnum = ien_solid(ie,inl)
        adist(1:nsd,nnum) = max(adist(1:nsd,nnum),xmax(1:nsd))
   	enddo

	 !...Calculate volume
	vol=0.0
	do iq=1,nquad_solid
		rs(1:nsd)=xq_solid(1:nsd,iq)
		call r_element(rs)
		call r_jacob(xn,toxj,toxji,det)
		vol=vol+det*wq_solid(iq)
	end do
continue
	do inl=1,nen
		nnum=ien_solid(ie,inl)
		snvolume(nnum)=snvolume(nnum)+vol/nen
	end do
end do
	tot_vol=sum(snvolume)
!	write(*,*) adist(1:nsd,:)
return
end subroutine


Program main
	Use nrtype
	Use phys_consts
	Use diel_models
	Implicit None

	Real(DP)            :: mu2, rho
	Real(DP)            :: diel, G, sigBH, temp, scale, y
	Integer(I4B)        :: i

	rho    = 0.70     ! dimensionless
	temp   = 1.45
	mu2    = 0.00001  ! dimensionless with eps
	scale  = 1.30

    	OPEN(UNIT=23, FILE='./out.dat', STATUS='UNKNOWN', FORM='FORMATTED')

     	do while (mu2 <= 5)
!     	do while (rho < 1.0)
!    	do while (temp <= 2.51)
                y = (FOUR/9)*PI*rho*mu2*(1/temp)
		call compute_dielecric_SM(rho, mu2, temp, diel, G, sigBH, scale)
		write( *,111) temp, rho, mu2, sigBH, diel, G, y ! mu*mu output in epsilon units
		write(23,111) temp, rho, mu2, sigBH, diel, G, y ! mu*mu output in epsilon units
       		!temp = temp + 0.02
		mu2 = mu2 + 0.05
        enddo

111 FORMAT ( F10.2, 2X, F10.3, 2X, F14.6, 2X, F10.4, 2X, F10.2, 2X, E10.2, 2X, E16.6)

End program main