      subroutine DSBASD(KORDER, LEFT, T, X, IDERIV, BDERIV)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1994-10-20 DSBASD Krogh  Changes to use M77CON
c>> 1993-01-12 DSBASD CLL  Bringing all computation inline.
c>> 1992-11-02 C. L. Lawson, JPL
c>> 1988-03-22 C. L. Lawson, JPL
c
c     Given the knot-set T(i), i = 1, ..., NT, this subr computes
c     values at X of the derivative of order IDERIV of each of the
c     the KORDER B-spline basis functions of order KORDER
c     that are nonzero on the open interval (T(LEFT), T(LEFT+1).
c     Require T(LEFT) < T(LEFT+1) and KORDER .le. LEFT .le.
c     NT-KORDER.
c     For proper evaluation, X must lie in the closed interval
c     [T(LEFT), T(LEFT+1], otherwise the computation constitutes
c     extrapolation.
c     The basis functions whose derivatives are returned will be those
c     indexed from LEFT+1-KORDER through LEFT, and their values will be
c     stored in BDERIV(I), I = 1, ..., KORDER.
c     ------------------------------------------------------------------
c  Method:
c
c  In general there are two stages: First compute values of basis
c  functions of order KORDER-IDERIV.  Then, if IDERIV > 0, transform
c  these values to produce values of higher order derivatives of
c  higher order basis functions, ultimately obtaining values of
c  the IDERIV derivative of basis functions of order KORDER.
c
c  The first stage uses the recursion:
C
C                       X - T(I)              T(I+J+1) - X
C     B(I,J+1)(X)  =  -----------B(I,J)(X) + ---------------B(I+1,J)(X)
C                     T(I+J)-T(I)            T(I+J+1)-T(I+1)
C
c  where B(I,J) denotes the basis function of order J and index I.
c  For order J, the only basis functions that can be nonzero on
c  [T(LEFT), T(LEFT+1] are those indexed from LEFT+1-J to LEFT.
c  For order 1, the only basis function nonzero on this interval is
c  is B(LEFT,1), whose value is 1.  The organization of the calculation
c  using the above recursion follows Algorithm (8) in Chapter X of the
c  book by DeBoor.
c
c  For the second stage, let B(ID, K, J) denote the value at X of the
c  IDth derivative of the basis function of order K, with index J.
c  From the first stage we will have values of B(0, KORDER-IDERIV, j)
c  for j = LEFT+1-KORDER+IDERIV), ..., LEFT, stored in BDERIV(i), for
c  i = 1+IDERIV, ..., KORDER.
c
c     Loop for ID = 1, ..., IDERIV
c        Replace the contents of BDERIV() by values of
c        B(ID, KORDER-IDERIV+ID, j) for
c        j = LEFT+1-KORDER+IDERIV-ID), ..., LEFT, storing these in
c        BDERIV(i), i = 1+IDERIV-ID, ..., KORDER.
c     End loop
c
c  The above loop uses formula (10), p. 138, of
c  A PRACTICAL GUIDE TO SPLINES by Carl DeBoor, Springer-Verlag,
c  1978, when ID = 1, and successive derivatives of that formula
c  when ID > 1.  Note that we are using Formula (10) in the special
c  case in which (Alpha sub i) = 1, and all other Alpha's are zero.
c
c  This approach and implementation by C. L. Lawson, JPL, March 1988.
C     ------------------------------------------------------------------
C  KORDER [in]  Gives both the order of the B-spline basis functions
c        whose derivatives are to be evaluated,
c        and the number of such functions to be evaluated.
c        Note that the polynomial degree of these functions is one less
c        than the order.  Example:  For cubic splines the order is 4.
c        Require 1 .le. KORDER .le. KMAX, where KMAX is an internal
c        parameter.
c  LEFT  [in]  Index identifying the left end of the interval
c        [T(LEFT), T(LEFT+1)] relative to which the B-spline basis
c        functions will be evaluated.
c        Require        KORDER .le. LEFT .le. NT-KORDER
c        and            T(LEFT) < T(LEFT+1)
c        The evaluation is proper if T(LEFT) .le. X .le. T(LEFT+1), and
c        otherwise constitutes extrapolation.
C        DIVISION BY ZERO  will result if T(LEFT) = T(LEFT+1)
C  T()   [in]  Knot sequence, indexed from 1 to NT, with
c        NT .ge. LEFT+KORDER.  Knot values must be nonincreasing.
c        Repetition of values is permitted and has the effect of
c        decreasing the order of contimuity at the repeated knot.
c        Proper function representation by splines of order K is
c        supported on the interval from T(K) to T(NT+1-K).
c        Extrapolation can be done outside this interval.
C  X     [in]  The abcissa at which the B-spline basis functions are to
c        be evaluated.  The evaluation is proper if T(KORDER) .le. X .le
c        T(NT+1-KORDER), and constitutes extrapolation otherwise.
c  IDERIV [in]  Order of derivative requested.  Require IDERIV .ge. 0.
c        Derivatives of order .ge. KORDER are zero.
C  BDERIV()  [out]  On normal return, this array will contain in
c        BDERIV(i), i = 1, ...,KORDER, the values computed by this subr.
c        These are values at X of the derivative of order IDERIV of each
c        of the basis functions indexed LEFT+1-KORDER through LEFT.
C     ------------------------------------------------------------------
c--D replaces "?": ?SBASD
c     Both versions use IERM1, IERV1
C     ------------------------------------------------------------------
      integer KMAX
      parameter(KMAX = 20)
      integer I, I1, ID, IDERIV, ISTART, IT1, IT2
      integer J, JP1, K1, KORDER, LEFT
      double precision BDERIV(KORDER), DELTAL(KMAX), DELTAR(KMAX), FLK1
      double precision SAVED, T(LEFT+KORDER), TERM, X
C     ------------------------------------------------------------------
      ID = IDERIV
      if(ID .lt. 0 ) then
         call IERM1('DSBASD',2,2,'Require IDERIV .ge. 0',
     *   'IDERIV',ID,'.')
         return
      endif
      if(ID .ge. KORDER) then
         do 5 I = 1, KORDER
            BDERIV(I) = 0.0d0
    5    continue
         return
      endif
      if(KORDER .gt. KMAX) then
         call IERM1('DSBASD',1,2,'Require KORDER .le. KMAX.',
     *   'KORDER',KORDER,',')
         call IERV1('KMAX',KMAX,'.')
         return
      endif
      ISTART = 1+ID
      K1 = KORDER - ID
c
c        Evaluate K1 basis functions of order K1.  Store values in
c        BDERIV(ISTART:ISTART+K1-1)
c
      BDERIV(ISTART) = 1.0d0
      do 30 J = 1, K1-1
         JP1 = J + 1
         DELTAR(J) = T(LEFT+J) - X
         DELTAL(J) = X - T(LEFT+1-J)
         SAVED = 0.0d0
         do 26 I=1,J
            TERM = BDERIV(ID+I)/(DELTAR(I) + DELTAL(JP1-I))
            BDERIV(ID+I) = SAVED + DELTAR(I)*TERM
            SAVED = DELTAL(JP1-I)*TERM
   26    continue
         BDERIV(ID+JP1) = SAVED
   30 continue
c
c     Loop IDERIV times, each time advancing the order of the
c     derivative by one, so final results are values of derivatives
c     of order IDERIV.
c
      do 70 I1 = ISTART, 2, -1
         FLK1 = dble(K1)
         IT1 = LEFT+1-I1
         IT2 = IT1 - K1
         do 50 I = I1, KORDER
            BDERIV(I) = BDERIV(I) * FLK1 /(T(IT1+I) - T(IT2+I))
   50    continue
c
         BDERIV(I1-1) = -BDERIV(I1)
         do 60 I = I1, KORDER-1
            BDERIV(I) = BDERIV(I) - BDERIV(I+1)
   60    continue
         K1 = K1 + 1
   70 continue
      return
      end


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

 subroutine gauss(n,a,b,c)

!                                                                               !
! This subroutine solves the n x n linear system ac = b                         !
! by Gauss-elimination with pivoting                                            !
!                                                                               !
! On input:                                                                     !
! n              dimension of the system                                        !
! a(n,n)         coefficient matrix                                             !
! b(n)           righthand side                                                 !
!                                                                               !
! On output:                                                                    !
! c(n)           solutions to the system                                        !
!                                                                               !
!  Authors:                                                                     !
!  Per J\"onsson, Malm\"o University, Sweden                                    !
!  e-mail per.jonsson@ts.mah.se                                                 !
!                                                                               !
!  Lars Eklundh, Lund University, Sweden                                        !
!  e-mail lars.eklundh@nateko.lu.se                                             !
!                                                                               !
!  Updated 26/3-2005                                                            !
!                                                                               !
!-------------------------------------------------------------------------------!

 implicit none

 integer :: i,j,k,n,pos(1)
 double precision :: a(n,n),b(n),c(n),f,temp1(n),temp2

!---- Elimination ---------------------------------------------------------------

 do i = 1,n-1
   pos(1:1) = maxloc(abs(a(i:n,i)))
   if (pos(1) > 1) then
     temp1  = a(i,:)
     temp2  = b(i)
     a(i,:) = a(i+pos(1)-1,:)
     b(i)   = b(i+pos(1)-1)
     a(i+pos(1)-1,:) = temp1
     b(i+pos(1)-1)   = temp2
   end if
   do j = i+1,n
     f = - a(j,i)/a(i,i)
     a(j,:) = a(j,:) + f*a(i,:)
     b(j) = b(j) + f*b(i)
   end do
 end do

!---- Back substitution ---------------------------------------------------------

 do i = 1,n
   if (abs(a(i,i)) < 1d-80) then
     c = 0.d0
!	 write(*,*) 'Bad condition in gauss'
     return
   end if
 end do

 c(n) = b(n)/a(n,n)
 do i = n-1,1,-1
   c(i) = (b(i) - sum(a(i,i+1:n)*c(i+1:n)) )/a(i,i)
 end do

 end subroutine gauss


SUBROUTINE spear(data1,data2,n,wksp1,wksp2,d,zd,probd,rs,probrs)
INTEGER n
REAL*8 d,probd,probrs,rs,zd,data1(n),data2(n),wksp1(n),wksp2(n)
!CU    USES betai,crank,erfcc,sort2
INTEGER j
REAL*8 aved,df,en,en3n,fac,sf,sg,t,vard,betai,erfcc
do j=1,n
  wksp1(j)=data1(j)
  wksp2(j)=data2(j)
enddo
call sort2(n,wksp1,wksp2)
call crank(n,wksp1,sf)
call sort2(n,wksp2,wksp1)
call crank(n,wksp2,sg)
d=0.
do j=1,n
  d=d+(wksp1(j)-wksp2(j))**2
enddo
en=n
en3n=en**3-en
aved=en3n/6.-(sf+sg)/12.
fac=(1.-sf/en3n)*(1.-sg/en3n)
vard=((en-1.)*en**2*(en+1.)**2/36.)*fac
zd=(d-aved)/sqrt(vard)
probd=erfcc(abs(zd)/1.4142136)
rs=(1.-(6./en3n)*(d+(sf+sg)/12.))/sqrt(fac)
fac=(1.+rs)*(1.-rs)
if(fac.gt.0.)then
  t=rs*sqrt((en-2.)/fac)
  df=en-2.
  probrs=betai(0.5*df,0.5,df/(df+t**2))
else
  probrs=0.
endif
return
END


program main
  implicit none
  integer :: i, n
  real(8) :: ff_0, ff_p, ff_m, dfdx_f, dfdx_m, dfdx_e
  real(8) :: x, h

  x = 0d0
  dfdx_e = exp(x)

  h = 1d0

  n = 16
  open(20,file="fd_error.out")
  do i = 1, n
     ff_0   = exp(x)
     ff_p = exp(x+h)
     ff_m = exp(x-h)

     dfdx_f = (ff_p-ff_0)/h
     dfdx_m = (ff_p-ff_m)/(2d0*h)

     write(20,"(5e16.6e3)")h,dfdx_f,abs(dfdx_f - dfdx_e),dfdx_m,abs(dfdx_m - dfdx_e)

     h = h/2d0
  end do
  close(20)

end program main


avg = mean(x)
res = SUM((x(:) - avg)**2)
res = res / REAL(SIZE(x) - 1,prec)


	FUNCTION PR_WCMP  ( drct, sped, dcmp )
C************************************************************************
C* PR_WCMP 								*
C*									*
C* This function computes the wind component toward a specified		*
C* direction.  The following equation is used:				*
C*									*
C*    WCMP = -COS ( DRCT - DCMP ) * SPED				*
C*									*
C*         WCMP = component of wind in meters/second			*
C*         DRCT = wind direction in degrees				*
C*         DCMP = direction of desired component			*
C*         SPED = wind speed in meters/second				*
C*									*
C* REAL PR_WCMP ( DRCT, SPED, DCMP )					*
C*									*
C* Input parameters:							*
C*	DRCT		REAL		Wind direction in degrees	*
C*	SPED		REAL		Wind speed in meters/second	*
C*	DCMP		REAL		Direction of desired component	*
C*									*
C* Output parameters:							*
C*	PR_WCMP		REAL		Component of wind in m/s	*
C**									*
C* Log:									*
C* John Nielsen/MIT	 9/88						*
C* John Nielsen/SUNYA	 8/90	GEMPAK 5				*
C* J. Whistler/SSAI	 7/91	Changed COSD to COS and converted to rad*
C* T. Piper/GSC		11/98	Updated prolog				*
C************************************************************************
C*
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
C
C* 	Check for missing input parameters.
C
	IF ( ERMISS (sped) .or. ERMISS (drct) .or. ERMISS (dcmp)) THEN
	    PR_WCMP = RMISSD
	  ELSE
C
C*	Calculate wind speed toward specified direction.
C
	    PR_WCMP = (-COS( ( drct - dcmp ) * DTR )) * sped
	END IF
C*
	RETURN
	END


  !! ----------------------------------------------------------------------- !!
  !>
  !! Tsunami initial height.
  !! Tsunami height eta(:,:) ( in m-unit ) must be defined here.
  !<
  !! --
  block

    real, parameter :: aa = 16000.
    real, parameter :: bb = 16000.
    integer :: i, j, i0, j0
    real :: hx, hy
    !! ----

    i0 = nx/2
    j0 = ny/2
    eta(:,:) = 0.0
    do j=1, ny
       if( -bb <= (j-j0)*dy  .and. (j-j0) * dy <= bb ) then
          hy = ( 1 + cos( pi * ( j-j0 ) * dy / bb ) ) / 2.0
       else
          hy = 0.0
       end if
       do i=1, nx

          if( -aa <= (i-i0)*dx  .and. (i-i0) * dx <= aa ) then
             hx = ( 1 + cos( pi * ( i-i0 ) * dx / aa ) ) / 2.0
          else
             hx = 0.0
          end if

          eta(i,j) = hx * hy

       end do

    end do

  end block


MODULE vector_module
IMPLICIT NONE
TYPE :: vector
  REAL :: x
  REAL :: y
END TYPE vector

CONTAINS
  TYPE (vector) FUNCTION vector_add(v1, v2)
  IMPLICIT NONE
  TYPE (vector), INTENT(IN) :: v1, v2
  vector_add = vector(v1%x + v2%x, v1%y + v2%y)
  END FUNCTION vector_add

  TYPE (vector) FUNCTION vector_sub(v1, v2)
  IMPLICIT NONE
  TYPE (vector), INTENT(IN) :: v1, v2
  vector_sub = vector(v1%x - v2%x, v1%y - v2%y)
  END FUNCTION vector_sub
END MODULE vector_module

PROGRAM test_vectors
USE vector_module
IMPLICIT NONE
TYPE (vector) :: a, b, c
a = vector(1., 2.)
b = vector(6., 9.)
c = vector_add(a, b)
WRITE(*, *) c
c = vector_sub(a, b)
WRITE(*, *) c
END PROGRAM test_vectors


subroutine apply_pde_operator(t, q, output)

! For the PDE q_t = g(q), calculates g(q).
!
! Args:
!   t: Time at which the operator is evaluated.
!   q: PDE solution at time t.
!   output: g(q), calculated here.

    implicit none

    integer :: mx, mbc, meqn
    double precision :: x_lower, dx
    common /claw_config/ mx, mbc, x_lower, dx, meqn

    double precision, intent(in) :: t
    double precision, dimension(1-mbc:mx+mbc, meqn), intent(in) :: q
    double precision, dimension(1-mbc:mx+mbc, meqn), intent(out) :: output

    integer :: ix

    do ix = 1, mx
        output(ix, 1) = (q(ix-1, 1) - 2 * q(ix, 1) + q(ix+1, 1)) / dx**2
    end do

end subroutine apply_pde_operator


module non_linear_solvers
  !! Module for solving non-linear equations of the form:
  !! $$ \mathbf{f}\left(\mathbf{x}\right)=\mathbf{0} $$
  !! There are specific functions for the scalar case.

  use linear_solvers, only: solve

  implicit none

contains

  function Bisection(f,a,b,err_x) result(x)
    !! Solves the scalar non-linear equation:
    !! $$ f(x)=0 $$
    !! using the bisection method on the interval \([a,b]\)
    interface
      function f(x) result(y)
        !! function defining the non-linear equation
        real, intent(in) :: x
        !! independent variable
        real :: y
        !! dependent variable
      end function
    end interface
    real, intent(in) :: a
    !! left boundary of the interval
    real, intent(in) :: b
    !! right boundary of the interval
    real, intent(in) :: err_x
    !! admisible error in the solution, that is:
    !! $$ x_\mathrm{true} = x \pm \frac{\epsilon_{x}}{2} $$
    real :: x
    !! numerical aproximation to the solution

    integer :: N, i
    real :: x_l, x_r

    if(f(a)*f(b)>=0) error stop "f(a) and f(b) must have different signs"

     if (a>b) then
       error stop "a cannot be greater than b"
     else if(a==b) then
       x=a
       return
     else
       N = ceiling(log((b-a)/err_x)/log(2.))
     end if
     x_l = a
     x_r = b
     do i = 1, N
       x = (x_l+x_r)/2
       if ( f(x)==0)then
         exit
       else if(f(x)*f(x_l)>0) then
         x_l = x
       else
         x_r = x
       end if
     end do
   end function

   function Newton(f, df, x0, err_x, err_f, max_iter) result(x)
     !! Solves the scalar non-linear equation:
     !! $$ f(x) = 0 $$
     !! using Newton's method.
     interface
       function f(x) result(y)
         !! function defining the non-linear equation
         real, intent(in) :: x
         !! independent variable
         real :: y
         !! dependent variable
       end function
       function df(x) result(y)
         !! derivative of function \(f\)
         real, intent(in) :: x
         !! independent variable
         real :: y
         !! dependent variable
       end function
     end interface
     real, intent(in) :: x0
     !! initial aproximation to the solution
     real, intent(in) :: err_x
     !! admisible error in the solution
     real, intent(in) :: err_f
     !! admisible error in the equation
     integer, intent(in) :: max_iter
     !! maximum number of iterations
     real :: x
     !! numerical aproximation to the solution

     integer :: i
     real :: x_old

     x_old = x0
     do i = 1, max_iter
       x  = x_old - f(x_old)/df(x_old)
       if ( ( abs(f(x))<err_f ) .or. ( abs(x-x_old) < err_x) ) exit
       x_old = x
     end do
     if(i>max_iter) print*, "maximum number of iterations reached without convergence"
  end function

  function Secant(f, x0, err_x, err_f, max_iter) result(x)
    !! Solves the scalar non-linear equation:
    !! $$ f(x) = 0 $$
    !! using the secant method.
    interface
      function f(x) result(y)
        !! function defining the non-linear equation
        real, intent(in) :: x
        !! independent variable
        real :: y
        !! dependent variable
      end function
    end interface
    real, intent(in) :: x0(2)
    !! array containing the first and second aproximations to the solution
    real, intent(in) :: err_x
    !! admisible error in the solution
    real, intent(in) :: err_f
    !! admisible error in the equation
    integer, intent(in) :: max_iter
    !! maximum number of iterations
    real :: x
    !! numerical aproximation to the solution

    integer :: i
    real :: x_old(2)

    x_old = x0
    do i = 1, max_iter
      x  = x_old(2) - f(x_old(2))* (x_old(2) - x_old(1)) / ( f(x_old(2))-f(x_old(1)))
      if ( ( abs(f(x))<err_f ) .or. ( abs(x-x_old(2)) < err_x) ) exit
      x_old = [ x_old(2), x ]
    end do
    if(i>max_iter) print*, "maximum number of iterations reached without convergence"
 end function

 function VectorNewton(f, J, x0, err_x, err_f, max_iter) result(x)
   !! Solves the vector non-linear equation:
   !! $$ f(x) = 0 $$
   !! using Newton's method.
   interface
     function f(x) result(y)
       !! function defining the non-linear equation
       real, intent(in) :: x(:)
       !! independent variable
       real :: y(size(x))
       !! dependent variable
     end function
     function J(x) result(y)
       !! jacobian of function \(f\)
       real, intent(in) :: x(:)
       !! independent variable
       real :: y(size(x), size(x))
       !! dependent variable
     end function
   end interface
   real, intent(in) :: x0(:)
   !! initial aproximation to the solution: \((x_0,y_0)\)
   real, intent(in) :: err_x
   !! admisible error in the solution
   real, intent(in) :: err_f
   !! admisible error in the equation
   integer, intent(in) :: max_iter
   !! maximum number of iterations
   real :: x(size(x0))
   !! numerical aproximation to the solution

   integer :: i
   real :: x_old(size(x0))

   x_old = x0
   print*, J(x_old)
   do i = 1, max_iter
     x  = x_old - solve(J(x_old),f(x_old))
     if ( ( norm2(f(x))<err_f ) .or. ( norm2(x-x_old) < err_x) ) exit
     x_old = x
   end do
   if(i>max_iter) print*, "maximum number of iterations reached without convergence"
 end function

end module


!>
!! This module handles the diffusion terms in the equation. It provides a second and fourth order centred discretization of
!!
!! \\( \\Delta q = q_{xx} + q_{yy} + q_{zz} \\)
!!
MODULE diffusion

IMPLICIT NONE

PUBLIC :: GetRHSDiffusion, InitializeDiffusion

TYPE diffusion_parameter
    INTEGER :: i_min, i_max, j_min, j_max, k_min, k_max
    DOUBLE PRECISION :: nu
END TYPE

TYPE(diffusion_parameter) :: param

!> Finite difference weight in the fourth order centred stencil
DOUBLE PRECISION, PARAMETER :: w1 = 1.0_8/12.0_8

!> Finite difference weight in the fourth order centred stencil
DOUBLE PRECISION, PARAMETER :: w2 = 4.0_8/3.0_8

!> Finite difference weight in the fourth order centred stencil
DOUBLE PRECISION, PARAMETER :: w3 = 5.0_8/2.0_8

CONTAINS

    !> Computes the contribution from the diffusive terms to the right hand side of the initial value problem.
    !! param[in] Q The solution
    !! param[out] RQ Discrete diffusion operator applied to Q
    !! param[in] order Either two or four.
    SUBROUTINE GetRHSDiffusion(Q, RQ, dx, dy, dz, i_start, i_end, j_start, j_end, k_start, k_end, order)
        DOUBLE PRECISION, DIMENSION(param%i_min:, param%j_min:, param%k_min:), INTENT(IN)  :: Q
        DOUBLE PRECISION, DIMENSION(param%i_min:, param%j_min:, param%k_min:), INTENT(OUT) :: RQ
        DOUBLE PRECISION,   INTENT(IN) :: dx, dy, dz
        INTEGER,            INTENT(IN) :: i_start, i_end, j_start, j_end, k_start, k_end, order

        DOUBLE PRECISION :: stencil_i, stencil_j, stencil_k, coeff_i, coeff_j, coeff_k

        INTEGER :: i, j, k

        SELECT CASE (order)

            CASE (2)

                coeff_i = 1.0/(dx*dx)
                coeff_j = 1.0/(dy*dy)
                coeff_k = 1.0/(dz*dz)

                DO k=k_start, k_end
                    DO j=j_start, j_end
                        DO i=i_start, i_end
                            stencil_i = coeff_i*(Q(i+1,j,k) - 2.0*Q(i,j,k) + Q(i-1,j,k))
                            stencil_j = coeff_j*(Q(i,j+1,k) - 2.0*Q(i,j,k) + Q(i,j-1,k))
                            stencil_k = coeff_k*(Q(i,j,k+1) - 2.0*Q(i,j,k) + Q(i,j,k-1))
                            RQ(i,j,k) = RQ(i,j,k) +  param%nu*(stencil_i + stencil_j + stencil_k)
                        END DO
                    END DO
                END DO

            CASE (4)

                coeff_i = 1.0/(dx*dx)
                coeff_j = 1.0/(dy*dy)
                coeff_k = 1.0/(dz*dz)

                DO k=k_start, k_end
                    DO j=j_start, j_end
                        DO i=i_start, i_end
                            stencil_i = coeff_i*( -w1*Q(i+2,j,k) + w2*Q(i+1,j,k) &
                                - w3*Q(i,j,k) + w2*Q(i-1,j,k) - w1*Q(i-2,j,k) )

                            stencil_j = coeff_j*( -w1*Q(i,j+2,k) + w2*Q(i,j+1,k) &
                                -w3*Q(i,j,k) + w2*Q(i,j-1,k) - w1*Q(i,j-2,k) )

                            stencil_k = coeff_k*( -w1*Q(i,j,k+2) + w2*Q(i,j,k+1) &
                                -w3*Q(i,j,k) + w2*Q(i,j,k-1) - w1*Q(i,j,k-2) )

                            RQ(i,j,k) = RQ(i,j,k) + param%nu*( stencil_i + stencil_j + stencil_k )
                        END DO
                    END DO
                END DO

            CASE DEFAULT
                WRITE(*,'(A,I2,A)') 'No implementation available for order = ', order, ' .. now exiting'
                STOP
        END SELECT

    END SUBROUTINE GetRHSDiffusion

    !> Initialize the diffusion module
    SUBROUTINE InitializeDiffusion(i_min, i_max, j_min, j_max, k_min, k_max, nu)

        DOUBLE PRECISION, INTENT(IN) :: nu
        INTEGER, INTENT(IN) :: i_min, i_max, j_min, j_max, k_min, k_max

        param%nu    = nu
        param%i_min = i_min
        param%i_max = i_max
        param%j_min = j_min
        param%j_max = j_max
        param%k_min = k_min
        param%k_max = k_max

    END SUBROUTINE InitializeDiffusion

END MODULE diffusion


module stress_routines_lib
	! module containing various routines for computation of stresses and stress invariants

	! load additional modules
	use iso_c_binding, only: dbl => c_double
	use constants_lib, only: Pi
	use math_routines_lib, only: calc_rot_matrix_zyz

	implicit none

	! definition and initialization of constant arrays

	! deviatoric operator
	real(kind=dbl), dimension(6,6), parameter :: I_dev = &
			 reshape( (/ 2._dbl/3._dbl, -1._dbl/3._dbl, -1._dbl/3._dbl, 0._dbl, 0._dbl, 0._dbl, &
						-1._dbl/3._dbl, 2._dbl/3._dbl, -1._dbl/3._dbl, 0._dbl, 0._dbl, 0._dbl, &
						-1._dbl/3._dbl, -1._dbl/3._dbl, 2._dbl/3._dbl, 0._dbl, 0._dbl, 0._dbl, &
						0._dbl, 0._dbl, 0._dbl, 1._dbl, 0._dbl, 0._dbl, &
						0._dbl, 0._dbl, 0._dbl, 0._dbl, 1._dbl, 0._dbl, &
						0._dbl, 0._dbl, 0._dbl, 0._dbl, 0._dbl, 1._dbl /), (/ 6, 6 /) )

	! dsigma_m/dsigma
	real(kind=dbl), dimension(6), bind(c) :: Dsigma_mDsigma = (/ 1._dbl/3._dbl, 1._dbl/3._dbl, 1._dbl/3._dbl, &
																	 0._dbl, 0._dbl, 0._dbl /)

	! numerical zero
	real(kind=dbl), parameter :: num_zero = 1.0d-10

	! scaling vector for strain vector to convert engineering shear strain components
	real(kind=dbl), dimension(6), bind(c) :: eps_eng_scale = (/ 1._dbl, 1._dbl, 1._dbl, 0.5_dbl, 0.5_dbl, 0.5_dbl /)

contains

	function calc_I1(sigma) bind(c)
		implicit none
		! computes first invariant of stress tensor

		! --------------------------------------------------------------------------
		! type declaration of return variable
		real(kind=dbl) :: calc_I1

		! passed variables
		real(kind=dbl), intent(in), dimension(6) :: sigma		! stress vector
		! --------------------------------------------------------------------------

		! computation of first invariant
		calc_I1 = sum(sigma(1:3))

	end function calc_I1

	function calc_I2(sigma) bind(c)
		implicit none
		! computes second invariant of stress tensor

		! --------------------------------------------------------------------------
		! type declaration of return variable
		real(kind=dbl) :: calc_I2

		! passed variables
		real(kind=dbl), intent(in), dimension(6) :: sigma		! stress vector

		! internal variables
		real(kind=dbl) :: s11
		real(kind=dbl) :: s22
		real(kind=dbl) :: s33
		real(kind=dbl) :: s12
		real(kind=dbl) :: s13
		real(kind=dbl) :: s23
		! --------------------------------------------------------------------------

		! unpacking of stress vector
		s11 = sigma(1)
		s22 = sigma(2)
		s33 = sigma(3)
		s12 = sigma(4)
		s13 = sigma(5)
		s23 = sigma(6)

		! compuation of second invariant
		calc_I2 = s11*s22 + s22*s33 + s11*s33 - s12**2 - s13**2 - s23**2

	end function calc_I2

	function calc_I3(sigma) bind(c)
		implicit none
		! computes third invariant of stress tensor

		! --------------------------------------------------------------------------
		! type declaration of return variable
		real(kind=dbl) :: calc_I3

		! passed variables
		real(kind=dbl), intent(in), dimension(6) :: sigma		! stress vector

		! internal variables
		real(kind=dbl) :: s11
		real(kind=dbl) :: s22
		real(kind=dbl) :: s33
		real(kind=dbl) :: s12
		real(kind=dbl) :: s13
		real(kind=dbl) :: s23
		! --------------------------------------------------------------------------

		! unpacking of stress vector
		s11 = sigma(1)
		s22 = sigma(2)
		s33 = sigma(3)
		s12 = sigma(4)
		s13 = sigma(5)
		s23 = sigma(6)

		! compuation of second invariant
		calc_I3 = s11*s22*s33 + 2._dbl*s12*s23*s13 - s12**2*s33 - s23**2*s11 - s13**2*s22

	end function calc_I3

	function calc_s_mean(sigma) bind(c)
		implicit none
		! computes mean stress

		! --------------------------------------------------------------------------
		! type declaration of return variable
		real(kind=dbl) :: calc_s_mean

		! passed variables
		real(kind=dbl), intent(in), dimension(6) :: sigma		! stress vector
		! --------------------------------------------------------------------------

		! computation of mean stress
		calc_s_mean = 1._dbl/3._dbl * sum( sigma(1:3) )

	end function calc_s_mean

	subroutine calc_s_dev(s_dev, sigma) bind(c)
		implicit none
		! computes deviatoric stress vector

		! --------------------------------------------------------------------------
		! type declaration of return variable
		real(kind=dbl), intent(out), dimension(6) :: s_dev

		! passed variables
		real(kind=dbl), intent(in), dimension(6) :: sigma		! stress vector

		! internal variable
		real(kind=dbl) :: s_mean								! mean stress
		! --------------------------------------------------------------------------

		! compuation of s_mean
		s_mean = calc_s_mean(sigma)

		! computation of s_dev
		s_dev = sigma - (/ s_mean, s_mean, s_mean, 0._dbl, 0._dbl, 0._dbl /)

	end subroutine calc_s_dev

	function calc_J2(sigma) bind(c)
		implicit none
		! computes second invariant of deviatoric stress vector

		! --------------------------------------------------------------------------
		! type declaration of return variable
		real(kind=dbl) :: calc_J2

		! passed variables
		real(kind=dbl), intent(in), dimension(6) :: sigma		! stress vector
		! --------------------------------------------------------------------------

		! computation J2
		calc_J2 = 1._dbl/3._dbl*calc_I1(sigma)**2 - calc_I2(sigma)

		! test if J2 < 0 (J2 must be positive)
		if (calc_J2 < 0._dbl) then
			calc_J2 = 0._dbl
		end if

	end function calc_J2

	function calc_J3(sigma) bind(c)
		implicit none
		! computes third invariant of deviatoric stress vector

		! --------------------------------------------------------------------------
		! type declaration of return variable
		real(kind=dbl) :: calc_J3

		! passed variables
		real(kind=dbl), intent(in), dimension(6) :: sigma		! stress vector
		! --------------------------------------------------------------------------

		! computation J3
		calc_J3 = 2._dbl/27._dbl*calc_I1(sigma)**3 - 1._dbl/3._dbl*calc_I1(sigma)*calc_I2(sigma) + calc_I3(sigma)

	end function calc_J3

	subroutine calc_DI1Dsigma(DI1Dsigma, sigma) bind(c)
		implicit none
	    ! computes the gradient of the first invariant of the stress vector with respect to sigma
	    ! dI1/dsigma

		! --------------------------------------------------------------------------
		! type declaration of return variable
		real(kind=dbl), intent(out), dimension(6) :: DI1Dsigma

		! passed variable
		real(kind=dbl), dimension(6), intent(in) :: sigma		! stress vector
		! --------------------------------------------------------------------------

		! dI1/dsigma
		DI1Dsigma = (/ 1._dbl, 1._dbl, 1._dbl, 0._dbl, 0._dbl, 0._dbl /)

	end subroutine calc_DI1Dsigma

	subroutine calc_DI2Dsigma(DI2Dsigma, sigma) bind(c)
		implicit none
	    ! computes the gradient of the second invariant of the stress vector with respect to sigma
	    ! dI2/dsigma

		! --------------------------------------------------------------------------
		! type declaration of return variable
		real(kind=dbl), intent(out), dimension(6) :: DI2Dsigma

		! passed variable
		real(kind=dbl), dimension(6), intent(in) :: sigma		! stress vector
		! --------------------------------------------------------------------------

		! dI2/dsigma
		DI2Dsigma = (/ sigma(2) + sigma(3), &
						sigma(1) + sigma(3), &
						sigma(2) + sigma(1), &
						-2._dbl*sigma(4), &
						-2._dbl*sigma(5), &
						-2._dbl*sigma(6) /)

	end subroutine calc_DI2Dsigma

	subroutine calc_DI3Dsigma(DI3Dsigma, sigma) bind(c)
		implicit none
	    ! computes the gradient of the third invariant of the stress vector with respect to sigma
	    ! dI3/dsigma

		! --------------------------------------------------------------------------
		! type declaration of return variable
		real(kind=dbl), dimension(6), intent(out) :: DI3Dsigma

		! passed variable
		real(kind=dbl), dimension(6), intent(in) :: sigma		! stress vector

		! internal variables
		real(kind=dbl) :: s11
		real(kind=dbl) :: s22
		real(kind=dbl) :: s33
		real(kind=dbl) :: s12
		real(kind=dbl) :: s13
		real(kind=dbl) :: s23
		! --------------------------------------------------------------------------

		! unpacking of stress vector
		s11 = sigma(1)
		s22 = sigma(2)
		s33 = sigma(3)
		s12 = sigma(4)
		s13 = sigma(5)
		s23 = sigma(6)

		! dI3/dsigma
		DI3Dsigma = (/ s22*s33 - s23**2, &
						s11*s33 - s13**2, &
						s11*s22 - s12**2, &
						2._dbl*(s23*s13 - s12*s33), &
						2._dbl*(s12*s23 - s13*s22), &
						2._dbl*(s12*s13 - s23*s11) /)

	end subroutine calc_DI3Dsigma

	subroutine calc_DJ2Dsigma(DJ2Dsigma, sigma) bind(c)
		implicit none
	    ! computes the gradient of the second invariant of the deviatoric stress vector with respect to sigma
	    ! dJ2/dsigma

		! --------------------------------------------------------------------------
		! type declaration of return variable
		real(kind=dbl), dimension(6), intent(out) :: DJ2Dsigma

		! passed variable
		real(kind=dbl), dimension(6), intent(in) :: sigma		! stress vector

		! internal variables
		real(kind=dbl) :: I1
		real(kind=dbl), dimension(6) :: DI1Dsigma
		real(kind=dbl), dimension(6) :: DI2Dsigma
		! --------------------------------------------------------------------------

		!return s_dev
		!calc_DJ2Dsigma = calc_s_dev(sigma)

		call calc_DI1Dsigma(DI1Dsigma, sigma)
		call calc_DI2Dsigma(DI2Dsigma, sigma)

		DJ2Dsigma = 2._dbl/3._dbl*calc_I1(sigma)*DI1Dsigma - DI2Dsigma

	end subroutine calc_DJ2Dsigma

	subroutine calc_DJ3Dsigma(DJ3Dsigma, sigma) bind(c)
		implicit none
	    ! computes the gradient if the third invariant of the deviatoric stress vector with respect to sigma
	    ! dJ3/dsigma

		! --------------------------------------------------------------------------
		! type declaration of return variable
		real(kind=dbl), dimension(6), intent(out) :: DJ3Dsigma

		! passed variable
		real(kind=dbl), dimension(6), intent(in) :: sigma		! stress vector

		! internal variables
		real(kind=dbl) :: dJ3dI1		! dJ3/dI1
		real(kind=dbl) :: dJ3dI2		! dJ3/dI2
		real(kind=dbl) :: dJ3dI3		! dJ3/dI3
		real(kind=dbl), dimension(6) :: DI1Dsigma
		real(kind=dbl), dimension(6) :: DI2Dsigma
		real(kind=dbl), dimension(6) :: DI3Dsigma
		! --------------------------------------------------------------------------

		! dJ3/dI1
		dJ3dI1 = 6._dbl/27._dbl*calc_I1(sigma)**2 - 1._dbl/3._dbl*calc_I2(sigma)

		! dJ3/dI2
		dJ3dI2 = -1._dbl/3._dbl*calc_I1(sigma)

		! dJ3/dI2
		dJ3dI3 = 1._dbl

		call calc_DI1Dsigma(DI1Dsigma, sigma)
		call calc_DI2Dsigma(DI2Dsigma, sigma)
		call calc_DI3Dsigma(DI3Dsigma, sigma)

	    ! dJ3/dsigma
	    DJ3Dsigma = dJ3dI1*DI1Dsigma + dJ3dI2*DI2Dsigma + dJ3dI3*DI3Dsigma

	end subroutine calc_DJ3Dsigma

	function calc_rho(sigma) bind(c)
		implicit none
		! computes the Haigh Westergaard coordinate rho

		! --------------------------------------------------------------------------
		! type declaration of return variable
		real(kind=dbl) :: calc_rho

		! passed variable
		real(kind=dbl), dimension(6), intent(in) :: sigma		! stress vector

		! internal variables
		real(kind=dbl) :: J2									! second invariant of deviatoric stress vector
		! --------------------------------------------------------------------------

		! computation of J2
		J2 = calc_J2(sigma)

		! computation of rho
		calc_rho = sqrt(2._dbl*J2)

	end function calc_rho

	function calc_theta(sigma) bind(c)
		implicit none
		! computes the Haigh Westergaard coordinate theta

		! --------------------------------------------------------------------------
		! type declaration of return variable
		real(kind=dbl) :: calc_theta

		! passed variable
		real(kind=dbl), dimension(6), intent(in) :: sigma		! stress vector

		! internal variables
		real(kind=dbl) :: J2									! second invariant of deviatoric stress vector
		real(kind=dbl) :: J3									! third invariant of deviatoric stress vector
		! --------------------------------------------------------------------------

		! computation of J2 and J3
		J2 = calc_J2(sigma)
		J3 = calc_J3(sigma)

		! computation of theta
		! test if both J2 and J3 are zero, or J2 is negative, i.e a stress state on the hydrostatic axis
		if ( (abs(J3) < epsilon(1._dbl) .and. sqrt(J2)**3 < epsilon(1._dbl) ) .or. &

				(J2 <= 0._dbl) ) then

			! set theta to zero
			calc_theta = 0._dbl

		else if ( 3._dbl*sqrt(3._dbl)/2._dbl * J3/sqrt(J2)**3 > 1._dbl ) then

			! set theta to zero
			calc_theta = 0._dbl

		else if ( 3._dbl*sqrt(3._dbl)/2._dbl * J3/sqrt(J2)**3 < -1._dbl ) then

			calc_theta = Pi/3._dbl

		else

			calc_theta = 1._dbl/3._dbl * acos( 3._dbl*sqrt(3._dbl)/2._dbl * J3/sqrt(J2)**3 )

		end if

	end function calc_theta

	subroutine calc_DrhoDsigma(DrhoDsigma, sigma) bind(c)
		implicit none
	    ! computes the gradient of the Haigh Weestergaard coordinate rho with respect to sigma ( drho/dsigma )

		! --------------------------------------------------------------------------
		! type declaration of return variable
		real(kind=dbl), dimension(6), intent(out) :: DrhoDsigma

		! passed variable
		real(kind=dbl), dimension(6), intent(in) :: sigma		! stress vector

		! internal variables
		real(kind=dbl) :: rho
		real(kind=dbl), dimension(6) :: DJ2Dsigma
		! --------------------------------------------------------------------------

		! compute rho
		rho = calc_rho(sigma)

		! droh/dsigma
		if (rho < epsilon(rho)) then	! numerically equivalent to zero
			DrhoDsigma = huge(rho)*1.0D-10
		else
			call calc_DJ2Dsigma(DJ2Dsigma, sigma)
		    DrhoDsigma = 1._dbl/rho * DJ2Dsigma
		end if

	end subroutine calc_DrhoDsigma

	subroutine calc_DthetaDsigma(DthetaDsigma, sigma) bind(c)
		implicit none
	    ! computes the gradient of the Haigh Weestergaard coordinate theta with respect to sigma ( dtheta/dsigma )

		! --------------------------------------------------------------------------
		! type declaration of return variable
		real(kind=dbl), dimension(6), intent(out) :: DthetaDsigma

		! passed variable
		real(kind=dbl), dimension(6), intent(in) :: sigma		! stress vector

		! internal variables
		real(kind=dbl) :: dtheta_dJ2				! dtheta/dJ2
		real(kind=dbl) :: dtheta_dJ3				! dtheta/dJ3
		real(kind=dbl), dimension(6) :: DJ2Dsigma
		real(kind=dbl), dimension(6) :: DJ3Dsigma
		! --------------------------------------------------------------------------

		! check if cos(3*theta) is outside the interval ]-1,1[
		if ( .not. (cos(3._dbl*calc_theta(sigma)) < 1._dbl) .or. &
			 .not. (cos(3._dbl*calc_theta(sigma)) > -1._dbl) ) then

			! cos(3*theta) is on the borders of or outside the interval,
			! set dtheta/dJ2 and dtheta/dJ3 to zero
			dtheta_dJ2 = 0.0_dbl
			dtheta_dJ3 = 0.0_dbl

		else

			! dtheta/dJ2
			dtheta_dJ2 = sqrt(27._dbl)/4._dbl * calc_J3(sigma)/ &
							( sqrt(calc_J2(sigma))**5 * sqrt(1._dbl - cos(3._dbl*calc_theta(sigma))**2) )

			! dtheta/dJ3
			dtheta_dJ3 = -sqrt(3._dbl)/2._dbl * 1._dbl/ &
							( sqrt(calc_J2(sigma))**3 * sqrt(1._dbl - cos(3._dbl*calc_theta(sigma))**2) )

		end if

		call calc_DJ2Dsigma(DJ2Dsigma, sigma)
		call calc_DJ3Dsigma(DJ3Dsigma, sigma)

	    ! DthetaDsigma
	    DthetaDsigma = dtheta_dJ2*DJ2Dsigma + dtheta_dJ3*DJ3Dsigma

	end subroutine calc_DthetaDsigma

	subroutine calc_C_elastic(C_elastic, E,nu) bind(c)
		implicit none
		! computes elasticity matrix according to the generalized hooke's law
		! sigma = C * epsilon
	    ! see "Concepts and Application of Finite Element Analysis" p. 79, Cook R. et al, 2002, John Wiley & Sons
	    ! engineering shear strains are assumed -> tau_xy = 2*epsilon_xy

		! --------------------------------------------------------------------------
		! type declaration of return variable
		real(kind=dbl), dimension(6,6), intent(out) :: C_elastic

		! passed variables
		real(kind=dbl), intent(in) :: E		! elasticity module
		real(kind=dbl), intent(in) :: nu		! poisson ratio

		! internal variables
		real(kind=dbl) :: a
		real(kind=dbl) :: b
		real(kind=dbl) :: c
		! --------------------------------------------------------------------------

		! initialization of internal variables
		a = E*(1._dbl-nu)/( (1._dbl+nu)*(1._dbl-2._dbl*nu) )
		b = nu/(1._dbl-nu)
		c = (1._dbl-2._dbl*nu)/( 2._dbl*(1._dbl-nu) )

		! initialization of C_el with zeros
		C_elastic = 0._dbl

		! initialization of non zero components of C_el
		C_elastic(1,1) = a
		C_elastic(2,2) = a
		C_elastic(3,3) = a
		C_elastic(4,4) = a*c
		C_elastic(5,5) = a*c
		C_elastic(6,6) = a*c
		C_elastic(1,2) = a*b
		C_elastic(1,3) = a*b
		C_elastic(2,1) = a*b
		C_elastic(2,3) = a*b
		C_elastic(3,1) = a*b
		C_elastic(3,2) = a*b

	end subroutine calc_C_elastic

	subroutine calc_inverse_C_elastic(inverse_C_elastic, E,nu) bind(c)
		implicit none
	    ! computes inverse elasticity matrix C^(-1) according to the generalized hooke's law
	    ! epsilon = C^(-1) * sigma
	    ! see "Festigkeitslehre" p. 86; Mang H. and G. Hofstetter; 2004, SpringerWienNewYork
	    ! engineering shear strains are assumed -> tau_xy = 2*epsilon_xy

		! --------------------------------------------------------------------------
		! type declaration of return variable
		real(kind=dbl), dimension(6,6), intent(out) :: inverse_C_elastic

		! passed variables
		real(kind=dbl), intent(in) :: E		! elasticity module
		real(kind=dbl), intent(in) :: nu		! poisson ratio

		! internal variables
		real(kind=dbl) :: c
		real(kind=dbl) :: G
		! --------------------------------------------------------------------------

		! initialization of internal variables
		c = -nu/E
		G = E/( 2._dbl*(1._dbl+nu) )

		! initialization of C_el with zeros
		inverse_C_elastic = 0._dbl

		! initialization of non zero components of C_el
		inverse_C_elastic(1,1) = 1._dbl/E
		inverse_C_elastic(2,2) = 1._dbl/E
		inverse_C_elastic(3,3) = 1._dbl/E
		inverse_C_elastic(4,4) = 1._dbl/G
		inverse_C_elastic(5,5) = 1._dbl/G
		inverse_C_elastic(6,6) = 1._dbl/G
		inverse_C_elastic(1,2) = c
		inverse_C_elastic(1,3) = c
		inverse_C_elastic(2,1) = c
		inverse_C_elastic(2,3) = c
		inverse_C_elastic(3,1) = c
		inverse_C_elastic(3,2) = c

	end subroutine calc_inverse_C_elastic

! CORRECTED TRANSVERSE ISOTROPIC ELASTICITY MATRIX, ERROR IN WITTKE'S BOOK !!!!!!
	subroutine calc_transv_istr_C_elastic(transv_istr_C_elastic, E1, E2, G2, nu1, nu2) bind(c)
		! computes transverse isotropic elasticity matrix,
		! defined according to 'Rock Mechanics Based on an Anisotropic Jointed Rock Model' by Walter Wittke, p. 42 ff
		! C_el(1,2) = C_el(2,1) is wrong in the book, here the corrected expressions are implemented
		! C_el(3,3) is wrong in the book, here the corrected expressions are implemented
		! sigma = C_el * epsilon
		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), intent(in) :: E1		! elasticity constant parallel to the structure (isotropic) plane
		real(kind=dbl), intent(in) :: E2		! elasticity constant perpendicular to the structure (isotropic) plane
		real(kind=dbl), intent(in) :: G2		! shear modulus for shear loading in/parallel to the structure (isotropic) plane
		real(kind=dbl), intent(in) :: nu1		! poisson ration perpendicular to the structure (isotropic) plane
		real(kind=dbl), intent(in) :: nu2		! poisson ration in the structure (isotropic) plane

		! return variable
		real(kind=dbl), dimension(6,6), intent(out) :: transv_istr_C_elastic		! return variable
