!>  @file  blsm.f90
!!  @brief Basic subprograms for the level-set method for Cartesian grid data structure
!<

function lsm_getd(phi0, phi1)
  implicit none
  real          :: lsm_getd
  real          :: phi0, phi1
  lsm_getd = abs(phi0)/(abs(phi0) + abs(phi1))
  if( phi0 >= 0 .and. phi1 >= 0 ) then
    lsm_getd = 1.0
  endif
  if( phi0 < 0 .and. phi1 < 0 ) then
    lsm_getd = 1.0
  endif
  return
end function lsm_getd

function lsm_getsign(a)
	implicit none
	real					:: lsm_getsign
	real					:: a
	lsm_getsign = 1.0
	if( a < 0 ) then
		lsm_getsign = -1.0
	end if
	return
end function lsm_getsign

function lsm_getminmod(a, b)
	implicit none
	real					:: lsm_getminmod
	real					:: a, b
!	lsm_getminmod = 0.5*(sign(a, a) + sign(b, b))*min(abs(a), abs(b))
	lsm_getminmod = 0.0
	if( abs(a) .lt. abs(b) ) then
		lsm_getminmod = a
	else if( abs(a) .gt. abs(b) ) then
		lsm_getminmod = b
	endif
	return
end function lsm_getminmod

function lsm_getupwind(u, n, p)
	implicit none
	real					:: lsm_getupwind
	real					:: u
	real					:: n, p
	lsm_getupwind = n
	if( u .lt. 0 ) then
		lsm_getupwind = p
	endif
	return
end function lsm_getupwind

function lsm_getupwind1(u, n, p)
	implicit none
	real					:: lsm_getupwind1
	real					:: u
	real					:: n, p
	lsm_getupwind1 = 0.0
	if( u .gt. 0 ) then
		lsm_getupwind1 = n
	else if( u .lt. 0 ) then
		lsm_getupwind1 = p
	endif
	return
end function lsm_getupwind1

function lsm_getupwind2(u, n, p)
	implicit none
	real					:: lsm_getupwind2
	real					:: u
	real					:: n, p
	lsm_getupwind2 = 0.5*(p + n)
	if( u .gt. 0 ) then
		lsm_getupwind2 = n
	else if( u .lt. 0 ) then
		lsm_getupwind2 = p
	endif
	return
end function lsm_getupwind2

function lsm_getweno3(v1, v2, v3)
	implicit none
	real					:: lsm_getweno3
	real					:: v1, v2, v3
	real					:: r
	real					:: w
	real					:: eps
	eps = 0.000001
	r = (eps + (v2-v1)**2)/(eps + (v3-v2)**2)
	w = 1.0/(1.0 + 2*r*r)
	lsm_getweno3 = 0.5*(v2 + v3) - 0.5*w*(v1 - 2.0*v2 + v3)
	return
end function lsm_getweno3

function lsm_getintval(f, xi, yi, zi, sz, g)
	implicit none
	real					:: lsm_getintval
	integer									:: g
	integer, dimension(3)		:: sz
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: f
	real					:: xi, yi, zi
	integer				:: i0, j0, k0
	real					:: x0, y0, z0
	real					:: dx, dy, dz
	real					:: f_ccc, f_pcc, f_cpc, f_ccp, f_ppc, f_cpp, f_pcp, f_ppp
	i0 = floor(xi + 0.5)
	j0 = floor(yi + 0.5)
	k0 = floor(zi + 0.5)
	x0 = real(i0) - 0.5
	y0 = real(j0) - 0.5
	z0 = real(k0) - 0.5
	dx = xi - x0
	dy = yi - y0
	dz = zi - z0
	f_ccc = f(i0, j0, k0)
	f_pcc = f(i0+1, j0, k0)
	f_cpc = f(i0, j0+1, k0)
	f_ccp = f(i0, j0, k0+1)
	f_ppc = f(i0+1, j0+1, k0)
	f_cpp = f(i0, j0+1, k0+1)
	f_pcp = f(i0+1, j0, k0+1)
	f_ppp = f(i0+1, j0+1, k0+1)
	lsm_getintval = &
						+ f_ccc*(1.0 - dx)*(1.0 - dy)*(1.0 - dz) &
						+ f_pcc*       dx *(1.0 - dy)*(1.0 - dz) &
						+ f_cpc*(1.0 - dx)*       dy *(1.0 - dz) &
						+ f_ccp*(1.0 - dx)*(1.0 - dy)*       dz  &
						+ f_ppc*       dx*        dy *(1.0 - dz) &
						+ f_cpp*(1.0 - dx)*       dy *       dz  &
						+ f_pcp*       dx *(1.0 - dy)*       dz  &
						+ f_ppp*       dx *       dy *       dz
	return
end function lsm_getintval

subroutine lsm_calc_n(nx, ny, nz, divn, phi, sz, g)
	implicit none
	integer									:: i, j, k
	integer									:: ix, jx, kx
	integer									:: g
	integer, dimension(3)		:: sz
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: nx, ny, nz
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: divn
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi
	real										:: dpx_c, dpy_c, dpz_c
	real										:: dpx_p, dpy_p, dpz_p
	real										:: dpx_n, dpy_n, dpz_n
	real										:: dp2_ppp, dp2_ppn, dp2_pnp, dp2_npp
	real										:: dp2_nnn, dp2_nnp, dp2_npn, dp2_pnn
	real										:: nx_tmp, ny_tmp, nz_tmp, n2_tmp, nl_tmp
	real										:: dpl_c, dp2_c
	real										:: dpxx_c, dpyy_c, dpzz_c
	real										:: dpxy_c, dpyz_c, dpzx_c
	real										:: eps
	ix = sz(1)
	jx = sz(2)
	kx = sz(3)
	eps = 1.0e-16
!$omp parallel private(i, j, k) &
!$omp					,private(dpx_c, dpy_c, dpz_c) &
!$omp					,private(dpx_p, dpy_p, dpz_p) &
!$omp					,private(dpx_n, dpy_n, dpz_n) &
!$omp					,private(dp2_ppp, dp2_ppn, dp2_pnp, dp2_npp) &
!$omp					,private(dp2_nnn, dp2_nnp, dp2_npn, dp2_pnn) &
!$omp					,private(nx_tmp, ny_tmp, nz_tmp, n2_tmp, nl_tmp) &
!$omp					,private(dpl_c, dp2_c) &
!$omp					,private(dpxx_c, dpyy_c, dpzz_c) &
!$omp					,private(dpxy_c, dpyz_c, dpzx_c)
!$omp do schedule(static, 1)
	do k=1, kx
	do j=1, jx
!ocl nouxsimd
	do i=1, ix
		dpx_p = phi(i+1, j, k) - phi(i, j, k)
		dpx_n = phi(i, j, k) - phi(i-1, j, k)
		dpy_p = phi(i, j+1, k) - phi(i, j, k)
		dpy_n = phi(i, j, k) - phi(i, j-1, k)
		dpz_p = phi(i, j, k+1) - phi(i, j, k)
		dpz_n = phi(i, j, k) - phi(i, j, k-1)
		dp2_ppp = dpx_p*dpx_p + dpy_p*dpy_p + dpz_p*dpz_p
		dp2_ppn = dpx_p*dpx_p + dpy_p*dpy_p + dpz_n*dpz_n
		dp2_pnp = dpx_p*dpx_p + dpy_n*dpy_n + dpz_p*dpz_p
		dp2_npp = dpx_n*dpx_n + dpy_p*dpy_p + dpz_p*dpz_p
		dp2_nnp = dpx_n*dpx_n + dpy_n*dpy_n + dpz_p*dpz_p
		dp2_npn = dpx_n*dpx_n + dpy_p*dpy_p + dpz_n*dpz_n
		dp2_pnn = dpx_p*dpx_p + dpy_n*dpy_n + dpz_n*dpz_n
		dp2_nnn = dpx_n*dpx_n + dpy_n*dpy_n + dpz_n*dpz_n
		nx_tmp = dpx_p/sqrt(dp2_ppp) &
					 + dpx_p/sqrt(dp2_ppn) &
					 + dpx_p/sqrt(dp2_pnp) &
					 + dpx_n/sqrt(dp2_npp) &
					 + dpx_n/sqrt(dp2_nnp) &
					 + dpx_n/sqrt(dp2_npn) &
					 + dpx_p/sqrt(dp2_pnn) &
					 + dpx_n/sqrt(dp2_nnn)
		ny_tmp = dpy_p/sqrt(dp2_ppp) &
					 + dpy_p/sqrt(dp2_ppn) &
					 + dpy_n/sqrt(dp2_pnp) &
					 + dpy_p/sqrt(dp2_npp) &
					 + dpy_n/sqrt(dp2_nnp) &
					 + dpy_p/sqrt(dp2_npn) &
					 + dpy_n/sqrt(dp2_pnn) &
					 + dpy_n/sqrt(dp2_nnn)
		nz_tmp = dpz_p/sqrt(dp2_ppp) &
					 + dpz_n/sqrt(dp2_ppn) &
					 + dpz_p/sqrt(dp2_pnp) &
					 + dpz_p/sqrt(dp2_npp) &
					 + dpz_p/sqrt(dp2_nnp) &
					 + dpz_n/sqrt(dp2_npn) &
					 + dpz_n/sqrt(dp2_pnn) &
					 + dpz_n/sqrt(dp2_nnn)
		n2_tmp = nx_tmp*nx_tmp + ny_tmp*ny_tmp + nz_tmp*nz_tmp
		nl_tmp = sqrt(n2_tmp)
		dpx_c = 0.5*(phi(i+1, j, k) - phi(i-1, j, k))
		dpy_c = 0.5*(phi(i, j+1, k) - phi(i, j-1, k))
		dpz_c = 0.5*(phi(i, j, k+1) - phi(i, j, k-1))
		dp2_c = dpx_c*dpx_c + dpy_c*dpy_c + dpz_c*dpz_c
		dpl_c = sqrt(dp2_c);
		dpxx_c = phi(i+1, j, k) + phi(i-1, j, k) - 2.0*phi(i, j, k)
		dpyy_c = phi(i, j+1, k) + phi(i, j-1, k) - 2.0*phi(i, j, k)
		dpzz_c = phi(i, j, k+1) + phi(i, j, k-1) - 2.0*phi(i, j, k)
		dpxy_c = (phi(i+1, j+1, k) + phi(i-1, j-1, k) - phi(i+1, j-1, k) - phi(i-1, j+1, k))*0.25
		dpyz_c = (phi(i, j+1, k+1) + phi(i, j-1, k-1) - phi(i, j-1, k+1) - phi(i, j+1, k-1))*0.25
		dpzx_c = (phi(i+1, j, k+1) + phi(i-1, j, k-1) - phi(i+1, j, k-1) - phi(i-1, j, k+1))*0.25
		nx(i, j, k) = dpx_c/dpl_c
		ny(i, j, k) = dpy_c/dpl_c
		nz(i, j, k) = dpz_c/dpl_c
		nx(i, j, k) = nx_tmp/nl_tmp
		ny(i, j, k) = ny_tmp/nl_tmp
		nz(i, j, k) = nz_tmp/nl_tmp
		divn(i, j, k) = ( &
										+ (dpyy_c + dpzz_c)*dpx_c*dpx_c &
										+ (dpzz_c + dpxx_c)*dpy_c*dpy_c &
										+ (dpxx_c + dpyy_c)*dpz_c*dpz_c &
										- 2.0*dpx_c*dpy_c*dpxy_c &
										- 2.0*dpy_c*dpz_c*dpyz_c &
										- 2.0*dpz_c*dpx_c*dpzx_c &
									)/(dpl_c**3 + eps);
	end do
	end do
	end do
!$omp end do
!$omp end parallel
end subroutine lsm_calc_n

subroutine lsm_calc_vin(vin, phi, psi, v, nx, ny, nz, sz, g)
	implicit none
	integer									:: i, j, k
	integer									:: ix, jx, kx
	integer									:: g
	integer, dimension(3)		:: sz
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: vin
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: psi
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g, 0:6)	:: v
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: nx, ny, nz
	real										:: vx, vy, vz
	ix = sz(1)
	jx = sz(2)
	kx = sz(3)
!$omp parallel private(i, j, k) &
!$omp					,private(vx, vy, vz)
!$omp do
	do k=1, kx
	do j=1, jx
	do i=1, ix
		vx = 0.5*(v(i, j, k, 1) + v(i, j, k, 3))
		vy = 0.5*(v(i, j, k, 2) + v(i, j, k, 4))
		vz = 0.5*(v(i, j, k, 5) + v(i, j, k, 6))
		vin(i, j, k) = vx*nx(i, j, k) + vy*ny(i, j, k) + vz*nz(i, j, k)
		if( psi(i, j, k) >= 0.0 ) then
			vin(i, j, k) = 0.0d0
		end if
	end do
	end do
	end do
!$omp end do
!$omp end parallel
end subroutine lsm_calc_vin

subroutine lsm_calc_i(fi, f0, phi, phinx, phiny, phinz, psi, sz, g)
	implicit none
	integer									:: i, j, k
	integer									:: ix, jx, kx
	integer									:: g
	integer, dimension(3)		:: sz
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: fi
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: f0
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phinx, phiny, phinz
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: psi
	real										:: phi0, phi1, phi3, phi2, phi4, phi5, phi6
	real										:: x, y, z
	real										:: xi, yi, zi
	real										:: nx, ny, nz, n2, nl
	integer									:: i0, j0, k0
	real										:: x0, y0, z0
	real										:: dx, dy, dz
	real										:: f_ccc, f_pcc, f_cpc, f_ccp, f_ppc, f_cpp, f_pcp, f_ppp
	real										:: lsm_getintval
	ix = sz(1)
	jx = sz(2)
	kx = sz(3)
!$omp parallel private(i, j, k) &
!$omp					,private(phi0, phi1, phi3, phi2, phi4, phi5, phi6) &
!$omp					,private(x, y, z) &
!$omp					,private(xi, yi, zi) &
!$omp					,private(nx, ny, nz, n2, nl) &
!$omp					,private(i0, j0, k0) &
!$omp					,private(x0, y0, z0) &
!$omp					,private(dx, dy, dz) &
!$omp					,private(f_ccc, f_pcc, f_cpc, f_ccp, f_ppc, f_cpp, f_pcp, f_ppp)
!$omp do schedule(dynamic, 1)
	do k=1, kx
	do j=1, jx
	do i=1, ix
		fi(i, j, k) = 0.0
		if( psi(i, j, k) >= 0 ) then
			cycle
		endif
		phi0 = phi(i, j, k)
		phi1 = phi(i+1, j, k)
		phi3 = phi(i-1, j, k)
		phi2 = phi(i, j+1, k)
		phi4 = phi(i, j-1, k)
		phi5 = phi(i, j, k+1)
		phi6 = phi(i, j, k-1)
		if( phi0*phi1 <= 0 .or. &
				phi0*phi3 <= 0 .or. &
				phi0*phi2 <= 0 .or. &
				phi0*phi4 <= 0 .or. &
				phi0*phi5 <= 0 .or. &
				phi0*phi6 <= 0 ) then
			if( abs(phi0) >= 1.0 ) then
				fi(i, j, k) = f0(i, j, k)
			else
				x = real(i) - 0.5
				y = real(j) - 0.5
				z = real(k) - 0.5
				xi = x - phi0*phinx(i, j, k)
				yi = y - phi0*phiny(i, j, k)
				zi = z - phi0*phinz(i, j, k)
				fi(i, j, k) = lsm_getintval(f0, xi, yi, zi, sz, g)
			endif
		endif
	end do
	end do
	end do
!$omp end do
!$omp end parallel
end subroutine lsm_calc_i

subroutine lsm_update_phi_v(phi1_, phi0_, v0_, psi_, sz, g)
	implicit none
	integer									:: i, j, k
	integer									:: ix, jx, kx
	integer									:: g
	integer, dimension(3)		:: sz
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi1_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi0_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g, 0:6)	:: v0_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: psi_
	real										:: dpx_p2, dpy_p2, dpz_p2
	real										:: dpx_p1, dpy_p1, dpz_p1
	real										:: dpx_n1, dpy_n1, dpz_n1
	real										:: dpx_n2, dpy_n2, dpz_n2
	real										:: dpx_p, dpy_p, dpz_p
	real										:: dpx_c, dpy_c, dpz_c
	real										:: dpx_n, dpy_n, dpz_n
	real										:: phi1p, phi3p, phi2p, phi4p, phi5p, phi6p
	real										:: phi1n, phi3n, phi2n, phi4n, phi5n, phi6n
	real										:: phi0, phi1, phi3, phi2, phi4, phi5, phi6
	real										:: psi0, psi1, psi3, psi2, psi4, psi5, psi6
	real										:: dpsi0, dpsi1, dpsi3, dpsi2, dpsi4, dpsi5, dpsi6
	real										:: q1, q3, q2, q4, q5, q6
	real										:: lsm_getminmod
	real										:: lsm_getupwind
	real										:: lsm_getd
	ix = sz(1)
	jx = sz(2)
	kx = sz(3)
