! Copyright (c) 2017, Lehrstuhl fuer Angewandte Mechanik, Technische
! Universitaet Muenchen.
!
! Distributed under BSD-3-Clause License. See LICENSE-File for more information
!

subroutine scatter_matrix(A, B, ndim, n, m)
    implicit none
    integer, intent(in) :: n, m, ndim
    real(8), intent(in) :: A(m, n)
    real(8), intent(out) :: B(ndim*m, ndim*n)
    integer i, j, k

!    Initialization to zero; otherwise random stuff is there...
    B(:,:) = 0.0
! looping style like in Python:
    do i=0,m-1
        do j=0,n-1
            do k=0,ndim-1
                B(ndim*i+k+1,ndim*j+k+1) = A(i+1,j+1)
            end do
        end do
    end do

end subroutine

subroutine compute_B_matrix(Bt, F, B, no_of_nodes, no_of_dims)
    implicit none

    integer, intent(in)  :: no_of_nodes, no_of_dims
    real(8), intent(in)  :: F(no_of_dims,no_of_dims), Bt(no_of_nodes, no_of_dims)
    real(8), intent(out) :: B(no_of_dims*(no_of_dims + 1)/2, no_of_nodes*no_of_dims)
    integer :: i

    if (no_of_dims.eq.2) then
!        here the counting starts at 1 in order to make indexing for Bt easier
        do i=1,no_of_nodes
            B(:,(i-1)*2+1)   = (/ F(1,1)*Bt(i,1), F(1,2)*Bt(i,2), F(1,1)*Bt(i,2) + F(1,2)*Bt(i,1) /)
            B(:,(i-1)*2+2) = (/ F(2,1)*Bt(i,1), F(2,2)*Bt(i,2), F(2,1)*Bt(i,2) + F(2,2)*Bt(i,1) /)
        end do
    elseif (no_of_dims.eq.3) then
        do i=1,no_of_nodes
            B(:,(i-1)*3+1) = (/ F(1,1)*Bt(i,1), F(1,2)*Bt(i,2), F(1,3)*Bt(i,3), &
               F(1,2)*Bt(i,3) + F(1,3)*Bt(i,2), F(1,3)*Bt(i,1) + F(1,1)*Bt(i,3), F(1,1)*Bt(i,2) + F(1,2)*Bt(i,1) /)
            B(:,(i-1)*3+2) = (/ F(2,1)*Bt(i,1), F(2,2)*Bt(i,2), F(2,3)*Bt(i,3), &
               F(2,2)*Bt(i,3) + F(2,3)*Bt(i,2), F(2,3)*Bt(i,1) + F(2,1)*Bt(i,3), F(2,1)*Bt(i,2) + F(2,2)*Bt(i,1) /)
            B(:,(i-1)*3+3) = (/ F(3,1)*Bt(i,1), F(3,2)*Bt(i,2), F(3,3)*Bt(i,3), &
               F(3,2)*Bt(i,3) + F(3,3)*Bt(i,2), F(3,3)*Bt(i,1) + F(3,1)*Bt(i,3), F(3,1)*Bt(i,2) + F(3,2)*Bt(i,1) /)
        end do
    else
        B = B*0
    endif

end subroutine

subroutine invert_3_by_3_matrix(A, A_inv, det)
    ! Invert the matrix A and compute the determinant
    implicit none

    real(8), intent(in) :: A(3,3)
    real(8), intent(out) :: A_inv(3,3), det
    real(8) :: a11, a12, a13, a21, a22, a23, a31, a32, a33
    a11 = A(1,1)
    a12 = A(1,2)
    a13 = A(1,3)
    a21 = A(2,1)
    a22 = A(2,2)
    a23 = A(2,3)
    a31 = A(3,1)
    a32 = A(3,2)
    a33 = A(3,3)
    det = a11*a22*a33 - a11*a23*a32 - a12*a21*a33 + a12*a23*a31 + a13*a21*a32 - a13*a22*a31
    A_inv = reshape((/ a22*a33 - a23*a32, -a21*a33 + a23*a31, &
                       a21*a32 - a22*a31, -a12*a33 + a13*a32, &
                       a11*a33 - a13*a31, -a11*a32 + a12*a31, &
                       a12*a23 - a13*a22, -a11*a23 + a13*a21, &
                       a11*a22 - a12*a21 /), (/3,3/)) / det
end subroutine

subroutine tri3_k_f_s_e(X, u, K, f_int, t, S_exp, E_exp, S_Sv_and_C_2d)
    implicit none

!   What is important here is that the
    real(8), intent(in) :: X(6), u(6), t
    real(8), intent(out) :: K(6, 6), f_int(6), S_exp(3, 6), E_exp(3, 6)
    real(8) :: X1, X2, X3, Y1, Y2, Y3, A0
    real(8) :: u_e(3,2), C_SE(3,3)
    real(8) :: K_geo_sm(3,3), K_mat(6,6), K_geo(6,6)
    real(8) :: B0_tilde(3,2),  B0(3,6)
    real(8) :: E(2,2), H(2,2), F(2,2), EYE(2,2), S(2,2), S_v(3)
    real(8) :: extrapol(3,1)
!   External functions that will be used afterwards
    external :: scatter_matrix
    external :: compute_b_matrix
    external :: S_Sv_and_C

!   The variables for calculation

    X1 = X(1)
    Y1 = X(2)
    X2 = X(3)
    Y2 = X(4)
    X3 = X(5)
    Y3 = X(6)

    u_e = transpose(reshape(u, (/2, 3/)))
    extrapol = reshape( (/ 1.0D0, 1.0D0, 1.0D0 /) , (/3, 1/))

    A0 = 0.5*((X3-X2)*(Y1-Y2) - (X1-X2)*(Y3-Y2))

    EYE = reshape((/1, 0, 0, 1/), shape(EYE))

    B0_tilde(1,1) = (Y2-Y3) / (2*A0)
    B0_tilde(2,1) = (Y3-Y1) / (2*A0)
    B0_tilde(3,1) = (Y1-Y2) / (2*A0)
    B0_tilde(1,2) = (X3-X2) / (2*A0)
    B0_tilde(2,2) = (X1-X3) / (2*A0)
    B0_tilde(3,2) = (X2-X1) / (2*A0)

!    The standard procedure for doing Total Lagrangian
!   computing the 'help' matrix H
    H = matmul(transpose(u_e), B0_tilde)
!     The deformation gradient F
    F = H + EYE
!     The Green-Lagrange-Strain tensor
    E = 0.5*(H + transpose(H) + matmul(transpose(H), H))
!     Compute the stress and the tangent moduli via external call
    call S_Sv_and_C_2d(E, S, S_v, C_SE)
!     The variational matrix B0
    call compute_b_matrix(B0_tilde, F, B0, 3, 2)
!     The material stiffness
    K_mat = matmul(transpose(B0), matmul(C_SE, B0))*A0*t
!     And the geometric stiffness
    K_geo_sm = matmul(B0_tilde, matmul(S, transpose(B0_tilde)))*A0*t
    call scatter_matrix(K_geo_sm, K_geo, 2, 3, 3)
    K = K_mat + K_geo
!     and last but not least the internal force
    f_int = matmul(transpose(B0), S_v)*A0*t
    S_exp = matmul(extrapol, reshape((/S(1,1), S(1,2), 0.0D0, S(2,2), 0.0D0, 0.0D0/), (/1, 6/)))
    E_exp = matmul(extrapol, reshape((/ E(1,1), E(1,2), 0.0D0, E(2,2), 0.0D0, 0.0D0/), (/1, 6/)))

end subroutine tri3_k_f_s_e

subroutine tri6_k_f_s_e(X, u, K, f_int, t, S_exp, E_exp, S_Sv_and_C_2d)
    implicit none

    integer :: i
    real(8), intent(in) :: X(12), u(12), t
    real(8), intent(out) :: K(12, 12), f_int(12), S_exp(6,6), E_exp(6,6)
    real(8) :: X1, X2, X3, Y1, Y2, Y3, X4, Y4, X5, Y5, X6, Y6, A0
    real(8) :: Jx1 ,Jx2 ,Jx3 ,Jy1 ,Jy2 ,Jy3, w
    real(8) :: u_e(6,2), C_SE(3,3)
    real(8) :: K_geo_sm(6,6), K_mat(12,12), K_geo(12,12)
    real(8) :: B0_tilde(6,2), B0(3,12)
    real(8) :: E(2,2), H(2,2), F(2,2), EYE(2,2), S(2,2), S_v(3)

    real(8) :: gauss_points(3,3), weights(3), extrapol(6,3)
!    real(8) :: w0, w1, w2, alpha1, alpha2, beta1, beta2
    real(8) :: L1, L2, L3, det

!   External functions that will be used afterwards
    external :: scatter_matrix
    external :: compute_b_matrix
    external :: S_Sv_and_C_2d

    X1 = X(1)
    Y1 = X(2)
    X2 = X(3)
    Y2 = X(4)
    X3 = X(5)
    Y3 = X(6)
    X4 = X(7)
    Y4 = X(8)
    X5 = X(9)
    Y5 = X(10)
    X6 = X(11)
    Y6 = X(12)

    ! take care of the fortran matrix order (columns first!):
    u_e = transpose(reshape(u, (/2, 6/)))
    extrapol(:,1) = (/ 5/3.0D0, -1/3.0D0, -1/3.0D0, 2/3.0D0, -1/3.0D0, 2/3.0D0 /)
    extrapol(:,2) = (/-1/3.0D0, 5/3.0D0, -1/3.0D0, 2/3.0D0, 2/3.0D0, -1/3.0D0 /)
    extrapol(:,3) = (/ -1/3.0D0, -1/3.0D0, 5/3.0D0, -1/3.0D0, 2/3.0D0, 2/3.0D0 /)

!    ! take care of a precise description of 1/3 in order to avoid errors!
!    w0 = 0.225D0
!
!    alpha1 = 0.0597158717D0
!    beta1 = 0.4701420641D0
!    w1 = 0.1323941527D0
!
!    alpha2 = 0.7974269853D0
!    beta2 = 0.1012865073D0
!    w2 = 0.1259391805D0
!
!    weights = (/ w0, w1, w1, w1, w2, w2, w2 /)
!    gauss_points(1,:) = (/ 1/3.0D0, 1/3.0D0, 1/3.0D0 /)
!    gauss_points(2,:) = (/ alpha1, beta1, beta1 /)
!    gauss_points(3,:) = (/ beta1, alpha1, beta1 /)
!    gauss_points(4,:) = (/ beta1, beta1, alpha1 /)
!    gauss_points(5,:) = (/ alpha2, beta2, beta2 /)
!    gauss_points(6,:) = (/ beta2, alpha2, beta2 /)
!    gauss_points(7,:) = (/ beta2, beta2, alpha2 /)

    weights = (/ 1/3.0D0, 1/3.0D0, 1/3.0D0 /)
    gauss_points(1,:) = (/ 2/3.0D0, 1/6.0D0, 1/6.0D0 /)
    gauss_points(2,:) = (/ 1/6.0D0, 2/3.0D0, 1/6.0D0 /)
    gauss_points(3,:) = (/ 1/6.0D0, 1/6.0D0, 2/3.0D0 /)

    EYE = reshape((/1, 0, 0, 1/), shape(EYE))

    K = 0.0
    f_int = 0.0
    S_exp = 0.0
    E_exp = 0.0

    ! loop over all quadrature points
    do i=1,3
       L1 = gauss_points(i, 1)
       L2 = gauss_points(i, 2)
       L3 = gauss_points(i, 3)
       w  = weights(i)

       ! the entries in the jacobian dX_dL
       Jx1 = 4*L2*X4 + 4*L3*X6 + X1*(4*L1 - 1)
       Jx2 = 4*L1*X4 + 4*L3*X5 + X2*(4*L2 - 1)
       Jx3 = 4*L1*X6 + 4*L2*X5 + X3*(4*L3 - 1)
       Jy1 = 4*L2*Y4 + 4*L3*Y6 + Y1*(4*L1 - 1)
       Jy2 = 4*L1*Y4 + 4*L3*Y5 + Y2*(4*L2 - 1)
       Jy3 = 4*L1*Y6 + 4*L2*Y5 + Y3*(4*L3 - 1)

       det = Jx1*Jy2 - Jx1*Jy3 - Jx2*Jy1 + Jx2*Jy3 + Jx3*Jy1 - Jx3*Jy2
       A0 = det/2

       B0_tilde(:,1) = (/            (Jy2 - Jy3)*(4*L1 - 1), &
                                    (-Jy1 + Jy3)*(4*L2 - 1), &
                                     (Jy1 - Jy2)*(4*L3 - 1), &
                       4*L1*(-Jy1 + Jy3) + 4*L2*(Jy2 - Jy3), &
                       4*L2*(Jy1 - Jy2) + 4*L3*(-Jy1 + Jy3), &
                        4*L1*(Jy1 - Jy2) + 4*L3*(Jy2 - Jy3) /)

       B0_tilde(:,2) = (/           (-Jx2 + Jx3)*(4*L1 - 1), &
                                     (Jx1 - Jx3)*(4*L2 - 1), &
                                    (-Jx1 + Jx2)*(4*L3 - 1), &
                       4*L1*(Jx1 - Jx3) + 4*L2*(-Jx2 + Jx3), &
                       4*L2*(-Jx1 + Jx2) + 4*L3*(Jx1 - Jx3), &
                      4*L1*(-Jx1 + Jx2) + 4*L3*(-Jx2 + Jx3) /)

       B0_tilde = B0_tilde/det

       H = matmul(transpose(u_e), B0_tilde)
       F = H + EYE
       E = 0.5*(H + transpose(H) + matmul(transpose(H), H))

       call S_Sv_and_C_2d(E, S, S_v, C_SE)

       call compute_b_matrix(B0_tilde, F, B0, 6, 2)

       K_mat = matmul(transpose(B0), matmul(C_SE, B0)) * A0 * t
       K_geo_sm = matmul(B0_tilde, matmul(S, transpose(B0_tilde))) * A0 * t

       call scatter_matrix(K_geo_sm, K_geo, 2, 6, 6)

       K = K + w*(K_mat + K_geo)
       f_int = f_int + w*matmul(transpose(B0), S_v)*A0*t

       S_exp = S_exp + matmul(reshape(extrapol(:,i), (/6,1/)), &
                reshape((/S(1,1), S(1,2), 0.0D0, S(2,2), 0.0D0, 0.0D0/), (/1, 6/)))
       E_exp = E_exp + matmul(reshape(extrapol(:,i), (/6,1/)), &
                reshape((/ E(1,1), E(1,2), 0.0D0, E(2,2), 0.0D0, 0.0D0/), (/1, 6/)))

    end do
end subroutine tri6_k_f_s_e

subroutine tri6_m(X, rho, t, M)
    implicit none

    integer :: i
    real(8), intent(in) :: X(12), t, rho
    real(8), intent(out) :: M(12,12)
    real(8) :: X1, X2, X3, Y1, Y2, Y3, X4, Y4, X5, Y5, X6, Y6
    real(8) :: Jx1 ,Jx2 ,Jx3 ,Jy1 ,Jy2 ,Jy3, w
    real(8) :: N(6,1), M_small(6,6)

    real(8) :: gauss_points(3,3), weights(3)
