      SUBROUTINE AB13ED( N, A, LDA, LOW, HIGH, TOL, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To estimate beta(A), the 2-norm distance from a real matrix A to
C     the nearest complex matrix with an eigenvalue on the imaginary
C     axis. The estimate is given as
C
C            LOW <= beta(A) <= HIGH,
C
C     where either
C
C            (1 + TOL) * LOW >= HIGH,
C
C     or
C
C            LOW = 0   and   HIGH = delta,
C
C     and delta is a small number approximately equal to the square root
C     of machine precision times the Frobenius norm (Euclidean norm)
C     of A. If A is stable in the sense that all eigenvalues of A lie
C     in the open left half complex plane, then beta(A) is the distance
C     to the nearest unstable complex matrix, i.e., the complex
C     stability radius.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             matrix A.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     LOW     (output) DOUBLE PRECISION
C             A lower bound for beta(A).
C
C     HIGH    (output) DOUBLE PRECISION
C             An upper bound for beta(A).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             Specifies the accuracy with which LOW and HIGH approximate
C             beta(A). If the user sets TOL to be less than SQRT(EPS),
C             where EPS is the machine precision (see LAPACK Library
C             Routine DLAMCH), then the tolerance is taken to be
C             SQRT(EPS).
C             The recommended value is TOL = 9, which gives an estimate
C             of beta(A) correct to within an order of magnitude.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX( 1, 3*N*(N+1) ).
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the QR algorithm (LAPACK Library routine DHSEQR)
C                   fails to converge; this error is very rare.
C
C     METHOD
C
C     Let beta(A) be the 2-norm distance from a real matrix A to the
C     nearest complex matrix with an eigenvalue on the imaginary axis.
C     It is known that beta(A) = minimum of the smallest singular
C     value of (A - jwI), where I is the identity matrix and j**2 = -1,
C     and the minimum is taken over all real w.
C     The algorithm computes a lower bound LOW and an upper bound HIGH
C     for beta(A) by a bisection method in the following way. Given a
C     non-negative real number sigma, the Hamiltonian matrix H(sigma)
C     is constructed:
C
C                       |   A      -sigma*I |     | A   G  |
C           H(sigma) =  |                   | :=  |        | .
C                       | sigma*I    -A'    |     | F  -A' |
C
C     It can be shown [1] that H(sigma) has an eigenvalue whose real
C     part is zero if and only if sigma >= beta. Any lower and upper
C     bounds on beta(A) can be improved by choosing a number between
C     them and checking to see if H(sigma) has an eigenvalue with zero
C     real part.  This decision is made by computing the eigenvalues of
C     H(sigma) using the square reduced algorithm of Van Loan [2].
C
C     REFERENCES
C
C     [1] Byers, R.
C         A bisection method for measuring the distance of a stable
C         matrix to the unstable matrices.
C         SIAM J. Sci. Stat. Comput., Vol. 9, No. 5, pp. 875-880, 1988.
C
C     [2] Van Loan, C.F.
C         A symplectic method for approximating all the eigenvalues of a
C         Hamiltonian matrix.
C         Linear Algebra and its Applications, Vol 61, 233-251, 1984.
C
C     NUMERICAL ASPECTS
C
C     Due to rounding errors the computed values of LOW and HIGH can be
C     proven to satisfy
C
C            LOW - p(n) * sqrt(e) * norm(A) <= beta(A)
C     and
C            beta(A) <= HIGH + p(n) * sqrt(e) * norm(A),
C
C     where p(n) is a modest polynomial of degree 3, e is the machine
C     precision and norm(A) is the Frobenius norm of A, see [1].
C     The recommended value for TOL is 9 which gives an estimate of
C     beta(A) correct to within an order of magnitude.
C     AB13ED requires approximately 38*N**3 flops for TOL = 9.
C
C     CONTRIBUTOR
C
C     R. Byers, the routines BISEC and BISEC0 (January, 1995).
C
C     REVISIONS
C
C     Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999.
C     V. Sima, Research Institute for Informatics, Bucharest, Jan. 2003.
C
C     KEYWORDS
C
C     Distances, eigenvalue, eigenvalue perturbation, norms, stability
C     radius.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      DOUBLE PRECISION  HIGH, LOW, TOL
      INTEGER           INFO, LDA, LDWORK, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), DWORK(*)
C     .. Local Scalars ..
      INTEGER           I, IA2, IAA, IGF, IHI, ILO, IWI, IWK, IWR,
     $                  JWORK, MINWRK, N2
      DOUBLE PRECISION  ANRM, SEPS, SFMN, SIGMA, TAU, TEMP, TOL1, TOL2
      LOGICAL           RNEG, SUFWRK
C     .. Local Arrays ..
      DOUBLE PRECISION  DUMMY(1), DUMMY2(1,1)
C     .. External Functions ..
      DOUBLE PRECISION  DLAMCH, DLANGE
      EXTERNAL          DLAMCH, DLANGE
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEBAL, DGEMM, DHSEQR, DLACPY, DSYMM,
     $                  DSYMV, MA02ED, MB04ZD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DBLE, MAX, SQRT
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO   = 0
      MINWRK = 3*N*( N + 1 )
C
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -3
      ELSE IF( LDWORK.LT.MAX( 1, MINWRK ) ) THEN
         INFO = -8
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB13ED', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      LOW = ZERO
      IF ( N.EQ.0 ) THEN
         HIGH = ZERO
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Indices for splitting the work array.
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.)
C
      N2  = N*N
      IGF = 1
      IA2 = IGF + N2 + N
      IAA = IA2 + N2
      IWK = IAA + N2
      IWR = IAA
      IWI = IWR + N
C
      SUFWRK = LDWORK-IWK.GE.N2
C
C     Computation of the tolerances and the treshold for termination of
C     the bisection method. SEPS is the square root of the machine
C     precision.
C
      SFMN = DLAMCH( 'Safe minimum' )
      SEPS = SQRT( DLAMCH( 'Epsilon' ) )
      TAU  = ONE + MAX( TOL, SEPS )
      ANRM = DLANGE( 'Frobenius', N, N, A, LDA, DWORK )
      TOL1 = SEPS * ANRM
      TOL2 = TOL1 * DBLE( 2*N )
C
C     Initialization of the bisection method.
C
      HIGH = ANRM
C
C     WHILE ( HIGH > TAU*MAX( TOL1, LOW ) ) DO
   10 IF ( HIGH.GT.( TAU*MAX( TOL1, LOW ) ) ) THEN
         SIGMA = SQRT( HIGH ) * SQRT( MAX( TOL1, LOW ) )
C
C        Set up H(sigma).
C        Workspace: N*(N+1)+2*N*N.
C
         CALL DLACPY( 'Full', N, N, A, LDA, DWORK(IAA), N )
         DWORK(IGF)   =  SIGMA
         DWORK(IGF+N) = -SIGMA
         DUMMY(1) = ZERO
         CALL DCOPY( N-1, DUMMY, 0, DWORK(IGF+1), 1 )
C
         DO 20 I = IGF, IA2 - N - 2, N + 1
            CALL DCOPY( N+1, DWORK(I), 1, DWORK(I+N+1), 1 )
   20    CONTINUE
C
C        Computation of the eigenvalues by the square reduced algorithm.
C        Workspace: N*(N+1)+2*N*N+2*N.
C
         CALL MB04ZD( 'No vectors', N, DWORK(IAA), N, DWORK(IGF), N,
     $                DUMMY2, 1, DWORK(IWK), INFO )
C
C        Form the matrix A*A + F*G.
C        Workspace: need   N*(N+1)+2*N*N+N;
C                   prefer N*(N+1)+3*N*N.
C
         JWORK = IA2
         IF ( SUFWRK )
     $      JWORK = IWK
C
         CALL DLACPY( 'Lower', N, N, DWORK(IGF), N, DWORK(JWORK), N )
         CALL MA02ED( 'Lower', N, DWORK(JWORK), N )
C
         IF ( SUFWRK ) THEN
C
C           Use BLAS 3 calculation.
C
            CALL DSYMM( 'Left', 'Upper', N, N, ONE, DWORK(IGF+N), N,
     $                  DWORK(JWORK), N, ZERO, DWORK(IA2), N )
         ELSE
C
C           Use BLAS 2 calculation.
C
            DO 30 I = 1, N
               CALL DSYMV( 'Upper', N, ONE, DWORK(IGF+N), N,
     $                     DWORK(IA2+N*(I-1)), 1, ZERO, DWORK(IWK), 1 )
               CALL DCOPY( N, DWORK(IWK), 1, DWORK(IA2+N*(I-1)), 1 )
   30       CONTINUE
C
         END IF
C
         CALL DGEMM( 'NoTranspose', 'NoTranspose', N, N, N, ONE,
     $               DWORK(IAA), N, DWORK(IAA), N, ONE, DWORK(IA2), N )
C
C        Find the eigenvalues of A*A + F*G.
C        Workspace: N*(N+1)+N*N+3*N.
C
         JWORK = IWI + N
         CALL DGEBAL( 'Scale', N, DWORK(IA2), N, ILO, IHI, DWORK(JWORK),
     $                I )
         CALL DHSEQR( 'Eigenvalues', 'NoSchurVectors', N, ILO, IHI,
     $                DWORK(IA2), N, DWORK(IWR), DWORK(IWI), DUMMY2, 1,
     $                DWORK(JWORK), N, INFO )
C
         IF ( INFO.NE.0 ) THEN
            INFO = 1
            RETURN
         END IF
C
C        (DWORK(IWR+i), DWORK(IWI+i)), i = 0,...,N-1, contain the
C        squares of the eigenvalues of H(sigma).
C
         I = 0
         RNEG = .FALSE.
C        WHILE ( ( DWORK(IWR+i),DWORK(IWI+i) ) not real positive
C                .AND. I < N ) DO
   40    IF ( .NOT.RNEG .AND. I.LT.N ) THEN
            TEMP = ABS( DWORK(IWI+I) )
            IF ( TOL1.GT.SFMN ) TEMP = TEMP / TOL1
            RNEG = ( ( DWORK(IWR+I).LT.ZERO ) .AND. ( TEMP.LE.TOL2 ) )
            I = I + 1
            GO TO 40
C           END WHILE 40
         END IF

         IF ( RNEG ) THEN
            HIGH = SIGMA
         ELSE
            LOW = SIGMA
         END IF
         GO TO 10
C        END WHILE 10
      END IF
C
C     Set optimal workspace dimension.
C
      DWORK(1) = DBLE( MAX( 4*N2 + N, MINWRK ) )
C
C *** Last line of AB13ED ***
      END


module math
  implicit none

  public :: pi, skewSymmetric, matinv3
  private :: matmatmul_operator, matvecmul_operator, &
             vecmatmul_operator, cross_operator

  real*8, parameter :: pi = 4*atan(1d0)

  interface operator (.matmul.)
    module procedure matmatmul_operator
    module procedure matvecmul_operator
    module procedure vecmatmul_operator
  end interface

  interface operator (.cross.)
    module procedure cross_operator
  end interface

  contains

    pure function matmatmul_operator(A, B) result(C)
      real*8, intent(in), dimension(:,:) :: A, B
      real*8, dimension(size(A,1),size(B,2)) :: C

      C = matmul(A,B)
    end function matmatmul_operator

    pure function matvecmul_operator(A, B) result(C)
      real*8, intent(in)  :: A(:,:), B(:)
      real*8, dimension(size(A,1)) :: C

      C = matmul(A,B)
    end function matvecmul_operator

    pure function vecmatmul_operator(A, B) result(C)
      real*8, intent(in)  :: A(:), B(:,:)
      real*8, dimension(size(A)) :: C
      !^^^^ Wrong shape

      C = matmul(A,B)
    end function vecmatmul_operator

    pure function cross_operator(x, y) result(z)
      real*8, intent(in) :: x(3), y(3)
      real*8             :: z(3)

      z(1) = x(2)*y(3) - x(3)*y(2)
      z(2) = x(3)*y(1) - x(1)*y(3)
      z(3) = x(1)*y(2) - x(2)*y(1)
    end function cross_operator

    pure subroutine skewSymmetric(vector, S)
      real*8, intent(in) :: vector(3)
      real*8, intent(out) :: S(3,3)

      S(1,:) = (/        0d0, -vector(3),  vector(2) /)
      S(2,:) = (/  vector(3),        0d0, -vector(1) /)
      S(3,:) = (/ -vector(2),  vector(1),        0d0 /)

    end subroutine skewSymmetric

    pure function matinv3(A) result(B)
      ! From http://fortranwiki.org/fortran/show/Matrix+inversion
      !! Performs a direct calculation of the inverse of a 3×3 matrix.
      real*8, intent(in) :: A(3,3)   !! Matrix
      real*8             :: B(3,3)   !! Inverse matrix
      real*8             :: detinv

      ! Calculate the inverse determinant of the matrix
      detinv = 1/(A(1,1)*A(2,2)*A(3,3) - A(1,1)*A(2,3)*A(3,2)&
                - A(1,2)*A(2,1)*A(3,3) + A(1,2)*A(2,3)*A(3,1)&
                + A(1,3)*A(2,1)*A(3,2) - A(1,3)*A(2,2)*A(3,1))

      ! Calculate the inverse of the matrix
      B(1,1) = +detinv * (A(2,2)*A(3,3) - A(2,3)*A(3,2))
      B(2,1) = -detinv * (A(2,1)*A(3,3) - A(2,3)*A(3,1))
      B(3,1) = +detinv * (A(2,1)*A(3,2) - A(2,2)*A(3,1))
      B(1,2) = -detinv * (A(1,2)*A(3,3) - A(1,3)*A(3,2))
      B(2,2) = +detinv * (A(1,1)*A(3,3) - A(1,3)*A(3,1))
      B(3,2) = -detinv * (A(1,1)*A(3,2) - A(1,2)*A(3,1))
      B(1,3) = +detinv * (A(1,2)*A(2,3) - A(1,3)*A(2,2))
      B(2,3) = -detinv * (A(1,1)*A(2,3) - A(1,3)*A(2,1))
      B(3,3) = +detinv * (A(1,1)*A(2,2) - A(1,2)*A(2,1))
    end function