!f2py	intent(out) :: calc_transv_istr_C_elastic

		! internal variables
		real(kind=dbl) :: n		! auxiliary variable
		real(kind=dbl) :: m		! auxiliary variable
		! --------------------------------------------------------------------------

		! initialize auxiliary variables
		n = E1/E2
		m = 1._dbl-nu1-2._dbl*n*nu2**2

		! initialize elasticity matrix with zeros
		transv_istr_C_elastic = 0._dbl

		! compute nonzero components of elasticity matrix
		transv_istr_C_elastic(1,1) = E1*(1._dbl-n*nu2**2)/((1._dbl+nu1)*m)
		transv_istr_C_elastic(1,2) = E1*(nu1+n*nu2**2)/((1._dbl+nu1)*m)		! E1*(1._dbl+n*nu2**2)/((1._dbl+nu1)*m) in Wittke's book which is wrong
		transv_istr_C_elastic(2,1) = E1*(nu1+n*nu2**2)/((1._dbl+nu1)*m)		! E1*(1._dbl+n*nu2**2)/((1._dbl+nu1)*m) in Wittke's book which is wrong
		transv_istr_C_elastic(2,2) = E1*(1._dbl-n*nu2**2)/((1._dbl+nu1)*m)
		transv_istr_C_elastic(1:2,3) = E1*nu2/m
		transv_istr_C_elastic(3,1:2) = E1*nu2/m
		transv_istr_C_elastic(3,3) = E2*(1._dbl-nu1)/m							! E1*(1._dbl-nu1)/m in Wittke's book which is wrong
		transv_istr_C_elastic(4,4) = E1/(2._dbl*(1._dbl+nu1))
		transv_istr_C_elastic(5,5) = G2
		transv_istr_C_elastic(6,6) = G2

	end subroutine calc_transv_istr_C_elastic

	subroutine calc_inv_transv_istr_C_elastic(inv_transv_istr_C_elastic, E1, E2, G2, nu1, nu2) bind(c)
		! computes transverse isotropic elasticity matrix,
		! defined according to 'Rock Mechanics Based on an Anisotropic Jointed Rock Model' by Walter Wittke, p. 42 ff
		! epsilon = C_el^(⁻1) * sigma
		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), intent(in) :: E1		! elasticity constant parallel to the structure (isotropic) plane
		real(kind=dbl), intent(in) :: E2		! elasticity constant perpendicular to the structure (isotropic) plane
		real(kind=dbl), intent(in) :: G2		! shear modulus for shear loading in/parallel to the structure (isotropic) plane
		real(kind=dbl), intent(in) :: nu1		! poisson ration perpendicular to the structure (isotropic) plane
		real(kind=dbl), intent(in) :: nu2		! poisson ration in the structure (isotropic) plane

		! return variable
		real(kind=dbl), dimension(6,6), intent(out) :: inv_transv_istr_C_elastic		! return variable

		! internal variables
		! --------------------------------------------------------------------------

		! initialize elasticity matrix with zeros
		inv_transv_istr_C_elastic = 0._dbl

		! compute nonzero components of elasticity matrix
		inv_transv_istr_C_elastic(1,1) = 1._dbl/E1
		inv_transv_istr_C_elastic(1,2) = -nu1/E1
		inv_transv_istr_C_elastic(2,1) = -nu1/E1
		inv_transv_istr_C_elastic(2,2) = 1._dbl/E1
		inv_transv_istr_C_elastic(1:2,3) = -nu2/E2
		inv_transv_istr_C_elastic(3,1:2) = -nu2/E2
		inv_transv_istr_C_elastic(3,3) = 1._dbl/E2
		inv_transv_istr_C_elastic(4,4) = 2._dbl*(1._dbl+nu1)/E1
		inv_transv_istr_C_elastic(5,5) = 1._dbl/G2
		inv_transv_istr_C_elastic(6,6) = 1._dbl/G2

	end subroutine calc_inv_transv_istr_C_elastic

	subroutine calc_sig_princ_hw(sig_princ_hw, s_mean, rho, theta) bind(c)
		implicit none

		! --------------------------------------------------------------------------
		! return variable
		real(kind=dbl), dimension(3), intent(out) :: sig_princ_hw

		! passed variables
		real(kind=dbl), intent(in) :: s_mean
		real(kind=dbl), intent(in) :: rho
		real(kind=dbl), intent(in) :: theta

		! internal variables
		real(kind=dbl), dimension(3) :: s_mean_vec
		real(kind=dbl), dimension(3) :: theta_vec
		! --------------------------------------------------------------------------

		s_mean_vec = (/ s_mean, s_mean, s_mean /)

		theta_vec = (/ cos(theta), -sin(Pi/6._dbl-theta), -sin(Pi/6._dbl+theta) /)

		sig_princ_hw = s_mean_vec + sqrt(2._dbl/3._dbl)*rho*theta_vec

	end subroutine calc_sig_princ_hw

	subroutine calc_sig_princ_hw_sig(sig_princ_hw_sig, sigma) bind(c)
		implicit none

		! --------------------------------------------------------------------------
		! return variable
		real(kind=dbl), dimension(3), intent(out) :: sig_princ_hw_sig

		! passed variables
		real(kind=dbl), intent(in), dimension(6) :: sigma

		! internal variables
		real(kind=dbl) :: s_mean
		real(kind=dbl) :: rho
		real(kind=dbl) :: theta
		real(kind=dbl), dimension(3) :: s_mean_vec
		real(kind=dbl), dimension(3) :: theta_vec
		! --------------------------------------------------------------------------

		! test if shear stress components are zero
		if ( (abs(sigma(4)) < epsilon(1._dbl)) .and. &
				(abs(sigma(5)) < epsilon(1._dbl)) .and. &
				(abs(sigma(6)) < epsilon(1._dbl)) ) then

			! shear stresses are zero and therefore
			! the components of sigma already resemble
			! the principal stresses
			sig_princ_hw_sig = sort_sig_princ(sigma(1:3))
			return

		end if

		s_mean = calc_s_mean(sigma)
		rho = calc_rho(sigma)
		theta = calc_theta(sigma)

		s_mean_vec = (/ s_mean, s_mean, s_mean /)

		theta_vec = (/ cos(theta), -sin(Pi/6._dbl-theta), -sin(Pi/6._dbl+theta) /)

		sig_princ_hw_sig = s_mean_vec + sqrt(2._dbl/3._dbl)*rho*theta_vec

	end subroutine calc_sig_princ_hw_sig

	subroutine calc_Dsigma_princDsigma(Dsigma_princDsigma, sigma) bind(c)
		! computes derivatives of principal stress vector
		! with respect to the stress vector via HW-coordinates
		! dsigma_princ/dsigma
		implicit none

		! --------------------------------------------------------------------------
		! return variable
		real(kind=dbl), dimension(3,6), intent(out) :: Dsigma_princDsigma	! dsigma_princ/dsigma

		! passed variables
		real(kind=dbl), intent(in), dimension(6) :: sigma			! stress vector

		! internal variables
		real(kind=dbl) :: s_mean									! HW-coordinate
		real(kind=dbl) :: rho										! HW-coordinate
		real(kind=dbl) :: theta										! HW-coordinate
		real(kind=dbl), dimension(3,1) :: Dsig_princDs_mean			! dsigma_princ/ds_mean initialized as rank 2 variable (matrix with 1 column),
																	! so that it can be transposed and used in matrix multiplications
																	! (not possible with rank 1 arrays, i.e. vectors)

		real(kind=dbl), dimension(3,1) :: Dsig_princDrho			! dsigma_princ/drho initialized as rank 2 variable (matrix with 1 column),
																	! so that it can be transposed and used in matrix multiplications
																	! (not possible with rank 1 arrays, i.e. vectors)

		real(kind=dbl), dimension(3,1) :: Dsig_princDtheta			! dsigma_princ/dtheta initialized as rank 2 variable (matrix with 1 column),
																	! so that it can be transposed and used in matrix multiplications
																	! (not possible with rank 1 arrays, i.e. vectors)

		real(kind=dbl), dimension(6,1) :: Ds_meanDsig				! ds_mean/dsigma initialized as rank 2 variable (matrix with 1 column),
																	! so that it can be transposed and used in matrix multiplications
																	! (not possible with rank 1 arrays, i.e. vectors)

		real(kind=dbl), dimension(6,1) :: DrhoDsig					! drho/dsigma initialized as rank 2 variable (matrix with 1 column),
																	! so that it can be transposed and used in matrix multiplications
																	! (not possible with rank 1 arrays, i.e. vectors)

		real(kind=dbl), dimension(6,1) :: dthetaDsig				! dtheta/dsigma initialized as rank 2 variable (matrix with 1 column),
																	! so that it can be transposed and used in matrix multiplications
																	! (not possible with rank 1 arrays, i.e. vectors)
		real(kind=dbl), dimension(6) :: DrhoDsig_vec
		real(kind=dbl), dimension(6) :: DthetaDsig_vec
		! --------------------------------------------------------------------------

		! computation of HW-coordinates
		s_mean = calc_s_mean(sigma)
		rho = calc_rho(sigma)
		theta = calc_theta(sigma)

		! computation of dsigma_princ/ds_mean
		Dsig_princDs_mean = reshape( (/ 1._dbl, 1._dbl, 1._dbl /), (/3,1/) )

		! computation of dsigma_princ/drho
		Dsig_princDrho = sqrt(2._dbl/3._dbl) * &
							reshape( (/ cos(theta), -sin(Pi/6._dbl-theta), -sin(Pi/6._dbl+theta) /), &
									(/3,1/) )

		! computation of dsigma_princ/dtheta
		Dsig_princDtheta = sqrt(2._dbl/3._dbl) * rho * &
							reshape( (/ -sin(theta), cos(Pi/6._dbl-theta), -cos(Pi/6._dbl+theta) /), &
									(/3,1/) )

		! computation of ds_mean/dsigma and assignment to
		! rank 2 (matrix) variable Ds_meanDsig
		Ds_meanDsig = reshape( Dsigma_mDsigma, (/6,1/) )

		! computation of drho/dsigma and assignment to
		! rank 2 (matrix) variable DrhoDsig
		call calc_DrhoDsigma(DrhoDsig_vec, sigma)
		DrhoDsig = reshape( DrhoDsig_vec, (/6,1/) )

		! computation of dtheta/dsigma and assignment to
		! rank 2 (matrix) variable DthetaDsig
		call calc_DthetaDsigma(DthetaDsig_vec, sigma)
		DthetaDsig = reshape( DthetaDsig_vec, (/6,1/) )

		! computation of dsigma_princ/dsigma with chain rule
		! dsigma_princ/dsigma = (dsigma_princ/ds_mean * ds_mean/dsigma) +
		! 						+ (dsigma_princ/drho * drho/dsigma) +
		! 						+ (dsigma_princ/dtheta * dtheta/dsigma)
		Dsigma_princDsigma = matmul( Dsig_princDs_mean, transpose(Ds_meanDsig) ) + &
									matmul( Dsig_princDrho, transpose(DrhoDsig) ) + &
									matmul( Dsig_princDtheta, transpose(DthetaDsig) )

	end subroutine calc_Dsigma_princDsigma

	function sort_sig_princ(sig_princ)
		! sorts the entries of the principal stress vector,
		! depending on their size in descending order
		implicit none

		! --------------------------------------------------------------------------
		! return variable
		real(kind=dbl), dimension(3) :: sort_sig_princ

		! input variable
		real(kind=dbl), intent(in), dimension(3) :: sig_princ

		! internal variables
		integer, dimension(1) :: ind_max	! index of maximum sigma component
		integer, dimension(1) :: ind_min	! index of minimum sigma component
		integer, dimension(1) :: ind_mid	! index of intermediate sigma component
		! --------------------------------------------------------------------------

		! find index of maximum value
		ind_max = maxloc(sig_princ)
		! find index of minimum value
		ind_min = minloc(sig_princ)

		if (ind_max(1) == ind_min(1)) then
			! all components have the same size
			! return principal stress vector in unchanged order
			sort_sig_princ = sig_princ
			return
		else
			! find index of intermediate value
			ind_mid = 6 - ind_max - ind_min

			! assign maximum value to first entry of array
			sort_sig_princ(1) = sig_princ(ind_max(1))
			! assign intermediate value to second entry of array
			sort_sig_princ(2) = sig_princ(ind_mid(1))
			! assign minimum value to third(last) entry of array
			sort_sig_princ(3) = sig_princ(ind_min(1))
		end if

	end function sort_sig_princ

	subroutine calc_rot_matrix_epsilon(rot_matrix_epsilon, alpha, beta, gam) bind(c)
		! computes rotation matrix for coordinate transformation of the strain vector,
		! with shear strains in engineering notation
		! according to 'Concepts and Applications of Finite Element Analysis' by Robert D. Cook et al, p. 274, ff
		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), intent(in) :: alpha		! rotation around z axis
		real(kind=dbl), intent(in) :: beta		! rotation around rotated y axis
		real(kind=dbl), intent(in) :: gam		! rotation around rotated z axis, in case if transverse isotropy zero

		! output variable
		real(kind=dbl), dimension(6,6), intent(out) :: rot_matrix_epsilon	! output rotation matrix

		! internal variables
		real(kind=dbl), dimension(3,3) :: T						! rotation matrix with direction cosines of angles between original and rotated coordinate axes
		real(kind=dbl) :: lx, mx, nx							! components of rotated x-base vector (first line of T)
		real(kind=dbl) :: ly, my, ny							! components of rotated y-base vector (second line of T)
		real(kind=dbl) :: lz, mz, nz							! components of rotated z-base vector (third line of T)
		real(kind=dbl), dimension(3,3) :: T11, T12, T21, T22	! submatrices of rotation matrix
		! --------------------------------------------------------------------------

		! computation of rotation matrix out of the three euler rotation angle defined by zyz convention
		call calc_rot_matrix_zyz(T, alpha, beta, gam)

		! assign values of T to components
		lx = T(1,1)
		mx = T(1,2)
		nx = T(1,3)
		ly = T(2,1)
		my = T(2,2)
		ny = T(2,3)
		lz = T(3,1)
		mz = T(3,2)
		nz = T(3,3)

		! fill submatrices
		T11 = T**2
		T12(:,1) = T(:,1)*T(:,2)
		T12(:,2) = T(:,1)*T(:,3)
		T12(:,3) = T(:,2)*T(:,3)
		T21(1,:) = 2._dbl*T(1,:)*T(2,:)
		T21(2,:) = 2._dbl*T(1,:)*T(3,:)
		T21(3,:) = 2._dbl*T(2,:)*T(3,:)
		T22 = reshape((/ (lx*my+mx*ly), (lx*mz+mx*lz), (ly*mz+my*lz), &
							(lx*ny+nx*ly), (lx*nz+nx*lz), (ly*nz+ny*lz), &
							(mx*ny+nx*my), (mx*nz+nx*mz), (my*nz+ny*mz) /), (/3,3/))

		! fill rotation matrix with submatrices
		rot_matrix_epsilon(1:3,1:3) = T11
		rot_matrix_epsilon(1:3,4:6) = T12
		rot_matrix_epsilon(4:6,1:3) = T21
		rot_matrix_epsilon(4:6,4:6) = T22

	end subroutine calc_rot_matrix_epsilon

	subroutine calc_rot_matrix_sigma(rot_matrix_sigma, alpha, beta, gam) bind(c)
		! computes rotation matrix for coordinate transformation of the stress vector,
		! according to 'Concepts and Applications of Finite Element Analysis' by Robert D. Cook et al, p. 274, ff
		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), intent(in) :: alpha		! rotation around z axis
		real(kind=dbl), intent(in) :: beta		! rotation around rotated y axis
		real(kind=dbl), intent(in) :: gam		! rotation around rotated z axis, in case if transverse isotropy zero

		!output variable
		real(kind=dbl), dimension(6,6), intent(out) :: rot_matrix_sigma		! output stress rotation matrix

		! internal variables
		real(kind=dbl), dimension(6,6) :: T_epsilon		! rotation matrix for strain vector
		! --------------------------------------------------------------------------

		! compute rotation matrix for strain vector
		call calc_rot_matrix_epsilon(T_epsilon, alpha, beta, gam)

		! change submatrices of T_epsilon and assign them to output stress rotation matrix
		rot_matrix_sigma(1:3,1:3) = T_epsilon(1:3,1:3)
		rot_matrix_sigma(1:3,4:6) = 2._dbl*T_epsilon(1:3,4:6)
		rot_matrix_sigma(4:6,1:3) = 0.5_dbl*T_epsilon(4:6,1:3)
		rot_matrix_sigma(4:6,4:6) = T_epsilon(4:6,4:6)

	end subroutine calc_rot_matrix_sigma

	subroutine rotate_sigma(sigma_rotated, sigma, alpha, beta, gam) bind(c)
		! computes and returns rotated stress vector
		implicit none

		! --------------------------------------------------------------------------
		! input variables
		real(kind=dbl), intent(in), dimension(6) :: sigma		! stress vector
		real(kind=dbl), intent(in) :: alpha						! first euler rotation angle, around z-axis, eastwards positive (zyz convention)
		real(kind=dbl), intent(in) :: beta						! second euler rotation angle, around rotated y-axis, downwards positive (zyz convention)
		real(kind=dbl), intent(in) :: gam						! third euler rotation angle, around rotated z-axis, eastwards positive (zyz convention)

		! return variable
		real(kind=dbl), dimension(6), intent(out) :: sigma_rotated			! rotated stress vector

		! internal variables
		real(kind=dbl), dimension(6,6) :: T_sig					! rotation matrix for rotation of stress vector
		! --------------------------------------------------------------------------

		! computation of stress rotation matrix with the three euler rotation angle defined by zyz convention
		call calc_rot_matrix_sigma(T_sig, alpha, beta, gam)

		! compute rotated stress vector
		sigma_rotated = matmul(T_sig, sigma)

	end subroutine rotate_sigma

	subroutine rotate_epsilon(epsilon_rotated, eps, alpha, beta, gam) bind(c)
		! computes and returns rotated strain vector
		implicit none

		! --------------------------------------------------------------------------
		! input variables
		real(kind=dbl), intent(in), dimension(6) :: eps			! strain vector
		real(kind=dbl), intent(in) :: alpha						! first euler rotation angle, around z-axis, eastwards positive (zyz convention)
		real(kind=dbl), intent(in) :: beta						! second euler rotation angle, around rotated y-axis, downwards positive (zyz convention)
		real(kind=dbl), intent(in) :: gam						! third euler rotation angle, around rotated z-axis, eastwards positive (zyz convention)

		! return variable
		real(kind=dbl), dimension(6), intent(out) :: epsilon_rotated			! rotated strain vector

		! internal variables
		real(kind=dbl), dimension(6,6) :: T_eps					! rotation matrix for rotation of strain vector
		! --------------------------------------------------------------------------

		! computation of strain rotation matrix with the three euler rotation angle defined by zyz convention
		call calc_rot_matrix_epsilon(T_eps, alpha, beta, gam)

		! compute rotated stress vector
		epsilon_rotated = matmul(T_eps, eps)

	end subroutine rotate_epsilon

	subroutine rotate_material_matrix(C_rot, C, alpha, beta, gam) bind(c)
		! computes and returns rotated material tensor/matrix (C_elastic or C_elastoplastic),
		! according to: 'Rock Mechanics Based on an Anisotropic Jointed Rock Model' by Walter Wittke, p. 45 ff
		!				'Concepts and Applications of Finite Element Analysis' by Robert D. Cook et al, p. 275, ff
		implicit none

		! --------------------------------------------------------------------------
		! input variables
		real(kind=dbl), intent(in), dimension(6,6) :: C			! material matrix
		real(kind=dbl), intent(in) :: alpha						! first euler rotation angle, around z-axis, eastwards positive (zyz convention)
		real(kind=dbl), intent(in) :: beta						! second euler rotation angle, around rotated y-axis, downwards positive (zyz convention)
		real(kind=dbl), intent(in) :: gam						! third euler rotation angle, around rotated z-axis, eastwards positive (zyz convention)

		! return variable
		real(kind=dbl), dimension(6,6), intent(out) :: C_rot			! rotated material matrix
