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

	! load additional modules
	use constants
	use math_routines, 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), parameter :: 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

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

contains

	function calc_I1(sigma)
		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)
		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)
		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)
		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

	function calc_s_dev(sigma)
		implicit none
		! computes deviatoric stress vector

		! --------------------------------------------------------------------------
		! type declaration of return variable
		real(kind=dbl), dimension(6) :: calc_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
		calc_s_dev = sigma - (/ s_mean, s_mean, s_mean, 0._dbl, 0._dbl, 0._dbl /)

	end function calc_s_dev

	function calc_J1(s_dev)
		implicit none
		! computes first invariant of deviatoric stress vector

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

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

		! computation of J1
		calc_J1 = sum( s_dev(1:3) )

	end function calc_J1

	function calc_J2(sigma)
		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)
		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

	function calc_DI1Dsigma(sigma)
		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), dimension(6) :: calc_DI1Dsigma

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

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

	end function calc_DI1Dsigma

	function calc_DI2Dsigma(sigma)
		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), dimension(6) :: calc_DI2Dsigma

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

		! dI2/dsigma
		calc_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 function calc_DI2Dsigma

	function calc_DI3Dsigma(sigma)
		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) :: calc_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
		calc_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 function calc_DI3Dsigma

	function calc_DJ2Dsigma(sigma)
		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) :: calc_DJ2Dsigma

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

		! internal variables
		real(kind=dbl) :: I1
		! --------------------------------------------------------------------------

		!return s_dev
		!calc_DJ2Dsigma = calc_s_dev(sigma)

		calc_DJ2Dsigma = 2._dbl/3._dbl*calc_I1(sigma)*calc_DI1Dsigma(sigma) - calc_DI2Dsigma(sigma)

	end function calc_DJ2Dsigma

	function calc_DJ3Dsigma(sigma)
		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) :: calc_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
		! --------------------------------------------------------------------------

		! 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

	    ! dJ3/dsigma
	    calc_DJ3Dsigma = dJ3dI1*calc_DI1Dsigma(sigma) + dJ3dI2*calc_DI2Dsigma(sigma) + dJ3dI3*calc_DI3Dsigma(sigma)

	end function calc_DJ3Dsigma

	function calc_rho(sigma)
		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)
		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

	function calc_DrhoDsigma(sigma)
		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) :: calc_DrhoDsigma

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

		! internal variables
		real(kind=dbl) :: rho
		! --------------------------------------------------------------------------

		! compute rho
		rho = calc_rho(sigma)

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

	end function calc_DrhoDsigma

	function calc_DthetaDsigma(sigma)
		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) :: calc_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
		! --------------------------------------------------------------------------

		! 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

	    ! DthetaDsigma
	    calc_DthetaDsigma = dtheta_dJ2*calc_DJ2Dsigma(sigma) + dtheta_dJ3*calc_DJ3Dsigma(sigma)

	end function calc_DthetaDsigma

	function calc_C_elastic(E,nu)
		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) :: calc_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
		calc_C_elastic = 0._dbl

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

	end function calc_C_elastic

	function calc_inverse_C_elastic(E,nu)
		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) :: calc_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
		calc_inverse_C_elastic = 0._dbl

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

	end function calc_inverse_C_elastic

! CORRECTED TRANSVERSE ELASTICITY MATRIX, ERROR IN WITTKE'S BOOK !!!!!!
	function calc_transv_istr_C_elastic(E1, E2, G2, nu1, nu2)
		! 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) :: calc_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
		calc_transv_istr_C_elastic = 0._dbl

		! compute nonzero components of elasticity matrix
		calc_transv_istr_C_elastic(1,1) = E1*(1._dbl-n*nu2**2)/((1._dbl+nu1)*m)
		calc_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
		calc_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
		calc_transv_istr_C_elastic(2,2) = E1*(1._dbl-n*nu2**2)/((1._dbl+nu1)*m)
		calc_transv_istr_C_elastic(1:2,3) = E1*nu2/m
		calc_transv_istr_C_elastic(3,1:2) = E1*nu2/m
		calc_transv_istr_C_elastic(3,3) = E2*(1._dbl-nu1)/m							! E1*(1._dbl-nu1)/m in Wittke's book which is wrong
		calc_transv_istr_C_elastic(4,4) = E1/(2._dbl*(1._dbl+nu1))
		calc_transv_istr_C_elastic(5,5) = G2
		calc_transv_istr_C_elastic(6,6) = G2

	end function calc_transv_istr_C_elastic

!	function calc_transv_istr_C_elastic(E1, E2, G2, nu1, nu2)
!		! computes transverse isotropic elasticity matrix,
!		! defined according to Maple Computation
!		! 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) :: calc_transv_istr_C_elastic		! return variable
!
!		! internal variables
!		! --------------------------------------------------------------------------
!
!		! initialize elasticity matrix with zeros
!		calc_transv_istr_C_elastic = 0._dbl
!
!		! compute nonzero components of elasticity matrix
!		calc_transv_istr_C_elastic(1,1) = E1*(-E2+nu2**2*E1)/((E2*nu1-E2+2._dbl*nu2**2*E1)*(1._dbl+nu1))
!		calc_transv_istr_C_elastic(1,2) = -E1*(E2*nu1+nu2**2*E1)/((E2*nu1-E2+2._dbl*nu2**2*E1)*(1._dbl+nu1))
!		calc_transv_istr_C_elastic(1,3) = -nu2*E1*E2/(E2*nu1-E2+2*nu2**2*E1)
!		calc_transv_istr_C_elastic(2,1) = -E1*(E2*nu1+nu2**2*E1)/((E2*nu1-E2+2._dbl*nu2**2*E1)*(1._dbl+nu1))
!		calc_transv_istr_C_elastic(2,2) = E1*(-E2+nu2**2*E1)/((E2*nu1-E2+2._dbl*nu2**2*E1)*(1._dbl+nu1))
!		calc_transv_istr_C_elastic(2,3) = -nu2*E1*E2/(E2*nu1-E2+2._dbl*nu2**2*E1)
!		calc_transv_istr_C_elastic(3,1) = -nu2*E1*E2/(E2*nu1-E2+2._dbl*nu2**2*E1)
!		calc_transv_istr_C_elastic(3,2) = -nu2*E1*E2/(E2*nu1-E2+2._dbl*nu2**2*E1)
!		calc_transv_istr_C_elastic(3,3) = (nu1-1._dbl)*E2**2/(E2*nu1-E2+2._dbl*nu2**2*E1)
!		calc_transv_istr_C_elastic(4,4) = 1._dbl/2._dbl*E1/(1._dbl+nu1)
!		calc_transv_istr_C_elastic(5,5) = G2
!		calc_transv_istr_C_elastic(6,6) = G2
!
!	end function calc_transv_istr_C_elastic

	function calc_inv_transv_istr_C_elastic(E1, E2, G2, nu1, nu2)
		! 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) :: calc_inv_transv_istr_C_elastic		! return variable

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

		! initialize elasticity matrix with zeros
		calc_inv_transv_istr_C_elastic = 0._dbl

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

	end function calc_inv_transv_istr_C_elastic

	function calc_sig_princ_hw(s_mean, rho, theta)
		implicit none

		! --------------------------------------------------------------------------
		! return variable
		real(kind=dbl), dimension(3) :: calc_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) /)

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

	end function calc_sig_princ_hw

	function calc_sig_princ_hw_sig(sigma)
		implicit none

		! --------------------------------------------------------------------------
		! return variable
		real(kind=dbl), dimension(3) :: calc_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
			calc_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) /)

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

	end function calc_sig_princ_hw_sig

	function calc_Dsigma_princDsigma(sigma)
		! 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) :: calc_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)
		! --------------------------------------------------------------------------

		! 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
		DrhoDsig = reshape( calc_DrhoDsigma(sigma), (/6,1/) )

		! computation of dtheta/dsigma and assignment to
		! rank 2 (matrix) variable DthetaDsig
		DthetaDsig = reshape( calc_DthetaDsigma(sigma), (/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)
		calc_Dsigma_princDsigma = matmul( Dsig_princDs_mean, transpose(Ds_meanDsig) ) + &
									matmul( Dsig_princDrho, transpose(DrhoDsig) ) + &
									matmul( Dsig_princDtheta, transpose(DthetaDsig) )

	end function 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

	function calc_rot_matrix_epsilon(alpha, beta, gam)
		! 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) :: calc_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
		T = calc_rot_matrix_zyz(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
		calc_rot_matrix_epsilon(1:3,1:3) = T11
		calc_rot_matrix_epsilon(1:3,4:6) = T12
		calc_rot_matrix_epsilon(4:6,1:3) = T21
		calc_rot_matrix_epsilon(4:6,4:6) = T22

	end function calc_rot_matrix_epsilon

	function calc_rot_matrix_sigma(alpha, beta, gam)
		! 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) :: calc_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
		T_epsilon = calc_rot_matrix_epsilon(alpha, beta, gam)

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

	end function calc_rot_matrix_sigma

	function rotate_sigma(sigma, alpha, beta, gam)
		! 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) :: rotate_sigma			! 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
		T_sig = calc_rot_matrix_sigma(alpha, beta, gam)

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

	end function rotate_sigma

	function rotate_epsilon(eps, alpha, beta, gam)
		! 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) :: rotate_epsilon			! 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
		T_eps = calc_rot_matrix_epsilon(alpha, beta, gam)

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

	end function rotate_epsilon

	function rotate_material_matrix(C, alpha, beta, gam)
		! 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) :: rotate_material_matrix			! 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
		T_eps = calc_rot_matrix_epsilon(-alpha, -beta, -gam)

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

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

	end function rotate_material_matrix

	function rotate_inv_material_matrix(C_inv, alpha, beta, gam)
		! 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) :: rotate_inv_material_matrix			! rotated inverse material matrix

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

		! computation of rotation matrix
		!T_sig = calc_rot_matrix_sigma(alpha, beta, gam)
		T_eps = calc_rot_matrix_epsilon(alpha,beta, gam)

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

	end function 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