end module math


*DECK DLBETA
      DOUBLE PRECISION FUNCTION DLBETA (A, B)
C***BEGIN PROLOGUE  DLBETA
C***PURPOSE  Compute the natural logarithm of the complete Beta
C            function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7B
C***TYPE      DOUBLE PRECISION (ALBETA-S, DLBETA-D, CLBETA-C)
C***KEYWORDS  FNLIB, LOGARITHM OF THE COMPLETE BETA FUNCTION,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DLBETA(A,B) calculates the double precision natural logarithm of
C the complete beta function for double precision arguments
C A and B.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D9LGMC, DGAMMA, DLNGAM, DLNREL, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900727  Added EXTERNAL statement.  (WRB)
C***END PROLOGUE  DLBETA
      DOUBLE PRECISION A, B, P, Q, CORR, SQ2PIL, D9LGMC, DGAMMA, DLNGAM,
     1  DLNREL
      EXTERNAL DGAMMA
      SAVE SQ2PIL
      DATA SQ2PIL / 0.9189385332 0467274178 0329736405 62 D0 /
C***FIRST EXECUTABLE STATEMENT  DLBETA
      P = MIN (A, B)
      Q = MAX (A, B)
C
      IF (P .LE. 0.D0) CALL XERMSG ('SLATEC', 'DLBETA',
     +   'BOTH ARGUMENTS MUST BE GT ZERO', 1, 2)
C
      IF (P.GE.10.D0) GO TO 30
      IF (Q.GE.10.D0) GO TO 20
C
C P AND Q ARE SMALL.
C
      DLBETA = LOG (DGAMMA(P) * (DGAMMA(Q)/DGAMMA(P+Q)) )
      RETURN
C
C P IS SMALL, BUT Q IS BIG.
C
 20   CORR = D9LGMC(Q) - D9LGMC(P+Q)
      DLBETA = DLNGAM(P) + CORR + P - P*LOG(P+Q)
     1  + (Q-0.5D0)*DLNREL(-P/(P+Q))
      RETURN
C
C P AND Q ARE BIG.
C
 30   CORR = D9LGMC(P) + D9LGMC(Q) - D9LGMC(P+Q)
      DLBETA = -0.5D0*LOG(Q) + SQ2PIL + CORR + (P-0.5D0)*LOG(P/(P+Q))
     1  + Q*DLNREL(-P/(P+Q))
      RETURN
C
      END


!     .................................................
!             ____  _       _   ____  _____   _
!            |  _ \| |     |_| |  _ \|  ___| |_|
!            | |_) | |___   _  | |_) | |___   _
!            |  _ /|  _  | | | |  _ /|___  | | |
!            | |   | | | | | | | |    ___| | | |
!            |_|   |_| |_| |_| |_|   |_____| |_|
!     .................................................
!     PhiPsi:     a general-purpose computational
!                 mechanics program written in Fortran.
!     Website:    http://phipsi.top
!     Author:     Shi Fang from Huaiyin Institute of
!                 Technology, HuaiAn, JiangSu, China
!     Contact me: shifang@hyit.edu.cn
!     ------------------------------------------------
!     Please cite the following papers:
!     (1)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based method with reduction technique
!        for modeling hydraulic fracture propagation
!        in formations containing frictional natural
!        fractures. Engineering Fracture Mechanics,
!        2017, 173: 64-90.
!     (2)Shi F, Wang X L, Liu C, Liu H, Wu H A. A
!        coupled extended finite element approach
!        for modeling hydraulic fracturing in
!        consideration of proppant. Journal of
!        Natural Gas Science and Engineering, 2016,
!        33: 885-897.
!     (3)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based numerical model to calculate
!        conductivity of propped fracture considering
!        proppant transport, embedment and crushing.
!        Journal of Petroleum Science and Engineering,
!        2018, 167: 615-626..

      subroutine Cal_detJ(kesi,yita,
     &                    X_NODES,Y_NODES,
     &                    detJ)

c     This function calculates determinant of Jacobian matrix.

      implicit none

      double precision,intent(in)::kesi,yita,X_NODES(4),Y_NODES(4)
      double precision,intent(out)::detJ
      double precision one   !1
      double precision fo    !4
      double precision temp(2,4),Coor(2,4),J(2,2),dNdkesi(4,2)

      one = 1.0D0
      fo  = 4.0D0

	  ! Coordinates of the element.
	  Coor(1,:) = [X_NODES(1),X_NODES(2),X_NODES(3),X_NODES(4)]
	  Coor(2,:) = [Y_NODES(1),Y_NODES(2),Y_NODES(3),Y_NODES(4)]

	  !Calculate dNdkesi.
	  temp(1,:) =[(yita-one)/fo,(-yita+one)/fo,
     &                    (yita+one)/fo,(-yita-one)/fo]
      temp(2,:) =[(kesi-one)/fo,(-kesi-one)/fo,
     &                    (kesi+one)/fo,(-kesi+one)/fo]

	  dNdkesi = transpose(temp)

	  ! Calculate the Jacobian matrix.
	  J = MATMUL(Coor,dNdkesi)

	  ! Calculate the determinant of Jacobian matrix.
      call Matrix_Det(2,J,detJ)

      return
      end SUBROUTINE Cal_detJ


!*******************************************************************
!> author: Akira Kageyama
!  license: MIT
!  date: 2020.01.15
!
!  古典的4次ルンゲ=クッタ積分法モジュール
!
!  @note これは教育用のコードである。
!        メモリの節約については全く考慮していない。
!

module rk4_m

  use constants_m
  use namelist_m
  use ut_m
  implicit none

  private
  public :: rk4__step

contains

  function burgers_equation(nx,dx,psi)
    !! バーガーズ方程式の2階中心差分
    !! 境界点を除いた内側の格子点を更新する
    !! @note
    !!   ここで更新していない境界上の格子点は、
    !!   境界条件で更新する必要がある。
    integer(SI), intent(in) :: nx                !! 格子点数
    real(DR), intent(in) :: dx                   !! 格子間隔
    real(DR), dimension(nx), intent(in) :: psi   !! 振幅（主変数）
    real(DR), dimension(nx) :: burgers_equation  !! 積分後の配列を返す

    integer(SI) :: i
    real(DR) :: dx1  ! 一階差分演算子（定数）割り算削減のため定義
    real(DR) :: dx2  ! 二階差分演算子（定数）割り算削減のため定義

    dx1 = 1.0_DR / (2*dx)
    dx2 = namelist__get_double('Diffusion_coeff')/(dx**2)

    do i = 2 , nx-1
       burgers_equation(i) = - psi(i)*dx1*(psi(i+1)-psi(i-1)) &
                             + dx2*(psi(i+1)-2*psi(i)+psi(i-1))
    end do
  end function burgers_equation

!
! Private
!==========
! Public
!

  function rk4__step(nth,dt,dx,psi,dpsi_prev) result(dpsi_new)
    !! 4段4次のRunge-Kutta法による1ステップ積分の実行
    !! @note 教科書のアルゴリズムをそのまま実装している。
    !!       メモリを贅沢に使っていることに注意。
    character(len=3), intent(in) :: nth       !! 4段の何番目か
    real(DR), intent(in) :: dt                !! 積分時間刻み
    real(DR), intent(in) :: dx                !! 格子間隔
    real(DR), dimension(:), intent(in) :: psi !! 被積分関数
    real(DR), dimension(size(psi,dim=1)), intent(in), optional :: dpsi_prev
                                              !! 前段の増分
    real(DR), dimension(size(psi,dim=1)) :: dpsi_new
                                              !! 現段の増分
                                              !! 配列で返す

    real(DR), dimension(size(psi,dim=1)) :: psi_   ! 作業配列

    ! 古典的な4段4次のRunge-Kutta積分法
    select case (nth)
    case ('1st') ! 第1段
       dpsi_new(:) = dt*burgers_equation(size(psi,dim=1),dx,psi)
    case ('2nd') ! 第2段
       psi_(:) = psi(:) + dpsi_prev(:)*0.5_DR
       dpsi_new(:) = dt*burgers_equation(size(psi,dim=1),dx,psi_)
    case ('3rd') ! 第3段
       psi_(:) = psi(:) + dpsi_prev(:)*0.5_DR
       dpsi_new(:) = dt*burgers_equation(size(psi,dim=1),dx,psi_)
    case ('4th') ! 第4段
       psi_(:) = psi(:) + dpsi_prev(:)
       dpsi_new(:) = dt*burgers_equation(size(psi,dim=1),dx,psi_)
    case default
       call ut__fatal('<rk4> Invalid step.')
    end select

  end function rk4__step

end module rk4_m


! This program will numerically compute the integral of
!                   4/(1+x*x)
! from 0 to 1.  The value of this integral is pi -- which
! is great since it gives us an easy way to check the answer.

! The is the original sequential program.  It uses the timer
! from the OpenMP runtime library

! History: C code written by Tim Mattson, 11/1999.
! adapted to Fortran code by Helen He, 09/2017.

  PROGRAM MAIN
  USE OMP_LIB
  IMPLICIT NONE

  INTEGER :: i
  INTEGER, PARAMETER :: num_steps = 100000000
  REAL*8 :: x, pi, sum, step
  REAL*8 :: start_time, run_time

  sum = 0.0

  step = 1.0 / num_steps
  start_time = OMP_GET_WTIME()

  DO i = 1, num_steps
     x = (i - 0.5) * step
     sum = sum + 4.0 / (1.0 + x * x)
  ENDDO

  pi = step * sum
  run_time = OMP_GET_WTIME() - start_time

  WRITE(*,100) num_steps, pi,  run_time
100  FORMAT('pi with ',i14,' steps is ',f15.8,' in ',f8.3,' secs')

  END PROGRAM MAIN


MODULE linear_algebra
CONTAINS
  SUBROUTINE solve_leqs(N,A,sol,triv)
    ! solve the linear equations Ax=0
    ! return a minimal solution,i.e.,in x the number of nonzero element is samllest but not 0
    IMPLICIT NONE
    INTEGER,INTENT(IN)::N
    REAL(KIND(1d0)),DIMENSION(N,N),INTENT(IN)::A
    REAL(KIND(1d0)),DIMENSION(N,N)::B
    INTEGER,DIMENSION(N)::iexchange
    INTEGER::i,j,inow,k,iswap,izero
    REAL(KIND(1d0)),PARAMETER::EPS=1d-10
    REAL(KIND(1d0)),DIMENSION(N),INTENT(OUT)::sol
    REAL(KIND(1d0)),DIMENSION(N)::row,coloum
    REAL(KIND(1d0))::maxv,temp
    LOGICAL,INTENT(OUT)::triv
    LOGICAL::allzero
    ! make matrix A to be upper triangular
    B(1:N,1:N)=A(1:N,1:N)
    maxv=MAXVAL(ABS(B(1:N,1:N)))
    IF(maxv.LT.EPS)THEN
       ! a trivial solution
       sol(1)=1d0
       sol(2:N)=0d0
       triv=.FALSE.
       RETURN
    ENDIF
    DO i=1,N
       iexchange(i)=i
    ENDDO
    inow=1
    izero=0
    DO i=1,N
       allzero=.TRUE.
       DO j=inow,N
          IF(ABS(B(j,inow))/maxv.GT.EPS)THEN
             allzero=.FALSE.
             IF(j.NE.inow)THEN
                row(1:N)=B(inow,1:N)
                B(inow,1:N)=B(j,1:N)
                B(j,1:N)=row(1:N)
             ENDIF
             EXIT
          ENDIF
       ENDDO
       IF(.NOT.allzero)THEN
          DO j=inow+1,N
             IF(inow+1.LE.N)THEN
                B(j,inow+1:N)=B(j,inow+1:N)-B(inow,inow+1:N)*B(j,inow)/B(inow,inow)
             ENDIF
             B(j,inow)=0d0
          ENDDO
          inow=inow+1
       ELSE
          ! the coloum is zero, put it to the end
          coloum(1:N)=B(1:N,inow)
          izero=izero+1
          iswap=iexchange(N)
          iexchange(N)=iexchange(inow)
          DO j=inow+1,N
             B(1:N,j-1)=B(1:N,j)
             IF(j.NE.N)THEN
                iexchange(j-1)=iexchange(j)
             ELSE
                iexchange(j-1)=iswap
             ENDIF
          ENDDO
          B(1:N,N)=coloum(1:N)
       ENDIF
!       PRINT *,i
!       DO j=1,N
!          WRITE(*,*)B(j,1:N)
!       ENDDO
    ENDDO
