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


      PROGRAM TEST

!   Version 1.4.

!   This is a sample program using the FMZM modules for doing arithmetic using the FM, IM, and ZM
!   derived types.

!   The program's output to the screen is also saved in file SampleFM.out.
!   The program checks all the results and the last line of the output file should be
!   "All results were ok."

!   These examples show various ways to use the FM package, but the methods used are not always
!   the most advanced for the sample problem.

      USE FMZM

      IMPLICIT NONE

!             Declare the multiple precision variables.  The three types are:
!             (FM) for multiple precision real
!             (IM) for multiple precision integer
!             (ZM) for multiple precision complex

      TYPE (FM), SAVE :: X1, X2, X3, X4
      TYPE (FM), SAVE, ALLOCATABLE :: A(:,:), B(:,:), V1(:), V2(:)
      TYPE (IM), SAVE :: I1, I2, I3
      TYPE (ZM), SAVE :: Z1, Z2, Z3, Z4

!             Declare the function name of a type (FM) function that will be passed as an argument
!             to a subroutine called from this program.

      TYPE (FM), EXTERNAL :: F

!             Declare the other variables (not multiple precision).

      CHARACTER(80)  :: ST1
      CHARACTER(175) :: FMT
      INTEGER :: ITER, J, K, KOUT, NERROR
      INTEGER :: SEED(7)
      DOUBLE PRECISION :: VALUE

!             Write output to the screen (unit *), and also to the file SampleFM.out.

      KOUT = 18
      OPEN (KOUT,FILE='SampleFM.out')

      NERROR = 0

!             1.  Find a root of the equation  f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0.

!                 Set precision to give at least 60 significant digits.

      CALL FM_SET(60)

!                 Use Newton's method with initial guess x = 3.12.
!                 Horner's rule is used to evaluate the function.

!                 X1 is the previous iterate.
!                 X2 is the current iterate.

!                 TO_FM is a function for converting other types of numbers to type FM.  Note that
!                 TO_FM(3.12) converts the REAL constant to FM, but it is accurate only to single
!                 precision, since the number 3.12 cannot be represented exactly in binary and has
!                 already been rounded to single precision.  Similarly, TO_FM(3.12D0) agrees with
!                 3.12 to double precision accuracy, and TO_FM('3.12') or TO_FM(312)/TO_FM(100)
!                 agrees to full FM accuracy.
!                 Here, TO_FM(3.12) would be ok, since Newton iteration will correct the error
!                 coming from single precision, but it is a good habit to use the more accurate
!                 form.

      X1 = TO_FM('3.12')

!                 Print the first iteration.

      FMT = "(//' Sample 1.  Real root of f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0.'//"// &
            "' Iteration       Newton approximation')"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)

!                 FM_FORM is a formatting subroutine.

      CALL FM_FORM('F65.60',X1,ST1)
      WRITE (*   ,"(/I10,4X,A)") 0,TRIM(ST1)
      WRITE (KOUT,"(/I10,4X,A)") 0,TRIM(ST1)

      DO ITER = 1, 10

!                 X3 is f(X1).

         X3 = ((((X1-3)*X1+1)*X1-4)*X1+1)*X1-6

!                 X4 is f'(X1).

         X4 = (((5*X1-12)*X1+3)*X1-8)*X1+1

         X2 = X1 - X3/X4

!                 Print each iteration.

         CALL FM_FORM('F65.60',X2,ST1)
         WRITE (*   ,"(/I10,4X,A)") ITER,TRIM(ST1)
         WRITE (KOUT,"(/I10,4X,A)") ITER,TRIM(ST1)

!                 Stop iterating if X1 and X2 agree to over 60 places.

         X4 = ABS(X1-X2)
         IF (X4 < 1.0D-61) EXIT

!                 Set X1 = X2 for the next iteration.

         X1 = X2
      ENDDO

!                 Check the answer.

      X3 = TO_FM('3.1206562153267265004709560135237974846546239355990660149888284358')

