!
!  miscset.f90
!
!  Alex 09/13/2011
!
!  Miscellaneous setup for the UWVFbgk code.
!  constains generation of meshes and more.
!!!!!!!!!!!!!!!!!!!!!!1

module miscset

use nrtype ! contains kind parameters (DP), (DP), (I4B) etc.
implicit none

contains
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! SetDGblzmGnodes
!
! This subroutine sets up the notes used in various integrations and
! also used as ordimnates/nodal values
!
! This subroutine uses parameters set by SetUWbgkParams
!
! This subroutine sets arrays used in other programs -- must go before
! SetDGVblzmmesh
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine SetDGblzmGnodes
use commvar, only: x_gauss_n, x_gauss_w, t_gauss_n, t_gauss_w, &
             x_lobat_n, x_lobat_w, t_lobat_n, t_lobat_w, k_c, k_b, d_c, d_b, &
             g_nds_all, g_wts_all, g_max_order, moments_u_gauss_nodes, moments_u_gauss_weights, &
             moments_x_gauss_nodes,moments_x_gauss_weights,moments_u_gauss_order,moments_x_gauss_order
use gaussian_mod
use gaussquad, only: gauss_rule

integer (I4B) :: loc_alloc_stat, info  ! local variable to keep the allocation status
real (DP), dimension (1:k_b) :: xb ! scratch array to use in the subroutine generating gauss-lobatto nodes.
real (DP), dimension (1:d_b) :: tb ! scratch array to use in the subroutine to generate gauss-Lobatto nodes.
real (DP), dimension (:), allocatable :: ugn, ugw ! scratch arrays to create gauss nodes...
integer (I4B) :: i ! local counter

