c ======================================================================
c User Subroutine UMAT for Abaqus linear elastic material
c By Irfan Habeeb CN (PhD, Technion - IIT)
c ======================================================================
      subroutine vumat(
C Read only -
     1     nblock, ndir, nshr, nstatev, nfieldv, nprops, lanneal,
     2     stepTime, totalTime, dt, cmname, coordMp, charLength,
     3     props, density, strainInc, relSpinInc,
     4     tempOld, stretchOld, defgradOld, fieldOld,
     5     stressOld, stateOld, enerInternOld, enerInelasOld,
     6     tempNew, stretchNew, defgradNew, fieldNew,
C Write only -
     7     stressNew, stateNew, enerInternNew, enerInelasNew)
C
      include 'vaba_param.inc'
C
      dimension props(nprops), density(nblock), coordMp(nblock,*),
     1     charLength(nblock), strainInc(nblock,ndir+nshr),
     2     relSpinInc(nblock,nshr), tempOld(nblock),
     3     stretchOld(nblock,ndir+nshr),
     4     defgradOld(nblock,ndir+nshr+nshr),
     5     fieldOld(nblock,nfieldv), stressOld(nblock,ndir+nshr),
     6     stateOld(nblock,nstatev), enerInternOld(nblock),
     7     enerInelasOld(nblock), tempNew(nblock),
     8     stretchNew(nblock,ndir+nshr),
     9     defgradNew(nblock,ndir+nshr+nshr),
     1     fieldNew(nblock,nfieldv),
     2     stressNew(nblock,ndir+nshr), stateNew(nblock,nstatev),
     3     enerInternNew(nblock), enerInelasNew(nblock)

      character*80 cmname
      integer k, k1
C inputs
      real*8 e, nu, mu, alamda

      e = props(1)                  ! Young's modulus
      nu = props(2)                 ! poisson's ratio

c lame's parameters
      mu = e/(2.d0*(1.d0 + nu))
      alamda = e*nu/((1.d0 + nu) * (1.d0 - 2.d0*nu))

c stress increment evaluation for each element
      do 10 k = 1, nblock
        trInc = sum(strainInc(k, 1:3))        ! strain trace
        do k1 = 1, ndir
          stressNew(k, k1) = stressOld(k, k1) + alamda*trInc
     1      + 2.d0*mu*strainInc(k, k1)
        end do

c shear stress
        do k1 = 1, nshr
          stressNew(k, ndir+k1) = stressOld(k, ndir+k1) +
     1      2.d0*mu*strainInc(k, ndir+k1)
        end do

 10   continue
      return
      end


      subroutine runC_ii(j,i1,i2,DetGr,Xtwiddle0,Gtwiddle,Shat3,N0)
      implicit none
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,j,i1,i2,n,np
      parameter(np=2)
      double precision DetGr,Xtwiddle0(np),Gtwiddle(np,np)
      double complex Shat3(np,z2max,-2:0),Shat3s(np,z2max,-2:0)

      do ep=-2,0
      do n=1,np
      Shat3s(n,z2(i1,i2),ep)=Shat3(n,z2(i1,i2),ep)
     .   -2d0*(delta(n,i1)*Cv(N0+czzi(i2),ep)
     .        +delta(n,i2)*Cv(N0+czzi(i1),ep))
c      if (ep.eq.-1) then
c      write(6,'(a8,3i3,2(f20.15))') 'Shat3s ',n,i1,i2,
c     .    Shat3(n,z2(i1,i2),ep)
c      write(6,'(a8,3i3,2(f20.15))') 'Shat3s ',n,i1,i2,
c     .   -2d0*delta(n,i1)*Cv(N0+czzi(i2),ep)
c      write(6,'(a8,3i3,2(f20.15))') 'Shat3s ',n,i1,i2,
c     .   -2d0*delta(n,i2)*Cv(N0+czzi(i1),ep)
c      endif
      enddo
      Cv(cii(z2(i1,i2))+N0,ep)=-(
     . +Gtwiddle(j,1)*Shat3s(1,z2(i1,i2),ep)
     . +Gtwiddle(j,2)*Shat3s(2,z2(i1,i2),ep)
     . -DetGr*Cv(ciii(z3(j,i1,i2))+N0,ep))/Xtwiddle0(j)

c      if (ep .eq. -1) then
c      write(6,*) 'Cii ',j,i1,i2,
c     . +Gtwiddle(j,1)*Shat3s(1,z2(i1,i2),ep)/Xtwiddle0(j)
c      write(6,*) 'Cii ',j,i1,i2,
c     . +Gtwiddle(j,2)*Shat3s(2,z2(i1,i2),ep)/Xtwiddle0(j)
c      write(6,*) 'Cii ',j,i1,i2,
c     . -DetGr*Cv(ciii(z3(j,i1,i2))+N0,ep)/Xtwiddle0(j)
c      write(6,*)
c      endif

      enddo

c      pause

      return
      end


!> Orchid -- 2D/3D Euler/MagnetoHydroDynamics solver.
!> Copyright (C) Butakov Oleg 2019.

Module orchid_solver_grid
Use orchid_solver_params
Use orchid_solver_helpers
Implicit None
Type :: MhdGridCell
    Integer :: nface, nface_end
    Integer :: nnode, nnode_end
    Real(8) :: x, y, z
    Real(8) :: Vcell
    Contains