!                 It is slightly safer to do this test with .NOT. instead of
!                       IF (ABS(X3-X2) >= 1.0D-61) THEN
!                 because if the result of ABS(X3-X2) is FM's UNKNOWN value,
!                 the comparison returns false for all comparisons.

      IF (.NOT.(ABS(X3-X2) < 1.0D-61)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 1.'/)")
          WRITE (KOUT,"(/' Error in sample case number 1.'/)")
      ENDIF

!             2.  Higher Precision.  Compute the root above to 500 decimal places.

      CALL FM_SET(500)

!                 It is tempting to just say X1 = X3 here to initialize the start of the higher
!                 precision iterations to be the check value defined above.  That will not work,
!                 because precision has changed.  Most of the digits of X3 may be undefined at
!                 the new precision.
!                 The most flexible way to pad a lower precision value with zeros when raising
!                 precision is to use subroutine FM_EQU, but here it is easier to re-define X1
!                 from scratch at the new precision.

      X1 = TO_FM('3.1206562153267265004709560135237974846546239355990660149888284358')

      DO ITER = 1, 10

!                 X3 is f(X1).

         X3 = ((((X1-3)*X1+1)*X1-4)*X1+1)*X1-6

!                 X4 is f'(X1).

         X4 = (((5*X1-12)*X1+3)*X1-8)*X1+1

         X2 = X1 - X3/X4

!                 Stop iterating if X1 and X2 agree to over 500 places.

         X4 = ABS(X1-X2)

!                 Compare this test to the similar one in case 1 above.
!                 For machines with 64-bit double precision, 1.0D-501 would be smaller than the
!                 smallest positive number.  So this error tolerance is converted to an FM number
!                 from character form.

         IF (X4 < TO_FM('1.0E-501')) EXIT

!                 Set X1 = X2 for the next iteration.

         X1 = X2
      ENDDO

!                 For very high precision output, it is sometimes more convenient to use FM_PRINT
!                 to format and print the numbers, since the line breaks are handled automatically.
!                 The unit number for the output, KW, and the format codes to be used, JFORM1 and
!                 JFORM2, are internal FM variables.
!                 Subroutine FM_SETVAR is used to re-define these, and the new values will remain in
!                 effect for any further calls to FM_PRINT.

!                 Other variables that can be changed and the options they control are listed in the
!                 documentation at the top of file FM.f95.

!                 Set the FM_PRINT format to F505.500

      CALL FM_SETVAR(' JFORM1 = 2 ')
      CALL FM_SETVAR(' JFORM2 = 500 ')

!                 Set the output screen width to 90 columns.

      CALL FM_SETVAR(' KSWIDE = 90 ')

      FMT = "(///' Sample 2.  Find the root above to 500 decimal places.'/)"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)

!                 Write to the output file.

      CALL FM_SETVAR(' KW = 18 ')
      CALL FM_PRINT(X2)

!                 Write to the screen (unit 6).

      CALL FM_SETVAR(' KW = 6 ')
      CALL FM_PRINT(X2)

!                 Check the answer.

      X3 = TO_FM('3.1206562153267265004709560135237974846546239355990660149888284358190264999'  // &
                   '517954689783257450017151095811923431332682839420040840535954560118152245371'// &
                   '792881305271951017118938898212403662058307303983547376913282000110058273504'// &
                   '202838670709895619275413484521549282591891156945200789415818387529512010999'// &
                   '602155131321076797099026664236992803703462570149559724389392331827597552460'// &
                   '610612200485579529156910428115547013787714423708578161025641555097481179969'// &
                   '175028390105904786831680128384331143259309155577171683842444352768419176139060')

      IF (.NOT.(ABS(X3-X2) < TO_FM('1.0E-501'))) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 2.'/)")
          WRITE (KOUT,"(/' Error in sample case number 2.'/)")
      ENDIF

!             3.  Compute the Riemann zeta function for s=3.

!                 Use Gosper's formula:  zeta(3) =
!                 (5/4)*Sum[ (-1)**k * (k!)**2 / ((k+1)**2 * (2k+1)!) ]
!                 while k = 0, 1, ....

!                 X1 is the current partial sum.
!                 X2 is the current term.
!                 X3 is k!
!                 X4 is (2k+1)!

      CALL FM_SET(60)
      X1 = 1
      X3 = 1
      X4 = 1
      DO K = 1, 200
         X3 = K*X3
         J = 2*K*(2*K+1)
         X4 = J*X4
         X2 = X3**2
         J = (K+1)*(K+1)
         X2 = (X2/J)/X4
         IF (MOD(K,2) == 0) THEN
             X1 = X1 + X2
         ELSE
             X1 = X1 - X2
         ENDIF

!                 Test for convergence.
!                 Here the rate of convergence is much slower than in the Newton iterations above.
!                 Asking for 60 digits in the call to FM_SET will cause the internal precision to
!                 be set slightly higher than that, giving the user a few guard digits.
!                 X2 is the difference between the two most recent partial sums, so the test
!                 below will stop the sum when the last two partial sums agree to at least 65
!                 significant digits.

         IF (ABS(X2/X1) < 1.0D-65) THEN
             FMT = "(///' Sample 3.',2X,I5,' terms were added in the zeta sum.'/)"
             WRITE (*   ,FMT) K
             WRITE (KOUT,FMT) K
             EXIT
         ENDIF
      ENDDO