!    DO i=1,N
!       WRITE(*,*)B(i,1:N)
!    ENDDO
!    WRITE(*,*)"================"
    IF(izero.GT.0)THEN
       sol(iexchange(N))=1d0
       DO inow=1,N-1
          i=N-inow
          IF(ABS(B(i,i))/maxv.LT.EPS)THEN
             sol(iexchange(i))=0d0
          ELSE
             temp=0d0
             DO j=i+1,N
                temp=temp-B(i,j)*sol(iexchange(j))
             ENDDO
             sol(iexchange(i))=temp/B(i,i)
          ENDIF
       ENDDO
       triv=.FALSE.
    ELSE
       sol(1:N)=0d0
       triv=.TRUE.
    ENDIF
    RETURN
  END SUBROUTINE SOLVE_LEQS

  SUBROUTINE solve_cleqs(N,A,sol,triv)
    ! solve the complex linear equations Ax=0
    ! return a minimal solution,i.e.,in x the number of nonzero element is samllest but not 0
    IMPLICIT NONE
    INTEGER,INTENT(IN)::N
    COMPLEX(KIND(1d0)),DIMENSION(N,N),INTENT(IN)::A
    COMPLEX(KIND(1d0)),DIMENSION(N,N)::B
    INTEGER,DIMENSION(N)::iexchange
    INTEGER::i,j,inow,k,iswap,izero
    REAL(KIND(1d0)),PARAMETER::EPS=1d-10
    COMPLEX(KIND(1d0)),DIMENSION(N),INTENT(OUT)::sol
    COMPLEX(KIND(1d0)),DIMENSION(N)::row,coloum
    REAL(KIND(1d0))::maxv
    COMPLEX(KIND(1d0))::temp
    LOGICAL,INTENT(OUT)::triv
    LOGICAL::allzero
    ! make matrix A to be upper triangular
    B(1:N,1:N)=A(1:N,1:N)
    maxv=MAXVAL(ABS(B(1:N,1:N)))
    IF(maxv.LT.EPS)THEN
       ! a trivial solution
       sol(1)=DCMPLX(1d0)
       sol(2:N)=DCMPLX(0d0)
       triv=.FALSE.
       RETURN
    ENDIF
    DO i=1,N
       iexchange(i)=i
    ENDDO
    inow=1
    izero=0
    DO i=1,N
       allzero=.TRUE.
       DO j=inow,N
          IF(ABS(B(j,inow))/maxv.GT.EPS)THEN
             allzero=.FALSE.
             IF(j.NE.inow)THEN
                row(1:N)=B(inow,1:N)
                B(inow,1:N)=B(j,1:N)
                B(j,1:N)=row(1:N)
             ENDIF
             EXIT
          ENDIF
       ENDDO
       IF(.NOT.allzero)THEN
          DO j=inow+1,N
             IF(inow+1.LE.N)THEN
                B(j,inow+1:N)=B(j,inow+1:N)-B(inow,inow+1:N)*B(j,inow)/B(inow,inow)
             ENDIF
             B(j,inow)=0d0
          ENDDO
          inow=inow+1
       ELSE
          ! the coloum is zero, put it to the end
          coloum(1:N)=B(1:N,inow)
          izero=izero+1
          iswap=iexchange(N)
          iexchange(N)=iexchange(inow)
          DO j=inow+1,N
             B(1:N,j-1)=B(1:N,j)
             IF(j.NE.N)THEN
                iexchange(j-1)=iexchange(j)
             ELSE
                iexchange(j-1)=iswap
             ENDIF
          ENDDO
          B(1:N,N)=coloum(1:N)
       ENDIF
    ENDDO
    IF(izero.GT.0)THEN
       sol(iexchange(N))=DCMPLX(1d0)
       DO inow=1,N-1
          i=N-inow
          IF(ABS(B(i,i))/maxv.LT.EPS)THEN
             sol(iexchange(i))=DCMPLX(0d0)
          ELSE
             temp=DCMPLX(0d0)
             DO j=i+1,N
                temp=temp-B(i,j)*sol(iexchange(j))
             ENDDO
             sol(iexchange(i))=temp/B(i,i)
          ENDIF
       ENDDO
       triv=.FALSE.
    ELSE
       sol(1:N)=DCMPLX(0d0)
       triv=.TRUE.
    ENDIF
    RETURN
  END SUBROUTINE SOLVE_CLEQS