!f2py	intent(out) :: rotate_material_matrix

		! internal variables
		real(kind=dbl), dimension(6,6) :: T_eps					! strain rotation matrix for rotation of material matrix
		real(kind=dbl), dimension(6,6) :: T_sigma				! stress rotation matrix for rotation of material matrix
		! --------------------------------------------------------------------------

		! computation of strain rotation matrix
		call calc_rot_matrix_epsilon(T_eps, -alpha, -beta, -gam)

		! computation of stress rotation matrix
		call calc_rot_matrix_sigma(T_sigma, alpha, beta, gam)

		! compute rotated material matrix
		C_rot = matmul(T_sigma, matmul(C,T_eps))

	end subroutine rotate_material_matrix

	subroutine rotate_inv_material_matrix(C_inv_rot, C_inv, alpha, beta, gam) bind(c)
		! computes and returns rotated material tensor/matrix (inverse C_elastic or inverse C_elastoplastic),
		! according to: 'Rock Mechanics Based on an Anisotropic Jointed Rock Model' by Walter Wittke, p. 45 ff
		!				'Concepts and Applications of Finite Element Analysis' by Robert D. Cook et al, p. 275, ff
		implicit none

		! --------------------------------------------------------------------------
		! input variables
		real(kind=dbl), intent(in), dimension(6,6) :: C_inv			! material matrix
		real(kind=dbl), intent(in) :: alpha						! first euler rotation angle, around z-axis, eastwards positive (zyz convention)
		real(kind=dbl), intent(in) :: beta						! second euler rotation angle, around rotated y-axis, downwards positive (zyz convention)
		real(kind=dbl), intent(in) :: gam						! third euler rotation angle, around rotated z-axis, eastwards positive (zyz convention)

		! return variable
		real(kind=dbl), dimension(6,6), intent(out) :: C_inv_rot			! rotated inverse material matrix

		! internal variables
		real(kind=dbl), dimension(6,6) :: T_sig					! rotation matrix for rotation of inverse material matrix
		! --------------------------------------------------------------------------

		! computation of rotation matrix
		call calc_rot_matrix_sigma(T_sig, alpha, beta, gam)

		! compute rotated inverse material matrix
		C_inv_rot = matmul(transpose(T_sig), matmul(C_inv,T_sig))

	end subroutine rotate_inv_material_matrix