!                 Print the result.

      X1 = (5*X1)/4
      CALL FM_FORM('F63.60',X1,ST1)
      WRITE (*   ,"(' zeta(3) = ',A)") TRIM(ST1)
      WRITE (KOUT,"(' zeta(3) = ',A)") TRIM(ST1)

!                 Check the answer.

      X3 = TO_FM('1.202056903159594285399738161511449990764986292340498881792271555')
      IF (.NOT.(ABS(X1-X3) < 1.0D-61)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 3.'/)")
          WRITE (KOUT,"(/' Error in sample case number 3.'/)")
      ENDIF

!             4.  Integer multiple precision calculations.

!                 Fermat's theorem says  x**(p-1) mod p = 1 when p is prime and x is not a
!                 multiple of p.
!                 If  x**(p-1) mod p  gives 1 for some p with several different x's, then it is
!                 very likely that p is prime (but it is not certain until further tests are done).

!                 Find a 70-digit number p that is "probably" prime.

!                 Use FM_RANDOM_NUMBER to generate a random 70-digit starting value and search for
!                 a prime from that point.

!                 Initialize the generator.
!                 Note that VALUE is double precision, unlike the similar Fortran intrinsic random
!                 number routine, which returns a single-precision result.

      SEED = (/ 2718281,8284590,4523536,0287471,3526624,9775724,7093698 /)
      CALL FM_RANDOM_SEED_PUT(SEED)

!                 I1 is the value p being tested.

      I1 = 0
      I3 = TO_IM(10)**13
      DO J = 1, 6
         CALL FM_RANDOM_NUMBER(VALUE)
         I2 = 1.0D13*VALUE
         I1 = I1*I3 + I2
      ENDDO
      I3 = TO_IM(10)**70
      I1 = MOD(I1,I3)

!                 To speed up the search, test only values that are not
!                 multiples of 2, 3, 5, 7, 11, 13.

      K = 2*3*5*7*11*13
      I1 = (I1/K)*K + K + 1
      I3 = 3

      DO J = 1, 100
         I2 = I1 - 1

!                 Compute 3**(p-1) mod p

         I3 = POWER_MOD(I3,I2,I1)
         IF (I3 == 1) THEN

!                 Check that 7**(p-1) mod p is also 1.

             I3 = 7
             I3 = POWER_MOD(I3,I2,I1)
             IF (I3 == 1) THEN
                 FMT = "(///' Sample 4.',2X,I5,' values were checked before finding a prime p.'/)"
                 WRITE (*   ,FMT) J
                 WRITE (KOUT,FMT) J
                 EXIT
             ENDIF
         ENDIF

         I3 = 3
         I1 = I1 + K
      ENDDO

!                 Print the result.

      CALL IM_FORM('I72',I1,ST1)
      WRITE (*   ,"(' p =',A)") TRIM(ST1)
      WRITE (KOUT,"(' p =',A)") TRIM(ST1)

!                 Check the answer.

      I3 = TO_IM('9552131129056058313103536357738804884840825498503088946760768419490591')
      IF (.NOT.(I1 == I3)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 4.'/)")
          WRITE (KOUT,"(/' Error in sample case number 4.'/)")
      ENDIF

!             5.  Log Integral function.

!                 Estimate the number of primes less than 10**30.

      FMT = "(///' Sample 5.  Log integral.  Estimate the number of primes less than 10**30.'/"//  &
                "'            It should be accurate to about 15 significant digits.'/)"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)

      I2 = TO_IM(LOG_INTEGRAL(TO_FM('1.0E+30')))

!                 Print the result.

      CALL IM_FORM('I30',I2,ST1)
      WRITE (*   ,"(' int(li(1.0e+30)) = ',A)") TRIM(ST1)
      WRITE (KOUT,"(' int(li(1.0e+30)) = ',A)") TRIM(ST1)

!                 Check the answer.

      I3 = TO_IM('14692398897720447639079087669')
      IF (.NOT.(I2 == I3)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 5.'/)")
          WRITE (KOUT,"(/' Error in sample case number 5.'/)")
      ENDIF

!             6.  Gamma function.

!                 Check that gamma(1/2) is sqrt(pi)

      FMT = "(///' Sample 6.  Check that gamma(1/2) = sqrt(pi).'/)"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)

      X2 = GAMMA(TO_FM('0.5'))

!                 Print the result.

      CALL FM_FORM('F63.60',X2,ST1)
      WRITE (*   ,"(' gamma(1/2) = ',A)") TRIM(ST1)
      WRITE (KOUT,"(' gamma(1/2) = ',A)") TRIM(ST1)

!                 Check the answer.

      X3 = SQRT(ACOS(TO_FM(-1)))
      IF (.NOT.(ABS(X3-X2) < 1.0D-61)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 6.'/)")
          WRITE (KOUT,"(/' Error in sample case number 6.'/)")
      ENDIF

!             7.  Psi and polygamma functions.

!                 Rational series can often be summed using these functions.
!                 Sum (n=1 to infinity) 1/(n**2 * (8n+1)**2) =
!                 16*(psi(1) - psi(9/8)) + polygamma(1,1) + polygamma(1,9/8)
!                 Reference: Abramowitz & Stegun, Handbook of Mathematical Functions,
!                 chapter 6, Example 10.

      FMT = "(///' Sample 7.  Psi and polygamma functions.'/)"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)

      X2 = 16*(PSI(TO_FM(1)) - PSI(TO_FM(9)/8)) + POLYGAMMA(1,TO_FM(1)) + POLYGAMMA(1,TO_FM(9)/8)

!                 Print the result.

      CALL FM_FORM('F65.60',X2,ST1)
      FMT = "(' Sum (n=1 to infinity) 1/(n**2 * (8n+1)**2) = '/9X,A)"
      WRITE (*   ,FMT) TRIM(ST1)
      WRITE (KOUT,FMT) TRIM(ST1)

!                 Check the answer.

      X3 = TO_FM('1.3499486145413024755107829105035147950644978635837270816327396M-2')
      IF (.NOT.(ABS(X3-X2) < 1.0D-61)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 7.'/)")
          WRITE (KOUT,"(/' Error in sample case number 7.'/)")
      ENDIF

!             8.  Incomplete gamma and gamma functions.

!                 Find the probability that an observed chi-square for a correct model should be
!                 less that 2.3 when the number of degrees of freedom is 5.
!                 Reference: Knuth, Volume 2, 3rd ed., Page 56, and Press, Flannery, Teukolsky,
!                 Vetterling, Numerical Recipes, 1st ed., Page 165.

      FMT = "(///' Sample 8.  Incomplete gamma and gamma functions.'/)"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)

      X1 = TO_FM(5)/2
      X2 = INCOMPLETE_GAMMA1(X1,TO_FM('2.3')/2) / GAMMA(X1)

!                 Print the result.

      CALL FM_FORM('F62.60',X2,ST1)
      WRITE (*   ,"(' Probability = ',A)") TRIM(ST1)
      WRITE (KOUT,"(' Probability = ',A)") TRIM(ST1)

!                 Check the answer.

      X3 = TO_FM('0.19373313011487144632751025918250599953472318607121386973066283739')
      IF (.NOT.(ABS(X3-X2) < 1.0D-61)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 8.'/)")
          WRITE (KOUT,"(/' Error in sample case number 8.'/)")
      ENDIF

!             9.  Error function.

!                 Find the probability that a value drawn from a normal distribution is within
!                 1 or 2 or 3 standard deviations from the mean.

      FMT = "(///' Sample 9.  Error function.  Probability that a value drawn from a normal'/"//  &
                "'            distribution is within k standard deviations from the mean.'/)"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)

      DO K = 1, 3
         X1 = K / SQRT(TO_FM(2))
         X2 = ERF(X1)

!                 Print the results.

         CALL FM_FORM('F52.50',X2,ST1)
         WRITE (*   ,"(' k = ',I2,',  probability = ',A)") K,TRIM(ST1)
         WRITE (KOUT,"(' k = ',I2,',  probability = ',A)") K,TRIM(ST1)

!                 Check the answer.

         IF (K == 1) THEN
             X3 = TO_FM('0.68268949213708589717046509126407584495582593345320878197478890049')
         ELSE IF (K == 2) THEN
             X3 = TO_FM('0.95449973610364158559943472566693312505644755259664313203266799974')
         ELSE
             X3 = TO_FM('0.99730020393673981094669637046481004524434126368323870127155602929')
         ENDIF
         IF (.NOT.(ABS(X3-X2) < 1.0D-61)) THEN
             NERROR = NERROR + 1
             WRITE (*   ,"(/' Error in sample case number 9.'/)")
             WRITE (KOUT,"(/' Error in sample case number 9.'/)")
         ENDIF
      ENDDO

!             10. Array operations.

!                 Find the dominant eigenvalue and a corresponding eigenvector for this 5x5 matrix:

!                          3  1  4  1  5
!                          9  2  6  5  3
!                    A =   5  8  9  7  9
!                          3  2  3  8  4
!                          6  2  6  4  3

!                 Use the power method.  Compute B = A**n.  If v1 is an initial guess for the
!                 largest magnitude eigenvector, v2 = B*v1 should be a more accurate approximation.
!                 The ratio of the elements of v3 = A*v2 to those of v2 gives an estimate of the
!                 corresponding eigenvalue.  By repeatedly squaring the matrix, each iteration uses
!                 the next higher power of 2 for n.

      FMT = "(///' Sample 10.  Eigenvalue from matrix powers.')"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)