!    real(8) :: w0, w1, w2, alpha1, alpha2, beta1, beta2
    real(8) :: L1, L2, L3, det

!   External functions that will be used afterwards
    external :: scatter_matrix

!    ! take care of a precise description of 1/3 in order to avoid errors!
!    w0 = 0.225D0
!
!    alpha1 = 0.0597158717D0
!    beta1 = 0.4701420641D0
!    w1 = 0.1323941527D0
!
!    alpha2 = 0.7974269853D0
!    beta2 = 0.1012865073D0
!    w2 = 0.1259391805D0
!
!    weights = (/ w0, w1, w1, w1, w2, w2, w2 /)
!    gauss_points(1,:) = (/ 1/3.0D0, 1/3.0D0, 1/3.0D0 /)
!    gauss_points(2,:) = (/ alpha1, beta1, beta1 /)
!    gauss_points(3,:) = (/ beta1, alpha1, beta1 /)
!    gauss_points(4,:) = (/ beta1, beta1, alpha1 /)
!    gauss_points(5,:) = (/ alpha2, beta2, beta2 /)
!    gauss_points(6,:) = (/ beta2, alpha2, beta2 /)
!    gauss_points(7,:) = (/ beta2, beta2, alpha2 /)

    weights = (/ 1/3.0D0, 1/3.0D0, 1/3.0D0 /)
    gauss_points(1,:) = (/ 1/6.0D0, 1/6.0D0, 2/3.0D0 /)
    gauss_points(2,:) = (/ 1/6.0D0, 2/3.0D0, 1/6.0D0 /)
    gauss_points(3,:) = (/ 2/3.0D0, 1/6.0D0, 1/6.0D0 /)

    X1 = X(1)
    Y1 = X(2)
    X2 = X(3)
    Y2 = X(4)
    X3 = X(5)
    Y3 = X(6)
    X4 = X(7)
    Y4 = X(8)
    X5 = X(9)
    Y5 = X(10)
    X6 = X(11)
    Y6 = X(12)

    M_small = 0.0
    M = 0.0

    do i=1,3
       L1 = gauss_points(i, 1)
       L2 = gauss_points(i, 2)
       L3 = gauss_points(i, 3)
       w  = weights(i)

       Jx1 = 4*L2*X4 + 4*L3*X6 + X1*(4*L1 - 1)
       Jx2 = 4*L1*X4 + 4*L3*X5 + X2*(4*L2 - 1)
       Jx3 = 4*L1*X6 + 4*L2*X5 + X3*(4*L3 - 1)
       Jy1 = 4*L2*Y4 + 4*L3*Y6 + Y1*(4*L1 - 1)
       Jy2 = 4*L1*Y4 + 4*L3*Y5 + Y2*(4*L2 - 1)
       Jy3 = 4*L1*Y6 + 4*L2*Y5 + Y3*(4*L3 - 1)

       det = Jx1*Jy2 - Jx1*Jy3 - Jx2*Jy1 + Jx2*Jy3 + Jx3*Jy1 - Jx3*Jy2

       N(:,1) = (/ L1*(2*L1 - 1), L2*(2*L2 - 1), L3*(2*L3 - 1), 4*L1*L2, 4*L2*L3, 4*L1*L3 /)
       M_small = M_small + matmul(N, transpose(N)) * det/2 * rho * t * w
    end do

    call scatter_matrix(M_small, M, 2, 6, 6)

end subroutine

subroutine tet4_k_f_s_e(X, u, K, f_int, S_exp, E_exp, S_Sv_and_C)
    implicit none

    real(8), intent(in) :: X(12), u(12)
    real(8), intent(out) :: K(12, 12), f_int(12), S_exp(4,6), E_exp(4,6)
    real(8) :: X1, Y1, Z1, X2, Y2, Z2, X3, Y3, Z3, X4, Y4, Z4
    real(8) :: u_e(4,3), C_SE(6,6)
    real(8) :: K_geo_sm(4,4), K_mat(12,12), K_geo(12,12)
    real(8) :: B0_tilde(4,3), B0(6,12)
    real(8) :: E(3,3), H(3,3), F(3,3), EYE(3,3), S(3,3), S_v(6)
    real(8) :: det, extrapol(4,1)

!   External functions that will be used afterwards
    external :: scatter_matrix
    external :: compute_b_matrix
    external :: S_Sv_and_C

    X1 = X(1)
    Y1 = X(2)
    Z1 = X(3)
    X2 = X(4)
    Y2 = X(5)
    Z2 = X(6)
    X3 = X(7)
    Y3 = X(8)
    Z3 = X(9)
    X4 = X(10)
    Y4 = X(11)
    Z4 = X(12)

    EYE = 0.0D0
    EYE(1,1) = 1
    EYE(2,2) = 1
    EYE(3,3) = 1
    extrapol = 1.0
    S_exp = 0.0
    E_exp = 0.0

    u_e = transpose(reshape(u, (/ 3, 4 /)))
    det = -X1*Y2*Z3 + X1*Y2*Z4 + X1*Y3*Z2 - X1*Y3*Z4 - X1*Y4*Z2 + X1*Y4*Z3 &
         + X2*Y1*Z3 - X2*Y1*Z4 - X2*Y3*Z1 + X2*Y3*Z4 + X2*Y4*Z1 - X2*Y4*Z3 &
         - X3*Y1*Z2 + X3*Y1*Z4 + X3*Y2*Z1 - X3*Y2*Z4 - X3*Y4*Z1 + X3*Y4*Z2 &
         + X4*Y1*Z2 - X4*Y1*Z3 - X4*Y2*Z1 + X4*Y2*Z3 + X4*Y3*Z1 - X4*Y3*Z2

    B0_tilde(1,:) = (/ -Y2*Z3 + Y2*Z4 + Y3*Z2 - Y3*Z4 - Y4*Z2 + Y4*Z3, &
                        X2*Z3 - X2*Z4 - X3*Z2 + X3*Z4 + X4*Z2 - X4*Z3, &
                       -X2*Y3 + X2*Y4 + X3*Y2 - X3*Y4 - X4*Y2 + X4*Y3 /)
    B0_tilde(2,:) = (/  Y1*Z3 - Y1*Z4 - Y3*Z1 + Y3*Z4 + Y4*Z1 - Y4*Z3, &
                       -X1*Z3 + X1*Z4 + X3*Z1 - X3*Z4 - X4*Z1 + X4*Z3, &
                        X1*Y3 - X1*Y4 - X3*Y1 + X3*Y4 + X4*Y1 - X4*Y3 /)
    B0_tilde(3,:) = (/ -Y1*Z2 + Y1*Z4 + Y2*Z1 - Y2*Z4 - Y4*Z1 + Y4*Z2, &
                        X1*Z2 - X1*Z4 - X2*Z1 + X2*Z4 + X4*Z1 - X4*Z2, &
                       -X1*Y2 + X1*Y4 + X2*Y1 - X2*Y4 - X4*Y1 + X4*Y2 /)
    B0_tilde(4,:) = (/ Y1*Z2 - Y1*Z3 - Y2*Z1 + Y2*Z3 + Y3*Z1 - Y3*Z2, &
                      -X1*Z2 + X1*Z3 + X2*Z1 - X2*Z3 - X3*Z1 + X3*Z2, &
                       X1*Y2 - X1*Y3 - X2*Y1 + X2*Y3 + X3*Y1 - X3*Y2 /)

    B0_tilde = B0_tilde/det
    H = matmul(transpose(u_e), B0_tilde)
    F = H + EYE
    E = 0.5*(H + transpose(H) + matmul(transpose(H), H))

    call S_Sv_and_C(E, S, S_v, C_SE)
    call compute_b_matrix(B0_tilde, F, B0, 4, 3)

    K_mat = matmul(transpose(B0), matmul(C_SE, B0)) * det/6
    K_geo_sm = matmul(B0_tilde, matmul(S, transpose(B0_tilde))) * det/6

    call scatter_matrix(K_geo_sm, K_geo, 3, 4, 4)

    K = K_mat + K_geo
    f_int = matmul(transpose(B0), S_v) * det/6

    S_exp = matmul(extrapol, reshape((/S(1,1), S(1,2), S(1,3), S(2,2), S(2,3), S(3,3)/), (/1, 6/)))
    E_exp = matmul(extrapol, reshape((/ E(1,1), E(1,2), E(1,3), E(2,2), E(2,3), E(3,3)/), (/1, 6/)))

end subroutine tet4_k_f_s_e

subroutine tet10_k_f_s_e(X, u, K, f_int, S_exp, E_exp, S_Sv_and_C)
    implicit none

    real(8), intent(in) :: X(30), u(30)
    real(8), intent(out) :: K(30, 30), f_int(30), S_exp(10,6), E_exp(10,6)
    real(8) :: X1, Y1, Z1, X2, Y2, Z2, X3, Y3, Z3, X4, Y4, Z4, X5, Y5, Z5
    real(8) :: X6, Y6, Z6, X7, Y7, Z7, X8, Y8, Z8, X9, Y9, Z9, X10, Y10, Z10
    real(8) :: Jx1, Jx2, Jx3, Jx4, Jy1, Jy2, Jy3, Jy4, Jz1, Jz2, Jz3, Jz4
    real(8) :: a1, a2, a3, a4, b1, b2, b3, b4, c1, c2, c3, c4
    real(8) :: L1, L2, L3, L4
    real(8) :: u_e(10,3), C_SE(6,6)
    real(8) :: K_geo_sm(10,10), K_mat(30,30), K_geo(30,30)
    real(8) :: B0_tilde(10,3), B0(6,30)
    real(8) :: E(3,3), H(3,3), F(3,3), EYE(3,3), S(3,3), S_v(6)
    real(8) :: det, extrapol(10,4)
    real(8) :: gauss_points(4,4), weights(4), a, b, w, m1, m2
    integer :: i

!   External functions that will be used afterwards
    external :: scatter_matrix
    external :: compute_b_matrix
    external :: S_Sv_and_C

    X1 = X(1)
    Y1 = X(2)
    Z1 = X(3)
    X2 = X(4)
    Y2 = X(5)
    Z2 = X(6)
    X3 = X(7)
    Y3 = X(8)
    Z3 = X(9)
    X4 = X(10)
    Y4 = X(11)
    Z4 = X(12)
    X5 = X(13)
    Y5 = X(14)
    Z5 = X(15)
    X6 = X(16)
    Y6 = X(17)
    Z6 = X(18)
    X7 = X(19)
    Y7 = X(20)
    Z7 = X(21)
    X8 = X(22)
    Y8 = X(23)
    Z8 = X(24)
    X9 = X(25)
    Y9 = X(26)
    Z9 = X(27)
    X10 = X(28)
    Y10 = X(29)
    Z10 = X(30)

    EYE = 0.0D0
    EYE(1,1) = 1
    EYE(2,2) = 1
    EYE(3,3) = 1

    ! take care of the fortran matrix order (columns first!):
    u_e = transpose(reshape(u, (/3, 10/)))

    ! take care of a precise description of 1/3 in order to avoid errors!
    a = 0.13819660112501050D0
    b = 0.585410196624968520D0
    w = 1/4D0

    gauss_points(1,:) = (/ b, a, a, a /)
    gauss_points(2,:) = (/ a, b, a, a /)
    gauss_points(3,:) = (/ a, a, b, a /)
    gauss_points(4,:) = (/ a, a, a, b /)

    weights = (/ w, w, w, w /)

    c1 = 1/4.0D0 + 3.0D0*sqrt(5.0D0)/4.0D0 ! close corner node
    c2 = -sqrt(5.0D0)/4.0D0 + 1/4.0D0  ! far corner node
    m1 = 1/4.0D0 + sqrt(5.0D0)/4.0D0   ! close mid-node
    m2 = -sqrt(5.0D0)/4.0D0 + 1/4.0D0  ! far mid node

    extrapol(:,1) = (/ c1, c2, c2, c2, m1, m2, m1, m1, m2, m2 /)
    extrapol(:,2) = (/ c2, c1, c2, c2, m1, m1, m2, m2, m1, m2 /)
    extrapol(:,3) = (/ c2, c2, c1, c2, m2, m1, m1, m2, m2, m1 /)
    extrapol(:,4) = (/ c2, c2, c2, c1, m2, m2, m2, m1, m1, m1 /)

    ! set the matrices and vectors to zero
    K = 0.0
    f_int = 0.0
    S_exp = 0.0
    E_exp = 0.0

    ! Loop over the gauss points
    do i = 1, 4

        L1 = gauss_points(i, 1)
        L2 = gauss_points(i, 2)
        L3 = gauss_points(i, 3)
        L4 = gauss_points(i, 4)
        w  = weights(i)

        Jx1 = 4*L2*X5 + 4*L3*X7 + 4*L4*X8  + X1*(4*L1 - 1)
        Jx2 = 4*L1*X5 + 4*L3*X6 + 4*L4*X9  + X2*(4*L2 - 1)
        Jx3 = 4*L1*X7 + 4*L2*X6 + 4*L4*X10 + X3*(4*L3 - 1)
        Jx4 = 4*L1*X8 + 4*L2*X9 + 4*L3*X10 + X4*(4*L4 - 1)
        Jy1 = 4*L2*Y5 + 4*L3*Y7 + 4*L4*Y8  + Y1*(4*L1 - 1)
        Jy2 = 4*L1*Y5 + 4*L3*Y6 + 4*L4*Y9  + Y2*(4*L2 - 1)
        Jy3 = 4*L1*Y7 + 4*L2*Y6 + 4*L4*Y10 + Y3*(4*L3 - 1)
        Jy4 = 4*L1*Y8 + 4*L2*Y9 + 4*L3*Y10 + Y4*(4*L4 - 1)
        Jz1 = 4*L2*Z5 + 4*L3*Z7 + 4*L4*Z8  + Z1*(4*L1 - 1)
        Jz2 = 4*L1*Z5 + 4*L3*Z6 + 4*L4*Z9  + Z2*(4*L2 - 1)
        Jz3 = 4*L1*Z7 + 4*L2*Z6 + 4*L4*Z10 + Z3*(4*L3 - 1)
        Jz4 = 4*L1*Z8 + 4*L2*Z9 + 4*L3*Z10 + Z4*(4*L4 - 1)

        det = - Jx1*Jy2*Jz3 + Jx1*Jy2*Jz4 + Jx1*Jy3*Jz2 - Jx1*Jy3*Jz4 &
              - Jx1*Jy4*Jz2 + Jx1*Jy4*Jz3 + Jx2*Jy1*Jz3 - Jx2*Jy1*Jz4 &
              - Jx2*Jy3*Jz1 + Jx2*Jy3*Jz4 + Jx2*Jy4*Jz1 - Jx2*Jy4*Jz3 &
              - Jx3*Jy1*Jz2 + Jx3*Jy1*Jz4 + Jx3*Jy2*Jz1 - Jx3*Jy2*Jz4 &
              - Jx3*Jy4*Jz1 + Jx3*Jy4*Jz2 + Jx4*Jy1*Jz2 - Jx4*Jy1*Jz3 &
              - Jx4*Jy2*Jz1 + Jx4*Jy2*Jz3 + Jx4*Jy3*Jz1 - Jx4*Jy3*Jz2

        a1 = -Jy2*Jz3 + Jy2*Jz4 + Jy3*Jz2 - Jy3*Jz4 - Jy4*Jz2 + Jy4*Jz3
        a2 =  Jy1*Jz3 - Jy1*Jz4 - Jy3*Jz1 + Jy3*Jz4 + Jy4*Jz1 - Jy4*Jz3
        a3 = -Jy1*Jz2 + Jy1*Jz4 + Jy2*Jz1 - Jy2*Jz4 - Jy4*Jz1 + Jy4*Jz2
        a4 =  Jy1*Jz2 - Jy1*Jz3 - Jy2*Jz1 + Jy2*Jz3 + Jy3*Jz1 - Jy3*Jz2
        b1 =  Jx2*Jz3 - Jx2*Jz4 - Jx3*Jz2 + Jx3*Jz4 + Jx4*Jz2 - Jx4*Jz3
        b2 = -Jx1*Jz3 + Jx1*Jz4 + Jx3*Jz1 - Jx3*Jz4 - Jx4*Jz1 + Jx4*Jz3
        b3 =  Jx1*Jz2 - Jx1*Jz4 - Jx2*Jz1 + Jx2*Jz4 + Jx4*Jz1 - Jx4*Jz2
        b4 = -Jx1*Jz2 + Jx1*Jz3 + Jx2*Jz1 - Jx2*Jz3 - Jx3*Jz1 + Jx3*Jz2
        c1 = -Jx2*Jy3 + Jx2*Jy4 + Jx3*Jy2 - Jx3*Jy4 - Jx4*Jy2 + Jx4*Jy3
        c2 =  Jx1*Jy3 - Jx1*Jy4 - Jx3*Jy1 + Jx3*Jy4 + Jx4*Jy1 - Jx4*Jy3
        c3 = -Jx1*Jy2 + Jx1*Jy4 + Jx2*Jy1 - Jx2*Jy4 - Jx4*Jy1 + Jx4*Jy2
        c4 =  Jx1*Jy2 - Jx1*Jy3 - Jx2*Jy1 + Jx2*Jy3 + Jx3*Jy1 - Jx3*Jy2

        B0_tilde(1,:) = (/     a1*(4*L1 - 1),     b1*(4*L1 - 1), c1*(4*L1 - 1) /)
        B0_tilde(2,:) = (/     a2*(4*L2 - 1),     b2*(4*L2 - 1), c2*(4*L2 - 1) /)
        B0_tilde(3,:) = (/     a3*(4*L3 - 1),     b3*(4*L3 - 1), c3*(4*L3 - 1) /)
        B0_tilde(4,:) = (/     a4*(4*L4 - 1),     b4*(4*L4 - 1), c4*(4*L4 - 1) /)
        B0_tilde(5,:) = (/ 4*L1*a2 + 4*L2*a1, 4*L1*b2 + 4*L2*b1,  4*L1*c2 + 4*L2*c1 /)
        B0_tilde(6,:) = (/ 4*L2*a3 + 4*L3*a2, 4*L2*b3 + 4*L3*b2,  4*L2*c3 + 4*L3*c2 /)
        B0_tilde(7,:) = (/ 4*L1*a3 + 4*L3*a1, 4*L1*b3 + 4*L3*b1,  4*L1*c3 + 4*L3*c1 /)
        B0_tilde(8,:) = (/ 4*L1*a4 + 4*L4*a1, 4*L1*b4 + 4*L4*b1,  4*L1*c4 + 4*L4*c1 /)
        B0_tilde(9,:) = (/ 4*L2*a4 + 4*L4*a2, 4*L2*b4 + 4*L4*b2,  4*L2*c4 + 4*L4*c2 /)
        B0_tilde(10,:) = (/ 4*L3*a4 + 4*L4*a3, 4*L3*b4 + 4*L4*b3,  4*L3*c4 + 4*L4*c3 /)

        B0_tilde = B0_tilde / det

        H = matmul(transpose(u_e), B0_tilde)
        F = H + EYE
        E = 0.5*(H + transpose(H) + matmul(transpose(H), H))

        call S_Sv_and_C(E, S, S_v, C_SE)
        call compute_b_matrix(B0_tilde, F, B0, 10, 3)

        K_mat = matmul(transpose(B0), matmul(C_SE, B0))
        K_geo_sm = matmul(B0_tilde, matmul(S, transpose(B0_tilde)))

        call scatter_matrix(K_geo_sm, K_geo, 3, 10, 10)

        K = K + (K_mat + K_geo)*det/6 * w
        f_int = f_int + matmul(transpose(B0), S_v) * det/6 * w

        S_exp = S_exp + matmul(reshape(extrapol(:,i), (/10,1/)), &
                 reshape((/S(1,1), S(1,2), S(1,3), S(2,2), S(2,3), S(3,3)/), (/1, 6/)))
        E_exp = E_exp + matmul(reshape(extrapol(:,i), (/10,1/)), &
                 reshape((/ E(1,1), E(1,2), E(1,3), E(2,2), E(2,3), E(3,3)/), (/1, 6/)))

    end do