!	function calc_gen_l_vec(sigma)
!		! computes the normed generalized loading vector l
!		! according to "On failure criteria for anisotropic cohesive-frictional materials" by S. Pietruszczak and Z. Mroz, 2000
!		implicit none
!
!		! --------------------------------------------------------------------------
!		! input variables
!		real(kind=dbl), intent(in), dimension(6) :: sigma			! stress vector
!
!		! return variable
!		real(kind=dbl), dimension(3) :: calc_gen_l_vec		! generalized loading vector
!!f2py	intent(out) :: calc_gen_loading_vec
!
!		! internal variables
!		real(kind=dbl), dimension(3) :: L		! loading vector
!		! --------------------------------------------------------------------------
!
!		! compute L
!!		L(1) = sqrt(sigma(1)**2+sigma(4)**2+sigma(5)**2)		! s11, s12, s13
!!		L(2) = sqrt(sigma(2)**2+sigma(4)**2+sigma(6)**2)		! s22, s12, s23
!!		L(3) = sqrt(sigma(3)**2+sigma(5)**2+sigma(6)**2)		! s33, s13, s23
!		if (.not. all(sigma .eq. 0._dbl)) then
!			L = calc_gen_l_vec_unnormed(sigma)			! not all stress components are zero, proceed to compute L
!
!			! compute generalized loading vector
!			calc_gen_l_vec = 1._dbl/norm2(L) * L
!		else
!
!			calc_gen_l_vec = 0._dbl		! all stress components are zero, set l to zero and return
!
!		end if
!
!	end function calc_gen_l_vec
!
!
!
!	function calc_gen_l_vec_unnormed(sigma)
!	        ! computes unnormed generalized loading vector L
!	        implicit none
!
!	        ! --------------------------------------------------------------------------
!	        ! passed variables
!			real(kind=dbl), intent(in), dimension(6) :: sigma		! stress vector
!
!	        ! return variable
!	        real(kind=dbl), dimension(3) :: calc_gen_l_vec_unnormed	! L
!! f2py		intent(out) :: calc_gen_loading_vec_unnormed
!
!	        ! internal variables
!	        ! --------------------------------------------------------------------------
!
!		! compute L
!		calc_gen_l_vec_unnormed(1) = sqrt(sigma(1)**2+sigma(4)**2+sigma(5)**2)		! s11, s12, s13
!		calc_gen_l_vec_unnormed(2) = sqrt(sigma(2)**2+sigma(4)**2+sigma(6)**2)		! s22, s12, s23
!		calc_gen_l_vec_unnormed(3) = sqrt(sigma(3)**2+sigma(5)**2+sigma(6)**2)		! s33, s13, s23
!
!	    end function calc_gen_l_vec_unnormed