End Type MhdGridCell
Type :: MhdGridFace
    Integer :: ncell_p, ncell_m
    Real(8) :: x, y, z
    Real(8) :: nx, ny, nz
    Real(8) :: Sface
    Contains
End Type MhdGridFace
Type :: MhdGridNode
    Integer :: ncell, ncell_end
    Integer :: bcond
    Real(8) :: x, y, z
    Contains
End Type MhdGridNode
Type :: MhdGrid
    Integer :: ndims
    Integer :: ncells_min, ncells_max
    Integer :: nfaces_min, nfaces_max
    Integer :: nnodes_min, nnodes_max
    Integer, Dimension(:), Allocatable :: cell2face
    Integer, Dimension(:), Allocatable :: cell2node
    Integer, Dimension(:), Allocatable :: node2cell
    Type(MhdGridCell), Dimension(:), Allocatable :: cells
    Type(MhdGridFace), Dimension(:), Allocatable :: faces
    Type(MhdGridNode), Dimension(:), Allocatable :: nodes
    Contains
    Procedure, Public, Non_Overridable :: init1D => mhd_grid_init1D
    Procedure, Public, Non_Overridable :: init2D => mhd_grid_init2D
    Procedure, Public, Non_Overridable :: init2D_polar => mhd_grid_init2D_polar
End Type MhdGrid
Private :: mhd_grid_init1D, &
           mhd_grid_init2D, &
           mhd_grid_init2D_polar
Contains
!########################################################################################################
!########################################################################################################
!########################################################################################################
Subroutine mhd_grid_init1D(This, L, N, Bpp, Bmm)
    !> Initialize a simple 1D cartesian grid.
    !> {{{
    Class(MhdGrid), Intent(InOut) :: This
    Real(8), Intent(In) :: L
    Integer, Intent(In) :: N
    Integer, Intent(In), Optional :: Bpp, Bmm
    !> }}}
    Real(8) :: h
    Integer :: i
    Integer :: Bp, Bm
    !>-------------------------------------------------------------------------------
    !> Parse the boundary conditions.
    If ( Present(Bpp) ) Then
        Bp = Bpp
    Else
        Bp = -1
    End If
    If ( Present(Bmm) ) Then
        Bm = Bmm
    Else
        Bm = -1
    End If
    !>-------------------------------------------------------------------------------

    !>-------------------------------------------------------------------------------
    !> Allocate the Grid.
    This%ndims = 1
    This%ncells_min = 1
    This%ncells_max = N
    This%nfaces_min = 0
    This%nfaces_max = N
    This%nnodes_min = 0
    This%nnodes_max = N
    Allocate(This%cells(This%ncells_min:This%ncells_max))
    Allocate(This%cell2face(This%ncells_min:2*This%ncells_max))
    Allocate(This%cell2node(This%ncells_min:2*This%ncells_max))
    Allocate(This%faces(This%nfaces_min:This%nfaces_max))
    Allocate(This%nodes(This%nnodes_min:This%nnodes_max))
    Allocate(This%node2cell(This%nnodes_min:2*This%nnodes_max + 1))
    !>-------------------------------------------------------------------------------

    !>-------------------------------------------------------------------------------
    !> Initialize Cells, Cell2Face and Cell2Node.
    h = L/Dble(N)
    !$OMP Parallel Do
    Do i = This%ncells_min, This%ncells_max
        This%cells(i)%nface = 2*i - 1
        This%cells(i)%nface_end = 2*i
        This%cell2face(This%cells(i)%nface) = i - 1
        This%cell2face(This%cells(i)%nface_end) = i
        This%cells(i)%nnode = 2*i - 1
        This%cells(i)%nnode_end = 2*i
        This%cell2node(This%cells(i)%nnode) = i - 1
        This%cell2node(This%cells(i)%nnode_end) = i
        This%cells(i)%x = h*( Dble(i) - 0.5D0 )
        This%cells(i)%y = 0.0D0
        This%cells(i)%z = 0.0D0
        This%cells(i)%Vcell = h
    End Do
    !$OMP End Parallel Do
    !> Initialize Faces.
    !$OMP Parallel Do
    Do i = This%nfaces_min, This%nfaces_max
        If ( i == N ) Then
            !> Domain Boundary.
            If ( Bp == -3 ) Then
                !> Periodic boundary conditions.
                This%faces(i)%ncell_p = 1
            Else
                !> Free flow or wall boundary conditions.
                This%faces(i)%ncell_p = Bp
            End If
        Else
            !> Domain Interior.
            This%faces(i)%ncell_p = i + 1
        End If
        If ( i == 0 ) Then
            !> Domain Boundary.
            If ( Bm == -3 ) Then
                !> Periodic boundary conditions.
                This%faces(i)%ncell_m = N
            Else
                !> Free flow or wall boundary conditions.
                This%faces(i)%ncell_m = Bm
            End If
        Else
            !> Domain Interior.
            This%faces(i)%ncell_m = i
        End If
        This%faces(i)%nx = 1.0D0
        This%faces(i)%ny = 0.0D0
        This%faces(i)%nz = 0.0D0
        This%faces(i)%Sface = 1.0D0
    End Do
    !$OMP End Parallel Do
    !> Initialize Nodes.
    !$OMP Parallel Do
    Do i = This%nnodes_min, This%nnodes_max
        If ( i == N ) Then
            !> Domain Boundary.
            If ( Bp == -3 ) Then
                !> Periodic boundary conditions.
                This%nodes(i)%bcond = 0
                This%nodes(i)%ncell_end = 2*i + 1
                This%node2cell(This%nodes(i)%ncell_end) = 1
            Else
                !> Free flow or wall boundary conditions.
                This%nodes(i)%bcond = Bp
                This%nodes(i)%ncell_end = 2*i
            End If
        Else
            !> Domain Interior.
            This%nodes(i)%bcond = 0
            This%nodes(i)%ncell_end = 2*i + 1
            This%node2cell(This%nodes(i)%ncell_end) = i + 1
        End If
        If ( i == 0 ) Then
            !> Domain Boundary.
            If ( Bm == -3 ) Then
                !> Periodic boundary conditions.
                This%nodes(i)%bcond = 0
                This%nodes(i)%ncell = 2*i
                This%node2cell(This%nodes(i)%ncell) = N
            Else
                !> Free flow or wall boundary conditions.
                This%nodes(i)%bcond = Bp
                This%nodes(i)%ncell = 2*i + 1
            End If
        Else
            !> Domain Interior.
            This%nodes(i)%bcond = 0
            This%nodes(i)%ncell = 2*i
            This%node2cell(This%nodes(i)%ncell) = i
        End If
        This%nodes(i)%x = h*Dble(i)
        This%nodes(i)%y = 0.0D0
        This%nodes(i)%z = 0.0D0
    End Do
    !$OMP End Parallel Do
    !>-------------------------------------------------------------------------------