!!! Prepare the Gaussian nodes and weights in x variables !!!!!!!!!!!!!!!!!!!!!!
!!! Allocate arrays for gaussian nodes and weights to inegration in the first variable
  allocate (x_gauss_n(1:max(k_c,1)), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (x_gauss_n)"
     end if
     !
  allocate (x_gauss_w(1:max(k_c,1)), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (x_gauss_w)"
     end if
     !
!!! Compute the gaussian nodes and weights for integration in the first variable
  if (k_c == 1) then
   x_gauss_n(:)= (/ 0.0_DP /)
   x_gauss_w(:)= (/ 2.0_DP /)
  else
   call GauLeg(Real(-1,DP),Real(1,DP),x_gauss_n,x_gauss_w)     ! the number of nodes/presition of the quadrature depends on the size of gnodes,gweights
  end if
!!!
!!! Prepare the Gaussian nodes and weights in u variables !!!!!!!!!!!!!!!!!!!!!!
!   first we need to allocate the arrays to store gauss nodes and weights:
!
  allocate (g_nds_all(1:g_max_order, 1:g_max_order), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (g_nds_all)"
     end if
     !
  allocate (g_wts_all(1:g_max_order, 1:g_max_order), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (g_wts_all)"
     end if
     !
!!! reset the arrays to zeros:
g_nds_all=0
g_wts_all=0
!!!
g_nds_all(1,1)=0.0_DP
g_wts_all(1,1)=2.0_DP
do i=2,g_max_order
 ! will need two scrap arrays...
 allocate (ugn(1:i), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (ugn), i=", i
     end if
 allocate (ugw(1:i), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (ugw), i=", i
     end if
call GauLeg(Real(-1,DP),Real(1,DP),ugn,ugw)
g_nds_all(1:i,i)=ugn
g_wts_all(1:i,i)=ugw
deallocate(ugn,ugw)
end do
!!! Prepare the Gaussian nodes and weights in t variables !!!!!!!!!!!!!!!!!!!!!!
!!! Allocate arrays for gaussian nodes and weights to inegration in the first variable
  allocate (t_gauss_n(1:max(d_c,1)), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (t_gauss_n)"
     end if
     !
  allocate (t_gauss_w(1:max(d_c,1)), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (t_gauss_w)"
     end if
     !
!!! Compute the gaussian nodes and weights for integration in the first variable
  if (d_c == 1) then
   t_gauss_n(:)= (/ 0.0_DP /)
   t_gauss_w(:)= (/ 2.0_DP /)
  else
   call GauLeg(Real(-1,DP),Real(1,DP),t_gauss_n,t_gauss_w)     ! the number of nodes/presition of the quadrature depends on the size of gnodes,gweights
  end if
!!!!!!!
!
! Next we will set the Gauss-Lobatto nodes used in the nodal formulation.
!!! Allocate arrays for gauss-lobatto nodes and weights
  allocate (t_lobat_n(1:max(d_b,1)), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (t_lobat_n)"
     end if
     !
  allocate (t_lobat_w(1:max(d_b,1)), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (t_lobat_w)"
     end if
   call gauss_rule(0, d_b, t_lobat_n, t_lobat_w, tb, 0.0_DP, 0.0_DP, 'B', info)
!!! Allocate arrays for gauss-lobatto nodes and weights
  allocate (x_lobat_n(1:max(k_b,1)), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (x_lobat_n)"
     end if
     !
  allocate (x_lobat_w(1:max(k_b,1)), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (x_lobat_w)"
     end if

   call gauss_rule(0, k_b, x_lobat_n, x_lobat_w, xb, 0.0_DP, 0.0_DP, 'B', info)
   ! We set the variables of moments_x_gauss_nodes, moments_u_gauss_nodes, moments_x_gauss_weights, moments_u_gauss_weights
   allocate (moments_x_gauss_nodes(1:moments_x_gauss_order), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (moments_x_gauss_nodes)"
     end if
     !
  allocate (moments_x_gauss_weights(1:moments_x_gauss_order), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (moments_x_gauss_nodes)"
     end if
 if (moments_x_gauss_order == 1) then
   moments_x_gauss_nodes(:)= (/ 0.0_DP /)
   moments_x_gauss_weights(:)= (/ 2.0_DP /)
  else
   call GauLeg(Real(-1,DP),Real(1,DP),moments_x_gauss_nodes,moments_x_gauss_weights)     ! the number of nodes/presition of the quadrature depends on the size of gnodes,gweights
  end if
 allocate (moments_u_gauss_nodes(1:moments_u_gauss_order), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (moments_u_gauss_nodes)"
     end if
     !
  allocate (moments_u_gauss_weights(1:moments_u_gauss_order), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGblzmGnodes: Allocation error for variable (moments_u_gauss_nodes)"
     end if
 if (moments_u_gauss_order == 1) then
   moments_u_gauss_nodes(:)= (/ 0.0_DP /)
   moments_u_gauss_weights(:)= (/ 2.0_DP /)
  else
   call GauLeg(Real(-1,DP),Real(1,DP),moments_u_gauss_nodes,moments_u_gauss_weights)     ! the number of nodes/presition of the quadrature depends on the size of gnodes,gweights
  end if

end subroutine SetDGblzmGnodes

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! SetDGVblzmmesh
!
! This subroutine sets up the meshes. Do not detouch from the main program
!
! This subroutine is highly dependent on the main program. It is created mainly
! to organize the main program.
!
! The subroutine can not be called before the parameters
! N,M, mesh_x_uniform, mesh_u_uniform, moments_x_gauss_order,
! moments_u_gauss_order are selected                               !!!!!
! CALL this SUBROUTINE before other subroutines use varaibles N,M.
!
! DO not call before arrays moments_x_gauss_nodes,moments_x_gauss_weights_x,moments_x_gauss_order
!          moments_u_gauss_order,moments_u_gauss_nodes,moments_u_gauss_weights are selected!
!
! Most of the varaibles are looked up in the common_varaibles_module
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine SetDGVblzmmesh
use commvar, only:  xmesh_l, xmesh_r, N, Mu, Mv, Mw, x_L, x_R, u_L, u_R, &
                   v_L, v_R, w_L, w_R, grids_cap_u, grids_cap_v, grids_cap_w, grids_u, grids_v, grids_w, &
                   mesh_x_uniform, mesh_u_uniform, x_nonuniform_mesh_type, u_nonuniform_mesh_type,&
                   moments_x_gauss_nodes, moments_u_gauss_nodes,mesh_v_uniform, mesh_w_uniform, &
                   v_nonuniform_mesh_type,w_nonuniform_mesh_type

intrinsic Min, Max, MinVal

integer (I4B) :: loc_alloc_stat ! to keep allocation status
integer (I4B) ::  i,j       ! local counter
integer (I4B) :: sml,smr   ! parameters for umesh with small cells around zero sml -- levels of refinment and smr -- ratio of refinement
integer (I4B) :: mxgo,mugo      ! local variables to keep the order of the gauss integration for the moments
real (DP) :: dx, du ! local temp variables to store 1/3 smallest distance between nodes.
 ! first the mesh in x
 if (mesh_x_uniform) then
  allocate (xmesh_l(1:N), stat=loc_alloc_stat)
    !
  if (loc_alloc_stat >0) then
  print *, "SetDGVblzmmesh: Allocation error for variable (xmesh_l)"
  stop
  end if
     !
  xmesh_l = (/ (x_L + (x_R - x_L )/Real(N,DP)*i, i=0,N-1) /)
  !
  allocate (xmesh_r(1:N), stat=loc_alloc_stat)
    !
  if (loc_alloc_stat >0) then
  print *, "SetDGVblzmmesh: Allocation error for variable (xmesh_r)"
  stop
  end if
     !
  xmesh_r = (/ (x_L + (x_R - x_L )/Real(N,DP)*i, i=1,N) /)
  !
 else
  select case (x_nonuniform_mesh_type)
  case (1) ! use "the gauss nodes for evaluating moments in x" to set up the "mesh in x"
           ! interval [x_left,x_right] is divided in subintervals as to have gauss nodes at centerpoints
           ! (and some extra points need to be introduced to make this possible).
  mxgo = size(moments_x_gauss_nodes) ! temp remember order of the guass method for integration of moments ....
  dx=min(minval(moments_x_gauss_nodes(2:mxgo) - moments_x_gauss_nodes(1:mxgo-1)),&
                 moments_x_gauss_nodes(1)+Real(1,DP), Real(1,DP)-moments_x_gauss_nodes(mxgo))/Real(3,DP)
  !! allocate memory for the nodes in x
     allocate (xmesh_l(1:mxgo*2+1), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGVblzmmesh: Allocation error for variable (xmesh_l)"
     stop
     end if
     !
!! allocate memory for the nodes in x
     allocate (xmesh_r(1:mxgo*2+1), stat=loc_alloc_stat)
     !
     if (loc_alloc_stat >0) then
     print *, "SetDGVblzmmesh: Allocation error for variable (xmesh_r)"
     stop
     end if
     !
  !! Now we set up the mesh in x:
  xmesh_l(1)=x_L
  do i=1,mxgo
  xmesh_l(2*i) = (x_R+x_L)/Real(2,DP) + (x_R-x_L)/Real(2,DP)*(moments_x_gauss_nodes(i) - dx)
  xmesh_l(2*i+1) = (x_R+x_L)/Real(2,DP) + (x_R-x_L)/Real(2,DP)*(moments_x_gauss_nodes(i) + dx)
  end do
  xmesh_r(1:2*mxgo)=xmesh_l(2:2*mxgo+1)
  xmesh_r(mxgo*2+1) = x_R
  N=mxgo*2+1 ! the new value of (N) in case somebody uses it directly...
  !! mesh in x is ready
  case (2) ! This mesh is to be used with diffusive boundary conditions
           ! and will make 1/8-1/4-1/2 refinement near the walls
           ! Only Static wall is implemented at this time!
           ! Requires N>=6 !!!
  !! allocate memory for the nodes in x
  if (N<6) then
    print *, "SetDGVblzmmesh: For the type 2 nonuniform mesh in x the number of mesh points has to be >=6 (xmesh_l)"
    stop
  end if
    allocate (xmesh_l(1:N), stat=loc_alloc_stat)
    !
    if (loc_alloc_stat >0) then
    print *, "SetDGVblzmmesh: Allocation error for variable (xmesh_l)"
    stop
    end if
    !
    allocate (xmesh_r(1:N), stat=loc_alloc_stat)
    !
    if (loc_alloc_stat >0) then
    print *, "SetDGVblzmmesh: Allocation error for variable (xmesh_r)"
    stop
    end if
    !
    dx=(x_R-x_L)/(Real(N-4,DP)-Real(1,DP)/Real(4,DP))
  !! Now we will set up the mesh in variable x:
    xmesh_l(1)=x_L
    xmesh_l(2)=x_L+dx/Real(8,DP)
    xmesh_l(3)=xmesh_l(2)+dx/Real(4,DP)
    xmesh_l(4)=xmesh_l(3)+dx/Real(2,DP)
     do i=5,N-3
      xmesh_l(i)=xmesh_l(i-1)+dx
     end do
    xmesh_r(N)=x_R
    xmesh_l(N)=xmesh_r(N)-dx/Real(8,DP)
    xmesh_l(N-1)=xmesh_l(N)-dx/Real(4,DP)
    xmesh_l(N-2)=xmesh_l(N-1)-dx/Real(2,DP)
    xmesh_r(1:N-1)=xmesh_l(2:N)
  !! end of the non-uniform mesh type 2.
  case (3) ! This mesh is to be used with diffusive boundary conditions
           ! and will make 1/4-1/2 refinement near the walls
           ! Only Static wall is implemented at this time!
           ! Requires N>=4 !!!
  !! allocate memory for the nodes in x
  if (N<4) then
    print *, "SetDGVblzmmesh: For the type 3 nonuniform mesh in x the number of mesh points has to be >=4 (xmesh_l)"
    stop
  end if
    allocate (xmesh_l(1:N), stat=loc_alloc_stat)
    !
    if (loc_alloc_stat >0) then
    print *, "SetDGVblzmmesh: Allocation error for variable (xmesh_l)"
    stop
    end if
    !
    allocate (xmesh_r(1:N), stat=loc_alloc_stat)
    !
    if (loc_alloc_stat >0) then
    print *, "SetDGVblzmmesh: Allocation error for variable (xmesh_r)"
    stop
    end if
    !
    dx=(x_R-x_L)/(Real(N-2,DP)-Real(1,DP)/Real(2,DP))
  !! Now we will set up the mesh in variable x:
    xmesh_l(1)=x_L
    xmesh_l(2)=x_L+dx/Real(4,DP)
    xmesh_l(3)=xmesh_l(2)+dx/Real(2,DP)
     do i=4,N-2
      xmesh_l(i)=xmesh_l(i-1)+dx
     end do
    xmesh_r(N)=x_R
    xmesh_l(N)=xmesh_r(N)-dx/Real(4,DP)
    xmesh_l(N-1)=xmesh_l(N)-dx/Real(2,DP)
    xmesh_r(1:N-1)=xmesh_l(2:N)
  !!! end of the non-uniform mesh type 3.
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  case default
    allocate (xmesh_l(1:3), stat=loc_alloc_stat)
     !
    if (loc_alloc_stat >0) then
    print *, "SetDGVblzmmesh: Allocation error for variable (xmesh_l)"
    stop
    end if
     !
    allocate (xmesh_r(1:3), stat=loc_alloc_stat)
     !
    if (loc_alloc_stat >0) then
    print *, "SetDGVblzmmesh: Allocation error for variable (xmesh_r)"
    stop
    end if
     !
    xmesh_l = (/ (x_L + (x_R-x_L)/Real(3,DP)*i, i=0,2) /)
    xmesh_r(1:2)=xmesh_l(2:3)
    xmesh_r(3) = x_R
    N=3 ! the new value of (N) in case somebody uses it directly...
    print *, "SetDGVblzmmesh: unsupported choice of non-uniform mesh. x_nonuniform_mesh_type= ", x_nonuniform_mesh_type
end select
 end if
 ! now we will setup the level zero meshes in u ( grids_u/_v/_w and grids_cap_u/_v/_w )
 ! first the mesh in u
  allocate (grids_u(1:Mu+1), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "SetDGVblzmmesh: Allocation error for variable (grids_u)"
  stop
  end if
     !
  allocate (grids_cap_u(1:1), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "SetDGVblzmmesh: Allocation error for variable (grids_cap_u)"
  stop
  end if
     !
  call OldCreateUmesh(grids_u,grids_cap_u,mesh_u_uniform,u_nonuniform_mesh_type,u_L,u_R)
  ! then mesh in v
  allocate (grids_v(1:Mv+1), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "SetDGVblzmmesh: Allocation error for variable (grids_v)"
  stop
  end if
     !
  allocate (grids_cap_v(1:1), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "SetDGVblzmmesh: Allocation error for variable (grids_cap_v)"
  stop
  end if
     !
  call OldCreateUmesh(grids_v,grids_cap_v,mesh_v_uniform, v_nonuniform_mesh_type,v_L,v_R)
  ! now the mesh in w
  allocate (grids_w(1:Mw+1), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "SetDGVblzmmesh: Allocation error for variable (grids_w)"
  stop
  end if
     !
  allocate (grids_cap_w(1:1), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "SetDGVblzmmesh: Allocation error for variable (grids_cap_w)"
  stop
  end if
     !
  call OldCreateUmesh(grids_w,grids_cap_w,mesh_w_uniform,w_nonuniform_mesh_type,w_L,w_R)
     !
 end subroutine SetDGVblzmmesh

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1
!
!  Subroutine OldCreateUmesh
!  This subroutine is used to generate 1D meshes in the velocity variables
!

subroutine OldCreateUmesh(ugrid,ugrid_cap,mesh_u_uniform,u_nonuniform_mesh_type,u_L,u_R)
!
real (DP), dimension (:), intent (out)  :: ugrid
integer (I4B), dimension (:), intent (out)  :: ugrid_cap
logical, intent(in) :: mesh_u_uniform
integer (I4B), intent (in) :: u_nonuniform_mesh_type
real (DP), intent (out) :: u_L, u_R
! local variables:
integer (I4B) :: M ! number of cells in the grid
integer (I4B) :: i,j ! local counters
!!!!!!!!!!!!!!!!!!!!!!!
integer (I4B) :: smr, sml ! refinement parameters for mesh of type 3
real (DP) :: du
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1
M=size(ugrid,1)-1
ugrid_cap(1) = M+1
!
if (mesh_u_uniform) then
  ugrid = (/ (u_L + (u_R-u_L)/Real(M,DP)*i, i=0,M) /)
  else
  select case (u_nonuniform_mesh_type)
  case (1) ! Unsupported
     print *, "OldCreateUmesh: Unsupported type of mesh in velocity variable (u_nonuniform_mesh_type=1)"
     stop
  case (2) ! This mesh is to be used with diffusive boundary conditions
           ! and will include the velocity of the wall, u_{w}=0 as a mesh point
           ! Only Static wall is implemented at this time!
           !
 ! first, let us check that u_wall =0  is in the velocity interval
  if ((u_L > 0.0_DP) .or. (u_R < 0.0_DP)) then
    u_L = min (0.0_DP,u_L)
    u_R = max (0.0_DP,u_R)
  end if
  ! now we start to fill in the mesh:
  i=-M
  j=1
  ugrid(1)=u_L
  do while ( u_R - (u_R-u_L)/Real(M,DP)*i > (u_R-u_L)/Real(M,DP)/2 - 0.00000000001_DP )
  if (i*(u_R-u_L)/Real(M,DP)-u_L > (u_R-u_L)/Real(M,DP)/2) then
  j=j+1
  ugrid(j)=i*(u_R-u_L)/Real(M,DP)
  end if
  i=i+1
  end do
  ugrid(M+1)=u_R
  ! now we have filled in the mesh:
 case (3) ! This mesh is to be used with diffusive boundary conditions
           ! and will include the velocity of the wall, u_{w}=0 as a mesh point
           ! also it will surround $u=0$ with small cells. The sizes of the sell are obtained
           ! by refining the size of biggest cells $smr^{sml}$ times. Here $smr$ -- is the
           ! refinement factor and $sml$ is the total level of reinements.
           ! Only Static wall is implemented at this time!
           !
 ! First we set values for $smr$ and $sml$
 smr=10
 sml=2
 if (2*sml > M-2) then
  print *, "SetDGVblzmmesh: selected number of refinements 'sml' of mesh is too large for the given M"
  stop
 end if
   ! now we need to evaluate the size of the largest cell.
 du=(u_R-u_L)/((M-2*sml) + 2.0_DP/Real(smr,DP)* &
             (1.0_DP/(Real(smr,DP)**sml)-1.0_DP)/(1.0_DP/Real(smr,DP)-1.0_DP))
 ! now we start to fill in the mesh:
  j=1
  ugrid(1) = u_L
  do while (ugrid(j) < - du*(1.0_DP/(Real(smr,DP)**sml) - 1.0_DP)/(1.0_DP/Real(smr,DP)-1.0_DP)/Real(smr,DP) - 0.00000000001_DP )
  j=j+1
  ugrid(j)=ugrid(j-1)+du
  end do
  ! Now we fill in the small cells
  do i=1,sml
  j=j+1
  ugrid(j) = ugrid(j-1) + du/(Real(smr,DP)**i)
  end do
  ugrid(j)=0.0_DP ! Just to have it exact --- otherwise it is not zero, but 10^-13
  do i=sml,1,-1
  j=j+1
  ugrid(j) = ugrid(j-1) + du/(Real(smr,DP)**i)
  end do
  ! now the rest of the cells.
  do while (ugrid(j) < u_R - du - 0.00000000001_DP)
  j = j+1
  ugrid(j) = ugrid(j-1)+du
  end do
  ugrid(M+1) = u_R
 case default
     print *, "SetDGVblzmmesh: Unknown type of mesh"
     stop
  end select
 end if
end subroutine OldCreateUmesh

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!   Set3DCellsR_DGVblzm
!
! This subroutine creates a 3D velocity mesh.
!
! The subroutine looks up the grids arrays and creates 3D cells from the grids arrays.
! If more than one grid is defined, grids are treated as non-related. Their ierarchy is ignored -- actually it is
! not known from the grids array rigth away and needs to be discovered by a painful process. So we just do not do it.
! instead, we would like to use this subroutine to create zero level mesh and we will hope that we only have one grid at this point.
!
! Later, another subroutine may be called to create embedded grids.
!
! Depends on the main program. Before calling Make sure su,sv,sw are defined!
! Also make sure that 1D grids in velocity are defined.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine Set3DCellsR_DGVblzm

use commvar, only: grids_cap_u,grids_cap_v,grids_cap_w,grids_u,grids_v,grids_w,su,sv,sw
!
integer (I4B) :: iu,iv,iw, ig ! some local counters

integer (I4B) :: mm,mx,igu,igv,igw ! local scrap counters,
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! creating cells from whaterwer is already in the grids -- refinement will be applied later
!

! we assume that at least one grid of level zero is defined...
if (size(grids_u,1) < 1) then
  print *, "Set3DCellsR_DGVblzm: Error, there seem to be no 1D grids_u/_v/_w defined."
  stop
end if
mm=(grids_cap_u(1)-1)*(grids_cap_v(1)-1)*(grids_cap_w(1)-1)
if (mm < 1) then
  print *, "Set3DCellsR_DGVblzm: Error, at least one of the 1D grids_u/_v/_w defined."
  stop
end if
! create the cells arrays...
call AllocCellsArrsDGV(mm)
! now we will need to populate the cells:
call FillCellsArrsDGV(1,mm, grids_u(1:grids_cap_u(1)),grids_v(1:grids_cap_v(1)),grids_w(1:grids_cap_w(1)),1,su,sv,sw)
! set some counters in case we have more stuff to process...
mx = mm  ! this will accumulate the total number of the recorded cells ...
igu=grids_cap_u(1)
igv=grids_cap_v(1)
igw=grids_cap_w(1)
! now if there is more grids... we needs to continue to create cells...
do ig=2,size(grids_cap_u,1)   ! all grids_u/_v/_w arrays are of the same length
 ! for each grid create cells...
 mm=(grids_cap_u(ig)-1)*(grids_cap_v(ig)-1)*(grids_cap_w(ig)-1) !! this is how many new cells will be on this grid
 ! extend the cells arrays to fit more cells ...
 call ExtendCellsArrsDGV(mx+mm)
 ! now we will need to populate the cells:
 call FillCellsArrsDGV(mx+1,mx+mm,grids_u(igu+1:igu+grids_cap_u(ig)),grids_v(igv+1:igv+grids_cap_v(ig)), &
             grids_w(igw+1:igw+grids_cap_w(ig)),ig,su,sv,sw)
 ! set some counters in case we have more stuff to process...
 mx = mx+mm  ! this will accumulate the total number of the recorded cells ...
 igu=igu+grids_cap_u(ig)
 igv=igv+grids_cap_v(ig)
 igw=igw+grids_cap_w(ig)
 !
end do

end subroutine Set3DCellsR_DGVblzm

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! AllocCellsArrsDGV
!! This is a "macro" subrouting to save some space in another subroutine.
!! given the sizes, it allocates the arrays and returns emply arrays
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine AllocCellsArrsDGV(M)
use commvar, only: cells_pgrid, cells_cgrid, cells_lu, cells_lv, cells_lw, &
                   cells_ru, cells_rv, cells_rw, cells_refu, cells_refv, &
                   cells_refw, cells_gow, cells_gou, cells_gov

integer (I4B), intent (in) :: M ! The size of the arrays...
!
integer (I4B) :: loc_alloc_stat
!!!!!!!!!!!!!!
!
allocate (cells_pgrid(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "AllocCellsArrsDGV: Allocation error for variable (cells_pgrid)"
  stop
  end if
allocate (cells_cgrid(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "AllocCellsArrsDGV: Allocation error for variable (cells_cgrid)"
  stop
  end if
allocate (cells_lu(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "AllocCellsArrsDGV: Allocation error for variable (cells_lu)"
  stop
  end if
allocate (cells_lv(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "AllocCellsArrsDGV: Allocation error for variable (cells_lv)"
  stop
  end if
allocate (cells_lw(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "AllocCellsArrsDGV: Allocation error for variable (cells_lw)"
  stop
  end if
allocate (cells_ru(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "AllocCellsArrsDGV: Allocation error for variable (cells_ru)"
  stop
  end if
allocate (cells_rv(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "AllocCellsArrsDGV: Allocation error for variable (cells_rv)"
  stop
  end if
allocate (cells_rw(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "AllocCellsArrsDGV: Allocation error for variable (cells_rw)"
  stop
  end if
allocate (cells_refu(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "AllocCellsArrsDGV: Allocation error for variable (cells_refu)"
  stop
  end if
allocate (cells_refv(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "AllocCellsArrsDGV: Allocation error for variable (cells_refv)"
  stop
  end if
allocate (cells_refw(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "AllocCellsArrsDGV: Allocation error for variable (cells_refw)"
  stop
  end if
allocate (cells_gou(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "AllocCellsArrsDGV: Allocation error for variable (cells_gou)"
  stop
  end if
allocate (cells_gov(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "AllocCellsArrsDGV: Allocation error for variable (cells_gov)"
  stop
  end if
allocate (cells_gow(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "AllocCellsArrsDGV: Allocation error for variable (cells_gow)"
  stop
  end if
end subroutine AllocCellsArrsDGV

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! ExtendCellsArrsDGV
!! This is a "macro" subroutine to save some space in another subroutine.
!! given the sizes, this subroutine extends the cells arrays
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine ExtendCellsArrsDGV(M)
use commvar, only: cells_pgrid, cells_cgrid, cells_lu, cells_lv, cells_lw, &
                   cells_ru, cells_rv, cells_rw, cells_refu, cells_refv, &
                   cells_refw, cells_gow, cells_gou, cells_gov

integer (I4B), intent (in) :: M ! The new size of the cells arrays...
!
integer (I4B) :: loc_alloc_stat
integer (I4B) :: Md ! a crap variable to keed the old size
!!!!!!!!!!!!!!
real (DP), dimension(:), allocatable ::cpg,ccg,clu,clv,clw,cru,crv,crw,&
                                       crefu,crefv,crefw,cgou,cgov,cgow

Md=size(cells_pgrid, 1)
if (Md>M) then
 print *, "ExtendCellsArrsDGV: new size for arrays cells is smaller then the old one... "
 stop
end if
!!!!
!!!!
allocate (cpg(1:Md),ccg(1:Md),clu(1:Md),clv(1:Md),clw(1:Md),cru(1:Md),crv(1:Md),crw(1:Md), stat=loc_alloc_stat)
!
if (loc_alloc_stat >0) then
  print *, "ExtendCellsArrsDGV: Allocation error for variables cpg,ccg,clu,clv,clw,cru,crv,crw"
  stop
  end if
allocate (crefu(1:Md),crefv(1:Md),crefw(1:Md),cgou(1:Md),cgov(1:Md),cgow(1:Md),stat=loc_alloc_stat)
!
if (loc_alloc_stat >0) then
  print *, "ExtendCellsArrsDGV: Allocation error for variables cells_refw, cells_gow, cells_gou, cells_gov"
  stop
  end if
! save the cells arrays in the temp arrays...
cpg=cells_pgrid
ccg=cells_cgrid
clu=cells_lu
clv=cells_lv
clw=cells_lw
cru=cells_ru
crv=cells_rv
crw=cells_rw
crefu=cells_refu
crefv=cells_refv
crefw=cells_refw
cgow=cells_gow
cgou=cells_gou
cgov=cells_gov
! deallocate the old cells arrays...
deallocate (cells_pgrid, cells_cgrid, cells_lu, cells_lv, cells_lw, &
                   cells_ru, cells_rv, cells_rw, cells_refu, cells_refv, &
                   cells_refw, cells_gow, cells_gou, cells_gov)
! now we allocate with the new size M
allocate (cells_pgrid(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "ExtendCellsArrsDGV: Allocation error for variable (cells_pgrid)"
  stop
  end if
allocate (cells_cgrid(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "ExtendCellsArrsDGV: Allocation error for variable (cells_cgrid)"
  stop
  end if
allocate (cells_lu(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "ExtendCellsArrsDGV: Allocation error for variable (cells_lu)"
  stop
  end if
allocate (cells_lv(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "ExtendCellsArrsDGV: Allocation error for variable (cells_lv)"
  stop
  end if
allocate (cells_lw(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "ExtendCellsArrsDGV: Allocation error for variable (cells_lw)"
  stop
  end if
allocate (cells_ru(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "ExtendCellsArrsDGV: Allocation error for variable (cells_ru)"
  stop
  end if
allocate (cells_rv(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "ExtendCellsArrsDGV: Allocation error for variable (cells_rv)"
  stop
  end if
allocate (cells_rw(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "ExtendCellsArrsDGV: Allocation error for variable (cells_rw)"
  stop
  end if
allocate (cells_refu(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "ExtendCellsArrsDGV: Allocation error for variable (cells_refu)"
  stop
  end if
allocate (cells_refv(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "ExtendCellsArrsDGV Allocation error for variable (cells_refv)"
  stop
  end if
allocate (cells_refw(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "ExtendCellsArrsDGV: Allocation error for variable (cells_refw)"
  stop
  end if
allocate (cells_gou(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "ExtendCellsArrsDGV: Allocation error for variable (cells_gou)"
  stop
  end if
allocate (cells_gov(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "ExtendCellsArrsDGV: Allocation error for variable (cells_gov)"
  stop
  end if
allocate (cells_gow(1:M), stat=loc_alloc_stat)
     !
  if (loc_alloc_stat >0) then
  print *, "ExtendCellsArrsDGV: Allocation error for variable (cells_gow)"
  stop
  end if
!! and the inverse assignment:
cells_pgrid(1:Md)=cpg
cells_cgrid(1:Md)=ccg
cells_lu(1:Md)=clu
cells_lv(1:Md)=clv
cells_lw(1:Md)=clw
cells_ru(1:Md)=cru
cells_rv(1:Md)=crv
cells_rw(1:Md)=crw
cells_refu(1:Md)=crefu
cells_refv(1:Md)=crefv
cells_refw(1:Md)=crefw
cells_gow(1:Md)=cgow
cells_gou(1:Md)=cgou
cells_gov(1:Md)=cgov
!! the rest will be filled outside.
deallocate(cpg,ccg,clu,clv,clw,cru,crv,crw,crefu,crefv,crefw,cgou,cgov,cgow)

end subroutine

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! this subroutine deallocates the cells arrays
!

subroutine  DeAllocCellsArrsDGV
use commvar, only: cells_pgrid, cells_cgrid, cells_lu, cells_lv, cells_lw, &
                   cells_ru, cells_rv, cells_rw, cells_refu, cells_refv, &
                   cells_refw, cells_gow, cells_gou, cells_gov

deallocate(cells_pgrid, cells_cgrid, cells_lu, cells_lv, cells_lw, &
                   cells_ru, cells_rv, cells_rw, cells_refu, cells_refv, &
                   cells_refw, cells_gow, cells_gou, cells_gov)

end subroutine DeAllocCellsArrsDGV

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! FillCellsArrsDGV
!
! This subroutine populates the certain portion of the cells_arrays.
!
! Expects to have cells_arrays to exists and to be of a proper size
!
! cells_cgrid = number of the grid. If the cell is not refined then the value is -1, if the cell is refined than
!               cells_cgrid gives the number of the grid.

subroutine FillCellsArrsDGV(ibeg,iend,umesh,vmesh,wmesh,pgrid,gou,gov,gow)

use commvar, only: cells_pgrid, cells_cgrid, cells_lu, cells_lv, cells_lw, &
                   cells_ru, cells_rv, cells_rw, cells_refu, cells_refv, &
                   cells_refw, cells_gow, cells_gou, cells_gov

integer (I4B), intent(in) :: ibeg,iend ! beginning and end of the range to fill the cells array
real (DP), dimension (0:), intent (in) :: umesh,vmesh,wmesh ! 1D meshes to be used
integer (I4B), intent (in) :: pgrid ! the number of the parent grid --- grid where these cells belong.
integer (I4B), intent (in) :: gou,gov,gow ! the max order of gauss lagrange basis to be assigned to the cells -- all cells in this range will be assigned the same order in all
!
integer (I4B) :: iu,iv,iw,mm ! local counters
! first some elementary checks
if ((size(cells_pgrid,1)< ibeg) .or. (size(cells_pgrid,1)< iend)) then
 print *, "FillCellsArrsDGV: supplied range does not work for the cells arrays. "
 stop
end if
if ((ibeg > iend) .or. ((iend-ibeg + 1) .neqv. (size(vmesh,1)-1)*(size(wmesh,1)-1)*(size(umesh,1)-1)))   then
 print *, "FillCellsArrsDGV: supplied range does not work: ibeg>iend or iend-ibeg + 1 .neq. size(vmesh)*size(wmesh)*size(umesh). "
 stop
end if
! ok, let us populate the cells
! some properties will be the same for the entire range:
cells_pgrid(ibeg:iend) = pgrid
cells_cgrid(ibeg:iend) = -1
cells_refu(ibeg:iend) = 1
cells_refv(ibeg:iend) = 1
cells_refw(ibeg:iend) = 1
cells_gou(ibeg:iend) = gou
cells_gov(ibeg:iend) = gov
cells_gow(ibeg:iend) = gow
! some properties will be different:
mm=ibeg
do iu=0,size(umesh,1)-2
do iv=0,size(vmesh,1)-2
do iw=0,size(wmesh,1)-2
   cells_lu(mm) = umesh(iu)
   cells_lv(mm) = vmesh(iv)
   cells_lw(mm) = wmesh(iw)
   cells_ru(mm) = umesh(iu+1)
   cells_rv(mm) = vmesh(iv+1)
   cells_rw(mm) = wmesh(iw+1)
   mm=mm+1
end do
end do
end do
end subroutine FillCellsArrsDGV

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1
!! CellsRefineDGV
!!
!! This subrotine refines cells that are on the supplied list
!!
!! Depends on the main program. The cells arrays must be set up before calling this subroutine
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine CellsRefineDGV(reflist,refu,refv,refw)

use commvar, only: cells_pgrid, cells_cgrid, cells_lu, cells_lv, cells_lw, &
                   cells_ru, cells_rv, cells_rw, cells_refu, cells_refv, &
                   cells_refw, cells_gow, cells_gou, cells_gov, grids_cap_u, &
                   grids_cap_v,grids_cap_w,grids_u,grids_v,grids_w

integer (I4B), dimension (:), intent (in) :: reflist  !list of cells to refine at this step
integer (I4B), intent(in) :: refu,refv,refw ! refinement factors in dimension u, v, and w
!!!!!!!!
!! IMPORTANT:
!!
integer (I4B) :: go_inc=0 !! THIS IS A PARAMETER: the refined cells will have orders of the parent + go_inc
!!
!!!!!!!!
integer (I4B) :: i,ic,mm ! local counters
integer (I4B) :: isc ! the number of the cell that is being refined
integer (I4B) :: cgrid ! a scrap number to keep the number of the new grid
integer (I4B) :: gou,gov,gow ! the scrap variables to keep the gauss order of the basis
integer (I4B) :: loc_alloc_stat  ! local variable to keep the allocation status

real (DP), dimension (:), allocatable :: dumu,dumv,dumw
! a quick check for errors:
if ((refu*refv*refw < 1 ) .or. (size(reflist,1)<1)) then
  print *,"CellsRefineDGV: error in incoming parameters, refu*refv*refw < 1 or size(reflist,1)<1"
end if
! also, we need to have a shorthand for how many cells we will add
mm=(refu)*(refv)*(refw)
!
do i=1,size(reflist,1)
  isc = reflist(i)
  ! We need to construnct the new refined grids
  allocate (dumu(1:refu+1),dumv(1:refv+1),dumw(1:refw+1), stat=loc_alloc_stat)
    !
  if (loc_alloc_stat >0) then
  print *, "CellsRefineDGV: Allocation error for variable (dumu),(dumv),or (dumw)"
  stop
  end if
     !
  dumu = (/ (cells_lu(isc) + (cells_ru(isc) - cells_lu(isc))/Real(refu,DP)*i, i=0,refu) /)
  dumv = (/ (cells_lv(isc) + (cells_rv(isc) - cells_lv(isc))/Real(refv,DP)*i, i=0,refv) /)
  dumw = (/ (cells_lw(isc) + (cells_rw(isc) - cells_lw(isc))/Real(refw,DP)*i, i=0,refw) /)
  ! Now we need to extend the grids arrays to include the new grids...
  call ExtendGridsDGV(dumu,dumv,dumw,cgrid)
  ! Now we mark the cell with number (isc) to have a child grid...
  cells_cgrid(isc) = cgrid
  cells_refu(isc)= refu
  cells_refv(isc)= refv
  cells_refw(isc)= refw
  ! We also want to know what is the order of the Lagrange basis on that cell:
  gou=cells_gou(isc)
  gov=cells_gov(isc)
  gow=cells_gow(isc)
  ! we need to know how long was cells before we added new:
  ic=size(cells_lu,1)
  ! Now we need to extend the cells arrays to include the new cells...
  call ExtendCellsArrsDGV(ic+mm)
  ! now we need to populate the new cells
  call FillCellsArrsDGV(ic+1,ic+mm,dumu,dumv,dumw,cgrid,gou+go_inc,gov+go_inc,gow+go_inc)
  ! ready to do the next cell
end do

end subroutine CellsRefineDGV

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! ExtendGridsDGV
!
! This subroutine extends the grids_cap_u/_v/_w and the grids_u/_v/_w arrays
! Depends on the main program.
!
! dumu,dumv,dumw -- these are the new grids that need to be added to the old grids...
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine ExtendGridsDGV(dumu,dumv,dumw,cgrid)

use commvar, only: grids_cap_u, grids_cap_v, grids_cap_w, grids_u, grids_v, grids_w

real (DP), dimension (:), intent (in) :: dumu,dumv,dumw ! the new velocity values that will be added to grids
integer (I4B), intent (out) :: cgrid ! the number of the child grid that will be created
!
integer (I4B) :: iu,iv,iw ! some scrap variables...
integer (I4B) :: loc_alloc_stat  ! local variable to keep the allocation status

real (DP), dimension (:), allocatable :: tmp_u,tmp_v,tmp_w ! temporary arrays to keep the old grids

! a quick check for errors
if ((size(dumu,1)< 3 ) .or. (size(dumv,1)< 3) .or. (size(dumw,1)< 3 )) then
  print *,"ExtendGridsDGV: error in incoming parameters, at least one of the arrays does not require a refinement < 1"
end if
! create the dump arrays to save current grids_cap_u/v/w:
iu=size(grids_cap_u,1)
allocate (tmp_u(1:iu),tmp_v(1:iu),tmp_w(1:iu), stat=loc_alloc_stat)
    !
  if (loc_alloc_stat >0) then
  print *, "ExtendGridsDGV: Allocation error 1 for variable (tmp_u),(tmp_v),or (tmp_w)"
  stop
  end if
! save the old grids_cap arrays
tmp_u=grids_cap_u
tmp_v=grids_cap_v
tmp_w=grids_cap_w
! deallocate the grids_cap
deallocate (grids_cap_u,grids_cap_v,grids_cap_w)
! allocate them 1 cell longer...
allocate (grids_cap_u(1:iu+1),grids_cap_v(1:iu+1),grids_cap_w(1:iu+1), stat=loc_alloc_stat)
    !
  if (loc_alloc_stat >0) then
  print *, "ExtendGridsDGV: Allocation error for variable (grids_cap_u/_v/_w)"
  stop
  end if
! restore the old grids_cap arrays
grids_cap_u(1:iu)=tmp_u
grids_cap_v(1:iu)=tmp_v
grids_cap_w(1:iu)=tmp_w
! record the new cells
grids_cap_u(iu+1)=size(dumu,1)
grids_cap_v(iu+1)=size(dumv,1)
grids_cap_w(iu+1)=size(dumw,1)
! done with grids_cap arrays
cgrid = iu+1 ! this will be passed out as the number of the new created grid
deallocate(tmp_u,tmp_v,tmp_w)
! now we extend the grids_u/_v/_w arrays...
iu=size(grids_u,1)
iv=size(grids_v,1)
iw=size(grids_w,1)
allocate (tmp_u(1:iu),tmp_v(1:iv),tmp_w(1:iw), stat=loc_alloc_stat)
    !
  if (loc_alloc_stat >0) then
  print *, "ExtendGridsDGV: Allocation error 2 for variable  (tmp_u),(tmp_v),or (tmp_w)"
  stop
  end if
! save the old grids_u/_v/_w arrays
tmp_u=grids_u
tmp_v=grids_v
tmp_w=grids_w
! deallocate the grids_cap
deallocate(grids_u,grids_v,grids_w)
! allocate them again but longer...
allocate (grids_u(1:iu+size(dumu,1)),grids_v(1:iv+size(dumv,1)),grids_w(1:iw+size(dumw,1)), stat=loc_alloc_stat)
    !
  if (loc_alloc_stat >0) then
  print *, "ExtendGridsDGV: Allocation error for variable (grids_cap_u/_v/_w)"
  stop
  end if
! restore the old grids_cap arrays
grids_u(1:iu)=tmp_u
grids_v(1:iv)=tmp_v
grids_w(1:iw)=tmp_w
! record the new cells
grids_u(iu+1:iu+size(dumu,1)) = dumu
grids_v(iv+1:iv+size(dumv,1)) = dumv
grids_w(iw+1:iw+size(dumw,1)) = dumw
! done with grids_cap arrays
deallocate(tmp_u,tmp_v,tmp_w)
end subroutine ExtendGridsDGV

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! subroutine SetNodesDGV
!
! This subroutine sets all nodes in velocity that will ever be used.
!
! nodes_cells contains the # of the cell where this node belongs
! nodex_x/_y/_z contains the coordinates of the nodes.
! nodes_weights contains the product of the weights of gauss quadrature for each node so that the
!               functions can be evaluated on the nodes and multiplied by the weigth and summed.
!
! grids_cap_u -- stores the grid capasity
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine SetNodesDGV

use commvar, only: nodes_pcell, nodes_u, nodes_v, nodes_w, nodes_gwts,&
				   cells_pgrid, cells_cgrid, cells_lu, cells_lv, cells_lw, &
                   cells_ru, cells_rv, cells_rw, cells_refu, cells_refv, &
                   cells_refw, cells_gow, cells_gou, cells_gov, grids_cap_u, &
                   grids_cap_v,grids_cap_w,grids_u,grids_v,grids_w,g_nds_all, &
                   g_wts_all, nodes_ui, nodes_vi, nodes_wi

intrinsic SUM

integer (I4B) :: ic,im,jm,iu,iv,iw ! some scrap variables...
real (DP) :: ru,qu,rv,qv,rw,qw ! some scrap variables ...

integer (I4B) :: loc_alloc_stat  ! local variable to keep the allocation status

im=0
do ic=1,size(cells_pgrid,1)
 if (cells_cgrid(ic) .eq. -1) then
  im=im+cells_gou(ic)*cells_gov(ic)*cells_gow(ic)
 end if
end do
!
! We now allocating the nodes arrays
allocate (nodes_pcell(1:im),nodes_ui(1:im),nodes_vi(1:im),nodes_wi(1:im),stat=loc_alloc_stat)
    !
  if (loc_alloc_stat >0) then
  print *, "SetNodesArDGV: Allocation error for variable (nodes_pcell,nodes_ui/_vi/_wi)"
  stop
  end if

allocate (nodes_u(1:im),nodes_v(1:im),nodes_w(1:im),nodes_gwts(1:im),stat=loc_alloc_stat)
    !
  if (loc_alloc_stat >0) then
  print *, "SetNodesArDGV: Allocation error for variables (nodes_u/_v/_w/_gwts)"
  stop
  end if
! Now we will populate them.
jm=1
do ic=1,size(cells_pgrid,1)
if (cells_cgrid(ic) .eq. -1) then
 do iu=1,cells_gou(ic)
   ru=g_nds_all(iu,cells_gou(ic))*(cells_ru(ic)-cells_lu(ic))/2.0_DP + (cells_ru(ic)+cells_lu(ic))/2.0_DP
   qu=g_wts_all(iu,cells_gou(ic))
 do iv=1,cells_gov(ic)
   rv=g_nds_all(iv,cells_gov(ic))*(cells_rv(ic)-cells_lv(ic))/2.0_DP + (cells_rv(ic)+cells_lv(ic))/2.0_DP
   qv=g_wts_all(iv,cells_gov(ic))
 do iw=1,cells_gow(ic)
   rw=g_nds_all(iw,cells_gow(ic))*(cells_rw(ic)-cells_lw(ic))/2.0_DP + (cells_rw(ic)+cells_lw(ic))/2.0_DP
   qw=g_wts_all(iw,cells_gow(ic))
! ready to fill the nodes!
nodes_pcell(jm) = ic
nodes_u(jm)= ru
nodes_v(jm)= rv
nodes_w(jm)= rw
nodes_gwts(jm)=qu*qv*qw*(cells_ru(ic)-cells_lu(ic))*(cells_rv(ic)-cells_lv(ic))*(cells_rw(ic)-cells_lw(ic))/8.0_DP
nodes_ui(jm)=iu
nodes_vi(jm)=iv
nodes_wi(jm)=iw
jm=jm+1
 end do
 end do
 end do
end if
end do
!
if (jm-1 .ne. im) then
  print *, "SetNodesArDGV: Error, jm-1 .neq. im. Nodes arrays may be populated wrong."
  stop
  end if

end subroutine SetNodesDGV

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! SetCellsUGIAshiftArrays
!
!
! This subroutine is setting up the arrays cells_gui, _gvi, _gwi that
! store the relative integer adress of the cell on the grid.
!
! Only wil work if there is only one grid in the mesh.
!
! Also this subroutine sets up an arrays that gives the adress shift for different nodes to
! read staff from the A-Array.
!
! Note that all these arrays can be created in other places of the algorithm, but we did nto think about them
! earlier. So we put them here.
!
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine SetCellsUGINdsSftArrs(ccell)

use commvar, only: nodes_pcell, nodes_ui, nodes_vi, nodes_wi, cells_ugi, cells_vgi, cells_wgi, &
             cells_pgrid, grids_cap_u, grids_cap_v, grids_cap_w, nodes_Ashift, nodes_phican,&
             cells_gou,cells_gov,cells_gow,nodes_dui,nodes_dvi,nodes_dwi,A_capphi
!!!!!!!!!!
integer (I4B), intent(in) :: ccell ! the number of the canonical cell -- a cell in the middle of the domain for which A is computed
!!!!!!!!!!
integer (I4B) :: i,Ashift,phishift,my_cshift ! scrap variable...
integer (I4B) :: iphi ! the number of the basis function. Recall that each node generates a basis function.
integer (I4B) :: phicell ! the number of the cell where phi belongs
integer (I4B) :: gou,gov,gow ! scrap variables to keep the number of nodes in a cell and the shift in nodes to the canonical cell
integer (I4B) :: pgcu,pgcv,pgcw ! scrap variables to keep the number of cells on the grid in each dimension
integer (I4B) :: ccell_ugi,ccell_vgi,ccell_wgi ! scrap variables to keep the integer address of the canonical cell on the grid
integer :: loc_alloc_stat ! scrap variable to keep the allocation status
!!!!!!!!!!!!!!!!!!!!
if (ccell < 0) then  ! a quick check for garbage in data:
 print *,"EvalCollisionPeriodicA_DGV: Error. The provided value of (ccell) is negative or invalid. Stop."
end if
!!!!
if (size(grids_cap_u,1) /= 1) then
     print *, "SetCellsUGIAshiftArrays: Error. The number of grids must be 1. Stop"
     stop
end if
!!! First, we need to calculate some useful constants:
gou=cells_gou(ccell)
gov=cells_gov(ccell)
gow=cells_gow(ccell)
my_cshift=(ccell-1)*gou*gov*gow ! this will be the number of the node right before the first node in canonical cell
! first we find the number of cells in each dimension
pgcu=grids_cap_u(cells_pgrid(ccell))-1
pgcv=grids_cap_v(cells_pgrid(ccell))-1
pgcw=grids_cap_w(cells_pgrid(ccell))-1
! now we will calculate the relative integer address of all cells on the grid.
! first, we create a space where to store this information:
i=size(cells_pgrid,1)
allocate (cells_ugi(1:i),cells_vgi(1:i),cells_wgi(1:i),stat=loc_alloc_stat)
    !
  if (loc_alloc_stat >0) then
  print *, "SetCellsUGIAshiftArrays: Allocation error for variable (cells_ugi/_vgi/_wgi)"
  stop
  end if
! Nex we will calculate the adresses
! IMPORTANT! Notice that this algorithm uses the convention that when enumerating cells the outside loop is in x, the
! middle loop is in y and the innermost is in z.

do phicell = 1,pgcu*pgcv*pgcw ! loop in all cells
!
ccell_ugi=1
ccell_vgi=1
ccell_wgi=1
i=1
do while (i<phicell)
 i=i+1
 if (ccell_wgi == pgcw) then
   ccell_wgi = 1
   if (ccell_vgi == pgcv) then
     ccell_vgi = 1
     if (ccell_ugi == pgcu) then
      print *,"EvalCollisionPeriodicA_DGV: Error the index of the canonical cell is not fouind. Value of (gui) is too big."
      stop
     else
      ccell_ugi=ccell_ugi+1
     end if
   else
     ccell_vgi=ccell_vgi+1
   end if
 else
   ccell_wgi = ccell_wgi+1
 end if
end do
! finshed finding the cells addresses, now recording:
cells_ugi(phicell) = ccell_ugi
cells_vgi(phicell) = ccell_vgi
cells_wgi(phicell) = ccell_wgi
end do
! finished finding the local adress of the cells

! Next find the nodes_Ashift and nodes_dui/_dvi/_dwi arrays.
! First we allocated them...
i=size(nodes_vi,1)
allocate (nodes_Ashift(1:i),nodes_dui(1:i),nodes_dvi(1:i),nodes_dwi(1:i),nodes_phican(1:i),stat=loc_alloc_stat)
    !
  if (loc_alloc_stat >0) then
  print *, "SetCellsUGIAshiftArrays: Allocation error for variable (nodes_Ashift,nodes_dui/dvi/dwi)"
  stop
  end if
! next we populate the cells_ugi/_vgi/wgi -arrays...
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
do iphi=1,size(nodes_vi,1)
    phicell = nodes_pcell(iphi)
    if (cells_pgrid(phicell) /= cells_pgrid(ccell)) then
     print *, "SetCellsUGIAshiftArrays: Error. The parent cell of phi belongs to a different grid than the canonical cell. Stop"
     stop
    end if
    ! next we record the shifts in integer index in from the cell containting phi to the canonical
    nodes_dui(iphi)=cells_ugi(phicell) - cells_ugi(ccell)
    nodes_dvi(iphi)=cells_vgi(phicell) - cells_vgi(ccell)
    nodes_dwi(iphi)=cells_wgi(phicell) - cells_wgi(ccell)
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! Now we need to calculate the nodes_Ashift number and the nodes_phican number
    ! First we calculate the number of the node on the canonical cell that corresponds to the node with number iphi
    phishift = my_cshift + (nodes_ui(iphi)-1)*gov*gow + (nodes_vi(iphi)-1)*gow + nodes_wi(iphi) ! this is the number of the node
    nodes_phican(iphi) = phishift ! we will record this number.
    ! Now we will calculate the Ashift number
    Ashift = sum(A_capphi(1:phishift-1))
    nodes_Ashift(iphi)=Ashift
    !!!!! all done
end do
end subroutine SetCellsUGINdsSftArrs

end module miscset


! Verify with CamFort using:
!  camfort invariants-check angle.f90

program degrees
  implicit none

  real, parameter :: deg = -45
  real rad

  rad = toRad(deg)
  print *, rad

contains

  != static_assert pre("deg >= 0" & "deg <= 360")
  != static_assert post("toRad >= 0" & "toRad <= 6.284")
  real function toRad(deg)
    real deg
    real, parameter :: pi = 3.14159265358979323864
    toRad = 2 * pi * (deg/360)
  end function toRad
end program degrees


! libRQZ
! author: daan. camps@cs.kuleuven.be
! Description:
!   Computes elementary rotations
! ___________________________________________________________________
module d_ctransformations

use u_parameters
implicit none
private
public d_compute_ct, d_apply_ct_r, d_apply_ct_l

contains

  subroutine d_compute_ct(x,y,c,s,r)
  ! Computes an elementary ctransformation that introduces a zero
  ! in a real 2x1 vector :
  ! [ c  s ]    [ x  ]        [ r   ]
  ! [      ] *  [    ]    =   [     ]
  ! [-s  c ]    [ y  ]        [ 0   ]
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! x         double [IN]
  !             First element of 2x1 vector
  ! y         double [IN]
  !             Second element of 2x1 vector
  ! c         double [OUT]
  !             Cosine of the rotation matrix
  ! s         double [OUT]
  !             Sine of the rotation matrix
  ! r         double [OUT]
  !             Remainder of the vector after rotating (2-norm)
  !___________________________________________________________________________
  ! last edit: September 5, 2018
    real(kind=dp), intent(in)  :: x,y
    real(kind=dp), intent(out) :: c,s,r

    ! real(kind=dp)              :: t ! Only required in own implementation

    call DLARTG( x, y, c, s, r )

    ! if (abs(y) .lt. sfmin) then
    !   c = done
    !   s = dzero
    !   r = x
    ! else
    !   if ( abs(x) .gt. abs(y) ) then
    !     t = y/x
    !     r = sqrt(done + abs(t)**2)
    !     c = done / r
    !     if ( x .lt. dzero ) then
    !       c = -c
    !     end if
    !     s = t * c
    !     r = abs(x) * r
    !   else
    !     t = x/y
    !     r = sqrt(done + abs(t)**2)
    !     s = done / r
    !     if (y .lt. dzero ) then
    !       s = -s
    !     end if
    !     c = t * s
    !     r = abs(y) * r
    !   end if
    ! end if
  end subroutine

  subroutine d_apply_ct_l(v1,v2,c,s)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Applies an elementary rotation from the left to two row
  ! vectors v1 and v2 of equal lenght :
  ! [ c  s ]    [ v1  ]
  ! [      ] *  [     ]
  ! [-s  c ]    [ v2  ]
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! v1        double array [INOUT]
  !             First row vector, on output equal to c * v1 + s * v2
  ! v2        double array [INOUT]
  !             Second row vector, on output equal to -s * v1 + c * v2
  ! c         double [IN]
  !             Cosine of rotation
  ! s         double [IN]
  !             Sine of rotation
  !___________________________________________________________________________
  ! last edit: September 5, 2018
    real(kind=dp), intent(inout)  :: v1(:),v2(:)
    real(kind=dp), intent(in)     :: c, s

    integer                       :: i, n
    real(kind=dp)                 :: t

    n = size(v1)
    do i=1, n
      t = c * v1(i) + s * v2(i)
      v2(i) = -s * v1(i) + c * v2(i)
      v1(i) = t
    end do
  end subroutine

  subroutine d_apply_ct_r(v1,v2,c,s)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Applies an elementary rotation from the left to two column
  ! vectors v1 and v2 of equal lenght :
  ! [     ]   [ c  s ]
  ! [v1 v2] * [      ]
  ! [     ]   [-s  c ]
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! v1        double array [INOUT]
  !             First column vector, on output equal to c * v1 - s * v2
  ! v2        double array [INOUT]
  !             Second row vector, on output equal to s * v1 + c * v2
  ! c         double [IN]
  !             Cosine of rotation
  ! s         double [IN]
  !             Sine of rotation
  !___________________________________________________________________________
  ! last edit: September 5, 2018
    real(kind=dp), intent(inout)  :: v1(:),v2(:)
    real(kind=dp), intent(in)     :: c, s

    integer                       :: i, n
    real(kind=dp)                 :: t

    n = size(v1)
    do i=1, n
      t = c * v1(i) - s * v2(i)
      v2(i) = s * v1(i) + c * v2(i)
      v1(i) = t
    end do
  end subroutine
end module


*deck aratio_hex
      subroutine aratio_hex(xl1,yl1,zl1,
     *                      xl2,yl2,zl2,
     *                      xl3,yl3,zl3,
     *                      xl4,yl4,zl4,
     *                      xl5,yl5,zl5,
     *                      xl6,yl6,zl6,
     *                      xl7,yl7,zl7,
     *                      xl8,yl8,zl8,
     *                      arathex)
C
C
C #####################################################################
C
C     PURPOSE -
C
C        Finds the aspect ratio of a hex.
C
C     INPUT ARGUMENTS -
C
C        (x1,y1,z1),...,(x8,y8,z8) - The coordinates of the hex.
C
C     OUTPUT ARGUMENTS -
C
C        arathex : The aspect ratio of the hex.
C
C     CHANGE HISTORY -
C
C$Log: aratio_hex.f,v $
CRevision 2.00  2007/11/05 19:45:46  spchu
CImport to CVS
C
CPVCS
CPVCS       Rev 1.0   Fri Aug 29 14:11:30 1997   dcg
CPVCS    Initial revision.
C
C ######################################################################
C
C
      implicit none
C
      include "local_element.h"
C
      real*8 xl1,yl1,zl1,xl2,yl2,zl2,xl3,yl3,zl3,xl4,yl4,zl4,
     *       xl5,yl5,zl5,xl6,yl6,zl6,xl7,yl7,zl7,xl8,yl8,zl8
      real*8 arathex
      real*8 xb,yb,zb,xc,yc,zc,xd,yd,zd,xe,ye,ze
      real*8 smdiag,lardiag,dist

      integer i

      dimension dist(4)

C
C ######################################################################
C
C
C  Calculation of "dist", the length of the
C  diagonals of the quad.
C

      xb = xl1 - xl7
      yb = yl1 - yl7
      zb = zl1 - zl7
      xc = xl2 - xl8
      yc = yl2 - yl8
      zc = zl2 - zl8
      xd = xl3 - xl5
      yd = yl3 - yl5
      zd = zl3 - zl5
      xe = xl4 - xl6
      ye = yl4 - yl6
      ze = zl4 - zl6

      dist(1) = sqrt ( xb*xb + yb*yb + zb*zb )
      dist(2) = sqrt ( xc*xc + yc*yc + zc*zc )
      dist(3) = sqrt ( xd*xd + yd*yd + zd*zd )
      dist(4) = sqrt ( xe*xe + ye*ye + ze*ze )

      smdiag = dist(1)
      lardiag = dist(1)
      do 21 i=2,4
         if(dist(i) .ge. lardiag) lardiag = dist(i)
         if(dist(i) .le. smdiag) smdiag = dist(i)
 21   continue

      arathex = smdiag/lardiag

      return
      end


!
! Example illustrating the use of the frand123 Fortran interface for the
! generation of single precision normally distributed random numbers.
! The example estimates the excess kurtosis of the underlying normal
! distribution with expectation mu = 0.7 and variance sigma = 1.6
!

program kurtosisSingle
   use, intrinsic :: iso_c_binding, only: c_double, c_float
   use omp_lib, only: omp_get_wtime
   use frand123, only: frand123State_t, frand123Init, frand123NormSingle
   implicit none

   ! integer kind for large integers
   integer, parameter :: ik = selected_int_kind( 10 )

   ! number of draws used to estimate the excess kurtosis
   integer( kind = ik ), parameter :: numberOfSamples = 1000 * 1000 * 100

   ! expectation and variance of the normal distribution to draw from
   real( kind = c_float ), parameter :: mu = real( 0.7, c_float )
   real( kind = c_float ), parameter :: sigma = real( 1.6, c_float )

   ! state for frand123
   type( frand123State_t ) :: state

   ! timing variables
   real( kind = c_double ) :: startTime, endTime

   ! result variables
   real( kind = c_float ) :: varScalar, varTwo, varFour, var1000

   ! initialize state
   call frand123Init( state, 0, 0 )

   ! use excessKurtosisScalar
   startTime = omp_get_wtime()
   varScalar = excessKurtosisScalar( state )
   endTime = omp_get_wtime()
   write(*, '( "Result generating  one random number at a time: ", ES11.4, &
          & " took ", ES11.4, " seconds" )' ) varScalar, endTime - startTime

   ! use excessKurtosisTwo
   startTime = omp_get_wtime()
   varTwo = excessKurtosisTwo( state )
   endTime = omp_get_wtime()
   write(*, '( "Result generating  two random number at a time: ", ES11.4, &
          & " took ", ES11.4, " seconds" )' ) varTwo, endTime - startTime

   ! use excessKurtosisFour
   startTime = omp_get_wtime()
   varFour = excessKurtosisFour( state )
   endTime = omp_get_wtime()
   write(*, '( "Result generating four random number at a time: ", ES11.4, &
          & " took ", ES11.4, " seconds" )' ) varFour, endTime - startTime

   ! use excessKurtosis1000
   startTime = omp_get_wtime()
   var1000 = excessKurtosis1000( state )
   endTime = omp_get_wtime()
   write(*, '( "Result generating 1000 random number at a time: ", ES11.4, &
          & " took ", ES11.4, " seconds" )' ) var1000, endTime - startTime

contains

   ! estimate excess kurtosis by drawing a single single precision sample at a
   ! time
   real( kind = c_float ) function excessKurtosisScalar( state )
      implicit none
      type( frand123State_t ), intent( inout ) :: state

      ! local variables
      real( kind = c_float ) :: excessKurtosis
      real( kind = c_float ) :: draw
      integer( kind = ik ) :: i

      ! iterate over samples
      excessKurtosis = real( 0, c_float )
      do i = 1, numberOfSamples
         ! draw random number
         call frand123NormSingle( state, mu, sigma, draw )
         ! centralize
         draw = draw - mu
         ! sum up contributions
         excessKurtosis = excessKurtosis + draw ** 4
      enddo
      ! apply remaining operations
      excessKurtosisScalar = excessKurtosis / &
          ( real( numberOfSamples, c_float) * sigma ** 4 ) - real( 3., c_float )
   end function excessKurtosisScalar

   ! estimate excess kurtosis by drawing two single precision sample at a time
   real( kind = c_float ) function excessKurtosisTwo( state )
      implicit none
      type( frand123State_t ), intent( inout ) :: state

      ! local variables
      real( kind = c_float ) :: excessKurtosis
      real( kind = c_float ), dimension( 2 ) :: draw
      integer( kind = ik ) :: i

      ! iterate over samples
      excessKurtosis = real( 0, c_float )
      do i = 1, numberOfSamples, 2
         ! draw random number
         call frand123NormSingle( state, mu, sigma, draw )
         ! centralize
         draw = draw - mu
         ! sum up contributions
         excessKurtosis = excessKurtosis + sum( draw ** 4 )
      enddo
      ! apply remaining operations
      excessKurtosisTwo = excessKurtosis / &
          ( real( numberOfSamples, c_float) * sigma ** 4 ) - real( 3., c_float )
   end function excessKurtosisTwo

   ! estimate excess kurtosis by drawing four single precision sample at a time
   real( kind = c_float ) function excessKurtosisFour( state )
      implicit none
      type( frand123State_t ), intent( inout ) :: state

      ! local variables
      real( kind = c_float ) :: excessKurtosis
      real( kind = c_float ), dimension( 4 ) :: draw
      integer( kind = ik ) :: i

      ! iterate over samples
      excessKurtosis = real( 0, c_float )
      do i = 1, numberOfSamples, 4
         ! draw random number
         call frand123NormSingle( state, mu, sigma, draw )
         ! centralize
         draw = draw - mu
         ! sum up contributions
         excessKurtosis = excessKurtosis + sum( draw ** 4 )
      enddo
      ! apply remaining operations
      excessKurtosisFour = excessKurtosis / &
          ( real( numberOfSamples, c_float) * sigma ** 4 ) - real( 3., c_float )
   end function excessKurtosisFour

   ! estimate excess kurtosis by drawing 1000 single precision sample at a time
   real( kind = c_float ) function excessKurtosis1000( state )
      implicit none
      type( frand123State_t ), intent( inout ) :: state

      ! local variables
      real( kind = c_float ) :: excessKurtosis
      real( kind = c_float ), dimension( 1000 ) :: draw
      integer( kind = ik ) :: i

      ! iterate over samples
      excessKurtosis = real( 0, c_float )
      do i = 1, numberOfSamples, 1000
         ! draw random number
         call frand123NormSingle( state, mu, sigma, draw )
         ! centralize
         draw = draw - mu
         ! sum up contributions
         excessKurtosis = excessKurtosis + sum( draw ** 4 )
      enddo
      ! apply remaining operations
      excessKurtosis1000 = excessKurtosis / &
          ( real( numberOfSamples, c_float) * sigma ** 4 ) - real( 3., c_float )
   end function excessKurtosis1000
end program kurtosisSingle


module hyperModelsLib
use funcAux
implicit none
private  Delfino, MooneyRivlin, Fibre, vol, calcInvCfromF, calcInvCfromC, calcInvCMfromF, calcInvCMfromC, Ciarlet , &
		DelfinoDpsi, DelfinoCompDPsi, MooneyRivlinDPsi, MooneyRivlinCompDPsi, MooneyRivlinComp2DPsi
public StrainEnergy, StrainEnergyC, strainEnergyDpsi

contains

subroutine Ciarlet(Psi,InvC,MatPar) !! page 259, Computation Inelasticity
	implicit none
	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: InvC(:),MatPar(:)
	real*8 :: E, nu , lambda, mu, J, I1

	E = MatPar(1)
	nu = MatPar(2)

	lambda = E*nu/((1.0d0 + nu)*(1.0d0 - 2.0d0*nu))
	mu = 0.5d0*E/(1.0d0 + nu)

	J = dsqrt(InvC(3)) ! J
	I1 = InvC(1)

	Psi = 0.25d0*(J*J-1.0d0) - (0.5d0*lambda + mu)*dlog(J) + 0.5d0*mu*(I1 - 3.0d0)

end subroutine

subroutine vol(Psi,InvC,MatPar)
	implicit none
	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: InvC(:),MatPar
	real*8 :: c1,I3, J
	c1 = MatPar ! kappa

	J = dsqrt(InvC(3)) ! J

	Psi = c1*(J - 1.0d0)**2.0d0

end subroutine

!~ subroutine vol(Psi,invC,MatPar)
!~ 	implicit none
!~ 	real*8 , intent(out) :: Psi
!~ 	real*8 , intent(in) :: InvC(:),MatPar
!~ 	real*8 :: c1,J
!~ 	c1 = MatPar ! kappa
!~
!~ 	J = dsqrt(invC(3)) ! J
!~
!~ 	Psi = 0.5d0*c1*( J*J - 1.0d0 - 2.0d0*dlog(J) )
!~ 	return
!~ end subroutine

!~ subroutine vol(Psi,invC,MatPar)
!~ 	implicit none
!~ 	real*8 , intent(out) :: Psi
!~ 	real*8 , intent(in) :: InvC(:),MatPar
!~ 	real*8 :: c1,J
!~ 	c1 = MatPar ! kappa
!~
!~ 	J = dsqrt(invC(3)) ! J
!~
!~ 	Psi = 0.5d0*c1*( 0.5d0*(J*J - 1.0d0) - dlog(J) )
!~ 	return
!~ end subroutine

!~
!~ subroutine vol(Psi,invC,MatPar)
!~ 	implicit none
!~ 	real*8 , intent(out) :: Psi
!~ 	real*8 , intent(in) :: InvC(:),MatPar
!~ 	real*8 :: c1, J
!~ 	c1 = MatPar ! kappa
!~
!~ 	J = dsqrt(InvC(3)) ! J

!~ 	Psi = c1*dlog(J)**2.0d0
!~ 	return
!~ end subroutine

!~ subroutine vol2(Psi,C,MatPar)
!~ 	implicit none
!~ 	real*8 , intent(out) :: Psi
!~ 	real*8 , intent(in) :: C(:,:),MatPar(2)
!~ 	real*8 :: c1,c2,I3
!~
!~ 	c1 = 2.0d0*MatPar(1) ! kappa
!~ 	c2 = MatPar(2) ! kappa
!~
!~ 	write(0,*) "New volumetric penalty function"
!~
!~ 	call calcI3(I3,C)
!~ 	I3 = dlog(dsqrt(I3)) ! J
!~
!~ 	Psi = -c1*I3 + c2*I3*I3
!~ 	return
!~ end subroutine

subroutine Delfino(Psi,invC,MatPar)
! Delfino et al. [10] proposed an (isotropic) rubber-like potential for carotid arteries
          ! [10] A. Delfino, N. Stergiopulos, J.E. Moore and J.-J. Meister,
          ! Residual strain effects on the stress field in a thick wall
          ! finite element model of the human carotid bifurcation.
          ! J. Biomech. 30 (1997) 777786.
	implicit none
	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: invC(:),MatPar(2)
	real*8 :: c1,c2,c3,I1bar,J,rI33
	c1 = MatPar(1) ! a
	c2 = MatPar(2)*0.5d0 ! b/2

	J = dsqrt(InvC(3)) ! J
	rI33 = J**(-2.0D0/3.0D0)
	I1bar = rI33*InvC(1) ! I1bar

	Psi = 0.5d0*(c1/c2)*( Dexp(c2*(I1bar-3.0d0))-1.0d0 )

end subroutine

!~ subroutine MooneyRivlin(Psi,invC,MatPar)
!~  !Mooney Rivlin Bathe, K.J., Finite Element Procedures, pp.592; see also 6.4 pp.561
!~  !Crisfield M.A. Vol II, Chap 13, pp 62. See also, Section 10.3 pp 07
!~ 	implicit none
!~ 	real*8 , intent(out) :: Psi
!~ 	real*8 , intent(in) :: invC(:),MatPar(2)
!~ 	real*8 :: c1,c2,I1bar,I2bar,J,rI33
!~ 	c1 = MatPar(1)
!~ 	c2 = MatPar(2)
!~
!~ 	J = dsqrt(InvC(3)) ! J
!~ 	rI33 = J**(-2.0D0/3.0D0)
!~ 	I1bar = rI33*InvC(1) ! I1bar
!~ 	I2bar = rI33*rI33*invC(2) ! I2bar
!~ 	Psi = c1*(I1bar-3.0d0) + c2*(I2bar-3.0d0)
!~ 	return
!~ end subroutine

subroutine MooneyRivlin(Psi,invC,MatPar)
 !Mooney Rivlin Bathe, K.J., Finite Element Procedures, pp.592; see also 6.4 pp.561
 !Crisfield M.A. Vol II, Chap 13, pp 62. See also, Section 10.3 pp 07
	implicit none
	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: invC(:),MatPar(2)
	real*8 :: c1,c2,I1bar,I2bar,J,rI33
	c1 = MatPar(1)
	c2 = MatPar(2)

	J = dsqrt(InvC(3)) ! J
	rI33 = J**(-2.0D0/3.0D0)
	I1bar = rI33*InvC(1) ! I1bar
	I2bar = rI33*rI33*invC(2) ! I2bar
	Psi = c1*(I1bar-3.0d0) + c2*(I2bar-3.0d0)
	return
end subroutine

subroutine MooneyRivlinModified(Psi,invC,MatPar)  !! the constants decrease with the deformation
	implicit none
	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: invC(:),MatPar(2)
	real*8 :: c1,c2,I1bar,I2bar,J,rI33
	c1 = MatPar(1)
	c2 = MatPar(2)

	J = dsqrt(InvC(3)) ! J
	rI33 = J**(-2.0D0/3.0D0)
	I1bar = rI33*InvC(1) ! I1bar
	I2bar = rI33*rI33*invC(2) ! I2bar

	c1 = c1/J
	c2 = c2/J

	Psi = c1*(I1bar-3.0d0) + c2*(I2bar-3.0d0)
	return
end subroutine

subroutine Fibre(Psi,invCM,MatPar) ! see my dissertation
	implicit none
	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: invCM(:),MatPar(2) ! MatPar is only the material coeficient, a0 was splitted
 	real*8 :: c1,c2,I4
	c1 = MatPar(1) ! k1
	c2 = MatPar(2) ! k2

	I4 = invCM(2) !! already incompressible

	Psi = 0.5d0*(c1/c2)*( Dexp(c2*(I4-1.0d0)**2.0d0)-1.0d0 )

end subroutine

subroutine MatrixRegularisation(Psi,invC,MatPar)
	implicit none
	real*8 , intent(out) :: Psi
	real*8 , intent(in) :: invC(:),MatPar(4)
!~  	real*8 :: c1,c2, c3,c4, I1, J
!~ 	c1 = MatPar(1)
!~ 	c2 = MatPar(2)
!~ 	c3 = MatPar(3)
!~ 	c4 = MatPar(4)

!~ 	I1 = invC(1)
!~ 	J = dsqrt(invC(3))

!~ 	if(J>c4) then
!~ 		J = c4
!~ 	end if

!~ 	if(I1>c3) then
!~ 		I1 = c3
!~ 	end if

!~ 	Psi = c1*(I1 - 3.0d0) + c2*( J*J - 1.0d0 - 2.0d0*dlog(J) )

	real*8 :: c1,c2,I1bar,I2bar,J,rI33, c3, c4
	c1 = MatPar(1)
	c2 = MatPar(2)
	c3 = MatPar(3)
	c4 = MatPar(4)

	J = dsqrt(InvC(3)) ! J
	rI33 = J**(-2.0D0/3.0D0)
	I1bar = rI33*InvC(1) ! I1bar
	I2bar = rI33*rI33*invC(2) ! I2bar

!~ 	if(I1bar > c2) then
!~ 		c1 = 0.0d0
!~ 	end if

!~ 	if(J > c4) then
!~ 		c3 = 0.0d0
!~ 	end if

!~ 	c1 = c1/(J**2.0d0)
!~ 	c3 = c3/(J**2.0d0)

	c1 = c1/J
	c3 = c3/J

	Psi = c1*(I1bar-3.0d0) + c3*(J - 1.0d0)**2.0d0

end subroutine

subroutine calcInvCMfromF(invCM,F,beta)
	real*8 , intent(in) :: F(:,:), beta
	real*8 , intent(out) :: InvCM(:)
	real*8 :: v(size(F,1)), J , a0(size(F,1))

	a0(1) = dcos(beta)
	a0(2) = dsin(beta)

	v = matmul(F,a0)
	InvCM(1) = dot_product(v,v)

	call calcI3(J,F)

	InvCM(2) = (J**(-2.0D0/3.0D0))*InvCM(1) ! incompressible

end subroutine

subroutine calcInvCMfromC(invCM,C,beta)
	real*8 , intent(in) :: C(:,:), beta
	real*8 , intent(out) :: InvCM(:)
	real*8 :: v(size(C,1)), J, a0(size(C,1))

	a0(1) = dcos(beta)
	a0(2) = dsin(beta)

	v = matmul(C,a0)
	InvCM(1) = dot_product(v,a0)

	call calcI3(J,C)
	J = dsqrt(J)

	InvCM(2) = (J**(-2.0D0/3.0D0))*InvCM(1) ! incompressible

end subroutine

subroutine calcInvCfromC(invC,C)
	real*8 , intent(in) :: C(:,:)
	real*8 , intent(out) :: InvC(:)

	call calcI1(InvC(1),C)
	call calcI2(InvC(2),C)
	call calcI3(InvC(3),C)

end subroutine

subroutine calcInvCfromF(invC,F)
	real*8 , intent(in) :: F(:,:)
	real*8 , intent(out) :: InvC(:)
	real*8 :: C(size(F,1),size(F,2))

	C = matmul(transpose(F),F)

	call calcI1(InvC(1),C)
	call calcI2(InvC(2),C)
	call calcI3(InvC(3),C)

end subroutine

subroutine strainEnergy(energy,F,matPar,constLaw)
	real*8, intent(in) :: F(:,:) , matPar(:)
	real*8 , intent(out) :: energy
	integer , intent(in) :: constLaw
	real*8 :: energyTemp, invC(3)

	if(constLaw<10) then
		call calcInvCfromF(invC,F)
	else
		call calcInvCMfromF(invC,F,matPar(3))
	end if

	energy = 0.0d0
	energyTemp = 0.0d0

	selectcase(constLaw)
		case(1)
			call Delfino(energy,invC,matPar(1:2))
		case(2)
			call MooneyRivlin(energy,invC,matPar(1:2))
		case(3)
			call Delfino(energy,invC,matPar(1:2))
			call vol(energyTemp,invC,matPar(3))
			energy = energy + energyTemp
		case(4)
			call MooneyRivlin(energy,invC,matPar(1:2))
            call vol(energyTemp,invC,matPar(3))
            energy = energy + energyTemp
		case(5)
			call Ciarlet(energy,invC,matPar(1:2))
		case(8)
			call MatrixRegularisation(energy,invC,matPar(1:4))
		case(9)
			call MooneyRivlinModified(energy,invC,matPar(1:2)) !! the constants decrease with the deformation
		case(13)
			call Fibre(energy,invC,matPar(1:2))
		case default
			write(0,*) constLaw, matpar(1:3), "Strain Energy case unknown"
			PAUSE
	end select

end subroutine

subroutine strainEnergyC(energy,C,matPar,constLaw)
	real*8, intent(in) :: C(:,:) , matPar(:)
	real*8 , intent(out) :: energy
	integer , intent(in) :: constLaw
	real*8 ::  energyTemp, invC(3)

	if(constLaw<10) then
		call calcInvCfromC(invC,C)
	else
		call calcInvCMfromC(invC,C,matPar(3))
	end if

	energy = 0.0d0
	energyTemp = 0.0d0

	selectcase(constLaw)
		case(1)
			call Delfino(energy,invC,matPar(1:2))
		case(2)
			call MooneyRivlin(energy,invC,matPar(1:2))
		case(3)
			call Delfino(energy,invC,matPar(1:2))
			call vol(energyTemp,invC,matPar(3))
			energy = energy + energyTemp
		case(4)
			call MooneyRivlin(energy,invC,matPar(1:2))
            call vol(energyTemp,invC,matPar(3))
            energy = energy + energyTemp
		case(5)
			call Ciarlet(energy,invC,matPar(1:2))
		case(9)
			call MooneyRivlinModified(energy,invC,matPar(1:2)) !! the constants decrease with the deformation
		case(13)
			call Fibre(energy,invC,matPar(1:2))
		case default
			write(0,*) constLaw, matpar(1:3), "Strain Energy case unknown"
			PAUSE
	end select

end subroutine

!! ============= quadratic ====================
subroutine volDPsi(DPsi,C,MatPar)
	implicit none
	real*8 , intent(out) :: DPsi(:)
	real*8 , intent(in) :: C(:,:),MatPar
	real*8 :: c1,I3
	c1 = MatPar
	call calcI3(I3,C)
	I3 = dsqrt(I3) ! J

	DPsi(3) = c1 - c1/I3
	DPsi(6) = 0.5d0*c1*I3**(-3.0d0)
	return
end subroutine

!! ============= mixed quad-log ======================
!~ subroutine vol(Psi,C,MatPar)
!~ 	implicit none
!~ 	real*8 , intent(out) :: Psi
!~ 	real*8 , intent(in) :: C(:,:),MatPar
!~ 	real*8 :: c1,I3
!~ 	c1 = MatPar ! kappa
!~
!~ 	call calcI3(I3,C)
!~ 	I3 = dsqrt(I3) ! J
!~
!~ 	Psi = c1*( I3*I3 - 1.0d0 - 2.0d0*dlog(I3) )
!~ 	return
!~ end subroutine
!~

! logarithm
!~ subroutine volDPsi(DPsi,C,MatPar)
!~ 	implicit none
!~ 	real*8 , intent(out) :: DPsi(:)
!~ 	real*8 , intent(in) :: C(:,:),MatPar
!~ 	real*8 :: c1,I3, logJ
!~ 	c1 = MatPar
!~ 	call calcI3(I3,C)
!~ 	I3 = dsqrt(I3) ! J
!~ 	logJ = dlog(I3)

!~ 	DPsi(3) = c1*logJ/(I3*I3)
!~ 	DPsi(6) = 0.5d0*c1*(1.0d0 - 2.0d0*logJ)*I3**(-4.0d0)
!~ 	return
!~ end subroutine

subroutine DelfinoDPsi(DPsi,C,MatPar) ! derivatives of Psi with respect to I1 and I2
	implicit none
	real*8 , intent(out) :: DPsi(:)
	real*8 , intent(in) :: C(:,:),MatPar(2)
	real*8 :: c1,c2,I1,rexp
	c1 = MatPar(1) ! a
	c2 = MatPar(2)*0.5d0 ! b/2

	call calcI1(I1,C)

	rexp = dexp(c2*(I1-3.0d0))

	DPsi(1) = 0.5d0*c1*rexp
	DPsi(3) = -I1*c1*rexp/(6.0d0)
	DPsi(4) = 0.5d0*c1*c2*rexp
	DPsi(6) = I1*c1*(I1*c2 + 4.0d0)*rexp/18.0d0
	DPsi(9) = -c1*(I1*c2 + 1.0d0)*rexp/(6.0d0)
	return
end subroutine

subroutine DelfinoCompDPsi(DPsi,C,MatPar)
	implicit none
	real*8 , intent(out) :: DPsi(:)
	real*8 , intent(in) :: C(:,:),MatPar(2)
	real*8 :: c1,c2,I1,I3,rI33,rexp
	c1 = MatPar(1) ! a
	c2 = MatPar(2)*0.5d0 ! b/2

	call calcI1(I1,C)
	call calcI3(I3,C)
	I3 = dsqrt(I3) ! J
	rI33 = I3**(-2.0D0/3.0D0)
	I1 = rI33*I1 ! I1bar
	rexp = dexp(c2*(I1-3.0d0))

	DPsi(1) = 0.5d0*c1*rexp*rI33
	DPsi(3) = -I1*c1*rexp/(6.0d0*I3*I3)
	DPsi(4) = 0.5d0*c1*c2*rexp*rI33*rI33
	DPsi(6) = I1*c1*(I1*c2 + 4.0d0)*rexp*I3**(-4.0d0)/18.0d0
	DPsi(9) = -c1*(I1*c2 + 1.0d0)*rexp/(6.0d0*I3**(8.0d0/3.0d0))
	return
end subroutine

subroutine MooneyRivlinDPsi(DPsi,C,MatPar) ! Derivatives of Psi with respect to I1 and I2
 	implicit none
	real*8 , intent(out) :: DPsi(:)
	real*8 , intent(in) :: C(:,:),MatPar(2)
	real*8 :: c1,c2
	c1 = MatPar(1)
	c2 = MatPar(2)
	DPsi(1) = c1
	DPsi(2) = c2
	return
end subroutine

subroutine MooneyRivlinCompDPsi(DPsi,C,MatPar)
 !Mooney Rivlin Bathe, K.J., Finite Element Procedures, pp.592; see also 6.4 pp.561
 !Crisfield M.A. Vol II, Chap 13, pp 62. See also, Section 10.3 pp 07
	implicit none
	real*8 , intent(out) :: DPsi(:)
	real*8 , intent(in) :: C(:,:),MatPar(2)
	real*8 :: c1,c2,I1,I2,I3,rI33
	c1 = MatPar(1)
	c2 = MatPar(2)
	call calcI1(I1,C)
	call calcI2(I2,C)
	call calcI3(I3,C)
	I3 = dsqrt(I3) ! J
	rI33 = I3**(-2.0D0/3.0D0)
	I1 = rI33*I1 ! I1bar
	I2 = rI33*rI33*I2 ! I2bar

	DPsi(1) = c1*rI33
	DPsi(2) = c2*rI33*rI33
	DPsi(3) = -(I1*c1+2.0d0*I2*c2)/(3.0d0*I3*I3)
	DPsi(6) = (4.0d0*I1*c1 + 10.0d0*I2*c2)/(9.0d0*I3**4.0d0)
	DPsi(8) = -2.0d0*c2*rI33**5.0d0/3.0d0
	DPsi(9) = -c1*rI33**4.0d0/3.0d0

	return
end subroutine

subroutine MooneyRivlinComp2DPsi(DPsi,C,MatPar)
 !Mooney Rivlin Holzapfel , Nonlinear Solid Mechanics pp.247 eq 6.147
	implicit none
	real*8 , intent(out) :: DPsi(:)
	real*8 , intent(in) :: C(:,:),MatPar(3)
	real*8 :: c1,c2,c3,I1,I2,I3,rI33,d
	c1 = MatPar(1)
	c2 = MatPar(2)
	c3 = MatPar(3)
	d = 2.0d0*(c1 + 2.0d0*c2)
	call calcI1(I1,C)
	call calcI2(I2,C)
	call calcI3(I3,C)
	I3 = dsqrt(I3) ! J
	rI33 = I3**(-2.0D0/3.0D0)
	I1 = rI33*I1 ! I1bar
	I2 = rI33*rI33*I2 ! I2bar

	DPsi(1) = c1*rI33
	DPsi(2) = c2*rI33*rI33
	DPsi(3) = -(I1*c1+2.0d0*I2*c2)/(3.0d0*I3*I3) + c3 - c3/I3 - 0.5d0*d/(I3**2.0d0)
	DPsi(6) = (4.0d0*I1*c1 + 10.0d0*I2*c2)/(9.0d0*I3**4.0d0) + c3/(2.0d0*I3**3.0d0) + 0.5d0*d/(I3**4.0d0)
	DPsi(8) = -2.0d0*c2*rI33**5.0d0/3.0d0
	DPsi(9) = -c1*rI33**4.0d0/3.0d0

	return
end subroutine

subroutine strainEnergyDpsi(Dpsi,C,matPar,constLaw)
	real*8, intent(in) :: C(:,:) , matPar(:)
	real*8 , intent(out) :: Dpsi(12)
	integer , intent(in) :: constLaw
	real*8 :: DpsiTemp(12)

	Dpsi = 0.0d0
	DpsiTemp = 0.0d0

	selectcase(constLaw)
		case(0)
			call volDpsi(Dpsi,C,matPar(3))
		case(1)
			call DelfinoDpsi(Dpsi,C,matPar(1:2))
		case(2)
			call MooneyRivlinDpsi(Dpsi,C,matPar(1:2))
		case(3)
			call DelfinoCompDpsi(Dpsi,C,matPar(1:2))
			call volDpsi(DpsiTemp,C,matPar(3))
			DPsi = Dpsi + DpsiTemp
		case(4)
			call MooneyRivlinCompDpsi(Dpsi,C,matPar(1:2))
			call volDpsi(DpsiTemp,C,matPar(3))
			DPsi = Dpsi + DpsiTemp
		case(6)
			call MooneyRivlinComp2Dpsi(Dpsi,C,matPar(1:3))
		case default
			write(0,*) constLaw, "Strain Energy Derivatives case unknown"
			PAUSE
	end select

end subroutine

subroutine strainEnergyDpsi_iso(Dpsi,C,matPar,constLaw) !! improve this, just to solve the problem of taking out the volumetric contribution from DPsi
	real*8, intent(in) :: C(:,:) , matPar(:)
	real*8 , intent(out) :: Dpsi(12)
	integer , intent(in) :: constLaw
	real*8 :: DpsiTemp(12)

	Dpsi = 0.0d0
	DpsiTemp = 0.0d0

	selectcase(constLaw)
		case(1)
			call DelfinoDpsi(Dpsi,C,matPar(1:2))
		case(2)
			call MooneyRivlinDpsi(Dpsi,C,matPar(1:2))
		case(3)
			call DelfinoCompDpsi(Dpsi,C,matPar(1:2))
		case(4)
			call MooneyRivlinCompDpsi(Dpsi,C,matPar(1:2))
		case(6)
			call MooneyRivlinComp2Dpsi(Dpsi,C,matPar(1:3))
		case default
			write(0,*) constLaw, "Strain Energy Derivatives case unknown"
			PAUSE
	end select

end subroutine

end module


subroutine derv(neqn,t,u,ut)
!
! Subroutine derv computes the derivative vector
! of the 1 x 1 ODE problem
!
! Double precision coding is used
implicit double precision(a-h,l,o-z)
!
! Size the arrays
dimension u(neqn), ut(neqn)
!
! Problem parameters
alpha=1.0d0
lambda=1.0d0
!
! Derivative vector
ut(1)=lambda*dexp(-alpha*t)*u(1)
return
!
! End of derv
end


      FUNCTION   ERFC
     &          (arg)

c***********************************************************************
c                         function erfc
c***********************************************************************

c  Program Source:   Naval Ocean Systems Center - Code 542

c  Date:
c     03 Jul 1991

c  Function:
c     Returns the complement of the error function using a polynomial
c     approximation to ERF(x) with error < t 1.5e-7

c  Parameters passed:
c     x              [r]   argument to the function

c  Parameters returned:
c     erfc           [r]   complement of the error function

c  Common blocks referenced:

c  Functions and subroutines referenced:
c     abs
c     exp

c  References:
c     Handbook of Mathematical Functions with Formulas, GRaphs, and
c     Mathematical Tables, Ed. M. Abramowitz and I. A. Stegun, 1970.

c  Change History:

c********************!**************************************************

      data           a1,a2,a3,a4,a5,p/  .254829592,-0.284496736,
     &                                 1.421413741,-1.453152027,
     &                                 1.061405429, 0.3275911/

      x=ABS(arg)
      t=1./(1.+p*x)
      erf=1.-(t*(a1+t*(a2+t*(a3+t*(a4+t*a5)))))*EXP(-x*x)
      if (arg .lt. 0.) erf=-erf
      erfc=1.-erf

      RETURN
      END      ! ERFC


      double precision FUNCTION dDIVDIF(F,A,NN,X,MM)
c F=y points, A=x points, NN=Number of points
c X=Point where interpolation is evaluated, MM=degree of interpolation.
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(NN),F(NN),T(20),D(20)
      LOGICAL EXTRA
      LOGICAL MFLAG,RFLAG
      DATA MMAX/10/
C
C  TABULAR INTERPOLATION USING SYMMETRICALLY PLACED ARGUMENT POINTS.
C
C  START.  FIND SUBSCRIPT IX OF X IN ARRAY A.
      IF( (NN.LT.2) .OR. (MM.LT.1) ) GO TO 20
      N=NN
      M=MIN0(MM,MMAX,N-1)
      MPLUS=M+1
      IX=0
      IY=N+1
      IF(A(1).GT.A(N)) GO TO 4
C     (SEARCH INCREASING ARGUMENTS.)
    1    MID=(IX+IY)/2
         IF(X.GE.A(MID)) GO TO 2
            IY=MID
            GO TO 3
C        (IF TRUE.)
    2       IX=MID
    3    IF(IY-IX.GT.1) GO TO 1
         GO TO 7
C     (SEARCH DECREASING ARGUMENTS.)
    4    MID=(IX+IY)/2
         IF(X.LE.A(MID)) GO TO 5
            IY=MID
            GO TO 6
C        (IF TRUE.)
    5       IX=MID
    6    IF(IY-IX.GT.1) GO TO 4
C
C  COPY REORDERED INTERPOLATION POINTS INTO (T(I),D(I)), SETTING
C  *EXTRA* TO TRUE IF M+2 POINTS TO BE USED.
    7 NPTS=M+2-MOD(M,2)
      IP=0
      L=0
      GO TO 9
    8    L=-L
         IF(L.GE.0) L=L+1
    9    ISUB=IX+L
         IF((1.LE.ISUB).AND.(ISUB.LE.N)) GO TO 10
C        (SKIP POINT.)
            NPTS=MPLUS
            GO TO 11
C        (INSERT POINT.)
   10       IP=IP+1
            T(IP)=A(ISUB)
            D(IP)=F(ISUB)
   11    IF(IP.LT.NPTS) GO TO 8
      EXTRA=NPTS.NE.MPLUS
C
C  REPLACE D BY THE LEADING DIAGONAL OF A DIVIDED-DIFFERENCE TABLE, SUP-
C  PLEMENTED BY AN EXTRA LINE IF *EXTRA* IS TRUE.
      DO 14 L=1,M
         IF(.NOT.EXTRA) GO TO 12
            ISUB=MPLUS-L
            D(M+2)=(D(M+2)-D(M))/(T(M+2)-T(ISUB))
   12    I=MPLUS
         DO 13 J=L,M
            ISUB=I-L
            D(I)=(D(I)-D(I-1))/(T(I)-T(ISUB))
            I=I-1
   13    CONTINUE
   14 CONTINUE
C
C  EVALUATE THE NEWTON INTERPOLATION FORMULA AT X, AVERAGING TWO VALUES
C  OF LAST DIFFERENCE IF *EXTRA* IS TRUE.
      SUM=D(MPLUS)
      IF(EXTRA) SUM=0.5*(SUM+D(M+2))
      J=M
      DO 15 L=1,M
         SUM=D(J)+(X-T(J))*SUM
         J=J-1
   15 CONTINUE
      dDIVDIF=SUM
      RETURN
C
   20 CALL KERMTR('E105.1',LGFILE,MFLAG,RFLAG)
      IF(MFLAG) THEN
         IF(LGFILE.EQ.0) THEN
            IF(MM.LT.1) WRITE(*,101) MM
            IF(NN.LT.2) WRITE(*,102) NN
         ELSE
            IF(MM.LT.1) WRITE(LGFILE,101) MM
            IF(NN.LT.2) WRITE(LGFILE,102) NN
         ENDIF
      ENDIF
      IF(.NOT.RFLAG) CALL ABEND
      RETURN
  101 FORMAT( 7X, 'FUNCTION dDIVDIF ... M =',I6,' IS LESS THAN 1')
  102 FORMAT( 7X, 'FUNCTION dDIVDIF ... N =',I6,' IS LESS THAN 2')
      END