!$omp parallel private(i, j, k) &
!$omp					,private(dpx_p2, dpy_p2, dpz_p2) &
!$omp					,private(dpx_p1, dpy_p1, dpz_p1) &
!$omp					,private(dpx_n1, dpy_n1, dpz_n1) &
!$omp					,private(dpx_n2, dpy_n2, dpz_n2) &
!$omp					,private(dpx_p, dpy_p, dpz_p) &
!$omp					,private(dpx_c, dpy_c, dpz_c) &
!$omp					,private(dpx_n, dpy_n, dpz_n) &
!$omp					,private(phi1p, phi3p, phi2p, phi4p, phi5p, phi6p) &
!$omp					,private(phi1n, phi3n, phi2n, phi4n, phi5n, phi6n) &
!$omp					,private(phi0, phi1, phi3, phi2, phi4, phi5, phi6) &
!$omp					,private(psi0, psi1, psi3, psi2, psi4, psi5, psi6) &
!$omp					,private(dpsi0, dpsi1, dpsi3, dpsi2, dpsi4, dpsi5, dpsi6) &
!$omp					,private(q1, q3, q2, q4, q5, q6)
!$omp do schedule(static, 1)
	do k=1, kx
	do j=1, jx
!ocl nouxsimd
	do i=1, ix
		dpx_p2 = phi0_(i+2, j, k) - phi0_(i+1, j, k)
		dpx_p1 = phi0_(i+1, j, k) - phi0_(i  , j, k)
		dpx_n1 = phi0_(i  , j, k) - phi0_(i-1, j, k)
		dpx_n2 = phi0_(i-1, j, k) - phi0_(i-2, j, k)

		dpy_p2 = phi0_(i, j+2, k) - phi0_(i, j+1, k)
		dpy_p1 = phi0_(i, j+1, k) - phi0_(i, j  , k)
		dpy_n1 = phi0_(i, j  , k) - phi0_(i, j-1, k)
		dpy_n2 = phi0_(i, j-1, k) - phi0_(i, j-2, k)

		dpz_p2 = phi0_(i, j, k+2) - phi0_(i, j, k+1)
		dpz_p1 = phi0_(i, j, k+1) - phi0_(i, j, k  )
		dpz_n1 = phi0_(i, j, k  ) - phi0_(i, j, k-1)
		dpz_n2 = phi0_(i, j, k-1) - phi0_(i, j, k-2)

		dpx_p = lsm_getminmod(dpx_p2, dpx_p1)
		dpx_c = lsm_getminmod(dpx_p1, dpx_n1)
		dpx_n = lsm_getminmod(dpx_n1, dpx_n2)
		dpy_p = lsm_getminmod(dpy_p2, dpy_p1)
		dpy_c = lsm_getminmod(dpy_p1, dpy_n1)
		dpy_n = lsm_getminmod(dpy_n1, dpy_n2)
		dpz_p = lsm_getminmod(dpz_p2, dpz_p1)
		dpz_c = lsm_getminmod(dpz_p1, dpz_n1)
		dpz_n = lsm_getminmod(dpz_n1, dpz_n2)

		phi1p = phi0_(i+1, j, k) - 0.5*dpx_p
		phi1n = phi0_(i  , j, k) + 0.5*dpx_c
		phi3p = phi0_(i  , j, k) - 0.5*dpx_c
		phi3n = phi0_(i-1, j, k) + 0.5*dpx_n

		phi2p = phi0_(i, j+1, k) - 0.5*dpy_p
		phi2n = phi0_(i, j  , k) + 0.5*dpy_c
		phi4p = phi0_(i, j  , k) - 0.5*dpy_c
		phi4n = phi0_(i, j-1, k) + 0.5*dpy_n

		phi5p = phi0_(i, j, k+1) - 0.5*dpz_p
		phi5n = phi0_(i, j, k  ) + 0.5*dpz_c
		phi6p = phi0_(i, j, k  ) - 0.5*dpz_c
		phi6n = phi0_(i, j, k-1) + 0.5*dpz_n

		phi1 = lsm_getupwind(v0_(i, j, k, 1), phi1n, phi1p)
		phi3 = lsm_getupwind(v0_(i, j, k, 3), phi3n, phi3p)
		phi2 = lsm_getupwind(v0_(i, j, k, 2), phi2n, phi2p)
		phi4 = lsm_getupwind(v0_(i, j, k, 4), phi4n, phi4p)
		phi5 = lsm_getupwind(v0_(i, j, k, 5), phi5n, phi5p)
		phi6 = lsm_getupwind(v0_(i, j, k, 6), phi6n, phi6p)

		if( psi_(i+1, j, k) >= 0 ) then
			phi1 = 0.0
			phi1 = phi0_(i, j, k) + (dpsi1 - 0.5)/(dpsi1 + 0.5)*(phi0_(i, j, k) - phi0_(i-1, j, k))
			phi1 = phi0_(i, j, k) + 0.5*(dpsi1 - 0.5)/(dpsi1 + 0.5)*(phi0_(i, j, k) - phi0_(i-1, j, k))
			phi1 = phi0_(i, j, k)
		end if
		if( psi_(i-1, j, k) >= 0 ) then
			phi3 = 0.0
			phi3 = phi0_(i, j, k) - (dpsi3 - 0.5)/(dpsi3 + 0.5)*(phi0_(i+1, j, k) - phi0_(i, j, k))
			phi3 = phi0_(i, j, k) - 0.5*(dpsi3 - 0.5)/(dpsi3 + 0.5)*(phi0_(i+1, j, k) - phi0_(i, j, k))
			phi3 = phi0_(i, j, k)
		end if
		if( psi_(i, j+1, k) >= 0 ) then
			phi2 = 0.0
			phi2 = phi0_(i, j, k) + (dpsi2 - 0.5)/(dpsi2 + 0.5)*(phi0_(i, j, k) - phi0_(i, j-1, k))
			phi2 = phi0_(i, j, k) + 0.5*(dpsi2 - 0.5)/(dpsi2 + 0.5)*(phi0_(i, j, k) - phi0_(i, j-1, k))
			phi2 = phi0_(i, j, k)
		end if
		if( psi_(i, j-1, k) >= 0 ) then
			phi4 = 0.0
			phi4 = phi0_(i, j, k) - (dpsi4 - 0.5)/(dpsi4 + 0.5)*(phi0_(i, j+1, k) - phi0_(i, j, k))
			phi4 = phi0_(i, j, k) - 0.5*(dpsi4 - 0.5)/(dpsi4 + 0.5)*(phi0_(i, j+1, k) - phi0_(i, j, k))
			phi4 = phi0_(i, j, k)
		end if
		if( psi_(i, j, k+1) >= 0 ) then
			phi5 = 0.0
			phi5 = phi0_(i, j, k) + (dpsi5 - 0.5)/(dpsi5 + 0.5)*(phi0_(i, j, k) - phi0_(i, j, k-1))
			phi5 = phi0_(i, j, k) + 0.5*(dpsi5 - 0.5)/(dpsi5 + 0.5)*(phi0_(i, j, k) - phi0_(i, j, k-1))
			phi5 = phi0_(i, j, k)
		end if
		if( psi_(i, j, k-1) >= 0 ) then
			phi6 = 0.0
			phi6 = phi0_(i, j, k) - (dpsi6 - 0.5)/(dpsi6 + 0.5)*(phi0_(i, j, k+1) - phi0_(i, j, k))
			phi6 = phi0_(i, j, k) - 0.5*(dpsi6 - 0.5)/(dpsi6 + 0.5)*(phi0_(i, j, k+1) - phi0_(i, j, k))
			phi6 = phi0_(i, j, k)
		end if

		q1 = phi1*v0_(i, j, k, 1)
		q3 = phi3*v0_(i, j, k, 3)
		q2 = phi2*v0_(i, j, k, 2)
		q4 = phi4*v0_(i, j, k, 4)
		q5 = phi5*v0_(i, j, k, 5)
		q6 = phi6*v0_(i, j, k, 6)

		phi1_(i, j, k) = phi0_(i, j, k) &
											- (q1 - q3) &
											- (q2 - q4) &
											- (q5 - q6)
	end do
	end do
	end do
!$omp end do
!$omp end parallel
end subroutine lsm_update_phi_v

subroutine lsm_update_phi_v_2(phi1_, phi0_, v0_, psi, sz, g)
	implicit none
	integer									:: i, j, k
	integer									:: ix, jx, kx
	integer									:: g
	integer, dimension(3)		:: sz
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi1_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi0_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g, 0:6)	:: v0_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: psi
	real										:: dpx_p2, dpy_p2, dpz_p2
	real										:: dpx_p1, dpy_p1, dpz_p1
	real										:: dpx_n1, dpy_n1, dpz_n1
	real										:: dpx_n2, dpy_n2, dpz_n2
	real										:: dpx_p, dpy_p, dpz_p
	real										:: dpx_c, dpy_c, dpz_c
	real										:: dpx_n, dpy_n, dpz_n
	real										:: phi1p, phi3p, phi2p, phi4p, phi5p, phi6p
	real										:: phi1n, phi3n, phi2n, phi4n, phi5n, phi6n
	real										:: phi0, phi1, phi3, phi2, phi4, phi5, phi6
	real										:: lsm_getminmod
	real										:: lsm_getupwind
	ix = sz(1)
	jx = sz(2)
	kx = sz(3)
!$omp parallel private(i, j, k) &
!$omp					,private(dpx_p2, dpy_p2, dpz_p2) &
!$omp					,private(dpx_p1, dpy_p1, dpz_p1) &
!$omp					,private(dpx_n1, dpy_n1, dpz_n1) &
!$omp					,private(dpx_n2, dpy_n2, dpz_n2) &
!$omp					,private(dpx_p, dpy_p, dpz_p) &
!$omp					,private(dpx_c, dpy_c, dpz_c) &
!$omp					,private(dpx_n, dpy_n, dpz_n) &
!$omp					,private(phi1p, phi3p, phi2p, phi4p, phi5p, phi6p) &
!$omp					,private(phi1n, phi3n, phi2n, phi4n, phi5n, phi6n) &
!$omp					,private(phi0, phi1, phi3, phi2, phi4, phi5, phi6)
!$omp do schedule(static, 1)
	do k=1, kx
	do j=1, jx
!ocl nouxsimd
	do i=1, ix
		phi1p = 0.125*(3.0*phi0_(i, j, k) + 6.0*phi0_(i+1, j, k) - phi0_(i+2, j, k))
		phi1n = 0.125*(6.0*phi0_(i, j, k) + 3.0*phi0_(i+1, j, k) - phi0_(i-1, j, k))
		phi3p = 0.125*(6.0*phi0_(i, j, k) + 3.0*phi0_(i-1, j, k) - phi0_(i+1, j, k))
		phi3n = 0.125*(3.0*phi0_(i, j, k) + 6.0*phi0_(i-1, j, k) - phi0_(i-2, j, k))

		phi2p = 0.125*(3.0*phi0_(i, j, k) + 6.0*phi0_(i, j+1, k) - phi0_(i, j+2, k))
		phi2n = 0.125*(6.0*phi0_(i, j, k) + 3.0*phi0_(i, j+1, k) - phi0_(i, j-1, k))
		phi4p = 0.125*(6.0*phi0_(i, j, k) + 3.0*phi0_(i, j-1, k) - phi0_(i, j+1, k))
		phi4n = 0.125*(3.0*phi0_(i, j, k) + 6.0*phi0_(i, j-1, k) - phi0_(i, j-2, k))

		phi5p = 0.125*(3.0*phi0_(i, j, k) + 6.0*phi0_(i, j, k+1) - phi0_(i, j, k+2))
		phi5n = 0.125*(6.0*phi0_(i, j, k) + 3.0*phi0_(i, j, k+1) - phi0_(i, j, k-1))
		phi6p = 0.125*(6.0*phi0_(i, j, k) + 3.0*phi0_(i, j, k-1) - phi0_(i, j, k+1))
		phi6n = 0.125*(3.0*phi0_(i, j, k) + 6.0*phi0_(i, j, k-1) - phi0_(i, j, k-2))

		phi1 = lsm_getupwind(v0_(i, j, k, 1), phi1n, phi1p)
		phi3 = lsm_getupwind(v0_(i, j, k, 3), phi3n, phi3p)
		phi2 = lsm_getupwind(v0_(i, j, k, 2), phi2n, phi2p)
		phi4 = lsm_getupwind(v0_(i, j, k, 4), phi4n, phi4p)
		phi5 = lsm_getupwind(v0_(i, j, k, 5), phi5n, phi5p)
		phi6 = lsm_getupwind(v0_(i, j, k, 6), phi6n, phi6p)

		phi1_(i, j, k) = phi0_(i, j, k) &
											- (v0_(i, j, k, 1)*phi1 - v0_(i, j, k, 3)*phi3) &
											- (v0_(i, j, k, 2)*phi2 - v0_(i, j, k, 4)*phi4) &
											- (v0_(i, j, k, 5)*phi5 - v0_(i, j, k, 6)*phi6)
	end do
	end do
	end do
!$omp end do
!$omp end parallel
end subroutine lsm_update_phi_v_2

subroutine lsm_update_phi_v_quick(phi1_, phi0_, v0_, psi_, sz, g)
	implicit none
	integer									:: i, j, k
	integer									:: ix, jx, kx
	integer									:: g
	integer, dimension(3)		:: sz
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi1_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi0_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g, 0:6)	:: v0_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: psi_
	real										:: dpx_p2, dpy_p2, dpz_p2
	real										:: dpx_p1, dpy_p1, dpz_p1
	real										:: dpx_n1, dpy_n1, dpz_n1
	real										:: dpx_n2, dpy_n2, dpz_n2
	real										:: dpx_p, dpy_p, dpz_p
	real										:: dpx_c, dpy_c, dpz_c
	real										:: dpx_n, dpy_n, dpz_n
	real										:: phi1p, phi3p, phi2p, phi4p, phi5p, phi6p
	real										:: phi1n, phi3n, phi2n, phi4n, phi5n, phi6n
	real										:: phi0, phi1, phi3, phi2, phi4, phi5, phi6
	real										:: psi0, psi1, psi3, psi2, psi4, psi5, psi6
	real										:: dpsi0, dpsi1, dpsi3, dpsi2, dpsi4, dpsi5, dpsi6
	real										:: lsm_getminmod
	real										:: lsm_getupwind
	real										:: lsm_getd
	ix = sz(1)
	jx = sz(2)
	kx = sz(3)
!$omp parallel private(i, j, k) &
!$omp					,private(dpx_p2, dpy_p2, dpz_p2) &
!$omp					,private(dpx_p1, dpy_p1, dpz_p1) &
!$omp					,private(dpx_n1, dpy_n1, dpz_n1) &
!$omp					,private(dpx_n2, dpy_n2, dpz_n2) &
!$omp					,private(dpx_p, dpy_p, dpz_p) &
!$omp					,private(dpx_c, dpy_c, dpz_c) &
!$omp					,private(dpx_n, dpy_n, dpz_n) &
!$omp					,private(phi1p, phi3p, phi2p, phi4p, phi5p, phi6p) &
!$omp					,private(phi1n, phi3n, phi2n, phi4n, phi5n, phi6n) &
!$omp					,private(phi0, phi1, phi3, phi2, phi4, phi5, phi6) &
!$omp					,private(psi0, psi1, psi3, psi2, psi4, psi5, psi6) &
!$omp					,private(dpsi0, dpsi1, dpsi3, dpsi2, dpsi4, dpsi5, dpsi6)
!$omp do schedule(static, 1)
	do k=1, kx
	do j=1, jx