End Subroutine mhd_grid_init1D
!########################################################################################################
!########################################################################################################
!########################################################################################################
Subroutine mhd_grid_init2D(This, Lx, Ly, Nx, Ny, Bppx, Bmmx, Bppy, Bmmy)
    !> Initialize a simple 2D cartesian grid.
    !> {{{
    Class(MhdGrid), Intent(InOut) :: This
    Real(8), Intent(In) :: Lx, Ly
    Integer, Intent(In) :: Nx, Ny
    Integer, Intent(In), Optional :: Bppx, Bmmx, Bppy, Bmmy
    !> }}}
    Real(8) :: hx, hy
    Integer :: i, j, n, m
    Integer :: Bpx, Bmx, Bpy, Bmy
    !>-------------------------------------------------------------------------------
    !> Parse the boundary conditions.
    If ( Present(Bppx) ) Then
        Bpx = Bppx
    Else
        Bpx = -1
    End If
    If ( Present(Bmmx) ) Then
        Bmx = Bmmx
    Else
        Bmx = -1
    End If
    If ( Present(Bppy) ) Then
        Bpy = Bppy
    Else
        Bpy = -1
    End If
    If ( Present(Bmmy) ) Then
        Bmy = Bmmy
    Else
        Bmy = -1
    End If
    !>-------------------------------------------------------------------------------

    !>-------------------------------------------------------------------------------
    !> Allocate the Grid.
    This%ndims = 2
    This%ncells_min = 1
    This%ncells_max = Nx*Ny
    This%nfaces_min = 0
    This%nfaces_max = Nx*( Ny + 1 ) + Ny*( Nx + 1 ) - 1
    Allocate(This%cells(This%ncells_min:This%ncells_max))
    Allocate(This%cell2face(This%ncells_min:4*This%ncells_max))
    Allocate(This%faces(This%nfaces_min:This%nfaces_max))
    !>-------------------------------------------------------------------------------

    !>-------------------------------------------------------------------------------
    !> Initialize Cells, Cell2Face and Cell2Node.
    hx = Lx/Dble(Nx)
    hy = Ly/Dble(Ny)
    !$OMP Parallel Do Private(i, j)
    Do n = This%ncells_min, This%ncells_max
        i = Mod(n - 1, Nx) + 1
        j = ( n - i )/Nx + 1
        This%cells(n)%nface = 4*n - 3
        This%cells(n)%nface_end = 4*n
        This%cell2face(This%cells(n)%nface + 0) = ( i - 1 ) + ( j - 1 )*( Nx + 1 )
        This%cell2face(This%cells(n)%nface + 1) = ( i - 0 ) + ( j - 1 )*( Nx + 1 )
        This%cell2face(This%cells(n)%nface + 2) = i + ( j - 1 )*Nx + Ny*( Nx + 1 ) - 1
        This%cell2face(This%cells(n)%nface_end) = i + ( j - 0 )*Nx + Ny*( Nx + 1 ) - 1
        This%cells(n)%x = hx*( Dble(i) - 0.5D0 )
        This%cells(n)%y = hy*( Dble(j) - 0.5D0 )
        This%cells(n)%z = 0.0D0
        This%cells(n)%Vcell = hx*hy
    End Do
    !$OMP End Parallel Do
    !> Initialize Faces.
    !$OMP Parallel Do Private(i, j, m)
    Do n = This%nfaces_min, This%nfaces_max
        If ( n < Ny*( Nx + 1 ) ) Then
            !> Initialize the Vertical Faces.
            m = n
            i = Mod(m, Nx + 1)
            j = ( m - i )/( Nx + 1 ) + 1
            If ( i == Nx ) Then
                !> Domain Boundary.
                If ( Bpx == -3 ) Then
                    !> Periodic boundary conditions.
                    This%faces(n)%ncell_p = 1 + ( j - 1 )*Nx
                Else
                    !> Free flow or wall boundary conditions.
                    This%faces(n)%ncell_p = Bpx
                End If
            Else
                !> Domain Interior.
                This%faces(n)%ncell_p = i + 1 + ( j - 1 )*Nx
            End If
            If ( i == 0 ) Then
                !> Domain Boundary.
                If ( Bmx == -3 ) Then
                    !> Periodic boundary conditions.
                    This%faces(n)%ncell_m = Nx + ( j - 1 )*Nx
                Else
                    !> Free flow or wall boundary conditions.
                    This%faces(n)%ncell_m = Bmx
                End If
            Else
                !> Domain Interior.
                This%faces(n)%ncell_m = i + 0 + ( j - 1 )*Nx
            End If
            This%faces(n)%x = hx*Dble(i)
            This%faces(n)%y = hy*( Dble(j) - 0.5D0 )
            This%faces(n)%z = 0.0D0
            This%faces(n)%nx = 1.0D0
            This%faces(n)%ny = 0.0D0
            This%faces(n)%nz = 0.0D0
            This%faces(n)%Sface = hx
        Else
            !> Initialize the Horizontal Faces.
            m = n - Ny*( Nx + 1 ) + 1
            i = Mod(m - 1, Nx) + 1
            j = ( m - i )/Nx
            If ( j == Ny ) Then
                !> Domain Boundary.
                If ( Bpy == -3 ) Then
                    !> Periodic boundary conditions.
                    This%faces(n)%ncell_p = i + ( 1 - 1 )*Nx
                Else
                    !> Free flow or wall boundary conditions.
                    This%faces(n)%ncell_p = Bpy
                End If
            Else
                !> Domain Interior.
                This%faces(n)%ncell_p = i + ( j - 0 )*Nx
            End If
            If ( j == 0 ) Then
                !> Domain Boundary.
                If ( Bmy == -3 ) Then
                    !> Periodic boundary conditions.
                    This%faces(n)%ncell_m = i + ( Ny - 1 )*Nx
                Else
                    !> Free flow or wall boundary conditions.
                    This%faces(n)%ncell_m = Bmy
                End If
            Else
                !> Domain Interior.
                This%faces(n)%ncell_m = i + ( j - 1 )*Nx
            End If
            This%faces(n)%x = hx*( Dble(i) - 0.5D0 )
            This%faces(n)%y = hy*Dble(j)
            This%faces(n)%z = 0.0D0
            This%faces(n)%nx = 0.0D0
            This%faces(n)%ny = 1.0D0
            This%faces(n)%nz = 0.0D0
            This%faces(n)%Sface = hy
        End If
    End Do
    !$OMP End Parallel Do
    !>-------------------------------------------------------------------------------