end subroutine

subroutine hexa8_k_f_s_e(X, u, K, f_int, S_exp, E_exp, S_Sv_and_C)
    implicit none

    real(8), intent(in) :: X(24), u(24)
    real(8), intent(out) :: K(24, 24), f_int(24), S_exp(8,6), E_exp(8,6)
    real(8) :: u_e(8,3), C_SE(6,6)
    real(8) :: K_geo_sm(8,8), K_mat(24,24), K_geo(24,24)
    real(8) :: B0_tilde(8,3), B0(6,24), X_mat(8,3)
    real(8) :: E(3,3), H(3,3), F(3,3), EYE(3,3), S(3,3), S_v(6)
    real(8) :: det, extrapol(8,8), dN_dxi(8,3), dxi_dX(3,3), dX_dxi(3,3)
    real(8) :: gauss_points(8,3), weights(8), a, b, c, d, g, w, xi, eta, zeta
    integer :: i

    ! External functions that will be used afterwards
    external :: scatter_matrix
    external :: compute_b_matrix
    external :: S_Sv_and_C
    external :: invert_3_by_3_matrix

    X_mat = transpose(reshape(X, (/ 3, 8/)))
    u_e = transpose(reshape(u, (/ 3, 8/)))
    EYE = 0.0D0
    EYE(1,1) = 1
    EYE(2,2) = 1
    EYE(3,3) = 1

    a = sqrt(1.0D0/3.0D0)
    gauss_points(1,:) = (/-a,  a,  a /)
    gauss_points(2,:) = (/ a,  a,  a /)
    gauss_points(3,:) = (/-a, -a,  a /)
    gauss_points(4,:) = (/ a, -a,  a /)
    gauss_points(5,:) = (/-a,  a, -a /)
    gauss_points(6,:) = (/ a,  a, -a /)
    gauss_points(7,:) = (/-a, -a, -a /)
    gauss_points(8,:) = (/ a, -a, -a /)

    weights = (/ 1, 1, 1, 1, 1, 1, 1, 1 /)

    b = (-sqrt(3.0D0) + 1)**2*(sqrt(3.0D0) + 1)/8.0D0
    c = (-sqrt(3.0D0) + 1)**3/8.0D0
    d = (sqrt(3.0D0) + 1)**3/8.0D0
    g = (sqrt(3.0D0) + 1)**2*(-sqrt(3.0D0) + 1)/8.0D0
    extrapol(1,:) = (/ b, c, g, b, g, b, d, g /)
    extrapol(2,:) = (/c, b, b, g, b, g, g, d /)
    extrapol(3,:) = (/b, g, c, b, g, d, b, g /)
    extrapol(4,:) = (/g, b, b, c, d, g, g, b /)
    extrapol(5,:) = (/g, b, d, g, b, c, g, b /)
    extrapol(6,:) = (/b, g, g, d, c, b, b, g /)
    extrapol(7,:) = (/g, d, b, g, b, g, c, b /)
    extrapol(8,:) = (/d, g, g, b, g, b, b, c /)

    ! set the matrices and vectors to zero
    K = 0.0
    f_int = 0.0
    S_exp = 0.0
    E_exp = 0.0

    ! Loop over the gauss points
    do i = 1, 8
        xi = gauss_points(i, 1)
        eta = gauss_points(i, 2)
        zeta = gauss_points(i, 3)
        w  = weights(i)

        dN_dxi(1,:) = (/-(-eta+1)*(-zeta+1), -(-xi+1)*(-zeta+1), -(-eta+1)*(-xi+1) /)
        dN_dxi(2,:) = (/ (-eta+1)*(-zeta+1),  -(xi+1)*(-zeta+1),  -(-eta+1)*(xi+1) /)
        dN_dxi(3,:) = (/  (eta+1)*(-zeta+1),   (xi+1)*(-zeta+1),   -(eta+1)*(xi+1) /)
        dN_dxi(4,:) = (/ -(eta+1)*(-zeta+1),  (-xi+1)*(-zeta+1),  -(eta+1)*(-xi+1) /)
        dN_dxi(5,:) = (/ -(-eta+1)*(zeta+1),  -(-xi+1)*(zeta+1),  (-eta+1)*(-xi+1) /)
        dN_dxi(6,:) = (/  (-eta+1)*(zeta+1),   -(xi+1)*(zeta+1),   (-eta+1)*(xi+1) /)
        dN_dxi(7,:) = (/   (eta+1)*(zeta+1),    (xi+1)*(zeta+1),    (eta+1)*(xi+1) /)
        dN_dxi(8,:) = (/  -(eta+1)*(zeta+1),   (-xi+1)*(zeta+1),   (eta+1)*(-xi+1) /)
        dN_dxi = dN_dxi / 8.0D0

        dX_dxi = matmul(transpose(X_mat), dN_dxi)
        call invert_3_by_3_matrix(dX_dxi, dxi_dX, det)
        B0_tilde = matmul(dN_dxi, dxi_dX)

        H = matmul(transpose(u_e), B0_tilde)
        F = H + EYE
        E = 0.5*(H + transpose(H) + matmul(transpose(H), H))

        call S_Sv_and_C(E, S, S_v, C_SE)
        call compute_b_matrix(B0_tilde, F, B0, 8, 3)

        K_mat = matmul(transpose(B0), matmul(C_SE, B0))
        K_geo_sm = matmul(B0_tilde, matmul(S, transpose(B0_tilde)))

        call scatter_matrix(K_geo_sm, K_geo, 3, 8, 8)

        K = K + (K_mat + K_geo)*det * w
        f_int = f_int + matmul(transpose(B0), S_v) * det * w

        S_exp = S_exp + matmul(reshape(extrapol(:,i), (/8,1/)), &
                 reshape((/S(1,1), S(1,2), S(1,3), S(2,2), S(2,3), S(3,3)/), (/1, 6/)))
        E_exp = E_exp + matmul(reshape(extrapol(:,i), (/8,1/)), &
                 reshape((/ E(1,1), E(1,2), E(1,3), E(2,2), E(2,3), E(3,3)/), (/1, 6/)))

    end do
end subroutine