!ocl nouxsimd
	do i=1, ix
		phi1p = 0.125*(3.0*phi0_(i, j, k) + 6.0*phi0_(i+1, j, k) - phi0_(i+2, j, k))
		phi1n = 0.125*(6.0*phi0_(i, j, k) + 3.0*phi0_(i+1, j, k) - phi0_(i-1, j, k))
		phi3p = 0.125*(6.0*phi0_(i, j, k) + 3.0*phi0_(i-1, j, k) - phi0_(i+1, j, k))
		phi3n = 0.125*(3.0*phi0_(i, j, k) + 6.0*phi0_(i-1, j, k) - phi0_(i-2, j, k))

		phi2p = 0.125*(3.0*phi0_(i, j, k) + 6.0*phi0_(i, j+1, k) - phi0_(i, j+2, k))
		phi2n = 0.125*(6.0*phi0_(i, j, k) + 3.0*phi0_(i, j+1, k) - phi0_(i, j-1, k))
		phi4p = 0.125*(6.0*phi0_(i, j, k) + 3.0*phi0_(i, j-1, k) - phi0_(i, j+1, k))
		phi4n = 0.125*(3.0*phi0_(i, j, k) + 6.0*phi0_(i, j-1, k) - phi0_(i, j-2, k))

		phi5p = 0.125*(3.0*phi0_(i, j, k) + 6.0*phi0_(i, j, k+1) - phi0_(i, j, k+2))
		phi5n = 0.125*(6.0*phi0_(i, j, k) + 3.0*phi0_(i, j, k+1) - phi0_(i, j, k-1))
		phi6p = 0.125*(6.0*phi0_(i, j, k) + 3.0*phi0_(i, j, k-1) - phi0_(i, j, k+1))
		phi6n = 0.125*(3.0*phi0_(i, j, k) + 6.0*phi0_(i, j, k-1) - phi0_(i, j, k-2))

		phi1 = lsm_getupwind(v0_(i, j, k, 1), phi1n, phi1p)
		phi3 = lsm_getupwind(v0_(i, j, k, 3), phi3n, phi3p)
		phi2 = lsm_getupwind(v0_(i, j, k, 2), phi2n, phi2p)
		phi4 = lsm_getupwind(v0_(i, j, k, 4), phi4n, phi4p)
		phi5 = lsm_getupwind(v0_(i, j, k, 5), phi5n, phi5p)
		phi6 = lsm_getupwind(v0_(i, j, k, 6), phi6n, phi6p)

		psi0 = psi_(i, j, k)
		psi1 = psi_(i+1, j, k)
		psi3 = psi_(i-1, j, k)
		psi2 = psi_(i, j+1, k)
		psi4 = psi_(i, j-1, k)
		psi5 = psi_(i, j, k+1)
		psi6 = psi_(i, j, k-1)

    dpsi1 = lsm_getd(psi0, psi1)
    dpsi3 = lsm_getd(psi0, psi3)
    dpsi2 = lsm_getd(psi0, psi2)
    dpsi4 = lsm_getd(psi0, psi4)
    dpsi5 = lsm_getd(psi0, psi5)
    dpsi6 = lsm_getd(psi0, psi6)

		if( psi_(i+1, j, k) >= 0 ) then
			phi1 = 0.0
			phi1 = phi0_(i, j, k) + (dpsi1 - 0.5)/(dpsi1 + 0.5)*(phi0_(i, j, k) - phi0_(i-1, j, k))
			phi1 = phi0_(i, j, k)
		end if
		if( psi_(i-1, j, k) >= 0 ) then
			phi3 = 0.0
			phi3 = phi0_(i, j, k) - (dpsi3 - 0.5)/(dpsi3 + 0.5)*(phi0_(i+1, j, k) - phi0_(i, j, k))
			phi3 = phi0_(i, j, k)
		end if
		if( psi_(i, j+1, k) >= 0 ) then
			phi2 = 0.0
			phi2 = phi0_(i, j, k) + (dpsi2 - 0.5)/(dpsi2 + 0.5)*(phi0_(i, j, k) - phi0_(i, j-1, k))
			phi2 = phi0_(i, j, k)
		end if
		if( psi_(i, j-1, k) >= 0 ) then
			phi4 = 0.0
			phi4 = phi0_(i, j, k) - (dpsi4 - 0.5)/(dpsi4 + 0.5)*(phi0_(i, j+1, k) - phi0_(i, j, k))
			phi4 = phi0_(i, j, k)
		end if
		if( psi_(i, j, k+1) >= 0 ) then
			phi5 = 0.0
			phi5 = phi0_(i, j, k) + (dpsi5 - 0.5)/(dpsi5 + 0.5)*(phi0_(i, j, k) - phi0_(i, j, k-1))
			phi5 = phi0_(i, j, k)
		end if
		if( psi_(i, j, k-1) >= 0 ) then
			phi6 = 0.0
			phi6 = phi0_(i, j, k) - (dpsi6 - 0.5)/(dpsi6 + 0.5)*(phi0_(i, j, k+1) - phi0_(i, j, k))
			phi6 = phi0_(i, j, k)
		end if

		phi1_(i, j, k) = phi0_(i, j, k) &
											- (v0_(i, j, k, 1)*phi1 - v0_(i, j, k, 3)*phi3) &
											- (v0_(i, j, k, 2)*phi2 - v0_(i, j, k, 4)*phi4) &
											- (v0_(i, j, k, 5)*phi5 - v0_(i, j, k, 6)*phi6)
	end do
	end do
	end do
!$omp end do
!$omp end parallel
end subroutine lsm_update_phi_v_quick

subroutine lsm_update_phi_v_weno3(phi1_, phi0_, v0_, sz, g)
	implicit none
	integer									:: i, j, k
	integer									:: ix, jx, kx
	integer									:: g
	integer, dimension(3)		:: sz
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi1_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi0_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g, 0:6)	:: v0_
	real										:: dpx_p2, dpy_p2, dpz_p2
	real										:: dpx_p1, dpy_p1, dpz_p1
	real										:: dpx_n1, dpy_n1, dpz_n1
	real										:: dpx_n2, dpy_n2, dpz_n2
	real										:: dpx_p, dpy_p, dpz_p
	real										:: dpx_n, dpy_n, dpz_n
	real										:: vx, vy, vz
	real										:: lsm_getweno3
	ix = sz(1)
	jx = sz(2)
	kx = sz(3)
!$omp parallel private(i, j, k) &
!$omp					,private(dpx_p2, dpy_p2, dpz_p2) &
!$omp					,private(dpx_p1, dpy_p1, dpz_p1) &
!$omp					,private(dpx_n1, dpy_n1, dpz_n1) &
!$omp					,private(dpx_n2, dpy_n2, dpz_n2) &
!$omp					,private(dpx_p, dpy_p, dpz_p) &
!$omp					,private(dpx_n, dpy_n, dpz_n) &
!$omp					,private(vx, vy, vz)
!$omp do schedule(static, 1)
	do k=1, kx
	do j=1, jx
	do i=1, ix
		dpx_p2 = phi0_(i+2, j, k) - phi0_(i+1, j, k)
		dpx_p1 = phi0_(i+1, j, k) - phi0_(i  , j, k)
		dpx_n1 = phi0_(i  , j, k) - phi0_(i-1, j, k)
		dpx_n2 = phi0_(i-1, j, k) - phi0_(i-2, j, k)

		dpy_p2 = phi0_(i, j+2, k) - phi0_(i, j+1, k)
		dpy_p1 = phi0_(i, j+1, k) - phi0_(i, j  , k)
		dpy_n1 = phi0_(i, j  , k) - phi0_(i, j-1, k)
		dpy_n2 = phi0_(i, j-1, k) - phi0_(i, j-2, k)

		dpz_p2 = phi0_(i, j, k+2) - phi0_(i, j, k+1)
		dpz_p1 = phi0_(i, j, k+1) - phi0_(i, j, k  )
		dpz_n1 = phi0_(i, j, k  ) - phi0_(i, j, k-1)
		dpz_n2 = phi0_(i, j, k-1) - phi0_(i, j, k-2)

		dpx_p = lsm_getweno3(dpx_p2, dpx_p1, dpx_n1)
		dpx_n = lsm_getweno3(dpx_n2, dpx_n1, dpx_p1)
		dpy_p = lsm_getweno3(dpy_p2, dpy_p1, dpy_n1)
		dpy_n = lsm_getweno3(dpy_n2, dpy_n1, dpy_p1)
		dpz_p = lsm_getweno3(dpz_p2, dpz_p1, dpz_n1)
		dpz_n = lsm_getweno3(dpz_n2, dpz_n1, dpz_p1)

		vx = 0.5*(v0_(i, j, k, 1) + v0_(i, j, k, 3))
		vy = 0.5*(v0_(i, j, k, 2) + v0_(i, j, k, 4))
		vz = 0.5*(v0_(i, j, k, 5) + v0_(i, j, k, 6))

		phi1_(i, j, k) = phi0_(i, j, k) &
											- (max(vx, 0.0)*dpx_n + min(vx, 0.0)*dpx_p) &
											- (max(vy, 0.0)*dpy_n + min(vy, 0.0)*dpy_p) &
											- (max(vz, 0.0)*dpz_n + min(vz, 0.0)*dpz_p)
	end do
	end do
	end do
!$omp end do
!$omp end parallel
end subroutine lsm_update_phi_v_weno3

subroutine lsm_update_phi_f(phi1_, phi0_, phif, sz, g)
	implicit none
	integer									:: i, j, k
	integer									:: ix, jx, kx
	integer									:: g
	integer, dimension(3)		:: sz
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi1_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi0_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phif
	real										:: dpxx_n, dpxx_c, dpxx_p
	real										:: dpyy_n, dpyy_c, dpyy_p
	real										:: dpzz_n, dpzz_c, dpzz_p
	real										:: dpxx_nc, dpxx_pc
	real										:: dpyy_nc, dpyy_pc
	real										:: dpzz_nc, dpzz_pc
	real										:: dpx_p1, dpy_p1, dpz_p1
	real										:: dpx_n1, dpy_n1, dpz_n1
	real										:: dpx_p2, dpy_p2, dpz_p2
	real										:: dpx_n2, dpy_n2, dpz_n2
	real										:: dp_p, dp_n
	real										:: lsm_getminmod
	ix = sz(1)
	jx = sz(2)
	kx = sz(3)
!$omp parallel private(i, j, k) &
!$omp					,private(dpxx_n, dpxx_c, dpxx_p) &
!$omp					,private(dpyy_n, dpyy_c, dpyy_p) &
!$omp					,private(dpzz_n, dpzz_c, dpzz_p) &
!$omp					,private(dpxx_nc, dpxx_pc) &
!$omp					,private(dpyy_nc, dpyy_pc) &
!$omp					,private(dpzz_nc, dpzz_pc) &
!$omp					,private(dpx_p1, dpy_p1, dpz_p1) &
!$omp					,private(dpx_n1, dpy_n1, dpz_n1) &
!$omp					,private(dpx_p2, dpy_p2, dpz_p2) &
!$omp					,private(dpx_n2, dpy_n2, dpz_n2) &
!$omp					,private(dp_p, dp_n)
!$omp do schedule(static, 1)
	do k=1, kx
	do j=1, jx
!ocl nouxsimd
	do i=1, ix
		dpxx_n = phi0_(i+0, j, k) + phi0_(i-2, j, k) - 2.0*phi0_(i-1, j, k)
		dpxx_c = phi0_(i+1, j, k) + phi0_(i-1, j, k) - 2.0*phi0_(i  , j, k)
		dpxx_p = phi0_(i+2, j, k) + phi0_(i-0, j, k) - 2.0*phi0_(i+1, j, k)
		dpyy_n = phi0_(i, j+0, k) + phi0_(i, j-2, k) - 2.0*phi0_(i, j-1, k)
		dpyy_c = phi0_(i, j+1, k) + phi0_(i, j-1, k) - 2.0*phi0_(i, j  , k)
		dpyy_p = phi0_(i, j+2, k) + phi0_(i, j-0, k) - 2.0*phi0_(i, j+1, k)
		dpzz_n = phi0_(i, j, k+0) + phi0_(i, j, k-2) - 2.0*phi0_(i, j, k-1)
		dpzz_c = phi0_(i, j, k+1) + phi0_(i, j, k-1) - 2.0*phi0_(i, j, k  )
		dpzz_p = phi0_(i, j, k+2) + phi0_(i, j, k-0) - 2.0*phi0_(i, j, k+1)
		dpx_n1 = phi0_(i, j, k) - phi0_(i-1, j, k)
		dpy_n1 = phi0_(i, j, k) - phi0_(i, j-1, k)
		dpz_n1 = phi0_(i, j, k) - phi0_(i, j, k-1)
		dpx_p1 = phi0_(i+1, j, k) - phi0_(i, j, k)
		dpy_p1 = phi0_(i, j+1, k) - phi0_(i, j, k)
		dpz_p1 = phi0_(i, j, k+1) - phi0_(i, j, k)
		dpx_n2 = dpx_n1 + 0.5*lsm_getminmod(dpxx_c, dpxx_n)
		dpy_n2 = dpy_n1 + 0.5*lsm_getminmod(dpyy_c, dpyy_n)
		dpz_n2 = dpz_n1 + 0.5*lsm_getminmod(dpzz_c, dpzz_n)
		dpx_p2 = dpx_p1 - 0.5*lsm_getminmod(dpxx_c, dpxx_p)
		dpy_p2 = dpy_p1 - 0.5*lsm_getminmod(dpyy_c, dpyy_p)
		dpz_p2 = dpz_p1 - 0.5*lsm_getminmod(dpzz_c, dpzz_p)
		dp_p = sqrt( &
								max(dpx_n2, 0.0)*max(dpx_n2, 0.0) &
							+ min(dpx_p2, 0.0)*min(dpx_p2, 0.0) &
							+ max(dpy_n2, 0.0)*max(dpy_n2, 0.0) &
							+ min(dpy_p2, 0.0)*min(dpy_p2, 0.0) &
							+ max(dpz_n2, 0.0)*max(dpz_n2, 0.0) &
							+ min(dpz_p2, 0.0)*min(dpz_p2, 0.0) &
						)
		dp_n = sqrt( &
								min(dpx_n2, 0.0)*min(dpx_n2, 0.0) &
							+ max(dpx_p2, 0.0)*max(dpx_p2, 0.0) &
							+ min(dpy_n2, 0.0)*min(dpy_n2, 0.0) &
							+ max(dpy_p2, 0.0)*max(dpy_p2, 0.0) &
							+ min(dpz_n2, 0.0)*min(dpz_n2, 0.0) &
							+ max(dpz_p2, 0.0)*max(dpz_p2, 0.0) &
						)
		phi1_(i, j, k) = phi0_(i, j, k) &
											- ( max(phif(i, j, k), 0.0)*dp_p &
												+ min(phif(i, j, k), 0.0)*dp_n )
	end do
	end do
	end do
!$omp end do
!$omp end parallel
end subroutine lsm_update_phi_f

subroutine lsm_update_phi_f_2(phi1_, phi0_, phif, psi, sz, g)
	implicit none
	integer									:: i, j, k
	integer									:: ix, jx, kx
	integer									:: g
	integer, dimension(3)		:: sz
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi1_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi0_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phif
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: psi
	real										:: dpxx_n, dpxx_c, dpxx_p
	real										:: dpyy_n, dpyy_c, dpyy_p
	real										:: dpzz_n, dpzz_c, dpzz_p
	real										:: dpxx_nc, dpxx_pc
	real										:: dpyy_nc, dpyy_pc
	real										:: dpzz_nc, dpzz_pc
	real										:: dpx_p1, dpy_p1, dpz_p1
	real										:: dpx_n1, dpy_n1, dpz_n1
	real										:: dpx_p2, dpy_p2, dpz_p2
	real										:: dpx_n2, dpy_n2, dpz_n2
	real										:: dp_p, dp_n
	real										:: lsm_getminmod
	ix = sz(1)
	jx = sz(2)
	kx = sz(3)
!$omp parallel private(i, j, k) &
!$omp					,private(dpxx_n, dpxx_c, dpxx_p) &
!$omp					,private(dpyy_n, dpyy_c, dpyy_p) &
!$omp					,private(dpzz_n, dpzz_c, dpzz_p) &
!$omp					,private(dpxx_nc, dpxx_pc) &
!$omp					,private(dpyy_nc, dpyy_pc) &
!$omp					,private(dpzz_nc, dpzz_pc) &
!$omp					,private(dpx_p1, dpy_p1, dpz_p1) &
!$omp					,private(dpx_n1, dpy_n1, dpz_n1) &
!$omp					,private(dpx_p2, dpy_p2, dpz_p2) &
!$omp					,private(dpx_n2, dpy_n2, dpz_n2) &
!$omp					,private(dp_p, dp_n)
!$omp do schedule(static, 1)
	do k=1, kx
	do j=1, jx