End Subroutine mhd_grid_init2D
!########################################################################################################
!########################################################################################################
!########################################################################################################
Subroutine mhd_grid_init2D_polar(This, Rinner, Router, Nr, Nphi, Bppr, Bmmr)
    !> Initialize a simple 2D polar grid.
    !> {{{
    Class(MhdGrid), Intent(InOut) :: This
    Real(8), Intent(In) :: Rinner, Router
    Integer, Intent(In) :: Nr, Nphi
    Integer, Intent(In), Optional :: Bppr, Bmmr
    !> }}}
    Real(8) :: hr, hphi
    Real(8) :: r, phi
    Integer :: i, j, n, m
    Integer :: Bpr, Bmr
    !>-------------------------------------------------------------------------------
    !> Parse the boundary conditions.
    If ( Present(Bppr) ) Then
        Bpr = Bppr
    Else
        Bpr = -1
    End If
    If ( Present(Bmmr) ) Then
        Bmr = Bmmr
    Else
        Bmr = -1
    End If
    !>-------------------------------------------------------------------------------

    !>-------------------------------------------------------------------------------
    !> Allocate the Grid.
    This%ndims = 2
    This%ncells_min = 1
    This%ncells_max = Nr*Nphi
    This%nfaces_min = 0
    This%nfaces_max = Nr*(Nphi + 1) + Nphi*(Nr + 1) - 1
    Allocate(This%cells(This%ncells_min:This%ncells_max))
    Allocate(This%cell2face(This%ncells_min:4*This%ncells_max))
    Allocate(This%faces(This%nfaces_min:This%nfaces_max))
    !>-------------------------------------------------------------------------------

    !>-------------------------------------------------------------------------------
    !> Initialize Cells and Cell2Face.
    hr = ( Router - Rinner )/Dble(Nr)
    hphi = 2.0D0*Pi/Dble(Nphi)
    !$OMP Parallel Do Private(i, j, r, phi)
    Do n = This%ncells_min, This%ncells_max
        i = Mod(n - 1, Nr) + 1
        j = ( n - i )/Nr + 1
        This%cells(n)%nface = 4*n - 3
        This%cells(n)%nface_end = 4*n
        This%cell2face(This%cells(n)%nface + 0) = ( i - 1 ) + ( j - 1 )*( Nr + 1 )
        This%cell2face(This%cells(n)%nface + 1) = ( i - 0 ) + ( j - 1 )*( Nr + 1 )
        This%cell2face(This%cells(n)%nface + 2) = i + ( j - 1 )*Nr + Nphi*( Nr + 1 ) - 1
        This%cell2face(This%cells(n)%nface_end) = i + ( j - 0 )*Nr + Nphi*( Nr + 1 ) - 1
        r = Rinner + hr*( Dble(i) - 0.5D0 )
        phi = hphi*( Dble(j) - 0.5D0 )
        This%cells(n)%x = r*Cos(phi)
        This%cells(n)%y = r*Sin(phi)
        This%cells(n)%z = 0.0D0
        This%cells(n)%Vcell = r*hr*Sin(hphi)
    End Do
    !$OMP End Parallel Do
    !> Initialize Faces.
    !$OMP Parallel Do Private(i, j, m)
    Do n = This%nfaces_min, This%nfaces_max
        If ( n < Nphi*( Nr + 1 ) ) Then
            !> Initialize the Radial Faces.
            m = n
            i = Mod(m, Nr + 1)
            j = ( m - i )/( Nr + 1 ) + 1
            If ( i == Nr ) Then
                !> Domain Boundary.
                !> Free flow or wall boundary conditions.
                This%faces(n)%ncell_p = Bpr
            Else
                !> Domain Interior.
                This%faces(n)%ncell_p = i + 1 + ( j - 1 )*Nr
            End If
            If ( i == 0 ) Then
                !> Domain Boundary.
                !> Free flow or wall boundary conditions.
                This%faces(n)%ncell_m = Bmr
            Else
                !> Domain Interior.
                This%faces(n)%ncell_m = i + 0 + ( j - 1 )*Nr
            End If
            r = Rinner + hr*Dble(i)
            phi = hphi*( Dble(j) - 0.5D0 )
            This%faces(n)%x = r*Cos(phi)
            This%faces(n)%y = r*Sin(phi)
            This%faces(n)%z = 0.0D0
            This%faces(n)%nx = +Cos(phi)
            This%faces(n)%ny = +Sin(phi)
            This%faces(n)%nz = 0.0D0
            This%faces(n)%Sface = 2.0D0*r*Sin(0.5D0*hphi)
        Else
            !> Initialize the Angular Faces.
            m = n - Nphi*( Nr + 1 ) + 1
            i = Mod(m - 1, Nr) + 1
            j = ( m - i )/Nr
            If ( j == Nphi ) Then
                !> Periodic boundary conditions.
                This%faces(n)%ncell_p = i + ( 1 - 1 )*Nr
            Else
                !> Domain Interior.
                This%faces(n)%ncell_p = i + ( j - 0 )*Nr
            End If
            If ( j == 0 ) Then
                !> Periodic boundary conditions.
                This%faces(n)%ncell_m = i + ( Nphi - 1 )*Nr
            Else
                !> Domain Interior.
                This%faces(n)%ncell_m = i + ( j - 1 )*Nr
            End If
            r = Rinner + hr*( Dble(i) - 0.5D0 )
            phi = hphi*Dble(j)
            This%faces(n)%x = r*Cos(phi)
            This%faces(n)%y = r*Sin(phi)
            This%faces(n)%z = 0.0D0
            This%faces(n)%nx = -Sin(phi)
            This%faces(n)%ny = +Cos(phi)
            This%faces(n)%nz = 0.0D0
            This%faces(n)%Sface = hr
        End If
    End Do
    !$OMP End Parallel Do
    !>-------------------------------------------------------------------------------
