*DECK DBINTK
      SUBROUTINE DBINTK (X, Y, T, N, K, BCOEF, Q, WORK)
C***BEGIN PROLOGUE  DBINTK
C***PURPOSE  Compute the B-representation of a spline which interpolates
C            given data.
C***LIBRARY   SLATEC
C***CATEGORY  E1A
C***TYPE      DOUBLE PRECISION (BINTK-S, DBINTK-D)
C***KEYWORDS  B-SPLINE, DATA FITTING, INTERPOLATION
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Written by Carl de Boor and modified by D. E. Amos
C
C     Abstract    **** a double precision routine ****
C
C         DBINTK is the SPLINT routine of the reference.
C
C         DBINTK produces the B-spline coefficients, BCOEF, of the
C         B-spline of order K with knots T(I), I=1,...,N+K, which
C         takes on the value Y(I) at X(I), I=1,...,N.  The spline or
C         any of its derivatives can be evaluated by calls to DBVALU.
C
C         The I-th equation of the linear system A*BCOEF = B for the
C         coefficients of the interpolant enforces interpolation at
C         X(I), I=1,...,N.  Hence, B(I) = Y(I), for all I, and A is
C         a band matrix with 2K-1 bands if A is invertible.  The matrix
C         A is generated row by row and stored, diagonal by diagonal,
C         in the rows of Q, with the main diagonal going into row K.
C         The banded system is then solved by a call to DBNFAC (which
C         constructs the triangular factorization for A and stores it
C         again in Q), followed by a call to DBNSLV (which then
C         obtains the solution BCOEF by substitution).  DBNFAC does no
C         pivoting, since the total positivity of the matrix A makes
C         this unnecessary.  The linear system to be solved is
C         (theoretically) invertible if and only if
C                 T(I) .LT. X(I) .LT. T(I+K),        for all I.
C         Equality is permitted on the left for I=1 and on the right
C         for I=N when K knots are used at X(1) or X(N).  Otherwise,
C         violation of this condition is certain to lead to an error.
C
C     Description of Arguments
C
C         Input       X,Y,T are double precision
C           X       - vector of length N containing data point abscissa
C                     in strictly increasing order.
C           Y       - corresponding vector of length N containing data
C                     point ordinates.
C           T       - knot vector of length N+K
C                     Since T(1),..,T(K) .LE. X(1) and T(N+1),..,T(N+K)
C                     .GE. X(N), this leaves only N-K knots (not nec-
C                     essarily X(I) values) interior to (X(1),X(N))
C           N       - number of data points, N .GE. K
C           K       - order of the spline, K .GE. 1
C
C         Output      BCOEF,Q,WORK are double precision
C           BCOEF   - a vector of length N containing the B-spline
C                     coefficients
C           Q       - a work vector of length (2*K-1)*N, containing
C                     the triangular factorization of the coefficient
C                     matrix of the linear system being solved.  The
C                     coefficients for the interpolant of an
C                     additional data set (X(I),YY(I)), I=1,...,N
C                     with the same abscissa can be obtained by loading
C                     YY into BCOEF and then executing
C                         CALL DBNSLV (Q,2K-1,N,K-1,K-1,BCOEF)
C           WORK    - work vector of length 2*K
C
C     Error Conditions
C         Improper input is a fatal error
C         Singular system of equations is a fatal error
C
C***REFERENCES  D. E. Amos, Computation with splines and B-splines,
C                 Report SAND78-1968, Sandia Laboratories, March 1979.
C               Carl de Boor, Package for calculating with B-splines,
C                 SIAM Journal on Numerical Analysis 14, 3 (June 1977),
C                 pp. 441-472.
C               Carl de Boor, A Practical Guide to Splines, Applied
C                 Mathematics Series 27, Springer-Verlag, New York,
C                 1978.
C***ROUTINES CALLED  DBNFAC, DBNSLV, DBSPVN, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800901  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  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   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DBINTK
C
      INTEGER IFLAG, IWORK, K, N, I, ILP1MX, J, JJ, KM1, KPKM2, LEFT,
     1 LENQ, NP1
      DOUBLE PRECISION BCOEF(*), Y(*), Q(*), T(*), X(*), XI, WORK(*)