c---------------------------------------------------------------------
c---------------------------------------------------------------------

      integer function nodedim(num)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c
c  compute the exponent where num = 2**nodedim
c  NOTE: assumes a power-of-two number of nodes
c
c---------------------------------------------------------------------

      implicit none

c---------------------------------------------------------------------
c  input parameters
c---------------------------------------------------------------------
      integer num

c---------------------------------------------------------------------
c  local variables
c---------------------------------------------------------------------
      double precision fnum

      fnum = dble(num)
      nodedim = log(fnum)/log(2.0d+0) + 0.00001

      return
      end


!**********************************************************************
!  ROUTINE:   FUZZY FORTRAN OPERATORS
!  PURPOSE:   Illustrate Hindmarsh's computation of EPS, and APL
!             tolerant comparisons, tolerant CEIL/FLOOR, and Tolerant
!             ROUND functions - implemented in Fortran.
!  PLATFORM:  PC Windows Fortran, Compaq-Digital CVF 6.1a, AIX XLF90
!  TO RUN:    Windows: DF EPS.F90
!             AIX: XLF90 eps.f -o eps.exe -qfloat=nomaf
!  CALLS:     none
!  AUTHOR:    H. D. Knoble <hdk@psu.edu> 22 September 1978
!  REVISIONS:
!**********************************************************************
!
      DOUBLE PRECISION EPS,EPS3, X,Y,Z, D1MACH,TFLOOR,TCEIL,EPSF90
      LOGICAL TEQ,TNE,TGT,TGE,TLT,TLE
!---Following are Fuzzy Comparison (arithmetic statement) Functions.
!
      TEQ(X,Y)=DABS(X-Y).LE.DMAX1(DABS(X),DABS(Y))*EPS3
      TNE(X,Y)=.NOT.TEQ(X,Y)
      TGT(X,Y)=(X-Y).GT.DMAX1(DABS(X),DABS(Y))*EPS3
      TLE(X,Y)=.NOT.TGT(X,Y)
      TLT(X,Y)=TLE(X,Y).AND.TNE(X,Y)
      TGE(X,Y)=TGT(X,Y).OR.TEQ(X,Y)
!
!---Compute EPS for this computer.  EPS is the smallest real number on
!   this architecture such that 1+EPS>1 and 1-EPS<1.
!   EPSILON(X) is a Fortran 90 built-in Intrinsic function. They should
!   be identically equal.
!
      EPS=D1MACH(NULL)
      EPSF90=EPSILON(X)
      IF(EPS.NE.EPSF90) THEN
        WRITE(*,2)'EPS=',EPS,' .NE. EPSF90=',EPSF90
2       FORMAT(A,Z16,A,Z16)
      ENDIF
!---Accept a representation if exact, or one bit on either side.
      EPS3=3.D0*EPS
      WRITE(*,1) EPS,EPS, EPS3,EPS3
1     FORMAT(' EPS=',D16.8,2X,Z16, ', EPS3=',D16.8,2X,Z16)
!---Illustrate Fuzzy Comparisons using EPS3. Any other magnitudes will
!   behave similarly.
      Z=1.D0
      I=49
        X=1.D0/I
        Y=X*I
        WRITE(*,*) 'X=1.D0/',I,', Y=X*',I,', Z=1.D0'
        WRITE(*,*) 'Y=',Y,' Z=',Z
        WRITE(*,3) X,Y,Z
3       FORMAT(' X=',Z16,' Y=',Z16,' Z=',Z16)
!---Floating-point Y is not identical (.EQ.) to floating-point Z.
        IF(Y.EQ.Z) WRITE(*,*) 'Fuzzy Comparisons: Y=Z'
        IF(Y.NE.Z) WRITE(*,*) 'Fuzzy Comparisons: Y<>Z'
!---But Y is tolerantly (and algebraically) equal to Z.
        IF(TEQ(Y,Z)) THEN
          WRITE(*,*) 'but TEQ(Y,Z) is .TRUE.'
          WRITE(*,*) 'That is, Y is computationally equal to Z.'
        ENDIF
        IF(TNE(Y,Z)) WRITE(*,*) 'and TNE(Y,Z) is .TRUE.'
      WRITE(*,*) ' '
!---Evaluate Fuzzy FLOOR and CEILing Function values using a Comparison
!   Tolerance, CT, of EPS3.
      X=0.11D0
      Y=((X*11.D0)-X)-0.1D0
      YFLOOR=TFLOOR(Y,EPS3)
      YCEIL=TCEIL(Y,EPS3)
55    Z=1.D0
      WRITE(*,*) 'X=0.11D0, Y=X*11.D0-X-0.1D0, Z=1.D0'
      WRITE(*,*) 'X=',X,' Y=',Y,' Z=',Z
      WRITE(*,3) X,Y,Z
!---Floating-point Y is not identical (.EQ.) to floating-point Z.
      IF(Y.EQ.Z) WRITE(*,*) 'Fuzzy FLOOR/CEIL: Y=Z'
      IF(Y.NE.Z) WRITE(*,*) 'Fuzzy FLOOR/CEIL: Y<>Z'
      IF(TFLOOR(Y,EPS3).EQ.TCEIL(Y,EPS3).AND.TFLOOR(Y,EPS3).EQ.Z) THEN
!---But Tolerant Floor/Ceil of Y is identical (and algebraically equal)
!   to Z.
        WRITE(*,*) 'but TFLOOR(Y,EPS3)=TCEIL(Y,EPS3)=Z.'
        WRITE(*,*) 'That is, TFLOOR/TCEIL return exact whole numbers.'
      ENDIF
      STOP
      END
      DOUBLE PRECISION FUNCTION D1MACH (IDUM)
      INTEGER IDUM
!=======================================================================
! This routine computes the unit roundoff of the machine in double
! precision.  This is defined as the smallest positive machine real
! number, EPS, such that (1.0D0+EPS > 1.0D0) & (1.D0-EPS < 1.D0).
! This computation of EPS is the work of Alan C. Hindmarsh.
! For computation of Machine Parameters also see:
!  W. J. Cody, "MACHAR: A subroutine to dynamically determine machine
!  parameters, " TOMS 14, December, 1988; or
!  Alan C. Hindmarsh at  http://www.netlib.org/lapack/util/dlamch.f
!  or Werner W. Schulz at  http://www.ozemail.com.au/~milleraj/ .
!
!  This routine appears to give bit-for-bit the same results as
!  the Intrinsic function EPSILON(x) for x single or double precision.
!  hdk - 25 August 1999.
!-----------------------------------------------------------------------
      DOUBLE PRECISION EPS, COMP
!     EPS = 1.0D0
!10   EPS = EPS*0.5D0
!     COMP = 1.0D0 + EPS
!     IF (COMP .NE. 1.0D0) GO TO 10
!     D1MACH = EPS*2.0D0
      EPS = 1.0D0
      COMP = 2.0D0
      DO WHILE ( COMP .NE. 1.0D0 )
         EPS = EPS*0.5D0
         COMP = 1.0D0 + EPS
      ENDDO
      D1MACH = EPS*2.0D0
      RETURN
      END
      DOUBLE PRECISION FUNCTION TFLOOR(X,CT)
!===========Tolerant FLOOR Function.
!
!    C  -  is given as a double precision argument to be operated on.
!          it is assumed that X is represented with m mantissa bits.
!    CT -  is   given   as   a   Comparison   Tolerance   such   that
!          0.lt.CT.le.3-Sqrt(5)/2. If the relative difference between
!          X and a whole number is  less  than  CT,  then  TFLOOR  is
!          returned   as   this   whole   number.   By  treating  the
!          floating-point numbers as a finite ordered set  note  that
!          the  heuristic  eps=2.**(-(m-1))   and   CT=3*eps   causes
!          arguments  of  TFLOOR/TCEIL to be treated as whole numbers
!          if they are  exactly  whole  numbers  or  are  immediately
!          adjacent to whole number representations.  Since EPS,  the
!          "distance"  between  floating-point  numbers  on  the unit
!          interval, and m, the number of bits in X's mantissa, exist
!          on  every  floating-point   computer,   TFLOOR/TCEIL   are
!          consistently definable on every floating-point computer.
!
!          For more information see the following references:
!    {1} P. E. Hagerty, "More on Fuzzy Floor and Ceiling," APL  QUOTE
!        QUAD 8(4):20-24, June 1978. Note that TFLOOR=FL5 took five
!        years of refereed evolution (publication).
!
!    {2} L. M. Breed, "Definitions for Fuzzy Floor and Ceiling",  APL
!        QUOTE QUAD 8(3):16-23, March 1978.
!
!   H. D. KNOBLE, Penn State University.
!=====================================================================
      DOUBLE PRECISION X,Q,RMAX,EPS5,CT,FLOOR,DINT
!---------FLOOR(X) is the largest integer algegraically less than
!         or equal to X; that is, the unfuzzy Floor Function.
      DINT(X)=X-DMOD(X,1.D0)
      FLOOR(X)=DINT(X)-DMOD(2.D0+DSIGN(1.D0,X),3.D0)
!---------Hagerty's FL5 Function follows...
      Q=1.D0
      IF(X.LT.0)Q=1.D0-CT
      RMAX=Q/(2.D0-CT)
      EPS5=CT/Q
      TFLOOR=FLOOR(X+DMAX1(CT,DMIN1(RMAX,EPS5*DABS(1.D0+FLOOR(X)))))
      IF(X.LE.0 .OR. (TFLOOR-X).LT.RMAX)RETURN
      TFLOOR=TFLOOR-1.D0
      RETURN
      END
      DOUBLE PRECISION FUNCTION TCEIL(X,CT)