End Subroutine mhd_grid_init2D_polar
!########################################################################################################
!########################################################################################################
!########################################################################################################
End Module orchid_solver_grid


!==========================================================================
elemental subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives (sa, &
              p, pot_enthalpy_ice_freezing_sa, pot_enthalpy_ice_freezing_p)
!==========================================================================
!
!  Calculates the first derivatives of the potential enthalpy of ice at
!  which seawater freezes, with respect to Absolute Salinity SA and
!  pressure P (in Pa).
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!  pot_enthalpy_ice_freezing_SA = the derivative of the potential enthalpy
!                  of ice at freezing (ITS-90) with respect to Absolute
!                  salinity at fixed pressure  [ K/(g/kg) ] i.e. [ K kg/g ]
!
!  pot_enthalpy_ice_freezing_P  = the derivative of the potential enthalpy
!                  of ice at freezing (ITS-90) with respect to pressure
!                  (in Pa) at fixed Absolute Salinity              [ K/Pa ]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_cp_ice, gsw_gibbs_ice, gsw_pt0_from_t_ice
use gsw_mod_toolbox, only : gsw_t_freezing_exact
use gsw_mod_toolbox, only : gsw_t_freezing_first_derivatives

use gsw_mod_teos10_constants, only : gsw_t0

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, p
real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_sa
real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_p

real (r8) :: cp_ihf, pt_icef, ratio_temp, tf, tf_p, tf_sa

real (r8), parameter :: saturation_fraction = 0.0_r8