C     DIMENSION Q(2*K-1,N), T(N+K)
C***FIRST EXECUTABLE STATEMENT  DBINTK
      IF(K.LT.1) GO TO 100
      IF(N.LT.K) GO TO 105
      JJ = N - 1
      IF(JJ.EQ.0) GO TO 6
      DO 5 I=1,JJ
      IF(X(I).GE.X(I+1)) GO TO 110
    5 CONTINUE
    6 CONTINUE
      NP1 = N + 1
      KM1 = K - 1
      KPKM2 = 2*KM1
      LEFT = K
C                ZERO OUT ALL ENTRIES OF Q
      LENQ = N*(K+KM1)
      DO 10 I=1,LENQ
        Q(I) = 0.0D0
   10 CONTINUE
C
C  ***   LOOP OVER I TO CONSTRUCT THE  N  INTERPOLATION EQUATIONS
      DO 50 I=1,N
        XI = X(I)
        ILP1MX = MIN(I+K,NP1)
C        *** FIND  LEFT  IN THE CLOSED INTERVAL (I,I+K-1) SUCH THAT
C                T(LEFT) .LE. X(I) .LT. T(LEFT+1)
C        MATRIX IS SINGULAR IF THIS IS NOT POSSIBLE
        LEFT = MAX(LEFT,I)
        IF (XI.LT.T(LEFT)) GO TO 80
   20   IF (XI.LT.T(LEFT+1)) GO TO 30
        LEFT = LEFT + 1
        IF (LEFT.LT.ILP1MX) GO TO 20
        LEFT = LEFT - 1
        IF (XI.GT.T(LEFT+1)) GO TO 80
C        *** THE I-TH EQUATION ENFORCES INTERPOLATION AT XI, HENCE
C        A(I,J) = B(J,K,T)(XI), ALL J. ONLY THE  K  ENTRIES WITH  J =
C        LEFT-K+1,...,LEFT ACTUALLY MIGHT BE NONZERO. THESE  K  NUMBERS
C        ARE RETURNED, IN  BCOEF (USED FOR TEMP. STORAGE HERE), BY THE
C        FOLLOWING
   30   CALL DBSPVN(T, K, K, 1, XI, LEFT, BCOEF, WORK, IWORK)
C        WE THEREFORE WANT  BCOEF(J) = B(LEFT-K+J)(XI) TO GO INTO
C        A(I,LEFT-K+J), I.E., INTO  Q(I-(LEFT+J)+2*K,(LEFT+J)-K) SINCE
C        A(I+J,J)  IS TO GO INTO  Q(I+K,J), ALL I,J,  IF WE CONSIDER  Q
C        AS A TWO-DIM. ARRAY , WITH  2*K-1  ROWS (SEE COMMENTS IN
C        DBNFAC). IN THE PRESENT PROGRAM, WE TREAT  Q  AS AN EQUIVALENT
C        ONE-DIMENSIONAL ARRAY (BECAUSE OF FORTRAN RESTRICTIONS ON
C        DIMENSION STATEMENTS) . WE THEREFORE WANT  BCOEF(J) TO GO INTO
C        ENTRY
C            I -(LEFT+J) + 2*K + ((LEFT+J) - K-1)*(2*K-1)
C                   =  I-LEFT+1 + (LEFT -K)*(2*K-1) + (2*K-2)*J
C        OF  Q .
        JJ = I - LEFT + 1 + (LEFT-K)*(K+KM1)
        DO 40 J=1,K
          JJ = JJ + KPKM2
          Q(JJ) = BCOEF(J)
   40   CONTINUE
   50 CONTINUE
C
C     ***OBTAIN FACTORIZATION OF  A  , STORED AGAIN IN  Q.
      CALL DBNFAC(Q, K+KM1, N, KM1, KM1, IFLAG)
      GO TO (60, 90), IFLAG
C     *** SOLVE  A*BCOEF = Y  BY BACKSUBSTITUTION
   60 DO 70 I=1,N
        BCOEF(I) = Y(I)
   70 CONTINUE
      CALL DBNSLV(Q, K+KM1, N, KM1, KM1, BCOEF)
      RETURN