END MODULE linear_algebra


      SUBROUTINE MC01MD( DP, ALPHA, K, P, Q, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To calculate, for a given real polynomial P(x) and a real scalar
C     alpha, the leading K coefficients of the shifted polynomial
C                                                               K-1
C        P(x) = q(1) + q(2) * (x-alpha) + ... + q(K) * (x-alpha)   + ...
C
C     using Horner's algorithm.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     DP      (input) INTEGER
C             The degree of the polynomial P(x).  DP >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The scalar value alpha of the problem.
C
C     K       (input) INTEGER
C             The number of coefficients of the shifted polynomial to be
C             computed.  1 <= K <= DP+1.
C
C     P       (input) DOUBLE PRECISION array, dimension (DP+1)
C             This array must contain the coefficients of P(x) in
C             increasing powers of x.
C
C     Q       (output) DOUBLE PRECISION array, dimension (DP+1)
C             The leading K elements of this array contain the first
C             K coefficients of the shifted polynomial in increasing
C             powers of (x - alpha), and the next (DP-K+1) elements
C             are used as internal workspace.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     Given the real polynomial
C                                         2                    DP
C        P(x) = p(1) + p(2) * x + p(3) * x  + ... + p(DP+1) * x  ,
C
C     the routine computes the leading K coefficients of the shifted
C     polynomial
C                                                                   K-1
C        P(x) = q(1) + q(2) * (x - alpha) + ... + q(K) * (x - alpha)
C
C     as follows.
C
C     Applying Horner's algorithm (see [1]) to P(x), i.e. dividing P(x)
C     by (x-alpha), yields
C
C        P(x) = q(1) + (x-alpha) * D(x),
C
C     where q(1) is the value of the constant term of the shifted
C     polynomial and D(x) is the quotient polynomial of degree (DP-1)
C     given by
C                                         2                     DP-1
C        D(x) = d(2) + d(3) * x + d(4) * x  + ... +  d(DP+1) * x    .
C
C     Applying Horner's algorithm to D(x) and subsequent quotient
C     polynomials yields q(2) and q(3), q(4), ..., q(K) respectively.
C
C     It follows immediately that q(1) = P(alpha), and in general
C                (i-1)
C        q(i) = P     (alpha) / (i - 1)! for i = 1, 2, ..., K.
C
C     REFERENCES
C
C     [1] STOER, J. and BULIRSCH, R.
C         Introduction to Numerical Analysis.
C         Springer-Verlag. 1980.
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997.
C     Supersedes Release 2.0 routine MC01AD by A.J. Geurts.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary polynomial operations, polynomial operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      INTEGER           DP, INFO, K
      DOUBLE PRECISION  ALPHA
C     .. Array Arguments ..
      DOUBLE PRECISION  P(*), Q(*)
C     .. Local Scalars ..
      INTEGER           I, J
C     .. External Subroutines ..
      EXTERNAL          DCOPY, XERBLA
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO = 0
      IF( DP.LT.0 ) THEN
         INFO = -1
      ELSE IF( K.LE.0 .OR. K.GT.DP+1 ) THEN
         INFO = -3
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MC01MD', -INFO )
         RETURN
      END IF
C
      CALL DCOPY( DP+1, P, 1, Q, 1 )
      IF ( DP.EQ.0 .OR. ALPHA.EQ.ZERO )
     $   RETURN
C
      DO 40 J = 1, K
C
         DO 20 I = DP, J, -1
            Q(I) = Q(I) + ALPHA*Q(I+1)
   20    CONTINUE
C
   40 CONTINUE
C
      RETURN
C *** Last line of MC01MD ***
      END


Module special

  Use typeKind

  Implicit None

contains

  !==================================!
  ! Gamma function                   !
  !==================================!

  real function gamma(x, y)
    implicit none

    real(wp), intent(in) :: x
    real(wp), intent(in), optional :: y
    real(wp) :: f,g,z
    REAL(WP), PARAMETER :: pi=3.14159

    if (.not. present(y))then

      f=huge(x)
      g=1
      z=x
      if ((z+int(abs(z))).ne.0)then
        do while(z<3)
          ! Lets use a recursion relation for Gamma functions
          ! to get a large argument and use Stirlings formula
          g=g*z
          z=z+1
        end do

        ! This is just stirlings formula...
        f=(1.-2.*(1-2./(3.*z*z))/(7.*z*z))/(30.*z*z)
        f=(1.-f)/(12.*z)+z*(log(z)-1)
        f=(exp(f)/g)*sqrt(2.*pi/z)

      endif
      gamma=f

    else

       gamma=max(0., gammaup(x,y))

    end if

  end function gamma

  !==================================!
  ! Upper incomplete gamma function  !
  !==================================!

  real(wp) function gammaup(a,x)

    implicit none

    real(wp) :: a,x

    ! integral(x to infty) t^a-1 exp(-t) dt

    gammaup=(gamma(a))*(1-x**a*eigamma(a,x))

  end function gammaup

  !==================================!
  ! Entire Incomplete gamma function !
  !==================================!

  real(wp) function eigamma(a,x)

    implicit none

    real(wp), intent(in) :: a,x
    real(wp) :: p,g,b,z,f
    integer :: j
    real(wp), parameter :: pi=3.14159

    if (x < 100.0) then

       g=1
       p=1
       b=a
       do while(b<=1.)
          b=b+1
          g=g*x
          p=p*b+g
       end do
       b=b+1

       j=int(5.*(3.+abs(x))/2.)
       f=1./(j+b-x)

       do while(j/=0)
          j=j-1
          f=(f*x+1.)/(j+b)
       end do

       p=p+f*g*x
       g=(1.-(2./(7.*b*b))*(1.-2./(3.*b*b)))/(30.*b*b)
       g=(g-1.)/(12.*b)-b*(log(b)-1.)

       f=p*exp(g-x)*sqrt(b/(2.*pi))

       eigamma=f

    else

       eigamma=0.0

    endif

  end function eigamma

end Module special


      FUNCTION pcurr (xx)
      USE stel_kinds
      USE vmec_input, ONLY: ac, bloat, ipcurr
C-----------------------------------------------
      REAL(rprec), PARAMETER :: one = 1
      INTEGER     :: i, ioff
      REAL(rprec) :: xx, pcurr, x
      REAL(rprec), parameter :: pi=3.141592653589793238462643d0
C-----------------------------------------------
!
!     NOTE:  AC COEFFICIENTS OBTAINED IN THREED1 FILE
!            BY MATCHING TO <JTOR> * dV/dPHI
!
      x = MIN (ABS(xx * bloat), one)

      pcurr = 0

      SELECT CASE(ipcurr)
      CASE(0)
       ioff = LBOUND(ac,1)
       DO i = UBOUND(ac,1), ioff, -1
        pcurr = x*pcurr + ac(i)/(i-ioff+1)
       END DO
       pcurr = x*pcurr
      CASE(1)
       pcurr = ac(1)*(2/pi)*atan(ac(2)*x**ac(3)/(1-x)**ac(4))
     >       + ac(5)*(2/pi)*atan(ac(6)*x**ac(7)/(1-x)**ac(8))
      CASE(2)
       pcurr = ac(1)*(2/pi)*atan(ac(2)*x**ac(3)/(1-x)**ac(4))
     >       + ac(5)*(2/pi)*atan(ac(6)*x**ac(7)/(1-x)**ac(8))
     >       + ac(9)*(2/pi)*atan(ac(10)*x**ac(11)/(1-x)**ac(12))
      CASE DEFAULT
        stop 'pcurr: Invalid mass profile selected'
      END SELECT

      END FUNCTION pcurr


module utils

    use globals, only: pi
    implicit none

    contains
! ###################
!
!
   function euler2rotm(ANG1d, ANG2d, ANG3d) result(Q0)
    ! ANG three Euler angles in degrees
        real(kind=8)    ::  ANG(3), Q0(3,3), ANG1, ANG2, ANG3, ANG1d, ANG2d, ANG3d

        ANG1 = deg2rad(ANG1d)
        ANG2 = deg2rad(ANG2d)
        ANG3 = deg2rad(ANG3d)

        Q0(1,1) = COS(ANG1)*COS(ANG3)-SIN(ANG1)*COS(ANG2)*SIN(ANG3)
        Q0(1,2) = SIN(ANG1)*COS(ANG3)+COS(ANG1)*COS(ANG2)*SIN(ANG3)
        Q0(1,3) = SIN(ANG2)*SIN(ANG3)
        Q0(2,1) =-COS(ANG1)*SIN(ANG3)-SIN(ANG1)*COS(ANG2)*COS(ANG3)
        Q0(2,2) =-SIN(ANG1)*SIN(ANG3)+COS(ANG1)*COS(ANG2)*COS(ANG3)
        Q0(2,3) = SIN(ANG2)*COS(ANG3)
        Q0(3,1) = SIN(ANG1)*SIN(ANG2)
        Q0(3,2) =-COS(ANG1)*SIN(ANG2)
        Q0(3,3) = COS(ANG2)

    end function euler2rotm

!C**********************************************************************
!C                         FUNCTION rotm2euler                         *
!C**********************************************************************
!C Computes the Euler angles associated with the orientation matrix    *
!C in terms of the three Euler angles: phi1 (rotation about Z1), PHI   *
!C (rotation about X2) and phi2 (rotation about Z3) - Bunge notation   *
!C**********************************************************************
      function rotm2euler(Q) result(ANG)

      real(kind=8)      ::  ANG(3), Q(3,3), ANG1, ANG2, ANG3, STH

      if (abs(Q(3,3)) < 1.D0) then
        ANG2 = acos(Q(3,3))
        STH  = sin(ANG2)
        ANG1 = atan2(Q(3,1)/STH,-Q(3,2)/STH)
        ANG3 = atan2(Q(1,3)/STH,Q(2,3)/STH)
      else
        ANG1 = atan2(Q(1,2),Q(1,1))
        ANG2 = 0.D0
        ANG3 = 0.D0
      end if
      ANG(1) = rad2deg(ANG1)
      ANG(2) = rad2deg(ANG2)
      ANG(3) = rad2deg(ANG3)

      end function rotm2euler

    function vonMises(A, m) result(VM)
    ! von Mises norm of stress or strain
        real(kind=8)   ::  A(3,3), VM, fVM, trace
        character(6)   ::  m

        trace = A(1,1) + A(2,2) + A(3,3)
        A = A - trace*eye(3)/3.d0

        if (m == 'strain') then
            fVM = sqrt(2.d0/3.d0)
        elseif (m == 'stress') then
            fVM = sqrt(3.d0/2.d0)
        end if

        VM = fVM*sqrt(A(1,1)**2 + A(2,2)**2 + A(3,3)**2 + 2.d0*(A(1,2)**2 + A(1,3)**2 + A(2,3)**2))

    end function vonMises

    subroutine vonMises_dvec(A, m, MA, VM, An)
    ! von Mises norm of deviatoric stress or dev strain given in Voigt notation
    ! masked array MA
        real(kind=8)    ::  A(5), An(5), VM, fVM
        integer         ::  i, MA(5)
        character(6)    ::  m

        intent(in)      ::  A, m, MA
        intent(out)     ::  VM, An

        if (m == 'strain') then
            fVM = sqrt(2.d0/3.d0)
        elseif (m == 'stress') then
            fVM = sqrt(3.d0/2.d0)
        end if

        An = 0.d0
        forall (i=1:5, MA(i)==1) An(i) = A(i)

        VM = fVM*sqrt(An(1)**2 + An(2)**2 + (-An(1)-An(2))**2 + 2.d0*An(3)**2 + 2.d0*An(4)**2 + 2.d0*An(5)**2)

        An = A
        forall (i=1:5, MA(i)==1) An(i) = An(i)/VM

    end subroutine vonMises_dvec

    function m2voigt_dev(M) result(v)

        real(kind=8)    ::  M(3,3), v(5)
        v = (/ M(1,1), M(2,2), M(2,3), M(1,3), M(1,2) /)

    end function m2voigt_dev

    function voigt_dev2m(x) result(M)

        real(kind=8)    ::  M(3,3), x(5)
        M = reshape( (/ x(1), x(5), x(4), x(5), x(2), x(3), x(4), x(3), -x(1)-x(2) /), (/3,3/) )

    end function voigt_dev2m

    function symouter5(x, y) result(M)

	integer     ::  i, j
	real(8)     ::  x(5), y(5), M(5,5)
!
    do i=1, 5
        do j=i, 5
            M(i,j) = x(i)*y(j)
        end do
    end do
!
    end function symouter5

    function outer2vec(e1, e2) result(v)
!
!   Uses new notation
!
	integer     ::  i, j
	real(8)     ::  e1(3), e2(3), v(6), tmp(6)
!
	tmp(1) = e1(1)*e2(1)
	tmp(2) = e1(2)*e2(2)
	tmp(3) = e1(3)*e2(3)
	tmp(4) = e1(2)*e2(3)
	tmp(5) = e1(1)*e2(3)
	tmp(6) = e1(1)*e2(2)
!
	v(1) = 1.d0/sqrt(3.d0)*(tmp(1)+tmp(2)+tmp(3))
	v(2) = 1.d0/sqrt(6.d0)*(2.d0*tmp(3)-tmp(1)-tmp(2))
	v(3) = 1.d0/sqrt(2.d0)*(tmp(2)-tmp(1))
	v(4) = sqrt(2.d0)*tmp(4)
	v(5) = sqrt(2.d0)*tmp(5)
	v(6) = sqrt(2.d0)*tmp(6)
!
    end function outer2vec
!
!
    function matrix2vec(A) result(v)
!
!   Transforms 3x3 matrix into new notation
    real*8      A(3,3), v(6)
!
	v(1) = 1.d0/sqrt(3.d0)*(A(1,1)+A(2,2)+A(3,3))
	v(2) = 1.d0/sqrt(6.d0)*(2.d0*A(3,3)-A(1,1)-A(2,2))
	v(3) = 1.d0/sqrt(2.d0)*(A(2,2)-A(1,1))
	v(4) = sqrt(2.d0)*A(2,3)
	v(5) = sqrt(2.d0)*A(1,3)
	v(6) = sqrt(2.d0)*A(1,2)
!
    end function matrix2vec
!
!
    function vec2matrix(v) result(A)
!
!   Transforms 6x1 vector v written in new notation
!   into a symmetric matrix A
!
    real*8      v(6), A(3,3)
!
    A(1,1) = 1.d0/sqrt(3.d0)*v(1) - 1.d0/sqrt(6.d0)*v(2) - 1.d0/sqrt(2.d0)*v(3)
    A(2,2) = 1.d0/sqrt(3.d0)*v(1) - 1.d0/sqrt(6.d0)*v(2) + 1.d0/sqrt(2.d0)*v(3)
    A(3,3) = 1.d0/sqrt(3.d0)*v(1) + sqrt(2.d0/3.d0)*v(2)
    A(2,3) = 1.d0/sqrt(2.d0)*v(4)
    A(1,3) = 1.d0/sqrt(2.d0)*v(5)
    A(1,2) = 1.d0/sqrt(2.d0)*v(6)
    A(3,2) = A(2,3)
    A(3,1) = A(1,3)
    A(2,1) = A(1,2)
!
    end function vec2matrix
!
!
    subroutine chol_decomp(A, n, choldiag)
!**********************************************************************
!   The CHOL_DECOMP function calculates the Cholesky decomposition
!   A = L*LT of matrix A, where L is lower-triangular matrix and is
!   stored in the lower triangle of A except for the diagonal, which
!   is stored in array CHOLDIAG
!
!**********************************************************************
! (IN/OUT) A is REAL*8 array, dimension (n,n)
!          Matrix A must be a positive-definite symmetric matrix and
!          at input it is read from the upper triangle of A. At return,
!          the factorized matrix L will be stored in the lower triangle
!          of A.
! (IN)     N is INTEGER,
!          It is the dimension of A.
! (OUT)    CHOLDIAG is REAL*8 array, dimension (n)
!          It contains diagonal Cholesky factors of matrix A.
!
      implicit none
      integer     i, j, k, n
      real*8      A(n,n), choldiag(n), sum
!
!     Cholesky factorization of A
      do i=1, n
         do j=i, n
            sum = A(i,j)
            do k=i-1, 1, -1
               sum = sum - A(i,k)*A(j,k)
            end do
            if (i .EQ. j) then
               choldiag(i) = sqrt(sum)
            else
               A(j,i) = sum/choldiag(i)
            end if
         end do
      end do
!
      return
      end subroutine chol_decomp
!
!
      subroutine chol_solve(A, n, b, choldiag, x)
!**********************************************************************
!      The CHOL_SOLVE function returns an n-element vector X containing
!      the solution to the set of linear equations Ax = b. The Cholesky
!      factorization of A must be stored in the lower-diagonal of A and
!      the diagonal factors in CHOLDIAG.
!
!**********************************************************************
! (IN)     A is REAL*8 array, dimension (n,n)
!          Array A contains the original matrix A stored in the upper
!          triangle including the diagonal. The Cholesky factorization
!          of A must at input be stored in the lower triangle, and
!          the diagonal factors stored in CHOLDIAG.
! (IN)     N is INTEGER,
!          It is the dimension of the linear system Ax = b
! (IN)     B is REAL*8 array, dimension (n)
!          It is the right-hand-side vector of the linear system Ax = b
! (IN)     CHOLDIAG is REAL*8 array, dimension (n)
!          It contains diagonal Cholesky factors of matrix A.
! (OUT)    X is REAL*8, dimension (n)
!          It is the solution of the linear system Ax = b
!
      implicit none
      integer     i, j, k, n
      real*8      A(n,n), b(n), choldiag(n), x(n), sum
!
!     backsubstitution
      do i=1, n
         sum = b(i)
         do k=i-1, 1, -1
            sum = sum - A(i,k)*x(k)
         end do
         x(i) = sum/choldiag(i)
      end do
!
      do i=n, 1, -1
         sum = x(i)
         do k=i+1, n
            sum = sum - A(k,i)*x(k)
         end do
         x(i) = sum/choldiag(i)
      end do

      return
      end subroutine chol_solve
!
!
      subroutine chol_inverse(A, n, choldiag, C)
!**********************************************************************
!      The CHOL_INVERSE function returns the matrix C which is inverse of
!      a positive-definite symmetric matrix A.
!
!**********************************************************************
! (IN)     A is REAL*8 array, dimension (n,n)
!          Array A contains the original matrix A stored in the upper
!          triangle including the diagonal. The Cholesky factorization
!          of A must at input be stored in the lower triangle, and
!          the diagonal factors stored in CHOLDIAG.
! (IN)     N is INTEGER,
!          It is the dimension of the linear system Ax = b
! (IN)     B is REAL*8 array, dimension (n)
!          It is the right-hand-side vector of the linear system Ax = b
! (IN)     CHOLDIAG is REAL*8 array, dimension (n)
!          It contains diagonal Cholesky factors of matrix A.
! (OUT)    C is REAL*8, dimension (n,n)
!          It contains inverse of A
!
      implicit none
      integer     i, j, k, n, m
      real*8      A(n,n), b(n), choldiag(n), sum, C(n,n)
!
!     inverse of A by factorized A stored in lower
!     triangle of A and in CHOLDIAG
      do m=1, n
!         create the cartesian basis vectors b
          do i=1, n
              if (m .EQ. i) then
                  b(i) = 1.d0
              else
                  b(i) = 0.d0
              end if
          end do
!         fill the columns of C with the solutions x=A-1*b
          do i=1, n
             sum = b(i)
             do k=i-1, 1, -1
                sum = sum - A(i,k)*C(k,m)
             end do
             C(i,m) = sum/choldiag(i)
          end do
!
          do i=n, 1, -1
             sum = C(i,m)
             do k=i+1, n
                sum = sum - A(k,i)*C(k,m)
             end do
             C(i,m) = sum/choldiag(i)
          end do
      end do
!
      return
      end subroutine chol_inverse

    function deg2rad(angd) result(angr)

    real(kind=8)    ::  angd, angr

    angr = pi*angd/180.d0

    end function deg2rad

    function rad2deg(angr) result(angd)

    real(kind=8)    ::  angd, angr

    angd = 180.d0*angr/pi

    end function rad2deg

    function mdot(A,x) result(y)

    real(kind=8) 	            ::  A(:,:), x(:)
    real(kind=8), allocatable   ::  y(:)
    integer			            ::  i, j, tmp1(2), tmp2, statu

    intent(in)      ::  A, x

    tmp1 = shape(A)
    tmp2 = size(x)
    if (tmp1(2) /= tmp2) then
        write(*,*) "Non-compatible dimensions for dot product."
        read(*,*)
        stop
    else
        allocate( y(tmp1(1)))
        if (allocated(y)) then
            do i = 1, tmp1(1)
                y(i) = 0.d0
                do j = 1, size(x)
                    y(i) = y(i) + A(i,j)*x(j)
                end do
            end do
        end if
    end if

    end function mdot
! ###################

!C**********************************************************************
!C                         FUNCTION TRANSFORM                          *
!C**********************************************************************
!C Rotates a matrix from one frame to another                          *
!C B = P.A.P^T                                                         *
!C**********************************************************************
    function transform(A, P) result(B)

    real(kind=8) A(3,3), B(3,3), P(3,3), PT(3,3), MAT(3,3)

    intent(in)  ::  A, P

    PT = transp3(P)
    MAT = mmult(A, PT)
    B = mmult(P, MAT)

    end function transform

!C**********************************************************************
!C                         FUNCTION MAT2VEC                            *
!C**********************************************************************
!C Transforms a (3x3) symmetric matrix into a (6x1) vector			   *
!C Van Houtte's specification of 3*3 matrix into vector, 6 dimensional *
!C space.                                                              *
!C**********************************************************************
    function mat2vec(MAT) result(VEC)

    real(kind=8) MAT(3,3), VEC(6)

    intent(in)  :: MAT

    VEC(1) = MAT(1,1)
    VEC(2) = MAT(2,2)
    VEC(3) = MAT(3,3)
    VEC(4) = MAT(2,3)
    VEC(5) = MAT(1,3)
    VEC(6) = MAT(1,2)

    end function mat2vec

!C**********************************************************************
!C                         FUNCTION VEC2MAT                            *
!C**********************************************************************
!C Transforms a (6x1) vector (3x3) into a symmetric matrix             *
!C**********************************************************************
    function vec2mat(VEC) result(MAT)

    real(kind=8) MAT(3,3), VEC(6)
    intent(in)  :: VEC

    MAT(1,1) = VEC(1)
    MAT(2,2) = VEC(2)
    MAT(3,3) = VEC(3)
    MAT(2,3) = VEC(4)
    MAT(3,2) = VEC(4)
    MAT(1,3) = VEC(5)
    MAT(3,1) = VEC(5)
    MAT(1,2) = VEC(6)
    MAT(2,1) = VEC(6)

    end function vec2mat

  !C**********************************************************************
  !C                         FUNCTION VEC2SKEWMAT                            *
  !C**********************************************************************
  !C Transforms a (6x1) vector (3x3) into a symmetric matrix             *
  !C**********************************************************************
      function vec2skewmat(VEC) result(MAT)

      real(kind=8) MAT(3,3), VEC(6)
      intent(in)  :: VEC

      MAT(1,1) = VEC(1)
      MAT(2,2) = VEC(2)
      MAT(3,3) = VEC(3)
      MAT(2,3) = VEC(4)
      MAT(3,2) = -VEC(4)
      MAT(1,3) = VEC(5)
      MAT(3,1) = -VEC(5)
      MAT(1,2) = VEC(6)
      MAT(2,1) = -VEC(6)

    end function vec2skewmat

!C**********************************************************************
!C                         FUNCTION MINV                               *
!C**********************************************************************
!C Computes the inverse of a (3x3) matrix AINV = A^-1                  *
!C**********************************************************************
    function minv3(A) result(AINV)

    real(kind=8) ::  A(3,3), AINV(3,3), ADJ(3,3), DET
    integer      ::  I,J

    intent(in)   ::  A

    !C Compute the determinant of A
    DET = determ(A)
    !C Compute the adjoint matrix of A
    ADJ(1,1)=A(2,2)*A(3,3)-A(3,2)*A(2,3)
    ADJ(1,2)=-(A(2,1)*A(3,3)-A(3,1)*A(2,3))
    ADJ(1,3)=A(2,1)*A(3,2)-A(3,1)*A(2,2)
    ADJ(2,1)=-(A(1,2)*A(3,3)-A(3,2)*A(1,3))
    ADJ(2,2)=A(1,1)*A(3,3)-A(3,1)*A(1,3)
    ADJ(2,3)=-(A(1,1)*A(3,2)-A(3,1)*A(1,2))
    ADJ(3,1)=A(1,2)*A(2,3)-A(2,2)*A(1,3)
    ADJ(3,2)=-(A(1,1)*A(2,3)-A(2,1)*A(1,3))
    ADJ(3,3)=A(1,1)*A(2,2)-A(2,1)*A(1,2)
    !C Compute the transpose of the adjoint matrix of A = inverse of A
    DO I=1,3
        DO J=1,3
            AINV(I,J)=ADJ(J,I)/DET
        END DO
    END DO

    end function minv3

!C**********************************************************************
!C                         FUNCTION MMULT                              *
!C**********************************************************************
!C Computes the product of two (3x3) matrices AB = A.B                 *
!C**********************************************************************
    function mmult(A,B) result(AB)

    real(kind=8)    ::  A(3,3), B(3,3), AB(3,3), P
    integer         ::  I,J,K

    intent(in)   ::  A, B

    DO I=1,3
        DO J=1,3
            P=0.D0
            DO K=1,3
                P=P+A(I,K)*B(K,J)
            END DO
            AB(I,J)=P
        END DO
    END DO

    end function mmult

!C**********************************************************************
!C                         FUNCTION TRANSP3                            *
!C**********************************************************************
!C Computes the transpose of a (3x3) matrix AT = A^T                   *
!C**********************************************************************
    function transp3(A) result(AT)

    real(kind=8)    ::  A(3,3), AT(3,3)
    integer         ::  I,J

    intent(in)      ::  A

    DO I=1,3
        DO J=1,3
            AT(I,J)=A(J,I)
        END DO
    END DO

    end function transp3

!C**********************************************************************
!C                         FUNCTION TRANSP                            *
!C**********************************************************************
!C Computes the transpose of a (mxn) matrix AT = A^T                   *
!C**********************************************************************
    function transp(A) result(AT)

    real(kind=8)    ::  A(:,:)
    real(kind=8), allocatable ::  AT(:,:)
    integer         ::  I,J,shpA(2)

    intent(in)      ::  A

    shpA = shape(A)
    allocate(AT(shpA(2),shpA(1)))
    if (allocated(AT)) then
        DO I=1,shpA(2)
            DO J=1,shpA(1)
                AT(I,J)=A(J,I)
            END DO
        END DO
    end if

    end function transp

!C**********************************************************************
!C                         FUNCTION GETSYM                             *
!C**********************************************************************
!C Computes the symmetric part of a (3x3) matrix A                     *
!C**********************************************************************
    function getsym(A) result(ASYM)

    real(kind=8)    ::  A(3,3), ASYM(3,3)

    intent(in)      ::  A

    ASYM = 0.5d0*(A+TRANSP3(A))

    end function getsym

!C**********************************************************************
!C                         FUNCTION GETSKW                             *
!C**********************************************************************
!C Computes the symmetric part of a (3x3) matrix A                     *
!C**********************************************************************
    function getskw(A) result(ASKW)

    real(kind=8)    ::  A(3,3), ASKW(3,3)

    intent(in)      ::  A

    ASKW = 0.5d0*(A-TRANSP3(A))

    end function getskw

!C**********************************************************************
!C                         FUNCTION FLATTEN                            *
!C**********************************************************************
!C To flatten the array A (N,M) into the vector y (M*N) row-vise       *
!C**********************************************************************
    function flatten(A) result(y)

    implicit none

    REAL(kind=8)    ::  A(:,:)
    REAL(kind=8), allocatable :: y(:)
    INTEGER ::  shpA(2), i, j, k

    intent(in) :: A

    shpA = shape(A)
    allocate(y(shpA(2)*shpA(1)))
    k = 0
    if (allocated(y)) then
        do i=1,shpA(1)
            do j=1,shpA(2)
                k = k + 1
                y(k) = A(i,j)
            end do
        end do
    end if

    end function flatten

!C**********************************************************************
!C                         FUNCTION reshape_rows                          *
!C**********************************************************************
!C Reshape the vector y (M*N) into the array A (N,M) row-vise          *
!C**********************************************************************
    function reshape_rows(y, shp) result(A)

    real(kind=8)    ::  y(:)
    integer(kind=8), allocatable :: A(:,:)
    integer ::  shp(2), i, j, k

    intent(in) :: y, shp

    allocate(A(shp(1),shp(2)))
    k = 0
    if (allocated(A)) then
        do i=1,shp(1)*shp(2),shp(2)
            k = k + 1
            A(k,:) = y(i:i+shp(2)-1)
        end do
    end if

    end function reshape_rows

!C**********************************************************************
!C                         FUNCTION DETERM                             *
!C**********************************************************************
!C Computes the determinant of a (3x3) matrix                          *
!C**********************************************************************
    function determ(A) result(DET)

    real(kind=8)    ::  A(3,3), DET

    intent(in)      ::  A

    DET = A(1,1)*A(2,2)*A(3,3) + &
            A(2,1)*A(3,2)*A(1,3) + &
            A(3,1)*A(1,2)*A(2,3) - &
            A(3,1)*A(2,2)*A(1,3) - &
            A(1,1)*A(3,2)*A(2,3) - &
            A(2,1)*A(1,2)*A(3,3)

    IF (ABS(DET) < 1.D-12) THEN
        WRITE(*,*) 'Determinant is null!'
        READ(*,*)
        STOP
    END IF

    end function determ

!C**********************************************************************
!C                         FUNCTION POLAR                              *
!C**********************************************************************
!C Polar decomposition of F = R.U using the Cayley-Hamilton theorem    *
!C see Nemat-Nasser's book p.55                                        *
!C Returns R                                                           *
!C**********************************************************************
    function polar(F) result(R)

    real(kind=8)    :: F(3,3),R(3,3),C(3,3),CS(3,3),U(3,3),UI(3,3),C1,C3,P, &
                        CD11,CD22,CD33,CD2,CD3,U1,U2,U3,A,B,PHI,L1,D,E,A3,B2
    integer         :: I,J,K

    intent(in)      :: F

    !C Compute stretch tensor: C = F^T.F
    DO J=1,3
        DO I=1,3
            C(I,J)=0.D0
            DO K=1,3
                C(I,J)=C(I,J)+F(K,I)*F(K,J)
            END DO
        END DO
    END DO
    !C Compute C^2
    CS = MMULT(C, C)
    !C Compute invariants
    C1=C(1,1)+C(2,2)+C(3,3)

    C3=C(1,1)*(C(2,2)*C(3,3)-C(2,3)*C(3,2))+ &
        C(1,2)*(C(2,3)*C(3,1)-C(2,1)*C(3,3))+ &
        C(1,3)*(C(2,1)*C(3,2)-C(2,2)*C(3,1))

    !C Invariants of the deviatoric part CD of tensor C
    P=(C(1,1)+C(2,2)+C(3,3))/3.D0

    CD11=C(1,1)-P
    CD22=C(2,2)-P
    CD33=C(3,3)-P

    CD2=CD11*CD22+CD11*CD33+CD22*CD33- &
        (C(1,2)*C(2,1)+C(1,3)*C(3,1)+C(2,3)*C(3,2))
    CD3=CD11*(CD22*CD33-C(2,3)*C(3,2))+ &
        C(1,2)*(C(2,3)*C(3,1)-C(2,1)*CD33)+ &
        C(1,3)*(C(2,1)*C(3,2)-CD22*C(3,1))
    !C Invariants of U
    U3=sqrt(C3)
    A=-CD2/3.D0
    B=CD3/2.D0
    A3=A**3.D0
    B2=B*B

    IF (ABS(A3-B2).GT.1.D-12) THEN
        PHI=ACOS(B/A**(3.D0/2.D0))
        L1=SQRT(C1/3.D0+2.D0*SQRT(A)*COS(PHI/3.D0))
    ELSE
        L1=SQRT(C1/3.D0)
    END IF

    U1=L1+SQRT(C1-L1*L1+2.D0*U3/L1)
    U2=0.5D0*(U1*U1-C1)
    !C Computes U
    D=U3-U1*U2
    E=U1**2.D0-U2
    DO I=1,3
        DO J=1,3
            U(I,J)=(CS(I,J)-E*C(I,J))/D
            IF (I.EQ.J) THEN
                U(I,J)=U(I,J)-U1*U3/D
            END IF
        END DO
    END DO
    UI = minv3(U)
    R = mmult(F,UI)

    end function polar

!C**********************************************************************
!C                         function MNORM                              *
!C**********************************************************************
!C Computes the norm of a (RxC) matrix using double contraction        *
!C Norm = (Tr(A.A^T))^1/2 = (A:A)^1/2                                  *
!C**********************************************************************
    function mnorm(A) result(norma)

    integer         :: sha(2)
    real(kind=8)    :: A(:,:), norma
    integer         :: I, J

    intent(in)      :: A

    shA = shape(A)
    norma = 0.D0
    DO I=1,shA(1)
        DO J=1,shA(2)
            norma = norma + A(I,J)**2
        END DO
    END DO

    norma = SQRT(norma)

    end function mnorm

! ###################
    pure function vdot(x,y) result(z)

    real(kind=8)	::  x(:), y(:), z
    integer			::  i

    intent(in)      ::  x, y

	z = 0.d0
    do i = 1, size(x)
        z = z + x(i)*y(i)
    end do

    end function vdot
! ###################

! ###################
	pure function cross(x,y) result(z)

	real(kind=8)	::  x(3), y(3), z(3)

    intent(in)      ::  x, y

	z(1) = x(2)*y(3)-y(2)*x(3)
	z(2) = x(3)*y(1)-y(3)*x(1)
	z(3) = x(1)*y(2)-y(1)*x(2)

    end function cross
! ###################

! ###################
    pure function norm(x) result(y)

    real(kind=8)	::  x(:), y
    integer			::  i

    intent(in)      ::  x

	y = 0.d0
    do i = 1, size(x)
        y = y + x(i)**2
    end do
	y = sqrt(y)

    end function norm
! ###################

! ###################
    function eye(n) result(A)

    integer			::  n, i
    real(kind=8)	::  A(n,n)

    intent(in)      ::  n

	A = 0.d0
    do i = 1, n
        A(i,i) = 1.d0
    end do

    end function eye
! ###################

! ###################
    function outer3(x,y) result(A)

    integer			::  i, j
    real(kind=8)	::  x(3), y(3), A(3,3)

    intent(in)      ::  x, y

	A = 0.d0
    do i = 1,3
        do j = 1,3
            A(i,j) = x(i)*y(j)
        end do
    end do

    end function outer3
! ###################

! ###################
    function inner(A,B) result(c)

    integer			::  i, j
    real(kind=8)	::  A(3,3), B(3,3), c

    intent(in)      ::  A, B

	c = 0.d0
    do i = 1,3
        do j = 1,3
            c = c + A(i,j)*B(i,j)
        end do
    end do

    end function inner
! ###################

! ###################
    function mean(x) result(a)

    real(kind=8)	::  x(:), a

    intent(in)      ::  x

    a = sum(x)/size(x)

    end function mean
! ###################

! ###################
    function schmidt(e2, e1) result(e2a)
    ! Schmidt ortho-normalize e2 against e1

    real(kind=8)	::  e2(3), e1(3), e2a(3), e3(3), l3

    intent(in)      ::  e2, e1

    e3 = cross(e1, e2)
    l3 = norm(e3)
    if (l3 < 1.d-10) then
        e2a = e2
        e2a(1) = e2a(1) + 1.d0
        e3 = cross(e1,e2a)
        l3 = norm(e3)
        if (l3==0) then
            e2a = e2
            e2a(2) = e2a(2) + 1.d0
            e3 = cross(e1, e2a)
            l3 = norm(e3)
        end if
    end if
    e3 = e3/l3

    e2a = cross(e3, e1)
    e2a = e2a/norm(e2a)
    end function schmidt
! ###################

! ###################
    subroutine minverse(a,c,n)
!============================================================
! Inverse matrix
! Method: Based on Doolittle LU factorization for Ax=b
! Alex G. December 2009
!-----------------------------------------------------------
! input ...
! a(n,n) - array of coefficients for matrix A
! n      - dimension
! output ...
! c(n,n) - inverse matrix of A
! comments ...
! the original matrix a(n,n) will be destroyed
! during the calculation
!===========================================================
    integer        ::  n
    real(kind=8)   ::  a(n,n), c(n,n)
    real(kind=8)   ::  L(n,n), U(n,n), b(n), d(n), x(n)
    real(kind=8)   ::  coeff
    integer        ::  i, j, k

    intent(in)     ::  n
    intent(out)    ::  c

    ! step 0: initialization for matrices L and U and b
    ! Fortran 90/95 allows such operations on matrices
    L = 0.d0
    U = 0.d0
    b = 0.d0

    ! step 1: forward elimination
    do k=1, n-1
        do i=k+1,n
            coeff=a(i,k)/a(k,k)
            L(i,k) = coeff
            do j=k+1,n
                a(i,j) = a(i,j)-coeff*a(k,j)
            end do
        end do
    end do

    ! Step 2: prepare L and U matrices
    ! L matrix is a matrix of the elimination coefficient
    ! + the diagonal elements are 1.0
    do i=1,n
        L(i,i) = 1.0
    end do
    ! U matrix is the upper triangular part of A
    do j=1,n
        do i=1,j
        U(i,j) = a(i,j)
        end do
    end do

    ! Step 3: compute columns of the inverse matrix C
    do k=1,n
        b(k)=1.0
        d(1) = b(1)
    ! Step 3a: Solve Ld=b using the forward substitution
        do i=2,n
        d(i)=b(i)
        do j=1,i-1
            d(i) = d(i) - L(i,j)*d(j)
        end do
        end do
    ! Step 3b: Solve Ux=d using the back substitution
        x(n)=d(n)/U(n,n)
        do i = n-1,1,-1
        x(i) = d(i)
        do j=n,i+1,-1
            x(i)=x(i)-U(i,j)*x(j)
        end do
        x(i) = x(i)/u(i,i)
        end do
    ! Step 3c: fill the solutions x(n) into column k of C
        do i=1,n
        c(i,k) = x(i)
        end do
        b(k)=0.0
    end do

    end subroutine minverse

	SUBROUTINE JACOBI(A,N,NP,D,V,NROT)

!  Purpose: Computes all eigenvalues and eigenvectors of a real
!     symmetric matrix A, which is of size N by N, stored in a
!     physical NP by NP array.  On output, elements of A above the
!     diagonal are destroyed.  D returns the eigenvalues of A in
!     its first N elements.  V is a matrix with the same logical and
!     physical dimensions as A whose columns contain, on output, the
!     normalized eigenvectors of A.  NROT returns the number of Jacobi
!     rotations which were required.
!
!  Source: W. H. Press et al., "Numerical Recipes", 1989, p. 346.
!
!  Modifications:
!
!     1. Double precision version
!
!  Prepared by J. Applequist, 10/23/91

    IMPLICIT REAL*8(A-H,O-Z)
    INTEGER, PARAMETER :: NMAX=100
    INTEGER :: I, IP, IQ, J, N, NP, NROT
    DIMENSION :: A(NP,NP),D(NP),V(NP,NP),B(NMAX),Z(NMAX)

!     Initialize the identity matrix.

    DO 12 IP=1,N
    DO 11 IQ=1,N
    V(IP,IQ)=0.D0
11   CONTINUE
    V(IP,IP)=1.D0
12   CONTINUE

!     Initialize B and D to the diagonal of A.

    DO 13 IP=1,N
    B(IP)=A(IP,IP)
    D(IP)=B(IP)
    Z(IP)=0.D0
13   CONTINUE
    NROT=0
    DO 24 I=1,50
    SM=0.D0

!     Sum off-diagonal elements.

    DO 15 IP=1,N-1
    DO 14 IQ=IP+1,N
    SM=SM+DABS(A(IP,IQ))
14   CONTINUE
15   CONTINUE
    IF (SM.EQ.0.D0) RETURN
    IF (I.LT.4) THEN
    TRESH=0.2D0*SM/N**2
    ELSE
    TRESH=0.D0
    ENDIF
    DO 22 IP=1,N-1
    DO 21 IQ=IP+1,N
    G=100.D0*DABS(A(IP,IQ))

!     After four sweeps, skip the rotation if the off-diagonal
!     element is small.

    IF ((I.GT.4).AND.(DABS(D(IP))+G.EQ.DABS(D(IP))) &
    .AND.(DABS(D(IQ))+G.EQ.DABS(D(IQ)))) THEN
    A(IP,IQ)=0.D0
    ELSE IF (DABS(A(IP,IQ)).GT.TRESH) THEN
    H=D(IQ)-D(IP)
    IF (DABS(H)+G.EQ.DABS(H)) THEN
    T=A(IP,IQ)/H
    ELSE
    THETA=0.5D0*H/A(IP,IQ)
    T=1.D0/(DABS(THETA)+DSQRT(1.D0+THETA**2))
    IF (THETA.LT.0.D0) T=-T
    ENDIF
    C=1.D0/DSQRT(1.D0+T**2)
    S=T*C
    TAU=S/(1.D0+C)
    H=T*A(IP,IQ)
    Z(IP)=Z(IP)-H
    Z(IQ)=Z(IQ)+H
    D(IP)=D(IP)-H
    D(IQ)=D(IQ)+H
    A(IP,IQ)=0.D0
    DO 16 J=1,IP-1
    G=A(J,IP)
    H=A(J,IQ)
    A(J,IP)=G-S*(H+G*TAU)
    A(J,IQ)=H+S*(G-H*TAU)
16   CONTINUE
    DO 17 J=IP+1,IQ-1
    G=A(IP,J)
    H=A(J,IQ)
    A(IP,J)=G-S*(H+G*TAU)
    A(J,IQ)=H+S*(G-H*TAU)
17   CONTINUE
    DO 18 J=IQ+1,N
    G=A(IP,J)
    H=A(IQ,J)
    A(IP,J)=G-S*(H+G*TAU)
    A(IQ,J)=H+S*(G-H*TAU)
18   CONTINUE
    DO 19 J=1,N
    G=V(J,IP)
    H=V(J,IQ)
    V(J,IP)=G-S*(H+G*TAU)
    V(J,IQ)=H+S*(G-H*TAU)
19   CONTINUE
    NROT=NROT+1
    ENDIF
21   CONTINUE
22   CONTINUE
    DO 23 IP=1,N
    B(IP)=B(IP)+Z(IP)
    D(IP)=B(IP)
    Z(IP)=0.D0
23   CONTINUE
24   CONTINUE
    WRITE (6,600)
600  FORMAT(/'50 ITERATIONS OCCURRED IN SUBROUTINE JACOBI.')
    RETURN
    END SUBROUTINE JACOBI

! ###################

    subroutine linspace(min, max, array)
        real(kind=8)	::  step, dx
        integer         ::  n_steps, i

        real(kind=8), intent(in)      ::  min, max
        real(kind=8), intent(out)     ::  array(:)

        n_steps = size(array)

        if (n_steps == 0) return

        if (n_steps == 1) then
            array(1) = min
            return
        end if

        dx = (max - min) / real(n_steps - 1)

        do i=1,n_steps
            array(i) = min + dx*(i-1)
        end do

    end subroutine linspace

end module utils


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

!> @brief Computes Legendre polynomial and its derivative on a given point x.
!! @author Ilario Mazzieri
!> @date September, 2013
!> @version 1.0
!> @param[in] n  degree of the polynomial
!> @param[in] x point
!> @param[out] p2  Legendre polynomial of degree n evaluated in x
!> @param[out] p2der  derivative of p2 evaluated in x
!> @param[out] p1  Legendre polynomial of degree n-1 evaluated in x
!> @param[out] p1der  derivative of p1 evaluated in x

      subroutine GET_LEGENDRE_VALUE(p2,p2der,p1,p1der,n,x)

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

      p2 = 1.d0
      p2der = 0.d0
      if (n .eq. 0) return
      p1 = p2
      p2 = x
      p1der = p2der
      p2der = 1.d0
      if (n .eq. 1) return
      do k = 1, n-1
        p0 = p1
        p1 = p2
        p0der = p1der
        p1der = p2der
        dk = dfloat(k)
        a1 = (2.d0*dk+1.d0) / (dk+1.d0)
        a2 = -dk / (dk+1.d0)
        p2 = a1*p1*x + a2*p0
        p2der = a1*p1 + a1*p1der*x + a2*p0der
      enddo

      return
      end subroutine GET_LEGENDRE_VALUE


submodule(forlab_math) forlab_math_cross

    implicit none

contains

    pure module function cross_rsp(x, y) result(cross)
        real(sp), intent(in) :: x(3), y(3)
        real(sp) :: cross(3)

        cross(1) = x(2)*y(3) - x(3)*y(2)
        cross(2) = x(3)*y(1) - x(1)*y(3)
        cross(3) = x(1)*y(2) - x(2)*y(1)

    end function cross_rsp
    pure module function cross_rdp(x, y) result(cross)
        real(dp), intent(in) :: x(3), y(3)
        real(dp) :: cross(3)

        cross(1) = x(2)*y(3) - x(3)*y(2)
        cross(2) = x(3)*y(1) - x(1)*y(3)
        cross(3) = x(1)*y(2) - x(2)*y(1)

    end function cross_rdp
    pure module function cross_iint8(x, y) result(cross)
        integer(int8), intent(in) :: x(3), y(3)
        integer(int8) :: cross(3)

        cross(1) = x(2)*y(3) - x(3)*y(2)
        cross(2) = x(3)*y(1) - x(1)*y(3)
        cross(3) = x(1)*y(2) - x(2)*y(1)

    end function cross_iint8
    pure module function cross_iint16(x, y) result(cross)
        integer(int16), intent(in) :: x(3), y(3)
        integer(int16) :: cross(3)

        cross(1) = x(2)*y(3) - x(3)*y(2)
        cross(2) = x(3)*y(1) - x(1)*y(3)
        cross(3) = x(1)*y(2) - x(2)*y(1)

    end function cross_iint16
    pure module function cross_iint32(x, y) result(cross)
        integer(int32), intent(in) :: x(3), y(3)
        integer(int32) :: cross(3)

        cross(1) = x(2)*y(3) - x(3)*y(2)
        cross(2) = x(3)*y(1) - x(1)*y(3)
        cross(3) = x(1)*y(2) - x(2)*y(1)

    end function cross_iint32
    pure module function cross_iint64(x, y) result(cross)
        integer(int64), intent(in) :: x(3), y(3)
        integer(int64) :: cross(3)

        cross(1) = x(2)*y(3) - x(3)*y(2)
        cross(2) = x(3)*y(1) - x(1)*y(3)
        cross(3) = x(1)*y(2) - x(2)*y(1)

    end function cross_iint64

end submodule forlab_math_cross


submodule (stdlib_math) stdlib_math_linspace

implicit none

contains

    module function linspace_default_1_rsp_rsp(start, end) result(res)
      real(sp), intent(in) :: start
      real(sp), intent(in) :: end

      real(sp) :: res(DEFAULT_LINSPACE_LENGTH)

      res = linspace(start, end, DEFAULT_LINSPACE_LENGTH)

    end function linspace_default_1_rsp_rsp
    module function linspace_default_1_rdp_rdp(start, end) result(res)
      real(dp), intent(in) :: start
      real(dp), intent(in) :: end

      real(dp) :: res(DEFAULT_LINSPACE_LENGTH)

      res = linspace(start, end, DEFAULT_LINSPACE_LENGTH)

    end function linspace_default_1_rdp_rdp
    module function linspace_default_1_rqp_rqp(start, end) result(res)
      real(qp), intent(in) :: start
      real(qp), intent(in) :: end

      real(qp) :: res(DEFAULT_LINSPACE_LENGTH)

      res = linspace(start, end, DEFAULT_LINSPACE_LENGTH)

    end function linspace_default_1_rqp_rqp

    module function linspace_n_1_rsp_rsp(start, end, n) result(res)
      real(sp), intent(in) :: start
      real(sp), intent(in) :: end
      integer, intent(in) :: n

      real(sp) :: res(max(n, 0))

      integer :: i    ! Looping index
      real(sp) :: interval ! Difference between adjacent elements

      if(n <= 0) return ! If passed length is less than or equal to 0, return an empty (allocated with length 0) array
      if(n == 1) then
        res(1) = end
        return
      end if

      interval = (end - start) / real((n - 1), sp)

      res(1) = start
      res(n) = end

      do i = 2, n - 1

        res(i) = real((i-1), sp) * interval + start

      end do

    end function linspace_n_1_rsp_rsp
    module function linspace_n_1_rdp_rdp(start, end, n) result(res)
      real(dp), intent(in) :: start
      real(dp), intent(in) :: end
      integer, intent(in) :: n

      real(dp) :: res(max(n, 0))

      integer :: i    ! Looping index
      real(dp) :: interval ! Difference between adjacent elements

      if(n <= 0) return ! If passed length is less than or equal to 0, return an empty (allocated with length 0) array
      if(n == 1) then
        res(1) = end
        return
      end if

      interval = (end - start) / real((n - 1), dp)

      res(1) = start
      res(n) = end

      do i = 2, n - 1

        res(i) = real((i-1), dp) * interval + start

      end do

    end function linspace_n_1_rdp_rdp
    module function linspace_n_1_rqp_rqp(start, end, n) result(res)
      real(qp), intent(in) :: start
      real(qp), intent(in) :: end
      integer, intent(in) :: n

      real(qp) :: res(max(n, 0))

      integer :: i    ! Looping index
      real(qp) :: interval ! Difference between adjacent elements

      if(n <= 0) return ! If passed length is less than or equal to 0, return an empty (allocated with length 0) array
      if(n == 1) then
        res(1) = end
        return
      end if

      interval = (end - start) / real((n - 1), qp)

      res(1) = start
      res(n) = end

      do i = 2, n - 1

        res(i) = real((i-1), qp) * interval + start

      end do

    end function linspace_n_1_rqp_rqp

      module procedure linspace_default_1_csp_csp

        res = linspace(start, end, DEFAULT_LINSPACE_LENGTH)

      end procedure linspace_default_1_csp_csp
      module procedure linspace_default_1_cdp_cdp

        res = linspace(start, end, DEFAULT_LINSPACE_LENGTH)

      end procedure linspace_default_1_cdp_cdp
      module procedure linspace_default_1_cqp_cqp

        res = linspace(start, end, DEFAULT_LINSPACE_LENGTH)

      end procedure linspace_default_1_cqp_cqp

      module procedure linspace_n_1_csp_csp

        real(sp) :: x(max(n, 0)) ! array of the real part of complex number
        real(sp) :: y(max(n, 0)) ! array of the imaginary part of the complex number

        x = linspace(start%re, end%re, n)
        y = linspace(start%im, end%im, n)

        res = cmplx(x, y, kind=sp)

      end procedure linspace_n_1_csp_csp
      module procedure linspace_n_1_cdp_cdp

        real(dp) :: x(max(n, 0)) ! array of the real part of complex number
        real(dp) :: y(max(n, 0)) ! array of the imaginary part of the complex number

        x = linspace(start%re, end%re, n)
        y = linspace(start%im, end%im, n)

        res = cmplx(x, y, kind=dp)

      end procedure linspace_n_1_cdp_cdp
      module procedure linspace_n_1_cqp_cqp

        real(qp) :: x(max(n, 0)) ! array of the real part of complex number
        real(qp) :: y(max(n, 0)) ! array of the imaginary part of the complex number

        x = linspace(start%re, end%re, n)
        y = linspace(start%im, end%im, n)

        res = cmplx(x, y, kind=qp)

      end procedure linspace_n_1_cqp_cqp

      module procedure linspace_default_1_iint8_iint8

        res = linspace(real(start, kind=dp), real(end, kind=dp), DEFAULT_LINSPACE_LENGTH)

      end procedure linspace_default_1_iint8_iint8
      module procedure linspace_default_1_iint16_iint16

        res = linspace(real(start, kind=dp), real(end, kind=dp), DEFAULT_LINSPACE_LENGTH)

      end procedure linspace_default_1_iint16_iint16
      module procedure linspace_default_1_iint32_iint32

        res = linspace(real(start, kind=dp), real(end, kind=dp), DEFAULT_LINSPACE_LENGTH)

      end procedure linspace_default_1_iint32_iint32
      module procedure linspace_default_1_iint64_iint64

        res = linspace(real(start, kind=dp), real(end, kind=dp), DEFAULT_LINSPACE_LENGTH)

      end procedure linspace_default_1_iint64_iint64

      module procedure linspace_n_1_iint8_iint8

        res = linspace(real(start, kind=dp), real(end, kind=dp), n)

      end procedure linspace_n_1_iint8_iint8
      module procedure linspace_n_1_iint16_iint16

        res = linspace(real(start, kind=dp), real(end, kind=dp), n)

      end procedure linspace_n_1_iint16_iint16
      module procedure linspace_n_1_iint32_iint32

        res = linspace(real(start, kind=dp), real(end, kind=dp), n)

      end procedure linspace_n_1_iint32_iint32
      module procedure linspace_n_1_iint64_iint64

        res = linspace(real(start, kind=dp), real(end, kind=dp), n)

      end procedure linspace_n_1_iint64_iint64

end submodule


program mruv
implicit none

!variables
real :: t_0, t_3, t !tiempo
real :: t_i, t_f !tiempo en un rango específico
real :: v_0 !velocidad
real :: v_i, v_f
real :: a !aceleración
real :: x, x_0, d !posición

!entrada
t_0 = 0.
t_3 = 3.
v_0 = 10.

!mensaje
write(*,*) '**********************************************************'
write(*,*) 'Este es un programa que permite el cálculo de la posicion'
write(*,*) 'de un móvil para cualquier tiempo "t" con aceleración'
write(*,*) 'variable.'
write(*,*) '**********************************************************'

print*, 'Ingrese el valor de t(s)'
read*, t
print*, 'Ingrese el valor de x0= (m)'
read*, x_0
print*, 'Ingrese los valores de t_i y t_f'
read*, t_i, t_f
print*, 'Ingrese los valores de v_i y v_f'
read*, v_i, v_f

!operaciones
a = (v_f - v_i) / (t_f - t_i)
d = v_0 * (t_3 - t_0) + 0.5 * a * (t_3 - t_0)**2
x = x_0 + v_0*(t - t_0) + 0.5 * a * (t-t_0)

!salida
print*, 'La distancia es ', d
print*, 'La posición x es ', x

end program mruv


!-------------------------------------------------------------------
!
!	Numerical Recipes random number generator for
!       a Gaussian distribution
!
! ----------------------------------------------------------------------------

FUNCTION GASDEV(idum)

!     ..Arguments..
integer          idum
real GASDEV

!     ..Local..
real v1,v2,r,fac
real ran3

if (idum.lt.0) iset=0
10   v1=2*ran3(idum)-1
v2=2*ran3(idum)-1
r=v1**2+v2**2
if(r.ge.1.or.r.eq.0) GOTO 10
fac=sqrt(-2*log(r)/r)
GASDEV=v2*fac

RETURN
END

!-------------------------------------------------------------------
!
!	Numerical Recipes random number generator
!
! ----------------------------------------------------------------------------

FUNCTION ran3(idum)
INTEGER idum
INTEGER MBIG,MSEED,MZ
!     REAL MBIG,MSEED,MZ
REAL ran3,FAC
PARAMETER (MBIG=1000000000,MSEED=161803398,MZ=0,FAC=1./MBIG)
!     PARAMETER (MBIG=4000000.,MSEED=1618033.,MZ=0.,FAC=1./MBIG)
INTEGER i,iff,ii,inext,inextp,k
INTEGER mj,mk,ma(55)
!     REAL mj,mk,ma(55)
SAVE iff,inext,inextp,ma
DATA iff /0/
! write(*,*)' idum ',idum
if(idum.lt.0.or.iff.eq.0)then
	iff=1
	mj=MSEED-iabs(idum)
	mj=mod(mj,MBIG)
	ma(55)=mj
	mk=1
	do 11 i=1,54
	ii=mod(21*i,55)
	ma(ii)=mk
	mk=mj-mk
	if(mk.lt.MZ)mk=mk+MBIG
	mj=ma(ii)
!  write(*,*)' idum av',idum
11      continue
	do 13 k=1,4
	do 12 i=1,55
	ma(i)=ma(i)-ma(1+mod(i+30,55))
	if(ma(i).lt.MZ)ma(i)=ma(i)+MBIG
12        continue
13      continue
! write(*,*)' idum ap',idum
	inext=0
	inextp=31
	idum=1
endif
! write(*,*)' idum app ',idum
inext=inext+1
if(inext.eq.56)inext=1
inextp=inextp+1
if(inextp.eq.56)inextp=1
mj=ma(inext)-ma(inextp)
if(mj.lt.MZ)mj=mj+MBIG
ma(inext)=mj
ran3=mj*FAC
!  write(*,*)' idum ',idum

return
END

!the code is finished.


      program jacobi
      integer count, maxcyc, p, q, i
      real a(100, 100), x
      real app, apq, aqq, theta, c, s, csq, ssq, cs, aip, aiq
      do 10 count = 1, maxcyc
         do 10 p=1,n-1
            do 10 q = p+1,n
               app = a(p,p)
               apq = a(p,q)
               aqq = a(q,q)
               theta = atan2(2.0*apq, app-aqq)/2.0
               c = cos(theta)
               s = sin(theta)
               csq = c*c
               ssq = s*s
               cs = c*s
               a(p,p) = csq * app + 2.0*cs*apq + ssq * aqq
               a(q,q) = ssq * app - 2.0*cs*apq + csq * aqq
               a(p,q) = 0.0
               a(q,p) = 0.0
               do 20 i=1, p-1
                  aip = a(i,p)
                  aiq = a(i,q)
                  a(i,p) = c*aip + s*aiq
                  a(p,i) = a(i,p)
                  a(i,q) = -s*aip + c*aiq
                  a(q,i) = a(i,q)
 20            continue
               do 30 i=p+1,q-1
                  aip = a(i,p)
                  aiq = a(i,q)
                  a(i,p) = c*aip + s*aiq
                  a(p,i) = a(i,p)
                  a(i,q) = -s*aip + c*aiq
                  a(q,i) = a(i,q)
 30            continue
               do 40 i=q+1,n
                  aip = a(i,p)
                  aiq = a(i,q)
                  a(i,p) = c*aip + s*aiq
                  a(p,i) = a(i,p)
                  a(i,q) = -s*aip + c*aiq
                  a(q,i) = a(i,q)
 40            continue
 10         continue
      end


program vanpol

  use stiff3_solver, only: wp => stiff3_wp, stiff3
  implicit none

  integer, parameter :: n = 2, nout = 1
  real(wp), parameter :: mu = 10.0_wp
  real(wp) :: y(n), w(n), x0, x1, h0, eps

! initial value
  y = [1.0_wp, 1.0_wp]
! initial step size
  h0 = 0.001_wp
! tolerance
  eps = 1.0e-4_wp
  w = 1
! time interval
  x0 = 0.0_wp
  x1 = 100.0_wp
! output initial condition
  call out(x0,y,0,0.0_wp)
! integrate system of ODEs
  call stiff3(n,fun,jac,out,nout,x0,x1,h0,eps,w,y)

contains

  subroutine fun(n,y,f)
    integer, intent(in) :: n
    real(wp), intent(in) :: y(n)
    real(wp), intent(inout) :: f(n)
    f(1) = y(2)
    f(2) = mu*(1.0_wp - y(1)**2)*y(2) - y(1)
  end subroutine

  subroutine jac(n,y,df)
    integer, intent(in) :: n
    real(wp), intent(in) :: y(n)
    real(wp), intent(inout) :: df(n,n)
    df(1,1) = 0.0_wp
    df(1,2) = 1.0_wp
    df(2,1) = mu*y(2)*(-2*y(1)) - 1.0_wp
    df(2,2) = mu*(1.0_wp - y(1)**2)
  end subroutine

  subroutine out(t,y,ih,qa)
    real(wp), intent(in) :: t
    real(wp), intent(in) :: y(:)
    integer, intent(in) :: ih
    real(wp), intent(in) :: qa
    write(*,'(3(E18.12,2X),I4,2X,G0)') t, y(1), y(2), ih, qa
  end subroutine

end program


subroutine spline(n, x, y, b, c, d)
implicit none
integer n
real(8) x(n), y(n), b(n), c(n), d(n)
integer nm1, ib, i
real(8) t

nm1 = n-1
if(n<2) return
if(n<3) then
  b(1) = (y(2)-y(1))/(x(2)-x(1))
  c(1) = 0.
  d(1) = 0.
  b(2) = b(1)
  c(2) = 0.
  d(2) = 0.
  return
end if

d(1) = x(2) - x(1)
c(2) = (y(2) - y(1))/d(1)
do i = 2, nm1
  d(i) = x(i+1) - x(i)
  b(i) = 2.*(d(i-1) + d(i))
  c(i+1) = (y(i+1) - y(i))/d(i)
  c(i) = c(i+1) - c(i)
end do

b(1) = -d(1)
b(n) = -d(n-1)
c(1) = 0.
c(n) = 0.
if(n>3) then
  c(1) = c(3)/(x(4)-x(2)) - c(2)/(x(3)-x(1))
  c(n) = c(n-1)/(x(n)-x(n-2)) - c(n-2)/(x(n-1)-x(n-3))
  c(1) = c(1)*d(1)**2/(x(4)-x(1))
  c(n) = -c(n)*d(n-1)**2/(x(n)-x(n-3))
end if

do i = 2, n
  t = d(i-1)/b(i-1)
  b(i) = b(i) - t*d(i-1)
  c(i) = c(i) - t*c(i-1)
end do

c(n) = c(n)/b(n)
do ib = 1, nm1
  i = n-ib
  c(i) = (c(i) - d(i)*c(i+1))/b(i)
end do

b(n) = (y(n) - y(nm1))/d(nm1) + d(nm1)*(c(nm1) + 2.*c(n))
do i = 1, nm1
  b(i) = (y(i+1) - y(i))/d(i) - d(i)*(c(i+1) + 2.*c(i))
  d(i) = (c(i+1) - c(i))/d(i)
  c(i) = 3.*c(i)
end do
c(n) = 3.*c(n)
d(n) = d(n-1)
return

end subroutine spline

real(8) function seval(n, u, x, y, b, c, d)
implicit none
integer n
real(8) u, x(n), y(n), b(n), c(n), d(n)
integer i, j, k
real(8) dx

i = 1
if(u>x(2)) then
  j = n+1
  do while(j>i+1)
    k = (i+j)/2
    if (u<x(k)) j = k
    if (u>=x(k)) i = k
  end do
end if

dx = u - x(i)
seval = y(i) + dx*(b(i) + dx*(c(i) + dx*d(i)))
return

end function seval


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   RMG - Reaction Mechanism Generator
!
!   Copyright (c) 2002-2009 Prof. William H. Green (whgreen@mit.edu) and the
!   RMG Team (rmg_dev@mit.edu)
!
!   Copyright (c) 2009 by Josh Allen (chemejosh@gmail.com)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the 'Software'),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
!   AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