tf = gsw_t_freezing_exact(sa,p,saturation_fraction)
pt_icef = gsw_pt0_from_t_ice(tf,p)
ratio_temp = (gsw_t0 + pt_icef)/(gsw_t0 + tf)

cp_ihf = gsw_cp_ice(tf,p)

if (present(pot_enthalpy_ice_freezing_sa) .and. present(pot_enthalpy_ice_freezing_p)) then
    call gsw_t_freezing_first_derivatives(sa,p,saturation_fraction,tf_sa,tf_p)
else if (present(pot_enthalpy_ice_freezing_sa)) then
    call gsw_t_freezing_first_derivatives(sa,p,saturation_fraction, &
                                          tfreezing_sa=tf_sa)
else if (present(pot_enthalpy_ice_freezing_p)) then
    call gsw_t_freezing_first_derivatives(sa,p,saturation_fraction, &
                                          tfreezing_p=tf_p)
end if

if (present(pot_enthalpy_ice_freezing_sa)) &
                pot_enthalpy_ice_freezing_sa = ratio_temp*cp_ihf*tf_sa

if (present(pot_enthalpy_ice_freezing_p)) &
                pot_enthalpy_ice_freezing_p = ratio_temp*cp_ihf*tf_p &
                             - (gsw_t0 + pt_icef)*gsw_gibbs_ice(1,1,tf,p)

return
end subroutine

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


!***********************************************************************
!                                                                      *
      SUBROUTINE Ions_param_Cart                                       &
                          (ion_number,q_ion,R_ion,GTheta_ion,Phy_ion)
!                                                                      *
!     Written by G. Gaigalas and D. Kato                               *
!                                        NIFS, Japan, September 2013   *
!     The last modification made by G. Gaigalas       June      2018   *
!                                                                      *
!***********************************************************************
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY: DOUBLE
      USE CONS_C,          ONLY: ZERO, ONE
      USE IOUNIT_C,        ONLY: ISTDE
      USE CrysPAR_C,       ONLY: QQ, Vector_L, X1, X2, X3
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(IN)       :: ion_number
      REAL(DOUBLE), INTENT(OUT) :: q_ion, R_ion, GTheta_ion, Phy_ion
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      REAL(DOUBLE) :: PI, X_coord, Y_coord, Z_coord
!-----------------------------------------------
!
      q_ion   = QQ(ion_number)
      PI      = 4.0D00*ATAN (ONE)
!
      X_coord = Vector_L * X1(ion_number)
      Y_coord = Vector_L * X2(ion_number)
      Z_coord = Vector_L * X3(ion_number)
      R_ion   = DSQRT(X_coord*X_coord+Y_coord*Y_coord+Z_coord*Z_coord)
      IF(X_coord == 0.000000D+00 .AND. Y_coord == 0.000000D+00         &
                                 .AND. Z_coord == 0.000000D+00) THEN
         WRITE (29,*)                                                  &
         'Incorect coordinates of ion =',ion_number
         STOP
      ELSE IF(X_coord == 0.000000D+00.AND.Y_coord == 0.000000D+00) THEN
         IF(Z_Coord > 0.0) THEN
            GTheta_ion = ZERO
         ELSE
            GTheta_ion = 180 * PI / 180.D00
         END IF
!GG         GTheta_ion = DACOS(Z_coord/R_ion)
         Phy_ion = ZERO
      ELSE IF(X_coord == 0.000000D+00.AND.Z_coord == 0.000000D+00) THEN
         GTheta_ion = 90 * PI / 180.D00
         IF(Y_Coord > 0.0) THEN
           Phy_ion = 90 * PI / 180.D00
         ELSE
           Phy_ion = -90 * PI / 180.D00
         END IF
!GG         Phy_ion = ATAN2(Y_coord,X_coord)
      ELSE IF(Y_coord == 0.000000D+00.AND.Z_coord == 0.000000D+00) THEN
         GTheta_ion = 90 * PI / 180.D00
         IF(X_Coord > 0.0) THEN
           Phy_ion = ZERO
         ELSE
           Phy_ion = 180.00D00 * PI / 180.D00
         END IF
!GG         Phy_ion = ATAN2(Y_coord,X_coord)
      ELSE IF(X_coord == 0.000000D+00) THEN
         GTheta_ion = DACOS(Z_coord/R_ion)
         IF(Y_Coord > 0.0) THEN
           Phy_ion = 90 * PI / 180.D00
         ELSE
           Phy_ion = -90 * PI / 180.D00
         END IF
!GG         Phy_ion = ATAN2(Y_coord,X_coord)
      ELSE IF(Y_coord == 0.000000D+00) THEN
         GTheta_ion = DACOS(Z_coord/R_ion)
         IF(X_Coord > 0.0) THEN
           Phy_ion = ZERO
         ELSE
           Phy_ion = 180.00D00 * PI / 180.D00
         END IF
