!
!    Copyright 2011 Sebastian Heimann
!
!    Licensed under the Apache License, Version 2.0 (the "License");
!    you may not use this file except in compliance with the License.
!    You may obtain a copy of the License at
!
!        http://www.apache.org/licenses/LICENSE-2.0
!
!    Unless required by applicable law or agreed to in writing, software
!    distributed under the License is distributed on an "AS IS" BASIS,
!    WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!    See the License for the specific language governing permissions and
!    limitations under the License.
!

program test_geometry

    use util
    use constants
    use euler
    use orthodrome
    use geometry

    implicit none

    type(t_halfspace) :: halfspace
    real, dimension(3,4) :: points = reshape( (/0.,2.,-1.,  0.,-2.,-1.,  0.,0.,-1.,  0.,0.,0./), (/3,4/) )
    logical, dimension(4) :: expected = (/.true., .false., .true., .true./)
    real, dimension(3) :: piercingpoint
    logical :: between_ab, parallel
    integer :: i
    type(t_circle) :: circle
    real :: dip, strike
    type(t_polygon) :: polygon, polygon_trimmed
    real, dimension(3,7) :: expected_circ = reshape( (/0.14987442, 2.4953687, &
    2.6585152, -1.9344299, 0.9903534, 3.0681345, -2.5620692, -1.2604182, &
    1.9204066, -1.2604178, -2.5620692, 0.07959348, -1.1043297, -2.5185432, 0., &
    2.3468528, 0.9326396, 0., 2.12132, 2.1213207, 1.0000004 /), (/3,7/) )
    type(t_polygon) :: square

    call test_begin("test_geometry")

    halfspace%point = (/0.,0.,-1./)
    halfspace%normal = (/0.,-1.,-1./)

    do i=1,4
        if (.not. (expected(i) .eqv. point_in_halfspace( points(:,i), halfspace )) ) then
            call test_fail("point_in_halfspace")
        end if
    end do

    call get_piercingpoint( points(:,1), points(:,2), halfspace, piercingpoint, between_ab, parallel )
    if (.not. (all(piercingpoint == (/0.,0.,-1./) ) .and. &
              (between_ab .eqv. .true.) .and. (parallel .eqv. .false.))) then
        call test_fail("piercingpoint 1")
    end if

    call get_piercingpoint( (/0.,2.,-1./), (/0.,1.,-2./), halfspace, piercingpoint, between_ab, parallel )
    if (.not. (all(piercingpoint == (/0.,1.,-2./) ) .and. &
              (between_ab .eqv. .false.) .and. (parallel .eqv. .false.))) then
        call test_fail("piercingpoint 2")
    end if

    call get_piercingpoint( (/0.,2.,5./), (/0.,1.,1./), halfspace, piercingpoint, between_ab, parallel )
    if (.not. (all(near(piercingpoint,(/0.,0.4,-1.4/),0.0001)) .and. &
              (between_ab .eqv. .false.) .and. (parallel .eqv. .false.))) then
        call test_fail("piercingpoint 3")
    end if

    call get_piercingpoint( (/0.,1.,0./), (/0.,2.,-1.0001/), halfspace, piercingpoint, between_ab, parallel )
    if (.not. (all(piercingpoint == (/0.,0.,0./) ) .and. &
              (between_ab .eqv. .false.) .and. (parallel .eqv. .true.))) then
        call test_fail("piercingpoint 4")
    end if

    dip = d2r(45.)
    strike = d2r(45.)
    call init_euler(dip,strike,0.,circle%transform)
    circle%transform = circle%transform * 3.
    circle%center = (/0.,0.,1./)
    call circle_to_polygon( circle, 7, polygon )
    halfspace%point = (/0.,0.,0./)
    halfspace%normal = (/0.,0.,-1./)
    call trim_polygon( polygon, halfspace, polygon_trimmed )
    if (.not. all(near( polygon_trimmed%points,expected_circ, 0.00001))) then
        call test_fail("trimmed circle")
    end if

    dip = d2r(13.)
    strike = d2r(100.)
    call init_euler(dip,strike,0.,circle%transform)
    circle%transform = circle%transform * 1.
    circle%center = (/-5.,-2.,1./)
    call circle_to_polygon( circle, 3600, polygon )
    if (.not. near( polygon_area(polygon), pi, 0.0001)) then
        call test_fail("pi estimation")
    end if

    allocate( square%points(3,4) )
    square%points(:,:) = reshape( (/0.,0.,1.,  0.,2.,1.,  2.,2.,1.,  2.,0.,1./), (/3,4/) )
    if (.not. near( polygon_area(square), 4., 0.00001)) call test_fail("square area 1")

    square%points(:,:) = reshape( (/1.,0.,0.,  1.,0.,2.,  1.,2.,2.,  1.,2.,0./), (/3,4/) )
    if (.not. near( polygon_area(square), 4., 0.00001)) call test_fail("square area 2")

    square%points(:,:) = reshape( (/0.,1.,0.,  2.,1.,0.,  2.,1.,2.,  0.,1.,2./), (/3,4/) )
    if (.not. near( polygon_area(square), 4., 0.00001)) call test_fail("square area 3")

    call polygon_destroy( square )
    call polygon_destroy( polygon )
    call polygon_destroy( polygon_trimmed )
    call test_end()
    call cleanup()

contains

    elemental logical function near( a,b, eps )
        real, intent(in) :: a,b,eps
        near = abs(a-b) < eps
    end function

end program


!			In our machines there is a powerful random number generator which appears to be
!			both fast and with good statistical properties. On most machines you just need
!			to compile your program with the option
!
!			-ldranxor
!
!			In some other machines, however, you need to include the source code dranxor.f90
!			in your compiler instruction. For instance
!
!			ifort -fast test.f90 dranxor.f90 -o test.x
!			gfortran -O test.f90 dranxor.f90 -o test.x
!
!			Next comes a description of what the generator does for you. Further details can
!			be found in
!
!			"Generation of Gaussian distributed random numbers by using a numerical
!			inversion method",
!			R. Toral, A. Chakrabarti.
!			Computer Physics Communications, 74 (1993) 327-334.
!
!			The program is free for you to use and disseminate. However, I would appreciate
!			if proper credit were given to this reference in all those papers that
!			use the Gaussian generator.
!
!
!									Raul Toral
!
!
!			==============================================================================
!
!			***************************************************************************
!			Disclaimer: Although we have made our best efforts to write a good code,
!			we can not make any warranties that the programs in these routines will
!			work in your computer. In particular, there are some bit manipulation
!			functions that might not be standard for your compiler. It is your
!			responsability to test that the random numbers generated are indeed correct.
!			****************************************************************************
!
!					         dranxor.f90
!
!			******************* RANDOM NUMBER GENERATOR ***********************
!
!			            Based on x(i)=x(i-p).xor.x(i-q) type algorithms
!
!				Uses
!					p=1279		q=418
!				(Remember that the R250 generator uses p=250, q=103)
!
!			Implements following functions and subroutines (DOUBLE PRECISION!!!)
!
!			subroutine dran_ini(iseed)
!					Initializes random number generator. Must be
!					called before any other use of the generators.
!
!			subroutine dran_write(iunit)
!					Writes in unit iunit the complete status of the
!					generator to continue runs.
!
!			subroutine dran_read(iunit)
!					Reads from unit iunit the status of the
!					generator.
!
!			function dran_u()
!					Returns random number uniformly distributed in
!					the interval (0,1)
!
!			function i_dran(n)
!					Integer function. Returns an integer random
!					number uniformly distributed in (1,n).
!			  			If n<=0 returns an integer number between 0 and 2**31-1
!
!			function dran_g()
!					Returns Gaussian distributed (mean 0, variance 1)
!					by using a numerical inversion method.
!					It is not a real Gaussian distribution because it is cut-off
!					The cut-off value depends on the parameter np. See details in
!
!			function dran_gbmw()
!					Returns Gaussian distributed (mean 0, variance 1)
!					by using the Box-Muller-Wiener algorithm.
!
!			subroutine dran_uv(u,n)
!					This is the vector routine for the uniform generator:
!				        call dran_uv(x,n)
!					will fill up n-component vector x with random numbers
!					uniformly distributed in (0,1)
!
!			subroutine ran_gv(x,n)
!					This is the vector routine for the fast Gaussian generator:
!				        call dran_gv(x,n)
!					will fill up n-component vector x with Gaussian
!					distributed (mean 0, variance 1) random numbers
!				        generated by the numerical inversion method.
!
!
!
!			I will be happy to get any results from your  experience on
!			different machines. Please do spend some time checking the routines. I have
!			done my best to ensure that there are no mistakes, but you never know.
!
!
!				Finally, it might be a good idea to use a different uniform
!			random generator to check the results. It seems that other good
!			generators can be obtained based on different values:
!
!				p=2281, q=1029
!				p=4423,	q=2098
!				p=9689, q=4187
!				etc.
!
!			Sources are in:
!
!				~raul/random/dranxor.f90
!
!
!			******************************************************************************
!
!			Example program 1.
!
!			Writes in unit (6) 10 sets of (uniform,integer between 1 and 100) random numbers
!
!				call dran_ini(87265)
!				do i=1,10
!				write(6,*) dran_u(),i_dran(100)
!				enddo
!				end
!
!			Example program 2.
!
!			Computes average and variance of 100 Gaussian numbers in double
!			precision.
!
!				implicit double precision (a-h,o-z)
!				call dran_ini(95237)
!				xm=0.0d0
!				x2=0.0d0
!				do i=1,100
!				g=dran_g()
!				xm=xm+g
!				x2=x2+g*g
!				enddo
!				xm=xm/100
!				x2=x2/100-xm*xm
!				write(6,*) xm,x2
!				end
!
!			Example program 3.
!
!			Generates a vector of 100 double precision Gaussian random numbers and
!			computes its mean and variance.
!
!				implicit double precision (a-h,o-z)
!				dimension x(100)
!				call dran_ini(365441)
!				xm=0.0d0
!				x2=0.0d0
!				call dran_gv(x,100)
!				xm=sum(x)/100
!				x2=sum(x*x)/100-xm*xm
!				write(6,*) xm,x2
!				end

subroutine dran_ini(iseed0)
implicit double precision(a-h,o-z)
parameter(ip=1279)
parameter(np=14)
parameter(nbit=31)
parameter(m=2**np,np1=nbit-np,nn=2**np1-1,nn1=nn+1)
integer ix(ip)
dimension g(0:m)

data c0,c1,c2/2.515517,0.802853,0.010328/
data d1,d2,d3/1.432788,0.189269,0.001308/
data pi/3.141592653589793d0/

common /ixx/ ix
common /icc/ ic
common /gg/ g

dseed=iseed0
do i=1,ip
 ix(i)=0
 do j=0,nbit-1
    if(rand_xx(dseed).lt.0.5) ix(i)=ibset(ix(i),j)
 enddo
enddo
ic=0

do i=m/2,m
	p=1.0-dble(i+1)/(m+2)
	t=sqrt(-2.0*log(p))
	x=t-(c0+t*(c1+c2*t))/(1.0+t*(d1+t*(d2+t*d3)))
	g(i)=x
	g(m-i)=-x
enddo

u2th=1.0-dble(m+2)/m*sqrt(2.0/pi)*g(m)*exp(-g(m)*g(m)/2)
u2th=nn1*sqrt(u2th)
g=g/u2th

return
end

subroutine dran_read(iunit)
implicit double precision(a-h,o-z)
parameter(ip=1279)
parameter(np=14)
parameter(m=2**np)
integer ix(ip)
dimension g(0:m)
common /ixx/ ix
common /icc/ ic
common /gg/ g
read (iunit,*) ic
read (iunit,*) (ix(i),i=1,ip)
read (iunit,*) (g(i),i=0,m)
return
end

subroutine dran_write(iunit)
implicit double precision(a-h,o-z)
parameter(ip=1279)
parameter(np=14)
parameter(m=2**np)
integer ix(ip)
dimension g(0:m)
common /ixx/ ix
common /icc/ ic
common /gg/ g
write (iunit,*) ic
write (iunit,*) (ix(i),i=1,ip)
write (iunit,*) (g(i),i=0,m)
return
end

function i_dran(n)
implicit double precision(a-h,o-z)
parameter(ip=1279)
parameter(iq=418)
parameter(is=ip-iq)
integer ix(ip)
common /ixx/ ix
common /icc/ ic
ic=ic+1
if (ic > ip) ic=1
if (ic > iq) then
ix(ic)=ieor(ix(ic),ix(ic-iq))
else
ix(ic)=ieor(ix(ic),ix(ic+is))
endif
i_dran=ix(ic)
if (n > 0) i_dran=mod(i_dran,n)+1
return
end

function dran_u()
implicit double precision(a-h,o-z)
parameter(ip=1279)
parameter(iq=418)
parameter(is=ip-iq)
parameter (rmax=2147483648.0d0)
integer ix(ip)
common /ixx/ ix
common /icc/ ic
ic=ic+1
if (ic > ip) ic=1
if (ic > iq) then
ix(ic)=ieor(ix(ic),ix(ic-iq))
else
ix(ic)=ieor(ix(ic),ix(ic+is))
endif
dran_u=(dble(ix(ic))+0.5d0)/rmax
return
end

function dran_g()
implicit double precision(a-h,o-z)
parameter(ip=1279)
parameter(iq=418)
parameter(np=14)
parameter(nbit=31)
parameter(m=2**np,np1=nbit-np,nn=2**np1-1,nn1=nn+1)
parameter(is=ip-iq)

integer ix(ip)
dimension g(0:m)

common /ixx/ ix
common /icc/ ic
common /gg/ g

ic=ic+1
if(ic > ip) ic=1
if(ic > iq) then
ix(ic)=ieor(ix(ic),ix(ic-iq))
else
ix(ic)=ieor(ix(ic),ix(ic+is))
endif
i=ishft(ix(ic),-np1)
i2=iand(ix(ic),nn)
dran_g=i2*g(i+1)+(nn1-i2)*g(i)
return
end