!==========Tolerant Ceiling Function.
!    See TFLOOR.
      DOUBLE PRECISION X,CT,TFLOOR
      TCEIL= -TFLOOR(-X,CT)
      RETURN
      END
      DOUBLE PRECISION FUNCTION ROUND(X,CT)
!=========Tolerant Round Function
!  See Knuth, Art of Computer Programming, Vol. 1, Problem 1.2.4-5.
      DOUBLE PRECISION TFLOOR,X,CT
      ROUND=TFLOOR(X+0.5D0,CT)
      RETURN
      END


! Program to test the PRODUCT intrinsic
program testproduct
   implicit none
   integer, dimension (3, 3) :: a
   integer, dimension (3) :: b
   logical, dimension (3, 3) :: m, tr
   character(len=12) line

   a = reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/));

   b = product (a, 1)

   tr = .true.

   if (any(b .ne. (/6, 120, 504/))) call abort

   write (line, 9000) product(a,1)
   if (line .ne. '   6 120 504') call abort

   if (product (a) .ne. 362880) call abort

   write (line, 9010) product(a)
   if (line .ne. '362880') call abort

   m = .true.
   m(1, 1) = .false.
   m(2, 1) = .false.

   b = product (a, 2, m)
   if (any(b .ne. (/28, 40, 162/))) call abort

   b = product (a, 2, m .and. tr)
   if (any(b .ne. (/28, 40, 162/))) call abort

   write (line, 9000) product(a, 2, m)
   if (line .ne. '  28  40 162') call abort

   if (product (a, mask=m) .ne. 181440) call abort

   if (product (a, mask=m .and. tr) .ne. 181440) call abort

   write (line, 9010) product(a, mask=m)
   if (line .ne. '181440') call abort

9000 format (3I4)
9010 format (I6)
end program


C ************************************************************************
C  FILE: ser_pi_calc.f
C  DESCRIPTION:
C    Serial pi Calculation - Fortran Version
C    This program calculates pi using a "dartboard" algorithm.  See
C    Fox et al.(1988) Solving Problems on Concurrent Processors, vol.1
C    page 207.
C    Note: Requires Fortran90 compiler due to random_number() function
C  AUTHOR: unknown
C  LAST REVISED: 02/23/12 Blaise Barney
C ************************************************************************
C Explanation of constants and variables used in this program:
C   DARTS               = number of throws at dartboard
C   ROUNDS              = number of times "DARTS" is iterated
C   pi                  = average of pi for this iteration
C   avepi               = average pi value for all iterations
C ************************************************************************

	program pi_calc

	integer  DARTS, ROUNDS
	parameter(DARTS = 10000)
	parameter(ROUNDS = 100)
        real*4    seednum
        real*8    pi, avepi, dboard

        print *,'Starting serial version of pi calculation...'

 	avepi = 0
	do 40 i = 1, ROUNDS
	  pi = dboard(DARTS)
          avepi = ((avepi*(i-1)) + pi)/ i
          write(*,32) DARTS*i, avepi
 32       format('   After',i8,' throws, average value of pi = ',
     &           f10.8,$)
 40	continue
        print *, ' '
        print *,'Real value of PI: 3.1415926535897'
        print *, ' '
	end

C ************************************************************************
C  dboard.f
C ************************************************************************
C Explanation of constants and variables used in this function:
C   darts       = number of throws at dartboard
C   score       = number of darts that hit circle
C   n           = index variable
C   r           = random number between 0 and 1
C   x_coord     = x coordinate, between -1 and 1
C   x_sqr       = square of x coordinate
C   y_coord     = y coordinate, between -1 and 1
C   y_sqr       = square of y coordinate
C   pi          = computed value of pi
C ************************************************************************
      real*8    function dboard(darts)

      integer   darts, score, n
      real*4    r
      real*8    x_coord, x_sqr, y_coord, y_sqr, pi

      score = 0

C  Throw darts at board.  Done by generating random numbers
C  between 0 and 1 and converting them to values for x and y
C  coordinates and then testing to see if they "land" in
C  the circle."  If so, score is incremented.  After throwing the
C  specified number of darts, pi is calculated.  The computed value
C  of pi is returned as the value of this function, dboard.
C  Note:  the seed value for rand() is set in pi_calc.

C    Note: Requires Fortran90 compiler due to random_number() function
      print *, ' '
      do 10 n = 1, darts
        call random_number(r)
        x_coord = (2.0 * r) - 1.0
        x_sqr = x_coord * x_coord

        call random_number(r)
        y_coord = (2.0 * r) - 1.0
        y_sqr = y_coord * y_coord

        if ((x_sqr + y_sqr) .le. 1.0) then
          score = score + 1
        endif

 10   continue

      pi = 4.0 * score / darts
      dboard = pi
      end


Program TaskOne
IMPLICIT NONE

  real :: X, Y, InsideCircCheck, PiEstimate
  integer :: i,iseed, first, n, ncirc
  real, external :: RandNum

  first=0; iseed=971739; nCirc=0
  write(6,'(a,i9)')'seed value that generates this sequence is ',iseed
  WRITE(6,*) 'Please enter number of points, n'
  READ(5,*) n
X = (RandNum(iseed,first)*2.0)-1
Y = (RandNum(iseed,first)*2.0)-1

DO i=1,n
  X = (RandNum(iseed,first)*2.0)-1
  Y = (RandNum(iseed,first)*2.0)-1
  InsideCircCheck = X**2+Y**2

  IF ( InsideCircCheck <= 1) then
    nCirc = nCirc + 1
  END IF

END DO

PiEstimate = 4.0*(REAL(nCirc)/REAL(n))
WRITE(6,*) PiEstimate

END PROGRAM

function RandNum(iseed,first)
  implicit none
  REAL:: RandNum
  integer, parameter :: MPLIER=16807
  integer, parameter :: MODLUS=2147483647
  integer, parameter :: MOBYMP=127773
  integer, parameter :: MOMDMP=2836
  integer :: hvlue,lvlue,testv,nextn,first,iseed
  save nextn

  if(first == 0) THEN
    nextn=iseed
    first=1
  end if
  hvlue=nextn/mobymp
  lvlue=mod(nextn,mobymp)
  testv=mplier*lvlue-momdmp*hvlue

  if(testv > 0)then
    nextn=testv
  else
    nextn=testv+modlus
  endif
  RandNum = real(nextn)/real(modlus)

end function RandNum

Monte Carlo Method and Bayesian Statistics/Task1.f95


module MC_randoms
    implicit none
    integer,parameter:: ik=selected_int_kind(11)
    integer,parameter:: rk=selected_real_kind(11,100)
    !QCG parameters
    integer(kind=ik),parameter:: qcg_m=11, qcg_a=11, qcg_b=1, qcg_c=3
    integer(kind=ik):: qcg_seed
    !LCG parameters.
    integer(kind=ik),parameter::lcg_m=113829760, lcg_a=10671541, lcg_c=3
    integer(kind=ik)::lcg_seed
    !Park-Miller parameters
    integer(kind=ik),parameter::pm_m=2147483647, pm_a=16807,pm_q=127773,pm_r=2836
    integer(kind=ik)::pm_seed

contains
    !QCG routines
    subroutine seed_qcg(seed)
        implicit none
        integer(kind=ik), intent(in):: seed
        qcg_seed=seed
    end subroutine seed_qcg

    real(kind=rk) function rand_qcg()
        implicit none
        qcg_seed=mod(qcg_a*qcg_seed**2+qcg_b*qcg_seed+qcg_c, qcg_m)
        rand_qcg=real(qcg_seed, rk)/real(qcg_m, rk)
    end function rand_qcg

    !LCG routines
    subroutine seed_lcg(seed)
        implicit none
        integer(kind=ik),intent(in)::seed
        lcg_seed=seed
    end subroutine seed_lcg

    real(rk) function rand_lcg()
        implicit none
        integer(kind=ik)::lcg_r
        lcg_r=mod(int(lcg_a*lcg_seed+lcg_c,ik),int(lcg_m,ik))
        !Return value between [0,1)
        rand_lcg=real(lcg_r,rk)/lcg_m
        !Change the value for I
        lcg_seed=lcg_r
    end function rand_lcg

    !Park-Miller routines
    subroutine seed_pm(seed)
        implicit none
        integer(kind=ik),intent(in)::seed
        pm_seed=seed
    end subroutine seed_pm

    real(rk) function rand_pm()
        implicit none
        integer(kind=ik)::k
        !Schrage approximations with the xor stuff from course material
        pm_seed=xor(pm_seed,123459876)
        k=pm_seed/pm_q
        pm_seed=pm_a*(pm_seed-k*pm_q)-pm_r*k
        !Adjust to correct interval
        if (pm_seed<0) then
           pm_seed=pm_seed + pm_m
        end if
        !Set the seed and result interval
        rand_pm=real(pm_seed,rk)/pm_m
        pm_seed=xor(pm_seed,123459876)
    end function rand_pm
end module MC_randoms