C
C
   80 CONTINUE
      CALL XERMSG ('SLATEC', 'DBINTK',
     +   'SOME ABSCISSA WAS NOT IN THE SUPPORT OF THE CORRESPONDING ' //
     +   'BASIS FUNCTION AND THE SYSTEM IS SINGULAR.', 2, 1)
      RETURN
   90 CONTINUE
      CALL XERMSG ('SLATEC', 'DBINTK',
     +   'THE SYSTEM OF SOLVER DETECTS A SINGULAR SYSTEM ALTHOUGH ' //
     +   'THE THEORETICAL CONDITIONS FOR A SOLUTION WERE SATISFIED.',
     +   8, 1)
      RETURN
  100 CONTINUE
      CALL XERMSG ('SLATEC', 'DBINTK', 'K DOES NOT SATISFY K.GE.1', 2,
     +   1)
      RETURN
  105 CONTINUE
      CALL XERMSG ('SLATEC', 'DBINTK', 'N DOES NOT SATISFY N.GE.K', 2,
     +   1)
      RETURN
  110 CONTINUE
      CALL XERMSG ('SLATEC', 'DBINTK',
     +   'X(I) DOES NOT SATISFY X(I).LT.X(I+1) FOR SOME I', 2, 1)
      RETURN
      END


!
!   a Fortran routine to compute two point clustering
!   (c) Mehdi Rezaie
! module load python/3.6-anaconda
! f2py -m counter -c counter.f90
!
! Oct 22: change the algorithn due to a bug introduced by int
!         one must use floor
subroutine paircount(theta1, phi1, theta2, phi2, delta1, delta2, fpix1, fpix2, bins, auto, C, n1,n2, m)
integer,intent(in) :: n1, n2, m, auto
real(8),dimension(n1),intent(in)   :: theta1, phi1, delta1, fpix1
real(8),dimension(n2),intent(in)   :: theta2, phi2, delta2, fpix2
real(8),dimension(m+1),intent(in)  :: bins
real(8),dimension(2,m),intent(out) :: C

real(8) :: s, be
integer :: i,j,binid
real(8), dimension(n1) :: cost1,sint1,cosp1,sinp1
real(8), dimension(n2) :: cost2,sint2,cosp2,sinp2

!
cost1 = dcos(theta1)
sint1 = dsin(theta1)
cosp1 = dcos(phi1)
sinp1 = dsin(phi1)
!
cost2 = dcos(theta2)
sint2 = dsin(theta2)
cosp2 = dcos(phi2)
sinp2 = dsin(phi2)

C    = 0.0
s    = 0.0

if (auto .eq. 0) then
    do i = 1, n1
        do j = 1, n2
           s = sint1(i)*sint2(j)*(cosp1(i)*cosp2(j) + sinp1(i)*sinp2(j))+cost1(i)*cost2(j)
           be = bins(1) ! starts from the max sep angle
           binid = 0
           do while (s > be)
                binid = binid + 1
                be    = bins(binid+1)
           end do
           if ((binid .ge. 1) .and. (binid .le. m)) then
               C(1,binid) = C(1,binid) + delta1(i)*delta2(j)*fpix1(i)*fpix2(j)
               C(2,binid) = C(2,binid) + fpix1(i)*fpix2(j)
           end if
           s = 0
        end do
    end do
else if ((auto .eq. 1) .and. (n1 .eq. n2)) then
    do i = 1, n1
        do j = i+1, n1
           !print*, i, j
           s = sint1(i)*sint2(j)*(cosp1(i)*cosp2(j) + sinp1(i)*sinp2(j))+cost1(i)*cost2(j)
           be = bins(1) ! starts from the max sep angle
           binid = 0
           do while (s > be)
                binid = binid + 1
                be    = bins(binid+1)
           end do
           if ((binid .ge. 1) .and. (binid .le. m)) then
               C(1,binid) = C(1,binid) + delta1(i)*delta2(j)*fpix1(i)*fpix2(j)
               C(2,binid) = C(2,binid) + fpix1(i)*fpix2(j)
           end if
           s = 0
        end do
    end do
end if
return
end subroutine paircount


      subroutine dmsum(flag,a,na,m,n,v,nv)
c!purpose
c     computes the sum of the entries of a matrix according to flag
c!calling sequence
c     subroutine dmsum(flag,a,na,m,n,v,nv)
c     double precision a(na,n),v(*)
c     integer na,n,m,nv
c     integer flag
c!parameters
c     flag : indicates operation to perform
c            0 : returns in v(1) the sum of all entries of a
c            1 : returns in v(j) the sum of jth column of a
c            2 : returns in v(i) the sum of ith row of a
c     a    : array containing the a matrix
c     na   : a matrix leading dimension
c     m    : a matrix row dimension
c     n    : a matrix column dimension
c     v    : array containing the result, may be confused with a row or
c            a column of the a matrix
c            if flag==0 size(v)>=1
c            if flag==1 size(v)>=n*nv
c            if flag==1 size(v)>=m*nv
c     nv   : increment between to consecutive entries ov v
c!
c     Copyright INRIA
      double precision a(na,n),v(nv)
      integer na,n,m,nv
      integer flag