subroutine hexa20_k_f_s_e(X, u, K, f_int, S_exp, E_exp, S_Sv_and_C)
        implicit none

        real(8), intent(in) :: X(60), u(60)
        real(8), intent(out) :: K(60, 60), f_int(60), S_exp(20,6), E_exp(20,6)
        real(8) :: u_e(20,3), C_SE(6,6)
        real(8) :: K_geo_sm(20,20), K_mat(60,60), K_geo(60,60)
        real(8) :: B0_tilde(20,3), B0(6,60), X_mat(20,3)
        real(8) :: E(3,3), H(3,3), F(3,3), EYE(3,3), S(3,3), S_v(6)
        real(8) :: det, extrapol(20,27), dN_dxi(20,3), dxi_dX(3,3), dX_dxi(3,3)
        real(8) :: gauss_points(27,3), weights(27), a, w, wa, w0, xi, eta, zeta
        real(8) :: b1, b2, b3, b4, b5, b6, b7, b8, b9, c1, c2, c3, c4, c5, c6
        integer :: i

        ! External functions that will be used afterwards
        external :: scatter_matrix
        external :: compute_b_matrix
        external :: S_Sv_and_C
        external :: invert_3_by_3_matrix

        X_mat = transpose(reshape(X, (/ 3, 20/)))
        u_e = transpose(reshape(u, (/ 3, 20/)))
        EYE = 0.0D0
        EYE(1,1) = 1
        EYE(2,2) = 1
        EYE(3,3) = 1

        a = sqrt(3.0D0/5.0D0)
        wa = 5/9.0D0
        w0 = 8/9.0D0
        gauss_points(1,:) = (/ -a, -a, -a /)
        gauss_points(2,:) = (/ 0.0D0 , -a, -a /)
        gauss_points(3,:) = (/  a, -a, -a /)
        gauss_points(4,:) = (/ -a, 0.0D0 , -a /)
        gauss_points(5,:) = (/ 0.0D0 , 0.0D0 , -a /)
        gauss_points(6,:) = (/  a, 0.0D0 , -a /)
        gauss_points(7,:) = (/ -a,  a, -a /)
        gauss_points(8,:) = (/ 0.0D0 ,  a, -a /)
        gauss_points(9,:) = (/  a,  a, -a /)
        gauss_points(10,:) = (/ -a, -a, 0.0D0  /)
        gauss_points(11,:) = (/ 0.0D0 , -a, 0.0D0  /)
        gauss_points(12,:) = (/  a, -a, 0.0D0  /)
        gauss_points(13,:) = (/ -a, 0.0D0 , 0.0D0  /)
        gauss_points(14,:) = (/ 0.0D0 , 0.0D0 , 0.0D0  /)
        gauss_points(15,:) = (/  a, 0.0D0 , 0.0D0  /)
        gauss_points(16,:) = (/ -a,  a, 0.0D0  /)
        gauss_points(17,:) = (/ 0.0D0 ,  a, 0.0D0  /)
        gauss_points(18,:) = (/  a,  a, 0.0D0  /)
        gauss_points(19,:) = (/ -a, -a,  a /)
        gauss_points(20,:) = (/ 0.0D0 , -a,  a /)
        gauss_points(21,:) = (/  a, -a,  a /)
        gauss_points(22,:) = (/ -a, 0.0D0 ,  a /)
        gauss_points(23,:) = (/ 0.0D0 , 0.0D0 ,  a /)
        gauss_points(24,:) = (/  a, 0.0D0 ,  a /)
        gauss_points(25,:) = (/ -a,  a,  a /)
        gauss_points(26,:) = (/ 0.0D0 ,  a,  a /)
        gauss_points(27,:) = (/  a,  a,  a /)
        weights = (/ wa*wa*wa, w0*wa*wa, wa*wa*wa, wa*w0*wa, w0*w0*wa, &
                     wa*w0*wa, wa*wa*wa, w0*wa*wa, wa*wa*wa, wa*wa*w0, &
                     w0*wa*w0, wa*wa*w0, wa*w0*w0, w0*w0*w0, wa*w0*w0, &
                     wa*wa*w0, w0*wa*w0, wa*wa*w0, wa*wa*wa, w0*wa*wa, &
                     wa*wa*wa, wa*w0*wa, w0*w0*wa, wa*w0*wa, wa*wa*wa, &
                     w0*wa*wa, wa*wa*wa /)

         b1 = 13.0D0*sqrt(15.0D0)/36.0D0 + 17.0D0/12.0D0
         b2 = (4.0D0 + sqrt(15.0D0))/9.0D0
         b3 = (1.0D0 + sqrt(15.0D0))/36.0D0
         b4 = (3.0D0 + sqrt(15.0D0))/27.0D0
         b5 = 1.0D0/9.0D0
         b6 = (1.0D0 - sqrt(15.0D0))/36.0D0
         b7 = -2.0D0/27.0D0
         b8 = (3.0D0 - sqrt(15.0D0))/27.0D0
         b9 = -13*sqrt(15.0D0)/36 + 17/12.0D0
         c1 = (-4.0D0 + sqrt(15.0D0))/9.0D0
         c2 = (3.0D0 + sqrt(15.0D0))/18.0D0
         c3 = sqrt(15.0D0)/6.0D0 + 2/3.0D0
         c4 = 3.0D0/18.0D0
         c5 = (- 3.0D0 + sqrt(15.0D0))/18.0D0
         c6 = (4.0D0 - sqrt(15.0D0))/6.0D0

        extrapol(1,:) = (/ b1,-b2,b3,-b2,b4,b5,b3,b5,b6,-b2,b4,b5,b4,b7,b8,b5,b8,c1,b3,b5,b6,b5,b8,c1,b6,c1,b9 /)
        extrapol(2,:) = (/ b3,-b2,b1,b5,b4,-b2,b6,b5,b3,b5,b4,-b2,b8,b7,b4,c1,b8,b5,b6,b5,b3,c1,b8,b5,b9,c1,b6 /)
        extrapol(3,:) = (/ b6,b5,b3,b5,b4,-b2,b3,-b2,b1,c1,b8,b5,b8,b7,b4,b5,b4,-b2,b9,c1,b6,c1,b8,b5,b6,b5,b3 /)
        extrapol(4,:) = (/ b3,b5,b6,-b2,b4,b5,b1,-b2,b3,b5,b8,c1,b4,b7,b8,-b2,b4,b5,b6,c1,b9,b5,b8,c1,b3,b5,b6 /)
        extrapol(5,:) = (/ b3,b5,b6,b5,b8,c1,b6,c1,b9,-b2,b4,b5,b4,b7,b8,b5,b8,c1,b1,-b2,b3,-b2,b4,b5,b3,b5,b6 /)
        extrapol(6,:) = (/ b6,b5,b3,c1,b8,b5,b9,c1,b6,b5,b4,-b2,b8,b7,b4,c1,b8,b5,b3,-b2,b1,b5,b4,-b2,b6,b5,b3 /)
        extrapol(7,:) = (/ b9,c1,b6,c1,b8,b5,b6,b5,b3,c1,b8,b5,b8,b7,b4,b5,b4,-b2,b6,b5,b3,b5,b4,-b2,b3,-b2,b1 /)
        extrapol(8,:) = (/ b6,c1,b9,b5,b8,c1,b3,b5,b6,b5,b8,c1,b4,b7,b8,-b2,b4,b5,b3,b5,b6,-b2,b4,b5,b1,-b2,b3 /)
        extrapol(9,:) = (/ c2,c3,c2,-c2,-c2,-c2,c4,-c4,c4,-c2,-c2,-c2,b5,b5,b5,c5,c5,c5,c4,-c4,c4,c5,c5,c5,-c5,c6,-c5 /)
        extrapol(10,:) = (/ c4,-c2,c2,-c4,-c2,c3,c4,-c2,c2,c5,b5,-c2,c5,b5,-c2,c5,b5,-c2,-c5,c5,c4,c6,c5,-c4,-c5,c5,c4 /)
        extrapol(11,:) = (/ c4,-c4,c4,-c2,-c2,-c2,c2,c3,c2,c5,c5,c5,b5,b5,b5,-c2,-c2,-c2,-c5,c6,-c5,c5,c5,c5,c4,-c4,c4 /)
        extrapol(12,:) = (/ c2,-c2,c4,c3,-c2,-c4,c2,-c2,c4,-c2,b5,c5,-c2,b5,c5,-c2,b5,c5,c4,c5,-c5,-c4,c5,c6,c4,c5,-c5 /)
        extrapol(13,:) = (/ c4,-c4,c4,c5,c5,c5,-c5,c6,-c5,-c2,-c2,-c2,b5,b5,b5,c5,c5,c5,c2,c3,c2,-c2,-c2,-c2,c4,-c4,c4 /)
        extrapol(14,:) = (/ -c5,c5,c4,c6,c5,-c4,-c5,c5,c4,c5,b5,-c2,c5,b5,-c2,c5,b5,-c2,c4,-c2,c2,-c4,-c2,c3,c4,-c2,c2 /)
        extrapol(15,:) = (/ -c5,c6,-c5,c5,c5,c5,c4,-c4,c4,c5,c5,c5,b5,b5,b5,-c2,-c2,-c2,c4,-c4,c4,-c2,-c2,-c2,c2,c3,c2 /)
        extrapol(16,:) = (/ c4,c5,-c5,-c4,c5,c6,c4,c5,-c5,-c2,b5,c5,-c2,b5,c5,-c2,b5,c5,c2,-c2,c4,c3,-c2,-c4,c2,-c2,c4 /)
        extrapol(17,:) = (/ c2,-c2,c4,-c2,b5,c5,c4,c5,-c5,c3,-c2,-c4,-c2,b5,c5,-c4,c5,c6,c2,-c2,c4,-c2,b5,c5,c4,c5,-c5 /)
        extrapol(18,:) = (/ c4,-c2,c2,c5,b5,-c2,-c5,c5,c4,-c4,-c2,c3,c5,b5,-c2,c6,c5,-c4,c4,-c2,c2,c5,b5,-c2,-c5,c5,c4 /)
        extrapol(19,:) = (/ -c5,c5,c4,c5,b5,-c2,c4,-c2,c2,c6,c5,-c4,c5,b5,-c2,-c4,-c2,c3,-c5,c5,c4,c5,b5,-c2,c4,-c2,c2 /)
        extrapol(20,:) = (/ c4,c5,-c5,-c2,b5,c5,c2,-c2,c4,-c4,c5,c6,-c2,b5,c5,c3,-c2,-c4,c4,c5,-c5,-c2,b5,c5,c2,-c2,c4 /)

        ! set the matrices and vectors to zero
        K = 0.0
        f_int = 0.0
        S_exp = 0.0
        E_exp = 0.0

        ! Loop over the gauss points
        do i = 1, 27
            xi = gauss_points(i, 1)
            eta = gauss_points(i, 2)
            zeta = gauss_points(i, 3)
            w  = weights(i)

            dN_dxi(1,:) = (/ (eta-1)*(zeta-1)*(eta+2*xi+zeta+1), &
                             (xi-1)*(zeta-1)*(2*eta+xi+zeta+1), &
                             (eta-1)*(xi-1)*(eta+xi+2*zeta+1) /)
            dN_dxi(2,:) = (/ (eta-1)*(zeta-1)*(-eta+2*xi-zeta-1), &
                             (xi+1)*(zeta-1)*(-2*eta+xi-zeta-1), &
                             (eta-1)*(xi+1)*(-eta+xi-2*zeta-1) /)
            dN_dxi(3,:) = (/ (eta+1)*(zeta-1)*(-eta-2*xi+zeta+1), &
                             (xi+1)*(zeta-1)*(-2*eta-xi+zeta+1), &
                             (eta+1)*(xi+1)*(-eta-xi+2*zeta+1) /)
            dN_dxi(4,:) = (/ (eta+1)*(zeta-1)*(eta-2*xi-zeta-1), &
                             (xi-1)*(zeta-1)*(2*eta-xi-zeta-1), &
                             (eta+1)*(xi-1)*(eta-xi-2*zeta-1) /)
            dN_dxi(5,:) = (/(eta-1)*(zeta+1)*(-eta-2*xi+zeta-1), &
                            (xi-1)*(zeta+1)*(-2*eta-xi+zeta-1), &
                            (eta-1)*(xi-1)*(-eta-xi+2*zeta-1) /)
            dN_dxi(6,:) = (/ (eta-1)*(zeta+1)*(eta-2*xi-zeta+1), &
                             (xi+1)*(zeta+1)*(2*eta-xi-zeta+1), &
                             (eta-1)*(xi+1)*(eta-xi-2*zeta+1) /)
            dN_dxi(7,:) = (/ (eta+1)*(zeta+1)*(eta+2*xi+zeta-1), &
                             (xi+1)*(zeta+1)*(2*eta+xi+zeta-1), &
                             (eta+1)*(xi+1)*(eta+xi+2*zeta-1) /)
            dN_dxi(8,:) = (/(eta+1)*(zeta+1)*(-eta+2*xi-zeta+1), &
                            (xi-1)*(zeta+1)*(-2*eta+xi-zeta+1), &
                            (eta+1)*(xi-1)*(-eta+xi-2*zeta+1) /)
            dN_dxi(9,:) = (/-4*xi*(eta-1)*(zeta-1), -2*(xi**2-1)*(zeta-1), &
                            -2*(eta-1)*(xi**2-1) /)
            dN_dxi(10,:) = (/ 2*(eta**2-1)*(zeta-1), 4*eta*(xi+1)*(zeta-1), &
                              2*(eta**2-1)*(xi+1) /)
            dN_dxi(11,:) = (/ 4*xi*(eta+1)*(zeta-1),  2*(xi**2-1)*(zeta-1), &
                              2*(eta+1)*(xi**2-1) /)
            dN_dxi(12,:) = (/-2*(eta**2-1)*(zeta-1),-4*eta*(xi-1)*(zeta-1), &
                             -2*(eta**2-1)*(xi-1) /)
            dN_dxi(13,:) = (/ 4*xi*(eta-1)*(zeta+1),  2*(xi**2-1)*(zeta+1), &
                              2*(eta-1)*(xi**2-1) /)
            dN_dxi(14,:) = (/-2*(eta**2-1)*(zeta+1),-4*eta*(xi+1)*(zeta+1), &
                             -2*(eta**2-1)*(xi+1) /)
            dN_dxi(15,:) = (/-4*xi*(eta+1)*(zeta+1), -2*(xi**2-1)*(zeta+1), &
                             -2*(eta+1)*(xi**2-1) /)
            dN_dxi(16,:) = (/ 2*(eta**2-1)*(zeta+1), 4*eta*(xi-1)*(zeta+1), &
                              2*(eta**2-1)*(xi-1) /)
            dN_dxi(17,:) = (/-2*(eta-1)*(zeta**2-1), -2*(xi-1)*(zeta**2-1), &
                             -4*zeta*(eta-1)*(xi-1) /)
            dN_dxi(18,:) = (/ 2*(eta-1)*(zeta**2-1),  2*(xi+1)*(zeta**2-1), &
                              4*zeta*(eta-1)*(xi+1) /)
            dN_dxi(19,:) = (/-2*(eta+1)*(zeta**2-1), -2*(xi+1)*(zeta**2-1), &
                             -4*zeta*(eta+1)*(xi+1) /)
            dN_dxi(20,:) = (/ 2*(eta+1)*(zeta**2-1),  2*(xi-1)*(zeta**2-1), &
                              4*zeta*(eta+1)*(xi-1) /)

            dN_dxi = dN_dxi / 8.0D0

            dX_dxi = matmul(transpose(X_mat), dN_dxi)
            call invert_3_by_3_matrix(dX_dxi, dxi_dX, det)
            B0_tilde = matmul(dN_dxi, dxi_dX)

            H = matmul(transpose(u_e), B0_tilde)
            F = H + EYE
            E = 0.5*(H + transpose(H) + matmul(transpose(H), H))

            call S_Sv_and_C(E, S, S_v, C_SE)
            call compute_b_matrix(B0_tilde, F, B0, 20, 3)

            K_mat = matmul(transpose(B0), matmul(C_SE, B0))
            K_geo_sm = matmul(B0_tilde, matmul(S, transpose(B0_tilde)))

            call scatter_matrix(K_geo_sm, K_geo, 3, 20, 20)

            K = K + (K_mat + K_geo)*det * w
            f_int = f_int + matmul(transpose(B0), S_v) * det * w

            S_exp = S_exp + matmul(reshape(extrapol(:,i), (/20,1/)), &
                     reshape((/S(1,1), S(1,2), S(1,3), S(2,2), S(2,3), S(3,3)/), (/1, 6/)))
            E_exp = E_exp + matmul(reshape(extrapol(:,i), (/20,1/)), &
                     reshape((/ E(1,1), E(1,2), E(1,3), E(2,2), E(2,3), E(3,3)/), (/1, 6/)))

        end do
end subroutine