!             These type FM arrays were declared as allocatable.  Allocate them now, and initialize.

      ALLOCATE( A(5,5) )
      ALLOCATE( B(5,5) )
      ALLOCATE( V1(5) )
      ALLOCATE( V2(5) )

!             To initialize the matrix, we can use array sections to set one row at a time, and the
!             FMZM interface will take care of converting from integer to type (FM).  If the values
!             were not integers, we could say  A(1,1:5) = (/ TO_FM(' 3.7 '),TO_FM(' 4.2 '), etc.

      A(1,1:5) = (/ 3, 1, 4, 1, 5 /)
      A(2,1:5) = (/ 9, 2, 6, 5, 3 /)
      A(3,1:5) = (/ 5, 8, 9, 7, 9 /)
      A(4,1:5) = (/ 3, 2, 3, 8, 4 /)
      A(5,1:5) = (/ 6, 2, 6, 4, 3 /)

!             Initialize all elements of the initial guess vector to 1.

      V1 = 1

      B = A
      WRITE (*   ,"(/' Iteration    eigenvalue approximation ')")
      WRITE (KOUT,"(/' Iteration    eigenvalue approximation ')")
      DO J = 1, 7
         B = MATMUL(B,B)
         V1 = MATMUL(B,V1)
         V2 = MATMUL(A,V1)
         X1 = V2(1) / V1(1)
         CALL FM_FORM('F64.57',X1,ST1)
         WRITE (*   ,"(/I10,A)") J,TRIM(ST1)
         WRITE (KOUT,"(/I10,A)") J,TRIM(ST1)
      ENDDO

!             Normalize the eigenvector (L-2 norm).

      V2 = V2 / NORM2(V2)
      WRITE (*   ,"(/' The corresponding eigenvector is'/)")
      WRITE (KOUT,"(/' The corresponding eigenvector is'/)")
      DO J = 1, 5
         CALL FM_FORM('F61.57',V2(J),ST1)
         WRITE (*   ,"(A)") TRIM(ST1)
         WRITE (KOUT,"(A)") TRIM(ST1)
      ENDDO

!                 Check the answer.

      X3 = TO_FM('23.91276717232132858935703922800330450554912919599927298216827247803204')
      IF (.NOT.(ABS(X3-X1) < 1.0D-61)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 10.'/)")
          WRITE (KOUT,"(/' Error in sample case number 10.'/)")
      ENDIF

!             11. Function and subroutine example.

!                 Find the integral from 0 to 1/2 of 2*exp(-x**2)/sqrt(pi).

!                 The exact value of the integral is erf(1/2).
!                 Use a simple numerical integration routine to apply an integration rule
!                 using 100 intervals.

      CALL FM_SET(40)

      FMT = "(///' Sample 11.  Function and subroutine example.'/)"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)

      X1 = 0
      X2 = TO_FM(' 0.5 ')
      CALL PLAN_9(F,X1,X2,100,X3)

!                 Print the result.

      CALL FM_FORM('F32.30',X3,ST1)
      WRITE (*   ,"(' Integral = ',A)") TRIM(ST1)
      WRITE (KOUT,"(' Integral = ',A)") TRIM(ST1)

!                 Check the answer.

      X4 = ERF(TO_FM('0.5'))
      IF (.NOT.(ABS(X3-X4) < 1.0D-31)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 11.'/)")
          WRITE (KOUT,"(/' Error in sample case number 11.'/)")
      ENDIF

!             Complex arithmetic.

!             Set precision to give at least 30 significant digits.

      CALL FM_SET(30)

!             12. Find a complex root of the equation
!                 f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0.

!                 Newton's method with initial guess x = .56 + 1.06 i.

!                 Z1 is the previous iterate.
!                 Z2 is the current iterate.

      Z1 = TO_ZM('.56 + 1.06 i')

!                 Print the first iteration.

      FMT = "(///' Sample 12.  Complex root of f(x) = x**5 - 3x**4 + x**3 - 4x**2 + x - 6 = 0.',"  &
            //"//' Iteration       Newton approximation')"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)
      CALL ZM_FORM('F32.30','F32.30',Z1,ST1)
      WRITE (*   ,"(/I6,4X,A)") 0,TRIM(ST1)
      WRITE (KOUT,"(/I6,4X,A)") 0,TRIM(ST1)

      DO ITER = 1, 10

!                 Z3 is f(Z1).

         Z3 = ((((Z1-3)*Z1+1)*Z1-4)*Z1+1)*Z1-6

!                 Z4 is f'(Z1).

         Z4 = (((5*Z1-12)*Z1+3)*Z1-8)*Z1+1

         Z2 = Z1 - Z3/Z4

!                 Print each iteration.

         CALL ZM_FORM('F32.30','F32.30',Z2,ST1)
         WRITE (*   ,"(/I6,4X,A)") ITER,TRIM(ST1)
         WRITE (KOUT,"(/I6,4X,A)") ITER,TRIM(ST1)

!                 Stop iterating if Z1 and Z2 agree to over 30 places.

         IF (ABS(Z1-Z2) < 1.0D-31) EXIT

!                 Set Z1 = Z2 for the next iteration.

         Z1 = Z2
      ENDDO

!                 Check the answer.

      Z3 = TO_ZM('0.561958308335403235498111195347453 + 1.061134679604332556983391239058885 i')
      IF (.NOT.(ABS(Z3-Z2) < 1.0D-31)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 12.'/)")
          WRITE (KOUT,"(/' Error in sample case number 12.'/)")
      ENDIF

!             13. Compute exp(1.23-2.34i).

!                 Use the direct Taylor series.

!                 Z1 is x.
!                 Z2 is the current term, x**n/n!.
!                 Z3 is the current partial sum.

      Z1 = TO_ZM('1.23-2.34i')
      Z2 = 1
      Z3 = 1
      DO K = 1, 100
         Z2 = Z2*Z1/K
         Z4 = Z3 + Z2

!                 Test for convergence.

!                 This is a common way to check for series convergence -- wait until the term
!                 being added is so close to zero that the sum does not change.  That is fine
!                 here, because we are using the default round-to-nearest rounding mode.

!                 There is a pitfall if we were to re-run the program with a different rounding
!                 mode.  For example, if we change the rounding mode to round toward +infinity,
!                 then at 30-digit precision the addition  1.2 + 3.4e-100  rounds up to  1.200...001
!                 and so the test to see if the sum did not change might never be satisfied.
!                 This problem can occur with either type FM or ZM sums.

!                 For cases where other rounding modes might be used, doing the convergence check
!                 like we did in the zeta sum of example 3 above is better.  Here that would be
!                    IF (ABS(Z2/Z3) < 1.0D-35) THEN

         IF (Z4 == Z3) THEN
             FMT = "(///' Sample 13.',2X,I5,' terms were added to get exp(1.23-2.34i).'/)"
             WRITE (*   ,FMT) K
             WRITE (KOUT,FMT) K
             EXIT
         ENDIF
         Z3 = Z4
      ENDDO

!                 Print the result.

      CALL ZM_FORM('F33.30','F32.30',Z3,ST1)
      WRITE (*   ,"(' Result= ',A)") TRIM(ST1)
      WRITE (KOUT,"(' Result= ',A)") TRIM(ST1)

!                 Check the answer.

      Z4 = TO_ZM('-2.379681796854777515745457977696745 - 2.458032970832342652397461908326042 i')
      IF (.NOT.(ABS(Z4-Z3) < 1.0D-31)) THEN
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 13.'/)")
          WRITE (KOUT,"(/' Error in sample case number 13.'/)")
      ENDIF

!             14. Exception handling.

!                 Iterate (real) exp(x) starting at 1.0 until overflow occurs.

!                 Testing to see if a type FM number is one of the special cases (+-overflow,
!                 +-underflow or unknown) by direct comparison can be tricky.  When X1 is
!                 +overflow, the statement
!                       IF (X1 == TO_FM(' +OVERFLOW ')) THEN
!                 will return false, since the comparison routine cannot be sure that two
!                 different overflowed results would have been equal if the overflow threshold
!                 had been higher.

!                 Function IS_OVERFLOW can be used to directly check whether a number is + or -
!                 overflow, so that is a safer test.

!                 The FM warning message is written on unit KW, so in this test it appears on the
!                 screen and not in the output file.

      CALL FM_SET(60)

      X1 = TO_FM(1)

      FMT = "(///' Sample 14.  Exception handling.'//12X,"                // &
            "' Iterate exp(x) starting at 1.0 until overflow occurs.'//"  // &
            "12X,' An FM warning message will be printed before the last iteration.')"
      WRITE (*,FMT)
      FMT = "(///' Sample 14.  Exception handling.'//"                    // &
            "12X,' Iterate exp(x) starting at 1.0 until overflow occurs.')"
      WRITE (KOUT,FMT)

      DO J = 1, 10
         X1 = EXP(X1)
         CALL FM_FORM('ES60.40',X1,ST1)
         WRITE (*   ,"(/' Iteration',I3,5X,A)") J,TRIM(ST1)
         WRITE (KOUT,"(/' Iteration',I3,5X,A)") J,TRIM(ST1)
         IF (IS_OVERFLOW(X1)) EXIT
      ENDDO

!             Check that the last result was +overflow.

      IF (IS_OVERFLOW(X1)) THEN
          WRITE (*   ,"(/' Overflow was correctly detected.')")
          WRITE (KOUT,"(/' Overflow was correctly detected.')")
      ELSE
          NERROR = NERROR + 1
          WRITE (*   ,"(/' Error in sample case number 14.'/)")
          WRITE (*   ,"(/' Overflow was not correctly detected.')")
          WRITE (KOUT   ,"(/' Error in sample case number 14.'/)")
          WRITE (KOUT   ,"(/' Overflow was not correctly detected.')")
      ENDIF

      IF (NERROR == 0) THEN
          WRITE (*   ,"(//A/)") ' All results were ok -- no errors were found.'
          WRITE (KOUT,"(//A/)") ' All results were ok -- no errors were found.'
      ELSE
          WRITE (*   ,"(//I3,A/)") NERROR,' error(s) found.'
          WRITE (KOUT,"(//I3,A/)") NERROR,' error(s) found.'
      ENDIF

      STOP
      END PROGRAM TEST

      SUBROUTINE PLAN_9(F,A,B,N,RESULT)

!  Sample subroutine usage for FM.

!  Integrate F(X) from A to B using N subintervals, and return the answer in RESULT.

!  This does numerical integration using a 9-point rule.
!  It is not a very good way to do high-precision integration, but it is a short routine
!  and can often get 20 to 30 digits if f(x) is well-behaved and the interval of integration
!  is not too big.

      USE FMZM
      IMPLICIT NONE
      TYPE (FM) :: A, B, RESULT
      TYPE (FM), SAVE :: H, H8, XJ
      TYPE (FM), EXTERNAL :: F
      INTEGER :: N, J
      INTENT (IN) :: N, A, B
      INTENT (INOUT) :: RESULT

      H = (B - A)/N
      H8 = H/8
      RESULT = 0
      DO J = 1, N
         XJ = A + (J-1)*H
         RESULT = RESULT +   989*F(XJ)      + 5888*F(XJ+  H8) -   928*F(XJ+2*H8) +  &
                           10496*F(XJ+3*H8) - 4540*F(XJ+4*H8) + 10496*F(XJ+5*H8) -  &
                             928*F(XJ+6*H8) + 5888*F(XJ+7*H8) +   989*F(XJ+8*H8)
      ENDDO
      RESULT = H*RESULT/28350

      END SUBROUTINE PLAN_9

      FUNCTION F(X)     RESULT (RETURN_VALUE)

!  Sample function usage for FM.

!  The test function for the integration subroutine is  2*exp(-x**2)/sqrt(pi).

      USE FMZM
      IMPLICIT NONE
      TYPE (FM) :: RETURN_VALUE, X
      TYPE (FM), SAVE :: PI

!             Compare the usage here with the SQRT(ACOS(TO_FM(-1))) usage in the gamma example
!             in the main program.  There pi was only used once, so ACOS(TO_FM(-1)) is more like
!             what a non-multiple-precision program would do to get pi.

!             If we need pi in a function like F that will be called hundreds of times, the acos
!             call will be done every time.  Here, since the argument is -1, the acos routine will
!             recognize it as a special case and return the saved value of pi without needlessly
!             making the program slower.  But if another formula were used, like pi = 6*asin(1/2),
!             it would be better to call FM_PI, since pi would be computed only once and later calls
!             just use the saved value of pi.

!             Another reason to call FM_PI instead of using a formula is that in case the calling
!             program changed the trig function mode to degrees, instead of the default radians,
!             then ACOS(TO_FM(-1)) would give 180, not pi.

!             For this case the 2/sqrt(pi) could have been factored out of the integral so pi would
!             not be needed every time F is called, but it was left in to illustrate similar but
!             more complicated situations.

      CALL FM_PI(PI)
      RETURN_VALUE = 2*EXP(-X**2)/SQRT(PI)

      END FUNCTION F


! Created by EverLookNeverSee@GitHub on 6/1/20
! For more information see FCS/img/Exercise_08_a.png

program main
    implicit none
    ! declaring and initializing variables
    real :: sum = 0.0, theta = 1.57079, t = 1.0
    integer :: i = 0
    ! iterating and calculating cos serie till obtaining correct result
    do
        sum = sum + t
        i = i + 1
        t = t * (-theta * theta) / (2 * i * (2 * i - 1))
        if (sum + t == sum) exit
    end do
    ! printing results
    print *, "Cos(", theta, "):", sum
end program main


module geometry
  !! Provides routines for basic geometrical and trigonometric functions in 2D and 3D.

  implicit none

  public :: norm, distance

contains

  pure real function norm(p) result(d)
    !! Returns the \(L_2\)-norm of a vector \(\mathbf{p}\),
    !! $$ \lVert \mathbf{p} \rVert = \sqrt{\sum_{i=1}^n p_i} $$

    implicit none

    real, allocatable, intent(in) :: p(:)
    integer :: l, u, i

    l = lbound(p,1)
    u = ubound(p,1)

    d = 0.0
    do i = l, u
       d = d + p(i)**2
    end do

    d = sqrt(d)

  end function norm

  pure real function distance(p, q) result(d)
    !! Returns the Euclidean distance between two points \(\mathbf{x}\) and \(\mathbf{y}\),
    !! $$ \lVert \mathbf{q} - \mathbf{p} \rVert = \sqrt{\sum_{i=1}^n \left(q_i - p_i\right)^2} $$

    implicit none

    real, allocatable, intent(in) :: p(:), q(:)
    integer :: l, u, i

    !! @todo Check rank of p vs q
    l = lbound(p,1)
    u = ubound(p,1)

    d = 0.0
    do i = l, u
       d = d + (q(i) - p(i))**2
    end do

    d = sqrt(d)

  end function distance
end module geometry


module circle
! MODULE circle
! This is a practise module intended for learning about modules in Fortran.
! It contains the following subprograms :
!   CircArea : calculates a circle's area
!   CircPeri : calculates the 'perimeter' (circumference) of a circle

  implicit none
  real, parameter::pi=atan(1.0)*4

  contains

  ! FUNCTION CircArea
  ! Input : the circle's radius
  ! Output : the circle's area
  function circarea(radius) result(area)
    real,intent(in)::radius
    real::area

    area = pi * radius * radius
    return
  end function circarea

  ! FUNCTION CircPeri
  ! Input : the circle's radius
  ! Output : the circle's circumference
  function circperi(radius) result(circumference)
    real,intent(in)::radius
    real::circumference

    circumference = 2 * pi * radius
    return
  end function circperi

end module circle


program MC_ex01_p04_Buffon
    use mc_randoms
    implicit none
    real,parameter :: pi=4.0*atan(1.0)
    integer::seed=13,iarg,j,k,n,hits
    real(8)::result,l=2,d=10,error=0
    character(len=80)::arg

    !RNG seed from arguments, default seed 13
    iarg=command_argument_count()
    if (iarg==1) then
        call get_command_argument(1,arg)
        read(arg,*) seed
    end if

    call seed_lcg(int(seed,ik))

    !Simulation part
    n=10000
    !Do 100 simulations with the new throw count
    do j=1,100
        !Simulate a single set of throws
        hits=0
        do k=1,n
            hits=hits+throw()
        end do
        if(hits==0) then
            result=0
        else
            result=n*2*l/(d*hits)
        end if
        error=error+abs(result-pi)
    end do
    error=error/100

    print*,"Error: ",error

contains
    integer function throw()
        implicit none
        real(rk)::y,alpha
        !Randomize the position and the angle of the needle.
        !It's only necessary to look at the other half of the throwing space, since the situation can always be mirrored
        y=rand_lcg()*d/2
        alpha=rand_lcg()*pi/2
        !Check if the end of the needle crosses a line
        if (l/2*sin(alpha)>=y) then
            throw=1
        else
            throw=0
        end if
    end function

end program MC_ex01_p04_Buffon