function dran_gbmw()
implicit double precision(a-h,o-z)
parameter(ip=1279)
parameter(iq=418)
parameter(is=ip-iq)
parameter (rmax=2147483648.0d0)
integer ix(ip)
integer, save :: icount=1
double precision, save :: u,v
common /ixx/ ix
common /icc/ ic
data pi2 /6.283185307179586d0/
if (icount == 1) then
	ic=ic+1
	if (ic > ip) ic=1
	if (ic > iq) then
	ix(ic)=ieor(ix(ic),ix(ic-iq))
	else
	ix(ic)=ieor(ix(ic),ix(ic+is))
	endif
	u=pi2*dble(ix(ic)+0.5d0)/rmax
	ic=ic+1
	if(ic > ip) ic=1
	if(ic > iq) then
	ix(ic)=ieor(ix(ic),ix(ic-iq))
	else
	ix(ic)=ieor(ix(ic),ix(ic+is))
	endif
	v=(dble(ix(ic))+0.5d0)/rmax
	v=dsqrt(-2.0d0*log(v))
	dran_gbmw=dcos(u)*v
	icount=2
else
  dran_gbmw=dsin(u)*v
  icount=1
endif
return
end

subroutine dran_gv(u,n)
implicit double precision(a-h,o-z)
parameter(ip=1279)
parameter(iq=418)
parameter(np=14)
parameter(nbit=31)
parameter(m=2**np,np1=nbit-np,nn=2**np1-1,nn1=nn+1)
parameter(is=ip-iq)
dimension g(0:m)
dimension u(n)
dimension ix(ip)
common /gg/ g
common /ixx/ ix
common /icc/ic

n1=0
do while (n1 < n)
if (ic.lt.iq) then
  kmax=min(n-n1,iq-ic)
  do k=1,kmax
    ic=ic+1
    ix(ic)=ieor(ix(ic),ix(ic+is))
    i=ishft(ix(ic),-np1)
    i2=iand(ix(ic),nn)
    u(n1+k)=i2*g(i+1)+(nn1-i2)*g(i)
  enddo
else
    kmax=min(n-n1,ip-ic)
    do k=1,kmax
      ic=ic+1
      ix(ic)=ieor(ix(ic),ix(ic-iq))
      i=ishft(ix(ic),-np1)
      i2=iand(ix(ic),nn)
      u(n1+k)=i2*g(i+1)+(nn1-i2)*g(i)
    enddo
endif
if(ic.ge.ip) ic=0
n1=n1+kmax
enddo

return
end

subroutine dran_uv(u,n)
implicit double precision(a-h,o-z)
parameter(ip=1279)
parameter(iq=418)
parameter(is=ip-iq)
parameter (rmax=2147483648.0d0)
dimension u(n)
dimension ix(ip)
common /ixx/ ix
common /icc/ic

n1=0
do while (n1 < n)
if (ic.lt.iq) then
  kmax=min(n-n1,iq-ic)
  do k=1,kmax
    ic=ic+1
    ix(ic)=ieor(ix(ic),ix(ic+is))
    u(n1+k)=(dble(ix(ic))+0.5d0)/rmax
  enddo
else
  kmax=min(n-n1,ip-ic)
  do k=1,kmax
    ic=ic+1
    ix(ic)=ieor(ix(ic),ix(ic-iq))
    u(n1+k)=(dble(ix(ic))+0.5d0)/rmax
  enddo
endif
if(ic.ge.ip) ic=0
n1=n1+kmax
enddo

return
end

function rand_xx(dseed)
double precision a,c,xm,rm,dseed,rand_xx
parameter (xm=2.d0**32,rm=1.d0/xm,a=69069.d0,c=1.d0)
dseed=mod(dseed*a+c,xm)
rand_xx=dseed*rm
return
end


program testSaxpy
  use iso_c_binding
  use hipfort
  use hipfort_check

  implicit none
  interface
     subroutine launch(y,x,b,N) bind(c)
       use iso_c_binding
       implicit none
       type(c_ptr) :: y,x
       integer, value :: N
       real, value :: b
     end subroutine
  end interface

  type(c_ptr) :: dx = c_null_ptr
  type(c_ptr) :: dy = c_null_ptr
  integer, parameter :: N = 40000
  integer, parameter :: bytes_per_element = 4
  integer(c_size_t), parameter :: Nbytes = N*bytes_per_element
  real, allocatable,target,dimension(:) :: x, y

  real, parameter ::  a=2.0
  real :: x_d(N), y_d(N)

  call hipCheck(hipMalloc(dx,Nbytes))
  call hipCheck(hipMalloc(dy,Nbytes))

  allocate(x(N))
  allocate(y(N))

  x = 1.0;y = 2.0

  call hipCheck(hipMemcpy(dx, c_loc(x), Nbytes, hipMemcpyHostToDevice))
  call hipCheck(hipMemcpy(dy, c_loc(y), Nbytes, hipMemcpyHostToDevice))

  call launch(dy, dx, a, N)

  call hipCheck(hipDeviceSynchronize())

  call hipCheck(hipMemcpy(c_loc(y), dy, Nbytes, hipMemcpyDeviceToHost))

  write(*,*) 'Max error: ', maxval(abs(y-4.0))

  call hipCheck(hipFree(dx))
  call hipCheck(hipFree(dy))

  deallocate(x)
  deallocate(y)

end program testSaxpy


! { dg-do run }
! Verify that when decimal precision is zero, error error given except with 1P.
! Submitted by Jerry DeLisle  <jvdelisle@gcc.gnu.org>
! Modified for fix to PR35036
program test
  implicit none
  character(20) :: astr
  integer       :: istat
  50 FORMAT (1PD20.0)
  astr = ""
  write(astr,50) -8.0D0
  if (astr.ne."             -8.D+00") call abort
  write(astr,50) 8.0D0
  if (astr.ne."              8.D+00") call abort
  write(astr, '(E15.0)', iostat=istat) 1e5
  if (istat /= 5006) call abort
  write(astr, '(D15.0)', iostat=istat) 1e5
  if (istat /= 5006) call abort
  write(astr, '(G15.0)', iostat=istat) 1e5
  if (istat /= 5006) call abort
  write(astr, '(2PE15.0)', iostat=istat) 1e5
  if (istat /= 5006) call abort
  write(astr, '(0PE15.0)', iostat=istat) 1e5
  if (istat /= 5006) call abort
  write(astr, '(1PE15.0)', iostat=istat) 1e5
  if (istat /= 0) call abort
  write(astr, '(F15.0)', iostat=istat) 1e5
  if (astr.ne."        100000.") call abort
  if (istat /= 0) call abort
end program test


needs testing
with~ ~test

| declare tests here:
test: Simple math +
	" Simple math tests" blab
	2 5 + 7 = ;
test: Simple math -
	~sys
	2 5 - -3 = ;
test: Simple math *
	2 5 * 10 = ;
test: Simple math /
	10 2 / 5 = ;
test: Simple math mod
	235 13 mod 1 = ;
test: Simple math /mod
	102 10 /mod - -8 = ;
test: Simple math /mod 2
	123 10 /mod 12 = ;
test: Simple math /mod 3
	123 10 /mod drop 3 = ;
test: Simple math boundary condtions
	1000000000 1 + 1000000001 = ;
test: Negatives 1
	23 -2 + 21 = ;
test: Negatives 2
	-300 -22 + -322 = ;
test: Negatives 3
	-3 2 * -6 = ;
test: Negatives 4
	-10 2 / -5 = ;
test: minmax 1
	456 123 max 456 = ;
test: minmax 1a
	123 456 max 456 = ;
test: minmax 2
	456 123 min 123 = ;
test: minmax 2a
	123 456 min 123 = ;
test: minmax 3a
	-1 1 max 1 = ;
test: minmax 3b
	1 -1 max 1 = ;
test: minmax 3c
	-1 1 min -1 = ;
test: minmax 3d
	1 -1 min -1 = ;
test: between 1a
	1 2 3 between 0 = ;
test: between 1b
	2 2 3 between -1 = ;
test: between 1c
	3 2 3 between -1 = ;
test: between 1d
	4 2 3 between 0 = ;
test: */ 1
	100 3 2 */ 150 = ;
test: */ 2
	100 3 -2 */ -150 = ;
test: negate 1
	1 negate -1 = ;
test: negate 2
	-1 negate 1 = ;
test: negate 0
	0 negate 0 = ;
test: <<
	1 3 << 8 = ;
test: >>
	8 3 >> 1 = ;
test: abs 1
	123 abs 123 = ;
test: abs 2
	-123 abs 123 = ;
test: abs 3
	0 abs 0 = ;
test: abs 4
	-1 abs 1 = ;

| BITWISE LOGIC
test: Bits 1
	" Bit logic" blab
	1 2 and 0 = ;
test: Bits 2
	1 2 or 3 = ;
test: Bits 3
	2 2 xor 0 = ;
test: Bits 4
	2 1 xor 3 = ;
test: Bits 5
	1 not 0 = ;
test: Bits 6
	0 not -1 = ;
test: Bits 7
	-1 not 0 = ;
test: Bits 8
	1 invert $fffffffe = ;

| Number conversion
test: cvt 1
	" Number conversions" blab
	2 3 '0 (p.r) " 002" cmp 0 = ;
test: cvt 2
	2 3 (.r) "   2" cmp 0 = ;
test: cvt 3
	2 (.) " 2" cmp 0 = ;
test: >digit 1
	0 >digit '0 = ;
test: >digit 2
	$a >digit 'A = ;
test: digit> 1
	'0 digit> 0 = ;
test: digit> 2
	'B digit> -1 = ;
test: digit> 2a
	hex 'B digit> decimal 11 = ;

: >number >single 0if ~doubles.>double 00; drop 2 else 1 then ;

test: cvts 1
	" 1234" >number 1 = ;
test: cvts 2
	" 1,234L" >number 2 = ;
test: cvts 3
	" 123e4" >number 0 = ;
test: cvts 4
	" 123e4" >number drop " 123e4" cmp 0 = ;

test: >single 1
	" -1" >single drop -1 = ;
test: >single 2
	" 1000" >single drop 1000 = ;
test: >single 3
	" 1,000" >single 0 = ;
test: >single 4
	" -1,000" >single 0 = ;
test: >single 5
	" $10" >single drop 16 = ;
test: >single 6
	" %10" >single drop 2 = ;
test: >single 7
	" #10" >single drop 10 = ;
test: >single 8
	" &10" >single drop 8 = ;

| Stack
test: stack 1
	" Stack manipulation" blab
	1 2 over 1 = ;
test: stack 2
	1 2 3 rot 1 = ;
test: stack 3
	1 2 3 -rot 2 = ;
test: stack 4
	1 2 swap 1 = ;
test: stack 5
	0 2 dup + 4  = ;
test: stack 6
	1 2 3 nip swap 1 = ;
test: stack 7
	1 2 3 drop 2 = ;
test: stack 8
	1 2 3 2 pick 1 = ;
test: stack 9
	1 0 ?dup drop 1 = ;
test: stack 10
	1 2 ?dup drop 2 = ;
test: stack 11
	1 2 3 tuck 2drop 3 = ;
test: stack 12
	1 2 2dup 10 -rot + 3 = ;
test: stack 13
	1 2 3 2drop 1 = ;

| Misc stuff
: ax drop ;
test: prior
	" Various" blab
	" : ax dup prior ax ; " eval
	10 20 " ax" eval 20 = ;
: ax2 3 : ay 10 * ;
test: fall-through colon
	4 ay 40 = ;

test: fall-through colon 2
	1 4 ax2 30 = ;