!ocl nouxsimd
	do i=1, ix
		dpxx_n = phi0_(i+0, j, k) + phi0_(i-2, j, k) - 2.0*phi0_(i-1, j, k)
		dpxx_c = phi0_(i+1, j, k) + phi0_(i-1, j, k) - 2.0*phi0_(i  , j, k)
		dpxx_p = phi0_(i+2, j, k) + phi0_(i-0, j, k) - 2.0*phi0_(i+1, j, k)
		dpyy_n = phi0_(i, j+0, k) + phi0_(i, j-2, k) - 2.0*phi0_(i, j-1, k)
		dpyy_c = phi0_(i, j+1, k) + phi0_(i, j-1, k) - 2.0*phi0_(i, j  , k)
		dpyy_p = phi0_(i, j+2, k) + phi0_(i, j-0, k) - 2.0*phi0_(i, j+1, k)
		dpzz_n = phi0_(i, j, k+0) + phi0_(i, j, k-2) - 2.0*phi0_(i, j, k-1)
		dpzz_c = phi0_(i, j, k+1) + phi0_(i, j, k-1) - 2.0*phi0_(i, j, k  )
		dpzz_p = phi0_(i, j, k+2) + phi0_(i, j, k-0) - 2.0*phi0_(i, j, k+1)
		dpx_n1 = phi0_(i, j, k) - phi0_(i-1, j, k)
		dpy_n1 = phi0_(i, j, k) - phi0_(i, j-1, k)
		dpz_n1 = phi0_(i, j, k) - phi0_(i, j, k-1)
		dpx_p1 = phi0_(i+1, j, k) - phi0_(i, j, k)
		dpy_p1 = phi0_(i, j+1, k) - phi0_(i, j, k)
		dpz_p1 = phi0_(i, j, k+1) - phi0_(i, j, k)
		dpx_n2 = dpx_n1 + 0.5*lsm_getminmod(dpxx_c, dpxx_n)
		dpy_n2 = dpy_n1 + 0.5*lsm_getminmod(dpyy_c, dpyy_n)
		dpz_n2 = dpz_n1 + 0.5*lsm_getminmod(dpzz_c, dpzz_n)
		dpx_p2 = dpx_p1 - 0.5*lsm_getminmod(dpxx_c, dpxx_p)
		dpy_p2 = dpy_p1 - 0.5*lsm_getminmod(dpyy_c, dpyy_p)
		dpz_p2 = dpz_p1 - 0.5*lsm_getminmod(dpzz_c, dpzz_p)

		if( psi(i+1, j, k) >= 0 ) then
			dpx_p2 = dpx_n2
		endif
		if( psi(i-1, j, k) >= 0 ) then
			dpx_n2 = dpx_p2
		endif
		if( psi(i, j+1, k) >= 0 ) then
			dpy_p2 = dpy_n2
		endif
		if( psi(i, j-1, k) >= 0 ) then
			dpy_n2 = dpy_p2
		endif
		if( psi(i, j, k+1) >= 0 ) then
			dpz_p2 = dpz_n2
		endif
		if( psi(i, j, k-1) >= 0 ) then
			dpz_n2 = dpz_p2
		endif

		dp_p = sqrt( &
								max(dpx_n2, 0.0)*max(dpx_n2, 0.0) &
							+ min(dpx_p2, 0.0)*min(dpx_p2, 0.0) &
							+ max(dpy_n2, 0.0)*max(dpy_n2, 0.0) &
							+ min(dpy_p2, 0.0)*min(dpy_p2, 0.0) &
							+ max(dpz_n2, 0.0)*max(dpz_n2, 0.0) &
							+ min(dpz_p2, 0.0)*min(dpz_p2, 0.0) &
						)
		dp_n = sqrt( &
								min(dpx_n2, 0.0)*min(dpx_n2, 0.0) &
							+ max(dpx_p2, 0.0)*max(dpx_p2, 0.0) &
							+ min(dpy_n2, 0.0)*min(dpy_n2, 0.0) &
							+ max(dpy_p2, 0.0)*max(dpy_p2, 0.0) &
							+ min(dpz_n2, 0.0)*min(dpz_n2, 0.0) &
							+ max(dpz_p2, 0.0)*max(dpz_p2, 0.0) &
						)
		phi1_(i, j, k) = phi0_(i, j, k) &
											- ( max(phif(i, j, k), 0.0)*dp_p &
												+ min(phif(i, j, k), 0.0)*dp_n )
	end do
	end do
	end do
!$omp end do
!$omp end parallel
end subroutine lsm_update_phi_f_2

subroutine lsm_calc_signeddistance(d, phi, sz, g)
	implicit none
	integer									:: i, j, k
	integer									:: ix, jx, kx
	integer									:: g
	integer, dimension(3)		:: sz
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: d
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi
	real										:: dpx_p1, dpy_p1, dpz_p1
	real										:: dpx_n1, dpy_n1, dpz_n1
	real										:: dpx_p, dpy_p, dpz_p
	real										:: dpx_c, dpy_c, dpz_c
	real										:: dpx_n, dpy_n, dpz_n
	real										:: dphi1, dphi2, dphi3, dphi4, dphi5, dphi6, dphi7, dphi
	real										:: lsm_getsign
	ix = sz(1)
	jx = sz(2)
	kx = sz(3)
!$omp parallel private(i, j, k) &
!$omp					,private(dpx_p1, dpy_p1, dpz_p1) &
!$omp					,private(dpx_n1, dpy_n1, dpz_n1) &
!$omp					,private(dpx_p, dpy_p, dpz_p) &
!$omp					,private(dpx_c, dpy_c, dpz_c) &
!$omp					,private(dpx_n, dpy_n, dpz_n) &
!$omp					,private(dphi1, dphi2, dphi3, dphi4, dphi5, dphi6, dphi7, dphi)
!$omp do schedule(static, 1)
	do k=1, kx
	do j=1, jx
!ocl nouxsimd
	do i=1, ix
		dpx_p1 = phi(i+1, j, k) - phi(i  , j, k)
		dpx_n1 = phi(i  , j, k) - phi(i-1, j, k)
		dpy_p1 = phi(i, j+1, k) - phi(i, j  , k)
		dpy_n1 = phi(i, j  , k) - phi(i, j-1, k)
		dpz_p1 = phi(i, j, k+1) - phi(i, j, k  )
		dpz_n1 = phi(i, j, k  ) - phi(i, j, k-1)

		dpx_c = 0.0
		dpx_c = 0.0
		dpy_c = 0.0
		dpy_c = 0.0
		dpz_c = 0.0
		dpz_c = 0.0
		if( phi(i, j, k)*phi(i+1, j, k) < 0 ) then
			dpx_c = phi(i+1, j, k) - phi(i  , j, k)
		end if
		if( phi(i, j, k)*phi(i-1, j, k) < 0 ) then
			dpx_c = phi(i  , j, k) - phi(i-1, j, k)
		end if
		if( phi(i, j, k)*phi(i, j+1, k) < 0 ) then
			dpy_c = phi(i, j+1, k) - phi(i, j  , k)
		end if
		if( phi(i, j, k)*phi(i, j-1, k) < 0 ) then
			dpy_c = phi(i, j  , k) - phi(i, j-1, k)
		end if
		if( phi(i, j, k)*phi(i, j, k+1) < 0 ) then
			dpz_c = phi(i, j, k+1) - phi(i, j, k  )
		end if
		if( phi(i, j, k)*phi(i, j, k-1) < 0 ) then
			dpz_c = phi(i, j, k  ) - phi(i, j, k-1)
		end if

		if( phi(i, j, k)*phi(i+1, j, k) < 0 .and. phi(i, j, k)*phi(i-1, j, k) < 0 ) then
			dpx_c = 0.5*(phi(i+1, j, k) - phi(i-1, j, k))
		end if
		if( phi(i, j, k)*phi(i, j+1, k) < 0 .and. phi(i, j, k)*phi(i, j-1, k) < 0 ) then
			dpy_c = 0.5*(phi(i, j+1, k) - phi(i, j-1, k))
		end if
		if( phi(i, j, k)*phi(i, j, k+1) < 0 .and. phi(i, j, k)*phi(i, j, k-1) < 0 ) then
			dpz_c = 0.5*(phi(i, j, k+1) - phi(i, j, k-1))
		end if

		dpx_p = dpx_p1
		dpx_n = dpx_n1
		dpy_p = dpy_p1
		dpy_n = dpy_n1
		dpz_p = dpz_p1
		dpz_n = dpz_n1

!		dpx_c = 0.5*(dpx_p1 + dpx_n1)
!		dpy_c = 0.5*(dpy_p1 + dpy_n1)
!		dpz_c = 0.5*(dpz_p1 + dpz_n1)

		dphi1 = max(abs(dpx_p), abs(dpx_n))
		dphi2 = max(abs(dpy_p), abs(dpy_n))
		dphi3 = max(abs(dpz_p), abs(dpz_n))
		dphi4 = max(dphi1, abs(dpx_c))
		dphi5 = max(dphi2, abs(dpy_c))
		dphi6 = max(dphi3, abs(dpz_c))
		dphi7 = sqrt(dpx_c*dpx_c + dpy_c*dpy_c + dpz_c*dpz_c)
		dphi1 = max(dphi4, dphi5)
		dphi2 = max(dphi6, dphi7)
		dphi3 = max(dphi1, dphi2)
		dphi = max(dphi7, 1.0)

		d(i, j, k) = phi(i, j, k)
		d(i, j, k) = phi(i, j, k)/(dphi7 + 1.0e-6)
		d(i, j, k) = phi(i, j, k)/dphi
	end do
	end do
	end do
!$omp end do
!$omp end parallel
end subroutine lsm_calc_signeddistance

subroutine lsm_calc_signeddistance2(d, phi, cid, sz, g)
	implicit none
	integer									:: i, j, k
	integer									:: ix, jx, kx
	integer									:: g
	integer, dimension(3)		:: sz
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: d
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: cid
	real										:: dpx_p1, dpy_p1, dpz_p1
	real										:: dpx_n1, dpy_n1, dpz_n1
	real										:: dpx_p, dpy_p, dpz_p
	real										:: dpx_c, dpy_c, dpz_c
	real										:: dpx_n, dpy_n, dpz_n
	real										:: dphi1, dphi2, dphi3, dphi4, dphi5, dphi6, dphi7, dphi
	real										:: lsm_getsign
	ix = sz(1)
	jx = sz(2)
	kx = sz(3)
!$omp parallel private(i, j, k) &
!$omp					,private(dpx_p1, dpy_p1, dpz_p1) &
!$omp					,private(dpx_n1, dpy_n1, dpz_n1) &
!$omp					,private(dpx_p, dpy_p, dpz_p) &
!$omp					,private(dpx_c, dpy_c, dpz_c) &
!$omp					,private(dpx_n, dpy_n, dpz_n) &
!$omp					,private(dphi1, dphi2, dphi3, dphi4, dphi5, dphi6, dphi7, dphi)
!$omp do schedule(dynamic, 1)
	do k=1, kx
	do j=1, jx
!ocl nouxsimd
	do i=1, ix
		cid(i, j, k) = -1.0

		if( phi(i, j, k)*phi(i+1, j, k) < 0 .or. &
				phi(i, j, k)*phi(i-1, j, k) < 0 .or. &
				phi(i, j, k)*phi(i, j+1, k) < 0 .or. &
				phi(i, j, k)*phi(i, j-1, k) < 0 .or. &
				phi(i, j, k)*phi(i, j, k+1) < 0 .or. &
				phi(i, j, k)*phi(i, j, k-1) < 0 ) then
			cid(i, j, k) = 1.0
		end if
	end do
	end do
	end do
!$omp end do

!$omp do schedule(dynamic, 1)
	do k=1, kx
	do j=1, jx
!ocl nouxsimd
	do i=1, ix
		d(i, j, k) = 0.0

		if( cid(i, j, k) < 0 ) then
			cycle
		end if

		dpx_c = 0.0
		dpx_c = 0.0
		dpy_c = 0.0
		dpy_c = 0.0
		dpz_c = 0.0
		dpz_c = 0.0
		if( cid(i+1, j, k) > 0 ) then
			dpx_c = phi(i+1, j, k) - phi(i  , j, k)
		end if
		if( cid(i-1, j, k) > 0 ) then
			dpx_c = phi(i  , j, k) - phi(i-1, j, k)
		end if
		if( cid(i, j+1, k) > 0 ) then
			dpy_c = phi(i, j+1, k) - phi(i, j  , k)
		end if
		if( cid(i, j-1, k) > 0 ) then
			dpy_c = phi(i, j  , k) - phi(i, j-1, k)
		end if
		if( cid(i, j, k+1) > 0 ) then
			dpz_c = phi(i, j, k+1) - phi(i, j, k  )
		end if
		if( cid(i, j, k-1) > 0 ) then
			dpz_c = phi(i, j, k  ) - phi(i, j, k-1)
		end if

		if( cid(i+1, j, k) > 0 .and. cid(i-1, j, k) > 0 ) then
			dpx_c = 0.5*(phi(i+1, j, k) - phi(i-1, j, k))
		end if
		if( cid(i, j+1, k) > 0 .and. cid(i, j-1, k) > 0 ) then
			dpy_c = 0.5*(phi(i, j+1, k) - phi(i, j-1, k))
		end if
		if( cid(i, j, k+1) > 0 .and. cid(i, j, k-1) > 0 ) then
			dpz_c = 0.5*(phi(i, j, k+1) - phi(i, j, k-1))
		end if

		dphi7 = sqrt(dpx_c*dpx_c + dpy_c*dpy_c + dpz_c*dpz_c)
		dphi4 = max(dphi7, abs(dpx_c))
		dphi5 = max(dphi7, abs(dpy_c))
		dphi6 = max(dphi7, abs(dpz_c))
		dphi1 = max(dphi4, dphi5)
		dphi2 = max(dphi1, dphi6)
		dphi3 = max(dphi2, dphi7)
		dphi = max(dphi3, 1.0)

		dphi7 = sqrt(dpx_c*dpx_c + dpy_c*dpy_c + dpz_c*dpz_c)
		dphi = min(dphi7, 1.0)
		dphi = max(dphi7, 1.0)

		d(i, j, k) = phi(i, j, k)/dphi
	end do
	end do
	end do
!$omp end do
!$omp end parallel
end subroutine lsm_calc_signeddistance2

subroutine lsm_reinit_core(phi1_, phi0_, dtau, phii_, phid_, psi, sz, g)
	implicit none
	integer									:: i, j, k
	integer									:: ix, jx, kx
	integer									:: g
	integer, dimension(3)		:: sz
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi1_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi0_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phii_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phid_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: psi
	real										:: dtau
	real										:: dpxx_p, dpyy_p, dpzz_p
	real										:: dpxx_n, dpyy_n, dpzz_n
	real										:: dpxx_c, dpyy_c, dpzz_c
	real										:: dpx_p1, dpy_p1, dpz_p1
	real										:: dpx_n1, dpy_n1, dpz_n1
	real										:: dpx_p2, dpy_p2, dpz_p2
	real										:: dpx_n2, dpy_n2, dpz_n2
	real										:: dpx_p_max2, dpy_p_max2, dpz_p_max2
	real										:: dpx_n_max2, dpy_n_max2, dpz_n_max2
	real										:: dpx_p_min2, dpy_p_min2, dpz_p_min2
	real										:: dpx_n_min2, dpy_n_min2, dpz_n_min2
	real										:: dp_p, dp_n
	real										:: dpl
	real										:: phis
	real										:: lsm_getsign
	real										:: lsm_getminmod
	ix = sz(1)
	jx = sz(2)
	kx = sz(3)
!$omp parallel private(i, j, k) &
!$omp					,private(dpxx_p, dpyy_p, dpzz_p) &
!$omp					,private(dpxx_n, dpyy_n, dpzz_n) &
!$omp					,private(dpxx_c, dpyy_c, dpzz_c) &
!$omp					,private(dpx_p1, dpy_p1, dpz_p1) &
!$omp					,private(dpx_n1, dpy_n1, dpz_n1) &
!$omp					,private(dpx_p2, dpy_p2, dpz_p2) &
!$omp					,private(dpx_n2, dpy_n2, dpz_n2) &
!$omp					,private(dpx_p_max2, dpy_p_max2, dpz_p_max2) &
!$omp					,private(dpx_n_max2, dpy_n_max2, dpz_n_max2) &
!$omp					,private(dpx_p_min2, dpy_p_min2, dpz_p_min2) &
!$omp					,private(dpx_n_min2, dpy_n_min2, dpz_n_min2) &
!$omp					,private(dp_p, dp_n) &
!$omp					,private(dpl) &
!$omp					,private(phis)
!$omp do schedule(static, 1)
	do k=1, kx
	do j=1, jx
	do i=1, ix