c
      double precision t,dsum
      integer iv
c
      iv=1
      if(flag.eq.0) then
         v(1) = dsum(m*n,a(1,1),1)
c     sum of all the entries
c         t=0.0d0
c         do 10 j=1,n
c            t=t+dsum(m,a(1,j),1)
c 10      continue
c         v(1)=t
      elseif(flag.eq.1) then
         do 20 j=1,n
            t=dsum(m,a(1,j),1)
            v(iv)=t
            iv=iv+nv
 20      continue
      elseif(flag.eq.2) then
         do 30 i=1,m
            t=dsum(n,a(i,1),m)
            v(iv)=t
            iv=iv+nv
 30      continue
      endif
      return
      end


! Name = ARPIT KUMAR JAIN  ROLL No = 180122009
! Code for HA8 Time Dependent Schrodinger Equation (TDSE) --> Using Discrete Fourire Transformation

MODULE precision
    IMPLICIT NONE

    ! dp = double precisiona
    INTEGER, PARAMETER:: dp = SELECTED_REAL_KIND(12)
END MODULE precision

MODULE constants
    USE precision
    IMPLICIT NONE

    REAL(KIND = dp), PARAMETER:: pi = acos(-1.0)
    ! k0 = p0/hbar,  hbar = 1 for a.u.
    ! So k0 = p0
    REAL(KIND = dp), PARAMETER:: alpha = 20.0, x0 = -0.5, p0 = 50.0, m = 14500.0
    REAL(KIND = dp), PARAMETER:: Xmin = -2.0, dx = 0.02, dt = 0.1
    INTEGER, PARAMETER:: numX = 256
    COMPLEX, PARAMETER:: iota = (0.0, 1.0)
    CHARACTER*64:: filename
END MODULE constants

PROGRAM TDSE_Discrete_Fourier_Transformation
    USE precision
    USE constants
    IMPLICIT NONE

    INTEGER:: i, j
    REAL(KIND = dp), DIMENSION(numX):: x, pot_V, Km, KSquare
    COMPLEX(KIND = dp), DIMENSION(numX):: psit0, psit1, psit2, Tpsi

    OPEN(UNIT = 6789, FILE = 'potential.txt')

    ! First Set Up X-Grid
    DO i = 1, numX
        x(i) = Xmin + (i-1) * dx
    ENDDO

    ! Now Set Up Potential Grid
    DO i = 1, numX
        IF(x(i) .GE. 0.0_dp) THEN
            pot_V(i) = 0.1
        ELSE
            pot_V(i) = 0.0
        ENDIF
        WRITE(6789, 859) x(i), pot_V(i)
        859 FORMAT(f0.3, 3x, f0.6)
    ENDDO
    CLOSE(6789)

    ! Calculate Initial wavepacket ψ(x, t0) using given equation
    CALL InitialWavePacket(x, psit0)

    ! Calculation of K-Grid
    CALL CalculateKgrid(Km, KSquare)

    ! Calculate Wavepacket at time t = 1 ψ(x, t1) using Euler Method
    CALL EulerWavePacket(x, pot_V, psit0, psit1, Km, KSquare)

    ! Propagation of ψ from t = 2 to 5000 time step
    DO j = 2, 5000
        Tpsi = psit1
        CALL DiscreteFourierTransformation(x, Tpsi, Km, KSquare)
        CALL PropagateWavePacket(x, pot_V, psit0, psit1, psit2, Tpsi, j)

        ! Update Values for next propagation
        psit0 = psit1
        psit1 = psit2
    ENDDO

END PROGRAM TDSE_Discrete_Fourier_Transformation

! Subroutine for initial wavepacket at t = 0
SUBROUTINE InitialWavePacket(x, psit0)
    USE precision
    USE constants
    IMPLICIT NONE

    REAL(KIND = dp):: x(numX), psisq
    COMPLEX(KIND = dp):: psit0(numX)
    INTEGER:: i

    OPEN(UNIT = 0, FILE = 'psi0.txt')
    DO i = 1, numX
        psit0(i) = ( (2.0_dp * alpha/pi)**0.25_dp ) * EXP(iota * p0 * (x(i)-x0)) * EXP(-alpha * (x(i)-x0)**2)
        psisq = REAL(psit0(i) * CONJG(psit0(i)))
        WRITE(0, *) x(i), psisq
    ENDDO
    CLOSE(0)