test: execute ay
	2 ['] ay execute 20 = ;

test: ++
	temp off
	temp ++
	temp @ 1 = ;
test: --
	temp off
	temp --
	temp @ -1 = ;
test: +!
	temp off
	10 temp +!
	5 temp +!
	temp @ 15 = ;

' swap alias myswap
test: myswap
	12 32 myswap 12 = ;
' myswap alias myswap2
13 test2: myswap2
	13 31 myswap2 13 ;

| Memory manipulation
test: ! @
	" Memory access" blab
	2 temp ! temp @ 2 = ;
test: here
	here 1 , 2 , cell+ @ 2 = ;
test: c@
	" joe" drop c@ 'j = ;
test: c!
	pad 10 0 fill
	'X pad c!
	pad c@ 'X = ;
test: w@
	$12345678 temp !
	temp w@ $5678 = ;
test: w!
	temp off
	$aabbccdd temp w!
	temp @ $ccdd = ;
test: move
	" hi there" pad swap move
	" hi there" pad 8 cmp 0 = ;
test: fill
	pad 30 $ab fill
	pad 20 + @ $abababab = ;

| Conditionals
: bigif 0if
	noop noop noop noop noop noop noop noop noop noop noop noop noop noop
	noop noop noop noop noop noop noop noop noop noop noop noop noop noop
	noop noop noop noop noop noop noop noop noop noop noop noop noop noop
	noop noop noop noop noop noop noop noop noop noop noop noop noop noop
	noop noop noop noop noop noop noop noop noop noop noop noop noop noop
	noop noop noop noop noop noop noop noop noop noop noop noop noop noop
	noop noop noop noop noop noop
	1 else
	noop noop noop noop noop noop noop noop noop noop noop noop noop noop
	noop noop noop noop noop noop noop noop noop noop noop noop noop noop
	noop noop noop noop noop noop noop noop noop noop noop noop noop noop
	noop noop noop noop noop noop noop noop noop noop noop noop noop noop
	noop noop noop noop noop noop noop noop noop noop noop noop noop noop
	noop noop noop noop noop noop noop noop noop noop noop noop noop noop
	noop noop noop noop noop noop
	0 then ;
test: bigif
	" Conditionals" blab
	1 bigif 0 = ;
test: bigif 2
	10 0 bigif 1 = ;
test: >if
	5 4 >if true else false then ;
test: >if 2
	4 5 >if false else true then ;
test: <if
	4 5 <if true else false then ;
test: =if
	5 5 =if true else false then ;

| Loops
test: doloop
	" Loops" blab
	temp off
	100 0 do temp ++ loop temp @ 100 = ;
test: doloop 2
	temp off
	10 0 do 3 2 do i j * temp ! loop loop
	temp @ 18 = ;
test: doloop 3
	temp off
	10 0 do i 5 =if leave then i temp ! loop
	temp @ 4 = ;
test: doloop 4
	0 10 0 do i 5 =if i eleave then loop 5 = ;
test: doloop 5
	3 0 0 ?do 1+ loop 1 0 ?do 1- loop  2  = ;
test: repeatwhile
	temp off
	150 repeat temp ++ 1- dup while
	temp @ 150 = ;
test: bigwhile
	temp off
	10 repeat
		noop noop noop noop noop noop noop noop noop noop noop noop noop noop
		noop noop noop noop noop noop noop noop noop noop noop noop noop noop
		noop noop noop noop noop noop noop noop noop noop noop noop noop noop
		noop noop noop
		temp ++ 1- dup
		while
	temp @ 10 = ;
test: bigloop
	temp off
	100 0 do temp ++
		noop noop noop noop noop noop noop noop noop noop noop noop noop noop
		noop noop noop noop noop noop noop noop noop noop noop noop noop noop
		noop noop
		loop
	temp @ 100 =
		;

| File IO
: testfname " testfilename" ;
: testdata " 0123456789" ;
test: file creation
	" File I/O" blab
	testfname creat >r
	ioerr @
	r> close
	0 =
	;

test: file open/rw
	testfname open/rw ioerr @ over close 0 =
	;
test: file open/rw and write
	testfname open/rw >r
	testdata r@ write ioerr @
	r> close 0 =
	;

test: file size
	testfname open/rw >r
	r@ fsize
	r> close
	10 =
	;

test: file open/r
	testfname open/r ioerr @ over close 0 =
	;

test: file read
	pad 10 0 fill
	testfname open/r >r
	pad 10 r@ read
	r> close
	10 = temp !
	pad 10 testdata cmp 0 = temp @ and
	;

test: file seek
	pad 10 0 fill
	testfname open/r >r
	5 r@ seek
	 pad 4 r@ read
	 r> close
	| pad 4 blab
	 pad c@ '5 =
	;

test: file tell
	testfname open/r >r
	5 r@ seek
	 pad 4 r@ read
	 r@ tell temp !
	 r> close
	 temp @ 9 =
	;

test: file open/r and write
	testfname open/r >r
	" ABC" r@ write
	ioerr @ 0 <> temp !
	r> close
	temp @
	;

test: file open/rw and write
	testfname open/rw >r
	" ABC" r@ write
	ioerr @ 0 = temp !
	r> close
	temp @
	;

test: file mtime
	testfname 2dup mtime temp !
	open/rw >r
	1000 ms
	" xxx" r@ write
	r> close
	temp @ testfname mtime u<
	;

test: file rename
	testfname " test.fname" rename
	ioerr @ 0 =
	;
test: file delete
	" test.fname" delete
	ioerr @ 0 =
	;

test: chdir/getcwd
	getcwd pad place
	" bin" chdir
	getcwd pad count cmp 0 <> temp !
	" .." chdir
	temp @
	;

| Strings
test: empty string
	" Strings" blab
	1
	" \" \"" eval
	0 =
	;
test: empty string 2
	1
	" "
	0 =
	;
test: lplace
	" joe" pad lplace
	" joe" pad lcount cmp 0 = ;
test: +lplace
	" bob" pad +lplace
	" joebob" pad lcount cmp 0 = ;

| Catch/throw
: c1 2 -1 throw ; : c2 4 10 throw ; : c3 11 c2 ; : c4 0 throw ;
test: catchthrow
	" Catch/throw" blab
	10 ['] c1 catch -1 = ;
test: catchthrow 2
	5 ['] c3 catch 10 = ;
test: catchthrow 3
	33 ['] c4 catch 0 = ;

| Libraries
needs random/simple
needs alg/bubblesort
needs alg/quicksort
needs alg/hsort
needs alg/insertsort

6 constant #arr
create arr 3 , 1 , 4 , 10 , 1000 , 20 ,
: mix
	#arr 10 + #arr do
		rand abs #arr mod cells arr +
		rand abs #arr mod	cells arr +					| x y -- two random array elements to exchange
		over @										| x y x@
		over @										| x y x@ y@
		-rot										| x y@ y x@
		swap !	swap !
	loop
	;
: arrok?
	#arr 1- 0do
		arr i cells + @
		arr i 1+ cells + @
		>if  unloop false ;then
	loop
	true ;
test: bsort
	mix arr #arr bsort arrok? -1 =  ;
test: hsort
	mix arr #arr hsort arrok? -1 =  ;
test: qsort
	mix arr #arr qsort arrok? -1 =  ;
test: isort
	mix arr #arr isort arrok? -1 =  ;

needs crypt/md5
create hi 'h 1, 'i 1, 10 1,
test: md5
	hi 3 md5 scratch place
	" 764EFA883DDA1E11DB47671C4A3BBD9E" scratch count cmp
	0 =
	;

needs util/eachline
: doeach >single if temp ! else 2drop then ;
test: eachline
	quote " 123
		345
		567
		"
	temp off
	['] doeach eachline temp @ 567 =
	;

needs alg/enum
100 enum: meah meah1 enum;

test: enum
	300 meah1 101 = ;

| Regression tests

: r205 0 ?do 1+ loop ;
: r205a 0 do 1+ loop ;
test: bug 205
	" Regression tests" blab
	0 -1 r205 0 = ;
test: bug 205a
	0 -1 r205a 1 = ;
: fail28 ioerr @ if rdrop 1 ;; then ;
variable fileh
: test28
	2drop
	" dummy-file" 2dup creat fail28 fileh !
	" stuff" fileh @ write fail28
	fileh @
	close fail28
	open/r
	fail28 fileh !
	pad 5 fileh @ read fail28 drop
	fileh @ close fail28
	" dummy-file" delete
	0 | indicate success
	;
test: bug 28
	123 test28 0 = ;

: dd ~doubles.>double if 1 else 0 then ;
: sd >single if 1 else 0 then ;
test: bug 52 a
	" 123456L" dd 1 = ;
test: bug 52 b
	" 123d456" dd 0 = ;
test: bug 52 c
	" 12356" sd 1 = ;
test: bug 52 d
	" 123d56" sd 0 = ;

: ifnoelse  if if 2 ( else 0 ) then  else 1 then ;
test: bug 53
	0 0 1 ifnoelse 0 = ;

test: bug 18
	reset . . . . . . . . . . . cr reset 0 0 = ;

: #20 parsews find ?dup if execute ;; then 2drop ;
test: bug 20
	0 " #20 dup " eval 0 = ;
test: bug 20a
	0 " #20 #20a " eval 0 = ;

test: bug 21
	123 invert -124 = ;

test: bug 22
	reset drop depth -1 = ;

: foo ;
test: bug 56
	123 " foo" find ?dup if 0 else 1 then  0 = ;

: 57a " : 57x abogusword ;" eval ;
test: bug 57
	123 57a	" 57x" find not
	;

test: bug 64
	1234 4 (.r) " 1234" cmp 0 = ;

: #65 ( -- ) 5 4 <if  0 noop then ;
: #65a ( -- ) 1 0 do leave loop ;
: #65b ( -- ) repeat while ;
test: bug 65
	1 #65 1 = ;
10 test2: bug 65a
	10 #65a ;
10 test2: bug 65b
	10 0 #65b ;

MAC not [IF]
| TODO: Why do 'floats' mess up on the Mac?
test: bug 80
	22
	" 1 needs ansi needs math/floats " eval 1 = ;

test: bug 81
	" needs math/floats ~floats f 123.0 1 (f.) \" 123.0\" cmp " eval 0 = ;
[THEN]

: #82 repeat 1- dup 0 <if drop 0 ;; then again 24 ;
test: bug 82
	10 #82 0 = ;

0 [IF]
test: bug 85a
	false ;
[THEN]

0 [IF]
test: bug 85b
	false ;
[ELSE]
[THEN]

1 [IF]
test: bug 85c
	true ;
[ELSE]
test: bug 85d
	false ;
[THEN]

: #107 " :: lala ; " eval ;
test: bug 107
	0 #107 1 dup 1 = ;

test: bug 108
	1 " -1.0e0" eval 1 = ;
test: bug 108a
	1 " 1.0e0" eval 1 = ;

test: bug 109
	" 2-" >single not ;

: 3d dup 2over rot ;
test: bug 115
	1 2 3 4 3d 4 = ;

test: slurp
	false " slurp-test" 2dup delete 2dup creat dup " blah" rot write close
	slurp " blah" cmp not ;

: dodah create 2 , does> @ 1+ 1+ ;
test: does
		" dodah doody 2 doody" eval
		4 = ;

variable temp100
~sys
:: temp100 on chain word? ; is word?
exit~
test: bug 100
	temp100 off
	" 23423a" eval
	temp100 @
	;

test: bug 79
	temp off
	10 0 do
		5 0 do
			i 3 =if i temp ! leave then
		loop
	loop
	temp @ 3 =
	;

test: bug 105
	44
	10 0 do 3 skip loop
	44 =
	;

test: bug 99
	22
	" test.txt" delete
	" test.txt" slurp 2drop
	22 =
	;

: a ;
: b a ;
test: tail-call
	1 ['] b c@ $e9 = ;

test: bug 116
	1234
	" : x create 0 , does> ; x y y drop " eval
	1234 = ;

: a 1 ;
: b: create , does> @execute 2 ;
' a b: b
2 test2: bug 134
	234 b ;

| test: bug 135
| 	" needs debugger 13 see see" eval 13 = ;

test: bug 136
	12 ['] noop execute 12 = ;

: setup-137 " ~floats : f=0 123. 321. f= ; : f=-1 123. 123. f= ; " eval ;
test: bug 137
	setup-137
	" 5 f=-1 -1 =" eval ;
0 test2: bug 137a
	455
	" ' f=0 temp ! " eval temp @ ;

test: bug 167
	5 1+ 6 = ;
test: bug 167a
	5 1- 4 = ;

test: bug 174
	" ~ : 174test ; to~ ~ 174test" eval
	" 174test" find not 0 =
	;

test: bug 179
	10
	" reset~ help" eval
	10 =
	;

test: bug 243
	" ~floats \" abd.\" >float" eval not ;
test: bug 243a
	" ~floats \" .qwer\" >float" eval not ;
test: bug 243b
	" ~floats \" .123eq\" >float" eval not ;

MAC not [IF]
test: bug 253
	" ~floats \" .12\" >float" eval ;
test: bug 253a
	" ~floats \" 1.12\" >float" eval ;
[THEN]

test: bug 242
	quote X
	needs date/calendar ~date
	3 1 2007 gregorian>fixed
	fixed>gregorian
	X eval
	over 1 =
	;

test: bug 229
	123
	" 1." eval
	123 = ;

: 215a ['] asdsasdfsfs ;
test: bug 215
	215a 0 = ;

test: bug 266
	" '' ~sys.appstart" eval not not ;

: skippy 3 0do 1+ 1 skip loop ;
test: bug 190
	10 skippy 12 = ;
| parse problem
: b273test '/ parse 2drop '/ parse ;
: b273 " b273test abc/def/ drop c@ 'd =" eval ;
test: bug 273
	false b273 ;
| parse problem
|
: b292 true ;
test: bug 292
	false b292 ;

: badparse quote @
	Hi there, bubba
@ ;
test: parse badness
	badparse + 1- c@ '@ <> ;

: a '/ parse ;
: badparse2 " a xy" eval ;
test: more parse badness
	badparse2 2 = ;

| defer 300.x
| test: bug 300a
| 	" make 300.x 100 ; " eval
| 	200 300.x 100 = ;

| test: bug 300b
| 	" make 300.x 300 ; " eval
| 	200 300.x 300 = ;

| test: bug 300c
| 	" undo 300.x " eval
| 	200 300.x 100 = ;

| test: make/undo depth
| 	depth
| 	" : 300.a make 300.x 123 ; " eval
| 	" : 300.b undo 300.x ; " eval
| 	depth 1- - 0 = ;

| test: bug 300d
| 	" 300.a " eval
| 	200 300.x 123 = ;
| test: bug 300e
| 	" 300.b " eval
| 	200 300.x 100 = ;

test: bug 236a
	" 0 [IF] 1 [ELSE] 2 [THEN]" eval 2 = ;
test: bug 236b
	" 1 [IF] 1 [ELSE] 2 [THEN]" eval 1 = ;
test: bug 236c
	" 0 [IF] 1 [IF] 10 [ELSE] 20 [THEN] [ELSE] 1 [IF] 30 [ELSE] 40 [THEN] [THEN]" eval 30 = ;
test: bug 236d
	" 1 [IF] 1 [IF] 10 [ELSE] 20 [THEN] [ELSE] 1 [IF] 30 [ELSE] 40 [THEN] [THEN]" eval 10 = ;
test: bug 236e
	" 0 [IF] 1 [IF] 10 [ELSE] 20 [THEN] [ELSE] 0 [IF] 30 [ELSE] 40 [THEN] [THEN]" eval 40 = ;
test: bug 236f
	" 1 [IF] 0 [IF] 10 [ELSE] 20 [THEN] [ELSE] 1 [IF] 30 [ELSE] 40 [THEN] [THEN]" eval 20 = ;
test: bug236g
	" 1 [IF] 3 [THEN]" eval 3 = ;
test: bug236h
	" 4 0 [IF] 3 [THEN]" eval 4 = ;
test: bug236i
	~priv.if-flag stack-size  0 = ;

test: bug352a
	" abc" " abc" cmp 0 = ;
test: bug352b
 	" " " cmp" cmp not 0 = ;
test: bug352c
 	0 0 " cmp" cmp not 0 = ;
test: bug352d
 	" cmp" 0 0 cmp not 0 = ;
test: bug352e
 	" cmp" " " cmp not 0 = ;
test: bug352aI
	" abc" " abc" cmpi 0 = ;
test: bug352bI
 	" " " cmp" cmpi not 0 = ;
test: bug352cI
 	0 0 " cmp" cmpi not 0 = ;
test: bug352dI
 	" cmp" 0 0 cmpi not 0 = ;
test: bug352eI
 	" cmp" " " cmpi not 0 = ;

test: bug369a
	" abc1" " abc2" cmpi 0 <> ;
test: bug369b
	" [a" " {a" cmpi 0 <> ;

test: bug369b-1
	'[ lc '[ = ;
test: bug369b-2
	'A lc 'a = ;
test: bug369b-3
	'a lc 'a = ;
test: bug369b-4
	'Z lc 'z = ;
test: bug369b-5
	'z lc 'z = ;

: teststr " reva" ;
create bug374-buf 20 allot
: bug374 'x parse bug374-buf place ;
test: bug374
	" bug374 revax " eval
	bug374-buf count
	teststr cmp 0 = ; | "

1024 1024 * 8 *  constant FILESIZE
variable thebuffer
: teststring " Rar" ;
test: bug359
	FILESIZE allocate thebuffer  !
	thebuffer @ FILESIZE 'R fill
	thebuffer @ FILESIZE 3 /string teststring search
	0 =
	;

test: tick1
	123 " ' this-doesnt-exist" eval drop 123 =
	;
test: tick2
	123 " ' this-doesnt-exist" eval 0 =
	;

WIN [IF]
needs os/shell
: maketestfile
	" test344.bat" 2dup delete creat >r
	" @reva -e \"123 . bye\" " r@ write r> close ;

: spawnReva " cmd /c test344.bat" shell$ ;
test: bug344
	maketestfile
	spawnReva blab
	spawnReva " 123" cmp 0 = ;
[THEN]

test bye


C-----------------------------------------------------------------------
      SUBROUTINE SPLAT(IDRT,JMAX,SLAT,WLAT)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:  SPLAT      COMPUTE LATITUDE FUNCTIONS
C   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-02-20
C
C ABSTRACT: COMPUTES COSINES OF COLATITUDE AND GAUSSIAN WEIGHTS
C           FOR ONE OF THE FOLLOWING SPECIFIC GLOBAL SETS OF LATITUDES.
C             GAUSSIAN LATITUDES (IDRT=4)
C             EQUALLY-SPACED LATITUDES INCLUDING POLES (IDRT=0)
C             EQUALLY-SPACED LATITUDES EXCLUDING POLES (IDRT=256)
C           THE GAUSSIAN LATITUDES ARE LOCATED AT THE ZEROES OF THE
C           LEGENDRE POLYNOMIAL OF THE GIVEN ORDER.  THESE LATITUDES
C           ARE EFFICIENT FOR REVERSIBLE TRANSFORMS FROM SPECTRAL SPACE.
C           (ABOUT TWICE AS MANY EQUALLY-SPACED LATITUDES ARE NEEDED.)
C           THE WEIGHTS FOR THE EQUALLY-SPACED LATITUDES ARE BASED ON
C           ELLSAESSER (JAM,1966).  (NO WEIGHT IS GIVEN THE POLE POINT.)
C           NOTE THAT WHEN ANALYZING GRID TO SPECTRAL IN LATITUDE PAIRS,
C           IF AN EQUATOR POINT EXISTS, ITS WEIGHT SHOULD BE HALVED.
C           THIS VERSION INVOKES THE IBM ESSL MATRIX SOLVER.
C
C PROGRAM HISTORY LOG:
C   96-02-20  IREDELL
C   97-10-20  IREDELL  ADJUST PRECISION
C   98-06-11  IREDELL  GENERALIZE PRECISION USING FORTRAN 90 INTRINSIC
C 1998-12-03  IREDELL  GENERALIZE PRECISION FURTHER
C 1998-12-03  IREDELL  USE BLAS CALLS
C 2007-04-26  YANG     FOR EQUALLY-SPACED GRID EXCLUDING POLES, CHANGE
c                      DIMENSION OF A FEW ARRAYS
C 2008-04-08  Todling  Replaced errexit() with exit()
C
C USAGE:    CALL SPLAT(IDRT,JMAX,SLAT,WLAT)
C
C   INPUT ARGUMENT LIST:
C     IDRT     - INTEGER GRID IDENTIFIER
C                (IDRT=4 FOR GAUSSIAN GRID,
C                 IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES,
C                 IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES)
C     JMAX     - INTEGER NUMBER OF LATITUDES.
C
C   OUTPUT ARGUMENT LIST:
C     SLAT     - REAL (JMAX) SINES OF LATITUDE.
C     WLAT     - REAL (JMAX) GAUSSIAN WEIGHTS.
C
C SUBPROGRAMS CALLED:
C   DGEF         MATRIX FACTORIZATION
C   DGES         MATRIX SOLVER
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C
C$$$
      REAL SLAT(JMAX),WLAT(JMAX)
      INTEGER,PARAMETER:: KD=SELECTED_REAL_KIND(15,45)
      REAL(KIND=KD):: PK(JMAX/2),PKM1(JMAX/2),PKM2(JMAX/2)
      REAL(KIND=KD):: SLATD(JMAX/2),SP,SPMAX,EPS=10.*EPSILON(SP)
      PARAMETER(JZ=50)
      REAL BZ(JZ)
      DATA BZ        / 2.4048255577,  5.5200781103,
     $  8.6537279129, 11.7915344391, 14.9309177086, 18.0710639679,
     $ 21.2116366299, 24.3524715308, 27.4934791320, 30.6346064684,
     $ 33.7758202136, 36.9170983537, 40.0584257646, 43.1997917132,
     $ 46.3411883717, 49.4826098974, 52.6240518411, 55.7655107550,
     $ 58.9069839261, 62.0484691902, 65.1899648002, 68.3314693299,
     $ 71.4729816036, 74.6145006437, 77.7560256304, 80.8975558711,
     $ 84.0390907769, 87.1806298436, 90.3221726372, 93.4637187819,
     $ 96.6052679510, 99.7468198587, 102.888374254, 106.029930916,
     $ 109.171489649, 112.313050280, 115.454612653, 118.596176630,
     $ 121.737742088, 124.879308913, 128.020877005, 131.162446275,
     $ 134.304016638, 137.445588020, 140.587160352, 143.728733573,
     $ 146.870307625, 150.011882457, 153.153458019, 156.295034268 /
      REAL(8) DLT
      REAL(8) AWORK((JMAX+1)/2,((JMAX+1)/2)),BWORK(((JMAX+1)/2))
      INTEGER(4):: NRHS,LDA,LDB,INFO
      INTEGER(4):: JHE,JHO,J0
      INTEGER(4) IPVT((JMAX+1)/2)
      PARAMETER(PI=3.14159265358979,C=(1.-(2./PI)**2)*0.25)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  GAUSSIAN LATITUDES
      J0=0
      IF(IDRT.EQ.4) THEN
        JH=JMAX/2
        JHE=(JMAX+1)/2
        R=1./SQRT((JMAX+0.5)**2+C)
        DO J=1,MIN(JH,JZ)
          SLATD(J)=COS(BZ(J)*R)
        ENDDO
        DO J=JZ+1,JH
          SLATD(J)=COS((BZ(JZ)+(J-JZ)*PI)*R)
        ENDDO
        SPMAX=1.
        DO WHILE(SPMAX.GT.EPS)
          SPMAX=0.
          DO J=1,JH
            PKM1(J)=1.
            PK(J)=SLATD(J)
          ENDDO
          DO N=2,JMAX
            DO J=1,JH
              PKM2(J)=PKM1(J)
              PKM1(J)=PK(J)
              PK(J)=((2*N-1)*SLATD(J)*PKM1(J)-(N-1)*PKM2(J))/N
            ENDDO
          ENDDO
          DO J=1,JH
            SP=PK(J)*(1.-SLATD(J)**2)/(JMAX*(PKM1(J)-SLATD(J)*PK(J)))
            SLATD(J)=SLATD(J)-SP
            SPMAX=MAX(SPMAX,ABS(SP))
          ENDDO
        ENDDO
CDIR$ IVDEP
        DO J=1,JH
          SLAT(J)=SLATD(J)
          WLAT(J)=(2.*(1.-SLATD(J)**2))/(JMAX*PKM1(J))**2
          SLAT(JMAX+1-J)=-SLAT(J)
          WLAT(JMAX+1-J)=WLAT(J)
        ENDDO
        IF(JHE.GT.JH) THEN
          SLAT(JHE)=0.
          WLAT(JHE)=2./JMAX**2
          DO N=2,JMAX,2
            WLAT(JHE)=WLAT(JHE)*N**2/(N-1)**2
          ENDDO
        ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  EQUALLY-SPACED LATITUDES INCLUDING POLES
      ELSEIF(IDRT.EQ.0) THEN
        JH=JMAX/2
        JHE=(JMAX+1)/2
        JHO=JHE-1
        DLT=PI/(JMAX-1)
        SLAT(1)=1.
        DO J=2,JH
          SLAT(J)=COS((J-1)*DLT)
        ENDDO
        DO JS=1,JHO
          DO J=1,JHO
            AWORK(JS,J)=COS(2*(JS-1)*J*DLT)
          ENDDO
        ENDDO
        DO JS=1,JHO
          BWORK(JS)=-1./(4*(JS-1)**2-1)
        ENDDO
!cjfe   CALL DGEF(AWORK,JHE,JHO,IPVT)
!cjfe   CALL DGES(AWORK,JHE,JHO,IPVT,BWORK,J0)
	NRHS=1
	LDA=size(AWORK,1)
	LDB=size(BWORK,1)
        CALL DGESV(JHO,NRHS,AWORK,LDA,IPVT,BWORK,LDB,INFO)
	  if(INFO/=0) call die_at_dgesv_messages_(INFO)
        WLAT(1)=0.
        DO J=1,JHO
          WLAT(J+1)=BWORK(J)
        ENDDO
CDIR$ IVDEP
        DO J=1,JH
          SLAT(JMAX+1-J)=-SLAT(J)
          WLAT(JMAX+1-J)=WLAT(J)
        ENDDO
        IF(JHE.GT.JH) THEN
          SLAT(JHE)=0.
          WLAT(JHE)=2.*WLAT(JHE)
        ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  EQUALLY-SPACED LATITUDES EXCLUDING POLES
      ELSEIF(IDRT.EQ.256) THEN
        JH=JMAX/2
        JHE=(JMAX+1)/2
        JHO=JHE
        DLT=PI/(JMAX+1)
        DO J=1,JH
          SLAT(J)=COS(J*DLT)
        ENDDO
        DO JS=1,JHO
          DO J=1,JHO
            AWORK(JS,J)=COS(2*(JS-1)*J*DLT)
          ENDDO
        ENDDO
        DO JS=1,JHO
          BWORK(JS)=-1./(4*(JS-1)**2-1)
        ENDDO
!cjfe   CALL DGEF(AWORK1,JHE,JHO,IPVT)
!cjfe   CALL DGES(AWORK1,JHE,JHO,IPVT,BWORK,J0)
	NRHS=1
	LDA=size(AWORK,1)
	LDB=size(BWORK,1)
        CALL DGESV(JHO,NRHS,AWORK,LDA,IPVT,BWORK,LDB,INFO)
	  if(INFO/=0) call die_at_dgesv_messages_(INFO)
        DO J=1,JHO
          WLAT(J)=BWORK(J)
        ENDDO
CDIR$ IVDEP
        DO J=1,JH
          SLAT(JMAX+1-J)=-SLAT(J)
          WLAT(JMAX+1-J)=WLAT(J)
        ENDDO
        IF(JHE.GT.JH) THEN
          SLAT(JHE)=0.
          WLAT(JHE)=2.*WLAT(JHE)
        ENDIF
      ENDIF
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      RETURN
	contains
	subroutine die_at_dgesv_messages_(INFO)
	integer(4),intent(in) :: INFO

	integer(4),parameter :: IEXIT=2

	if(INFO<0) then
	  write(*,*) "NCEP_sp/splat(): >>>> ERROR <<<< the ",
     &		-INFO,"-th argument had an illegal value"
	endif

	if(INFO>0) then
	  write(*,*) "NCEP_sp/splat(): >>>> ERROR <<<< U(",
     &		INFO,",",INFO,") is singular"
	endif

	call exit(IEXIT)
	end subroutine die_at_dgesv_messages_
      END


!Modified version of Komatsu's CRL function
!(http://www.mpa-garching.mpg.de/~komatsu/crl/)
!compute_mf_shethtormen for CosmoSIS, NR removed - EJ

MODULE compute_mf_shethtormen
  USE linearpk
  USE mf_shethtormen
  USE sigma
  USE interface_tools
  IMPLICIT none
  double precision :: deltac=1.6865d0,dndlnRh,dndlnMh

        contains

        SUBROUTINE compute_massfunction(k,p,MassF,nr)
                USE linearpk
                USE sigma
                USE interface_tools
                double precision :: lnnu,dlnnudlnRh,Mh
                double precision :: lnsigma2,dlnsigma2dlnRh
                real :: Rh,lnRh
                real(dl) :: step
                integer :: int_lnRh
                integer :: n, nr,ii,nn
                real(dl),  dimension(:) :: k
                real(dl),  dimension(:) :: p
                type(massfunction) :: MassF
                double precision :: lnRh_1
                n=size(k)
                CALL Open_LinearPk(k,p,n)
                !fit sigma^2(R) to Chebyshev polynomials
                CALL compute_sigma2
                CALL close_linearpk

                step = 0.01
                nn= nint((lnR2 - lnR1)/step) !control variable for DO loop
                !allocate space for massfunction
                MassF%num_r = nr
                call allocate_mf(MassF)

                lnRh = lnR1
                DO ii=1,nn+1
                        if(lnRh>lnR2) exit
                        lnRh_1 = (2.0D+00*lnRh - lnR1 - lnR2)/(lnR2 - lnR1) !interval [-1,1]
                        CALL echebser0(DBLE(lnRh_1), c, ndim, lnsigma2)
                        CALL echebser0(DBLE(lnRh_1), cder, ndim, dlnsigma2dlnRh)
                        lnnu = 2d0*dlog(deltac)-dble(lnsigma2) ! ln(nu)
                        dlnnudlnRh = -dble(dlnsigma2dlnRh)     ! dln(nu)/dlnRh
                        Rh=exp(lnRh) ! h^-1 Mpc
                        dndlnRh = (3d0/4d0/3.1415926535d0)*dlnnudlnRh*mf(lnnu)/dble(Rh)**3d0
                        MassF%R_h(ii) = Rh
                        MassF%dn_dlnRh(ii) = dndlnRh
                        dndlnMh = dndlnRh/3d0 ! in units of h^3 Mpc^-3
                        Mh = (4d0*3.1415926535d0/3d0)*2.775d11*Rh**3d0 ! in units of omega_matter h^-1 M_solar
                        MassF%M_h(ii) = Mh
                        MassF%dn_dlnMh(ii) = dndlnMh
                        lnRh = lnR1 + ii*step
                END DO
        END SUBROUTINE compute_massfunction

END MODULE compute_mf_shethtormen


!=======================================================================
!    			k-eps model
!	includes low-Re near wall damping (as in Lam and Bremhorst, 1981)
!			Bruño Fraga Bugallo
!			Cardiff 2016
!=======================================================================
!##########################################################################
        subroutine eddyv_keps
!##########################################################################
        use vars
        use multidata
        implicit none
        integer :: i,j,k,rk
        integer :: ib,is,ie,js,je,ks,ke
        double precision :: cmu
        double precision :: rrey,dx,dy,dz
        double precision :: alfark(3),strain

        alfark(1)=1./3.
        !alfark(1)=1./4.
        alfark(2)=0.5
       ! alfark(2)=0.4
        alfark(3)=1.0
       ! alfark(3)=0.8
	  !alfark(4)=1.0

	  !call exchange(11)
	  !call exchange(22)
	  !call exchange(33)

       do rk=1,3
	 	call eddyv_k(alfark(rk))
		call eddyv_eps(alfark(rk))
	 enddo

       rrey=1.0/Re
       cmu=0.09

       do ib=1,nbp

       is=dom(ib)%isp; ie=dom(ib)%iep
       js=dom(ib)%jsp; je=dom(ib)%jep
       ks=dom(ib)%ksp; ke=dom(ib)%kep

	do k=ks,ke ; do j=js,je ; do i=is,ie

!	if (abs(dom(ib)%eps(i,j,k)).lt.1.0d-07) then
!		dom(ib)%eps(i,j,k)=1.0d-07
!	endif

!        if (L_LSM) rrey=dom(ib)%mu(i,j,k)/dom(ib)%dens(i,j,k)

        	dom(ib)%vis(i,j,k) = rrey +
     &	cmu*dom(ib)%ksgs(i,j,k)**2.0/dom(ib)%eps(i,j,k)				!laminar + eddy viscosity

        	dom(ib)%vis(i,j,k) = min(dom(ib)%vis(i,j,k),
     &	0.33*dom(ib)%ksgs(i,j,k)*sqrt(1.5/strain(i,j,k)))
	enddo ; enddo ; enddo

	     call exchange(7)

           dx=dom(ib)%dx
           dy=dom(ib)%dy
           dz=dom(ib)%dz

!..........................................................................
!=== West ===> ..  4=wall  ..   1=Inlet
!..........................................................................
        if (dom(ib)%iprev.lt.0) then
           if (dom(ib)%bc_west.eq.4) then
              do k=ks-1,ke+1
                 do j=js-1,je+1
                    dom(ib)%vis(is,j,k)= rrey
                    dom(ib)%vis(is-1,j,k)= dom(ib)%vis(is,j,k)
                 end do
              end do
           else if (dom(ib)%bc_west.eq.1) then
              do k=ks-1,ke+1
                 do j=js-1,je+1
                    dom(ib)%vis(is-1,j,k)= dom(ib)%vis(is,j,k)
                 end do
              end do
           else if (dom(ib)%bc_west.ge.63) then
	     call wall_function(1,dom(ib)%bc_west)
              do k=ks-1,ke+1
                 do j=js-1,je+1
                    !dom(ib)%vis(is,j,k)= dom(ib)%tauww2(j,k)*dx		!m2/s
                    dom(ib)%vis(is-1,j,k)= dom(ib)%vis(is,j,k)
                 end do
              end do
           else if (dom(ib)%bc_west.eq.61.or.dom(ib)%bc_west.eq.62) then
	     call log_law(1,dom(ib)%bc_west)
              do k=ks-1,ke+1
                 do j=js-1,je+1
                    !dom(ib)%vis(is,j,k)= dom(ib)%tauww2(j,k)*dx		!m2/s
                    dom(ib)%vis(is-1,j,k)= dom(ib)%vis(is,j,k)
                 end do
              end do
           else
              do k=ks-1,ke+1
                 do j=js-1,je+1
                    dom(ib)%vis(is-1,j,k)= dom(ib)%vis(is,j,k)
                 end do
              end do
           end if
        else
           do k=ks-1,ke+1
              do j=js-1,je+1
                 dom(ib)%vis(is-1,j,k)= dom(ib)%vis(is,j,k)
              end do
           end do
        end if
!..........................................................................
!=== East ===> ..  4=wall  ..   2=Outflow
!..........................................................................
        if (dom(ib)%inext.lt.0) then
           if (dom(ib)%bc_east.eq.4) then
              do k=ks-1,ke+1
                 do j=js-1,je+1
                    dom(ib)%vis(ie,j,k)= rrey
                    dom(ib)%vis(ie+1,j,k)= dom(ib)%vis(ie,j,k)
                 end do
              end do
           else if (dom(ib)%bc_east.eq.2) then
              do k=ks-1,ke+1
                 do j=js-1,je+1
                    dom(ib)%vis(ie+1,j,k)= dom(ib)%vis(ie,j,k)
                 end do
              end do
           else if (dom(ib)%bc_east.ge.63) then
	     call wall_function(2,dom(ib)%bc_east)
              do k=ks-1,ke+1
                 do j=js-1,je+1
                    !dom(ib)%vis(ie,j,k)= dom(ib)%tauwe2(j,k)*dx		!m2/s
                    dom(ib)%vis(ie+1,j,k)= dom(ib)%vis(ie,j,k)
                 end do
              end do
           else if (dom(ib)%bc_east.eq.61.or.dom(ib)%bc_east.eq.62) then
	     call log_law(2,dom(ib)%bc_east)
              do k=ks-1,ke+1
                 do j=js-1,je+1
                    !dom(ib)%vis(ie,j,k)= dom(ib)%tauwe2(j,k)*dx		!m2/s
                    dom(ib)%vis(ie+1,j,k)= dom(ib)%vis(ie,j,k)
                 end do
              end do
           else
              do k=ks-1,ke+1
                 do j=js-1,je+1
                    dom(ib)%vis(ie+1,j,k)= dom(ib)%vis(ie,j,k)
                 end do
              end do
           end if
        else
           do k=ks-1,ke+1
              do j=js-1,je+1
                 dom(ib)%vis(ie+1,j,k)= dom(ib)%vis(ie,j,k)
              end do
           end do
        end if
!..........................................................................
!=== South ===> ..   4=wall ..   3=Symmetry
!..........................................................................
        if (dom(ib)%jprev.lt.0) then
           if (dom(ib)%bc_south.eq.4) then
              do k=ks-1,ke+1
                 do i=is-1,ie+1
                    dom(ib)%vis(i,js,k)= rrey
                    dom(ib)%vis(i,js-1,k)= dom(ib)%vis(i,js,k)
                 end do
              end do
           else if (dom(ib)%bc_south.ge.63) then
	     call wall_function(3,dom(ib)%bc_south)
              do k=ks-1,ke+1
                 do i=is-1,ie+1
                   ! dom(ib)%vis(i,js,k)= dom(ib)%tauws2(i,k)*dy		!m2/s
                    dom(ib)%vis(i,js-1,k)= dom(ib)%vis(i,js,k)
                 end do
              end do
           else if(dom(ib)%bc_south.eq.61.or.dom(ib)%bc_south.eq.62)then
	     call log_law(3,dom(ib)%bc_south)
              do k=ks-1,ke+1
                 do i=is-1,ie+1
                    !dom(ib)%vis(i,js,k)= dom(ib)%tauws2(i,k)*dy		!m2/s
                    dom(ib)%vis(i,js-1,k)= dom(ib)%vis(i,js,k)
                 end do
              end do
           else
              do k=ks-1,ke+1
                 do i=is-1,ie+1
                    dom(ib)%vis(i,js-1,k)= dom(ib)%vis(i,js,k)
                 end do
              end do
           end if
        else
           do k=ks-1,ke+1
              do i=is-1,ie+1
                 dom(ib)%vis(i,js-1,k)= dom(ib)%vis(i,js,k)
              end do
           end do
        end if
!..........................................................................
!=== North ===>  ..   4=wall ..   44=moving wall ..  3=Symmetry
!..........................................................................
        if (dom(ib)%jnext.lt.0) then
           if (dom(ib)%bc_north.eq.4) then
              do k=ks-1,ke+1
                 do i=is-1,ie+1
                    dom(ib)%vis(i,je,k) = rrey
                    dom(ib)%vis(i,je+1,k) =  dom(ib)%vis(i,je,k)
                 end do
              end do
           else if (dom(ib)%bc_north.eq.3) then
              do k=ks-1,ke+1
                 do i=is-1,ie+1
                    dom(ib)%vis(i,je+1,k) =  dom(ib)%vis(i,je,k)
                 end do
              end do
           else if (dom(ib)%bc_north.ge.63) then
	     call wall_function(4,dom(ib)%bc_north)
              do k=ks-1,ke+1
                 do i=is-1,ie+1
                   ! dom(ib)%vis(i,je,k)= dom(ib)%tauwn2(i,k)*dy		!m2/s
                    dom(ib)%vis(i,je+1,k) =  dom(ib)%vis(i,je,k)
                 end do
              end do
           else if(dom(ib)%bc_north.eq.61.or.dom(ib)%bc_north.eq.62)then
	     call log_law(4,dom(ib)%bc_north)
              do k=ks-1,ke+1
                 do i=is-1,ie+1
                  !  dom(ib)%vis(i,je,k)= dom(ib)%tauwn2(i,k)*dy		!m2/s
                    dom(ib)%vis(i,je+1,k) =  dom(ib)%vis(i,je,k)
                 end do
              end do
           else
              do k=ks-1,ke+1
                 do i=is-1,ie+1
                    dom(ib)%vis(i,je+1,k) =  dom(ib)%vis(i,je,k)
                 end do
              end do
           end if
        else
           do k=ks-1,ke+1
              do i=is-1,ie+1
                 dom(ib)%vis(i,je+1,k) =  dom(ib)%vis(i,je,k)
              end do
           end do
        end if
!..........................................................................
!=== Bottom ===> ..   4=wall ..   3=Symmetry
!..........................................................................
        if (dom(ib)%kprev.lt.0) then
           if (dom(ib)%bc_bottom.eq.4) then
              do j=js-1,je+1
                 do i=is-1,ie+1
                    dom(ib)%vis(i,j,ks)= rrey
                    dom(ib)%vis(i,j,ks-1)= dom(ib)%vis(i,j,ks)
                 end do
              end do
           else if (dom(ib)%bc_bottom.eq.3) then
              do j=js-1,je+1
                 do i=is-1,ie+1
                    dom(ib)%vis(i,j,ks-1)= dom(ib)%vis(i,j,ks)
                 end do
              end do
           else if (dom(ib)%bc_bottom.ge.63) then
	     call wall_function(5,dom(ib)%bc_bottom)
              do j=js-1,je+1
                 do i=is-1,ie+1
                   ! dom(ib)%vis(i,j,ks)= dom(ib)%tauwb2(i,j)*dz
                    dom(ib)%vis(i,j,ks-1)= dom(ib)%vis(i,j,ks)
                 end do
              end do
           else if(dom(ib)%bc_bottom.eq.61.or.
     &					dom(ib)%bc_bottom.eq.62)then
	     call log_law(5,dom(ib)%bc_bottom)
              do j=js-1,je+1
                 do i=is-1,ie+1
                  !  dom(ib)%vis(i,j,ks)= dom(ib)%tauwb2(i,j)*dz
                    dom(ib)%vis(i,j,ks-1)= dom(ib)%vis(i,j,ks)
                 end do
              end do
           else
              do j=js-1,je+1
                 do i=is-1,ie+1
                    dom(ib)%vis(i,j,ks-1)= dom(ib)%vis(i,j,ks)
                 end do
              end do
           end if
        else
           do j=js-1,je+1
              do i=is-1,ie+1
                 dom(ib)%vis(i,j,ks-1)= dom(ib)%vis(i,j,ks)
              end do
           end do
        end if
!..........................................................................
!=== Top ===>  ..   4=wall ..     3=Symmetry
!..........................................................................
        if (dom(ib)%knext.lt.0) then
           if (dom(ib)%bc_top.eq.4) then
              do j=js-1,je+1
                 do i=is-1,ie+1
                    dom(ib)%vis(i,j,ke)   = rrey
                    dom(ib)%vis(i,j,ke+1)   = dom(ib)%vis(i,j,ke)
                 end do
              end do
           else if (dom(ib)%bc_top.eq.3) then
              do j=js-1,je+1
                 do i=is-1,ie+1
                    dom(ib)%vis(i,j,ke+1)   = dom(ib)%vis(i,j,ke)
                 end do
              end do
           else if (dom(ib)%bc_top.ge.63) then
	     call wall_function(6,dom(ib)%bc_top)
              do j=js-1,je+1
                 do i=is-1,ie+1
                   ! dom(ib)%vis(i,j,ke)= dom(ib)%tauwt2(i,j)*dz
                    dom(ib)%vis(i,j,ke+1)   = dom(ib)%vis(i,j,ke)
                 end do
              end do
           else if(dom(ib)%bc_top.eq.61.or.
     &					dom(ib)%bc_top.eq.62)then
	     call log_law(6,dom(ib)%bc_top)
              do j=js-1,je+1
                 do i=is-1,ie+1
                   ! dom(ib)%vis(i,j,ke)   = dom(ib)%tauwt2(i,j)*dz
                    dom(ib)%vis(i,j,ke+1)   = dom(ib)%vis(i,j,ke)
                 end do
              end do
           else
              do j=js-1,je+1
                 do i=is-1,ie+1
                    dom(ib)%vis(i,j,ke+1)   = dom(ib)%vis(i,j,ke)
                 end do
              end do
           end if
        else
           do j=js-1,je+1
              do i=is-1,ie+1
                 dom(ib)%vis(i,j,ke+1)   = dom(ib)%vis(i,j,ke)
              end do
           end do
        end if

        end do

        return
        end subroutine eddyv_keps

!##########################################################################
        subroutine eddyv_k(alfark)
!##########################################################################
        use vars
        use multidata
        implicit none
        integer :: i,j,k
        integer :: ib,is,ie,js,je,ks,ke
        double precision :: dukdx,dvkdy,dwkdz,kp,km,ku,kc,kd,b_r
        double precision :: awT,aeT,asT,anT,abT,atT,apT
        double precision :: dxx,dyy,dzz,vsgs
        double precision :: visc_w,visc_e,visc_s,visc_n,visc_b,visc_t
        double precision :: sigmak,cmu
        double precision :: rrey,conv,diff,prod,other
        double precision :: alfark
	  double precision :: strain

        rrey=1.0/Re
        sigmak=1.00
	  cmu = 0.09

        do ib=1,nbp

              do k=1,dom(ib)%ttc_k
              do i=1,dom(ib)%ttc_i
              do j=1,dom(ib)%ttc_j
                 dom(ib)%ksgso(i,j,k)=dom(ib)%ksgs(i,j,k)
                 dom(ib)%epso(i,j,k)=dom(ib)%eps(i,j,k)
			if (dom(ib)%epso(i,j,k).lt.1.0d-07) then
				dom(ib)%epso(i,j,k)=1.0d-07
			endif
			if (dom(ib)%ksgso(i,j,k).lt.1.0d-07) then
				dom(ib)%ksgso(i,j,k)=1.0d-07
			endif
              end do
              end do
              end do

	!if (dom_id(ib).eq.8) then
	!write(6,*)'k',dom(ib)%ksgso(20,20,20)
	!write(6,*)'eps',dom(ib)%epso(20,20,20)
	!write(6,*)'vis',dom(ib)%vis(20,20,20)
	!endif

        dxx=dom(ib)%dx*dom(ib)%dx
        dyy=dom(ib)%dy*dom(ib)%dy
        dzz=dom(ib)%dz*dom(ib)%dz

        is=dom(ib)%isp; ie=dom(ib)%iep
        js=dom(ib)%jsp; je=dom(ib)%jep
        ks=dom(ib)%ksp; ke=dom(ib)%kep

        do k=ks,ke
           do j=js,je
              do i=is,ie

        vsgs=cmu*dom(ib)%ksgso(i,j,k)**2.0/dom(ib)%epso(i,j,k)		!eddy viscosity based on t-1

        prod=0.8*2.0*vsgs*strain(i,j,k)

	  prod=min(prod,20.*dom(ib)%epso(i,j,k))

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
        if(dom(ib)%uoo(i-1,j,k).gt.0.0) then
           ku=dom(ib)%ksgso(i-2,j,k)
           kc=dom(ib)%ksgso(i-1,j,k)
           kd=dom(ib)%ksgso(i,j,k)
           b_r=max(0.0,
     & min(2.0*((kd-kc)/(kc-ku)),0.75*((kd-kc)/(kc-ku))+0.25,4.0))
           km=kc+0.5*b_r*(kc-ku)
        else if(dom(ib)%uoo(i-1,j,k).lt.0.0) then
           ku=dom(ib)%ksgso(i+1,j,k)
           kc=dom(ib)%ksgso(i,j,k)
           kd=dom(ib)%ksgso(i-1,j,k)
           b_r=max(0.0,
     & min(2.0*((kd-kc)/(kc-ku)),0.75*((kd-kc)/(kc-ku))+0.25,4.0))
           km=kc+0.5*b_r*(kc-ku)
        else
           km=0.5*(dom(ib)%ksgso(i,j,k)+dom(ib)%ksgso(i-1,j,k))
        end if
        if(dom(ib)%uoo(i,j,k).gt.0.0) then
           ku=dom(ib)%ksgso(i-1,j,k)
           kc=dom(ib)%ksgso(i,j,k)
           kd=dom(ib)%ksgso(i+1,j,k)
           b_r=max(0.0,
     & min(2.0*((kd-kc)/(kc-ku)),0.75*((kd-kc)/(kc-ku))+0.25,4.0))
           kp=kc+0.5*b_r*(kc-ku)
        else if(dom(ib)%uoo(i,j,k).lt.0.0) then
           ku=dom(ib)%ksgso(i+2,j,k)
           kc=dom(ib)%ksgso(i+1,j,k)
           kd=dom(ib)%ksgso(i,j,k)
           b_r=max(0.0,
     & min(2.0*((kd-kc)/(kc-ku)),0.75*((kd-kc)/(kc-ku))+0.25,4.0))
           kp=kc+0.5*b_r*(kc-ku)
        else
           kp=0.5*(dom(ib)%ksgso(i,j,k)+dom(ib)%ksgso(i+1,j,k))
        end if
        dukdx=(dom(ib)%uoo(i,j,k)*kp-dom(ib)%uoo(i-1,j,k)*km)
     &	/dom(ib)%dx
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        if(dom(ib)%voo(i,j-1,k).gt.0.0) then
           ku=dom(ib)%ksgso(i,j-2,k)
           kc=dom(ib)%ksgso(i,j-1,k)
           kd=dom(ib)%ksgso(i,j,k)
           b_r=max(0.0,
     & min(2.0*((kd-kc)/(kc-ku)),0.75*((kd-kc)/(kc-ku))+0.25,4.0))
           km=kc+0.5*b_r*(kc-ku)
        else if(dom(ib)%voo(i,j-1,k).lt.0.0) then
           ku=dom(ib)%ksgso(i,j+1,k)
           kc=dom(ib)%ksgso(i,j,k)
           kd=dom(ib)%ksgso(i,j-1,k)
           b_r=max(0.0,
     & min(2.0*((kd-kc)/(kc-ku)),0.75*((kd-kc)/(kc-ku))+0.25,4.0))
           km=kc+0.5*b_r*(kc-ku)
        else
           km=0.5*(dom(ib)%ksgso(i,j,k)+dom(ib)%ksgso(i,j-1,k))
        end if
        if(dom(ib)%voo(i,j,k).gt.0.0) then
           ku=dom(ib)%ksgso(i,j-1,k)
           kc=dom(ib)%ksgso(i,j,k)
           kd=dom(ib)%ksgso(i,j+1,k)
           b_r=max(0.0,
     & min(2.0*((kd-kc)/(kc-ku)),0.75*((kd-kc)/(kc-ku))+0.25,4.0))
           kp=kc+0.5*b_r*(kc-ku)
        else if(dom(ib)%voo(i,j,k).lt.0.0) then
           ku=dom(ib)%ksgso(i,j+2,k)
           kc=dom(ib)%ksgso(i,j+1,k)
           kd=dom(ib)%ksgso(i,j,k)
           b_r=max(0.0,
     & min(2.0*((kd-kc)/(kc-ku)),0.75*((kd-kc)/(kc-ku))+0.25,4.0))
           kp=kc+0.5*b_r*(kc-ku)
        else
           kp=0.5*(dom(ib)%ksgso(i,j,k)+dom(ib)%ksgso(i,j+1,k))
        end if
        dvkdy=(dom(ib)%voo(i,j,k)*kp-dom(ib)%voo(i,j-1,k)*km)
     &	/dom(ib)%dy
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        if(dom(ib)%woo(i,j,k-1).gt.0.0) then
           ku=dom(ib)%ksgso(i,j,k-2)
           kc=dom(ib)%ksgso(i,j,k-1)
           kd=dom(ib)%ksgso(i,j,k)
           b_r=max(0.0,
     & min(2.0*((kd-kc)/(kc-ku)),0.75*((kd-kc)/(kc-ku))+0.25,4.0))
           km=kc+0.5*b_r*(kc-ku)
        else if(dom(ib)%woo(i,j,k-1).lt.0.0) then
           ku=dom(ib)%ksgso(i,j,k+1)
           kc=dom(ib)%ksgso(i,j,k)
           kd=dom(ib)%ksgso(i,j,k-1)
           b_r=max(0.0,
     & min(2.0*((kd-kc)/(kc-ku)),0.75*((kd-kc)/(kc-ku))+0.25,4.0))
           km=kc+0.5*b_r*(kc-ku)
        else
           km=0.5*(dom(ib)%ksgso(i,j,k)+dom(ib)%ksgso(i,j,k-1))
        end if
        if(dom(ib)%woo(i,j,k).gt.0.0) then
           ku=dom(ib)%ksgso(i,j,k-1)
           kc=dom(ib)%ksgso(i,j,k)
           kd=dom(ib)%ksgso(i,j,k+1)
           b_r=max(0.0,
     & min(2.0*((kd-kc)/(kc-ku)),0.75*((kd-kc)/(kc-ku))+0.25,4.0))
           kp=kc+0.5*b_r*(kc-ku)
        else if(dom(ib)%woo(i,j,k).lt.0.0) then
           ku=dom(ib)%ksgso(i,j,k+2)
           kc=dom(ib)%ksgso(i,j,k+1)
           kd=dom(ib)%ksgso(i,j,k)
           b_r=max(0.0,
     & min(2.0*((kd-kc)/(kc-ku)),0.75*((kd-kc)/(kc-ku))+0.25,4.0))
           kp=kc+0.5*b_r*(kc-ku)
        else
           kp=0.5*(dom(ib)%ksgso(i,j,k)+dom(ib)%ksgso(i,j,k+1))
        end if
        dwkdz=(dom(ib)%woo(i,j,k)*kp-dom(ib)%woo(i,j,k-1)*km)
     &	/dom(ib)%dz
!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

        conv=(dukdx+dvkdy+dwkdz)

        visc_w=0.5*cmu*									!does rrey have to be here? According to Lars, yes
     & (dom(ib)%ksgso(i,j,k)**2.0/dom(ib)%epso(i,j,k)
     & +dom(ib)%ksgso(i-1,j,k)**2.0/dom(ib)%epso(i-1,j,k))
        visc_e=0.5*cmu*
     & (dom(ib)%ksgso(i,j,k)**2.0/dom(ib)%epso(i,j,k)
     & +dom(ib)%ksgso(i+1,j,k)**2.0/dom(ib)%epso(i+1,j,k))
        visc_s=0.5*cmu*
     & (dom(ib)%ksgso(i,j,k)**2.0/dom(ib)%epso(i,j,k)
     & +dom(ib)%ksgso(i,j-1,k)**2.0/dom(ib)%epso(i,j-1,k))
        visc_n=0.5*cmu*
     & (dom(ib)%ksgso(i,j,k)**2.0/dom(ib)%epso(i,j,k)
     & +dom(ib)%ksgso(i,j+1,k)**2.0/dom(ib)%epso(i,j+1,k))
        visc_b=0.5*cmu*
     & (dom(ib)%ksgso(i,j,k)**2.0/dom(ib)%epso(i,j,k)
     & +dom(ib)%ksgso(i,j,k-1)**2.0/dom(ib)%epso(i,j,k-1))
        visc_t=0.5*cmu*
     & (dom(ib)%ksgso(i,j,k)**2.0/dom(ib)%epso(i,j,k)
     & +dom(ib)%ksgso(i,j,k+1)**2.0/dom(ib)%epso(i,j,k+1))

        awT=visc_w/(dxx*sigmak); aeT=visc_e/(dxx*sigmak)
        anT=visc_n/(dyy*sigmak); asT=visc_s/(dyy*sigmak)
        atT=visc_t/(dzz*sigmak); abT=visc_b/(dzz*sigmak)
        apT = -1.0*(awT+aeT+asT+anT+abT+atT)
        diff=(apT*dom(ib)%ksgso(i,j,k)+
     & anT*dom(ib)%ksgso(i,j+1,k) + asT*dom(ib)%ksgso(i,j-1,k)+
     & aeT*dom(ib)%ksgso(i+1,j,k) + awT*dom(ib)%ksgso(i-1,j,k)+
     & atT*dom(ib)%ksgso(i,j,k+1) + abT*dom(ib)%ksgso(i,j,k-1))

        other=dom(ib)%epso(i,j,k)

        dom(ib)%ksgs(i,j,k)=(dom(ib)%ksgso(i,j,k)+
     & alfark*dt*(diff-conv+prod-other))

        !if(dom(ib)%ksgs(i,j,k).lt.0.0) then
          ! print*,'ERRORRRR in eps eqn'
           !print*,dom_id(ib),i,j,k
		!write(6,*)'k',dom(ib)%ksgs(i,j,k)
		!write(6,*)'ko',dom(ib)%ksgso(i,j,k)
		!write(6,*)'epso',dom(ib)%epso(i,j,k)
		!write(6,*)'u',dom(ib)%uoo(i,j,k)
		!write(6,*)'v',dom(ib)%voo(i,j,k)
		!write(6,*)'w',dom(ib)%woo(i,j,k)
		!write(6,*)'diff',diff
		!write(6,*)'conv',conv
		!write(6,*)'prod',prod
		!write(6,*)'dest',other
		!write(6,*)(diff-conv+prod-other)
 		!call tecplot_p(itime)
          !stop
        !end if

              end do
           end do
        end do

        end do

        call exchange(6)
        call boundksgs(cmu)

        return
        end subroutine eddyv_k
!##########################################################################
        subroutine eddyv_eps(alfark)
!##########################################################################
        use vars
        use multidata
        implicit none
        integer :: i,j,k
        integer :: ib,is,ie,js,je,ks,ke
        double precision :: epsdudx,epsdvdy,epsdwdz
 	  double precision :: epsp,epsm,epsu,epsc,epsd,b_r
        double precision :: awT,aeT,asT,anT,abT,atT,apT
        double precision :: dxx,dyy,dzz,vsgs
        double precision :: visc_w,visc_e,visc_s,visc_n,visc_b,visc_t
        double precision :: rrey
        double precision :: cmu,c1eps,c2eps,sigmaeps
        double precision :: conv,diff,prod,other
        double precision :: alfark,strain

        c1eps=1.44; c2eps=1.92 ; sigmaeps=1.31 ; cmu=0.09
        rrey=1.0/Re

        do ib=1,nbp

              do k=1,dom(ib)%ttc_k
              do i=1,dom(ib)%ttc_i
              do j=1,dom(ib)%ttc_j
                 dom(ib)%ksgso(i,j,k)=dom(ib)%ksgs(i,j,k)
			if (dom(ib)%ksgso(i,j,k).lt.1.0d-07) then
				dom(ib)%ksgso(i,j,k)=1.0d-07
			endif
              end do
              end do
              end do

        dxx=dom(ib)%dx*dom(ib)%dx
        dyy=dom(ib)%dy*dom(ib)%dy
        dzz=dom(ib)%dz*dom(ib)%dz

        is=dom(ib)%isp; ie=dom(ib)%iep
        js=dom(ib)%jsp; je=dom(ib)%jep
        ks=dom(ib)%ksp; ke=dom(ib)%kep

        do k=ks,ke
           do j=js,je
              do i=is,ie

        vsgs=cmu*dom(ib)%ksgso(i,j,k)**2.0/dom(ib)%epso(i,j,k)		!eddy viscosity based on t-1

        prod=c1eps*(dom(ib)%epso(i,j,k)/dom(ib)%ksgso(i,j,k))		!production term based on t-1
     &	 *2.0*vsgs*strain(i,j,k)

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ Convection: Locating upstream, central and downstream nodes and interpolating k using previous time step
        if(dom(ib)%uoo(i-1,j,k).gt.0.0) then
           epsu=dom(ib)%epso(i-2,j,k)
           epsc=dom(ib)%epso(i-1,j,k)
           epsd=dom(ib)%epso(i,j,k)
           b_r=max(0.0,
     & 	min(2.0*((epsd-epsc)/(epsc-epsu)),
     &	0.75*((epsd-epsc)/(epsc-epsu))+0.25,4.0))
           epsm=epsc+0.5*b_r*(epsc-epsu)						!what's b_r?
        else if(dom(ib)%uoo(i-1,j,k).lt.0.0) then
           epsu=dom(ib)%epso(i+1,j,k)
           epsc=dom(ib)%epso(i,j,k)
           epsd=dom(ib)%epso(i-1,j,k)
           b_r=max(0.0,
     &	min(2.0*((epsd-epsc)/(epsc-epsu)),
     &	0.75*((epsd-epsc)/(epsc-epsu))+0.25,4.0))
           epsm=epsc+0.5*b_r*(epsc-epsu)
        else
           epsm=0.5*(dom(ib)%epso(i,j,k)+dom(ib)%epso(i-1,j,k))
        end if
        if(dom(ib)%uoo(i,j,k).gt.0.0) then
           epsu=dom(ib)%epso(i-1,j,k)
           epsc=dom(ib)%epso(i,j,k)
           epsd=dom(ib)%epso(i+1,j,k)
           b_r=max(0.0,
     & 	min(2.0*((epsd-epsc)/(epsc-epsu)),
     &	0.75*((epsd-epsc)/(epsc-epsu))+0.25,4.0))
           epsp=epsc+0.5*b_r*(epsc-epsu)
        else if(dom(ib)%uoo(i,j,k).lt.0.0) then
           epsu=dom(ib)%epso(i+2,j,k)
           epsc=dom(ib)%epso(i+1,j,k)
           epsd=dom(ib)%epso(i,j,k)
           b_r=max(0.0,
     & 	min(2.0*((epsd-epsc)/(epsc-epsu)),
     &	0.75*((epsd-epsc)/(epsc-epsu))+0.25,4.0))
           epsp=epsc+0.5*b_r*(epsc-epsu)
        else
           epsp=0.5*(dom(ib)%epso(i,j,k)+dom(ib)%epso(i+1,j,k))
        end if
        epsdudx=(dom(ib)%uoo(i,j,k)*epsp-dom(ib)%uoo(i-1,j,k)*epsm)		!calculating convective term
     &	    /dom(ib)%dx
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        if(dom(ib)%voo(i,j-1,k).gt.0.0) then
           epsu=dom(ib)%epso(i,j-2,k)
           epsc=dom(ib)%epso(i,j-1,k)
           epsd=dom(ib)%epso(i,j,k)
           b_r=max(0.0,
     & 	min(2.0*((epsd-epsc)/(epsc-epsu)),
     &	0.75*((epsd-epsc)/(epsc-epsu))+0.25,4.0))
           epsm=epsc+0.5*b_r*(epsc-epsu)
        else if(dom(ib)%voo(i,j-1,k).lt.0.0) then
           epsu=dom(ib)%epso(i,j+1,k)
           epsc=dom(ib)%epso(i,j,k)
           epsd=dom(ib)%epso(i,j-1,k)
           b_r=max(0.0,
     & 	min(2.0*((epsd-epsc)/(epsc-epsu)),
     &	0.75*((epsd-epsc)/(epsc-epsu))+0.25,4.0))
           epsm=epsc+0.5*b_r*(epsc-epsu)
        else
           epsm=0.5*(dom(ib)%epso(i,j,k)+dom(ib)%epso(i,j-1,k))
        end if
        if(dom(ib)%voo(i,j,k).gt.0.0) then
           epsu=dom(ib)%epso(i,j-1,k)
           epsc=dom(ib)%epso(i,j,k)
           epsd=dom(ib)%epso(i,j+1,k)
           b_r=max(0.0,
     & 	min(2.0*((epsd-epsc)/(epsc-epsu)),
     &	0.75*((epsd-epsc)/(epsc-epsu))+0.25,4.0))
           epsp=epsc+0.5*b_r*(epsc-epsu)
        else if(dom(ib)%voo(i,j,k).lt.0.0) then
           epsu=dom(ib)%epso(i,j+2,k)
           epsc=dom(ib)%epso(i,j+1,k)
           epsd=dom(ib)%epso(i,j,k)
           b_r=max(0.0,
     & 	min(2.0*((epsd-epsc)/(epsc-epsu)),
     &	0.75*((epsd-epsc)/(epsc-epsu))+0.25,4.0))
           epsp=epsc+0.5*b_r*(epsc-epsu)
        else
           epsp=0.5*(dom(ib)%epso(i,j,k)+dom(ib)%epso(i,j+1,k))
        end if
        epsdvdy=(dom(ib)%voo(i,j,k)*epsp-dom(ib)%voo(i,j-1,k)*epsm)
     &	    /dom(ib)%dy
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        if(dom(ib)%woo(i,j,k-1).gt.0.0) then
           epsu=dom(ib)%epso(i,j,k-2)
           epsc=dom(ib)%epso(i,j,k-1)
           epsd=dom(ib)%epso(i,j,k)
           b_r=max(0.0,
     & 	min(2.0*((epsd-epsc)/(epsc-epsu)),
     &	0.75*((epsd-epsc)/(epsc-epsu))+0.25,4.0))
           epsm=epsc+0.5*b_r*(epsc-epsu)
        else if(dom(ib)%woo(i,j,k-1).lt.0.0) then
           epsu=dom(ib)%epso(i,j,k+1)
           epsc=dom(ib)%epso(i,j,k)
           epsd=dom(ib)%epso(i,j,k-1)
           b_r=max(0.0,
     & 	min(2.0*((epsd-epsc)/(epsc-epsu)),
     &	0.75*((epsd-epsc)/(epsc-epsu))+0.25,4.0))
           epsm=epsc+0.5*b_r*(epsc-epsu)
        else
           epsm=0.5*(dom(ib)%epso(i,j,k)+dom(ib)%epso(i,j,k-1))
        end if
        if(dom(ib)%woo(i,j,k).gt.0.0) then
           epsu=dom(ib)%epso(i,j,k-1)
           epsc=dom(ib)%epso(i,j,k)
           epsd=dom(ib)%epso(i,j,k+1)
           b_r=max(0.0,
     & 	min(2.0*((epsd-epsc)/(epsc-epsu)),
     &	0.75*((epsd-epsc)/(epsc-epsu))+0.25,4.0))
           epsp=epsc+0.5*b_r*(epsc-epsu)
        else if(dom(ib)%woo(i,j,k).lt.0.0) then
           epsu=dom(ib)%epso(i,j,k+2)
           epsc=dom(ib)%epso(i,j,k+1)
           epsd=dom(ib)%epso(i,j,k)
           b_r=max(0.0,
     & 	min(2.0*((epsd-epsc)/(epsc-epsu)),
     &	0.75*((epsd-epsc)/(epsc-epsu))+0.25,4.0))
           epsp=epsc+0.5*b_r*(epsc-epsu)
        else
           epsp=0.5*(dom(ib)%epso(i,j,k)+dom(ib)%epso(i,j,k+1))
        end if
        epsdwdz=(dom(ib)%woo(i,j,k)*epsp-dom(ib)%woo(i,j,k-1)*epsm)
     &	    /dom(ib)%dz

        conv=(epsdudx+epsdvdy+epsdwdz)						!convective term

!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ Difusion

        visc_w=0.5*cmu*									!does rrey have to be here? According to Lars, yes
     & (dom(ib)%ksgso(i,j,k)**2.0/dom(ib)%epso(i,j,k)
     & +dom(ib)%ksgso(i-1,j,k)**2.0/dom(ib)%epso(i-1,j,k))
        visc_e=0.5*cmu*
     & (dom(ib)%ksgso(i,j,k)**2.0/dom(ib)%epso(i,j,k)
     & +dom(ib)%ksgso(i+1,j,k)**2.0/dom(ib)%epso(i+1,j,k))
        visc_s=0.5*cmu*
     & (dom(ib)%ksgso(i,j,k)**2.0/dom(ib)%epso(i,j,k)
     & +dom(ib)%ksgso(i,j-1,k)**2.0/dom(ib)%epso(i,j-1,k))
        visc_n=0.5*cmu*
     & (dom(ib)%ksgso(i,j,k)**2.0/dom(ib)%epso(i,j,k)
     & +dom(ib)%ksgso(i,j+1,k)**2.0/dom(ib)%epso(i,j+1,k))
        visc_b=0.5*cmu*
     & (dom(ib)%ksgso(i,j,k)**2.0/dom(ib)%epso(i,j,k)
     & +dom(ib)%ksgso(i,j,k-1)**2.0/dom(ib)%epso(i,j,k-1))
        visc_t=0.5*cmu*
     & (dom(ib)%ksgso(i,j,k)**2.0/dom(ib)%epso(i,j,k)
     & +dom(ib)%ksgso(i,j,k+1)**2.0/dom(ib)%epso(i,j,k+1))

        awT=visc_w/(dxx*sigmaeps); aeT=visc_e/(dxx*sigmaeps)
        anT=visc_n/(dyy*sigmaeps); asT=visc_s/(dyy*sigmaeps)
        atT=visc_t/(dzz*sigmaeps); abT=visc_b/(dzz*sigmaeps)
        apT = -1.0*(awT+aeT+asT+anT+abT+atT)
        diff=(apT*dom(ib)%epso(i,j,k)+						!diffusive term
     & anT*dom(ib)%epso(i,j+1,k) + asT*dom(ib)%epso(i,j-1,k)+
     & aeT*dom(ib)%epso(i+1,j,k) + awT*dom(ib)%epso(i-1,j,k)+
     & atT*dom(ib)%epso(i,j,k+1) + abT*dom(ib)%epso(i,j,k-1))

        other=c2eps*dom(ib)%epso(i,j,k)**2.0/dom(ib)%ksgso(i,j,k)			!destruction

        dom(ib)%eps(i,j,k)=(dom(ib)%epso(i,j,k)+				!time derivative
     & alfark*dt*(diff-conv+prod-other))

        !if(dom(ib)%eps(i,j,k).lt.0.0) then
           !print*,'ERRORRRR in eps eqn'
           !print*,dom_id(ib),i,j,k
		!write(6,*)'eps',dom(ib)%eps(i,j,k)
		!write(6,*)'epso',dom(ib)%epso(i,j,k)		!why this doesnt print out?
		!write(6,*)'ko',dom(ib)%ksgso(i,j,k)
		!write(6,*)'u',dom(ib)%uoo(i,j,k)
		!write(6,*)'v',dom(ib)%voo(i,j,k)
		!write(6,*)'w',dom(ib)%woo(i,j,k)
		!write(6,*)'diff',diff
		!write(6,*)'conv',conv
		!write(6,*)'prod',prod
		!write(6,*)'dest',other
		!write(6,*)(diff-conv+prod-other)
 		!call tecplot_p(itime)
           !stop
       ! end if

              end do
           end do
        end do

        end do

        call exchange(9)
        call boundeps

        return
        end subroutine eddyv_eps

!##########################################################################
        double precision function strain(i,j,k)
!	  calculates the Strain tensor based on the velocity gradients
!##########################################################################

        use vars
        use multidata
        implicit none
        integer :: i,j,k
        integer :: ib,is,ie,js,je,ks,ke
        double precision :: dudx,dudy,dudz,dvdx,dvdy,dvdz,dwdx,dwdy,dwdz
        double precision :: vr_a,vr_b,vr_c,vr_d
        double precision :: s12,s13,s23

        do ib=1,nbp

!====================================================
        vr_a = 0.25*( dom(ib)%uoo(i,j,k)   + dom(ib)%uoo(i-1,j,k) +
     &	 	  dom(ib)%uoo(i,j+1,k) + dom(ib)%uoo(i-1,j+1,k) )
        vr_b = 0.25*( dom(ib)%uoo(i,j,k)   + dom(ib)%uoo(i-1,j,k) +
     &	 	   dom(ib)%uoo(i,j-1,k) + dom(ib)%uoo(i-1,j-1,k) )

        vr_c = 0.25*( dom(ib)%uoo(i,j,k)   + dom(ib)%uoo(i-1,j,k) +
     &	 	  dom(ib)%uoo(i,j,k+1) + dom(ib)%uoo(i-1,j,k+1) )
        vr_d = 0.25*( dom(ib)%uoo(i,j,k)   + dom(ib)%uoo(i-1,j,k) +
     &	 	  dom(ib)%uoo(i,j,k-1) + dom(ib)%uoo(i-1,j,k-1) )

        dudx = (dom(ib)%uoo(i,j,k)-dom(ib)%uoo(i-1,j,k) )/dom(ib)%dx
        dudy = ( vr_a - vr_b )/dom(ib)%dy
        dudz = ( vr_c - vr_d )/dom(ib)%dz
!====================================================
        vr_a = 0.25*( dom(ib)%voo(i,j,k)   + dom(ib)%voo(i,j-1,k) +
     &	 	   dom(ib)%voo(i+1,j,k) + dom(ib)%voo(i+1,j-1,k) )
        vr_b = 0.25*( dom(ib)%voo(i,j,k)   + dom(ib)%voo(i,j-1,k) +
     &	 	   dom(ib)%voo(i-1,j,k) + dom(ib)%voo(i-1,j-1,k) )

        vr_c = 0.25*( dom(ib)%voo(i,j,k)   + dom(ib)%voo(i,j-1,k) +
     &	 	   dom(ib)%voo(i,j,k+1) + dom(ib)%voo(i,j-1,k+1) )
        vr_d = 0.25*( dom(ib)%voo(i,j,k)   + dom(ib)%voo(i,j-1,k) +
     &	 	  dom(ib)%voo(i,j,k-1) + dom(ib)%voo(i,j-1,k-1) )

        dvdy = (dom(ib)%voo(i,j,k)-dom(ib)%voo(i,j-1,k) )/dom(ib)%dy
        dvdx = ( vr_a - vr_b )/dom(ib)%dx
        dvdz = ( vr_c - vr_d )/dom(ib)%dz
!====================================================
        vr_a = 0.25*( dom(ib)%woo(i,j,k)   + dom(ib)%woo(i,j,k-1) +
     &	 	  dom(ib)%woo(i+1,j,k) + dom(ib)%woo(i+1,j,k-1) )
        vr_b = 0.25*( dom(ib)%woo(i,j,k)   + dom(ib)%woo(i,j,k-1) +
     &	 	   dom(ib)%woo(i-1,j,k) + dom(ib)%woo(i-1,j,k-1) )

        vr_c = 0.25*( dom(ib)%woo(i,j,k)   + dom(ib)%woo(i,j,k-1) +
     &	 	   dom(ib)%woo(i,j+1,k) + dom(ib)%woo(i,j+1,k-1) )
        vr_d = 0.25*( dom(ib)%woo(i,j,k)   + dom(ib)%woo(i,j,k-1) +
     &	 	   dom(ib)%woo(i,j-1,k) + dom(ib)%woo(i,j-1,k-1) )

        dwdz = (dom(ib)%woo(i,j,k)-dom(ib)%woo(i,j,k-1) )/dom(ib)%dz
        dwdx = ( vr_a - vr_b )/dom(ib)%dx
        dwdy = ( vr_c - vr_d )/dom(ib)%dy

        s12 = 0.5 * (dudy + dvdx)
        s13 = 0.5 * (dudz + dwdx)
        s23 = 0.5 * (dvdz + dwdy)
        strain  = ( dudx*dudx + dvdy*dvdy   + dwdz*dwdz  +
     &      2.0*s12*s12   + 2.0*s13*s13 + 2.0*s23*s23 )

	enddo

	end function


C
C**************************  FVGSE *************************************
C
C  calculate effective saturation using van Genuchten
C  characteristic equation
C
C***********************************************************************
C
      DOUBLE PRECISION FUNCTION FVGSE(PSI,INOD)
C
      IMPLICIT NONE
      INCLUDE 'CATHY.H'
      INTEGER  INOD
      REAL*8   BETA
      REAL*8   PSI
      INCLUDE 'SOILCHAR.H'
C
      IF (PSI .LT. -1.0D-14) THEN
         BETA=(ABS(PSI/VGPSAT(INOD)))**VGN(INOD)
         FVGSE=ABS(1.0D0/(BETA+1.0D0))**VGM(INOD)
      ELSE
         FVGSE=1.0D0
      END IF
C
      RETURN
      END


      FUNCTION F89 (I,A,B,M,N,X)
C
      DIMENSION X(1)
C
      F89  = 0.0
      CAPX = A + B*X(I)
      NFAC = M
      ASSIGN 5 TO IRET
      GO TO 1000
    5 AMF = IFAC
      N1  = M + 1
      N2  = N1 - N
      AN1 = N1
      AN2 = N2
      IS  = 0
      S   = 0.0
      SF  = 1.0
      AMMSF = AMF
      GO TO 50
   10 IS = IS + 1
      S  = IS
      SF = SF*S
      AMMSF = AMMSF/(AN1-S)
   50 CONTINUE
      N3 = N2 - IS
      IF (N3 .EQ. 0) GO TO 100
      F89 = F89 + AMF*((-A)**IS)*(CAPX**N3)/(AMMSF*SF*(AN2-S))
      GO TO 200
  100 CONTINUE
      NFAC = N2
      ASSIGN 110 TO IRET
      GO TO 1000
  110 AMN1F = IFAC
      NFAC  = N - 1
      ASSIGN 120 TO IRET
      GO TO 1000
  120 ANM1F = IFAC
      F89 = F89 + AMF*((-A)**N2)*ALOG(ABS(CAPX))/(AMN1F*ANM1F)
  200 IF (IS .LT.  M) GO TO 10
      IF (B .EQ. 0.0) GO TO 300
      F89 = F89/(B**N1)
      RETURN
C
  300 F89 = 0.0
      RETURN
C
 1000 IFAC = 1
      IF (NFAC .LT. 2) GO TO 1020
      DO 1010 LFAC = 2,NFAC
      IFAC = IFAC*LFAC
 1010 CONTINUE
 1020 GO TO IRET, (5,110,120)
      END


! This module initializes the coefficients for the turbulent forcing

module turbinit_module

  use amrex_fort_module, only : rt => amrex_real
  use bl_types
  use bl_space

  use turbforce_module

  implicit none

contains

  subroutine turbforce_init(prob_lo,prob_hi)

    use parallel
    use bl_constants_module, only: TWO, ONE, HALF, ZERO, M_PI
    use box_module
    use mt19937_module

    real(rt), intent(in) :: prob_lo(:), prob_hi(:)

    integer :: kx,ky,kz
    integer :: xstep,ystep,zstep
    integer :: mode_count

    real(rt) :: Lx, Ly, Lz
    real(rt) :: kxd,kyd,kzd
    real(rt) :: kappa,kappaMax,Lmin
    real(rt) :: twicePi
    real(rt) :: thetaTmp,cosThetaTmp,sinThetaTmp
    real(rt) :: phiTmp,cosPhiTmp,sinPhiTmp
    real(rt) :: px,py,pz,mp2,Ekh
    real(rt) :: freqMin,freqMax,freqDiff
    real(rt) :: rn

    if (parallel_IOProcessor()) then
       write (*,*) "Initialising random number generator..."
    endif

    twicePi = TWO*M_PI

!   if (blrandseed.gt.0) then
!      call init_genrand(20908)
!      call blutilinitrand(blrandseed)
!      rn = genrand_real1()
!      call blutilinitrand(blrandseed)
!      if (parallel_IOProcessor()) then
!         write (*,*) "blrandseed = ",blrandseed
!         write (*,*) "first random number = ",rn
!      endif
!   else
       call init_genrand(111397)
       rn = genrand_real1()
!   endif
    if (parallel_IOProcessor()) then
       print *,"first random number = ",rn
    endif

    Lx = prob_hi(1)-prob_lo(1)
    Ly = prob_hi(2)-prob_lo(2)
    Lz = prob_hi(3)-prob_lo(3)

    if (parallel_IOProcessor()) then
       write(*,*) "Lx = ",Lx
       write(*,*) "Ly = ",Ly
       write(*,*) "Lz = ",Lz
    endif

         Lmin = min(Lx,Ly,Lz)
         kappaMax = dble(nmodes)/Lmin + 1.0d-8
         nxmodes = nmodes*int(0.5+Lx/Lmin)
         nymodes = nmodes*int(0.5+Ly/Lmin)
         nzmodes = nmodes*int(0.5+Lz/Lmin)
         if (parallel_IOProcessor()) then
            write(*,*) "Lmin = ",Lmin
            write(*,*) "kappaMax = ",kappaMax
            write(*,*) "nxmodes = ",nxmodes
            write(*,*) "nymodes = ",nymodes
            write(*,*) "nzmodes = ",nzmodes
         endif

         if (forcing_time_scale_min.eq.ZERO) then
            forcing_time_scale_min = HALF
         endif
         if (forcing_time_scale_max.eq.ZERO) then
            forcing_time_scale_max = ONE
         endif

         freqMin = one/forcing_time_scale_max
         freqMax = one/forcing_time_scale_min
         freqDiff= freqMax-freqMin

         if (parallel_IOProcessor()) then
            write(*,*) "forcing_time_scale_min = ",forcing_time_scale_min
            write(*,*) "forcing_time_scale_max = ",forcing_time_scale_max
            write(*,*) "freqMin = ",freqMin
            write(*,*) "freqMax = ",freqMax
            write(*,*) "freqDiff = ",freqDiff
         endif

         mode_count = 0

         xstep = int(Lx/Lmin+0.5)
         ystep = int(Ly/Lmin+0.5)
         zstep = int(Lz/Lmin+0.5)
         if (parallel_IOProcessor()) then
            write (*,*) "Mode step ",xstep, ystep, zstep
         endif

         do kz = mode_start*zstep, nzmodes, zstep
            kzd = dble(kz)

            do ky = mode_start*ystep, nymodes, ystep
               kyd = dble(ky)

               do kx = mode_start*xstep, nxmodes, xstep
                  kxd = dble(kx)

                  kappa = sqrt( (kxd*kxd)/(Lx*Lx) + (kyd*kyd)/(Ly*Ly) + (kzd*kzd)/(Lz*Lz) )

                  if (kappa.le.kappaMax) then
                     rn = genrand_real1()
                     FTX(kx,ky,kz) = (freqMin + freqDiff*rn)*twicePi
                     rn = genrand_real1()
                     FTY(kx,ky,kz) = (freqMin + freqDiff*rn)*twicePi
                     rn = genrand_real1()
                     FTZ(kx,ky,kz) = (freqMin + freqDiff*rn)*twicePi
!     Translation angles, theta=0..2Pi and phi=0..Pi
                     rn = genrand_real1()
                     TAT(kx,ky,kz) = rn*twicePi
                     rn = genrand_real1()
                     TAP(kx,ky,kz) = rn*M_PI
!     Phases
                     rn = genrand_real1()
                     FPXX(kx,ky,kz) = rn*twicePi
                     rn = genrand_real1()
                     FPYX(kx,ky,kz) = rn*twicePi
                     rn = genrand_real1()
                     FPZX(kx,ky,kz) = rn*twicePi
                     rn = genrand_real1()
                     FPXY(kx,ky,kz) = rn*twicePi
                     rn = genrand_real1()
                     FPYY(kx,ky,kz) = rn*twicePi
                     rn = genrand_real1()
                     FPZY(kx,ky,kz) = rn*twicePi
                     rn = genrand_real1()
                     FPXZ(kx,ky,kz) = rn*twicePi
                     rn = genrand_real1()
                     FPYZ(kx,ky,kz) = rn*twicePi
                     rn = genrand_real1()
                     FPZZ(kx,ky,kz) = rn*twicePi
!     Amplitudes (alpha)
                     rn = genrand_real1()
                     thetaTmp      = rn*twicePi
                     cosThetaTmp   = cos(thetaTmp)
                     sinThetaTmp   = sin(thetaTmp)
                     rn = genrand_real1()
                     phiTmp        = rn*M_PI
                     cosPhiTmp     = cos(phiTmp)
                     sinPhiTmp     = sin(phiTmp)

                     px = cosThetaTmp * sinPhiTmp
                     py = sinThetaTmp * sinPhiTmp
                     pz =               cosPhiTmp

                     mp2           = px*px + py*py + pz*pz
                     if (mp2 .lt. 0.000001) then
                        write(*,*) "ZERO AMPLITUDE MODE ",kx,ky,kz
                        FAX(kx,ky,kz) = zero
                        FAY(kx,ky,kz) = zero
                        FAZ(kx,ky,kz) = zero
                     else
!     Count modes that contribute
                        mode_count = mode_count + 1
!     Set amplitudes
                        if (spectrum_type.eq.1) then
                           Ekh        = one / kappa
                        else if (spectrum_type.eq.2) then
                           Ekh        = one / (kappa*kappa)
                        else
                           Ekh        = one
                        endif
                        if (force_scale.ge.zero) then
                           FAX(kx,ky,kz) = force_scale * px * Ekh / mp2
                           FAY(kx,ky,kz) = force_scale * py * Ekh / mp2
                           FAZ(kx,ky,kz) = force_scale * pz * Ekh / mp2
                        else
                           FAX(kx,ky,kz) = px * Ekh / mp2
                           FAY(kx,ky,kz) = py * Ekh / mp2
                           FAZ(kx,ky,kz) = pz * Ekh / mp2
                        endif

!                       if (parallel_IOProcessor()) then
!                          write (*,*) "Mode"
!                          write (*,*) "kappa = ",kx,ky,kz,kappa
!                          write (*,*) "Amplitudes"
!                          write (*,*) FAX(kx,ky,kz), FAY(kx,ky,kz), FAZ(kx,ky,kz)
!                          write (*,*) "Frequencies"
!                          write (*,*) FTX(kx,ky,kz), FTY(kx,ky,kz), FTZ(kx,ky,kz)
!                       endif
                     endif
                  endif
               enddo
            enddo
         enddo

         call flush(6)

  end subroutine turbforce_init

end module turbinit_module


      subroutine fem_transverse_isotropy_elastic_stiffness(i, j, D)
!***********************************************************************
! Copyright 2011 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!
! Returns the 6x6 material stiffness (D) matrix for a transverse isotropic
! elastic solid when the 'plastic' submacro is used with 'fem' computations
!
! Author : Satish Karra
!

      use comai, only: iout, iptty, ns
      use comsi, only: modelNumber, plasticModel, elastic_mod, poisson
      use comsi, only: iPlastic
      use comsi, only: elastic_mod_t, poisson_t, shearmod_t
      use comfem

      implicit none
      integer                      :: i, j
      real*8,  dimension(6,6)      :: D

      integer                      :: k, itmp, iModel, node
      real*8                       :: e1bar, e2bar, e3bar, e4bar, ezzbar
      real*8                       :: young_p, young_t, pois_p, pois_t
      real*8                       :: shear_t, shear_t_bar, pois_sq
      real*8                       :: fac1, fac2, fac3, e1, e2, e3
      real*8                       :: e4, ezz

      if(iPlastic.ne.0) then
        itmp = modelNumber(elnode(i, 1))
        iModel = plasticModel(itmp)

        do k=2,ns
          itmp = modelNumber(elnode(i, k))
          if(iModel.ne.plasticModel(itmp)) then
            write(iout, *) 'Multiple plastic models being used !
     &          Not supported at this time! '
            write(iptty, *) 'Multiple plastic models being used !
     &          Not supported at this time! '
            stop
          endif
        enddo
      endif

      D = 0.0d0

      e1bar = 0.0d0
      e2bar = 0.0d0
      e3bar = 0.0d0
      e4bar = 0.0d0
      shear_t_bar = 0.0d0

      do k = 1,ns
!     Notation
!     e1=c11, e2=c12=c21, e3=c66=Gp, e4=c13, and ezz=c33
!     these goto isotropic limit when Ep=Et and Nue-p=Nue-t
        young_p = elastic_mod(node)
        young_t = elastic_mod_t(node)
        pois_p = poisson(node)
        pois_t = poisson_t(node)
        shear_t = shearmod_t(node)
        pois_sq = pois_t*pois_t
        fac1 = young_p/young_t
        fac2 = 1.0d0 - pois_p - 2.0d0*fac1*pois_sq
        fac3 = fac2*(1.0d0 + pois_p)
        e1 = young_p*(1.0d0 - fac1*pois_sq)/fac3
        e2 = young_p*(pois_p + fac1*pois_sq)/fac3
        e3 = 0.5d0*young_p/(1.d0 + pois_p)
        e4 = young_p*pois_t/fac2
        ezz = young_t*(1.0d0 - pois_p)/fac2

        e1bar = e1bar + Psi(i, j, k)*e1
        e2bar = e2bar + Psi(i, j, k)*e2
        e3bar = e3bar + Psi(i, j, k)*e3
        e4bar = e4bar + Psi(i, j, k)*e4
        ezzbar = ezzbar + Psi(i, j, k)*ezz
        shear_t_bar = shear_t_bar + Psi(i, j, k)*shear_t

      enddo

      D(1,1) = e1bar
      D(2,2) = e1bar

      D(3,3) = ezzbar

      D(1,2) = e2bar
      D(2,1) = e2bar

      D(1,3) = e4bar
      D(3,1) = e4bar
      D(2,3) = e4bar
      D(3,2) = e4bar

      D(4,4) = e3bar

      D(5,5) = shear_t_bar
      D(6,6) = shear_t_bar

      end subroutine fem_transverse_isotropy_elastic_stiffness