end module stress_routines_lib


c ===============================
c
c Tensor Library for ME725
c
c P.Sathananthan
c
c ===============================
c
c Subroutines implemented to date
c
c  tpose (A,B)       -> Aij = Bji           (implemented & verified)
c  det (A,x)         -> det(Aij) = x        (implemented & verified)
c  scale2 (A,B,m)    -> Bij = m.*Aij        (implemented & verified)
c  scale4 (A,B,m)    -> Bijkl = m.*Aijkl    (implemented)
c  invert (A,B)      -> B = inv (A)         (implemented & verified)
c  tc_2s2 (A,B,C)    -> Cij = Aik*Bkj       (implemented)
c  tc_2d2 (A,B,c)    -> c = Aij*Bji         (implemented)
c  tc_4d4 (A4,B4,C4) -> Cijkl = Aijmn*Bmnkl (implemented)
c  tc_4d2 (A4,B,C)   -> Cij = Aijkl*Bkl     (implemented)
c  tc_2d4 (A,B4,C)   -> Cij = Akl*Bklij     (implemented)
c  transform2        -> B = QAQt            (implemented)
c  qzrad             -> rot tensor about z  (implemented)
c  qxrad             -> rot tensor about x  (implemented)
c  qyrad             -> rot tensor about y  (implemented)
c  tp_2dy2           -> Cijkl = AijXBkl
c
c -------------------------------
c
c   2nd order tensor indexing (aij)
c
c   a11 a12 a13   (1) (2) (3)
c   a21 a22 a23   (4) (5) (6)
c   a31 a32 a33   (7) (8) (9)
c
c    index (i,j) = 3*(i-1)+j
c
c -------------------------------
c
c   4th order tensor indexing (aijkl)
c
c   a1111 a1112 ... a1132 a1133   (1,1) (1,2) ... (1,8) (1,9)
c     .                     .       .                  .
c     .                     .       .                  .
c     .                     .       .                  .
c   a3311 a3312 ... a3332 a3333   (9,1) (9,2) ... (9,8) (9,9)
c
c
c   index1 (i,j) = 3*(i-1)+j
c   index2 (k,l) = 3*(k-1)+l
c
c ===============================
c
c transpose 2nd order tensor subroutine
c
c input:  Aij (a 2nd order tensor)
c output: Bji (a 2nd order tensor Aij=Bji)
c
       subroutine tpose (A,B)