END SUBROUTINE InitialWavePacket

! Subroutine for calculation of K and K^2
SUBROUTINE CalculateKgrid(Km, KSquare)
    USE precision
    USE constants
    IMPLICIT NONE

    REAL(KIND = dp):: Km(numX), KSquare(numX)
    INTEGER:: i

    DO i = 1, numX/2
        Km(i) = 2.0_dp * pi * dfloat(i-1) / (dfloat(numX) * dx)
    ENDDO

    DO i = numX/2+1, numX
        Km(i) = 2.0_dp * pi * dfloat(i-1-numX) / (dfloat(numX) * dx)
    ENDDO

    KSquare = Km * Km

END SUBROUTINE CalculateKgrid

! Subroutine for WavePacket at t = 1 step using Euler Method
SUBROUTINE EulerWavePacket(x, pot_V, psit0, psit1, Km, KSquare)
    USE precision
    USE constants
    IMPLICIT NONE

    REAL(KIND = dp):: x(numX), pot_V(numX), Km(numX), KSquare(numX)
    COMPLEX(KIND = dp):: psit0(numX), psit1(numX), Tpsi(numX)
    INTEGER:: i

    Tpsi = psit0
    CALL DiscreteFourierTransformation(x, Tpsi, Km, KSquare)

    DO i = 1, numX
        psit1(i) = psit0(i) + iota * dt * ( Tpsi(i)/(2.0_dp * m) - pot_V(i) * psit0(i) )
    ENDDO

END SUBROUTINE EulerWavePacket

SUBROUTINE PropagateWavePacket(x, pot_V, psit0, psit1, psit2, Tpsi, iterationNumber)
    USE precision
    USE constants
    IMPLICIT NONE

    REAL(KIND = dp):: x(numX), pot_V(numX), psisq
    COMPLEX(KIND = dp):: psit0(numX), psit1(numX), psit2(numX), Tpsi(numX)
    INTEGER:: i, iterationNumber

    DO i = 1, numX
        psit2(i) = psit0(i) - 2.0_dp * iota * dt * ( -Tpsi(i)/(2.0_dp*m) + pot_V(i) * psit1(i) )
        psisq = REAL(psit2(i) * CONJG(psit2(i)))

        ! We have to plot for every 100th time stap so take mode with 100
        IF(MOD(iterationNumber, 100) .EQ. 0) THEN
            WRITE(filename, 8976) iterationNumber
            8976 FORMAT('psi',i0,'.txt')
            IF(i .EQ. 1) WRITE(*, 15) filename
            15 FORMAT("Generating ", A11, "...")
            OPEN(unit = 16, FILE = filename)
            WRITE(16, *) x(i), psisq
        ENDIF
    ENDDO

END SUBROUTINE PropagateWavePacket

SUBROUTINE DiscreteFourierTransformation(x, psi, Km, KSquare)
    USE precision
    USE constants
    IMPLICIT NONE

    REAL(KIND = dp):: x(numX), Km(numX), KSquare(numX)
    COMPLEX(KIND = dp):: psi(numX), phi(numX)
    INTEGER:: i, j

    phi = 0.0
    DO j = 1, numX
        phi = phi + psi(j) * EXP(-iota * Km * x(j))
    ENDDO

    phi = phi / sqrt(dfloat(numX))
    phi = -KSquare * phi

    psi = 0.0
    DO i = 1, numX
        psi = psi + phi(i) * EXP(iota * Km(i) * x)
    ENDDO
    psi = psi / sqrt(dfloat(numX))

END SUBROUTINE DiscreteFourierTransformation


      SUBROUTINE DEMEAN(IN,IOUT,N,MEAN)