PROGRAM FU_example3
   ! Example program for FU_Prec, FU_Files and FU_Statistics modules of ecasglez's FortranUtilities,
   ! showing how to load data from a file and how to perform different types of regressions.
   ! The dataset can be downloaded from: https://ecasglez.github.io/FortranUtilities/page/Examples/Example03/example3.dat
   ! compile using: gfortran example3.f90 -o example3 -I/path/to/include/ -lFortranUtilities -L/path/to/lib/ -O2
   ! before running: export LD_LIBRARY_PATH=/path/to/lib:${LD_LIBRARY_PATH}
   ! run using: ./example3
   ! license: MIT.

   USE FU_Prec      , ONLY: dp
   USE FU_Files     , ONLY: readMatrix
   USE FU_statistics, ONLY: linreg, logreg, expreg, potreg

   IMPLICIT NONE

   LOGICAL :: exists
   REAL(KIND=dp), DIMENSION(:,:), ALLOCATABLE :: matrix
   REAL(KIND=dp) :: a, b, r2

   !First check if the dataset exists.
   INQUIRE(FILE='example3.dat', EXIST=exists)
   IF (.NOT.exists) THEN
      WRITE(*,*) 'ERROR: Dataset named "example03.dat" not found.'
      STOP
   END IF

   !Load the data in the file.
   CALL readMatrix('example3.dat',matrix)

   !Calculate regression parameters and print the results.
   CALL linreg(matrix(:,1),matrix(:,2),a,b,r2)
   WRITE(*,'(A,F6.4,A,F6.4,A,F6.4)') 'Linear regression:      f(x) = ',a,' x + ',b,'.      Determination coefficient R2 = ',r2
   CALL logreg(matrix(:,1),matrix(:,3),a,b,r2)
   WRITE(*,'(A,F6.4,A,F6.4,A,F6.4)') 'Logarithmic regression: f(x) = ',a,' ln(x) + ',b,'.  Determination coefficient R2 = ',r2
   CALL expreg(matrix(:,1),matrix(:,4),a,b,r2)
   WRITE(*,'(A,F6.4,A,F6.4,A,F6.4)') 'Exponential regression: f(x) = ',b,' exp(',a,'x).    Determination coefficient R2 = ',r2
   CALL potreg(matrix(:,1),matrix(:,5),a,b,r2)
   WRITE(*,'(A,F6.4,A,F6.4,A,F6.4)') 'Potential regression:   f(x) = ',b,' x^',a,'.        Determination coefficient R2 = ',r2

   DEALLOCATE(matrix)

END PROGRAM FU_example3


! Modified to add f_int and fprime_int for the intersections problem.

module functions

    implicit none
    real(kind=8) :: epsilon
    save

contains

real(kind=8) function f_sqrt(x)
    implicit none
    real(kind=8), intent(in) :: x

    f_sqrt = x**2 - 4.d0

end function f_sqrt

real(kind=8) function fprime_sqrt(x)
    implicit none
    real(kind=8), intent(in) :: x

    fprime_sqrt = 2.d0 * x

end function fprime_sqrt

real(kind=8) function f_int(x)
    implicit none
    real(kind=8), intent(in) :: x
    real(kind=8) :: pi
    pi = acos(-1.d0)

    f_int = x*cos(pi*x) - (1.d0 - 0.6d0*x**2)

end function f_int

real(kind=8) function fprime_int(x)
    implicit none
    real(kind=8), intent(in) :: x
    real(kind=8) :: pi
    pi = acos(-1.d0)

    fprime_int = (cos(pi*x) - x*pi*sin(pi*x)) + 1.2d0*x

end function fprime_int

end module functions


      SUBROUTINE ZCOEF(N,ZRT,ZC)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1995-11-29 ZCOEF  Krogh   Converted from SFTRAN to Fortran 77
C>> 1987-09-16 ZCOEF  Lawson  Initial code.
c Conversion should only be done from "Z" to "C" for processing to C.
c--Z replaces "?": ?COEF
C
c     Given N complex numbers, this subr computes the (complex)
c     coefficients of the Nth degree monic polynomial having these
c     numbers as its roots.
c     C. L. Lawson, JPL, 1987 Feb 13.
c
c     N     [In, Integer]  Number of given roots and degree of poly.
c     ZRT() [In, DP]  The given ith complex root is (ZRT(1,i), ZRT(2,i))
c     ZC()  [Out, DP]  The (complex) coefficient of z**j will be stored
c           in (ZC(1,N+1-j), ZC(2,N+1-j)) for j = 0, ...,N+1.  The high
c           order coeff will be one, i.e.
c                (ZC(1,1), ZC(2,1)) = (1.0, 0.0).
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      INTEGER N, I, J
      DOUBLE PRECISION ZRT(2,N),ZC(2,N+1),FAC(2)
      DOUBLE PRECISION ZCR,ZCI,RTR,RTI,TEM
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      ZC(1,1) = 1.D0
      ZC(2,1) = 0.D0
      ZC(1,2) = -ZRT(1,1)
      ZC(2,2) = -ZRT(2,1)
      DO 20 I = 2,N
        ZCR = ZC(1,I)
        ZCI = ZC(2,I)
        RTR = ZRT(1,I)
        RTI = ZRT(2,I)
        TEM = ZCR*RTR - ZCI*RTI
        ZCI = ZCR*RTI + ZCI*RTR
        ZCR = TEM
        ZC(1,I+1) = -ZCR
        ZC(2,I+1) = -ZCI
        DO 10 J = I,2,-1
          ZCR = ZC(1,J-1)
          ZCI = ZC(2,J-1)
          FAC(1) = ZCR*RTR - ZCI*RTI
          FAC(2) = ZCR*RTI + ZCI*RTR
          ZC(1,J) = ZC(1,J) - FAC(1)
          ZC(2,J) = ZC(2,J) - FAC(2)
   10   continue
   20 continue
      RETURN
      END


COMPUTE ROOTS OF A QUADRATIC FUNCTION - 1956
      READ 100,A,B,C
 100  FORMAT(3F8.3)
      PRINT 100,A,B,C
      DISC=B**2-4.*A*C
      IF(DISC),1,2,3
 1    XR=-B/(2.*A)
      XI=SQRT(-DISC)/(2.*A)
      XJ=-XI
      PRINT 311
      PRINT 312,XR,XI,XR,XJ
 311  FORMAT(13HCOMPLEX ROOTS)
 312  FORMAT(4HX1=(,2E12.4,6H),X2=(,2E12.4,1H))
      GO TO 999
 2    X1=-B/(2.*A)
      X2=X1
      PRINT 321
      PRINT 332,X1,X2
 321  FORMAT(16HEQUAL REAL ROOTS)
      GO TO 999
 3    X1= (-B+SQRT(DISC)) / (2.*A)
      X2= (-B-SQRT(DISC)) / (2.*A)
      PRINT 331
      PRINT 332,X1,X2
 331  FORMAT(10HREAL ROOTS)
 332  FORMAT(3HX1=,E12.5,4H,X2=,E12.5)
 999  STOP


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

! Code converted using TO_F90 by Alan Miller
! Date: 2000-07-14  Time: 11:42:45

!  PRMFAC

!  DECOMPOSE A NUMBER INTO ITS PRIME FACTORS.

!  CODED AT MADISON ACADEMIC COMPUTING CENTER,
!  UNIVERSITY OF WISCONSIN, MADISON

!  FORTRAN 77 VERSION 88.09

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

!--------CALLING SEQUENCE

!  CALL PRMFAC (NUMBER, IOPT, NPRM, IPRM, IEXP, *ERR)

!  NUMBER - INTEGER CONSTANT OR VARIABLE, NUMBER TO BE DECOMPOSED
!           INTO PRIME FACTORS.  NUMBER .GE. 2.

!  IOPT   - INTEGER CONSTANT OR VARIABLE, CONTROLS PRINTING OF RESULTS.
!           IOPT .EQ. 0 - RESULTS ARE NOT PRINTED.
!           IOPT .NE. 0 - RESULTS ARE PRINTED.

!  NPRM   - INTEGER VARIABLE, WILL CONTAIN THE NO. OF DISTINCT PRIME
!           FACTORS OF THE NUMBER.

!  IPRM   - INTEGER ARRAY OF SIZE AT LEAST 9, WILL CONTAIN THE PRIME
!           FACTORS OF THE NUMBER.

!  IEXP   - INTEGER ARRAY OF SIZE AT LEAST 9, WILL CONTAIN THE
!           EXPONENTS OF THE CORRESPONDING PRIME FACTORS.

!  *ERR   - STATEMENT NUMBER PRECEDED WITH AN ASTERISK (*).
!           IF AN ERROR CONDITION IS DETECTED, CONTROL IS RETURNED
!           TO THAT STATEMENT IN THE CALLING PROGRAM.
!           This has been deleted below.

!--------NOTES

!  (1)  UPON RETURN FROM PRMFAC,
!       NUMBER = IPRM(1)**IEXP(1) * IPRM(2)**IEXP(2) * ... *
!               IPRM(NPRM)**IEXP(NPRM)

!  (2)  A NUMBER REPRESENTED BY A (SINGLE-PRECISION) INTEGER
!       VALUE ON THE VMS VAX CLUSTER CAN HAVE AT MOST 9 DISTINCT
!       PRIME FACTORS.  ON MACHINES WHERE THE MAXIMUM INTEGER IS
!       LARGER THAN 2**31 - 1, IPRM AND IEXP WOULD, IN GENERAL,
!       HAVE TO BE DIMENSIONED LARGER SINCE LARGER NUMBERS MAY
!       HAVE MORE THAN 9 DISTINCT PRIME FACTORS.

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

SUBROUTINE prmfac (NUMBER, iopt, nprm, iprm, iexp)

!--------PARAMETERS

IMPLICIT NONE

INTEGER, INTENT(IN)   :: NUMBER
INTEGER, INTENT(IN)   :: iopt
INTEGER, INTENT(OUT)  :: nprm
INTEGER, INTENT(OUT)  :: iprm(:)
INTEGER, INTENT(OUT)  :: iexp(:)

!--------LOCAL VARIABLES
INTEGER            :: div, indx, isize, j, n, offset, olddiv, quo, rem

!---------DATA TO OBTAIN TRIAL DIVISORS 2, 3, 5, 7 AND ALL
!         HIGHER NUMBERS NOT DIVISIBLE BY 2, 3, 5, 7.
INTEGER, PARAMETER  :: base(52) = (/   &
    211, 209, 199, 197, 193, 191, 187, 181, 179, 173, 169, 167, 163, &
    157, 151, 149, 143, 139, 137, 131, 127, 121, 113, 109, 107, 103, &
    101,  97,  89,  83,  79,  73,  71,  67,  61,  59,  53,  47,  43, &
     41,  37,  31,  29,  23,  19,  17,  13,  11,   7,   5,   3,   2 /)