!		if( psi(i, j, k) >= 0 ) then
!			phi1_(i, j, k) = phi0_(i, j, k)
!			cycle
!		endif

		dpx_n1 = phi0_(i, j, k) - phi0_(i-1, j, k)
		dpy_n1 = phi0_(i, j, k) - phi0_(i, j-1, k)
		dpz_n1 = phi0_(i, j, k) - phi0_(i, j, k-1)
		dpx_p1 = phi0_(i+1, j, k) - phi0_(i, j, k)
		dpy_p1 = phi0_(i, j+1, k) - phi0_(i, j, k)
		dpz_p1 = phi0_(i, j, k+1) - phi0_(i, j, k)
		dpxx_n = phi0_(i+0, j, k) + phi0_(i-2, j, k) - 2.0*phi0_(i-1, j, k)
		dpxx_c = phi0_(i+1, j, k) + phi0_(i-1, j, k) - 2.0*phi0_(i  , j, k)
		dpxx_p = phi0_(i+2, j, k) + phi0_(i-0, j, k) - 2.0*phi0_(i+1, j, k)
		dpyy_n = phi0_(i, j+0, k) + phi0_(i, j-2, k) - 2.0*phi0_(i, j-1, k)
		dpyy_c = phi0_(i, j+1, k) + phi0_(i, j-1, k) - 2.0*phi0_(i, j  , k)
		dpyy_p = phi0_(i, j+2, k) + phi0_(i, j-0, k) - 2.0*phi0_(i, j+1, k)
		dpzz_n = phi0_(i, j, k+0) + phi0_(i, j, k-2) - 2.0*phi0_(i, j, k-1)
		dpzz_c = phi0_(i, j, k+1) + phi0_(i, j, k-1) - 2.0*phi0_(i, j, k  )
		dpzz_p = phi0_(i, j, k+2) + phi0_(i, j, k-0) - 2.0*phi0_(i, j, k+1)
		dpx_n2 = dpx_n1 + 0.5*lsm_getminmod(dpxx_c, dpxx_n)
		dpy_n2 = dpy_n1 + 0.5*lsm_getminmod(dpyy_c, dpyy_n)
		dpz_n2 = dpz_n1 + 0.5*lsm_getminmod(dpzz_c, dpzz_n)
		dpx_p2 = dpx_p1 - 0.5*lsm_getminmod(dpxx_c, dpxx_p)
		dpy_p2 = dpy_p1 - 0.5*lsm_getminmod(dpyy_c, dpyy_p)
		dpz_p2 = dpz_p1 - 0.5*lsm_getminmod(dpzz_c, dpzz_p)

		dpx_n_max2 = max(dpx_n2, 0.0)*max(dpx_n2, 0.0)
		dpx_n_min2 = min(dpx_n2, 0.0)*min(dpx_n2, 0.0)
		dpx_p_max2 = max(dpx_p2, 0.0)*max(dpx_p2, 0.0)
		dpx_p_min2 = min(dpx_p2, 0.0)*min(dpx_p2, 0.0)
		dpy_n_max2 = max(dpy_n2, 0.0)*max(dpy_n2, 0.0)
		dpy_n_min2 = min(dpy_n2, 0.0)*min(dpy_n2, 0.0)
		dpy_p_max2 = max(dpy_p2, 0.0)*max(dpy_p2, 0.0)
		dpy_p_min2 = min(dpy_p2, 0.0)*min(dpy_p2, 0.0)
		dpz_n_max2 = max(dpz_n2, 0.0)*max(dpz_n2, 0.0)
		dpz_n_min2 = min(dpz_n2, 0.0)*min(dpz_n2, 0.0)
		dpz_p_max2 = max(dpz_p2, 0.0)*max(dpz_p2, 0.0)
		dpz_p_min2 = min(dpz_p2, 0.0)*min(dpz_p2, 0.0)

		dpx_p2 = max(dpx_n_max2, dpx_p_min2)
		dpy_p2 = max(dpy_n_max2, dpy_p_min2)
		dpz_p2 = max(dpz_n_max2, dpz_p_min2)
		dpx_n2 = max(dpx_n_min2, dpx_p_max2)
		dpy_n2 = max(dpy_n_min2, dpy_p_max2)
		dpz_n2 = max(dpz_n_min2, dpz_p_max2)

		dp_p = sqrt(dpx_p2 + dpy_p2 + dpz_p2)
		dp_n = sqrt(dpx_n2 + dpy_n2 + dpz_n2)

		phis = lsm_getsign( phii_(i, j, k) )

		if( phis > 0.0 ) then
			dpl = dp_p
		else if( phis < 0.0 ) then
			dpl = dp_n
		else
			dpl = 1.0
		end if

		if( phii_(i, j, k)*phii_(i+1, j, k) < 0 .or. &
				phii_(i, j, k)*phii_(i-1, j, k) < 0 .or. &
				phii_(i, j, k)*phii_(i, j+1, k) < 0 .or. &
				phii_(i, j, k)*phii_(i, j-1, k) < 0 .or. &
				phii_(i, j, k)*phii_(i, j, k+1) < 0 .or. &
				phii_(i, j, k)*phii_(i, j, k-1) < 0 ) then
			phi1_(i, j, k) = phid_(i, j, k)
		else
			phi1_(i, j, k) = phi0_(i, j, k) - phis*(dpl - 1.0)*dtau
		endif
	end do
	end do
	end do
!$omp end do
!$omp end parallel
end subroutine lsm_reinit_core

subroutine lsm_reinit_s_core(phi1_, phi0_, dtau, psi, psinx, psiny, psinz, thetas, sz, g)
	implicit none
	integer									:: i, j, k
	integer									:: ix, jx, kx
	integer									:: g
	integer, dimension(3)		:: sz
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi1_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi0_
	real										:: dtau
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: psi
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: psinx, psiny, psinz
	real										:: thetas
	real										:: wx, wy, wz
	real										:: dpxx_p, dpyy_p, dpzz_p
	real										:: dpxx_n, dpyy_n, dpzz_n
	real										:: dpxx_c, dpyy_c, dpzz_c
	real										:: dpx_p1, dpy_p1, dpz_p1
	real										:: dpx_n1, dpy_n1, dpz_n1
	real										:: dpx_p2, dpy_p2, dpz_p2
	real										:: dpx_n2, dpy_n2, dpz_n2
	real										:: dpx_p, dpy_p, dpz_p
	real										:: dpx_n, dpy_n, dpz_n
	real										:: dpx, dpy, dpz
	real										:: dpl
	real										:: lsm_getupwind2
	real										:: lsm_getupwind1
	real										:: lsm_getupwind
	real										:: lsm_getweno3
	real										:: lsm_getminmod
	ix = sz(1)
	jx = sz(2)
	kx = sz(3)
!$omp parallel private(i, j, k) &
!$omp					,private(wx, wy, wz) &
!$omp					,private(dpxx_p, dpyy_p, dpzz_p) &
!$omp					,private(dpxx_n, dpyy_n, dpzz_n) &
!$omp					,private(dpxx_c, dpyy_c, dpzz_c) &
!$omp					,private(dpx_p1, dpy_p1, dpz_p1) &
!$omp					,private(dpx_n1, dpy_n1, dpz_n1) &
!$omp					,private(dpx_p2, dpy_p2, dpz_p2) &
!$omp					,private(dpx_n2, dpy_n2, dpz_n2) &
!$omp					,private(dpx_p, dpy_p, dpz_p) &
!$omp					,private(dpx_n, dpy_n, dpz_n) &
!$omp					,private(dpx, dpy, dpz) &
!$omp					,private(dpl)
!$omp do schedule(static, 1)
	do k=1, kx
	do j=1, jx
	do i=1, ix
		if( psi(i, j, k) < 0 ) then
			phi1_(i, j, k) = phi0_(i, j, k)
			cycle
		endif

		if( abs(psi(i, j, k)) > 4.0*sqrt(3.0) ) then
!			cycle
		endif

		if( abs(phi0_(i, j, k)) > 4.0*sqrt(3.0) ) then
!			cycle
		endif

		wx = psinx(i, j, k)
		wy = psiny(i, j, k)
		wz = psinz(i, j, k)

		dpx_n1 = phi0_(i, j, k) - phi0_(i-1, j, k)
		dpy_n1 = phi0_(i, j, k) - phi0_(i, j-1, k)
		dpz_n1 = phi0_(i, j, k) - phi0_(i, j, k-1)
		dpx_p1 = phi0_(i+1, j, k) - phi0_(i, j, k)
		dpy_p1 = phi0_(i, j+1, k) - phi0_(i, j, k)
		dpz_p1 = phi0_(i, j, k+1) - phi0_(i, j, k)
		dpxx_n = phi0_(i+0, j, k) + phi0_(i-2, j, k) - 2.0*phi0_(i-1, j, k)
		dpxx_c = phi0_(i+1, j, k) + phi0_(i-1, j, k) - 2.0*phi0_(i  , j, k)
		dpxx_p = phi0_(i+2, j, k) + phi0_(i-0, j, k) - 2.0*phi0_(i+1, j, k)
		dpyy_n = phi0_(i, j+0, k) + phi0_(i, j-2, k) - 2.0*phi0_(i, j-1, k)
		dpyy_c = phi0_(i, j+1, k) + phi0_(i, j-1, k) - 2.0*phi0_(i, j  , k)
		dpyy_p = phi0_(i, j+2, k) + phi0_(i, j-0, k) - 2.0*phi0_(i, j+1, k)
		dpzz_n = phi0_(i, j, k+0) + phi0_(i, j, k-2) - 2.0*phi0_(i, j, k-1)
		dpzz_c = phi0_(i, j, k+1) + phi0_(i, j, k-1) - 2.0*phi0_(i, j, k  )
		dpzz_p = phi0_(i, j, k+2) + phi0_(i, j, k-0) - 2.0*phi0_(i, j, k+1)
		dpx_n2 = dpx_n1 + 0.5*lsm_getminmod(dpxx_c, dpxx_n)
		dpy_n2 = dpy_n1 + 0.5*lsm_getminmod(dpyy_c, dpyy_n)
		dpz_n2 = dpz_n1 + 0.5*lsm_getminmod(dpzz_c, dpzz_n)
		dpx_p2 = dpx_p1 - 0.5*lsm_getminmod(dpxx_c, dpxx_p)
		dpy_p2 = dpy_p1 - 0.5*lsm_getminmod(dpyy_c, dpyy_p)
		dpz_p2 = dpz_p1 - 0.5*lsm_getminmod(dpzz_c, dpzz_p)
		dpx_p = dpx_p2
		dpx_n = dpx_n2
		dpy_p = dpy_p2
		dpy_n = dpy_n2
		dpz_p = dpz_p2
		dpz_n = dpz_n2

		phi1_(i, j, k) = phi0_(i, j, k) -( &
																			+ (max(wx, 0.0)*dpx_n + min(wx, 0.0)*dpx_p) &
																			+ (max(wy, 0.0)*dpy_n + min(wy, 0.0)*dpy_p) &
																			+ (max(wz, 0.0)*dpz_n + min(wz, 0.0)*dpz_p) - cos(thetas) )*dtau
	end do
	end do
	end do
!$omp end do
!$omp end parallel
end subroutine lsm_reinit_s_core

subroutine lsm_reinit_core_0(phi1_, phi0_, dtau, phii_, phid_, sz, g)
	implicit none
	integer									:: i, j, k
	integer									:: ix, jx, kx
	integer									:: g
	integer, dimension(3)		:: sz
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi1_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi0_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phii_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phid_
	real										:: dtau
	real										:: dpx_p1, dpy_p1, dpz_p1
	real										:: dpx_n1, dpy_n1, dpz_n1
	real										:: dpx_p_max2, dpy_p_max2, dpz_p_max2
	real										:: dpx_n_max2, dpy_n_max2, dpz_n_max2
	real										:: dpx_p_min2, dpy_p_min2, dpz_p_min2
	real										:: dpx_n_min2, dpy_n_min2, dpz_n_min2
	real										:: dpx_p2, dpy_p2, dpz_p2
	real										:: dpx_n2, dpy_n2, dpz_n2
	real										:: dp_p, dp_n
	real										:: dpl
	real										:: phis
	ix = sz(1)
	jx = sz(2)
	kx = sz(3)
!$omp parallel private(i, j, k) &
!$omp					,private(dpx_p1, dpy_p1, dpz_p1) &
!$omp					,private(dpx_n1, dpy_n1, dpz_n1) &
!$omp					,private(dpx_p_max2, dpy_p_max2, dpz_p_max2) &
!$omp					,private(dpx_n_max2, dpy_n_max2, dpz_n_max2) &
!$omp					,private(dpx_p_min2, dpy_p_min2, dpz_p_min2) &
!$omp					,private(dpx_n_min2, dpy_n_min2, dpz_n_min2) &
!$omp					,private(dpx_p2, dpy_p2, dpz_p2) &
!$omp					,private(dpx_n2, dpy_n2, dpz_n2) &
!$omp					,private(dp_p, dp_n) &
!$omp					,private(dpl) &
!$omp					,private(phis)
!$omp do schedule(static, 1)
	do k=1, kx
	do j=1, jx
	do i=1, ix
		dpx_p1 = phi0_(i+1, j, k) - phi0_(i  , j, k)
		dpx_n1 = phi0_(i  , j, k) - phi0_(i-1, j, k)
		dpy_p1 = phi0_(i, j+1, k) - phi0_(i, j  , k)
		dpy_n1 = phi0_(i, j  , k) - phi0_(i, j-1, k)
		dpz_p1 = phi0_(i, j, k+1) - phi0_(i, j, k  )
		dpz_n1 = phi0_(i, j, k  ) - phi0_(i, j, k-1)

		dpx_n_max2 = max(dpx_n1, 0.0)*max(dpx_n1, 0.0)
		dpx_n_min2 = min(dpx_n1, 0.0)*min(dpx_n1, 0.0)
		dpx_p_max2 = max(dpx_p1, 0.0)*max(dpx_p1, 0.0)
		dpx_p_min2 = min(dpx_p1, 0.0)*min(dpx_p1, 0.0)
		dpy_n_max2 = max(dpy_n1, 0.0)*max(dpy_n1, 0.0)
		dpy_n_min2 = min(dpy_n1, 0.0)*min(dpy_n1, 0.0)
		dpy_p_max2 = max(dpy_p1, 0.0)*max(dpy_p1, 0.0)
		dpy_p_min2 = min(dpy_p1, 0.0)*min(dpy_p1, 0.0)
		dpz_n_max2 = max(dpz_n1, 0.0)*max(dpz_n1, 0.0)
		dpz_n_min2 = min(dpz_n1, 0.0)*min(dpz_n1, 0.0)
		dpz_p_max2 = max(dpz_p1, 0.0)*max(dpz_p1, 0.0)
		dpz_p_min2 = min(dpz_p1, 0.0)*min(dpz_p1, 0.0)

		dpx_p2 = max(dpx_n_max2, dpx_p_min2)
		dpy_p2 = max(dpy_n_max2, dpy_p_min2)
		dpz_p2 = max(dpz_n_max2, dpz_p_min2)
		dpx_n2 = max(dpx_n_min2, dpx_p_max2)
		dpy_n2 = max(dpy_n_min2, dpy_p_max2)
		dpz_n2 = max(dpz_n_min2, dpz_p_max2)

		dp_p = sqrt(dpx_p2 + dpy_p2 + dpz_p2)
		dp_n = sqrt(dpx_n2 + dpy_n2 + dpz_n2)

		if(phii_(i, j, k) > 0.0) then
			dpl = dp_p
		else if(phii_(i, j, k) < 0.0) then
			dpl = dp_n
		else
			dpl = 1.0
		endif

		if(phii_(i, j, k) > 0.0) then
			phis = 1.0
		else if(phii_(i, j, k) < 0.0) then
			phis = -1.0
		else
			phis = 0.0
		endif

		if( phii_(i, j, k)*phii_(i+1, j, k) < 0 .or. &
				phii_(i, j, k)*phii_(i-1, j, k) < 0 .or. &
				phii_(i, j, k)*phii_(i, j+1, k) < 0 .or. &
				phii_(i, j, k)*phii_(i, j-1, k) < 0 .or. &
				phii_(i, j, k)*phii_(i, j, k+1) < 0 .or. &
				phii_(i, j, k)*phii_(i, j, k-1) < 0 ) then
			phi1_(i, j, k) = phi0_(i, j, k)*(1.0 - dtau) + phid_(i, j, k)*dtau
		else
			phi1_(i, j, k) = phi0_(i, j, k) - phis*(dpl - 1.0)*dtau
		endif
	end do
	end do
	end do
!$omp end do
!$omp end parallel
end subroutine lsm_reinit_core_0

subroutine lsm_smooth_core(phi1_, phi0_, dtau, sz, g)
	implicit none
	integer									:: i, j, k
	integer									:: ix, jx, kx
	integer									:: g
	integer, dimension(3)		:: sz
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi1_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi0_
	real										:: dtau
	real										:: dpx_p1, dpy_p1, dpz_p1
	real										:: dpx_n1, dpy_n1, dpz_n1
	real										:: dpx_p_max2, dpy_p_max2, dpz_p_max2
	real										:: dpx_n_max2, dpy_n_max2, dpz_n_max2
	real										:: dpx_p_min2, dpy_p_min2, dpz_p_min2
	real										:: dpx_n_min2, dpy_n_min2, dpz_n_min2
	real										:: dpx_p2, dpy_p2, dpz_p2
	real										:: dpx_n2, dpy_n2, dpz_n2
	real										:: dp_p, dp_n
	real										:: dpl
	real										:: phis
	ix = sz(1)
	jx = sz(2)
	kx = sz(3)