c
c       variable declaration region
c       declare intent to avoid accidental changes (C.Butcher)
c
        implicit none
        double precision, intent (in) :: A(9)
        double precision, intent (out) :: B(9)
c
c       hard-code transpose for SPEED!!!
c
        B(1)=A(1)
        B(2)=A(4)
        B(3)=A(7)
        B(4)=A(2)
        B(5)=A(5)
        B(6)=A(8)
        B(7)=A(3)
        B(8)=A(6)
        B(9)=A(9)
c
        return
c
       end subroutine tpose
c
c determinant of a 2nd order tensor subroutine
c
c
       subroutine det (A,x)
c
        implicit none
        double precision, intent (in) :: A(9)
        double precision, intent (out) :: x
c
        x = A(1)*A(5)*A(9)+A(2)*A(6)*A(7)+A(3)*A(4)*A(8)
     &     -A(1)*A(6)*A(8)-A(2)*A(4)*A(9)-A(3)*A(5)*A(7)
c
        return
       end subroutine det
c
c scale 2nd order tensor subroutine
c
       subroutine scale2 (A,B,m)
c
        implicit none
        double precision, intent (in) :: A(9)
        double precision, intent (out) :: B(9)
        double precision, intent (in) :: m
c
        B(1)=m*A(1)
	B(2)=m*A(2)
        B(3)=m*A(3)
        B(4)=m*A(4)
        B(5)=m*A(5)
        B(6)=m*A(6)
        B(7)=m*A(7)
        B(8)=m*A(8)
        B(9)=m*A(9)