!--------FORMAT TEMPLATE
CHARACTER (LEN=16) :: i4mat = '(1X,A8,1X,--I--)'
CHARACTER (LEN=8)  :: txtlst(2) = (/ 'PRIME   ', 'EXPONENT' /)

!--------LOGICAL UNIT FOR STANDARD OUTPUT
INTEGER, PARAMETER :: prn = 6

!--------CHECK NUMBER.  MUST BE .GE. 2
IF (NUMBER < 2) GO TO 140

!--------INITIALIZATIONS.
j = 0
n = NUMBER
olddiv = 0
offset = 0
indx = 53

!--------GET NEXT TRIAL DIVISOR.
DO
  indx = indx - 1
  IF (indx <= 0) THEN
    indx = 48
    offset = offset + 210
  END IF
  div = offset + base(indx)

!--------TEST TRIAL DIVISOR.
  DO
    quo = n / div
    rem = n - quo*div
    IF (rem /= 0) EXIT

!--------FACTOR FOUND, ZERO REMAINDER.
    n = quo
    IF (div <= olddiv) THEN

!--------MULTIPLE FACTOR.
      iexp(j) = iexp(j) + 1
      CYCLE
    END IF

!--------NEW FACTOR.
    j = j + 1
    iprm(j) = div
    iexp(j) = 1
    olddiv = div
  END DO

!--------NOT A FACTOR, POSITIVE REMAINDER.  CHECK DIVISOR SIZE.
  IF (div >= quo) EXIT
END DO

!--------FINISHED, WHAT ISN'T FACTORED IS A PRIME (OR 1).
IF (n > 1) THEN
  j = j + 1
  iexp(j) = 1
  iprm(j) = n
END IF
nprm = j

!--------PRINT RESULTS IF REQUESTED.
IF (iopt == 0) GO TO 130
WRITE (prn,70)
70 FORMAT ( / ' ', 7('----------') )
IF (nprm /= 1 .OR. iexp(1) /= 1) GO TO 90

!--------NUMBER IS PRIME
WRITE (prn,80) NUMBER
80 FORMAT ( / t3, i12, ' IS PRIME' )
GO TO 120

!--------NUMBER IS COMPOSITE
90 WRITE (prn,100) NUMBER
100 FORMAT ( / t3, i12, ' FACTORS AS FOLLOWS' / )

!--------DETERMINE SUITABLE FORMAT FOR FACTORS AND EXPONENTS AND PRINT.
isize = LOG10 (REAL(iprm(nprm)) + 0.5D0)
isize = MAX (6,isize+3)
WRITE (i4mat(11:12), 110) nprm
110 FORMAT (i2.2)
WRITE (i4mat(14:15), 110) isize
WRITE (prn, i4mat) txtlst(1), iprm(1:nprm)
WRITE (prn, i4mat) txtlst(2), iexp(1:nprm)

120 WRITE (prn,70)

!--------NORMAL EXIT
130 RETURN

!--------ERROR, ISSUE MESSAGE AND TAKE ERROR EXIT.
140 WRITE (prn,150) NUMBER
150 FORMAT (' *** ERROR IN PRMFAC, NUMBER =', i12, ', NUMBER MUST BE >= 2')

!--------ERROR EXIT
RETURN

!--------END OF PRMFAC
END SUBROUTINE prmfac

PROGRAM find_prime_factors
IMPLICIT NONE

INTERFACE
  SUBROUTINE prmfac (NUMBER, iopt, nprm, iprm, iexp)
    IMPLICIT NONE
    INTEGER, INTENT(IN)   :: NUMBER
    INTEGER, INTENT(IN)   :: iopt
    INTEGER, INTENT(OUT)  :: nprm
    INTEGER, INTENT(OUT)  :: iprm(:)
    INTEGER, INTENT(OUT)  :: iexp(:)
  END SUBROUTINE prmfac
END INTERFACE

INTEGER  :: iexp(10), iopt, iprm(10), nprm, NUMBER

DO
  iopt = 1
  WRITE(*, '(a)', ADVANCE='NO') ' Enter number to be factored: '
  READ(*, *) NUMBER
  CALL prmfac (NUMBER, iopt, nprm, iprm, iexp)
  WRITE(*, *)
END DO

STOP
END PROGRAM find_prime_factors


! Runga-Kutta method

program RK4
implicit none
double precision h,w,exact,diff,f,a,b,alpha,t,k1,k2,k3,k4
integer i,N
write(*,*) 'enter a,b'
read(*,*) a,b
write(*,*) 'enter N'
read(*,*) N
write(*,*) 'enter alpha'
read(*,*) alpha
h=(b-a)/dfloat(N)
t=a
w=alpha
do i=1,n
  k1=h*f(t,w)
  k2=h*f(t+h/2.d0,w+k1/2.d0)
  k3=h*f(t+h/2.d0,w+k2/2.d0)
  k4=h*f(t+h,w+k3)
  w=w+(k1+2.d0*(k2+k3)+k4)/6.d0
  t=a+dfloat(i)*h
  diff=dabs(exact(t)-w)
  write(8,*) t,diff
  write(10,*) t,w,exact(t),diff
enddo
write(9,*) h,diff
stop
end program RK4

function exact(t)
double precision t,exact,x
x=2.d0*t
exact=(.5d0)*(1/(t**2.d0))*(4+dcos(2.d0)-dcos(x))
return
end function exact

function f(t,y)
double precision t,y,f,z,x
x=2*t
z=x*y
f=(1/(t**2))*(dsin(x) - z)
return
end function f


SUBROUTINE BeachGen3Dver2(h,h0,h1,lx,ly,x,y,Nx,Ny)
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
IMPLICIT NONE
INTEGER :: Nx,Ny,i,j
REAL(KIND=long) :: h(Nx,Ny), h0, h1, l, x(Nx), y(Ny), xi, lx, ly

IF (lx /= ly .OR. ABS(lx-one)>1e-10) THEN
	PRINT*,'Error: Lx and Ly have to be equal to size 1 for the chosen test case.'
	STOP
ELSE
	l = lx
ENDIF

! Initialize:
h = zero
DO j = 1,Ny
	DO i = 1,Nx
        IF (SQRT(x(i)**2 + y(j)**2) > one) THEN
            xi = one
        ELSE
            xi = SQRT(x(i)**2 + y(j)**2)
        ENDIF
	    IF (xi > zero .AND. xi < l) THEN
	        h(i,j)   = h0 - (h0-h1)/two*(one+TANH(SIN(pi*(xi-l/two)/l)/(one-(two*(xi-l/two)/l)**2)))
		ELSE IF (xi>=l) THEN
			h(i,j) = h1
		ELSE
		    h(i,j)   = h0
		ENDIF
    END DO
END DO
END SUBROUTINE BeachGen3Dver2


      SUBROUTINE CHEBFT(A,B,C,N,FUNC)
      REAL*8 PI
      PARAMETER (NMAX=50, PI=3.141592653589793D0)
      REAL*8 SUM
      DIMENSION C(N),F(NMAX)
      BMA=0.5*(B-A)
      BPA=0.5*(B+A)
      DO 11 K=1,N
        Y=COS(PI*(K-0.5)/N)
        F(K)=FUNC(Y*BMA+BPA)
11    CONTINUE
      FAC=2./N
      DO 13 J=1,N
        SUM=0.D0
        DO 12 K=1,N
          SUM=SUM+F(K)*COS((PI*(J-1))*((K-0.5D0)/N))
12      CONTINUE
        C(J)=FAC*SUM
13    CONTINUE
      RETURN
      END


	FUNCTION PR_MIXR  ( dwpc, pres )
C************************************************************************
C* PR_MIXR								*
C*									*
C* This function computes MIXR from DWPC and PRES.  The following	*
C* equation is used:							*
C*									*
C*         MIXR = .62197 * ( e / ( PRES - e ) ) * 1000.			*
C*									*
C*              e    =  VAPR * corr					*
C*              corr =  (1.001 + ( ( PRES - 100. ) / 900. ) * .0034)	*
C*									*
C* University of Wisconsin green sheet.					*
C*									*
C* This function can also be used for the following computations:	*
C*            MIXS from TMPC and PRES					*
C*            SMXR from DWPC and PALT					*
C*            SMXS from TMPC and PALT					*
C*									*
C* REAL PR_MIXR  ( DWPC, PRES )						*
C*									*
C* Input parameters:							*
C*	DWPC		REAL   		Dewpoint in Celsius		*
C*	PRES		REAL   		Pressure in millibars		*
C*									*
C* Output parameters:							*
C*	PR_MIXR		REAL		Mixing ratio in g/kg		*
C**									*
C* Log:									*
C* P. Kocin/914		1980	Original source code			*
C* M. Goodman/RDS	3/84	Added PR_TMCK				*
C* I. Graffman/RDS	12/84	Changed .622 to .62197			*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC	7/88	Documentation; check missing VAPR,	*
C*				large E at low PRES			*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for missing data.
C
	IF  ( ERMISS ( dwpc ) .or. ERMISS ( pres ) )  THEN
	    PR_MIXR = RMISSD
	  ELSE
C
C*	    Calculate vapor pressure.
C
	    vapr = PR_VAPR ( dwpc )
	    IF  ( ERMISS ( vapr ) )  THEN
	        PR_MIXR = RMISSD
		RETURN
	    END IF
C
C*	    CORR is a correction to the vapor pressure
C*	    since the atmosphere is not an ideal gas.
C
	    corr = (1.001 + (( pres - 100.) / 900.) * .0034)
	    e    = corr * vapr
C
C*	    Test for unphysical case of large E at low PRES.
C
	    IF  ( e .gt. ( .5 * pres ) )  THEN
                PR_MIXR = RMISSD
	      ELSE
C
C*	    Calculate mixing ratio.
C
	        PR_MIXR = .62197 * (e / (pres - e)) * 1000.
	    END IF
	END IF
C*
	RETURN
	END