subroutine hexa20_m(X, rho, M)
    implicit none

    real(8), intent(in) :: X(60), rho
    real(8), intent(out) :: M(60, 60)
    real(8) :: gauss_points(27,3), weights(27), xi, eta, zeta
    real(8) :: dX_dxi(3,3), dN_dxi(20,3), X_mat(20,3), det
    real(8) :: N(20,1), M_small(20,20)
    real(8) :: a, w, wa, w0
    integer :: i

    external :: scatter_matrix

    X_mat = transpose(reshape(X, (/ 3, 20/)))

    a = sqrt(3.0D0/5.0D0)
    wa = 5/9.0D0
    w0 = 8/9.0D0
    gauss_points(1,:) = (/ -a, -a, -a /)
    gauss_points(2,:) = (/ 0.0D0 , -a, -a /)
    gauss_points(3,:) = (/  a, -a, -a /)
    gauss_points(4,:) = (/ -a, 0.0D0 , -a /)
    gauss_points(5,:) = (/ 0.0D0 , 0.0D0 , -a /)
    gauss_points(6,:) = (/  a, 0.0D0 , -a /)
    gauss_points(7,:) = (/ -a,  a, -a /)
    gauss_points(8,:) = (/ 0.0D0 ,  a, -a /)
    gauss_points(9,:) = (/  a,  a, -a /)
    gauss_points(10,:) = (/ -a, -a, 0.0D0  /)
    gauss_points(11,:) = (/ 0.0D0 , -a, 0.0D0  /)
    gauss_points(12,:) = (/  a, -a, 0.0D0  /)
    gauss_points(13,:) = (/ -a, 0.0D0 , 0.0D0  /)
    gauss_points(14,:) = (/ 0.0D0 , 0.0D0 , 0.0D0  /)
    gauss_points(15,:) = (/  a, 0.0D0 , 0.0D0  /)
    gauss_points(16,:) = (/ -a,  a, 0.0D0  /)
    gauss_points(17,:) = (/ 0.0D0 ,  a, 0.0D0  /)
    gauss_points(18,:) = (/  a,  a, 0.0D0  /)
    gauss_points(19,:) = (/ -a, -a,  a /)
    gauss_points(20,:) = (/ 0.0D0 , -a,  a /)
    gauss_points(21,:) = (/  a, -a,  a /)
    gauss_points(22,:) = (/ -a, 0.0D0 ,  a /)
    gauss_points(23,:) = (/ 0.0D0 , 0.0D0 ,  a /)
    gauss_points(24,:) = (/  a, 0.0D0 ,  a /)
    gauss_points(25,:) = (/ -a,  a,  a /)
    gauss_points(26,:) = (/ 0.0D0 ,  a,  a /)
    gauss_points(27,:) = (/  a,  a,  a /)
    weights = (/ wa*wa*wa, w0*wa*wa, wa*wa*wa, wa*w0*wa, w0*w0*wa, &
                 wa*w0*wa, wa*wa*wa, w0*wa*wa, wa*wa*wa, wa*wa*w0, &
                 w0*wa*w0, wa*wa*w0, wa*w0*w0, w0*w0*w0, wa*w0*w0, &
                 wa*wa*w0, w0*wa*w0, wa*wa*w0, wa*wa*wa, w0*wa*wa, &
                 wa*wa*wa, wa*w0*wa, w0*w0*wa, wa*w0*wa, wa*wa*wa, &
                 w0*wa*wa, wa*wa*wa /)

    M = 0
    M_small = 0

    ! Loop over the gauss points
    do i = 1, 27
        xi = gauss_points(i, 1)
        eta = gauss_points(i, 2)
        zeta = gauss_points(i, 3)
        w  = weights(i)

        dN_dxi(1,:) = (/ (eta-1)*(zeta-1)*(eta+2*xi+zeta+1), &
                         (xi-1)*(zeta-1)*(2*eta+xi+zeta+1), &
                         (eta-1)*(xi-1)*(eta+xi+2*zeta+1) /)
        dN_dxi(2,:) = (/ (eta-1)*(zeta-1)*(-eta+2*xi-zeta-1), &
                         (xi+1)*(zeta-1)*(-2*eta+xi-zeta-1), &
                         (eta-1)*(xi+1)*(-eta+xi-2*zeta-1) /)
        dN_dxi(3,:) = (/ (eta+1)*(zeta-1)*(-eta-2*xi+zeta+1), &
                         (xi+1)*(zeta-1)*(-2*eta-xi+zeta+1), &
                         (eta+1)*(xi+1)*(-eta-xi+2*zeta+1) /)
        dN_dxi(4,:) = (/ (eta+1)*(zeta-1)*(eta-2*xi-zeta-1), &
                         (xi-1)*(zeta-1)*(2*eta-xi-zeta-1), &
                         (eta+1)*(xi-1)*(eta-xi-2*zeta-1) /)
        dN_dxi(5,:) = (/(eta-1)*(zeta+1)*(-eta-2*xi+zeta-1), &
                        (xi-1)*(zeta+1)*(-2*eta-xi+zeta-1), &
                        (eta-1)*(xi-1)*(-eta-xi+2*zeta-1) /)
        dN_dxi(6,:) = (/ (eta-1)*(zeta+1)*(eta-2*xi-zeta+1), &
                         (xi+1)*(zeta+1)*(2*eta-xi-zeta+1), &
                         (eta-1)*(xi+1)*(eta-xi-2*zeta+1) /)
        dN_dxi(7,:) = (/ (eta+1)*(zeta+1)*(eta+2*xi+zeta-1), &
                         (xi+1)*(zeta+1)*(2*eta+xi+zeta-1), &
                         (eta+1)*(xi+1)*(eta+xi+2*zeta-1) /)
        dN_dxi(8,:) = (/(eta+1)*(zeta+1)*(-eta+2*xi-zeta+1), &
                        (xi-1)*(zeta+1)*(-2*eta+xi-zeta+1), &
                        (eta+1)*(xi-1)*(-eta+xi-2*zeta+1) /)
        dN_dxi(9,:) = (/-4*xi*(eta-1)*(zeta-1), -2*(xi**2-1)*(zeta-1), &
                        -2*(eta-1)*(xi**2-1) /)
        dN_dxi(10,:) = (/ 2*(eta**2-1)*(zeta-1), 4*eta*(xi+1)*(zeta-1), &
                          2*(eta**2-1)*(xi+1) /)
        dN_dxi(11,:) = (/ 4*xi*(eta+1)*(zeta-1),  2*(xi**2-1)*(zeta-1), &
                          2*(eta+1)*(xi**2-1) /)
        dN_dxi(12,:) = (/-2*(eta**2-1)*(zeta-1),-4*eta*(xi-1)*(zeta-1), &
                         -2*(eta**2-1)*(xi-1) /)
        dN_dxi(13,:) = (/ 4*xi*(eta-1)*(zeta+1),  2*(xi**2-1)*(zeta+1), &
                          2*(eta-1)*(xi**2-1) /)
        dN_dxi(14,:) = (/-2*(eta**2-1)*(zeta+1),-4*eta*(xi+1)*(zeta+1), &
                         -2*(eta**2-1)*(xi+1) /)
        dN_dxi(15,:) = (/-4*xi*(eta+1)*(zeta+1), -2*(xi**2-1)*(zeta+1), &
                         -2*(eta+1)*(xi**2-1) /)
        dN_dxi(16,:) = (/ 2*(eta**2-1)*(zeta+1), 4*eta*(xi-1)*(zeta+1), &
                          2*(eta**2-1)*(xi-1) /)
        dN_dxi(17,:) = (/-2*(eta-1)*(zeta**2-1), -2*(xi-1)*(zeta**2-1), &
                         -4*zeta*(eta-1)*(xi-1) /)
        dN_dxi(18,:) = (/ 2*(eta-1)*(zeta**2-1),  2*(xi+1)*(zeta**2-1), &
                          4*zeta*(eta-1)*(xi+1) /)
        dN_dxi(19,:) = (/-2*(eta+1)*(zeta**2-1), -2*(xi+1)*(zeta**2-1), &
                         -4*zeta*(eta+1)*(xi+1) /)
        dN_dxi(20,:) = (/ 2*(eta+1)*(zeta**2-1),  2*(xi-1)*(zeta**2-1), &
                          4*zeta*(eta+1)*(xi-1) /)

        dN_dxi = dN_dxi / 8.0D0

        dX_dxi = matmul(transpose(X_mat), dN_dxi)
        det =   dX_dxi(1,1)*dX_dxi(2,2)*dX_dxi(3,3) &
              - dX_dxi(1,1)*dX_dxi(2,3)*dX_dxi(3,2) &
              - dX_dxi(1,2)*dX_dxi(2,1)*dX_dxi(3,3) &
              + dX_dxi(1,2)*dX_dxi(2,3)*dX_dxi(3,1) &
              + dX_dxi(1,3)*dX_dxi(2,1)*dX_dxi(3,2) &
              - dX_dxi(1,3)*dX_dxi(2,2)*dX_dxi(3,1)

       N(:,1) = (/ (eta-1)*(xi-1)*(zeta-1)*(eta+xi+zeta+2), &
                  -(eta-1)*(xi+1)*(zeta-1)*(eta-xi+zeta+2), &
                  -(eta+1)*(xi+1)*(zeta-1)*(eta+xi-zeta-2), &
                 -(eta+1)*(xi-1)*(zeta-1)*(-eta+xi+zeta+2), &
                  -(eta-1)*(xi-1)*(zeta+1)*(eta+xi-zeta+2), &
                   (eta-1)*(xi+1)*(zeta+1)*(eta-xi-zeta+2), &
                   (eta+1)*(xi+1)*(zeta+1)*(eta+xi+zeta-2), &
                  -(eta+1)*(xi-1)*(zeta+1)*(eta-xi+zeta-2), &
                             -2*(eta-1)*(xi**2-1)*(zeta-1), &
                              2*(eta**2-1)*(xi+1)*(zeta-1), &
                              2*(eta+1)*(xi**2-1)*(zeta-1), &
                             -2*(eta**2-1)*(xi-1)*(zeta-1), &
                              2*(eta-1)*(xi**2-1)*(zeta+1), &
                             -2*(eta**2-1)*(xi+1)*(zeta+1), &
                             -2*(eta+1)*(xi**2-1)*(zeta+1), &
                              2*(eta**2-1)*(xi-1)*(zeta+1), &
                             -2*(eta-1)*(xi-1)*(zeta**2-1), &
                              2*(eta-1)*(xi+1)*(zeta**2-1), &
                             -2*(eta+1)*(xi+1)*(zeta**2-1), &
                              2*(eta+1)*(xi-1)*(zeta**2-1) /)

        N = N / 8.0D0
        M_small = M_small + matmul(N, transpose(N)) * det * rho * w
    end do

    call scatter_matrix(M_small, M, 3, 20, 20)
end subroutine


      SUBROUTINE XLIN EQ
     &          (a,ae,b,be,x,xe,n,n dim,iflag,err)

c***********************************************************************
c                         subroutine xlineq
c***********************************************************************

c  Program Source:  Naval Ocean Systems Center - Code 542

c  Date:
c     04 Jan 1996

c  Function:
c     Solves simultaneous linear equations of the form:
c         A*X=L*U*X=B
c     for COMPLEX*16 variables

c     Uses L-U decomposition to find the triangular matrices L and U
c     such that L*U=A.  The matrices L and U are stored in A. This form
c     is used with back substitution to find the solution X of:
c         A*X=L*U*X=B.

c  Parameters passed:
c     a                [c,nxn] matrix A
c     ae               [r,nxn] matrix A exponents
c     b                [c,n]   matrix B
c     be               [r,n]   matrix B exponents
c     n                [i]     number of elements in the matrices
c     n dim            [i]     dimension of the matrices in the calling
c                              routine
c     iflag            [i]  =0 indicates that the matrix A has not been
c                              decomposed into L and U; after it has
c                              been decomposed, it is replaced by the
c                              matrices L and U;
c                           =1 indicates that the matrix A has already
c                              been decomposed into L and U

c  Parameters returned:
c     x                [c,n]   matrix X; the solution vector
c     xe               [r,n]   matrix X; the solution vector exponent
c     err              [r]     relative error of the solution vector

c  Common blocks referenced:

c  Functions and subroutines referenced:
c     abs

c     xc_add
c     xc_norme

c  References:

c  Change History:

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

      implicit      real*8 (a-h,o-z)

      parameter    (max dim=51)

      complex *  16 a (n dim,n dim),b (n dim),x (n dim),t
      real    *   8 ae(n dim,n dim),be(n dim),xe(n dim),te

      dimension     irow(max dim),q(max dim),qe(max dim)

      character*200 error_msg

      if (n .gt. max dim) then
         write(error_msg,
     &       '(''[XLIN EQ]: '',
     &         ''matrix size greater than '',i2)') max dim
         call LWPC_ERROR ('ERROR',error_msg)
      end if

      if (n .eq. 1) then
         x (1)=b (1)/a (1,1)
         xe(1)=be(1)-ae(1,1)
         call XC_NORME (x(1),xe(1))
         RETURN
      end if

      if (iflag .eq. 0) then
         do i=1,n
            q (i)=0.d0
            qe(i)=0.d0
            do j=1,n
               qq =ABS(a (i,j))
               qqe=    ae(i,j)
               if (q(i)/qq*DEXP(qe(i)-qqe) .lt. 1.d0) then
                  q (i)=qq
                  qe(i)=qqe
               end if
            end do
            if (q(i) .eq. 0.d0) then
               loop=40
               write(error_msg,
     &             '(''[XLIN EQ]: '',
     &               ''matrix is singular at loop '',i3)') loop
               call LWPC_ERROR ('ERROR',error_msg)
            end if
         end do
         err  =1.d-15
         ppiv =0.d0
         ppive=0.d0
         do i=1,n
            irow(i)=i
         end do

         do l=1,n
            pivot =0.d0
            pivote=0.d0
            k=l-1
            do i=l,n
               if (k .ge. 1) then
                  do j=1,k
cxx                  a(i,l)=a(i,l)-a(i,j)*a(j,l)
                     call XC_ADD
     &                   (a(i,l),ae(i,l),a(i,l),ae(i,l),
     &                   -a(i,j)*a(j,l),ae(i,j)+ae(j,l))
                  end do
               end if
               t =a (i,l)/q (i)
               te=ae(i,l)-qe(i)
               call XC_NORME (t,te)
               f =ABS(t )
               fe=    te
               if (pivot/f*DEXP(pivote-fe) .le. 1.d0) then
                  pivot =f
                  pivote=fe
                  npivot=i
               end if
            end do
            if (pivot .eq. 0.d0) then
               loop=240
               write(error_msg,
     &             '(''[XLIN EQ]: '',
     &               ''matrix is singular at loop '',i3)') loop
               call LWPC_ERROR ('ERROR',error_msg)
            end if
            if (ppiv/pivot*DEXP(ppive-pivote) .gt. 1.d0)
     &         err=err*ppiv/pivot*DEXP(ppive-pivote)
            ppiv =pivot
            ppive=pivote
            if (npivot .ne. l) then
               q (npivot)=q (l)
               qe(npivot)=qe(l)
               j=irow(l)
               irow(l)=irow(npivot)
               irow(npivot)=j
               do i=1,n
                  t =a (l,i)
                  te=ae(l,i)
                  a (l,i)=a (npivot,i)
                  ae(l,i)=ae(npivot,i)
                  a (npivot,i)=t
                  ae(npivot,i)=te
               end do
            end if
            if (l .ne. n) then
               t =1.d0/a (l,l)
               te=    -ae(l,l)
               k=l+1
               m=l-1
               do i=k,n
                  if (m .ge. 1) then
                     do j=1,m
cxx                     a(l,i)=a(l,i)-a(l,j)*a(j,i)
                        call XC_ADD
     &                      (a(l,i),ae(l,i),a(l,i),ae(l,i),
     &                      -a(l,j)*a(j,i),ae(l,j)+ae(j,i))
                     end do
                  end if
                  a (l,i)=t *a (l,i)
                  ae(l,i)=te+ae(l,i)
                  call XC_NORME (a(l,i),ae(l,i))
               end do
            end if
         end do
         if (err .gt. 1.d-5)then
            write(error_msg,
     &          '(''[XLIN EQ]: '',
     &            ''Has decomposed an ill-conditioned matrix. '',
     &            ''The relative error is '',1pe12.2)') err
               call LWPC_ERROR ('WARNING',error_msg)
          endif
      end if

      j=irow(1)
      x (1)=b (j)/a (1,1)
      xe(1)=be(j)-ae(1,1)
      do i=2,n
         t =0.d0
         te=0.d0
         j=irow(i)
         k=i-1
         do l=1,k
cxx         x(i)=x(i)+a(i,l)*x(l)
            call XC_ADD
     &          (t,te,t,te,a(i,l)*x(l),ae(i,l)+xe(l))
         end do
cxx      x(i)=(b(j)-x(i))/a(i,i)
         call XC_ADD
     &       (t,te,b(j),be(j),-t,te)
         x (i)=t /a (i,i)
         xe(i)=te-ae(i,i)
      end do
      k=n-1
      do i=1,k
         j=n-i
         m=j+1
         t =x (j)
         te=xe(j)
         do l=m,n
cxx         x(j)=x(j)-a(j,l)*x(l)
            call XC_ADD
     &          (t,te,t,te,-a(j,l)*x(l),ae(j,l)+xe(l))
         end do
         x (j)=t
         xe(j)=te
      end do

      RETURN
      END      ! XLIN EQ


subroutine METRO(RES, H, N, CP, T, U, ITER)

! sead var
  INTEGER :: ns, ival(8), v(3)
  INTEGER, ALLOCATABLE :: seed(:)