!     DEMEAN IS AN AP ROUTINE TO REMOVE THE MEAN VALUE OF A TRACE.  MEAN REMOVAL
! IS THE SAME AS REMOVING THE DC SHIFT OR DC BIAS.
!
! ARGUMENTS:
!  IN     - THE AP ADDRESS OF THE INPUT ARRAY (THE BIASED ARRAY).
!  IOUT   - THE AP ADDRESS OF THE OUTPUT ARRAY TO RECEIVE THE UNBIASED DATA.
!           (IOUT MAY BE THE SAME AS IN).
!  N      - THE NUMBER OF ELEMENTS IN THE IN ARRAY.
!  MEAN   - THE AP ADDRESS WHERE THE MEAN VALUE CAN BE STORED.
!
!
!  WRITTEN AND COPYRIGHTED BY:
!  PAUL HENKART, SCRIPPS INSTITUTION OF OCEANOGRAPHY, 27 OCTOBER 1981
!  ALL RIGHTS ARE RESERVED BY THE AUTHOR.  PERMISSION TO COPY OR REPRODUCE THIS
!  SUBROUTINE, BY COMPUTER OR OTHER MEANS, MAY BE OBTAINED ONLY FROM THE AUTHOR.
!
      CALL MEANV(IN,1,MEAN,N)                                           ! FIND THE MEAN VALUE
      CALL VNEG(MEAN,1,MEAN,1,1)                                        ! NEGATE THE MEAN VALUE
      CALL VSADD(IN,1,MEAN,IOUT,1,N)                                    ! SUBTRACT THE MEAN (ADD THE NEGATIVE)
      CALL VNEG(MEAN,1,MEAN,1,1)                                        ! MAKE THE MEAN AS IT WAS
      RETURN
      END


program main

use test, only: test_value
use io, only: stdout

use elast

implicit none

double precision :: strain(3,3), stress(3,3), normal(3), traction(3), tn, ts, td, max_shear
double precision :: poisson, lame, shearmod
integer :: ierr

! subroutine strain2stress(strain,lame_param,shear_modulus,stress)
strain(1,1) =  3.6339344890890711d-002
strain(2,2) =  5.5369613435628490d-002
strain(3,3) =  9.7093061723786969d-002
strain(1,2) =  4.3088477821184440d-002
strain(1,3) =  8.8046778867983427d-002
strain(2,3) =  2.2125123077825250d-003
strain(2,1) = strain(1,2)
strain(3,1) = strain(1,3)
strain(3,2) = strain(2,3)
call strain2stress(strain,42.0d9,37.0d9,stress)
call test_value(stress(1,1),10618796364.038771d0,'strain2stress: stress(1,1)')
call test_value(stress(2,1),3188547358.7676487d0,'strain2stress: stress(2,1)')
call test_value(stress(3,1),6515461636.2307739d0,'strain2stress: stress(3,1)')
call test_value(stress(1,2),3188547358.7676487d0,'strain2stress: stress(1,2)')
call test_value(stress(2,2),12027036236.349367d0,'strain2stress: stress(2,2)')
call test_value(stress(3,2),163725910.77590686d0,'strain2stress: stress(3,2)')
call test_value(stress(1,3),6515461636.2307739d0,'strain2stress: stress(1,3)')
call test_value(stress(2,3),163725910.77590686d0,'strain2stress: stress(2,3)')
call test_value(stress(3,3),15114571409.673096d0,'strain2stress: stress(3,3)')

! subroutine stress2traction(stress_tensor,normal_vector,traction_vector)
normal(1) =  0.517088d0
normal(2) = -0.775632d0
normal(3) =  0.361961d0
call stress2traction(stress,normal,traction)
call test_value(traction(1), 5376051707.6165333d0,'stress2traction: traction(1)')
call test_value(traction(2),-7620526371.6986370d0,'stress2traction: traction(2)')
call test_value(traction(3), 8712954690.2444344d0,'stress2traction: traction(3)')

! subroutine traction_components(trac_vec,nor_vec,trac_nor,trac_str,trac_dip)
call traction_components(traction,normal,tn,ts,td)
call test_value(tn,11844356671.507679d0,'traction_components: normal traction')
call test_value(ts,246037931.97703600d0,'traction_components: strike traction')
call test_value(td,4747682533.5481758d0,'traction_components: dip traction')

! subroutine max_shear_stress(stress,max_shear)
call max_shear_stress(stress,max_shear)
call test_value(max_shear,7611365305.0594463d0,'max_shear_stress')

! subroutine read_halfspace_file(halfspace_file,poisson,shearmod,lame,ierr)
open(unit=11,file='unit_test_elast_read_halfspace_file',status='unknown')
write(11,*) 'lame 40e9 shear 30e9'
close(11)
call read_halfspace_file('unit_test_elast_read_halfspace_file',poisson,shearmod,lame,ierr)
call test_value(poisson,0.28571428571428570d0,'read_halfspace_file: lame/shear->poisson')
call test_value(shearmod,30d9,'read_halfspace_file: lame/shear->shear modulus')
call test_value(lame,40d9,'read_halfspace_file: lame/shear->lame')