program intrinsics_19
! Test intrinsics both declarations and executable statements.
! Single and double precision, real only.
integer, parameter :: dp = kind(0.d0)

real, parameter :: &
    s1 = abs(-0.5), &
    s2 = exp(0.5), &
    s3 = log(0.5), &
    s4 = erf(0.5), &
    s5 = erfc(0.5), &
    s6 = sqrt(0.5), &
    s7 = gamma(0.5), &
    s8 = atan2(0.5, 0.5), &
    s9 = log_gamma(0.5), &
    s10 = log10(0.5)

integer, parameter :: &
    s11 = nint(3.6), &
    s12 = floor(3.6), &
    s13 = nint(-3.6), &
    s14 = floor(-3.6)

real(dp), parameter :: &
    d1 = abs(-0.5_dp), &
    d2 = exp(0.5_dp), &
    d3 = log(0.5_dp), &
    d4 = erf(0.5_dp), &
    d5 = erfc(0.5_dp), &
    d6 = sqrt(0.5_dp), &
    d7 = gamma(0.5_dp), &
    d8 = atan2(0.5_dp, 0.5_dp), &
    d9 = log_gamma(0.5_dp), &
    d10 = log10(0.5_dp)

integer, parameter :: &
    d11 = nint(3.6_dp), &
    d12 = floor(3.6_dp), &
    d13 = nint(-3.6_dp), &
    d14 = floor(-3.6_dp)

real :: x, x2
real(dp) :: y, y2

x = 0.5
y = 0.5_dp
x2 = 3.6
y2 = 3.6_dp

print *, abs(-0.5), abs(-0.5_dp), s1, d1, abs(-x), abs(-y)
print *, exp(0.5), exp(0.5_dp), s2, d2, exp(x), exp(y)
print *, log(0.5), log(0.5_dp), s3, d3, log(x), log(y)
print *, erf(0.5), erf(0.5_dp), s4, d4, erf(x), erf(y)
print *, erfc(0.5), erfc(0.5_dp), s5, d5, erfc(x), erfc(y)
print *, sqrt(0.5), sqrt(0.5_dp), s6, d6, sqrt(x), sqrt(y)
print *, gamma(0.5), gamma(0.5_dp), s7, d7, gamma(x), gamma(y)
print *, atan2(0.5, 0.5), atan2(0.5_dp, 0.5_dp), s8, d8, atan2(x,x), atan2(y,y)
print *, log_gamma(0.5), log_gamma(0.5_dp), s9, d9, log_gamma(x), log_gamma(y)
print *, log10(0.5), log10(0.5_dp), s10, d10, log10(x), log10(y)
print *, nint(3.6), nint(3.6_dp), s11, d11, nint(x2), nint(y2)
print *, floor(3.6), floor(3.6_dp), s12, d12, floor(x2), floor(y2)
print *, nint(-3.6), nint(-3.6_dp), s13, d13, nint(-x2), nint(-y2)
print *, floor(-3.6), floor(-3.6_dp), s14, d14, floor(-x2), floor(-y2)

end


ELEMENTAL FUNCTION func_rising_factorial(x, n) result(ans)
    ! NOTE: See https://en.wikipedia.org/wiki/Falling_and_rising_factorials

    USE ISO_FORTRAN_ENV

    IMPLICIT NONE

    ! Declare inputs/outputs ...
    REAL(kind = REAL64)                                                         :: ans
    REAL(kind = REAL64), INTENT(in)                                             :: n
    REAL(kind = REAL64), INTENT(in)                                             :: x

    ! Set value ...
    ans = GAMMA(x + n) / GAMMA(x)