recursive function factorial(x) result(res)
    implicit none
    integer, intent(in) :: x
    integer :: res
    if (x <= 1) then
        res = 1
    else
        res = x * factorial(x - 1)
    end if
end function

function besseli(v, z) result(res)
    implicit none
    integer, intent(in) :: v
    real(8), intent(in) :: z
    real(8) :: res
    integer k, factorial
    real(8) term
    res = 0.0
    do k = 0, 25 - v
        term = (0.25 * z * z)**k / factorial(k) / factorial(k + v)
        res = res + term
        if (abs(term / res) < 1.0e-8) then
            res = res * (0.5 * z)**v
            return
        end if
    end do
    ! If we're here, then we didn't reach that tolerance
    ! Let's try a looser tolerance
    res = 0.0
    do k = 0, 25 - v
        term = (0.25 * z * z)**k / factorial(k) / factorial(k + v)
        res = res + term
        if (abs(term / res) < 1.0e-6) then
            res = res * (0.5 * z)**v
            return
        end if
    end do
    ! If we're here, then we didn't reach that tolerance either
    ! Let's try one more looser tolerance
    res = 0.0
    do k = 0, 25 - v
        term = (0.25 * z * z)**k / factorial(k) / factorial(k + v)
        res = res + term
        if (abs(term / res) < 1.0e-4) then
            res = res * (0.5 * z)**v
            return
        end if
    end do
    ! If we're here, then something's really gone bad
    ! Let's give up
    write (*,*) 'Warning: Unable to determine value of modified Bessel function for v =', v, 'z =', z