! in var
  INTEGER :: N,ITER
  REAL*8 :: CP,T,U, H(N,N)
  !f2py intent(in) N, ITER, CP, T, U, H

! out var
  REAL*8 :: E0, RES(N,N)
  !f2py intent(out) RES

! other var
  INTEGER :: I,S1,S2,SIZE,OK,MC
  REAL*8 :: P,BE,DET, TT(N,N), E
  REAL*8, DIMENSION(:), ALLOCATABLE :: WORK,EIGE

! sead set
  call date_and_time(values=ival)
  v(1) = ival(8) + 2048*ival(7)
  v(2) = ival(6) + 64*ival(5)     ! value(4) isn't really 'random'
  v(3) = ival(3) + 32*ival(2) + 32*8*ival(1)
  call random_seed(size=ns)
  allocate(seed(ns))
  call random_seed()   ! Give the seed an implementation-depENDent kick
  call random_seed(get=seed)
  do i=1, ns
     seed(i) = seed(i) + v(mod(i-1, 3) + 1)
  ENDdo
  call random_seed(put=seed)
  deallocate(seed)

! main

  !WRITE(*,*)"T=", T, " CP=",cp, " N=", N, " U=", U
  SIZE=N
  ALLOCATE(WORK(3*SIZE))
  ALLOCATE(EIGE(SIZE))

  be=1.0/T

  TT=H
  call DSYEV('N', 'U', SIZE, TT, SIZE, EIGE, work, size*3, ok)
  E0=0

  DO I=1,SIZE
      E0=E0+LOG(1+EXP(-BE*(EIGE(I)-CP)))
  ENDDO
  E0=-T*E0

! main loop
  DO MC=1,ITER
    DO
      CALL RANDOM_NUMBER(P)
      S1=INT(P*SIZE)+1
      IF (abs(H(S1,S1))>0.001) THEN
        EXIT
      ENDIF
    END DO

    DO
      CALL RANDOM_NUMBER(P)
      S2=INT(P*SIZE)+1
      IF (H(S2,S2)==0) THEN
        EXIT
      ENDIF
    END DO

    TT=H
    TT(S1,S1)=0
    TT(S2,S2)=U

    call DSYEV('N', 'U', SIZE, TT, SIZE, EIGE, work, size*3, ok)
    E=0

    DO I=1,SIZE
        E=E+LOG(1+EXP(-BE*(EIGE(I)-CP)))
    ENDDO
    E=-T*E

    DET=E-E0

    IF (DET<0) THEN
      H(S1,S1)=0
      H(S2,S2)=U
      E0=E
    ELSE
      CALL RANDOM_NUMBER(P)
      IF (EXP((-DET)*be)>=P) THEN
        H(S1,S1)=0
        H(S2,S2)=U
        E0=E
      END IF
    END IF
  ENDDO
  RES=H

end subroutine


      SUBROUTINE RHS(YY,YP)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!   Provides right hand sides of eqns of motion
!!!   K.Travis
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      USE header_file
      IMPLICIT NONE

      INTEGER :: I, J, IP
      REAL(kind = double) :: XI,XJ,YI,YJ,XIJ, YIJ
      REAL(kind = double) :: R, RSQ, FACTOR, FORCE_MN,DELR
      REAL(kind = double) :: RATIO, FORCE_REP,SUMPXPY
      REAL(kind = double) :: RRR,RR6,RR12,FORCEIJ,PXYP,PXYK,PXYV
      REAL(kind = double) :: RDIF,RDIF2,RDIF3,RXX,RYY,RAI,RBI,RAJ,RBJ
      REAL(kind = double) :: ESUM,TK,DRIFT, SUMFP,SUMPP

      REAL(kind = double), DIMENSION(NEQ) ::  YY,YP
      REAL(kind = double), DIMENSION(N)   ::  FX,FY

      FX = (/ (I*0.0D0,I = 1,N) /)
      FY = (/ (I*0.0D0,I = 1,N) /)

!     store arguments into local arrays

      DO I = 1,N
        X(I)    = YY(I)
        Y(I)    = YY(I+N)
        PX(I)   = YY(I+N+N)
        PY(I)   = YY(I+N+N+N)
      END DO

!     compute the instantaneous temperature

      ESUM = 0.0D0
      PXYK = 0.0d0
      DO I = 1,N
          ESUM = ESUM + PX(I)**2/MASS(I) + PY(I)**2/MASS(I)
          PXYK = PXYK + PX(I)*PY(I)/MASS(I)
      END DO

      TK = ESUM/DEGFREE

! calculate pair forces
      PXYP = 0.0D0
      DO IP = 1, NPAIRS
        I = NI(IP)
        J = NJ(IP)
        XI = X(I)
        YI = Y(I)
        CALL CARTFRAC(XI,YI,RAI,RBI)
        XJ = X(J)
        YJ = Y(J)
        CALL CARTFRAC(XJ,YJ,RAJ,RBJ)
        RAJ = RAJ - ANINT(RAJ-RAI)
        RBJ = RBJ - ANINT(RBJ-RBI)
        CALL FRACCART(RAJ,RBJ,XJ,YJ)
        XIJ = XI - XJ
        YIJ = YI - YJ
        RSQ = XIJ*XIJ + YIJ*YIJ

        IF(RSQ < CUTSQ) THEN

          CALL PAIR_FORCE(RSQ,FORCEIJ)

          FX(I) = FX(I) + FORCEIJ*XIJ
          FY(I) = FY(I) + FORCEIJ*YIJ
          FX(J) = FX(J) - FORCEIJ*XIJ
          FY(J) = FY(J) - FORCEIJ*YIJ
          PXYP = PXYP + XIJ*YIJ*FORCEIJ
       END IF

      END DO

      PXYV = 0.5*(PXYP + PXYK)

!! compute the Gaussian constraint thermostat multiplier

      SELECT CASE (ITHERM) ! choose option depending on potential type

      CASE(1)   ! Gaussian thermostat

        SUMFP = 0.0D0
        SUMPP = 0.0D0
        SUMPXPY = 0.0D0
        DO I = 1,N
          SUMFP = SUMFP + FX(I)*PX(I) + FY(I)*PY(I)
          SUMPP = SUMPP + PX(I)*PX(I) + PY(I)*PY(I)
          SUMPXPY = SUMPXPY + PX(I)*PY(I)
        END DO
        ZETA = (SUMFP - SHEAR*SUMPXPY)/SUMPP
        DRIFT = BETA*(TK - TREQ)

      CASE(2)   ! Gaussian ergostat

        SUMPP = 0.0D0
        DO I = 1,N
          SUMPP = SUMPP + PX(I)*PX(I)/MASS(I) + PY(I)*PY(I)/MASS(I)
        END DO
        ZETA = -SHEAR*PXYV/SUMPP
        DRIFT = 0.0d0

      CASE DEFAULT

        ZETA = 0.0D0
        DRIFT = 0.0d0

      END SELECT

 !!! pack all first derivatives into a 1-D array

      DO I = 1, N
          YP(I)                  = PX(I)/MASS(I) + SHEAR*Y(I)
          YP(I+N)                = PY(I)/MASS(I)
          YP(I+N+N)              = FX(I) - (ZETA + DRIFT)*PX(I) - SHEAR*PY(I)
          YP(I+N+N+N)            = FY(I) - (ZETA + DRIFT)*PY(I)
      END DO

      END SUBROUTINE


c
c Copyright (C) 2002 Vanderbilt group
c This file is distributed under the terms of the GNU General Public
c License as described in the file 'License' in the current directory.
c
c----------------------------------------------------------------------
      SUBROUTINE EXCHPBE(rho,S,U,V,lgga,lpot,EX,VX)