!$omp parallel private(i, j, k) &
!$omp					,private(dpx_p1, dpy_p1, dpz_p1) &
!$omp					,private(dpx_n1, dpy_n1, dpz_n1) &
!$omp					,private(dpx_p_max2, dpy_p_max2, dpz_p_max2) &
!$omp					,private(dpx_n_max2, dpy_n_max2, dpz_n_max2) &
!$omp					,private(dpx_p_min2, dpy_p_min2, dpz_p_min2) &
!$omp					,private(dpx_n_min2, dpy_n_min2, dpz_n_min2) &
!$omp					,private(dpx_p2, dpy_p2, dpz_p2) &
!$omp					,private(dpx_n2, dpy_n2, dpz_n2) &
!$omp					,private(dp_p, dp_n) &
!$omp					,private(dpl) &
!$omp					,private(phis)
!$omp do schedule(static, 1)
	do k=1, kx
	do j=1, jx
	do i=1, ix
		dpx_p1 = phi0_(i+1, j, k) - phi0_(i  , j, k)
		dpx_n1 = phi0_(i  , j, k) - phi0_(i-1, j, k)
		dpy_p1 = phi0_(i, j+1, k) - phi0_(i, j  , k)
		dpy_n1 = phi0_(i, j  , k) - phi0_(i, j-1, k)
		dpz_p1 = phi0_(i, j, k+1) - phi0_(i, j, k  )
		dpz_n1 = phi0_(i, j, k  ) - phi0_(i, j, k-1)

		dpx_n_max2 = max(dpx_n1, 0.0)*max(dpx_n1, 0.0)
		dpx_n_min2 = min(dpx_n1, 0.0)*min(dpx_n1, 0.0)
		dpx_p_max2 = max(dpx_p1, 0.0)*max(dpx_p1, 0.0)
		dpx_p_min2 = min(dpx_p1, 0.0)*min(dpx_p1, 0.0)
		dpy_n_max2 = max(dpy_n1, 0.0)*max(dpy_n1, 0.0)
		dpy_n_min2 = min(dpy_n1, 0.0)*min(dpy_n1, 0.0)
		dpy_p_max2 = max(dpy_p1, 0.0)*max(dpy_p1, 0.0)
		dpy_p_min2 = min(dpy_p1, 0.0)*min(dpy_p1, 0.0)
		dpz_n_max2 = max(dpz_n1, 0.0)*max(dpz_n1, 0.0)
		dpz_n_min2 = min(dpz_n1, 0.0)*min(dpz_n1, 0.0)
		dpz_p_max2 = max(dpz_p1, 0.0)*max(dpz_p1, 0.0)
		dpz_p_min2 = min(dpz_p1, 0.0)*min(dpz_p1, 0.0)

		dpx_p2 = max(dpx_n_max2, dpx_p_min2)
		dpx_n2 = max(dpx_n_min2, dpx_p_max2)
		dpy_p2 = max(dpy_n_max2, dpy_p_min2)
		dpy_n2 = max(dpy_n_min2, dpy_p_max2)
		dpz_p2 = max(dpz_n_max2, dpz_p_min2)
		dpz_n2 = max(dpz_n_min2, dpz_p_max2)

		dp_p = sqrt(dpx_p2 + dpy_p2 + dpz_p2)
		dp_n = sqrt(dpx_n2 + dpy_n2 + dpz_n2)

		if(phi0_(i, j, k) > 0.0) then
			dpl = dp_p
			phis = 1.0
		else if(phi0_(i, j, k) < 0.0) then
			dpl = dp_n
			phis = -1.0
		else
			dpl = 1.0
			phis = 0.0
		endif

		phi1_(i, j, k) = phi0_(i, j, k) - phis*(dpl - 1.0)*dtau
	end do
	end do
	end do
!$omp end do
!$omp end parallel
end subroutine lsm_smooth_core

subroutine lsm_extend_core(data1_, data0_, dtau, phi, nx, ny, nz, psi, sz, g)
	implicit none
	integer									:: i, j, k
	integer									:: ix, jx, kx
	integer									:: g
	integer, dimension(3)		:: sz
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: data1_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: data0_
	real										:: dtau
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: phi
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: nx, ny, nz
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: psi
	real										:: s
	real										:: wx, wy, wz
	real										:: ddx_p1, ddy_p1, ddz_p1
	real										:: ddx_n1, ddy_n1, ddz_n1
	real										:: ddx_p2, ddy_p2, ddz_p2
	real										:: ddx_n2, ddy_n2, ddz_n2
	real										:: ddxx_n, ddxx_c, ddxx_p
	real										:: ddyy_n, ddyy_c, ddyy_p
	real										:: ddzz_n, ddzz_c, ddzz_p
	real										:: ddx_p, ddy_p, ddz_p
	real										:: ddx_n, ddy_n, ddz_n
	real										:: lsm_getsign
	real										:: lsm_getminmod
	real										:: lsm_getweno3
	ix = sz(1)
	jx = sz(2)
	kx = sz(3)
!$omp parallel private(i, j, k) &
!$omp					,private(s) &
!$omp					,private(wx, wy, wz) &
!$omp					,private(ddx_p1, ddy_p1, ddz_p1) &
!$omp					,private(ddx_n1, ddy_n1, ddz_n1) &
!$omp					,private(ddx_p2, ddy_p2, ddz_p2) &
!$omp					,private(ddx_n2, ddy_n2, ddz_n2) &
!$omp					,private(ddxx_n, ddxx_c, ddxx_p) &
!$omp					,private(ddyy_n, ddyy_c, ddyy_p) &
!$omp					,private(ddzz_n, ddzz_c, ddzz_p) &
!$omp					,private(ddx_p, ddy_p, ddz_p) &
!$omp					,private(ddx_n, ddy_n, ddz_n)
!$omp do schedule(dynamic, 1)
	do k=1, kx
	do j=1, jx
	do i=1, ix
		if( psi(i, j, k) >= 0 ) then
			data1_(i, j, k) = data0_(i, j, k)
			cycle
		endif

		if( abs(phi(i, j, k)) > 4.0 ) then
!			cycle
		endif

		s  = lsm_getsign( phi(i, j, k) )
		wx = nx(i, j, k)*s
		wy = ny(i, j, k)*s
		wz = nz(i, j, k)*s

		ddx_p1 = data0_(i+1, j, k) - data0_(i  , j, k)
		ddx_n1 = data0_(i  , j, k) - data0_(i-1, j, k)
		ddy_p1 = data0_(i, j+1, k) - data0_(i, j  , k)
		ddy_n1 = data0_(i, j  , k) - data0_(i, j-1, k)
		ddz_p1 = data0_(i, j, k+1) - data0_(i, j, k  )
		ddz_n1 = data0_(i, j, k  ) - data0_(i, j, k-1)
		ddxx_p = data0_(i+2, j, k) + data0_(i  , j, k) - 2.0*data0_(i+1, j, k)
		ddxx_c = data0_(i+1, j, k) + data0_(i-1, j, k) - 2.0*data0_(i  , j, k)
		ddxx_n = data0_(i  , j, k) + data0_(i-2, j, k) - 2.0*data0_(i-1, j, k)
		ddyy_p = data0_(i, j+2, k) + data0_(i, j  , k) - 2.0*data0_(i, j+1, k)
		ddyy_c = data0_(i, j+1, k) + data0_(i, j-1, k) - 2.0*data0_(i, j  , k)
		ddyy_n = data0_(i, j  , k) + data0_(i, j-2, k) - 2.0*data0_(i, j-1, k)
		ddzz_p = data0_(i, j, k+2) + data0_(i, j, k  ) - 2.0*data0_(i, j, k+1)
		ddzz_c = data0_(i, j, k+1) + data0_(i, j, k-1) - 2.0*data0_(i, j, k  )
		ddzz_n = data0_(i, j, k  ) + data0_(i, j, k-2) - 2.0*data0_(i, j, k-1)
		ddx_p2 = ddx_p1 - 0.5*lsm_getminmod(ddxx_c, ddxx_p)
		ddx_n2 = ddx_n1 + 0.5*lsm_getminmod(ddxx_c, ddxx_n)
		ddy_p2 = ddy_p1 - 0.5*lsm_getminmod(ddyy_c, ddyy_p)
		ddy_n2 = ddy_n1 + 0.5*lsm_getminmod(ddyy_c, ddyy_n)
		ddz_p2 = ddz_p1 - 0.5*lsm_getminmod(ddzz_c, ddzz_p)
		ddz_n2 = ddz_n1 + 0.5*lsm_getminmod(ddzz_c, ddzz_n)
		ddx_p = ddx_p1
		ddx_n = ddx_n1
		ddy_p = ddy_p1
		ddy_n = ddy_n1
		ddz_p = ddz_p1
		ddz_n = ddz_n1

		if( psi(i+1, j, k) >= 0 ) then
			ddx_p = 0.0
		endif
		if( psi(i-1, j, k) >= 0 ) then
			ddx_n = 0.0
		endif
		if( psi(i, j+1, k) >= 0 ) then
			ddy_p = 0.0
		endif
		if( psi(i, j-1, k) >= 0 ) then
			ddy_n = 0.0
		endif
		if( psi(i, j, k+1) >= 0 ) then
			ddz_p = 0.0
		endif
		if( psi(i, j, k-1) >= 0 ) then
			ddz_n = 0.0
		endif

		data1_(i, j, k) = data0_(i, j, k) -( &
																			+ (max(wx, 0.0)*ddx_n + min(wx, 0.0)*ddx_p) &
																			+ (max(wy, 0.0)*ddy_n + min(wy, 0.0)*ddy_p) &
																			+ (max(wz, 0.0)*ddz_n + min(wz, 0.0)*ddz_p) )*dtau
	end do
	end do
	end do
!$omp end do
!$omp end parallel
end subroutine lsm_extend_core

subroutine lsm_extend_s_core(data1_, data0_, dtau, psi, psinx, psiny, psinz, sz, g)
	implicit none
	integer									:: i, j, k
	integer									:: ix, jx, kx
	integer									:: g
	integer, dimension(3)		:: sz
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: data1_
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: data0_
	real										:: dtau
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: psi
	real, dimension(1-g:sz(1)+g, 1-g:sz(2)+g, 1-g:sz(3)+g)	:: psinx, psiny, psinz
	real										:: s
	real										:: wx, wy, wz
	real										:: ddx_p1, ddy_p1, ddz_p1
	real										:: ddx_n1, ddy_n1, ddz_n1
	real										:: ddx_p2, ddy_p2, ddz_p2
	real										:: ddx_n2, ddy_n2, ddz_n2
	real										:: ddxx_n, ddxx_c, ddxx_p
	real										:: ddyy_n, ddyy_c, ddyy_p
	real										:: ddzz_n, ddzz_c, ddzz_p
	real										:: ddx_p, ddy_p, ddz_p
	real										:: ddx_n, ddy_n, ddz_n
	real										:: lsm_getsign
	real										:: lsm_getminmod
	real										:: lsm_getweno3
	ix = sz(1)
	jx = sz(2)
	kx = sz(3)
!$omp parallel private(i, j, k) &
!$omp					,private(s) &
!$omp					,private(wx, wy, wz) &
!$omp					,private(ddx_p1, ddy_p1, ddz_p1) &
!$omp					,private(ddx_n1, ddy_n1, ddz_n1) &
!$omp					,private(ddx_p2, ddy_p2, ddz_p2) &
!$omp					,private(ddx_n2, ddy_n2, ddz_n2) &
!$omp					,private(ddxx_n, ddxx_c, ddxx_p) &
!$omp					,private(ddyy_n, ddyy_c, ddyy_p) &
!$omp					,private(ddzz_n, ddzz_c, ddzz_p) &
!$omp					,private(ddx_p, ddy_p, ddz_p) &
!$omp					,private(ddx_n, ddy_n, ddz_n)
!$omp do schedule(dynamic, 1)
	do k=1, kx
	do j=1, jx
	do i=1, ix
		if( psi(i, j, k) < 0 ) then
			data1_(i, j, k) = data0_(i, j, k)
			cycle
		endif

		if( abs(psi(i, j, k)) > 8.0 ) then
!			cycle
		endif

		wx = psinx(i, j, k)
		wy = psiny(i, j, k)
		wz = psinz(i, j, k)

		ddx_p1 = data0_(i+1, j, k) - data0_(i  , j, k)
		ddx_n1 = data0_(i  , j, k) - data0_(i-1, j, k)
		ddy_p1 = data0_(i, j+1, k) - data0_(i, j  , k)
		ddy_n1 = data0_(i, j  , k) - data0_(i, j-1, k)
		ddz_p1 = data0_(i, j, k+1) - data0_(i, j, k  )
		ddz_n1 = data0_(i, j, k  ) - data0_(i, j, k-1)
		ddxx_p = data0_(i+2, j, k) + data0_(i  , j, k) - 2.0*data0_(i+1, j, k)
		ddxx_c = data0_(i+1, j, k) + data0_(i-1, j, k) - 2.0*data0_(i  , j, k)
		ddxx_n = data0_(i  , j, k) + data0_(i-2, j, k) - 2.0*data0_(i-1, j, k)
		ddyy_p = data0_(i, j+2, k) + data0_(i, j  , k) - 2.0*data0_(i, j+1, k)
		ddyy_c = data0_(i, j+1, k) + data0_(i, j-1, k) - 2.0*data0_(i, j  , k)
		ddyy_n = data0_(i, j  , k) + data0_(i, j-2, k) - 2.0*data0_(i, j-1, k)
		ddzz_p = data0_(i, j, k+2) + data0_(i, j, k  ) - 2.0*data0_(i, j, k+1)
		ddzz_c = data0_(i, j, k+1) + data0_(i, j, k-1) - 2.0*data0_(i, j, k  )
		ddzz_n = data0_(i, j, k  ) + data0_(i, j, k-2) - 2.0*data0_(i, j, k-1)
		ddx_p2 = ddx_p1 - 0.5*lsm_getminmod(ddxx_c, ddxx_p)
		ddx_n2 = ddx_n1 + 0.5*lsm_getminmod(ddxx_c, ddxx_n)
		ddy_p2 = ddy_p1 - 0.5*lsm_getminmod(ddyy_c, ddyy_p)
		ddy_n2 = ddy_n1 + 0.5*lsm_getminmod(ddyy_c, ddyy_n)
		ddz_p2 = ddz_p1 - 0.5*lsm_getminmod(ddzz_c, ddzz_p)
		ddz_n2 = ddz_n1 + 0.5*lsm_getminmod(ddzz_c, ddzz_n)
		ddx_p = ddx_p1
		ddx_n = ddx_n1
		ddy_p = ddy_p1
		ddy_n = ddy_n1
		ddz_p = ddz_p1
		ddz_n = ddz_n1

		data1_(i, j, k) = data0_(i, j, k) -( &
																			+ (max(wx, 0.0)*ddx_n + min(wx, 0.0)*ddx_p) &
																			+ (max(wy, 0.0)*ddy_n + min(wy, 0.0)*ddy_p) &
																			+ (max(wz, 0.0)*ddz_n + min(wz, 0.0)*ddz_p) )*dtau
	end do
	end do
	end do
!$omp end do
!$omp end parallel
end subroutine lsm_extend_s_core


      subroutine angle3(xxi,yyi,zzi,xxj,yyj,zzj,sinph,cosph,sinth,costh)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
C**********************************************************************
CD1
CD1 PURPOSE
CD1
CD1 this routine calculates the rotation angles needed to rotate
CD1 the x-axis from i to j and the from here
CD1 to rotate the z-axis from i to j.
CD1
CD1 determine the angles of rotation needed to point the
CD1 z-axis from mass point 'i' to neighbor 'j'.
CD1
CD1 find the cosine and sine of the angle with reference to the z-axis
CD1
C**********************************************************************
CD2
CD2 REVISION HISTORY
CD2
CD2 Revision                    ECD
CD2 Date         Programmer     Number  Comments
CD2
CD2 25-APR-96    S. Henderson   22      Initial implementation
CD2
CD2 $Log:   /pvcs.config/fehm90/src/angle3.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:42:16   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 08:54:10   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:04:36   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:21:42   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 11:55:12   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:38:48 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
CD2
CD2    Rev 1.0   Thu Apr 25 13:30:18 1996   hend
CD2 Initial coding for use in long/trans dispersion
CD2
C**********************************************************************
CD3
CD3 REQUIREMENTS TRACEABILITY
CD3
CD3 2.3.4 Solute-transport equations
CD3
C**********************************************************************
CD4
CD4 SPECIAL COMMENTS
CD4
CD4 This code is part of X3D
!D4
!D4 Requirements from SDN: 10086-RD-2.20-00
!D4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
!D4   FEHM Application Version 2.20
!D4
C**********************************************************************

      implicit none

      real*8 xxi, yyi, zzi, xxj, yyj, zzj
      real*8 sinph, cosph, sinth, costh
      real*8 xnoise, ds, dsxy, dsxysq, dsiv
      character*132 logmess

      xnoise=1.0e-10
      dsxysq=(xxj-xxi)**2 + (yyj-yyi)**2
      dsxy=sqrt(dsxysq)
      ds=sqrt(dsxysq+(zzj-zzi)**2)
      dsiv=1.0/ds
      costh=(zzj-zzi)*dsiv
      sinth=dsxy*dsiv