end function

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

function besseli0(x)
    implicit none

    real(8) x, besseli0

    real(8) Y,P1,P2,P3,P4,P5,P6,P7,Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9,AX,BX

    data P1,P2,P3,P4,P5,P6,P7/1.D0,3.5156229D0,3.0899424D0,1.2067429D0,  &
    0.2659732D0,0.360768D-1,0.45813D-2/

    data Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9/0.39894228D0,0.1328592D-1, &
    0.225319D-2,-0.157565D-2,0.916281D-2,-0.2057706D-1,  &
    0.2635537D-1,-0.1647633D-1,0.392377D-2/

    if (abs(x) < 3.75) then
        Y = x * x / 3.75 / 3.75
        besseli0 = P1+Y*(P2+Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7)))))
    else
        AX = abs(x)
        Y = 3.75 / AX
        BX = exp(AX)/sqrt(AX)
        AX = Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*(Q5+Y*(Q6+Y*(Q7+Y*(Q8+Y*Q9)))))))
        besseli0 = AX*BX
    end if

end function

function besseli1(x)
    implicit none

    real(8) x, besseli1

    real(8) Y,P1,P2,P3,P4,P5,P6,P7,Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9,AX,BX

    data P1,P2,P3,P4,P5,P6,P7/0.5D0,0.87890594D0,0.51498869D0,  &
    0.15084934D0,0.2658733D-1,0.301532D-2,0.32411D-3/

    data Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9/0.39894228D0,-0.3988024D-1, &
    -0.362018D-2,0.163801D-2,-0.1031555D-1,0.2282967D-1, &
    -0.2895312D-1,0.1787654D-1,-0.420059D-2/

    if (abs(x) < 3.75) then
        Y = x * x / 3.75 / 3.75
        besseli1 = P1+Y*(P2+Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7)))))
    else
        AX = abs(x)
        Y = 3.75 / AX
        BX = exp(AX)/sqrt(AX)
        AX = Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*(Q5+Y*(Q6+Y*(Q7+Y*(Q8+Y*Q9)))))))
        besseli1 = AX*BX
    end if