open(unit=11,file='unit_test_elast_read_halfspace_file',status='unknown')
write(11,*) 'shear 40e9 lame 30e9'
close(11)
call read_halfspace_file('unit_test_elast_read_halfspace_file',poisson,shearmod,lame,ierr)
call test_value(poisson,0.21428571428571427d0,'read_halfspace_file: shear/lame->poisson')
call test_value(shearmod,40d9,'read_halfspace_file: shear/lame->shear modulus')
call test_value(lame,30d9,'read_halfspace_file: shear/lame->lame')

open(unit=11,file='unit_test_elast_read_halfspace_file',status='unknown')
write(11,*) 'poisson 0.25 lame 20e9'
close(11)
call read_halfspace_file('unit_test_elast_read_halfspace_file',poisson,shearmod,lame,ierr)
call test_value(poisson,0.25d0,'read_halfspace_file: poisson/lame->poisson')
call test_value(shearmod,20d9,'read_halfspace_file: poisson/lame->shear modulus')
call test_value(lame,20d9,'read_halfspace_file: poisson/lame->lame')

open(unit=11,file='unit_test_elast_read_halfspace_file',status='unknown')
write(11,*) 'shearmod 60e9 poisson 0.25'
close(11)
call read_halfspace_file('unit_test_elast_read_halfspace_file',poisson,shearmod,lame,ierr)
call test_value(poisson,0.25d0,'read_halfspace_file: shearmod/poisson->poisson')
call test_value(shearmod,60d9,'read_halfspace_file: shearmod/poisson->shear modulus')
call test_value(lame,60d9,'read_halfspace_file: shearmod/poisson->lame')

open(unit=11,file='unit_test_elast_read_halfspace_file',status='unknown')
write(11,*) 'young 100e9 poisson 0.25'
close(11)
call read_halfspace_file('unit_test_elast_read_halfspace_file',poisson,shearmod,lame,ierr)
call test_value(poisson,0.25d0,'read_halfspace_file: young/poisson->poisson')
call test_value(shearmod,40d9,'read_halfspace_file: young/poisson->shear modulus')
call test_value(lame,40d9,'read_halfspace_file: young/poisson->lame')

open(unit=11,file='unit_test_elast_read_halfspace_file',status='unknown')
close(11,status='delete')

write(stdout,*) 'elast_module unit test passed'
end


!************************************************************************
!
      SUBROUTINE POLINT(XA, YA, N, X, Y, DY)
!************************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:07:11   1/ 3/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  11/02/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: N
      REAL(DOUBLE), INTENT(IN) :: X
      REAL(DOUBLE), INTENT(OUT) :: Y, DY
      REAL(DOUBLE), DIMENSION(N),  INTENT(IN) :: XA, YA
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      INTEGER, PARAMETER :: NMAX = 10
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: NS, I, M
      REAL(DOUBLE), DIMENSION(NMAX) :: C, D
      REAL(DOUBLE) :: DIF, DIFT, HO, HP, W, DEN
!-----------------------------------------------
      NS = 1
      DIF = ABS(X - XA(1))
      DO I = 1, N
         DIFT = ABS(X - XA(I))
         IF (DIFT < DIF) THEN
            NS = I
            DIF = DIFT
         ENDIF
         C(I) = YA(I)
         D(I) = YA(I)
      END DO
      Y = YA(NS)
      NS = NS - 1
      DO M = 1, N - 1
         DO I = 1, N - M
            HO = XA(I) - X
            HP = XA(I+M) - X
            W = C(I+1) - D(I)
            DEN = HO - HP
            IF (DEN == 0.0D00) THEN
               WRITE (*, '(2A)') 'PAUSE ', 'FAILURE IN POLINT'
               READ *
            ENDIF
            DEN = W/DEN
            D(I) = HP*DEN
            C(I) = HO*DEN
         END DO
         IF (2*NS < N - M) THEN
            DY = C(NS+1)
         ELSE
            DY = D(NS)
            NS = NS - 1
         ENDIF
         Y = Y + DY
      END DO
      RETURN
      END SUBROUTINE POLINT