c
c find the cosine and sine of the angle with reference to the x-axis
c
      if(dsxy.lt.ds*xnoise) then
         cosph=0.0
         sinph=1.0
      else
         cosph=-(yyj-yyi)/dsxy
         sinph= (xxj-xxi)/dsxy
      endif
      goto 9999
 9999 continue
      return
      end


      program mulliken
!
!     This program carries out Mulliken population analysis from a Gaussian
!     unformatted matrix file.
!
!
!     H. P. Hratchian
!     Department of Chemistry & Chemical Biology
!     Center for Chemical Computation and Theory
!     University of California, Merced
!     hhratchian@ucmerced.edu
!
!
!
!     USE Connections
!
      use mqc_general
      use mqc_gaussian
      use mqc_algebra2
      use iso_fortran_env
!
!     Variable Declarations
!
      implicit none
      integer,parameter::IOut=6
      character(len=512)::matrixFilename
      type(mqc_gaussian_unformatted_matrix_file)::GMatrixFile
      integer::nAlpha,nBeta,nBasis,nBasisUse
      type(MQC_Variable)::nEalpha,nEbeta,nEtot
      type(MQC_Variable)::SMatrixAO,PMatrixAlpha,PMatrixBeta,PMatrixTotal
      type(MQC_Variable)::mullikenMatrixAO,mullikenGrossPopAO
!
!     Format Statements
!
 1000 Format(1x,'Enter Mulliken.')
 1010 Format(3x,'Matrix File: ',A,/)
 1100 Format(1x,'nAlpha=',I4,'  nBeta=',I4,'  nBasis=',I5,'  nBasisUse=',I5)
!
!
      write(IOut,1000)
!
!     Open the Gaussian matrix file and load the number of alpha electrons
!     (nAlpha), number of beta electrons (nBeta), and number of basis functions
!     (nBasis and nBasisUse).
!
      call get_command_argument(1,matrixFilename)
      call GMatrixFile%load(matrixFilename)
      write(IOut,1010) TRIM(matrixFilename)
      nAlpha    = GMatrixFile%getVal('nAlpha')
      nBeta     = GMatrixFile%getVal('nBeta')
      nBasis    = GMatrixFile%getVal('nBasis')
      nBasisUse = GMatrixFile%getVal('nBasisUse')
      write(IOut,1100) nAlpha,nBeta,nBasis,nBasisUse
!
!     Get the AO overlap and density matrices from the matrix file.
!
      call GMatrixFile%getArray('OVERLAP',mqcVarOut=SMatrixAO)
      call GMatrixFile%getArray('ALPHA DENSITY MATRIX',mqcVarOut=PMatrixAlpha)
      if(GMatrixFile%isUnrestricted()) then
        call GMatrixFile%getArray('BETA DENSITY MATRIX',mqcVarOut=PMatrixBeta)
      else
        PMatrixBeta  = PMatrixAlpha
      endIf
      PMatrixTotal = PMatrixAlpha+PMatrixBeta
      nEalpha = Contraction(PMatrixAlpha,SMatrixAO)
      nEbeta  = Contraction(PMatrixBeta,SMatrixAO)
      nEtot   = Contraction(PMatrixTotal,SMatrixAO)
      call nEalpha%print(IOut,'<P(Alpha)S>=')
      call nEbeta%print(IOut,'<P(Beta )S>=')
      call nEtot%print(IOut,'<P(Total)S>=')
!
!     Form the Mulliken matrix and compress it down to populationAO.
!
      mullikenMatrixAO = PMatrixTotal*SMatrixAO
      call mullikenMatrixAO%print(IOut,header='Mulliken Matrix in the AO Basis')

      mullikenGrossPopAO = MQC_Variable_Array_Sum(mullikenMatrixAO,1)
      call mullikenGrossPopAO%print(IOut,header='Gross AO Populations')

      end program mulliken


!***********************************/
!	Name:Venkatakrishnanリミッターを求めるプログラム
!	Alias:Venkatakrishnan
!	Description:既に求めてあるΔmax,Δmin,Δ_を元に各格子における流束制限関数を求める
!	Type:CellCenter
!	Input:Geometory,CC%VariationOfVariable,CC%GradientOfVariable,CE%NormalGradient
!	Output:CC%LimiterFunction
!	Note:法線ベクトルについての考慮は式自体に内包してあるのでいらない
!	Author:Akitaka Toyota
!	Date:2017.10.26
!	Update:2018.01.11
!	Other:
!***********************************/
subroutine UVenkatakrishnan(UG,UCC,UCE,UV)
    use StructVar_Mod
    !use LoopVar_Mod
    use ConstantVar_Mod, VPK => VenkatakrishnanParameterK
    use UVenkatakrishnanVar_Mod4OMP
    implicit none
    type(UnstructuredGrid), intent(in) :: UG
    type(CellCenter), intent(inout) :: UCC
    type(CellEdge), intent(inout) :: UCE
    integer :: iEdge, iSide, iVariable, iCell
    type(UVenkatakrishnanWithOMP), intent(inout) :: UV

!初期値として1.0(制限関数の最大値)を与える
        UCE%TmpLimiterFunction = 1.0d0

!$omp parallel num_threads(CoreNumberOfCPU),shared(UG,UCE,UCC),firstprivate(iCell,iEdge,iSide,iVariable,UV)
!$omp do
        do iEdge = 1, UG%GI%Edges
            do iSide=1,2
                do iVariable=1,5
                if(UCE%NormalGradient(iVariable,1,1,iSide,iEdge) == 0.0d0) then
                    UCE%TmpLimiterFunction(iVariable,1,1,iSide,iEdge) = 1.0d0

                else
                    iCell = UG%Line%Cell(iEdge,iSide,1) !界面の隣接要素を与えるが
                    if(iCell > UG%GI%RealCells) then
                        UCE%TmpLimiterFunction(iVariable,1,1,iSide,iEdge) = 1.0d0
                    else
                        if(UCE%NormalGradient(iVariable,1,1,iSide,iEdge) > 0.0d0) then
                            UV%iMaxMin => iOne !Δmax
                        else !if(UCE%NormalGradient(iVariable,1,1,iSide,iEdge) <= 0.0d0) then
                            UV%iMaxMin => iTwo !Δmin
                        end if

                        UV%VE2 = (VPK * 2.0d0*UG%GM%AverageWidth(iCell))**3

                        UCE%TmpLimiterFunction(iVariable,1,1,iSide,iEdge) = &
                        &   (UCC%VariationOfVariable(UV%iMaxMin,iVariable,iCell,1,1)**2 + UV%VE2 &
                            &   + 2.0d0 * UCE%NormalGradient(iVariable,1,1,iSide,iEdge) &
                            &   * UCC%VariationOfVariable(UV%iMaxMin,iVariable,iCell,1,1)) &
                        & / (UCC%VariationOfVariable(UV%iMaxMin,iVariable,iCell,1,1)**2  &
                            &   + 2.0d0*UCE%NormalGradient(iVariable,1,1,iSide,iEdge)**2 &
                            &   + UCC%VariationOfVariable(UV%iMaxMin,iVariable,iCell,1,1) &
                            &   * UCE%NormalGradient(iVariable,1,1,iSide,iEdge) + UV%VE2)

                    end if
                end if
                end do
            end do
        end do
!$omp end do
!$omp barrier
!$omp do
        do iCell = 1, UG%GI%RealCells
            UCC%LimiterFunction(:,iCell,1,1) = &
            & min(UCE%TmpLimiterFunction(:,1,1,1,UG%Tri%Edge(iCell,1)), UCE%TmpLimiterFunction(:,1,1,2,UG%Tri%Edge(iCell,1)), &
            &     UCE%TmpLimiterFunction(:,1,1,1,UG%Tri%Edge(iCell,2)), UCE%TmpLimiterFunction(:,1,1,2,UG%Tri%Edge(iCell,2)), &
            &     UCE%TmpLimiterFunction(:,1,1,1,UG%Tri%Edge(iCell,3)), UCE%TmpLimiterFunction(:,1,1,2,UG%Tri%Edge(iCell,3)))

        end do
!$omp end do
!$omp end parallel
    return
end subroutine UVenkatakrishnan


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE BLOCH                                                 C
C                                                                      C
C     Read the couple of nodes with bloch-periodicity constraints      C
C                                                                      C
C                                                                      C
C     NCOND       :NUMBER OF NODAL CONSTRAINTS                         C
C     IMNODES     :IMAGE NODES                                         C
C     IRNODES     :REFERENCES NODES                                    C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     AUTHOR: NICOLAS GUARIN Z.                                        C
C     GRUPO DE MECANICA APLICADA- UNIVERSIDAD EAFIT                    C
C     LAST MOD: 08 AUGUST 2012                                         C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE BLOCH(NDOF,SKG,SMG,NCOR,COORDS,NCOND_WO,NCOND,
     1           IRNODES_WO,IMNODES,IRNODES,NEVALS,AKXMIN,
     2           AKYMIN,AKXMAX,AKYMAX,NKX,NKY,EIGVALS)

      IMPLICIT REAL*8(A-H,O-Z)
      PARAMETER (PI = 3.141592653589793)

      DIMENSION SKG(NDOF,NDOF),SMG(NDOF,NDOF),COORDS(2,NCOR),
     1          IRNODES_WO(NCOND_WO),
     2          IMNODES(NCOND),IRNODES(NCOND),
     3          EIGVALS(NKX*NKY,NEVALS+2)

C     LOCAL VARIABLES
      COMPLEX*16 SAUX, SKBLOCH, SMBLOCH, XJ, WORK
      DIMENSION SAUX(NDOF,NDOF),
     1          SKBLOCH(NDOF - NCOND,NDOF - NCOND),
     2          SMBLOCH(NDOF - NCOND,NDOF - NCOND),IANODES(NCOND),
     3          EVALS(NDOF - NCOND),
     4          RWORK(3*(NDOF - NCOND)-2), WORK(2*(NDOF - NCOND)-1)

      N = NDOF - NCOND

      XJ=(0.0,1.0)
      SKBLOCH = 0.0
      DO II=1,NCOND
        IANODES(II) = IMNODES(II)
      END DO

      DKX = (AKXMAX - AKXMIN)/(NKX-1)  ! X Wave Number step
      DKY = (AKYMAX - AKYMIN)/(NKY-1)  ! Y Wave Number step
      AKX = AKXMIN
      ICONT = 1
      DO IKX=1,NKX

       AKY = AKYMIN
        DO IKY=1,NKY

          SAUX = DCMPLX(SKG)
          CALL BLOCH_BC(SAUX,NDOF,COORDS,NCOND,NCOND_WO,  ! Bloch BC Imposition
     1                  NCOR,AKX,AKY,IRNODES,IRNODES_WO,
     2                  IMNODES,IANODES,SKBLOCH)

          SAUX = DCMPLX(SMG)
          CALL BLOCH_BC(SAUX,NDOF,COORDS,NCOND,NCOND_WO,  ! Bloch BC Imposition
     1                  NCOR,AKX,AKY,IRNODES,IRNODES_WO,
     2                  IMNODES,IANODES,SMBLOCH)

        CALL ZHEGV(1, 'N', 'U', N, SKBLOCH, N, SMBLOCH, N, EVALS, WORK,
     1             2*N-1, RWORK, INFO)

          EIGVALS(ICONT,1) = AKX
          EIGVALS(ICONT,2) = AKY
          EIGVALS(ICONT,3:NEVALS+2) = EVALS(1:NEVALS)

          ICONT = ICONT+1

          AKY = AKY + DKY
        END DO

        AKX = AKX + DKX
      END DO

      RETURN

      END SUBROUTINE BLOCH

C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE  BLOCH_BC()                                           C
C                                                                      C
C     Pending...                                                       C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     AUTHOR: NICOLAS GUARIN Z.                                        C
C     GRUPO DE MECANICA APLICADA- UNIVERSIDAD EAFIT                    C
C     LAST MOD: 11 MARCH 2012                                          C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
      SUBROUTINE BLOCH_BC(SKAUX,NDOF,COORDS,NCOND,NCOND_WO,
     1                    NCOR,AKX,AKY,IRNODES,IRNODES_WO,
     2                    IMNODES,IANODES,SKBLOCH)

      IMPLICIT REAL*8(A-H,O-Z)

      COMPLEX*16 SKAUX,SKBLOCH,FI, FCI, FR,
     1           FCR, XJ

      DIMENSION SKAUX(NDOF,NDOF),
     1          SKBLOCH(NDOF - NCOND,NDOF - NCOND),
     2          IANODES(NCOND),COORDS(2,NCOR),
     3          IRNODES_WO(NCOND_WO),
     4          IMNODES(NCOND),IRNODES(NCOND)

      N = NDOF - NCOND

      XJ=(0.0,1.0)

      DO II=1,NCOND_WO     ! Assigning the Phase shifts for Reference Nodes
        IR = IRNODES_WO(II)
        XR = COORDS(1,IR); YR = COORDS(2,IR)
        FR = EXP(XJ*AKX*XR)*EXP(XJ*AKY*YR)
        FCR= EXP(-XJ*AKX*XR)*EXP(-XJ*AKY*YR)
        CALL CROWMULT(SKAUX,NDOF,SKAUX,IR,FCR)
        CALL CCOLMULT(SKAUX,NDOF,SKAUX,IR,FR)

      END DO

      DO II=1,NCOND     ! Assigning the Phase shifts for Image Nodes
        IM = IMNODES(II)
        XI = COORDS(1,IM); YI = COORDS(2,IM)
        FI = EXP(XJ*AKX*XI)*EXP(XJ*AKY*YI)
        FCI= EXP(-XJ*AKX*XI)*EXP(-XJ*AKY*YI)
        CALL CROWMULT(SKAUX,NDOF,SKAUX,IM,FCI)
        CALL CCOLMULT(SKAUX,NDOF,SKAUX,IM,FI)
      END DO

      DO II=1,NCOND            ! Summing rows and columns
        IR = IRNODES(II); IM = IMNODES(II)
        CALL CROWADD(SKAUX,NDOF,SKAUX,IM,IR)
        CALL CCOLADD(SKAUX,NDOF,SKAUX,IM,IR)
      END DO

      CALL COLROWDEL(SKAUX,NDOF,NCOND,SKBLOCH,IANODES) ! Deleting redundant equations

      RETURN

      END SUBROUTINE BLOCH_BC

C
C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE COLROWDEL(A,NA,NRED,B,COLS)                             C
C                                                                      C
C    Delete NRED rows and columns from the matrix A and returns the    C
C    submatrix B. COLS are the columns/rows to be deleted.             C
C    NA is the dimension of A.                                         C
C                                                                      C
C    Both matrices, A and B are complex.
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE COLROWDEL(A,NA,NRED,B,COLS)
C
      COMPLEX*16 A, B
      INTEGER COLS, COLN, CONTII, CONTJJ
      DIMENSION A(NA,NA),B(NA-NRED,NA-NRED), COLS(NRED), COLN(NA)

      COLN = 0

      DO II=1,NRED
        COLN(COLS(II)) = 1
      END DO

      CONTII = 1
      DO II=1,NA
        IF(COLN(II).EQ.0)THEN
          CONTJJ = 1
          DO JJ=1,NA
            IF(COLN(JJ).EQ.0)THEN
              B(CONTII,CONTJJ) = A(II,JJ)
              CONTJJ = CONTJJ + 1
            END IF
          END DO
         CONTII = CONTII +1
        END IF

      END DO

      RETURN

C
      END SUBROUTINE COLROWDEL
C
C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE CCOLMULT                                                C
C                                                                      C
C    Multiply the COL column of the complex matrix A by a factor FACT, C
C    the result is stored in the complex matrix B.                     C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CCOLMULT(A,N,B,COL,FACT)
C
      COMPLEX*16 A, B, FACT
      INTEGER COL
      DIMENSION A(N,N),B(N,N)

       DO II=1,N
          DO JJ=1,N
            IF (JJ.EQ.COL) THEN
              B(II,JJ) = A(II,JJ)*FACT
            ELSE
              B(II,JJ) = A(II,JJ)
            END IF
          END DO
      END DO

      RETURN

      END SUBROUTINE CCOLMULT
C
C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE CROWMULT                                                C
C                                                                      C
C    Multiply the ROW row of the complex matrix A by a factor FACT,    C
C    the result is stored in the complex matrix B.                     C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CROWMULT(A,N,B,ROW,FACT)
C
      COMPLEX*16 A, B, FACT
      INTEGER ROW
      DIMENSION A(N,N),B(N,N)

       DO II=1,N
          DO JJ=1,N
            IF (II.EQ.ROW) THEN
              B(II,JJ) = A(II,JJ)*FACT
            ELSE
              B(II,JJ) = A(II,JJ)
            END IF
          END DO
      END DO

      RETURN

      END SUBROUTINE CROWMULT