end function

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

recursive function besselratioperron(x, n) result(res)
    ! Recursively evaluates Perron's continued fraction for the modified
    ! Bessel function ratio I_1(x) / I_0(x) to 25 terms. A relevant citation is
    !
    ! W. Gautschi and J. Slavic. "On the Computation of Modified Bessel
    ! Function Ratios." Mathematics of Computation 32 (143), p. 865-875 (1978).

    implicit none
    real(8), intent(in) :: x
    integer, intent(in) :: n
    real(8) :: res

    if (n >= 25) then
        res = 0
    else
        res = (2 * n + 1) * x / (n + 2 + 2 * x - besselratioperron(x, n+1))
    end if

end function

function besselratio(x) result(res)
    ! Computes the ratio of modified bessel functions I_1(x) / I_0(x) using
    ! Perron's continued fraction.

    implicit none
    real(8), intent(in) :: x
    real(8) :: res

    real(8) :: besselratioperron

    res = x / (2 + x - besselratioperron(x, 1))

end function

function cellipk(x)
    implicit none
    real(8), intent(in) :: x
    real(8) :: cellipk

    real(8) A0, B0, A, B
    integer n

    if (x < 0 .or. x > 1) then
        cellipk = 0.0
        return
    end if

    A = 1.0 + x
    B = 1.0 - x
    do n = 0, 100
        A0 = A
        B0 = B
        A = (A0 + B0) / 2
        B = sqrt(A0 * B0)
        if (abs(A - B) < 1.0e-8) then
            cellipk = 3.141592654 / 2.0 / A
            return
        end if
    end do

    cellipk = 3.141592654 / 2.0 / A