c
        return
       end subroutine scale2
c
c scale 4th order tensor subroutine
c
       subroutine scale4 (A4,B4,m)
c
        implicit none
        double precision, intent (in) :: A4(9,9)
        double precision, intent (out) :: B4(9,9)
        double precision, intent (in) :: m
        integer ij
c
        do ij=1,9
         B4(ij,1)=m*A4(ij,1)
	 B4(ij,2)=m*A4(ij,2)
         B4(ij,3)=m*A4(ij,3)
         B4(ij,4)=m*A4(ij,4)
         B4(ij,5)=m*A4(ij,5)
         B4(ij,6)=m*A4(ij,6)
         B4(ij,7)=m*A4(ij,7)
         B4(ij,8)=m*A4(ij,8)
         B4(ij,9)=m*A4(ij,9)
        end do
c
        return
       end subroutine scale4
c
c invert 2nd order tensor subroutine
c        using cofactor method
c
       subroutine invert (A,B)
c
       implicit none
       double precision, intent (in) :: A(9)
       double precision, intent (out) :: B(9)
       double precision minor (9)
       double precision det_A
c
c DETERMINE WHETHER MATRIX IS SINGULAR (NOT INVERTIBLE)
c
       call det (A,det_A)
       if (det_A.EQ.0.0_8) then
         B = (/ 0,0,0,0,0,0,0,0,0 /)
         return
       end if