C
C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE CROWADD                                                 C
C                                                                      C
C    PENDING...                                                        C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CROWADD(A,N,B,ROW1,ROW2)

      COMPLEX*16 A, B
      INTEGER ROW1, ROW2
      DIMENSION A(N,N),B(N,N)

      DO II=1,N
          DO JJ=1,N
            IF (II.EQ.ROW2) THEN
              B(II,JJ) = A(II,JJ) + A(ROW1,JJ)

            ELSE
              B(II,JJ) = A(II,JJ)
            END IF
          END DO
      END DO

      RETURN

      END SUBROUTINE CROWADD
C
C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE CCOLADD                                                 C
C                                                                      C
C    PENDING...                                                        C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CCOLADD(A,N,B,COL1,COL2)

      COMPLEX*16 A, B
      INTEGER COL1, COL2
      DIMENSION A(N,N),B(N,N)

      DO II=1,N
          DO JJ=1,N
            IF (JJ.EQ.COL2) THEN
              B(II,JJ) = A(II,JJ) + A(II,COL1)

            ELSE
              B(II,JJ) = A(II,JJ)
            END IF
          END DO
      END DO

      RETURN

      END SUBROUTINE CCOLADD
C
C


      PROGRAM xfourn
C     driver for routine fourn
      INTEGER NDAT,NDIM
      PARAMETER(NDIM=3,NDAT=1024)
      INTEGER i,idum,isign,j,k,l,nn(NDIM)
      REAL data1(NDAT),data2(NDAT),ran1
      idum=-23
      do 11 i=1,NDIM
        nn(i)=2*(2**i)
11    continue
      do 14 i=1,nn(3)
        do 13 j=1,nn(2)
          do 12 k=1,nn(1)
            l=k+(j-1)*nn(1)+(i-1)*nn(2)*nn(1)
            l=2*l-1
C     real part of component
            data1(l)=2.*ran1(idum)-1.
            data2(l)=data1(l)
C     imaginary part of component
            l=l+1
            data1(l)=2.*ran1(idum)-1.
            data2(l)=data1(l)
12        continue
13      continue
14    continue
      isign=+1
      call fourn(data2,nn,NDIM,isign)
C     here would be any processing to be done in Fourier space
      isign=-1
      call fourn(data2,nn,NDIM,isign)
      write(*,'(1x,a)') 'Double 3-dimensional Transform'
      write(*,'(/1x,t10,a,t35,a,t63,a)') 'Double Transf.',
     *     'Original Data','Ratio'
      write(*,'(1x,t8,a,t20,a,t33,a,t45,a,t57,a,t69,a/)')
     *     'Real','Imag.','Real','Imag.','Real','Imag.'
      do 15 i=1,4
        j=2*i
        k=2*j
        l=k+(j-1)*nn(1)+(i-1)*nn(2)*nn(1)
        l=2*l-1
        write(*,'(1x,6f12.2)') data2(l),data2(l+1),data1(l),
     *       data1(l+1),data2(l)/data1(l),data2(l+1)/data1(l+1)
15    continue
      write(*,'(/1x,a,i4)') 'The product of transform lengths is:',
     *     nn(1)*nn(2)*nn(3)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xfourn.for


MODULE common_enkf
!=======================================================================
!
! [PURPOSE:] Ensemble Kalman Filter (EnKF)
!            Model Independent Core Module
!
! [REFERENCES:]
!  Miyoshi, T., 2004: Application of ensemble Kalman filtering
!    including model bias estimation to a primitive-equation global
!    model. PhD Proposal, University of Maryland, College Park, 27pp.
!
! [HISTORY:]
!  07/20/2004 Takemasa Miyoshi  Created at University of Maryland, College Park
!  02/16/2005 Takemasa Miyoshi  Bias analysis (enkf_banl0) is added
!
!=======================================================================
  USE common
  USE common_mtx

  IMPLICIT NONE

  PUBLIC

CONTAINS
!=======================================================================
! Analysis
!=======================================================================
!-----------------------------------------------------------------------
! Analysis for ny=1
!  K = E (HE)^T [ HE (HE)^T + R ]^(-1)
!-----------------------------------------------------------------------
SUBROUTINE enkf_anal0(nx,m,hdxf,r,dxf,gain)
  IMPLICIT NONE
  INTEGER,INTENT(IN) :: nx               ! dimension of analysis space
  INTEGER,INTENT(IN) :: m                ! ensemble size
  REAL(r_size),INTENT(IN) :: hdxf(m)     ! HE
  REAL(r_size),INTENT(IN) :: r           ! observational error variance
  REAL(r_size),INTENT(IN) :: dxf(nx,m)   ! background ensemble ptb
  REAL(r_size),INTENT(OUT) :: gain(nx)   ! Kalman gain
  REAL(r_size) :: wk1d1(m)
  REAL(r_size) :: wk0d1
!
! [ HE (HE)^T + R ] -> wk0d1
!
  wk0d1 = SUM(hdxf**2) / REAL(m-1,r_size) + r
!
! K = E (HE)^T [ HE (HE)^T + R ]^(-1)
!
  wk1d1 = hdxf / wk0d1
  gain = MATMUL(dxf,wk1d1) / REAL(m-1,r_size)

  RETURN
END SUBROUTINE enkf_anal0
!-----------------------------------------------------------------------
! Bias Analysis for ny=1
!  Kb = Eb (HEb)^T [ HEb (HEb)^T + HE (HE)^T + R ]^(-1)
!-----------------------------------------------------------------------
SUBROUTINE enkf_bias_anal0(nx,m,hdbf,hdxf,r,dbf,gain)
  IMPLICIT NONE
  INTEGER,INTENT(IN) :: nx               ! dimension of analysis space
  INTEGER,INTENT(IN) :: m                ! ensemble size
  REAL(r_size),INTENT(IN) :: hdbf(m)     ! HEb
  REAL(r_size),INTENT(IN) :: hdxf(m)     ! HE
  REAL(r_size),INTENT(IN) :: r           ! observational error variance
  REAL(r_size),INTENT(IN) :: dbf(nx,m)   ! background bias ensemble ptb
  REAL(r_size),INTENT(OUT) :: gain(nx)   ! Kalman gain
  REAL(r_size) :: wk1d1(m)
  REAL(r_size) :: wk0d1
!
! [ HEb (HEb)^T + HE (HE)^T + R ] -> wk0d1
!
  wk0d1 = ( SUM(hdbf**2) + SUM(hdxf**2) ) / REAL(m-1,r_size) + r
!
! Kb = Eb (HEb)^T [ HEb (HEb)^T + HE (HE)^T + R ]^(-1)
!
  wk1d1 = hdbf / wk0d1
  gain = MATMUL(dbf,wk1d1) / REAL(m-1,r_size)

  RETURN
END SUBROUTINE enkf_bias_anal0
!-----------------------------------------------------------------------
! Analysis for small ny; usually used serially
!  Matrix inversion of the size [ny x ny] is required
!  K = E (HE)^T [ HE (HE)^T + R ]^(-1)
!-----------------------------------------------------------------------
SUBROUTINE enkf_anal1(nx,ny,m,hdxf,dep,r,dxf,xfbar,xabar,gain)
  IMPLICIT NONE
  INTEGER,INTENT(IN) :: nx               ! dimension of analysis space
  INTEGER,INTENT(IN) :: ny               ! number of observation
  INTEGER,INTENT(IN) :: m                ! ensemble size
  REAL(r_size),INTENT(IN) :: hdxf(ny,m)  ! HE
  REAL(r_size),INTENT(IN) :: dep(ny)     ! departure (y-Hx)
  REAL(r_size),INTENT(IN) :: r(ny,ny)    ! observational error covariance
  REAL(r_size),INTENT(IN) :: dxf(nx,m)   ! background ensemble ptb
  REAL(r_size),INTENT(IN) :: xfbar(nx)   ! background ensemble mean
  REAL(r_size),INTENT(OUT) :: xabar(nx)  ! analysis ensemble mean
  REAL(r_size),INTENT(OUT) :: gain(nx,ny)! Kalman gain
  REAL(r_size) :: wk2d1(ny,ny),wk2d2(ny,ny),wk2d3(m,ny)
!
! [ HE (HE)^T + R ]^(-1) -> wk2d2
!
  wk2d1 = matmul(hdxf,transpose(hdxf)) / REAL(m-1,r_size) + r
  CALL mtx_inv(ny,wk2d1,wk2d2)
!
! K = E (HE)^T [ HE (HE)^T + R ]^(-1)
!
  wk2d3 = matmul(transpose(hdxf),wk2d2)
  gain = matmul(dxf,wk2d3) / REAL(m-1,r_size)
!
! xa = xf + K * dep -> xabar (RETURN)
!
  xabar = xfbar + matmul(gain,dep)

  RETURN
END SUBROUTINE enkf_anal1
!-----------------------------------------------------------------------
! Analysis for not small ny assuming diagonal R
!  Matrix inversion of the size [m x m] is required
!  K = E [ I + (HE)^T R^(-1) (HE) ]^(-1) (HE)^T R^(-1)
!-----------------------------------------------------------------------
SUBROUTINE enkf_anal2(nx,ny,m,hdxf,dep,rdiag,dxf,xfbar,xabar)
  IMPLICIT NONE
  INTEGER,INTENT(IN) :: nx               ! dimension of analysis space
  INTEGER,INTENT(IN) :: ny               ! number of observation
  INTEGER,INTENT(IN) :: m                ! ensemble size
  REAL(r_size),INTENT(IN) :: hdxf(ny,m)  ! HE
  REAL(r_size),INTENT(IN) :: dep(ny)     ! departure (y-Hx)
  REAL(r_size),INTENT(IN) :: rdiag(ny)   ! observational error variance
  REAL(r_size),INTENT(IN) :: dxf(nx,m)   ! background ensemble ptb
  REAL(r_size),INTENT(IN) :: xfbar(nx)   ! background ensemble mean
  REAL(r_size),INTENT(OUT) :: xabar(nx)  ! analysis ensemble mean
  REAL(r_size) :: wk1d1(ny),wk1d2(m),wk1d3(m)
  REAL(r_size) :: wk2d1(ny,m),wk2d2(m,m),wk2d3(m,m)
  INTEGER :: i
!
! [ I + (HE)^T R^(-1) (HE) ]^(-1) -> wk2d3
!
  DO i=1,ny
    wk2d1(i,:) = hdxf(i,:) / rdiag(i)
  END DO
  wk2d2 = matmul(transpose(hdxf),wk2d1) / REAL(m-1,r_size)
  DO i=1,m
    wk2d2(i,i) = wk2d2(i,i) + 1.0d0
  END DO
  CALL mtx_inv(m,wk2d2,wk2d3)
!
! dxa =  E [ I + (HE)^T R^(-1) (HE) ]^(-1) (HE)^T R^(-1) * dep -> xabar
!
  wk1d1 = dep / rdiag
  wk1d2 = matmul(transpose(hdxf),wk1d1)
  wk1d3 = matmul(wk2d3,wk1d2)
  xabar = matmul(dxf,wk1d3) / REAL(m-1,r_size)
!
! xa = xf + dxa -> xabar (RETURN)
!
  xabar = xfbar + xabar

  RETURN
END SUBROUTINE enkf_anal2
!=======================================================================
! Ensemble Update
!=======================================================================
!-----------------------------------------------------------------------
! Serial method: Eq(13) of Whitaker and Hamill (2002) (Potter 1964)
! ny = 1
!-----------------------------------------------------------------------
SUBROUTINE enkf_serial(nx,m,hdxf,r,dxf,gain,dxa)
  IMPLICIT NONE
  INTEGER,INTENT(IN) :: nx               ! dimension of analysis space
  INTEGER,INTENT(IN) :: m                ! ensemble size
  REAL(r_size),INTENT(IN) :: hdxf(m)     ! HE
  REAL(r_size),INTENT(IN) :: r           ! observational error variance
  REAL(r_size),INTENT(IN) :: dxf(nx,m)   ! background ensemble ptb
  REAL(r_size),INTENT(IN) :: gain(nx)    ! Kalman gain
  REAL(r_size),INTENT(OUT) :: dxa(nx,m)  ! analysis ensemble ptb
  REAL(r_size) :: alpha
  INTEGER :: i,j

  alpha = 1 + SQRT( r / ( SUM(hdxf**2)/REAL(m-1,r_size) + r ) )

  DO j=1,m
    DO i=1,nx
      dxa(i,j) = dxf(i,j) - gain(i) * hdxf(j) / alpha
    END DO
  END DO

  RETURN
END SUBROUTINE enkf_serial
!-----------------------------------------------------------------------
! Serial method for bias analysis
! ny = 1
!-----------------------------------------------------------------------
SUBROUTINE enkf_bias_serial(nx,m,hdbf,hdxf,r,dbf,gain,dba)
  IMPLICIT NONE
  INTEGER,INTENT(IN) :: nx               ! dimension of analysis space
  INTEGER,INTENT(IN) :: m                ! ensemble size
  REAL(r_size),INTENT(IN) :: hdbf(m)     ! HEb
  REAL(r_size),INTENT(IN) :: hdxf(m)     ! HE
  REAL(r_size),INTENT(IN) :: r           ! observational error variance
  REAL(r_size),INTENT(IN) :: dbf(nx,m)   ! background bias ensemble ptb
  REAL(r_size),INTENT(IN) :: gain(nx)    ! Kalman gain
  REAL(r_size),INTENT(OUT) :: dba(nx,m)  ! analysis bias ensemble ptb
  REAL(r_size) :: alpha
  INTEGER :: i,j

  alpha = 1 + SQRT( r / ( (SUM(hdbf**2)+SUM(hdxf**2))/REAL(m-1,r_size) + r ) )

  DO j=1,m
    DO i=1,nx
      dba(i,j) = dbf(i,j) - gain(i) * hdbf(j) / alpha
    END DO
  END DO

  RETURN
END SUBROUTINE enkf_bias_serial
!-----------------------------------------------------------------------
! ETKF
!-----------------------------------------------------------------------
SUBROUTINE enkf_etkf(nx,ny,m,hdxf,rdiag,dxf,dxa)
  IMPLICIT NONE
  INTEGER,INTENT(IN) :: nx               ! dimension of analysis space
  INTEGER,INTENT(IN) :: ny               ! number of observation
  INTEGER,INTENT(IN) :: m                ! ensemble size
  REAL(r_size),INTENT(IN) :: hdxf(ny,m)  ! HE
  REAL(r_size),INTENT(IN) :: rdiag(ny)   ! observational error variance
  REAL(r_size),INTENT(IN) :: dxf(nx,m)   ! background ensemble ptb
  REAL(r_size),INTENT(OUT) :: dxa(nx,m)  ! analysis ensemble ptb
  REAL(r_size) :: wk1d1(m),wk2d1(ny,m),wk2d2(m,m),wk2d3(m,m)
  INTEGER :: i,nrank_eff
!
! R^(-1/2) (HE) -> wk2d1
!
  DO i=1,ny
    wk2d1(i,:) = hdxf(i,:) / SQRT( rdiag(i) )
  END DO
!
! [ R^(-1/2) (HE) ]^T [ R^(-1/2) (HE) ] -> wk2d2
!
  wk2d2 = matmul(transpose(wk2d1),wk2d1) / REAL(m-1,r_size)
!
! Eigenvalue decomposition CGC^T
!
  CALL mtx_eigen(1,m,wk2d2,wk1d1,wk2d3,nrank_eff)
!
! T = C [ G + I ]^(-1/2) where CGC^T is eigenvalue decomposition
!
  DO i=1,m
    wk2d2(:,i) = wk2d3(:,i)  / SQRT( wk1d1(i) + 1.0d0 )
  END DO
!
! Ea = Ef T
!
  dxa = matmul(dxf,wk2d2)

  RETURN
END SUBROUTINE enkf_etkf
!=======================================================================
! Localization
!=======================================================================
!-----------------------------------------------------------------------
! Schur Product
!-----------------------------------------------------------------------
SUBROUTINE enkf_schur(scale,dist,factor)
  IMPLICIT NONE
  REAL(r_size),INTENT(IN) :: scale
  REAL(r_size),INTENT(IN) :: dist
  REAL(r_size),INTENT(OUT) :: factor
  REAL(r_size) :: a,b

  a = scale * SQRT(10.0d0/3.0d0)
  b = dist / a

  IF( dist <= a ) THEN
    factor = 1.0d0 -0.25d0*b**5 + 0.5d0*b**4 + 5.0d0/8.0d0*b**3 &
      & - 5.0d0/3.0d0*b**2
  ELSE IF( dist <= 2*a ) THEN
    factor = 1.0d0/12.0d0*b**5 - 0.5d0*b**4 + 5.0d0/8.0d0*b**3 &
      & + 5.0d0/3.0d0*b**2 - 5.0d0*b + 4.0d0 - 2.0d0/3.0d0/b
  ELSE
    factor = 0.0d0
  END IF

  RETURN
END SUBROUTINE enkf_schur

END MODULE common_enkf