end function

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


module module_gauss_legendre_quadrature
  use module_qlapack
  implicit none

  private
  public assemble_gauss_legendre

contains
  !> ガウス積分の分点と重みを計算する
  !! \param ng 分点の数
  !! \param gz 分点の座標
  !! \param we 重み
  subroutine assemble_gauss_legendre(n,gz,we)
    integer,intent(in) :: n
    real(16),intent(out) :: gz(n), we(n)

    ! 対称三重対角行列の対角成分
    real(16) :: td(n)

    ! 対称三重対角行列の非対角成分
    real(16) :: tl(n-1)

    ! 固有ベクトル
    complex(16) :: q(n,n)

    integer :: i, info
    real(16) :: work(2*n-2)

    td(:)=0.q0
    do i=1,n-1
       tl(i)=dble(i)/sqrt((2.q0*i-1.0q0)*(2.q0*i+1.q0))
    end do

    q(:,:)=cmplx(0.q0,0.q0,kind(1.q0))
    do i=1,n
       q(i,i)=cmplx(1.q0,0.q0,kind(1.q0))
    end do

    call qzsteqr("V",n,td,tl,q,n,work,info)

    do i=1,n
       gz(i)=td(i)
       we(i)=2.q0*(real(q(1,i))**2+aimag(q(1,i))**2)
    end do

  end subroutine assemble_gauss_legendre

end module module_gauss_legendre_quadrature


      PROGRAM MAIN
C     GAUSSIAN ELIMINATION
C     From: http://users.metu.edu.tr/azulfu/courses/es361/programs/fortran/GAUEL.FOR

      DIMENSION A(20,21)
      PRINT *
      PRINT *, 'GAUSS ELIMINATION'
      DATA  N/4/
      DATA  (A(1,J), J=1,5) /-40.0,28.5,0.,0.,1.81859/
      DATA  (A(2,J), J=1,5) /21.5,-40.0,28.5,0.,-1.5136/
      DATA  (A(3,J), J=1,5) /0.,21.5,-40.0,28.5,-0.55883/
      DATA (A(4,J), J=1,5) /0.,0.,21.5,-40.0,1.69372/
      PRINT *
      PRINT *, 'AUGMENTED MATRIX'
      PRINT *
      DO I=1,N
      PRINT 61, (A(I,J),J=1,5)
61        FORMAT(1X,5f8.4)
      END DO
      PRINT *
      CALL GAUSS(N,A)
65    PRINT *
68    PRINT *, 'SOLUTION'
      PRINT *, '...........................................'
69    PRINT *, '        I       X(I)'
70    PRINT *, '............................................'
        DO I=1,N
72         FORMAT(5X,I5, 1PE16.6)
           PRINT 72, I, A(I,N+1)
         END DO
75    PRINT *,'..............................................'
80    PRINT *
      STOP
      END PROGRAM MAIN
C*************************************
      SUBROUTINE GAUSS(N,A)
      INTEGER PV
      DIMENSION A(20,21)
      EPS=1.0
10    IF (1.0+EPS.GT.1.0) THEN
          EPS=EPS/2.0
          GOTO 10
      END IF
      EPS=EPS*2
      PRINT *,'      MACHINE EPSILON=',EPS
      EPS2=EPS*2
1005  DET=1.
      DO 1010 I=1,N-1
         PV=I
         DO J=I+1,N
            IF (ABS(A(PV,I)) .LT. ABS(A(J,I))) PV=J
         END DO
         IF (PV.EQ.I) GOTO 1050
         DO JC=1,N+1
          TM=A(I,JC)
          A(I,JC)=A(PV,JC)
          A(PV,JC)=TM
        END DO
1045    DET=-1*DET
1050    IF (A(I,I).EQ.0.0) GOTO 1200
        DO JR=I+1,N
           IF (A(JR,I).NE.0.0) THEN
              R=A(JR,I)/A(I,I)
              DO KC=I+1,N+1
              TEMP=A(JR,KC)
              A(JR,KC)=A(JR,KC)-R*A(I,KC)
              IF (ABS(A(JR,KC)).LT.EPS2*TEMP) A(JR,KC)=0.0
            END DO
          END IF
1060     END DO
1010  CONTINUE
      DO I=1,N
         DET=DET*A(I,I)
      END DO
      PRINT *
      PRINT *,' DETERMINANT= ',DET
      PRINT*
      IF (A(N,N).EQ.0.0) GOTO 1200
      A(N,N+1)=A(N,N+1)/A(N,N)
      DO NV=N-1,1,-1
         VA=A(NV,N+1)
         DO K=NV+1,N
            VA=VA-A(NV,K)*A(K,N+1)
         END DO
         A(NV,N+1)=VA/A(NV,NV)
      END DO
      RETURN
1100  CONTINUE
      RETURN
1200  PRINT *,'MATRIX IS SINGULAR'
      END


MODULE BackSub_Mod

    ! MICHAEL B. PORTER 7/1/85

    ! Based on TINVIT in EISPACK, once upon a time ...
    ! performs back-substitution for a symmetric tridiagonal linear system
    !
    ! On input
    !    N is the order of the matrix
    !    RV1,2,3,4 contain the LU factorization of A
    !    B contains the right hand side (Ax=b)
    ! On output
    !    b contains the solution

  IMPLICIT NONE
  INTEGER, PRIVATE :: i

  INTERFACE BackSub
     MODULE PROCEDURE BackSub_sngl, BackSub_dble
  END INTERFACE BackSub

CONTAINS

  SUBROUTINE BackSub_sngl( N, Rv1, Rv2, Rv4, b )

    INTEGER, INTENT( IN    ) :: N
    COMPLEX, INTENT( IN    ) :: Rv1( N ), Rv2( N ), Rv4( N )
    COMPLEX, INTENT( INOUT ) :: b( N )

    ! Forward elimination

    DO I = 2, N
       b( I ) = b( I ) - Rv4( I ) * b( I - 1 )
       ! prevent underflows from propagating:
       !IF ( ABS(  REAL( b( I ) ) ) < SMALL .AND. ABS( AIMAG( b( I ) ) ) < SMALL ) b( I ) = 0.0
    END DO

    ! Back-substitution (result in b)
    b( N ) = b( N ) * Rv1( N )

    IF ( N >= 2 ) THEN
       DO I = N - 1, 1, -1
          b( I ) = ( b( I ) - b( I + 1 ) * Rv2( I ) ) * Rv1( I )
       END DO
    END IF

  END SUBROUTINE BackSub_sngl

SUBROUTINE BackSub_dble( N, Rv1, Rv2, Rv4, b )

INTEGER,          INTENT( IN    ) :: N
COMPLEX (KIND=8), INTENT( IN    ) :: Rv1( N ), Rv2( N ), Rv4( N )
COMPLEX (KIND=8), INTENT( INOUT ) :: b( N )

! Forward elimination

DO I = 2, N
   b( I ) = b( I ) - Rv4( I ) * b( I - 1 )
   ! prevent underflows from propagating:
   !IF ( ABS(  REAL( b( I ) ) ) < SMALL .AND. ABS( AIMAG( b( I ) ) ) < SMALL ) b( I ) = 0.0
END DO

! Back-substitution (result in b)
b( N ) = b( N ) * Rv1( N )

IF ( N >= 2 ) THEN
   DO I = N - 1, 1, -1
      b( I ) = ( b( I ) - b( I + 1 ) * Rv2( I ) ) * Rv1( I )
   END DO
END IF

END SUBROUTINE BackSub_dble

END MODULE BackSub_Mod