!GG         Phy_ion = ATAN2(Y_coord,X_coord)
      ELSE IF(Z_coord == 0.000000D+00) THEN
         GTheta_ion = 90 * PI / 180.D00
         Phy_ion = ATAN2(Y_coord,X_coord)
      ELSE
         GTheta_ion = DACOS(Z_coord/R_ion)
         Phy_ion = ATAN2(Y_coord,X_coord)
      IF(DABS(R_ion*dcos(GTheta_ion)-Z_coord) > 0.0000001)  THEN
         WRITE(istde,*)'ERROR in Ions_param Z Coord'
         WRITE(istde,'(3(3X,E16.9))')X_coord,Y_coord,Z_coord
         WRITE(istde,'(3(3X,E16.9))')                                  &
             R_ion*dsin(GTheta_ion)*dcos(Phy_ion),                     &
             R_ion*dsin(GTheta_ion)*dsin(Phy_ion),                     &
             R_ion*dcos(GTheta_ion)
             STOP
      ELSE IF(DABS(R_ion*dsin(GTheta_ion)*dsin(Phy_ion)-Y_coord)       &
             > 0.0000001)  THEN
         WRITE(istde,*)'ERROR in Ions_param Y Coord'
         WRITE(istde,'(3(3X,E16.9))')X_coord,Y_coord,Z_coord
         WRITE(istde,'(3(3X,E16.9))')                                  &
             R_ion*dsin(GTheta_ion)*dcos(Phy_ion),                     &
             R_ion*dsin(GTheta_ion)*dsin(Phy_ion),                     &
             R_ion*dcos(GTheta_ion)
             STOP
      ELSE IF(DABS(R_ion*dsin(GTheta_ion)*dcos(Phy_ion)-X_coord)       &
             > 0.0000001)  THEN
         WRITE(istde,*)'ERROR in Ions_param X Coord'
         WRITE(istde,'(3(3X,E16.9))')X_coord,Y_coord,Z_coord
         WRITE(istde,'(3(3X,E16.9))')                                  &
             R_ion*dsin(GTheta_ion)*dcos(Phy_ion),                     &
             R_ion*dsin(GTheta_ion)*dsin(Phy_ion),                     &
             R_ion*dcos(GTheta_ion)
             STOP
      END IF
      END IF
!     Pervedame angstremus i atominius vienetus
!
      R_ion      = R_ion/0.52917706
!
!     Pervedame laipsnius i radianus
!
!      GTheta_ion = GTheta_ion*PI / 180.D 00
!      Phy_ion    = Phy_ion   *PI / 180.D 00
!
      RETURN
      END SUBROUTINE Ions_param_Cart


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------
MODULE m_doswt
   !
   !     calculates the weights for each k-point for integrating functions
   !     of k.  the array w has beeen cleared before entering.
   !
   USE m_trisrt
   USE m_types

   IMPLICIT NONE

   CONTAINS

   SUBROUTINE doswt(ei,nemax,jspins,kpts,eig,w)

      INTEGER,       INTENT(IN) :: jspins
      TYPE(t_kpts),  INTENT(IN) :: kpts
      REAL,          INTENT(IN) :: ei
      INTEGER,       INTENT(IN) :: nemax(:)
      REAL,          INTENT(IN) :: eig(:,:,:)      !(neig,nkpt,jspins)
      REAL,          INTENT(OUT):: w(:,:,:)        !(neig,nkpt,jspins)

      INTEGER :: jspin,iBand,itria
      INTEGER :: k1,k2,k3
      INTEGER :: neig
      REAL    :: e1,e2,e3
      REAl    :: ee,e32,e31,e21,s

      DO jspin = 1,jspins
         neig = nemax(jspin)
         DO iBand = 1,neig
            DO itria = 1,kpts%ntet
               !Get the k-points and eigenvalues
               !of the current triangle
               k1 = kpts%ntetra(1,itria)
               k2 = kpts%ntetra(2,itria)
               k3 = kpts%ntetra(3,itria)
               e1 = eig(iBand,k1,jspin)
               e2 = eig(iBand,k2,jspin)
               e3 = eig(iBand,k3,jspin)
               !Sort by ascending eigenvalues
               CALL trisrt(e1,e2,e3,k1,k2,k3)
               IF (e1.LE.-9999.0) CYCLE !Not all eigenvalues available
               IF (ei.LE.e1) CYCLE !triangle not occupied
               IF (ei.GE.e3) THEN
                  !---> e3<e
                  s = kpts%voltet(itria)/kpts%ntet/3.0
                  w(iBand,k1,jspin) = w(iBand,k1,jspin) + s
                  w(iBand,k2,jspin) = w(iBand,k2,jspin) + s
                  w(iBand,k3,jspin) = w(iBand,k3,jspin) + s
               ELSEIF (ei.GT.e2) THEN
                  !---> e2<ei<e3
                  ee = e3 - ei
                  e31 = ee/ (e3-e1)
                  e32 = ee/ (e3-e2)
                  s = kpts%voltet(itria)/kpts%ntet/3.0
                  w(iBand,k1,jspin) = w(iBand,k1,jspin) + s* (1.-e31*e31*e32)
                  w(iBand,k2,jspin) = w(iBand,k2,jspin) + s* (1.-e31*e32*e32)
                  w(iBand,k3,jspin) = w(iBand,k3,jspin) + s* (1.-e31*e32*(3.-e31-e32))
               ELSE
                  !---> e1<ei<e2
                  ee = ei - e1
                  e31 = ee/ (e3-e1)
                  e21 = ee/ (e2-e1)
                  s = kpts%voltet(itria)/kpts%ntet*e31*e21/3.0
                  w(iBand,k1,jspin) = w(iBand,k1,jspin) + s* (3.0-e21-e31)
                  w(iBand,k2,jspin) = w(iBand,k2,jspin) + s*e21
                  w(iBand,k3,jspin) = w(iBand,k3,jspin) + s*e31
               ENDIF

            ENDDO
         ENDDO
      ENDDO

   END SUBROUTINE doswt