c----------------------------------------------------------------------
C  PBE EXCHANGE FOR A SPIN-UNPOLARIZED ELECTRONIC SYSTEM
c  K Burke's modification of PW91 codes, May 14, 1996
c  Modified again by K. Burke, June 29, 1996, with simpler Fx(s)
c----------------------------------------------------------------------
c Programs implement functional in PBE paper, July 1996 version.
c
C Atomic units are used, so all energies are in hartrees and all
c distances in bohrs.
c 1 hartree=27.2116eV=627.5kcal/mol; 1bohr=0.529E-10m.
c----------------------------------------------------------------------
C  INPUT rho : DENSITY
C  INPUT S:  ABS(GRAD rho)/(2*KF*rho), where kf=(3 pi^2 rho)^(1/3)
C  INPUT U:  (GRAD rho)*GRAD(ABS(GRAD rho))/(rho**2 * (2*KF)**3)
C  INPUT V: (LAPLACIAN rho)/(rho*(2*KF)**2)
c   (for U,V, see PW86(24))
c  input lgga:  (=0=>don't put in gradient corrections, just LDA)
c  input lpot:  (=0=>don't get potential and don't need U and V)
C  OUTPUT:  EXCHANGE ENERGY PER ELECTRON (EX) AND POTENTIAL (VX)
c----------------------------------------------------------------------
c----------------------------------------------------------------------
c References:
c [a]J.P.~Perdew, K.~Burke, and M.~Ernzerhof, submiited to PRL, May96
c [b]J.P. Perdew and Y. Wang, Phys. Rev.  B {\bf 33},  8800  (1986);
c     {\bf 40},  3399  (1989) (E).
c----------------------------------------------------------------------
c----------------------------------------------------------------------
c Formulas:
c   	e_x[unif]=ax*rho^(4/3)  [LDA]
c ax = -0.75*(3/pi)^(1/3)
c	e_x[PBE]=e_x[unif]*FxPBE(s)
c	FxPBE(s)=1+uk-uk/(1+ul*s*s)                 [a](13)
c uk, ul defined after [a](13)
c----------------------------------------------------------------------
c----------------------------------------------------------------------
      IMPLICIT REAL*8 (A-H,O-Z)
      parameter(thrd=1.d0/3.d0,thrd4=4.d0/3.d0)
      parameter(pi=3.14159265358979323846264338327950d0)
      parameter(ax=-0.738558766382022405884230032680836d0)
      parameter(um=0.2195149727645171d0,uk=0.8040d0,ul=um/uk)
c----------------------------------------------------------------------
c----------------------------------------------------------------------
c construct LDA exchange energy density
      exunif = AX*rho**THRD
      if(lgga.eq.0)then
	ex=exunif
        vx=ex*thrd4
	return
      endif
c----------------------------------------------------------------------
c----------------------------------------------------------------------
c construct PBE enhancement factor
      S2 = S*S
      P0=1.d0+ul*S2
      FxPBE = 1d0+uk-uk/P0
      EX = exunif*FxPBE
      if(lpot.eq.0)return
c----------------------------------------------------------------------
c----------------------------------------------------------------------
C  ENERGY DONE. NOW THE POTENTIAL:
c  find first and second derivatives of Fx w.r.t s.
c  Fs=(1/s)*d FxPBE/ ds
c  Fss=d Fs/ds
      Fs=2.d0*uk*ul/(P0*P0)
      Fss=-4.d0*ul*S*Fs/P0
c----------------------------------------------------------------------
c----------------------------------------------------------------------
c calculate potential from [b](24)
      VX = exunif*(THRD4*FxPBE-(U-THRD4*S2*s)*FSS-V*FS)
      RETURN
      END
c----------------------------------------------------------------------
c######################################################################
c----------------------------------------------------------------------
      SUBROUTINE CORPBE(RS,ZET,T,UU,VV,WW,lgga,lpot,ec,vcup,vcdn,
     1                  H,DVCUP,DVCDN)
c----------------------------------------------------------------------
c  Official PBE correlation code. K. Burke, May 14, 1996.
C  INPUT: RS=SEITZ RADIUS=(3/4pi rho)^(1/3)
C       : ZET=RELATIVE SPIN POLARIZATION = (rhoup-rhodn)/rho
C       : t=ABS(GRAD rho)/(rho*2.*KS*G)  -- only needed for PBE
C       : UU=(GRAD rho)*GRAD(ABS(GRAD rho))/(rho**2 * (2*KS*G)**3)
C       : VV=(LAPLACIAN rho)/(rho * (2*KS*G)**2)
C       : WW=(GRAD rho)*(GRAD ZET)/(rho * (2*KS*G)**2
c       :  UU,VV,WW, only needed for PBE potential
c       : lgga=flag to do gga (0=>LSD only)
c       : lpot=flag to do potential (0=>energy only)
c  output: ec=lsd correlation energy from [a]
c        : vcup=lsd up correlation potential
c        : vcdn=lsd dn correlation potential
c        : h=NONLOCAL PART OF CORRELATION ENERGY PER ELECTRON
c        : dvcup=nonlocal correction to vcup
c        : dvcdn=nonlocal correction to vcdn
c----------------------------------------------------------------------
c----------------------------------------------------------------------
c References:
c [a] J.P.~Perdew, K.~Burke, and M.~Ernzerhof,
c     {\sl Generalized gradient approximation made simple}, sub.
c     to Phys. Rev.Lett. May 1996.
c [b] J. P. Perdew, K. Burke, and Y. Wang, {\sl Real-space cutoff
c     construction of a generalized gradient approximation:  The PW91
c     density functional}, submitted to Phys. Rev. B, Feb. 1996.
c [c] J. P. Perdew and Y. Wang, Phys. Rev. B {\bf 45}, 13244 (1992).
c----------------------------------------------------------------------
c----------------------------------------------------------------------
      IMPLICIT REAL*8 (A-H,O-Z)
c thrd*=various multiples of 1/3
c numbers for use in LSD energy spin-interpolation formula, [c](9).
c      GAM= 2^(4/3)-2
c      FZZ=f''(0)= 8/(9*GAM)
c numbers for construction of PBE
c      gamma=(1-log(2))/pi^2
c      bet=coefficient in gradient expansion for correlation, [a](4).
c      eta=small number to stop d phi/ dzeta from blowing up at
c          |zeta|=1.
      parameter(thrd=1.d0/3.d0,thrdm=-thrd,thrd2=2.d0*thrd)
      parameter(sixthm=thrdm/2.d0)
      parameter(thrd4=4.d0*thrd)
      parameter(GAM=0.5198420997897463295344212145565d0)
      parameter(fzz=8.d0/(9.d0*GAM))
      parameter(gamma=0.03109069086965489503494086371273d0)
      parameter(bet=0.06672455060314922d0,delt=bet/gamma)
      parameter(eta=1.d-12)
c----------------------------------------------------------------------
c----------------------------------------------------------------------
c find LSD energy contributions, using [c](10) and Table I[c].
c EU=unpolarized LSD correlation energy
c EURS=dEU/drs
c EP=fully polarized LSD correlation energy
c EPRS=dEP/drs
c ALFM=-spin stiffness, [c](3).
c ALFRSM=-dalpha/drs
c F=spin-scaling factor from [c](9).
c construct ec, using [c](8)
C     Modification by D. Vanderbilt 2/14/02: replace explicit
C     'dsqrt' by generic 'sqrt'; some compilers complained about
C     use of 'dsqrt'
C     rtrs=dsqrt(rs)
      rtrs=sqrt(rs)
      CALL gcor2(0.0310907D0,0.21370D0,7.5957D0,3.5876D0,1.6382D0,
     1    0.49294D0,rtrs,EU,EURS)
      CALL gcor2(0.01554535D0,0.20548D0,14.1189D0,6.1977D0,3.3662D0,
     1    0.62517D0,rtRS,EP,EPRS)
      CALL gcor2(0.0168869D0,0.11125D0,10.357D0,3.6231D0,0.88026D0,
     1    0.49671D0,rtRS,ALFM,ALFRSM)
      ALFC = -ALFM
      Z4 = ZET**4
      F=((1.D0+ZET)**THRD4+(1.D0-ZET)**THRD4-2.D0)/GAM
      EC = EU*(1.D0-F*Z4)+EP*F*Z4-ALFM*F*(1.D0-Z4)/FZZ
c----------------------------------------------------------------------
c----------------------------------------------------------------------
c LSD potential from [c](A1)
c ECRS = dEc/drs [c](A2)
c ECZET=dEc/dzeta [c](A3)
c FZ = dF/dzeta [c](A4)
      ECRS = EURS*(1.D0-F*Z4)+EPRS*F*Z4-ALFRSM*F*(1.D0-Z4)/FZZ
      FZ = THRD4*((1.D0+ZET)**THRD-(1.D0-ZET)**THRD)/GAM
      ECZET = 4.D0*(ZET**3)*F*(EP-EU+ALFM/FZZ)+FZ*(Z4*EP-Z4*EU
     1        -(1.D0-Z4)*ALFM/FZZ)
      COMM = EC -RS*ECRS/3.D0-ZET*ECZET
      VCUP = COMM + ECZET
      VCDN = COMM - ECZET
      if(lgga.eq.0)return
c----------------------------------------------------------------------
c----------------------------------------------------------------------
c PBE correlation energy
c G=phi(zeta), given after [a](3)
c DELT=bet/gamma
c B=A of [a](8)
      G=((1.d0+ZET)**thrd2+(1.d0-ZET)**thrd2)/2.d0
      G3 = G**3
      PON=-EC/(G3*gamma)
      B = DELT/(DEXP(PON)-1.D0)
      B2 = B*B
      T2 = T*T
      T4 = T2*T2
      RS2 = RS*RS
      RS3 = RS2*RS
      Q4 = 1.D0+B*T2
      Q5 = 1.D0+B*T2+B2*T4
      H = G3*(BET/DELT)*DLOG(1.D0+DELT*Q4*T2/Q5)
      if(lpot.eq.0)return
c----------------------------------------------------------------------
c----------------------------------------------------------------------
C ENERGY DONE. NOW THE POTENTIAL, using appendix E of [b].
      G4 = G3*G
      T6 = T4*T2
      RSTHRD = RS/3.D0
      GZ=(((1.d0+zet)**2+eta)**sixthm-
     1((1.d0-zet)**2+eta)**sixthm)/3.d0
      FAC = DELT/B+1.D0
      BG = -3.D0*B2*EC*FAC/(BET*G4)
      BEC = B2*FAC/(BET*G3)
      Q8 = Q5*Q5+DELT*Q4*Q5*T2
      Q9 = 1.D0+2.D0*B*T2
      hB = -BET*G3*B*T6*(2.D0+B*T2)/Q8
      hRS = -RSTHRD*hB*BEC*ECRS
      FACT0 = 2.D0*DELT-6.D0*B
      FACT1 = Q5*Q9+Q4*Q9*Q9
      hBT = 2.D0*BET*G3*T4*((Q4*Q5*FACT0-DELT*FACT1)/Q8)/Q8
      hRST = RSTHRD*T2*hBT*BEC*ECRS
      hZ = 3.D0*GZ*h/G + hB*(BG*GZ+BEC*ECZET)
      hT = 2.d0*BET*G3*Q9/Q8
      hZT = 3.D0*GZ*hT/G+hBT*(BG*GZ+BEC*ECZET)
      FACT2 = Q4*Q5+B*T2*(Q4*Q9+Q5)
      FACT3 = 2.D0*B*Q5*Q9+DELT*FACT2
      hTT = 4.D0*BET*G3*T*(2.D0*B/Q8-(Q9*FACT3/Q8)/Q8)
      COMM = H+HRS+HRST+T2*HT/6.D0+7.D0*T2*T*HTT/6.D0
      PREF = HZ-GZ*T2*HT/G
      FACT5 = GZ*(2.D0*HT+T*HTT)/G
      COMM = COMM-PREF*ZET-UU*HTT-VV*HT-WW*(HZT-FACT5)
      DVCUP = COMM + PREF
      DVCDN = COMM - PREF
      RETURN
      END
c----------------------------------------------------------------------
c######################################################################
c----------------------------------------------------------------------
      SUBROUTINE GCOR2(A,A1,B1,B2,B3,B4,rtrs,GG,GGRS)
c slimmed down version of GCOR used in PW91 routines, to interpolate
c LSD correlation energy, as given by (10) of
c J. P. Perdew and Y. Wang, Phys. Rev. B {\bf 45}, 13244 (1992).
c K. Burke, May 11, 1996.
      IMPLICIT REAL*8 (A-H,O-Z)
      Q0 = -2.D0*A*(1.D0+A1*rtrs*rtrs)
      Q1 = 2.D0*A*rtrs*(B1+rtrs*(B2+rtrs*(B3+B4*rtrs)))
      Q2 = DLOG(1.D0+1.D0/Q1)
      GG = Q0*Q2
      Q3 = A*(B1/rtrs+2.D0*B2+rtrs*(3.D0*B3+4.D0*B4*rtrs))
      GGRS = -2.D0*A*A1*Q2-Q0*Q3/(Q1*(1.d0+Q1))
      RETURN
      END


      SUBROUTINE INTEGRATE( TIN, TOUT )

      INCLUDE 'KPP_ROOT_params.h'
      INCLUDE 'KPP_ROOT_global.h'

C TIN - Start Time
      KPP_REAL TIN
C TOUT - End Time
      KPP_REAL TOUT

      INTEGER    INFO(5)

      EXTERNAL FUNC_CHEM, JAC_CHEM

      INFO(1) = Autonomous

      CALL ROS4(NVAR,TIN,TOUT,STEPMIN,STEPMAX,
     +                   STEPMIN,VAR,ATOL,RTOL,
     +                   Info,FUNC_CHEM,JAC_CHEM)

      RETURN
      END

      SUBROUTINE ROS4(N,T,Tnext,Hmin,Hmax,Hstart,
     +                   y,AbsTol,RelTol,
     +                   Info,FUNC_CHEM,JAC_CHEM)
      IMPLICIT NONE
      INCLUDE 'KPP_ROOT_params.h'
      INCLUDE 'KPP_ROOT_sparse.h'
C
C  Four Stages, Fourth Order L-stable Rosenbrock Method,
C     with embedded L-stable, third order method for error control
C     Simplified version of E. Hairer's atmros4; the coefficients are slightly
C     different
C
C
C  INPUT ARGUMENTS:
C     y = Vector of (NVAR) concentrations, contains the
C         initial values on input
C     [T, Tnext] = the integration interval
C     Hmin, Hmax = lower and upper bounds for the selected step-size.
C          Note that for Step = Hmin the current computed
C          solution is unconditionally accepted by the error
C          control mechanism.
C     AbsTol, RelTol = (NVAR) dimensional vectors of
C          componentwise absolute and relative tolerances.
C     FUNC_CHEM = name of routine of derivatives. KPP syntax.
C          See the header below.
C     JAC_CHEM = name of routine that computes the Jacobian, in
C          sparse format. KPP syntax. See the header below.
C     Info(1) = 1  for  Autonomous   system
C             = 0  for nonAutonomous system
C
C  OUTPUT ARGUMENTS:
C     y = the values of concentrations at Tend.
C     T = equals TENDon output.
C     Info(2) = # of FUNC_CHEM CALLs.
C     Info(3) = # of JAC_CHEM CALLs.
C     Info(4) = # of accepted steps.
C     Info(5) = # of rejected steps.
C     Hstart = The last accepted stepsize
C
C    Adrian Sandu, December 2001
C
      KPP_REAL K1(NVAR), K2(NVAR), K3(NVAR), K4(NVAR)
      KPP_REAL F1(NVAR)
      KPP_REAL DFDT(NVAR)
      KPP_REAL JAC(LU_NONZERO)
      KPP_REAL Hmin,Hmax,Hstart
      KPP_REAL y(NVAR), ynew(NVAR)
      KPP_REAL AbsTol(NVAR), RelTol(NVAR)
      KPP_REAL T, Tnext, H, Hnew, Tplus
      KPP_REAL elo,ghinv,uround
      KPP_REAL ERR, factor, facmax
      KPP_REAL w, e, dround, tau
      KPP_REAL hgam1, hgam2, hgam3, hgam4
      KPP_REAL hc21, hc31, hc32, hc41, hc42, hc43

      INTEGER    n,nfcn,njac,Naccept,Nreject,i,j,ier
      INTEGER    Info(5)
      LOGICAL    IsReject, Autonomous
      EXTERNAL   FUNC_CHEM, JAC_CHEM

C   The method coefficients
      DOUBLE PRECISION gamma, gamma2, gamma3, gamma4
      PARAMETER ( gamma  =  0.5728200000000000D+00 )
      PARAMETER ( gamma2 = -0.1769193891319233D+01 )
      PARAMETER ( gamma3 =  0.7592633437920482D+00 )
      PARAMETER ( gamma4 = -0.1049021087100450D+00 )
      DOUBLE PRECISION a21, a31, a32, a41, a42, a43
      PARAMETER (  a21 = 0.2000000000000000D+01  )
      PARAMETER (  a31 = 0.1867943637803922D+01  )
      PARAMETER (  a32 = 0.2344449711399156D+00  )
      DOUBLE PRECISION alpha2, alpha3
      PARAMETER (  alpha2  = 0.1145640000000000D+01  )
      PARAMETER (  alpha3  = 0.6552168638155900D+00  )
      DOUBLE PRECISION c21, c31, c32, c41, c42, c43
      PARAMETER (  c21  = -0.7137615036412310D+01  )
      PARAMETER (  c31  =  0.2580708087951457D+01  )
      PARAMETER (  c32  =  0.6515950076447975D+00  )
      PARAMETER (  c41  = -0.2137148994382534D+01  )
      PARAMETER (  c42  = -0.3214669691237626D+00  )
      PARAMETER (  c43  = -0.6949742501781779D+00  )
      DOUBLE PRECISION b1, b2, b3, b4
      PARAMETER (  b1 = 0.2255570073418735D+01  )
      PARAMETER (  b2 = 0.2870493262186792D+00  )
      PARAMETER (  b3 = 0.4353179431840180D+00  )
      PARAMETER (  b4 = 0.1093502252409163D+01 )
      DOUBLE PRECISION d1, d2, d3, d4
      PARAMETER (  d1 = -0.2815431932141155D+00  )
      PARAMETER (  d2 = -0.7276199124938920D-01  )
      PARAMETER (  d3 = -0.1082196201495311D+00  )
      PARAMETER (  d4 = -0.1093502252409163D+01  )

c     Initialization of counters, etc.
      Autonomous = Info(1) .EQ. 1
      uround = 1.d-15
      dround = DSQRT(uround)
      IF (Hmax.le.0.D0) THEN
          Hmax = DABS(Tnext-T)
      END IF
      H = DMAX1(1.d-8, Hstart)
      Tplus = T
      IsReject = .false.
      Naccept  = 0
      Nreject  = 0
      Nfcn     = 0
      Njac     = 0

C === Starting the time loop ===
 10    CONTINUE

       Tplus = T + H
       IF ( Tplus .gt. Tnext ) THEN
          H = Tnext - T
          Tplus = Tnext
       END IF

C              Initial Function and Jacobian values
       CALL FUNC_CHEM( T, y, F1 )
       CALL JAC_CHEM( T, y, JAC )

C              The time derivative for non-Autonomous case
       IF (.not. Autonomous) THEN
         tau = DSIGN(dround*DMAX1( 1.0d-6, DABS(T) ), T)
         CALL FUNC_CHEM( T+tau, y, K2 )
         nfcn=nfcn+1
         DO 20 j = 1,NVAR
           DFDT(j) = ( K2(j)-F1(j) )/tau
 20      CONTINUE
       END IF

C              Form the Prediction matrix and compute its LU factorization
       Njac = Njac+1
       ghinv = 1.0d0/(gamma*H)
       DO 30 j=1,LU_NONZERO
         JAC(j) = -JAC(j)
 30    CONTINUE
       DO 40 j=1,NVAR
         JAC(LU_DIAG(j)) = JAC(LU_DIAG(j)) + ghinv
 40    CONTINUE
       CALL KppDecomp (JAC, ier)
C
       IF (ier.ne.0) THEN
         IF ( H.gt.Hmin) THEN
            H = 5.0d-1*H
            GO TO 10
         ELSE
            PRINT *,'ROS4: Singular factorization at T=',T,'; H=',H
            STOP
         END IF
       END IF

C ------------ STAGE 1-------------------------
       DO 50 j = 1,NVAR
         K1(j) =  F1(j)
 50    CONTINUE
       IF (.NOT. Autonomous) THEN
          hgam1 = H*gamma
	  DO 60 j=1,NVAR
	    K1(j) = K1(j) + hgam1*DFDT(j)
 60	  CONTINUE
       END IF
       CALL KppSolve (JAC, K1)

C ----------- STAGE 2 -------------------------
       DO 70 j = 1,NVAR
         ynew(j) = y(j) + a21*K1(j)
 70    CONTINUE
       CALL FUNC_CHEM( T+alpha2*H, ynew, F1)
       nfcn=nfcn+1
       hc21 = c21/H
       DO 80 j = 1,NVAR
         K2(j) = F1(j) + hc21*K1(j)
 80    CONTINUE
       IF (.NOT. Autonomous) THEN
         hgam2 = H*gamma2
	 DO 90 j=1,NVAR
	    K2(j) = K2(j) + hgam2*DFDT(j)
 90	 CONTINUE
       END IF
       CALL KppSolve (JAC, K2)

C ------------ STAGE 3 -------------------------
       DO 100 j = 1,NVAR
         ynew(j) = y(j) + a31*K1(j) + a32*K2(j)
 100   CONTINUE
       CALL FUNC_CHEM( T+alpha3*H, ynew, F1)
       nfcn=nfcn+1
       hc31 = c31/H
       hc32 = c32/H
       DO 110 j = 1,NVAR
         K3(j) = F1(j) + hc31*K1(j) + hc32*K2(j)
 110   CONTINUE
       IF (.NOT. Autonomous) THEN
         hgam3 = H*gamma3
	 DO 120 j=1,NVAR
	    K3(j) = K3(j) + hgam3*DFDT(j)
 120     CONTINUE
       END IF
       CALL KppSolve (JAC, K3)

C ------------ STAGE 4 -------------------------
C              Note: uses the same function value as stage 3
       hc41 = c41/H
       hc42 = c42/H
       hc43 = c43/H
       DO 140 j = 1,NVAR
         K4(j) = F1(j) + hc41*K1(j) + hc42*K2(j) + hc43*K3(j)
 140   CONTINUE
       IF (.NOT. Autonomous) THEN
          hgam4 = H*gamma4
	  DO 150 j=1,NVAR
	    K4(j) = K4(j) + hgam4*DFDT(j)
 150      CONTINUE
       END IF
       CALL KppSolve (JAC, K4)

C ---- The Solution ---
       DO 160 j = 1,NVAR
         ynew(j) = y(j) + b1*K1(j) + b2*K2(j) + b3*K3(j) + b4*K4(j)
 160   CONTINUE

C ====== Error estimation ========

        ERR=0.d0
        DO 170 j = 1,NVAR
           w = AbsTol(j) + RelTol(j)*DMAX1(DABS(y(j)),DABS(ynew(j)))
	   e = d1*K1(j) + d2*K2(j) + d3*K3(j) + d4*K4(j)
           ERR = ERR + ( e/w )**2
 170    CONTINUE
        ERR = DMAX1( uround, DSQRT( ERR/NVAR ) )

C ======= Choose the stepsize ===============================

        elo    = 4.0D0 ! estimator local order
        factor = DMAX1(2.0D-1,DMIN1(6.0D0,ERR**(1.0D0/elo)/.9D0))
        Hnew   = DMIN1(Hmax,DMAX1(Hmin, H/factor))

C ======= Rejected/Accepted Step ============================

        IF ( (ERR.gt.1).and.(H.gt.Hmin) ) THEN
          IsReject = .true.
	  H = DMIN1(H/10,Hnew)
          Nreject  = Nreject+1
        ELSE
          DO 180 i=1,NVAR
             y(i)  = ynew(i)
 180      CONTINUE
          T = Tplus
	  IF (.NOT.IsReject) THEN
	      H = Hnew   ! Do not increase stepsize if previos step was rejected
	  END IF
          IsReject = .false.
          Naccept = Naccept+1
        END IF

C ======= End of the time loop ===============================
      IF ( T .lt. Tnext ) GO TO 10

C ======= Output Information =================================
      Info(2) = Nfcn
      Info(3) = Njac
      Info(4) = Naccept
      Info(5) = Nreject
      Hstart  = H

      RETURN
      END

      SUBROUTINE FUNC_CHEM( T, Y, P )
      INCLUDE 'KPP_ROOT_params.h'
      INCLUDE 'KPP_ROOT_global.h'
      KPP_REAL   T, Told
      KPP_REAL   Y(NVAR), P(NVAR)
      Told = TIME
      TIME = T
      CALL Update_SUN()
      CALL Update_RCONST()
      CALL Fun( Y,  FIX, RCONST, P )
      TIME = Told
      RETURN
      END

      SUBROUTINE JAC_CHEM( T, Y, J )
      INCLUDE 'KPP_ROOT_params.h'
      INCLUDE 'KPP_ROOT_global.h'
      KPP_REAL   Told, T
      KPP_REAL   Y(NVAR), J(LU_NONZERO)
      Told = TIME
      TIME = T
      CALL Update_SUN()
      CALL Update_RCONST()
      CALL Jac_SP( Y,  FIX, RCONST, J )
      TIME = Told
      RETURN
      END


! { dg-do compile }
!
! PR fortran/47507
!
! PURE procedures: Allow arguments w/o INTENT if they are VALUE
!

pure function f(x)
  real, VALUE :: x
  real :: f
  f = sin(x)
end function f

pure subroutine sub(x)
  real, VALUE :: x
end subroutine sub


MODULE DIFFERENCE
  IMPLICIT NONE

  CONTAINS

  SUBROUTINE Fdiff(a, n)
    INTEGER, INTENT(IN) :: a(:), n
    INTEGER :: b(SIZE(a))
    INTEGER :: i, j, arraysize

    b = a
    arraysize = SIZE(b)
    DO i = arraysize-1, arraysize-n, -1
      DO j = 1, i
        b(j) = b(j+1) - b(j)
      END DO
    END DO
    WRITE (*,*) b(1:arraysize-n)
  END SUBROUTINE Fdiff
END MODULE DIFFERENCE


module mini_test

    use mini_test_kinds
    private

    public :: check, is_close, disp
    public :: optval, to_string

    interface
        !> Version: experimental
        !>
        !> `warn == .true.`(default): if `condition == .false.` then error stop `msg`;
        !> `warn == .false.`        : if `condition == .false.` then print      `msg`.
        module subroutine check(condition, msg, warn)
            logical,          intent(in)            :: condition
            character(len=*), intent(in)            :: msg
            logical,          intent(in), optional  :: warn
        end subroutine check
    end interface

    !> Version: experimental
    !>
    !> Determines whether the values of `a` and `b` are close.
    interface is_close
        elemental module function is_close_rsp(a, b, rtol, atol) result(bool)
            real(sp), intent(in) :: a, b
            real(sp), intent(in), optional :: rtol, atol
            logical :: bool
        end function is_close_rsp
        elemental module function is_close_rdp(a, b, rtol, atol) result(bool)
            real(dp), intent(in) :: a, b
            real(dp), intent(in), optional :: rtol, atol
            logical :: bool
        end function is_close_rdp
        elemental module function is_close_rqp(a, b, rtol, atol) result(bool)
            real(qp), intent(in) :: a, b
            real(qp), intent(in), optional :: rtol, atol
            logical :: bool
        end function is_close_rqp
        elemental module function is_close_csp(a, b, rtol, atol) result(bool)
            complex(sp), intent(in) :: a, b
            real(sp), intent(in), optional :: rtol, atol
            logical :: bool
        end function is_close_csp
        elemental module function is_close_cdp(a, b, rtol, atol) result(bool)
            complex(dp), intent(in) :: a, b
            real(dp), intent(in), optional :: rtol, atol
            logical :: bool
        end function is_close_cdp
        elemental module function is_close_cqp(a, b, rtol, atol) result(bool)
            complex(qp), intent(in) :: a, b
            real(qp), intent(in), optional :: rtol, atol
            logical :: bool
        end function is_close_cqp
    end interface is_close

    !> Version: experimental
    !>
    !> if `x` is presented, then `x_ = x`;
    !> if not,              then `x_ = default`.
    interface optval
        elemental module function optval_rsp(x, default) result(x_)
            real(sp), intent(in), optional            :: x
            real(sp), intent(in)                      :: default
            real(sp)                                  :: x_
        end function optval_rsp
        elemental module function optval_rdp(x, default) result(x_)
            real(dp), intent(in), optional            :: x
            real(dp), intent(in)                      :: default
            real(dp)                                  :: x_
        end function optval_rdp
        elemental module function optval_rqp(x, default) result(x_)
            real(qp), intent(in), optional            :: x
            real(qp), intent(in)                      :: default
            real(qp)                                  :: x_
        end function optval_rqp
        elemental module function optval_ll1(x, default) result(x_)
            logical, intent(in), optional            :: x
            logical, intent(in)                      :: default
            logical                                  :: x_
        end function optval_ll1
        pure module function optval_character(x, default) result(x_)
            character(len=*), intent(in), optional  :: x
            character(len=*), intent(in)            :: default
            character(len=:), allocatable           :: x_
        end function optval_character
    end interface optval

    !> version: experimental
    !>
    !> Display a scalar, vector or matrix.
    interface disp
        module subroutine disp_0_rsp(value, header, brief)
            real(sp), intent(in) :: value
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_0_rsp
        module subroutine disp_1_rsp(value, header, brief)
            real(sp), intent(in) :: value(:)
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_1_rsp
        module subroutine disp_2_rsp(value, header, brief)
            real(sp), intent(in) :: value(:,:)
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_2_rsp
        module subroutine disp_0_rdp(value, header, brief)
            real(dp), intent(in) :: value
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_0_rdp
        module subroutine disp_1_rdp(value, header, brief)
            real(dp), intent(in) :: value(:)
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_1_rdp
        module subroutine disp_2_rdp(value, header, brief)
            real(dp), intent(in) :: value(:,:)
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_2_rdp
        module subroutine disp_0_rqp(value, header, brief)
            real(qp), intent(in) :: value
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_0_rqp
        module subroutine disp_1_rqp(value, header, brief)
            real(qp), intent(in) :: value(:)
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_1_rqp
        module subroutine disp_2_rqp(value, header, brief)
            real(qp), intent(in) :: value(:,:)
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_2_rqp
        module subroutine disp_0_iint8(value, header, brief)
            integer(int8), intent(in) :: value
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_0_iint8
        module subroutine disp_1_iint8(value, header, brief)
            integer(int8), intent(in) :: value(:)
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_1_iint8
        module subroutine disp_2_iint8(value, header, brief)
            integer(int8), intent(in) :: value(:,:)
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_2_iint8
        module subroutine disp_0_iint16(value, header, brief)
            integer(int16), intent(in) :: value
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_0_iint16
        module subroutine disp_1_iint16(value, header, brief)
            integer(int16), intent(in) :: value(:)
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_1_iint16
        module subroutine disp_2_iint16(value, header, brief)
            integer(int16), intent(in) :: value(:,:)
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_2_iint16
        module subroutine disp_0_iint32(value, header, brief)
            integer(int32), intent(in) :: value
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_0_iint32
        module subroutine disp_1_iint32(value, header, brief)
            integer(int32), intent(in) :: value(:)
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_1_iint32
        module subroutine disp_2_iint32(value, header, brief)
            integer(int32), intent(in) :: value(:,:)
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_2_iint32
        module subroutine disp_0_iint64(value, header, brief)
            integer(int64), intent(in) :: value
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_0_iint64
        module subroutine disp_1_iint64(value, header, brief)
            integer(int64), intent(in) :: value(:)
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_1_iint64
        module subroutine disp_2_iint64(value, header, brief)
            integer(int64), intent(in) :: value(:,:)
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_2_iint64
        module subroutine disp_0_csp(value, header, brief)
            complex(sp), intent(in) :: value
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_0_csp
        module subroutine disp_1_csp(value, header, brief)
            complex(sp), intent(in) :: value(:)
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_1_csp
        module subroutine disp_2_csp(value, header, brief)
            complex(sp), intent(in) :: value(:,:)
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_2_csp
        module subroutine disp_0_cdp(value, header, brief)
            complex(dp), intent(in) :: value
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_0_cdp
        module subroutine disp_1_cdp(value, header, brief)
            complex(dp), intent(in) :: value(:)
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_1_cdp
        module subroutine disp_2_cdp(value, header, brief)
            complex(dp), intent(in) :: value(:,:)
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_2_cdp
        module subroutine disp_0_cqp(value, header, brief)
            complex(qp), intent(in) :: value
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_0_cqp
        module subroutine disp_1_cqp(value, header, brief)
            complex(qp), intent(in) :: value(:)
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_1_cqp
        module subroutine disp_2_cqp(value, header, brief)
            complex(qp), intent(in) :: value(:,:)
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_2_cqp
        module subroutine disp_0_llk(value, header, brief)
            logical(lk), intent(in) :: value
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_0_llk
        module subroutine disp_1_llk(value, header, brief)
            logical(lk), intent(in) :: value(:)
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_1_llk
        module subroutine disp_2_llk(value, header, brief)
            logical(lk), intent(in) :: value(:,:)
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_2_llk
        module subroutine disp_0_lc_bool(value, header, brief)
            logical(c_bool), intent(in) :: value
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_0_lc_bool
        module subroutine disp_1_lc_bool(value, header, brief)
            logical(c_bool), intent(in) :: value(:)
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_1_lc_bool
        module subroutine disp_2_lc_bool(value, header, brief)
            logical(c_bool), intent(in) :: value(:,:)
            character(len=*), intent(in), optional :: header
            logical, intent(in), optional :: brief
        end subroutine disp_2_lc_bool
        module subroutine disp_character(value, header, brief)
            character(len=*), intent(in), optional :: value
            character(len=*), intent(in), optional :: header
            logical,          intent(in), optional :: brief
        end subroutine disp_character
    end interface disp

    !> Version: experimental
    !>
    !> Format or transfer other types as a string.
    interface to_string
        pure module function to_string_r_sp(value, format) result(string)
            real(sp), intent(in) :: value
            character(len=*), intent(in), optional :: format
            character(len=:), allocatable          :: string
        end function to_string_r_sp
        pure module function to_string_r_dp(value, format) result(string)
            real(dp), intent(in) :: value
            character(len=*), intent(in), optional :: format
            character(len=:), allocatable          :: string
        end function to_string_r_dp
        pure module function to_string_r_qp(value, format) result(string)
            real(qp), intent(in) :: value
            character(len=*), intent(in), optional :: format
            character(len=:), allocatable          :: string
        end function to_string_r_qp
        pure module function to_string_c_sp(value, format) result(string)
            complex(sp), intent(in) :: value
            character(len=*), intent(in), optional :: format
            character(len=:), allocatable          :: string
        end function to_string_c_sp
        pure module function to_string_c_dp(value, format) result(string)
            complex(dp), intent(in) :: value
            character(len=*), intent(in), optional :: format
            character(len=:), allocatable          :: string
        end function to_string_c_dp
        pure module function to_string_c_qp(value, format) result(string)
            complex(qp), intent(in) :: value
            character(len=*), intent(in), optional :: format
            character(len=:), allocatable          :: string
        end function to_string_c_qp
        pure module function to_string_1_i_int8(value) result(string)
            integer(int8), intent(in) :: value
            character(len=:), allocatable :: string
        end function to_string_1_i_int8
        pure module function to_string_2_i_int8(value, format) result(string)
            integer(int8), intent(in) :: value
            character(len=*), intent(in)  :: format
            character(len=:), allocatable :: string
        end function to_string_2_i_int8
        pure module function to_string_1_i_int16(value) result(string)
            integer(int16), intent(in) :: value
            character(len=:), allocatable :: string
        end function to_string_1_i_int16
        pure module function to_string_2_i_int16(value, format) result(string)
            integer(int16), intent(in) :: value
            character(len=*), intent(in)  :: format
            character(len=:), allocatable :: string
        end function to_string_2_i_int16
        pure module function to_string_1_i_int32(value) result(string)
            integer(int32), intent(in) :: value
            character(len=:), allocatable :: string
        end function to_string_1_i_int32
        pure module function to_string_2_i_int32(value, format) result(string)
            integer(int32), intent(in) :: value
            character(len=*), intent(in)  :: format
            character(len=:), allocatable :: string
        end function to_string_2_i_int32
        pure module function to_string_1_i_int64(value) result(string)
            integer(int64), intent(in) :: value
            character(len=:), allocatable :: string
        end function to_string_1_i_int64
        pure module function to_string_2_i_int64(value, format) result(string)
            integer(int64), intent(in) :: value
            character(len=*), intent(in)  :: format
            character(len=:), allocatable :: string
        end function to_string_2_i_int64
        pure module function to_string_1_l_lk(value) result(string)
            logical(lk), intent(in) :: value
            character(len=1) :: string
        end function to_string_1_l_lk
        pure module function to_string_2_l_lk(value, format) result(string)
            logical(lk), intent(in) :: value
            character(len=*), intent(in)  :: format
            character(len=:), allocatable :: string
        end function to_string_2_l_lk
        pure module function to_string_1_l_c_bool(value) result(string)
            logical(c_bool), intent(in) :: value
            character(len=1) :: string
        end function to_string_1_l_c_bool
        pure module function to_string_2_l_c_bool(value, format) result(string)
            logical(c_bool), intent(in) :: value
            character(len=*), intent(in)  :: format
            character(len=:), allocatable :: string
        end function to_string_2_l_c_bool
    end interface to_string

end module mini_test