c
c MATRIX OF MINORS (COFACTORS FROM HERE)
c
       minor (1) =  A(5)*A(9) - A(6)*A(8)
       minor (2) = -A(4)*A(9) + A(6)*A(7)
       minor (3) =  A(4)*A(8) - A(5)*A(7)
       minor (4) = -A(2)*A(9) + A(3)*A(8)
       minor (5) =  A(1)*A(9) - A(3)*A(7)
       minor (6) = -A(1)*A(8) + A(2)*A(7)
       minor (7) =  A(2)*A(6) - A(3)*A(5)
       minor (8) = -A(1)*A(6) + A(3)*A(4)
       minor (9) =  A(1)*A(5) - A(2)*A(4)
c
c TRANSPOSE MAT TO GET ADJUGATE AND FIND INV
c
       call tpose (minor,B)
       call scale2 (B,B,1.0_8/det_A)
c
       end subroutine invert
c
c
c Single Contraction of 2 2nd order Tensors
c
       subroutine tc_2s2 (A,B,C)
c
        implicit none
        double precision, intent (in) :: A(9),B(9)
        double precision, intent (out) :: C(9)
c
        C(1)=A(1)*B(1)+A(2)*B(4)+A(3)*B(7)
        C(2)=A(1)*B(2)+A(2)*B(5)+A(3)*B(8)
        C(3)=A(1)*B(3)+A(2)*B(6)+A(3)*B(9)
        C(4)=A(4)*B(1)+A(5)*B(4)+A(6)*B(7)
        C(5)=A(4)*B(2)+A(5)*B(5)+A(6)*B(8)
        C(6)=A(4)*B(3)+A(5)*B(6)+A(6)*B(9)
        C(7)=A(7)*B(1)+A(8)*B(4)+A(9)*B(7)
        C(8)=A(7)*B(2)+A(8)*B(5)+A(9)*B(8)
        C(9)=A(7)*B(3)+A(8)*B(6)+A(9)*B(9)
c
       end subroutine tc_2s2
c
c Double Contraction of 2 2nd order Tensors
c
       subroutine tc_2d2 (A,B,c)
c
        implicit none
        double precision, intent (inout) :: A(9),B(9)
        double precision, intent (out) :: c
c
        c = A(1)*B(1)+A(2)*B(4)+A(3)*B(7)
     &     +A(4)*B(2)+A(5)*B(5)+A(6)*B(8)
     &     +A(7)*B(3)+A(8)*B(6)+A(9)*B(9)
c
       end subroutine tc_2d2
c
c
c Double Contraction of 2 4th order Tensors
c
       subroutine tc_4d4 (A,B,C)
c
        implicit none
        double precision, intent (in) :: A(9,9),B(9,9)
        double precision, intent (out) :: C(9,9)
        integer ij,kl
c
        do ij=1,9
           do kl=1,9
            C(ij,kl)=A(ij,1)*B(1,kl)+A(ij,2)*B(2,kl)+A(ij,3)*B(3,kl)+
     &               A(ij,4)*B(4,kl)+A(ij,5)*B(5,kl)+A(ij,6)*B(6,kl)+
     &               A(ij,7)*B(7,kl)+A(ij,8)*B(8,kl)+A(ij,9)*B(9,kl)
           end do
        end do
c
       end subroutine tc_4d4
c
c
c Double Contraction of 4th and 2nd order Tensors
c
       subroutine tc_4d2 (A4,B,C)
c
        implicit none
        double precision, intent (in) :: A4(9,9),B(9)
        double precision, intent (out) :: C(9)
        integer ij
c
        do ij=1,9
            C(ij)=A4(ij,1)*B(1)+A4(ij,2)*B(2)+A4(ij,3)*B(3)+
     &            A4(ij,4)*B(4)+A4(ij,5)*B(5)+A4(ij,6)*B(6)+
     &            A4(ij,7)*B(7)+A4(ij,8)*B(8)+A4(ij,9)*B(9)
        end do
c
       end subroutine tc_4d2
c
c
c Double Contraction of 2nd and 4th order Tensors
c
       subroutine tc_2d4 (A,B4,C)
c
        implicit none
        double precision, intent (in) :: A(9),B4(9,9)
        double precision, intent (out) :: C(9)
        integer ij
c
        do ij=1,9
            C(ij)=A(1)*B4(1,ij)+A(2)*B4(2,ij)+A(3)*B4(3,ij)+
     &            A(4)*B4(4,ij)+A(5)*B4(5,ij)+A(6)*B4(6,ij)+
     &            A(7)*B4(7,ij)+A(8)*B4(8,ij)+A(9)*B4(9,ij)
        end do
c
       end subroutine tc_2d4
c
c Transformation of second order tensor
c
       subroutine transform2 (A,Q,C)
c
        implicit none
        double precision, intent (in) :: A(9), Q(9)
        double precision, intent (out) :: C(9)
        double precision :: B(9)
        double precision :: Qt(9)
c
c       calculate qt
c
        call tpose (Q,Qt)
c
c        let      B = QA
c        we want  B = (QA)Qt
c        then     B = BQt
c
        call tc_2s2 (A,Qt,B)
        call tc_2s2 (Q,B,C)
c
        return
c
       end subroutine transform2
c
c Rotation tensor for rotation about z-axis
c        IN RADIANS!!!!!!!!!!!
c
       subroutine qzrad (th,Q)
c
        implicit none
        double precision, intent (in) :: th
        double precision, intent (out) :: Q(9)
c
        Q(1) = COS(th)
        Q(2) = SIN(th)
        Q(3) = 0.0_8
        Q(4) = -SIN(th)
        Q(5) = COS(th)
        Q(6) = 0.0_8
        Q(7) = 0.0_8
        Q(8) = 0.0_8
        Q(9) = 1.0_8
        return
c
       end subroutine qzrad
c
c Rotation tensor for rotation about x-axis
c        IN RADIANS!!!!!!!!!!!
c
       subroutine qxrad (th,Q)
c
        implicit none
        double precision, intent (in) :: th
        double precision, intent (out) :: Q(9)
c
        Q(1) = 1.0_8
        Q(2) = 0.0_8
        Q(3) = 0.0_8
        Q(4) = 0
        Q(5) = COS(th)
        Q(6) = -SIN(th)
        Q(7) = 0.0_8
        Q(8) = SIN(th)
        Q(9) = COS(th)
        return
c
       end subroutine qxrad
c
c Rotation tensor for rotation about y-axis
c        IN RADIANS!!!!!!!!!!!
c
       subroutine qyrad (th,Q)
c
        implicit none
        double precision, intent (in) :: th
        double precision, intent (out) :: Q(9)
c
        Q(1) = COS(th)
        Q(2) = 0.0_8
        Q(3) = SIN(th)
        Q(4) = 0.0_8
        Q(5) = 1.0_8
        Q(6) = 0.0_8
        Q(7) = -SIN(th)
        Q(8) = 0.0_8
        Q(9) = COS(th)
        return
c
       end subroutine qyrad
c
c Dyadic Product of 2 2nd order tensors
c
       subroutine tp_2dy2 (A,B,C4)
c
        implicit none
        double precision, intent (in) :: A(9), B(9)
        double precision, intent (out) :: C4(9,9)
        integer ij

        do ij=1,9
         C4(ij,1) = A(ij)*B(1)
         C4(ij,2) = A(ij)*B(2)
         C4(ij,3) = A(ij)*B(3)
         C4(ij,4) = A(ij)*B(4)
         C4(ij,5) = A(ij)*B(5)
         C4(ij,6) = A(ij)*B(6)
         C4(ij,7) = A(ij)*B(7)
         C4(ij,8) = A(ij)*B(8)
         C4(ij,9) = A(ij)*B(9)
        end do
c
        return
c
       end subroutine tp_2dy2
c


!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED is distributed in the hope that it will be useful, but
!    WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Makes Gauss Legendre nodes and weights
!! @author Ilario Mazzieri
!> @date September, 2013
!> @version 1.0
!> @param[in] ngp  number of Gauss points
!> @param[out] xabsc Gauss points
!> @param[out] weig weights for the Gauss quadrature rule

      subroutine  MAKE_GL_NW(ngp, xabsc, weig)

      implicit none

      INTEGER, parameter :: dbp = SELECTED_REAL_KIND (15,307)
      REAL(dbp) :: newv
      REAL(dbp) :: EPS, M_PI
      PARAMETER (EPS=3.0d-15)               !EPS is the relative precision
      PARAMETER (M_PI=3.141592654d0)

      INTEGER*4  i, j, m
      REAL(dbp)  p1, p2, p3, pp, z, z1
      INTEGER*4, INTENT(IN) :: ngp            ! # of Gauss Points
      REAL(dbp), INTENT(OUT) :: xabsc(ngp), weig(ngp)

           m = (ngp + 1) / 2
!* Roots are symmetric in the interval - so only need to find half of them  */

           do i = 1, m                                ! Loop over the desired roots */

                     z = cos( M_PI * (i-0.25d0) / (ngp+0.5d0) )
!*   Starting with the above approximation to the ith root,
!*          we enter the main loop of refinement by NEWTON'S method   */

100             p1 = 1.0d0
                p2 = 0.0d0
!*  Loop up the recurrence relation to get the Legendre
!*  polynomial evaluated at z                 */

                do j = 1, ngp
                   p3 = p2
                   p2 = p1
                   p1 = ((2.0d0*j-1.0d0) * z * p2 - (j-1.0d0)*p3) / j
                enddo

!* p1 is now the desired Legendre polynomial. We next compute pp,
!* its derivative, by a standard relation involving also p2, the
!* polynomial of one lower order.      */
                pp = ngp*(z*p1-p2)/(z*z-1.0d0)
                z1 = z
                z = z1 - p1/pp             ! Newton's Method  */

                if (dabs(z-z1) .gt. EPS) GOTO  100

              xabsc(i) =  - z                            ! Roots will be bewteen -1.0 & 1.0 */
              xabsc(ngp+1-i) =  + z                        ! and symmetric about the origin   */
              weig(i) = 2.0d0/((1.0d0-z*z)*pp*pp)     ! Compute the weight and its       */
              weig(ngp+1-i) = weig(i)                 ! symmetric counterpart            */

      end do     ! i loop

   End subroutine MAKE_GL_NW


program roots

  implicit none

  intrinsic :: selected_real_kind, abs, sqrt
  integer, parameter :: wp = selected_real_kind(15)
  real(wp) :: p, q, d

  write (*, *) "Solving x² + p·x + q = 0, please enter p and q"
  read (*, *) p, q
	d = 0.25_wp * p**2 - q

	! descriminant is positive, we have two real roots
  if (d > 0.0_wp) then
    write (*, *) "x1 =", -0.5_wp*p + sqrt(d)
    write (*, *) "x2 =", -0.5_wp*p - sqrt(d)
	! descriminant is negative, we have two complex roots
  else if (d < 0.0_wp) then
    write (*, *) "x1 =", -0.5_wp*p, "+ i ·", sqrt(abs(d))
    write (*, *) "x2 =", -0.5_wp*p, "- i ·", sqrt(abs(d))
	! descriminant is zero, we have only one root
	else
    write(*, *) "x1 = x2 =", -0.5_wp * p
  end if

end program roots