END MODULE m_doswt


!***** SOURCES.F90 ***********************************************************************
module sources

use params
use helpers
use basis_funcs

! use random  ! TODO: commented to get working w/o MKL

contains

    subroutine source_calc(Q_ri)
        implicit none
        real, dimension(nx,ny,nz,nQ,nbasis), intent(inout) :: Q_ri

        real, dimension(npg,nQ) :: source
        real, dimension(nQ) :: Qin
        real dn,dni, vx,vy,vz,vx2,vy2,vz2, pr,te, colldn
        integer i,j,k,ieq,ipg,ir

        source_r(:,:,:,:,:) = 0.0
        source(:,:) = 0.0

        do k = 1,nz
        do j = 1,ny
        do i = 1,nx

            do ipg = 1,npg

                do ieq = 1,nQ
                    Qin(ieq) = sum(bfvals_int(ipg,1:nbasis)*Q_ri(i,j,k,ieq,1:nbasis))
                end do

                source(ipg,rh:en) = 0

                select case (ivis)
                case(0)  ! NOTE: FOR INVISCID FLOW, MUST ENSURE coll = colvis = 0
                        source(ipg,pxx) = -coll*Qin(pxx)
                        source(ipg,pyy) = -coll*Qin(pyy)
                        source(ipg,pzz) = -coll*Qin(pzz)
                        source(ipg,pxy) = -coll*Qin(pxy)
                        source(ipg,pxz) = -coll*Qin(pxz)
                        source(ipg,pyz) = -coll*Qin(pyz)
                    case(1)
                        source(ipg,pxx) = 0  ! impl. solv w/ sources at next tstep in advance_time_level_gl
                        source(ipg,pyy) = 0  ! impl. solv w/ sources at next tstep in advance_time_level_gl
                        source(ipg,pzz) = 0  ! impl. solv w/ sources at next tstep in advance_time_level_gl
                        source(ipg,pxy) = 0  ! impl. solv w/ sources at next tstep in advance_time_level_gl
                        source(ipg,pxz) = 0  ! impl. solv w/ sources at next tstep in advance_time_level_gl
                        source(ipg,pyz) = 0  ! impl. solv w/ sources at next tstep in advance_time_level_gl
                    case(2) ! NOTE: for doing full 10-moment equations explicitly
                        dn = Qin(rh)
                        dni = 1./dn
                        vx = Qin(mx)*dni
                        vy = Qin(my)*dni
                        vz = Qin(mz)*dni
                        vx2 = vx**2
                        vy2 = vy**2
                        vz2 = vz**2
                        ! pr = (aindex - 1.)*(Qin(en) - 0.5*dn*(vx**2 + vy**2 + vz**2))
                        ! te = Pres*dni
                        colldn = coll*dn

                        source(ipg,pxx) = colldn*(2*vx2 - vy2 - vz2)*c1d3
                        source(ipg,pyy) = colldn*(2*vy2 - vz2 - vx2)*c1d3
                        source(ipg,pzz) = colldn*(2*vz2 - vx2 - vy2)*c1d3
                        source(ipg,pxy) = colldn*vx*vy
                        source(ipg,pxz) = colldn*vx*vz
                        source(ipg,pyz) = colldn*vy*vz
                end select

            end do

            do ir=1,nbasis
                do ieq = 1,nQ
                    source_r(i,j,k,ieq,ir) = 0.125*cbasis(ir)*sum(bval_int_wgt(1:npg,ir)*source(1:npg,ieq))
                end do
            end do

        end do
        end do
        end do

    end subroutine source_calc
    !---------------------------------------------------------------------------

end module sources


MODULE mod1
 INTEGER , PARAMETER :: p1 = 6
 INTEGER , PARAMETER :: p2 = 37
 INTEGER , PARAMETER :: p3 = 12
 INTEGER , PARAMETER :: p4 = 307
 INTEGER , PARAMETER :: sp = selected_real_kind ( 6 , 37 )
 INTEGER , PARAMETER :: dp = selected_real_kind ( 12 , 307 )
 INTEGER , PARAMETER :: wp = selected_real_kind ( 12 , 307 )
 INTEGER , PARAMETER :: vp = selected_real_kind ( 12 , 307 )
 INTEGER , PARAMETER :: vp2 = selected_real_kind ( 12 , 307 )
 INTEGER , PARAMETER :: pi2 = 4
 INTEGER , PARAMETER :: pi4 = 9
 INTEGER , PARAMETER :: pi8 = 14
 INTEGER , PARAMETER :: i2 = selected_int_kind ( 4 )
 INTEGER , PARAMETER :: i4 = selected_int_kind ( 9 )
 INTEGER , PARAMETER :: i8 = selected_int_kind ( 14 )
END MODULE mod1