END FUNCTION func_rising_factorial


      real             function SCSHMM (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1994-10-20 SCSHMM Krogh  Changes to use M77CON
c>> 1993-05-07 SCSHMM WVSnyder JPL Initial code
c
c     Compute cosh(x) - 1 - x**2 using a rational approximation when
c     abs(x) is less than 2.7, else use the Fortran intrinsic function.
c
c--S replaces "?": ?CSHMM
      real             ZP3, ZP2, ZP1, ZQ4, ZQ3, ZQ2, ZQ1, X, XS
      parameter ( ZP3 = 5.59297116264720E-07 )
      parameter ( ZP2 = 1.77943488030894E-04 )
      parameter ( ZP1 = 1.69800461894792E-02 )
      parameter ( ZQ4 = 1.33412535492375E-09 * 24.0e0 )
      parameter ( ZQ3 = -5.80858944138663E-07 * 24.0e0 )
      parameter ( ZQ2 = 1.27814964403863E-04 * 24.0e0 )
      parameter ( ZQ1 = -1.63532871439181E-02 * 24.0e0 )
c     DATA ZP3/5.59297116264720E-07/,
c    *     ZP2/1.77943488030894E-04/,
c    *     ZP1/1.69800461894792E-02/,
c    *     ZQ4/1.33412535492375E-09/,
c    *     ZQ3/-5.80858944138663E-07/,
c    *     ZQ2/1.27814964403863E-04/,
c    *     ZQ1/-1.63532871439181E-02/
      xs = x * x
      if (xs .lt. 7.29e0) then
         scshmm = ((((zp3*xs+zp2)*xs+zp1)*xs+1.0e0)*xs*xs)/
     *            ((((zq4*xs+zq3)*xs+zq2)*xs+zq1)*xs+24.0e0)
      else
         scshmm = cosh(x) - 1.0e0 - 0.5e0*xs
      end if
      return
      end


module rationals_mod
    use, intrinsic :: iso_fortran_env
    implicit none

    private
    type, public :: rational
        private
        integer :: num = 1, denom = 1, sign = 1
    end type rational

    interface rational
        module procedure rat_create
    end interface rational

    interface operator(+)
        module procedure rat_add
    end interface

    interface operator(*)
        module procedure rat_mul, int_rat_mul
    end interface

    public :: rat_print, operator(+), operator(*)

contains

    type(rational) function rat_create(n, d)
        implicit none
        integer, value :: n, d
        integer :: n_act, d_act, g
        if (d == 0) then
            write (unit=error_unit, fmt='(A)') &
                "# error: denominator must be non-zero"
            stop
        end if
        if (n*d < 0) then
            rat_create%sign = -1
        else
            rat_create%sign = 1
        end if
        n = abs(n)
        d = abs(d)
        g = gcd(n, d)
        rat_create%num = n/g
        rat_create%denom = d/g
    end function rat_create

    type(rational) function rat_add(a, b)
        implicit none
        type(rational), intent(in) :: a, b
        rat_add = rat_create(a%sign*a%num*b%denom + b%sign*b%num*a%denom, &
                             a%denom*b%denom)
    end function rat_add

    type(rational) function rat_mul(a, b)
        implicit none
        type(rational), intent(in) :: a, b
        rat_mul = rat_create(a%sign*a%num*b%sign*b%num, a%denom*b%denom)
    end function rat_mul

    type(rational) function int_rat_mul(a, b)
        implicit none
        integer, intent(in) :: a
        type(rational), intent(in) :: b
        int_rat_mul = rat_create(a*b%sign*b%num, b%denom)
    end function int_rat_mul

    subroutine rat_print(a)
        implicit none
        type(rational), intent(in) :: a
        if (a%sign > 0) then
            write (*, "(I0, '/', I0)") a%num, a%denom
        else
            write (*, "('-', I0, '/', I0)") a%num, a%denom
        end if
    end subroutine rat_print

    integer function gcd(x, y)
        implicit none
        integer, value :: x, y
        x = abs(x)
        y = abs(y)
        do while (x /= y)
            if (x > y) then
                x = x - y
            else if (y > x) then
                y = y - x
            end if
        end do
        gcd = x
    end function gcd

end module rationals_mod


module plotter_functions
!USE Plotter
	implicit none
	contains
	!Здесь хранятся функции.
	function first_function(first_input) result (first_output)
		implicit none
		real, intent(in) :: first_input
		real :: first_output
		first_output=sin(first_input)
	end function first_function

	function second_function(second_input) result (second_output)
		implicit none
		real, intent(in) :: second_input
		real :: second_output
		second_output = cos(second_input)
	end function second_function

	function third_function(third_input) result(third_output)
		implicit none
		real,intent(in) :: third_input
		real :: third_output
		third_output=third_input
	end function third_function

	function fourth_function(fourth_input) result(fourth_output)
		implicit none
		real,intent(in) :: fourth_input
		real :: fourth_output
		fourth_output = fourth_input**2
	end function fourth_function

	function afourth_function(fourth_input) result(fourth_output)
		implicit none
		real,intent(in) :: fourth_input
		real :: fourth_output
		fourth_output = -fourth_input**2
	end function afourth_function

	function fifth_function(fifth_input) result (fifth_output)
		implicit none
		real, intent(in) :: fifth_input
		real :: fifth_output
		fifth_output=1/fifth_input
	end function fifth_function

	function first_surface(a,b) result(c)
		implicit none
		real,intent(in) :: a,b
		real :: c
		c = a*a+b*b
	end function first_surface

	function second_surface(a,b) result(c)
		implicit none
		real,intent(in) :: a,b
		real :: c
		c = (a*a-b*b)/4
	end function second_surface
end module plotter_functions


*
* Program quad - calculate the quadratic formula roots
*
* Written by - C. Severance 12Mar92
*
      REAL A,B,C,DET,ROOT1,ROOT2
*
      PRINT *,'Enter A,B,C -'
      READ *,A,B,C
*
      DET = SQRT( B*B - 4 * A * C )
      ROOT1 = ( -1.0*B + DET ) /  ( 2 * A )
      ROOT2 = ( -1.0*B - DET ) /  ( 2 * A )
*
      PRINT *,'ROOT1 = ',ROOT1
      PRINT *,'ROOT2 = ',ROOT2
*
      END


MODULE EIGEN

CONTAINS
    FUNCTION OUTER(A, B)
        IMPLICIT NONE

        REAL, DIMENSION(:)                :: A, B
        REAL, DIMENSION(SIZE(A), SIZE(B)) :: OUTER

        ! c_ij = a_i * b_j
        OUTER = SPREAD(A, DIM=2, NCOPIES=SIZE(B)) * SPREAD(B, DIM=1, NCOPIES=SIZE(A))
    END FUNCTION OUTER

    SUBROUTINE TRIDIAGONAL(A, B, C, X, R)
        IMPLICIT NONE

        REAL, DIMENSION(:), INTENT(IN)  :: A, B, C, R
        REAL, DIMENSION(:), INTENT(OUT) :: X

        REAL, DIMENSION(:), ALLOCATABLE :: beta
        INTEGER                         :: i, NSIZE

        ! initialization
        NSIZE = SIZE(B)
        ALLOCATE(beta(NSIZE))

        beta(1) = B(1)
        X(1)    = R(1)

        ! Forward elimination of x_i
        DO i = 2, NSIZE
            beta(i) = B(i) - A(i) * C(i-1) / beta(i-1)
            X(i)    = R(i) - A(i) * X(i-1) / beta(i-1)
        END DO

        ! Backward substitution
        X(NSIZE) = X(NSIZE) / beta(NSIZE)
        DO i = NSIZE - 1, 1, -1
            X(i) = (X(i) - C(i) * X(i+1)) / beta(i)
        END DO

        DEALLOCATE(beta)
    END SUBROUTINE TRIDIAGONAL

END MODULE EIGEN


program solve3x3
    implicit none
    real a(3,3),b(3),det,num,x1,x2,x3
    a(1,1)=6;a(1,2)=4;a(1,3)=-5;b(1)=9;
    a(2,1)=1;a(2,2)=-8;a(2,3)=2;b(2)=-3;
    a(3,1)=4;a(3,2)=1;a(3,3)=-10;b(3)=12;

    call determinant33(a(1,1),a(1,2),a(1,3),det)
    call determinant33(b,a(1,2),a(1,3),num)
    x1=num/det
    call determinant33(a(1,1),b,a(1,3),num)
    x2=num/det
    call determinant33(a(1,1),a(1,2),b,num)
    x3=num/det
    print *,'X1,X2,X3=',x1,x2,x3
end program solve3x3

subroutine determinant33(u,v,w,det)
    implicit none
    real :: u(3),v(3),w(3),det
    det=u(1)*v(2)*w(3)+u(2)*v(3)*w(1)+u(3)*v(1)*w(2) &
       -w(1)*v(2)*u(3)-w(2)*v(3)*u(1)-w(3)*v(1)*u(2)
end subroutine determinant33


module loglikelihood_module
    use utils_module, only: dp

    real(dp) :: normalisation

    ! Parameters of the rosenbrock function
    real(dp), parameter :: a = 1d0
    real(dp), parameter :: b = 1d2
    real(dp), parameter :: pi = 4d0*atan(1d0) ! \pi in double precision

    ! number of dimensions
    integer :: nDims

    contains

    !> Upside down [Rosenbrock function](http://en.wikipedia.org/wiki/Rosenbrock_function).
    !!
    !! \f[ -\log\mathcal{L}(\theta) = \sum_{i=1}^{N-1}   (a-\theta_i)^2+ b (\theta_{i+1} -\theta_i^2 )^2 \f]
    !!
    !! This is the industry standard 'Banana'. It is useful for testing whether the
    !! algorithm is capable of navigating a curving degenerate space and able to
    !! find the global maximum. As is conventional, we choose \f$a=1\f$ and
    !! \f$b=100\f$
    !!
    !! It is only valid in nDims>2.
    !!
    !! To be precise, we choose our log likelihood as the negative of the 'true'
    !! Rosenbrock function, as our algorithm is a maximiser.
    !!
    !! In addition, we add an offset to normalise the loglikelihood so that in
    !! 2D it should integrate to 1. (There is no analytic formula for ND).
    !!
    !! The global maximum is atop a long, narrow, parabolic shaped ridge.
    !!
    !! dimension | extrema
    !! ----------|------
    !! \f$ 2 \f$ | One maximum at \f$(1,1)\f$
    !! \f$ 3 \f$ | One maximum at \f$(1,1,1)\f$
    !! \f$4-7\f$ | One global maximum at \f$(1,\ldots,1)\f$, one local near \f$(-1,1,\ldots,1)\f$
    !!
    !! \f$(1,\ldots,1)\f$ is always the
    !! global maximum, but it is unclear analytically how many (if any) local maxima there
    !! are elsewhere in dimensions higher than 7.
    !!
    function loglikelihood(theta,phi)
        implicit none
        real(dp), intent(in),  dimension(:) :: theta         !> Input parameters
        real(dp), intent(out), dimension(:) :: phi           !> Output derived parameters
        real(dp)                            :: loglikelihood ! loglikelihood value to output

        ! Normalisation for 2D
        loglikelihood = normalisation

        ! Sum expressed with fortran intrinsics
        loglikelihood =  loglikelihood  - sum( (a-theta(1:nDims-1))**2 + b*(theta(2:nDims) - theta(1:nDims-1)**2)**2 )

    end function loglikelihood

    subroutine setup_loglikelihood(settings)
        use settings_module,   only: program_settings
        implicit none
        type(program_settings), intent(in) :: settings

        ! Get the number of dimensions from the settings variable
        nDims = settings%nDims

        !
        normalisation = -0.5d0 * log( pi**nDims / det(nDims) )

    end subroutine setup_loglikelihood

    function det(n)
        integer,intent(in) :: n
        real(dp)   :: det

        det = abs(-2d0*b*recur(n-1) - 16*b*b*recur(n-2))

    end function

    recursive function recur(n) result(ans)
        integer,intent(in) :: n
        real(dp)   :: ans

        if(n<=0) then
            ans = 0d0
            return
        else if(n==1) then
            ans = 1d0
            return
        else
            ans = (-2d0-10d0*b) * recur(n-1) - 16d0*b*b * recur(n-2)
        end if

    end function recur

end module loglikelihood_module


module loglikelihood_module
    use utils_module, only: dp

    contains

    !> Twin gaussian peaks likelihood with mean mu(:) and an uncorrelated covariance sigma(:).
    !!
    !! It is normalised so that it should output an evidence of 1.0 for
    !! effectively infinite priors.
    !!
    !! The mean is set at 0.5 by default, apart from the x and y directions, where
    !! they are separated by 20sqrt(2) sigma widths and all sigmas at 0.01

    function loglikelihood(theta,phi)
        use utils_module, only: logaddexp,logTwoPi
        implicit none
        real(dp), intent(in),  dimension(:) :: theta         !> Input parameters
        real(dp), intent(out), dimension(:) :: phi           !> Output derived parameters
        real(dp)                            :: loglikelihood ! loglikelihood value to output

        real(dp) :: loglikelihood1
        real(dp) :: loglikelihood2

        real(dp), dimension(size(theta)) :: sigma ! Standard deviation (uncorrelated)
        real(dp), dimension(size(theta)) :: mu1   ! Mean
        real(dp), dimension(size(theta)) :: mu2   ! Mean

        ! Initialise the mean and standard deviation
        sigma  = 1d-1 ! all sigma set relatively small
        mu1    = 0d0  ! mean in the center
        mu1(1) = -5d-1
        mu1(2) = -5d-1
        mu2    = 0d0  ! mean in the center
        mu2(1) = +5d-1
        mu2(2) = +5d-1

        ! Gaussian normalisation
        loglikelihood1 = - sum( log( sigma ) + logTwoPi/2d0 )
        loglikelihood2 = loglikelihood1

        ! theta dependence
        loglikelihood1 = loglikelihood1 - sum( ( ( theta - mu1 ) / sigma ) ** 2d0 ) / 2d0
        loglikelihood2 = loglikelihood2 - sum( ( ( theta - mu2 ) / sigma ) ** 2d0 ) / 2d0

        loglikelihood = logaddexp(loglikelihood1,loglikelihood2) - log(2d0)

        ! One derived parameter, which is +1 if its in the right hand cluster,
        ! or -1 if its in the left hand cluster
        if(theta(1) >0.5d0) then
            phi(1)=1d0
        else
            phi(1)=-1d0
        end if

    end function loglikelihood

    subroutine setup_loglikelihood(settings)
        use settings_module,   only: program_settings
        implicit none
        type(program_settings), intent(in) :: settings

    end subroutine setup_loglikelihood

end module loglikelihood_module


!----------------------------------------------------------
!                           TRIAL FUNCTION
!----------------------------------------------------------
subroutine calbvec( l,theta,phi,plm,bvec )
!----------------------------------------------------------
! Evaluating the value of toroidal harmonics (fully normalized)
! at each station whose latitude and longitude are theta and phi.
!----------------------------------------------------------
    use parameters
    implicit none
    integer,intent(in):: l
    integer:: m,i
    double precision:: theta,phi,x,plm(3,0:3),fact,coef
    complex(dp):: bvec(3,-2:2),expimp

    x = dcos( theta )
    do m=0,min0(l,3)
        call calplm( l,m,x,plm(1,m) )
    enddo
    do m=0,min0(l,2)
        fact = 1
        if ( m/=0 ) then
            do i=l-m+1,l+m
                fact = fact * dble(i)
            enddo
        endif
        coef = dsqrt( (2*l+1)/(4.d0*pi) / fact )
        expimp = cdexp( dcmplx( 0, m*phi ) )
        bvec(1,m)  = coef * plm(1,m) * expimp
        bvec(1,-m) = dconjg( bvec(1,m) )
        bvec(2,m) = coef *( m*x / dsin( theta ) * plm(1,m) + plm(1,m+1) ) * expimp
        bvec(2,-m) = dconjg( bvec(2,m) )
        bvec(3,m)  = dcmplx( 0, m ) / dsin( theta ) * coef * plm(1,m) * expimp
        bvec(3,-m) = dconjg( bvec(3,m) )
        if ( mod(m,2)==1 ) bvec(1:3,-m) = - bvec(1:3,-m)
    enddo
    return
end

!----------------------------------------------------------
subroutine calplm( l,m,x,plm )
!----------------------------------------------------------
    implicit none
    integer:: l,m,i
    double precision:: x,plm(3),pmm,somx2,fact

    if ( m<0 .or. m>l .or. dabs(x)>1.d0 ) stop 'bad arguments'
    if ( l==m ) then
        pmm = 1
        if ( m>0 ) then
            somx2 = dsqrt( (1.d0-x)*(1.d0+x) )
            fact = 1
            do i=1,m
                pmm = -pmm * fact * somx2
                fact = fact + 2
            enddo
        endif
        plm(2:3) = 0
        plm(1) = pmm
    else
        plm(3) = plm(2)
        plm(2) = plm(1)
        if ( l==m+1 ) then
            plm(1) = x * (2*m+1) * plm(2)
        else
            plm(1) = ( x * (2*l-1) * plm(2) - (l+m-1) * plm(3) ) / (l-m)
        endif
    endif
    return
end


module spline_dlg

contains

! See Burden and Faires pg 133.
!
! NOTE: allocate the "spline" variable prior to
!   function call. Does not work otherwise. Not
!   sure as to the cause, perhaps compiler bug?

function spline ( x, a, fp0, fpn )

    implicit none

    real, intent(in) :: x(:), a(:), fp0, fpn
    real, allocatable :: spline(:,:)

    integer :: n, i
    real, allocatable :: b(:), c(:), d(:), h(:), alpha(:)
    real, allocatable :: u(:), l(:), z(:)

    n = size ( x ) - 1

    allocate ( b(n+1),c(n+1),d(n+1),h(n), alpha(n+1) )
    if(.not.allocated(spline)) allocate ( spline(n+1,4) )
    allocate ( u(n+1), l(n+1), z(n+1) )

    do i=1,n
       h(i) = x(i+1)-x(i)
    enddo

    alpha(1) = 3 * ( a(2)-a(1) ) / h(1) - 3 * fp0
    alpha(n+1) = 3 * fpn - 3 * ( a(n+1)-a(n) ) / h(n)

    do i=2,n
        alpha(i) = &
            3 * (a(i+1)*h(i-1) - a(i) * ( x(i+1)-x(i-1) ) + a(i-1)*h(i) ) &
                / (h(i-1)*h(i))
    enddo

    l(1) = 2 * h(1)
    u(1) = 0.5
    z(1) = alpha(1) / l(1)

    do i=2,n
        l(i) = 2 * ( x(i+1)-x(i-1) ) - h(i-1)*u(i-1)
        u(i) = h(i) / l(i)
        z(i) = ( alpha(i) - h(i-1)*z(i-1) ) / l(i)
    enddo

    l(n+1) = h(n) * ( 2-u(n) )
    z(n+1) = ( alpha(n+1)-h(n)*z(n) ) / l(n+1)

    c(n+1) = z(n+1)

    do i=n,1,-1

        c(i) = z(i) - u(i)*c(i+1)
        b(i) = (a(i+1)-a(i))/h(i) - h(i)*(c(i+1)+2*c(i))/3
        d(i) = (c(i+1)-c(i))/(3*h(i))

    enddo

    spline(:,1) = a
    spline(:,2) = b
    spline(:,3) = c
    spline(:,4) = d

end function spline

end module spline_dlg


MODULE constants
IMPLICIT NONE
REAL, PARAMETER :: E = 2.71828
END MODULE constants

COMPLEX FUNCTION euler(theta)
USE constants
IMPLICIT NONE
REAL, INTENT(IN) :: theta
euler = COS(theta) + CMPLX(0.,1.) * SIN(theta)
END FUNCTION euler

PROGRAM test_euler
USE constants
IMPLICIT NONE
REAL :: theta
COMPLEX :: euler
WRITE(*, *) "Enter a value for theta: "
READ(*, *) theta
WRITE(*, 100) "euler(", theta, ")     =", euler(theta)
WRITE(*, 100) "CEXP(e^i *", theta, ") =", CEXP(CMPLX(0,1.) * theta)
100 FORMAT (A,F8.5,A,"(",F16.12,", ",F16.12,")")
END PROGRAM test_euler


! ==================================================================================================================================
! NAME
!
!     rot [ rot ] - Rotation Module
!
! SYNOPSIS
!
!     USE :: ROT
!
! DESCRIPTION
!
!     ROT is a custom Fortran module written to compute the elemental rotation matrices of a Cartesian coordinate system.
!
! OPTIONS
!
! SEE ALSO
!
! BUGS
!
! HISTORY
!
! AUTHOR
!
!     Marty Kandes, Ph.D.
!     Computational & Data Science Research Specialist
!     High-Performance Computing User Services Group
!     San Diego Supercomputer Center
!     University of California, San Diego
!
! COPYRIGHT
!
!     Copyright (c) 2014, 2015, 2016, 2017, 2018, 2019, 2020 Martin Charles Kandes
!
! LAST UPDATED
!
!     Tuesday, April 2nd, 2019
!
! ----------------------------------------------------------------------------------------------------------------------------------

      MODULE rot

! --- MODULE DECLARATIONS ----------------------------------------------------------------------------------------------------------

      USE, INTRINSIC :: ISO_FORTRAN_ENV

! --- MODULE DEFINITIONS -----------------------------------------------------------------------------------------------------------
!
!     ISO_FORTRAN_ENV is the intrinsic Fortran module that provides information about the run-time environment.
!
! ----------------------------------------------------------------------------------------------------------------------------------

      IMPLICIT NONE
      PRIVATE

! --- VARIABLE DECLARATIONS --------------------------------------------------------------------------------------------------------

      REAL, PUBLIC :: thetaX
      REAL, PUBLIC :: thetaY
      REAL, PUBLIC :: thetaZ

! --- VARIABLE DEFINITIONS ---------------------------------------------------------------------------------------------------------
!
!     thetaX is a PUBLIC, REAL-valued variable that stores the rotation angle about the x-axis.
!
!     thetaY is a PUBLIC, REAL-valued variable that stores the rotation angle about the y-axis.
!
!     thetaZ is a PUBLIC, REAL-valued variable that stores the rotation angle about the z-axis.
!
! --- ARRAY DECLARATIONS -----------------------------------------------------------------------------------------------------------

      REAL, DIMENSION ( 3 , 3 ), PUBLIC :: R

! --- ARRAY DEFINITIONS ------------------------------------------------------------------------------------------------------------
!
!     R is a PUBLIC, REAL-valued rank-two array that stores the 3-by-3 rotation matrix.
!
! --- FUNCTION DECLARATIONS --------------------------------------------------------------------------------------------------------

      PUBLIC :: rot_rx
      PUBLIC :: rot_ry
      PUBLIC :: rot_rz

! --- FUNCTION DEFINITIONS ---------------------------------------------------------------------------------------------------------
!
!     rot_rx is a PUBLIC FUNCTION that computes the elemental rotation matrix about the x-axis of a Cartesian coordinate system.
!
!     rot_ry is a PUBLIC FUNCTION that computes the elemental rotation matrix about the y-axis of a Cartesian coordinate system.
!
!     rot_rz is a PUBLIC FUNCTION that computes the elemental rotation matrix about the z-axis of a Cartesian coordinate system.
!
! ----------------------------------------------------------------------------------------------------------------------------------

      CONTAINS

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

      FUNCTION rot_rx ( theta )

      IMPLICIT NONE

      REAL, INTENT ( IN ) :: theta

      REAL, DIMENSION ( 3 , 3 ) :: rot_rx

      rot_rx ( 1 , 1 ) = 1.0
      rot_rx ( 2 , 1 ) = 0.0
      rot_rx ( 3 , 1 ) = 0.0
      rot_rx ( 1 , 2 ) = 0.0
      rot_rx ( 2 , 2 ) = COS ( theta )
      rot_rx ( 3 , 2 ) = SIN ( theta )
      rot_rx ( 1 , 3 ) = 0.0
      rot_rx ( 2 , 3 ) = -SIN ( theta )
      rot_rx ( 3 , 3 ) = COS ( theta )

      RETURN

      END FUNCTION

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

      FUNCTION rot_ry ( theta )

      IMPLICIT NONE

      REAL, INTENT ( IN ) :: theta

      REAL, DIMENSION ( 3, 3 ) :: rot_ry

      rot_ry ( 1 , 1 ) = COS ( theta )
      rot_ry ( 2 , 1 ) = 0.0
      rot_ry ( 3 , 1 ) = -SIN ( theta )
      rot_ry ( 1 , 2 ) = 0.0
      rot_ry ( 2 , 2 ) = 1.0
      rot_ry ( 3 , 2 ) = 0.0
      rot_ry ( 1 , 3 ) = SIN ( theta )
      rot_ry ( 2 , 3 ) = 0.0
      rot_ry ( 3 , 3 ) = COS ( theta )

      RETURN

      END FUNCTION

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

      FUNCTION rot_rz ( theta )

      IMPLICIT NONE

      REAL, INTENT ( IN ) :: theta

      REAL, DIMENSION ( 3 , 3 ) :: rot_rz

      rot_rz ( 1 , 1 ) = COS ( theta )
      rot_rz ( 2 , 1 ) = SIN ( theta )
      rot_rz ( 3 , 1 ) = 0.0
      rot_rz ( 1 , 2 ) = -SIN ( theta )
      rot_rz ( 2 , 2 ) = COS ( theta )
      rot_rz ( 3 , 2 ) = 0.0
      rot_rz ( 1 , 3 ) = 0.0
      rot_rz ( 2 , 3 ) = 0.0
      rot_rz ( 3 , 3 ) = 1.0

      RETURN

      END FUNCTION

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

      END MODULE

! ==================================================================================================================================