      subroutine xcrit(a,b,c,tauc,xb,xe,qostar,xc1,xc2,mshear)
c
c     + + + PURPOSE + + +
c     Determines whether shear stress exceeds critical shear stress
c     for a certain segment.  Returns a flag.
c
c     Called from subroutine ROUTE.
c     Author(s): G. Foster, M. Nearing, D. Flanagan
c     Reference in User Guide:
c
c     Changes: 1) All the GOTO logic was changed to nested IF's.  This
c                 permitted a single RETURN at the end of the module.
c              2) In the statement under the label "added 8/23/90 by dcf",
c                 "...x2.gt.xb)mshear=1" was changed to "...x2.gt.xE)
c                 mshear=1".  (Dennis's suggestion.)
c              3) Re: the values of MSHEAR, since 2 & 3 were lumped
c                 together, and a computed GOTO can't handle a zero,
c                 the original "3" was eliminated, and 0-2 were "pro-
c                 moted" to 1-3. CRM - 1/24/91.
c
c     Version: This module recoded from WEPP version 90.92.
c     Date recoded: 01/09/91.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
      real a, b, c, tauc, xb, xe, qostar, xc1, xc2
      integer mshear
c
c     + + + ARGUMENT DEFINITIONS + + +
c     a     - shear stress equation coefficient
c     b     - shear stress equation coefficient
c     c     - shear stress equation coefficient
c     tauc  - n.d. critical shear for the Overland Flow Element
c     xb    - beginning distance for segment of OFE
c     xe    - ending distance for segment of OFE
c     qostar- n.d. water inflow to the current OFE
c     xc1   - 1st point where shear = critical shear (if one exists)
c     xc2   - 2nd point where shear = critical shear (if one exists)
c     mshear- flag indicating what shear conditions exist on segment
c
c     mshear |      Meaning
c     ----------------------------------------------------------------
c       1    |  shear less than critical throughout segment
c       2    |  shear greater than critical throughout segment
c       3    |  shear equal critical shear within a segment
c            |      upslope  shear < critical shear
c            |      downslope shear > critical shear
c       4    |  shear equal critical shear within a segment
c            |      shear decreasing within segment
c            |      upslope  shear > critical shear
c            |      downslope shear < critical shear
c       5    |  shear equal critical shear two places in a segment
c            |      shear increases then decreases
c     ----------------------------------------------------------------
c
c
c
c     + + + LOCAL VARIABLES + + +
      double precision tauchk, x1, x2
      real taub,taue,part
c
c     tauchk - partial solution to quadratic equation used here
c     taub   - n.d. shear stress calculated at the beg. of segment
c     taue   - n.d. shear stress calculated at the end of the segment
c     part   - partial solution to quadratic equation used here
c
c     + + + SUBROUTINES CALLED + + +
c     root
c
c     + + + FUNCTION DECLARATIONS + + +
      real shear
c
c     + + + END SPECIFICATIONS + + +
c
c
      tauchk = tauc ** 1.5 - c
      taub = shear(a,b,c,xb)
      taue = shear(a,b,c,xe)

c     if(tauchk.lt.0.0) tauchk=0.0
c
c     ********************
c     ***  The BIG If  ***
c     ********************
      if (a.eq.0.0) then
c
c       UNIFORM-SLOPE SEGMENT.
c       Determine location where critical shear stress is exceeded.
c
        if (b.ne.0.0) then
          xc1 = tauchk / b
        else
          xc1 = 1000.
        end if
c
c
cc      if (qostar.ge.0.0) then
        if (taue.gt.taub) then
          mshear = 3
          if (xc1.le.xb) mshear = 2
          if (xc1.ge.xe) mshear = 1
        else
          mshear = 4
          if (xc1.ge.xe) mshear = 2
          if (xc1.le.xb) mshear = 1
        end if
c
c     *************************
c     ***  The BIG Else-If  ***
c     *************************
c     else if (a.gt.0.0.and.qostar.ge.0.0) then
      else if (a.gt.0.0 .and. taue.gt.taub) then
c
c     CONVEX SEGMENT on an OFE on which shear increases downslope
c
cc      taub = shear(a,b,c,xb)
c
c       If shear stress at the beginning of the convex segment exceeds
c       critical, then the entire segment exceeds critical shear stress.
c
        if (taub.ge.tauc) then
          mshear = 2
c
        else
cc        taue = shear(a,b,c,xe)
c
c         Else, if shear stress at the end of the convex segment is less
c         than critical, then the entire segment is below critical shear
c         stress.
c
          if (taue.le.tauc) then
            mshear = 1
c
          else
            call root(a,b,tauchk,x1,x2)
c
            mshear = 3
c
c           Else, determine the point where shear stress exceeds critical
c           shear stress.
c
            if (x1.ge.xb.and.x1.le.xe) then
              xc1 = x1
            else
              if (x2.ge.xb.and.x2.le.xe) xc1 = x2
            end if
          end if
        end if
c
c     **********************
c     ***  The BIG Else  ***
c     **********************
      else
c
c       any other type of segment:
c       CONVEX with shear decreasing down segment
c       CONCAVE with shear increasing or decreasing down segment
c       UNIFORM with shear increasing or decreasing down segment
c
cc      taub = shear(a,b,c,xb)
cc      taue = shear(a,b,c,xe)
c
        if (taue.ge.tauc.and.taub.ge.tauc) then
c
c         If shear stress exceeds critical at both ends of the segment,
c         it exceeds critical all along the segment.
c
          mshear = 2
        else
c
c         Determine if shear exceeds critical shear somewhere
c         along the segment.
c
          part = b ** 2 + 4.0 * a * tauchk
c
c         If solution of quadratic equation has no real roots, then
c         critical shear stress is not exceeded along entire segment.
c
          if (part.le.0.0) then
            mshear = 1
          else
c
c           Else, determine WHERE shear stress equals critical shear
c           stress, by solving for roots of quadratic equation.
c
            call root(a,b,tauchk,x1,x2)
c
c           If shear stress INCREASES on segment, set MSHEAR flag = 3
c           and return location where shear = critical.
c
            if (taub.le.tauc.and.taue.ge.tauc) then
              mshear = 3
              if (x1.le.xb.or.x1.ge.xe) then
                xc1 = x2
              else
                xc1 = x1
              end if
            else
c
c             If shear stress DECREASES on segment, set MSHEAR flag = 4
c             and return location where shear = critical.
c
              if (taub.ge.tauc.and.taue.le.tauc) then
                mshear = 4
                if (x1.le.xb.or.x1.ge.xe) then
                  xc1 = x2
                else
                  xc1 = x1
                end if
              else
c
c               If shear at both top and bottom of segment is below
c               critical, return two locations where it equals critical.
c
                if (taub.le.tauc.and.taue.le.tauc) then
                  mshear = 5
c                 note:  root always computes x1 < x2
                  xc1 = x1
                  xc2 = x2
cWarnings from ftnchek
c                 89           xc1 = tauchk / b
c                 ^
cWarning near line 89 col 15: dble truncated to real
c                 139               xc1 = x1
c                 ^
cWarning near line 139 col 19: dble truncated to real
c                 141               if (x2.ge.xb.and.x2.le.xe) xc1 = x2
c                 ^
cWarning near line 141 col 46: dble truncated to real
c                 168           part = b ** 2 + 4.0 * a * tauchk
c                 ^
cWarning near line 168 col 16: dble truncated to real
c                 188                 xc1 = x2
c                 ^
cWarning near line 188 col 21: dble truncated to real
c                 190                 xc1 = x1
c                 ^
cWarning near line 190 col 21: dble truncated to real
c                 200                   xc1 = x2
c                 ^
cWarning near line 200 col 23: dble truncated to real
c                 202                   xc1 = x1
c                 ^
cWarning near line 202 col 23: dble truncated to real
c                 212                   xc1 = x1
c                 ^
cWarning near line 212 col 23: dble truncated to real
c                 213                   xc2 = x2
c                 ^
cWarning near line 213 col 23: dble truncated to real
c
c                 Check to make sure that for a Case 4, both points fall
c                 between xb and xe, and that they are not the SAME point.
c
                  if (x1.lt.xb.or.x1.gt.xe.or.x2.lt.xb.or.x2.gt.xe.or.x1
     1                .eq.x2) mshear = 1
                end if
              end if
            end if
          end if
        end if
c
c     ************************
c     ***  The BIG End-If  ***
c     ************************
      end if
      return
      end


! { dg-do compile }
! { dg-options "-std=f2003" }
!
! PR fortran/33197
!
! Fortran 2008 complex trigonometric functions: tan, cosh, sinh, tanh
!
real :: r
complex :: z
r = -45.5
r = sin(r)
r = cos(r)
r = tan(r)
r = cosh(r)
r = sinh(r)
r = tanh(r)
z = 4.0
z = cos(z)
z = sin(z)
z = tan(z) ! { dg-error "Fortran 2008: COMPLEX argument" }
z = cosh(z)! { dg-error "Fortran 2008: COMPLEX argument" }
z = sinh(z)! { dg-error "Fortran 2008: COMPLEX argument" }
z = tanh(z)! { dg-error "Fortran 2008: COMPLEX argument" }
end


 SUBROUTINE shape5(deriv ,shape ,s,t,q ,nnode)
 !********************************************************************
 !
 !***  calculates shape functions and their
 !***  derivatives for eight node elements
 !
 !********************************************************************
 IMPLICIT NONE
 INTEGER (kind=4),PARAMETER :: ndime=3
 INTEGER (kind=4) :: nnode
 REAL    (kind=8) deriv(nnode,ndime),shape(nnode)
 REAL    (kind=8) s,t,q,sm,tm,zm,sp,tp,zp, &
                  omg,omh,omr,opg,oph,opr, &
   tpgphpr,tmgphpr,tmgmhpr,tpgmhpr,tpgphmr,tmgphmr,tmgmhmr,tpgmhmr

 IF (nnode == 4) THEN

   shape(   1) = 1.-s-t-q
   deriv(1, 1) =-1.
   deriv(1, 2) =-1.
   deriv(1, 3) =-1.

   shape(   2) = s
   deriv(2, 1) = 1.
   deriv(2, 2) = 0.
   deriv(2, 3) = 0.

   shape(   3) = t
   deriv(3, 1) = 0.
   deriv(3, 2) = 1.
   deriv(3, 3) = 0.

   shape(   4) = q
   deriv(4, 1) = 0.
   deriv(4, 2) = 0.
   deriv(4, 3) = 1.

 ELSE IF (nnode == 8) THEN
   sm = 0.5d0*(1d0-s)
   tm = 0.5d0*(1d0-t)
   zm = 0.5d0*(1d0-q)
   sp = 0.5d0*(1d0+s)
   tp = 0.5d0*(1d0+t)
   zp = 0.5d0*(1d0+q)

   !       shape functions

   shape(1) = sm*tm*zm
   shape(2) = sp*tm*zm
   shape(3) = sp*tp*zm
   shape(4) = sm*tp*zm
   shape(5) = sm*tm*zp
   shape(6) = sp*tm*zp
   shape(7) = sp*tp*zp
   shape(8) = sm*tp*zp

   !       derivatives

   deriv(1,1) = -0.5d0*tm*zm
   deriv(2,1) = +0.5d0*tm*zm
   deriv(3,1) = +0.5d0*tp*zm
   deriv(4,1) = -0.5d0*tp*zm
   deriv(5,1) = -0.5d0*tm*zp
   deriv(6,1) = +0.5d0*tm*zp
   deriv(7,1) = +0.5d0*tp*zp
   deriv(8,1) = -0.5d0*tp*zp
   deriv(1,2) = -0.5d0*sm*zm
   deriv(2,2) = -0.5d0*sp*zm
   deriv(3,2) = +0.5d0*sp*zm
   deriv(4,2) = +0.5d0*sm*zm
   deriv(5,2) = -0.5d0*sm*zp
   deriv(6,2) = -0.5d0*sp*zp
   deriv(7,2) = +0.5d0*sp*zp
   deriv(8,2) = +0.5d0*sm*zp
   deriv(1,3) = -0.5d0*sm*tm
   deriv(2,3) = -0.5d0*sp*tm
   deriv(3,3) = -0.5d0*sp*tp
   deriv(4,3) = -0.5d0*sm*tp
   deriv(5,3) = +0.5d0*sm*tm
   deriv(6,3) = +0.5d0*sp*tm
   deriv(7,3) = +0.5d0*sp*tp
   deriv(8,3) = +0.5d0*sm*tp

 ELSE IF (nnode == 20) THEN

   !       auxiliar values

   omg=1.d0-s
   omh=1.d0-t
   omr=1.d0-q
   opg=1.d0+s
   oph=1.d0+t
   opr=1.d0+q
   tpgphpr=2.d0+s+t+q
   tmgphpr=2.d0-s+t+q
   tmgmhpr=2.d0-s-t+q
   tpgmhpr=2.d0+s-t+q
   tpgphmr=2.d0+s+t-q
   tmgphmr=2.d0-s+t-q
   tmgmhmr=2.d0-s-t-q
   tpgmhmr=2.d0+s-t-q

   !       shape functions

   shape( 1)=-omg*omh*omr*tpgphpr/8.d0
   shape( 2)=-opg*omh*omr*tmgphpr/8.d0
   shape( 3)=-opg*oph*omr*tmgmhpr/8.d0
   shape( 4)=-omg*oph*omr*tpgmhpr/8.d0
   shape( 5)=-omg*omh*opr*tpgphmr/8.d0
   shape( 6)=-opg*omh*opr*tmgphmr/8.d0
   shape( 7)=-opg*oph*opr*tmgmhmr/8.d0
   shape( 8)=-omg*oph*opr*tpgmhmr/8.d0
   shape( 9)=omg*opg*omh*omr/4.d0
   shape(10)=omh*oph*opg*omr/4.d0
   shape(11)=omg*opg*oph*omr/4.d0
   shape(12)=omh*oph*omg*omr/4.d0
   shape(13)=omr*opr*omg*omh/4.d0
   shape(14)=omr*opr*opg*omh/4.d0
   shape(15)=omr*opr*opg*oph/4.d0
   shape(16)=omr*opr*omg*oph/4.d0
   shape(17)=omg*opg*omh*opr/4.d0
   shape(18)=omh*oph*opg*opr/4.d0
   shape(19)=omg*opg*oph*opr/4.d0
   shape(20)=omh*oph*omg*opr/4.d0

   !       local derivatives of the shape functions: xi-derivative

   deriv( 1,1)=omh*omr*(tpgphpr-omg)/8.d0
   deriv( 2,1)=(opg-tmgphpr)*omh*omr/8.d0
   deriv( 3,1)=(opg-tmgmhpr)*oph*omr/8.d0
   deriv( 4,1)=oph*omr*(tpgmhpr-omg)/8.d0
   deriv( 5,1)=omh*opr*(tpgphmr-omg)/8.d0
   deriv( 6,1)=(opg-tmgphmr)*omh*opr/8.d0
   deriv( 7,1)=(opg-tmgmhmr)*oph*opr/8.d0
   deriv( 8,1)=oph*opr*(tpgmhmr-omg)/8.d0
   deriv( 9,1)=(omg-opg)*omh*omr/4.d0
   deriv(10,1)=omh*oph*omr/4.d0
   deriv(11,1)=(omg-opg)*oph*omr/4.d0
   deriv(12,1)=-omh*oph*omr/4.d0
   deriv(13,1)=-omr*opr*omh/4.d0
   deriv(14,1)=omr*opr*omh/4.d0
   deriv(15,1)=omr*opr*oph/4.d0
   deriv(16,1)=-omr*opr*oph/4.d0
   deriv(17,1)=(omg-opg)*omh*opr/4.d0
   deriv(18,1)=omh*oph*opr/4.d0
   deriv(19,1)=(omg-opg)*oph*opr/4.d0
   deriv(20,1)=-omh*oph*opr/4.d0

   !       local derivatives of the shape functions: eta-derivative

   deriv( 1,2)=omg*omr*(tpgphpr-omh)/8.d0
   deriv( 2,2)=opg*omr*(tmgphpr-omh)/8.d0
   deriv( 3,2)=opg*(oph-tmgmhpr)*omr/8.d0
   deriv( 4,2)=omg*(oph-tpgmhpr)*omr/8.d0
   deriv( 5,2)=omg*opr*(tpgphmr-omh)/8.d0
   deriv( 6,2)=opg*opr*(tmgphmr-omh)/8.d0
   deriv( 7,2)=opg*(oph-tmgmhmr)*opr/8.d0
   deriv( 8,2)=omg*(oph-tpgmhmr)*opr/8.d0
   deriv( 9,2)=-omg*opg*omr/4.d0
   deriv(10,2)=(omh-oph)*opg*omr/4.d0
   deriv(11,2)=omg*opg*omr/4.d0
   deriv(12,2)=(omh-oph)*omg*omr/4.d0
   deriv(13,2)=-omr*opr*omg/4.d0
   deriv(14,2)=-omr*opr*opg/4.d0
   deriv(15,2)=omr*opr*opg/4.d0
   deriv(16,2)=omr*opr*omg/4.d0
   deriv(17,2)=-omg*opg*opr/4.d0
   deriv(18,2)=(omh-oph)*opg*opr/4.d0
   deriv(19,2)=omg*opg*opr/4.d0
   deriv(20,2)=(omh-oph)*omg*opr/4.d0

   !       local derivatives of the shape functions: zeta-derivative

   deriv( 1,3)=omg*omh*(tpgphpr-omr)/8.d0
   deriv( 2,3)=opg*omh*(tmgphpr-omr)/8.d0
   deriv( 3,3)=opg*oph*(tmgmhpr-omr)/8.d0
   deriv( 4,3)=omg*oph*(tpgmhpr-omr)/8.d0
   deriv( 5,3)=omg*omh*(opr-tpgphmr)/8.d0
   deriv( 6,3)=opg*omh*(opr-tmgphmr)/8.d0
   deriv( 7,3)=opg*oph*(opr-tmgmhmr)/8.d0
   deriv( 8,3)=omg*oph*(opr-tpgmhmr)/8.d0
   deriv( 9,3)=-omg*opg*omh/4.d0
   deriv(10,3)=-omh*oph*opg/4.d0
   deriv(11,3)=-omg*opg*oph/4.d0
   deriv(12,3)=-omh*oph*omg/4.d0
   deriv(13,3)=(omr-opr)*omg*omh/4.d0
   deriv(14,3)=(omr-opr)*opg*omh/4.d0
   deriv(15,3)=(omr-opr)*opg*oph/4.d0
   deriv(16,3)=(omr-opr)*omg*oph/4.d0
   deriv(17,3)=omg*opg*omh/4.d0
   deriv(18,3)=omh*oph*opg/4.d0
   deriv(19,3)=omg*opg*oph/4.d0
   deriv(20,3)=omh*oph*omg/4.d0

 END IF

 END SUBROUTINE shape5


module Mod_plcd_TD_PolarizationTensor
   use typre
   implicit none

   type, abstract :: PolarizationTensor

contains
      procedure(ComputePTensor0), deferred :: ComputePTensor
      procedure(ApplyPTensor0), deferred :: ApplyPTensor
   end type

   type, extends(PolarizationTensor) :: PlainStressPolarizationTensor
      real(rp) :: PTensor(3,3,2)

contains
   procedure :: ComputePTensor => ComputePTensorPlainStress
   procedure :: ApplyPTensor   => ApplyPTensorPlainStress

   end type

   type, extends(PolarizationTensor) :: PolarizationTensor3D
      real(rp) :: PTensor(6,6,2)

contains
   procedure :: ComputePTensor => ComputePTensor3D
   procedure :: ApplyPTensor   => ApplyPTensor3D

   end type

   type, extends(PolarizationTensor) :: PolarizationTensor2DLargeStrains
      real(rp) :: PTensor(3,3,2)

contains
   procedure :: ComputePTensor => ComputePTensor2DLS
   procedure :: ApplyPTensor   => ApplyPTensor2DLS

   end type

   type, extends(PolarizationTensor) :: PolarizationTensor3DLargeStrains
      real(rp) :: PTensor(6,6,2)

contains
   procedure :: ComputePTensor => ComputePTensor3DLS
   procedure :: ApplyPTensor   => ApplyPTensor3DLS

   end type

   abstract interface
      subroutine ComputePTensor0(a,nu,extgamma)
         import
         implicit none
         class(PolarizationTensor) :: a
         real(rp) :: nu, extgamma

      end subroutine

      subroutine ApplyPTensor0(a,relativeChi,stress,PStress)
         import
         implicit none
         class(PolarizationTensor) :: a
         real(rp) :: stress(:), PStress(:)
         real(rp) :: relativeChi

      end subroutine

   end interface

contains
   subroutine ComputePTensorPlainStress(a,nu,extgamma)
      use Mod_plcd_Isotrop2DPlainStress
      use Mod_plcd_SIMPMaterial
      implicit none
      class(PlainStressPolarizationTensor) :: a
      real(rp) :: nu, extgamma

      type(Isotrop2dPlainStress) :: CTForPolarizationTensor

      real(rp) :: gamma(2)

      real(rp) :: tau1 = 1.0_rp, tau2 = 1.0_rp, tau3 = 1.0_rp
      real(rp) :: alpha, beta

      real(rp) :: muForPolarization(2), lambdaForPolarization(2), EForPolarization(2), nuForPolarization(2)
      real(rp) :: direction(3) = 1.0_rp

      real(rp), pointer :: C(:,:)
      real(rp) :: coeff
      integer(ip) :: i

      alpha = (1.0_rp+nu)/(1.0_rp-nu)
      beta = (3_rp-nu)/(1_rp+nu)
      gamma(1) = extgamma
      gamma(2) = 1/gamma(1)

      do i = 1,2
         coeff = -0.5_rp/(beta*gamma(i)+tau1)
         muForPolarization(i) = coeff*(1+beta)*(tau1-gamma(i))
         !we divide by two so that we can enter in CT
         muForPolarization(i) = muForPolarization(i)*0.5_rp
         lambdaForPolarization(i) = coeff*0.5_rp*(alpha-beta)*(gamma(i)*(gamma(i)-2*tau3)+tau1*tau2)/(alpha*gamma(i)+tau2)

         EForPolarization(i) = muForPolarization(i)*(3*lambdaForPolarization(i)+2*muForPolarization(i))/(lambdaForPolarization(i)+muForPolarization(i))
         nuForPolarization(i) = lambdaForPolarization(i)/(2*(lambdaForPolarization(i)+muForPolarization(i)))

         call CTForPolarizationTensor%Initialize(2_ip,0)
         CTForPolarizationTensor%E=EForPolarization(i)
         CTForPolarizationTensor%nu=nuForPolarization(i)

         call CTForPolarizationTensor%Build
         call CTForPolarizationTensor%GetPointerToC(C)

         a%PTensor(:,:,i) = C

         !we multiply by two the \sigma_12 terms so that when we multiply by sigma everything is fine
         !The tensor usually multiplies epsilon, which is not divided by two in the cross terms
         !So we need to multiply them by 2 so that we can obtain the correct result
         a%PTensor(:,3,i) = a%PTensor(:,3,i)*2.0_rp

    enddo

   end subroutine

   subroutine ApplyPTensorPlainStress(a,relativeChi,stress,PStress)
      class(PlainStressPolarizationTensor) :: a
      real(rp) :: relativeChi
      real(rp) :: stress(:)
      real(rp) :: PStress(:)

      real(rp) :: gamma

      real(rp) :: dp(3,3)
      real(rp) :: stress2(3,3) = 0.0_rp, Pstress2(3,3)

      PStress = relativeChi*matmul(a%PTensor(:,:,1),stress)-(1.0_rp-relativeChi)*matmul(a%PTensor(:,:,2),stress)

      !PStress = stress;

      !if (plusminus == 1) then
      !   PStress = matmul(a%PTensor(:,:,1),stress)
      !else
      !   PStress = matmul(a%PTensor(:,:,2),stress)
      !end if

       !call Compute_dP(relativeChi,0.001_rp,1.0_rp,0.21_rp,0.21_rp,0.001_rp,1.0_rp,2,3,dp)

       !call Compute_dP(0.001_rp,0.001_rp,1.0_rp,0.21_rp,0.21_rp,0.001_rp,1.0_rp,2,3,dp)

!       PStress = matmul(dp,stress)

   end subroutine

   subroutine ComputePTensor3D(a,nu,extgamma)
      use Mod_plcd_IsotropConstitutiveTensor
      use Mod_plcd_SIMPMaterial
      implicit none
      class(PolarizationTensor3D) :: a
      real(rp) :: nu, extgamma

      type(IsotropCT) :: CTForPolarizationTensor

      real(rp) :: gamma(2)

      real(rp) :: alpha1, alpha2, aux1,auxlambdaNoE,auxmuNoE

      real(rp) :: muForPolarization(2), lambdaForPolarization(2), EForPolarization(2), nuForPolarization(2)

      real(rp), pointer :: C(:,:)
      integer(ip) :: i

      gamma(1) = extgamma
      gamma(2) = 1/gamma(1)

      auxlambdaNoE = nu/((1+nu)*(1-2*nu))
      auxmuNoE     = 1/(2*(1+nu))
      alpha1 = (auxlambdaNoE+auxmuNoE)/auxmuNoE
      alpha2 = (auxlambdaNoE+3*auxmuNoE)/(auxlambdaNoE+auxmuNoE)

      do i = 1,2
         aux1 = 0.5_rp*(1.0_rp - gamma(i))/(1+gamma(i)*alpha2)

         muForPolarization(i) = aux1*(1+alpha2)*0.5_rp
         lambdaForPolarization(i) = aux1*0.5_rp*(alpha1-alpha2)*(1-gamma(i))/(1+gamma(i)*alpha1)

         EForPolarization(i) = muForPolarization(i)*(3*lambdaForPolarization(i)+2*muForPolarization(i))/(lambdaForPolarization(i)+muForPolarization(i))
         nuForPolarization(i) = lambdaForPolarization(i)/(2*(lambdaForPolarization(i)+muForPolarization(i)))

         call CTForPolarizationTensor%Initialize(2_ip,0)
         CTForPolarizationTensor%E=EForPolarization(i)
         CTForPolarizationTensor%nu=nuForPolarization(i)

         call CTForPolarizationTensor%Build
         call CTForPolarizationTensor%GetPointerToC(C)

         a%PTensor(:,:,i) = -C

         !we multiply by two the \sigma_12 terms so that when we multiply by sigma everything is fine
         !The tensor usually multiplies epsilon, which is not divided by two in the cross terms
         !So we need to multiply them by 2 so that we can obtain the correct result
         a%PTensor(:,4:6,i) = a%PTensor(:,4:6,i)*2.0_rp

    enddo

   end subroutine

   subroutine ApplyPTensor3D(a,relativeChi,stress,PStress)
      class(PolarizationTensor3D) :: a
      real(rp) :: relativeChi
      real(rp) :: stress(:)
      real(rp) :: PStress(:)

      real(rp) :: gamma

      real(rp) :: dp(3,3)
      real(rp) :: stress2(3,3) = 0.0_rp, Pstress2(3,3)

      PStress = relativeChi*matmul(a%PTensor(:,:,1),stress)-(1.0_rp-relativeChi)*matmul(a%PTensor(:,:,2),stress)
   end subroutine

   subroutine ComputePTensor2DLS(a,nu,extgamma)
      use Mod_plcd_SIMPMaterial
      implicit none
      class(PolarizationTensor2DLargeStrains) :: a
      real(rp) :: nu, extgamma
      integer(ip) :: i,ivoigt

   end subroutine

   subroutine ApplyPTensor2DLS(a,relativeChi,stress,PStress)
      class(PolarizationTensor2DLargeStrains) :: a
      real(rp) :: relativeChi
      real(rp) :: stress(:)
      real(rp) :: PStress(:)

      PStress = stress

   end subroutine

   subroutine ComputePTensor3DLS(a,nu,extgamma)
      use Mod_plcd_SIMPMaterial
      implicit none
      class(PolarizationTensor3DLargeStrains) :: a
      real(rp) :: nu, extgamma
      integer(ip) :: i,ivoigt

   end subroutine

   subroutine ApplyPTensor3DLS(a,relativeChi,stress,PStress)
      class(PolarizationTensor3DLargeStrains) :: a
      real(rp) :: relativeChi
      real(rp) :: stress(:)
      real(rp) :: PStress(:)

      PStress = stress

   end subroutine

end module

!    SUBROUTINE Compute_dP(gamm, Eminus, Eplus, numinus, nuplus, alphaminus, alphaplus, d, nstre, dP)
!       implicit none
! !       Gamma: from 0 to 1, element density
! !       Eminus y Eplus:  Young
! !       numinus, muplus: Poisson
! !       alphaminus
!
!       REAL(rp), INTENT(in) :: gamm
!       REAL(rp), INTENT(in) :: Eminus, Eplus, numinus, nuplus, alphaminus, alphaplus
!       INTEGER(ip), INTENT(in) :: d, nstre
!       REAL(rp) :: mu, dmu, kappa, lambda, dlambda, detinv
!       REAL(rp), DIMENSION(nstre,nstre) :: C, dC, IC, P
!       REAL(rp), INTENT(out) ,DIMENSION(nstre,nstre) :: dP
!       integer(ip) :: i
!
!
!
!       mu=(Eminus**2*alphaplus**2*1.5+ &
!          Eplus**2*alphaminus**2*1.5+&
!          Eminus**2*gamm**2*1.5+&
!          Eplus**2*gamm**2*1.5+&
!          Eminus**2*alphaplus**2*nuplus+&
!          Eplus**2*alphaminus**2*numinus+&
!          Eminus**2*gamm**2*nuplus+ &
!          Eplus**2*gamm**2*numinus- &
!          Eminus**2*alphaplus**2*nuplus**2*0.5- &
!          Eplus**2*alphaminus**2*numinus**2*0.5- &
!          Eminus**2*gamm**2*nuplus**2*0.5- &
!          Eplus**2*gamm**2*numinus**2*0.5+ &
!          Eminus*Eplus*alphaplus**2*4.5+ &
!          Eminus*Eplus*alphaminus**2*4.5- &
!          Eminus*Eplus*gamm**2*3.0- &
!          Eminus**2*alphaplus*gamm*3.0- &
!          Eplus**2*alphaminus*gamm*3.0- &
!          Eminus*Eplus*alphaplus**2*nuplus*1.5- &
!          Eminus*Eplus*alphaplus**2*numinus*1.5- &
!          Eminus*Eplus*alphaminus**2*nuplus*1.5- &
!          Eminus*Eplus*alphaminus**2*numinus*1.5- &
!          Eminus*Eplus*gamm**2*nuplus- &
!          Eminus*Eplus*gamm**2*numinus- &
!          Eminus**2*alphaplus*gamm*nuplus*2.0- &
!          Eplus**2*alphaminus*gamm*numinus*2.0+ &
!          Eminus**2*alphaplus*gamm*nuplus**2+ &
!          Eplus**2*alphaminus*gamm*numinus**2- &
!          Eminus*Eplus*alphaplus*alphaminus*12.0+ &
!          Eminus*Eplus*alphaplus*gamm*3.0+ &
!          Eminus*Eplus*alphaminus*gamm*3.0+ &
!          Eminus*Eplus*alphaplus*alphaminus*nuplus*2.0+ &
!          Eminus*Eplus*alphaplus*alphaminus*numinus*2.0+ &
!          Eminus*Eplus*alphaplus*gamm*nuplus+ &
!          Eminus*Eplus*alphaplus*gamm*numinus+ &
!          Eminus*Eplus*alphaminus*gamm*nuplus+ &
!          Eminus*Eplus*alphaminus*gamm*numinus+ &
!          Eminus*Eplus*alphaplus**2*nuplus*numinus*0.5+ &
!          Eminus*Eplus*alphaminus**2*nuplus*numinus*0.5+ &
!          Eminus*Eplus*gamm**2*nuplus*numinus- &
!          Eminus*Eplus*alphaplus*gamm*nuplus*numinus- &
!          Eminus*Eplus*alphaminus*gamm*nuplus*numinus)/ &
!          ( &
!          (alphaplus-alphaminus)* &
!          (Eminus*alphaplus*3.0- &
!          Eminus*alphaminus*9.0+ &
!          Eplus*alphaplus*9.0- &
!          Eplus*alphaminus*3.0+ &
!          Eminus*gamm*6.0- &
!          Eplus*gamm*6.0+ &
!          Eminus*alphaplus*nuplus*2.0+ &
!          Eminus*alphaplus*numinus*3.0- &
!          Eminus*alphaminus*nuplus*6.0+ &
!          Eminus*alphaminus*numinus*3.0- &
!          Eplus*alphaplus*nuplus*3.0+ &
!          Eplus*alphaplus*numinus*6.0- &
!          Eplus*alphaminus*nuplus*3.0- &
!          Eplus*alphaminus*numinus*2.0+ &
!          Eminus*gamm*nuplus*4.0-Eminus*gamm*numinus*6.0+ &
!          Eplus*gamm*nuplus*6.0- &
!          Eplus*gamm*numinus*4.0- &
!          Eminus*alphaplus*nuplus**2+ &
!          Eminus*alphaminus*nuplus**2*3.0- &
!          Eplus*alphaplus*numinus**2*3.0+ &
!          Eplus*alphaminus*numinus**2- &
!          Eminus*gamm*nuplus**2*2.0+ &
!          Eplus*gamm*numinus**2*2.0- &
!          Eminus*alphaplus*nuplus**2*numinus- &
!          Eminus*alphaminus*nuplus**2*numinus+ &
!          Eplus*alphaplus*nuplus*numinus**2+ &
!          Eplus*alphaminus*nuplus*numinus**2+ &
!          Eminus*gamm*nuplus**2*numinus*2.0- &
!          Eplus*gamm*nuplus*numinus**2*2.0+ &
!          Eminus*alphaplus*nuplus*numinus*2.0+ &
!          Eminus*alphaminus*nuplus*numinus*2.0- &
!          Eplus*alphaplus*nuplus*numinus*2.0- &
!          Eplus*alphaminus*nuplus*numinus*2.0- &
!          Eminus*gamm*nuplus*numinus*4.0+ &
!          Eplus*gamm*nuplus*numinus*4.0) &
!          )
!
!
!       dmu= (Eminus**2*alphaplus*-3.0- &
!          Eplus**2*alphaminus*3.0+ &
!          Eminus**2*gamm*3.0+ &
!          Eplus**2*gamm*3.0+ &
!          Eminus**2*alphaplus*nuplus**2+ &
!          Eplus**2*alphaminus*numinus**2- &
!          Eminus**2*gamm*nuplus**2- &
!          Eplus**2*gamm*numinus**2+ &
!          Eminus*Eplus*alphaplus*3.0 + &
!          Eminus*Eplus*alphaminus*3.0- &
!          Eminus*Eplus*gamm*6.0- &
!          Eminus**2*alphaplus*nuplus*2.0- &
!          Eplus**2*alphaminus*numinus*2.0+ &
!          Eminus**2*gamm*nuplus*2.0+ &
!          Eplus**2*gamm*numinus*2.0+ &
!          Eminus*Eplus*alphaplus*nuplus+ &
!          Eminus*Eplus*alphaplus*numinus+ &
!          Eminus*Eplus*alphaminus*nuplus+ &
!          Eminus*Eplus*alphaminus*numinus- &
!          Eminus*Eplus*gamm*nuplus*2.0- &
!          Eminus*Eplus*gamm*numinus*2.0- &
!          Eminus*Eplus*alphaplus*nuplus*numinus- &
!          Eminus*Eplus*alphaminus*nuplus*numinus+ &
!          Eminus*Eplus*gamm*nuplus*numinus*2.0)/ &
!          ( &
!          (alphaplus-alphaminus)* &
!          (Eminus*alphaplus*3.0- &
!          Eminus*alphaminus*9.0+ &
!          Eplus*alphaplus*9.0- &
!          Eplus*alphaminus*3.0+ &
!          Eminus*gamm*6.0-Eplus*gamm*6.0+ &
!          Eminus*alphaplus*nuplus*2.0+ &
!          Eminus*alphaplus*numinus*3.0- &
!          Eminus*alphaminus*nuplus*6.0+ &
!          Eminus*alphaminus*numinus*3.0- &
!          Eplus*alphaplus*nuplus*3.0+ &
!          Eplus*alphaplus*numinus*6.0- &
!          Eplus*alphaminus*nuplus*3.0- &
!          Eplus*alphaminus*numinus*2.0+ &
!          Eminus*gamm*nuplus*4.0- &
!          Eminus*gamm*numinus*6.0+ &
!          Eplus*gamm*nuplus*6.0- &
!          Eplus*gamm*numinus*4.0- &
!          Eminus*alphaplus*nuplus**2+ &
!          Eminus*alphaminus*nuplus**2*3.0- &
!          Eplus*alphaplus*numinus**2*3.0+ &
!          Eplus*alphaminus*numinus**2- &
!          Eminus*gamm*nuplus**2*2.0+ &
!          Eplus*gamm*numinus**2*2.0- &
!          Eminus*alphaplus*nuplus**2*numinus- &
!          Eminus*alphaminus*nuplus**2*numinus+ &
!          Eplus*alphaplus*nuplus*numinus**2+ &
!          Eplus*alphaminus*nuplus*numinus**2+ &
!          Eminus*gamm*nuplus**2*numinus*2.0- &
!          Eplus*gamm*nuplus*numinus**2*2.0+ &
!          Eminus*alphaplus*nuplus*numinus*2.0+ &
!          Eminus*alphaminus*nuplus*numinus*2.0- &
!          Eplus*alphaplus*nuplus*numinus*2.0- &
!          Eplus*alphaminus*nuplus*numinus*2.0- &
!          Eminus*gamm*nuplus*numinus*4.0+ &
!          Eplus*gamm*nuplus*numinus*4.0) &
!          )- &
!          ( &
!          (Eminus*6.0-Eplus*6.0+ &
!          Eminus*nuplus*4.0- &
!          Eminus*numinus*6.0+ &
!          Eplus*nuplus*6.0- &
!          Eplus*numinus*4.0- &
!          Eminus*nuplus**2*2.0+ &
!          Eplus*numinus**2*2.0- &
!          Eminus*nuplus*numinus*4.0+ &
!          Eplus*nuplus*numinus*4.0+ &
!          Eminus*nuplus**2*numinus*2.0- &
!          Eplus*nuplus*numinus**2*2.0)* &
!          1.0/ &
!          (Eminus*alphaplus*3.0- &
!          Eminus*alphaminus*9.0+ &
!          Eplus*alphaplus*9.0- &
!          Eplus*alphaminus*3.0+ &
!          Eminus*gamm*6.0- &
!          Eplus*gamm*6.0+ &
!          Eminus*alphaplus*nuplus*2.0+ &
!          Eminus*alphaplus*numinus*3.0- &
!          Eminus*alphaminus*nuplus*6.0+ &
!          Eminus*alphaminus*numinus*3.0- &
!          Eplus*alphaplus*nuplus*3.0+ &
!          Eplus*alphaplus*numinus*6.0- &
!          Eplus*alphaminus*nuplus*3.0- &
!          Eplus*alphaminus*numinus*2.0+ &
!          Eminus*gamm*nuplus*4.0- &
!          Eminus*gamm*numinus*6.0+ &
!          Eplus*gamm*nuplus*6.0- &
!          Eplus*gamm*numinus*4.0- &
!          Eminus*alphaplus*nuplus**2+ &
!          Eminus*alphaminus*nuplus**2*3.0- &
!          Eplus*alphaplus*numinus**2*3.0+ &
!          Eplus*alphaminus*numinus**2- &
!          Eminus*gamm*nuplus**2*2.0+ &
!          Eplus*gamm*numinus**2*2.0- &
!          Eminus*alphaplus*nuplus**2*numinus- &
!          Eminus*alphaminus*nuplus**2*numinus+ &
!          Eplus*alphaplus*nuplus*numinus**2+ &
!          Eplus*alphaminus*nuplus*numinus**2+ &
!          Eminus*gamm*nuplus**2*numinus*2.0- &
!          Eplus*gamm*nuplus*numinus**2*2.0+ &
!          Eminus*alphaplus*nuplus*numinus*2.0+ &
!          Eminus*alphaminus*nuplus*numinus*2.0- &
!          Eplus*alphaplus*nuplus*numinus*2.0- &
!          Eplus*alphaminus*nuplus*numinus*2.0- &
!          Eminus*gamm*nuplus*numinus*4.0+ &
!          Eplus*gamm*nuplus*numinus*4.0)**2* &
!          (Eminus**2*alphaplus**2*3.0+ &
!          Eplus**2*alphaminus**2*3.0+ &
!          Eminus**2*gamm**2*3.0+ &
!          Eplus**2*gamm**2*3.0+ &
!          Eminus**2*alphaplus**2*nuplus*2.0+ &
!          Eplus**2*alphaminus**2*numinus*2.0+ &
!          Eminus**2*gamm**2*nuplus*2.0+Eplus**2*gamm**2*numinus*2.0- &
!          Eminus**2*alphaplus**2*nuplus**2- &
!          Eplus**2*alphaminus**2*numinus**2- &
!          Eminus**2*gamm**2*nuplus**2- &
!          Eplus**2*gamm**2*numinus**2+ &
!          Eminus*Eplus*alphaplus**2*9.0+ &
!          Eminus*Eplus*alphaminus**2*9.0- &
!          Eminus*Eplus*gamm**2*6.0- &
!          Eminus**2*alphaplus*gamm*6.0- &
!          Eplus**2*alphaminus*gamm*6.0- &
!          Eminus*Eplus*alphaplus**2*nuplus*3.0- &
!          Eminus*Eplus*alphaplus**2*numinus*3.0- &
!          Eminus*Eplus*alphaminus**2*nuplus*3.0- &
!          Eminus*Eplus*alphaminus**2*numinus*3.0- &
!          Eminus*Eplus*gamm**2*nuplus*2.0- &
!          Eminus*Eplus*gamm**2*numinus*2.0- &
!          Eminus**2*alphaplus*gamm*nuplus*4.0- &
!          Eplus**2*alphaminus*gamm*numinus*4.0+ &
!          Eminus**2*alphaplus*gamm*nuplus**2*2.0+ &
!          Eplus**2*alphaminus*gamm*numinus**2*2.0- &
!          Eminus*Eplus*alphaplus*alphaminus*2.4e1+ &
!          Eminus*Eplus*alphaplus*gamm*6.0+ &
!          Eminus*Eplus*alphaminus*gamm*6.0+ &
!          Eminus*Eplus*alphaplus*alphaminus*nuplus*4.0+ &
!          Eminus*Eplus*alphaplus*alphaminus*numinus*4.0+ &
!          Eminus*Eplus*alphaplus*gamm*nuplus*2.0+ &
!          Eminus*Eplus*alphaplus*gamm*numinus*2.0+ &
!          Eminus*Eplus*alphaminus*gamm*nuplus*2.0+ &
!          Eminus*Eplus*alphaminus*gamm*numinus*2.0+ &
!          Eminus*Eplus*alphaplus**2*nuplus*numinus+ &
!          Eminus*Eplus*alphaminus**2*nuplus*numinus+ &
!          Eminus*Eplus*gamm**2*nuplus*numinus*2.0- &
!          Eminus*Eplus*alphaplus*gamm*nuplus*numinus*2.0- &
!          Eminus*Eplus*alphaminus*gamm*nuplus*numinus*2.0)*0.5)/(alphaplus-alphaminus)
!
!
!
!       kappa=( &
!       Eminus**2*alphaplus**2*0.5+ &
!       Eplus**2*alphaminus**2*0.5+ &
!       Eminus**2*gamm**2*0.5+ &
!       Eplus**2*gamm**2*0.5- &
!       Eminus**2*alphaplus**2*nuplus**2*0.5- &
!       Eplus**2*alphaminus**2*numinus**2*0.5- &
!       Eminus**2*gamm**2*nuplus**2*0.5- &
!       Eplus**2*gamm**2*numinus**2*0.5+ &
!       Eminus*Eplus*alphaplus**2*0.5+ &
!       Eminus*Eplus*alphaminus**2*0.5- &
!       Eminus*Eplus*gamm**2- &
!       Eminus**2*alphaplus*gamm- &
!       Eplus**2*alphaminus*gamm+ &
!       Eminus*Eplus*alphaplus**2*nuplus*0.5+ &
!       Eminus*Eplus*alphaplus**2*numinus*0.5+ &
!       Eminus*Eplus*alphaminus**2*nuplus*0.5+ &
!       Eminus*Eplus*alphaminus**2*numinus*0.5+ &
!       Eminus**2*alphaplus*gamm*nuplus**2+ &
!       Eplus**2*alphaminus*gamm*numinus**2- &
!       Eminus*Eplus*alphaplus*alphaminus*2.0+ &
!       Eminus*Eplus*alphaplus*gamm+Eminus*Eplus*alphaminus*gamm- &
!       Eminus*Eplus*alphaplus*alphaminus*nuplus- &
!       Eminus*Eplus*alphaplus*alphaminus*numinus+ &
!       Eminus*Eplus*alphaplus**2*nuplus*numinus*0.5+ &
!       Eminus*Eplus*alphaminus**2*nuplus*numinus*0.5+ &
!       Eminus*Eplus*gamm**2*nuplus*numinus- &
!       Eminus*Eplus*alphaplus*gamm*nuplus*numinus- &
!       Eminus*Eplus*alphaminus*gamm*nuplus*numinus)/ &
!       ( &
!       (alphaplus-alphaminus)* &
!       (Eminus*alphaplus-Eminus*alphaminus+ &
!       Eplus*alphaplus- &
!       Eplus*alphaminus- &
!       Eminus*alphaplus*numinus- &
!       Eminus*alphaminus*numinus+ &
!       Eplus*alphaplus*nuplus+ &
!       Eplus*alphaminus*nuplus+ &
!       Eminus*gamm*numinus*2.0- &
!       Eplus*gamm*nuplus*2.0- &
!       Eminus*alphaplus*nuplus**2+ &
!       Eminus*alphaminus*nuplus**2- &
!       Eplus*alphaplus*numinus**2+ &
!       Eplus*alphaminus*numinus**2+ &
!       Eminus*alphaplus*nuplus**2*numinus+ &
!       Eminus*alphaminus*nuplus**2*numinus- &
!       Eplus*alphaplus*nuplus*numinus**2- &
!       Eplus*alphaminus*nuplus*numinus**2- &
!       Eminus*gamm*nuplus**2*numinus*2.0+ &
!       Eplus*gamm*nuplus*numinus**2*2.0) &
!       )
!
!
!       lambda=( &
!       Eminus**2*alphaplus**2*0.5+ &
!       Eplus**2*alphaminus**2*0.5+ &
!       Eminus**2*gamm**2*0.5+ &
!       Eplus**2*gamm**2*0.5- &
!       Eminus**2*alphaplus**2*nuplus**2*0.5- &
!       Eplus**2*alphaminus**2*numinus**2*0.5- &
!       Eminus**2*gamm**2*nuplus**2*0.5- &
!       Eplus**2*gamm**2*numinus**2*0.5+ &
!       Eminus*Eplus*alphaplus**2*0.5+ &
!       Eminus*Eplus*alphaminus**2*0.5- &
!       Eminus*Eplus*gamm**2- &
!       Eminus**2*alphaplus*gamm- &
!       Eplus**2*alphaminus*gamm+ &
!       Eminus*Eplus*alphaplus**2*nuplus*0.5+ &
!       Eminus*Eplus*alphaplus**2*numinus*0.5+ &
!       Eminus*Eplus*alphaminus**2*nuplus*0.5+ &
!       Eminus*Eplus*alphaminus**2*numinus*0.5+ &
!       Eminus**2*alphaplus*gamm*nuplus**2+ &
!       Eplus**2*alphaminus*gamm*numinus**2- &
!       Eminus*Eplus*alphaplus*alphaminus*2.0+ &
!       Eminus*Eplus*alphaplus*gamm+ &
!       Eminus*Eplus*alphaminus*gamm- &
!       Eminus*Eplus*alphaplus*alphaminus*nuplus- &
!       Eminus*Eplus*alphaplus*alphaminus*numinus+ &
!       Eminus*Eplus*alphaplus**2*nuplus*numinus*0.5+ &
!       Eminus*Eplus*alphaminus**2*nuplus*numinus*0.5+ &
!       Eminus*Eplus*gamm**2*nuplus*numinus- &
!       Eminus*Eplus*alphaplus*gamm*nuplus*numinus-Eminus*Eplus*alphaminus*gamm*nuplus*numinus)/ &
!       ( &
!       (alphaplus-alphaminus)* &
!       (Eminus*alphaplus- &
!       Eminus*alphaminus+ &
!       Eplus*alphaplus- &
!       Eplus*alphaminus- &
!       Eminus*alphaplus*numinus- &
!       Eminus*alphaminus*numinus+ &
!       Eplus*alphaplus*nuplus+ &
!       Eplus*alphaminus*nuplus+ &
!       Eminus*gamm*numinus*2.0- &
!       Eplus*gamm*nuplus*2.0- &
!       Eminus*alphaplus*nuplus**2+ &
!       Eminus*alphaminus*nuplus**2- &
!       Eplus*alphaplus*numinus**2+ &
!       Eplus*alphaminus*numinus**2+ &
!       Eminus*alphaplus*nuplus**2*numinus+ &
!       Eminus*alphaminus*nuplus**2*numinus- &
!       Eplus*alphaplus*nuplus*numinus**2- &
!       Eplus*alphaminus*nuplus*numinus**2- &
!       Eminus*gamm*nuplus**2*numinus*2.0+ &
!       Eplus*gamm*nuplus*numinus**2*2.0) &
!       )- &
!       (Eminus**2*alphaplus**2*3.0+ &
!       Eplus**2*alphaminus**2*3.0+ &
!       Eminus**2*gamm**2*3.0+ &
!       Eplus**2*gamm**2*3.0+ &
!       Eminus**2*alphaplus**2*nuplus*2.0+ &
!       Eplus**2*alphaminus**2*numinus*2.0+ &
!       Eminus**2*gamm**2*nuplus*2.0+ &
!       Eplus**2*gamm**2*numinus*2.0- &
!       Eminus**2*alphaplus**2*nuplus**2- &
!       Eplus**2*alphaminus**2*numinus**2- &
!       Eminus**2*gamm**2*nuplus**2-Eplus**2*gamm**2*numinus**2+ &
!       Eminus*Eplus*alphaplus**2*9.0+ &
!       Eminus*Eplus*alphaminus**2*9.0- &
!       Eminus*Eplus*gamm**2*6.0-Eminus**2*alphaplus*gamm*6.0- &
!       Eplus**2*alphaminus*gamm*6.0- &
!       Eminus*Eplus*alphaplus**2*nuplus*3.0- &
!       Eminus*Eplus*alphaplus**2*numinus*3.0- &
!       Eminus*Eplus*alphaminus**2*nuplus*3.0- &
!       Eminus*Eplus*alphaminus**2*numinus*3.0- &
!       Eminus*Eplus*gamm**2*nuplus*2.0- &
!       Eminus*Eplus*gamm**2*numinus*2.0- &
!       Eminus**2*alphaplus*gamm*nuplus*4.0- &
!       Eplus**2*alphaminus*gamm*numinus*4.0+ &
!       Eminus**2*alphaplus*gamm*nuplus**2*2.0+ &
!       Eplus**2*alphaminus*gamm*numinus**2*2.0- &
!       Eminus*Eplus*alphaplus*alphaminus*2.4e1+ &
!       Eminus*Eplus*alphaplus*gamm*6.0+ &
!       Eminus*Eplus*alphaminus*gamm*6.0+ &
!       Eminus*Eplus*alphaplus*alphaminus*nuplus*4.0+ &
!       Eminus*Eplus*alphaplus*alphaminus*numinus*4.0+ &
!       Eminus*Eplus*alphaplus*gamm*nuplus*2.0+ &
!       Eminus*Eplus*alphaplus*gamm*numinus*2.0+ &
!       Eminus*Eplus*alphaminus*gamm*nuplus*2.0+ &
!       Eminus*Eplus*alphaminus*gamm*numinus*2.0+ &
!       Eminus*Eplus*alphaplus**2*nuplus*numinus+ &
!       Eminus*Eplus*alphaminus**2*nuplus*numinus+ &
!       Eminus*Eplus*gamm**2*nuplus*numinus*2.0- &
!       Eminus*Eplus*alphaplus*gamm*nuplus*numinus*2.0- &
!       Eminus*Eplus*alphaminus*gamm*nuplus*numinus*2.0)/ &
!       (d*(alphaplus-alphaminus)* &
!       (Eminus*alphaplus*3.0- &
!       Eminus*alphaminus*9.0+ &
!       Eplus*alphaplus*9.0- &
!       Eplus*alphaminus*3.0+ &
!       Eminus*gamm*6.0- &
!       Eplus*gamm*6.0+ &
!       Eminus*alphaplus*nuplus*2.0+ &
!       Eminus*alphaplus*numinus*3.0- &
!       Eminus*alphaminus*nuplus*6.0+ &
!       Eminus*alphaminus*numinus*3.0- &
!       Eplus*alphaplus*nuplus*3.0+ &
!       Eplus*alphaplus*numinus*6.0- &
!       Eplus*alphaminus*nuplus*3.0- &
!       Eplus*alphaminus*numinus*2.0+ &
!       Eminus*gamm*nuplus*4.0- &
!       Eminus*gamm*numinus*6.0+ &
!       Eplus*gamm*nuplus*6.0- &
!       Eplus*gamm*numinus*4.0- &
!       Eminus*alphaplus*nuplus**2+ &
!       Eminus*alphaminus*nuplus**2*3.0- &
!       Eplus*alphaplus*numinus**2*3.0+ &
!       Eplus*alphaminus*numinus**2- &
!       Eminus*gamm*nuplus**2*2.0+ &
!       Eplus*gamm*numinus**2*2.0- &
!       Eminus*alphaplus*nuplus**2*numinus- &
!       Eminus*alphaminus*nuplus**2*numinus+ &
!       Eplus*alphaplus*nuplus*numinus**2+ &
!       Eplus*alphaminus*nuplus*numinus**2+ &
!       Eminus*gamm*nuplus**2*numinus*2.0- &
!       Eplus*gamm*nuplus*numinus**2*2.0+ &
!       Eminus*alphaplus*nuplus*numinus*2.0+ &
!       Eminus*alphaminus*nuplus*numinus*2.0- &
!       Eplus*alphaplus*nuplus*numinus*2.0- &
!       Eplus*alphaminus*nuplus*numinus*2.0- &
!       Eminus*gamm*nuplus*numinus*4.0+ &
!       Eplus*gamm*nuplus*numinus*4.0) &
!       )
!
!
!       dlambda=( &
!       -Eminus**2*alphaplus- &
!       Eplus**2*alphaminus+ &
!       Eminus**2*gamm+ &
!       Eplus**2*gamm+ &
!       Eminus**2*alphaplus*nuplus**2+ &
!       Eplus**2*alphaminus*numinus**2- &
!       Eminus**2*gamm*nuplus**2- &
!       Eplus**2*gamm*numinus**2+ &
!       Eminus*Eplus*alphaplus+ &
!       Eminus*Eplus*alphaminus- &
!       Eminus*Eplus*gamm*2.0- &
!       Eminus*Eplus*alphaplus*nuplus*numinus- &
!       Eminus*Eplus*alphaminus*nuplus*numinus+ &
!       Eminus*Eplus*gamm*nuplus*numinus*2.0)/ &
!       ( &
!       (alphaplus-alphaminus)* &
!       (Eminus*alphaplus- &
!       Eminus*alphaminus+ &
!       Eplus*alphaplus- &
!       Eplus*alphaminus- &
!       Eminus*alphaplus*numinus- &
!       Eminus*alphaminus*numinus+ &
!       Eplus*alphaplus*nuplus+ &
!       Eplus*alphaminus*nuplus+ &
!       Eminus*gamm*numinus*2.0- &
!       Eplus*gamm*nuplus*2.0- &
!       Eminus*alphaplus*nuplus**2+ &
!       Eminus*alphaminus*nuplus**2- &
!       Eplus*alphaplus*numinus**2+ &
!       Eplus*alphaminus*numinus**2+ &
!       Eminus*alphaplus*nuplus**2*numinus+ &
!       Eminus*alphaminus*nuplus**2*numinus- &
!       Eplus*alphaplus*nuplus*numinus**2- &
!       Eplus*alphaminus*nuplus*numinus**2- &
!       Eminus*gamm*nuplus**2*numinus*2.0+ &
!       Eplus*gamm*nuplus*numinus**2*2.0) &
!       )- &
!       ( &
!       (Eminus*numinus*2.0- &
!       Eplus*nuplus*2.0- &
!       Eminus*nuplus**2*numinus*2.0+ &
!       Eplus*nuplus*numinus**2*2.0)* &
!       1.0/ &
!       (Eminus*alphaplus- &
!       Eminus*alphaminus+ &
!       Eplus*alphaplus- &
!       Eplus*alphaminus- &
!       Eminus*alphaplus*numinus- &
!       Eminus*alphaminus*numinus+ &
!       Eplus*alphaplus*nuplus+ &
!       Eplus*alphaminus*nuplus+ &
!       Eminus*gamm*numinus*2.0- &
!       Eplus*gamm*nuplus*2.0- &
!       Eminus*alphaplus*nuplus**2+ &
!       Eminus*alphaminus*nuplus**2- &
!       Eplus*alphaplus*numinus**2+ &
!       Eplus*alphaminus*numinus**2+ &
!       Eminus*alphaplus*nuplus**2*numinus+ &
!       Eminus*alphaminus*nuplus**2*numinus- &
!       Eplus*alphaplus*nuplus*numinus**2- &
!       Eplus*alphaminus*nuplus*numinus**2- &
!       Eminus*gamm*nuplus**2*numinus*2.0+ &
!       Eplus*gamm*nuplus*numinus**2*2.0)**2* &
!       (Eminus**2*alphaplus**2+ &
!       Eplus**2*alphaminus**2+ &
!       Eminus**2*gamm**2+ &
!       Eplus**2*gamm**2- &
!       Eminus**2*alphaplus**2*nuplus**2- &
!       Eplus**2*alphaminus**2*numinus**2- &
!       Eminus**2*gamm**2*nuplus**2- &
!       Eplus**2*gamm**2*numinus**2+ &
!       Eminus*Eplus*alphaplus**2+ &
!       Eminus*Eplus*alphaminus**2- &
!       Eminus*Eplus*gamm**2*2.0- &
!       Eminus**2*alphaplus*gamm*2.0- &
!       Eplus**2*alphaminus*gamm*2.0+ &
!       Eminus*Eplus*alphaplus**2*nuplus+ &
!       Eminus*Eplus*alphaplus**2*numinus+ &
!       Eminus*Eplus*alphaminus**2*nuplus+ &
!       Eminus*Eplus*alphaminus**2*numinus+ &
!       Eminus**2*alphaplus*gamm*nuplus**2*2.0+ &
!       Eplus**2*alphaminus*gamm*numinus**2*2.0- &
!       Eminus*Eplus*alphaplus*alphaminus*4.0+ &
!       Eminus*Eplus*alphaplus*gamm*2.0+ &
!       Eminus*Eplus*alphaminus*gamm*2.0- &
!       Eminus*Eplus*alphaplus*alphaminus*nuplus*2.0- &
!       Eminus*Eplus*alphaplus*alphaminus*numinus*2.0+ &
!       Eminus*Eplus*alphaplus**2*nuplus*numinus+ &
!       Eminus*Eplus*alphaminus**2*nuplus*numinus+ &
!       Eminus*Eplus*gamm**2*nuplus*numinus*2.0- &
!       Eminus*Eplus*alphaplus*gamm*nuplus*numinus*2.0- &
!       Eminus*Eplus*alphaminus*gamm*nuplus*numinus*2.0)*0.5)/ &
!       (alphaplus-alphaminus)- &
!       (Eminus**2*alphaplus*-6.0- &
!       Eplus**2*alphaminus*6.0+ &
!       Eminus**2*gamm*6.0+ &
!       Eplus**2*gamm*6.0+ &
!       Eminus**2*alphaplus*nuplus**2*2.0+ &
!       Eplus**2*alphaminus*numinus**2*2.0- &
!       Eminus**2*gamm*nuplus**2*2.0- &
!       Eplus**2*gamm*numinus**2*2.0+ &
!       Eminus*Eplus*alphaplus*6.0+ &
!       Eminus*Eplus*alphaminus*6.0- &
!       Eminus*Eplus*gamm*12- &
!       Eminus**2*alphaplus*nuplus*4.0- &
!       Eplus**2*alphaminus*numinus*4.0+ &
!       Eminus**2*gamm*nuplus*4.0+ &
!       Eplus**2*gamm*numinus*4.0+ &
!       Eminus*Eplus*alphaplus*nuplus*2.0+ &
!       Eminus*Eplus*alphaplus*numinus*2.0+ &
!       Eminus*Eplus*alphaminus*nuplus*2.0+ &
!       Eminus*Eplus*alphaminus*numinus*2.0- &
!       Eminus*Eplus*gamm*nuplus*4.0- &
!       Eminus*Eplus*gamm*numinus*4.0- &
!       Eminus*Eplus*alphaplus*nuplus*numinus*2.0- &
!       Eminus*Eplus*alphaminus*nuplus*numinus*2.0+ &
!       Eminus*Eplus*gamm*nuplus*numinus*4.0)/ &
!       ( &
!       d*(alphaplus-alphaminus)*(Eminus*alphaplus*3.0- &
!       Eminus*alphaminus*9.0+Eplus*alphaplus*9.0- &
!       Eplus*alphaminus*3.0+Eminus*gamm*6.0- &
!       Eplus*gamm*6.0+Eminus*alphaplus*nuplus*2.0+ &
!       Eminus*alphaplus*numinus*3.0-Eminus*alphaminus*nuplus*6.0+ &
!       Eminus*alphaminus*numinus*3.0-Eplus*alphaplus*nuplus*3.0+ &
!       Eplus*alphaplus*numinus*6.0-Eplus*alphaminus*nuplus*3.0- &
!       Eplus*alphaminus*numinus*2.0+Eminus*gamm*nuplus*4.0- &
!       Eminus*gamm*numinus*6.0+Eplus*gamm*nuplus*6.0- &
!       Eplus*gamm*numinus*4.0-Eminus*alphaplus*nuplus**2+ &
!       Eminus*alphaminus*nuplus**2*3.0-Eplus*alphaplus*numinus**2*3.0+ &
!       Eplus*alphaminus*numinus**2-Eminus*gamm*nuplus**2*2.0+ &
!       Eplus*gamm*numinus**2*2.0-Eminus*alphaplus*nuplus**2*numinus- &
!       Eminus*alphaminus*nuplus**2*numinus+Eplus*alphaplus*nuplus*numinus**2+ &
!       Eplus*alphaminus*nuplus*numinus**2+Eminus*gamm*nuplus**2*numinus*2.0- &
!       Eplus*gamm*nuplus*numinus**2*2.0+Eminus*alphaplus*nuplus*numinus*2.0+ &
!       Eminus*alphaminus*nuplus*numinus*2.0-Eplus*alphaplus*nuplus*numinus*2.0- &
!       Eplus*alphaminus*nuplus*numinus*2.0-Eminus*gamm*nuplus*numinus*4.0+ &
!       Eplus*gamm*nuplus*numinus*4.0))+((Eminus*6.0-Eplus*6.0+Eminus*nuplus*4.0- &
!       Eminus*numinus*6.0+Eplus*nuplus*6.0-Eplus*numinus*4.0-Eminus*nuplus**2*2.0+ &
!       Eplus*numinus**2*2.0-Eminus*nuplus*numinus*4.0+Eplus*nuplus*numinus*4.0+ &
!       Eminus*nuplus**2*numinus*2.0-Eplus*nuplus*numinus**2*2.0)*1.0/ &
!       (Eminus*alphaplus*3.0-Eminus*alphaminus*9.0+Eplus*alphaplus*9.0- &
!       Eplus*alphaminus*3.0+Eminus*gamm*6.0-Eplus*gamm*6.0+Eminus*alphaplus*nuplus*2.0+ &
!       Eminus*alphaplus*numinus*3.0-Eminus*alphaminus*nuplus*6.0+ &
!       Eminus*alphaminus*numinus*3.0-Eplus*alphaplus*nuplus*3.0+ &
!       Eplus*alphaplus*numinus*6.0-Eplus*alphaminus*nuplus*3.0-Eplus*alphaminus*numinus*2.0+ &
!       Eminus*gamm*nuplus*4.0-Eminus*gamm*numinus*6.0+Eplus*gamm*nuplus*6.0- &
!       Eplus*gamm*numinus*4.0-Eminus*alphaplus*nuplus**2+Eminus*alphaminus*nuplus**2*3.0- &
!       Eplus*alphaplus*numinus**2*3.0+Eplus*alphaminus*numinus**2-Eminus*gamm*nuplus**2*2.0+ &
!       Eplus*gamm*numinus**2*2.0-Eminus*alphaplus*nuplus**2*numinus-Eminus*alphaminus*nuplus**2*numinus+ &
!       Eplus*alphaplus*nuplus*numinus**2+Eplus*alphaminus*nuplus*numinus**2+ &
!       Eminus*gamm*nuplus**2*numinus*2.0-Eplus*gamm*nuplus*numinus**2*2.0+ &
!       Eminus*alphaplus*nuplus*numinus*2.0+Eminus*alphaminus*nuplus*numinus*2.0- &
!       Eplus*alphaplus*nuplus*numinus*2.0-Eplus*alphaminus*nuplus*numinus*2.0- &
!       Eminus*gamm*nuplus*numinus*4.0+Eplus*gamm*nuplus*numinus*4.0)**2* &
!       (Eminus**2*alphaplus**2*3.0+Eplus**2*alphaminus**2*3.0+ &
!       Eminus**2*gamm**2*3.0+Eplus**2*gamm**2*3.0+Eminus**2*alphaplus**2*nuplus*2.0+ &
!       Eplus**2*alphaminus**2*numinus*2.0+Eminus**2*gamm**2*nuplus*2.0+ &
!       Eplus**2*gamm**2*numinus*2.0-Eminus**2*alphaplus**2*nuplus**2- &
!       Eplus**2*alphaminus**2*numinus**2-Eminus**2*gamm**2*nuplus**2- &
!       Eplus**2*gamm**2*numinus**2+Eminus*Eplus*alphaplus**2*9.0+ &
!       Eminus*Eplus*alphaminus**2*9.0-Eminus*Eplus*gamm**2*6.0- &
!       Eminus**2*alphaplus*gamm*6.0-Eplus**2*alphaminus*gamm*6.0- &
!       Eminus*Eplus*alphaplus**2*nuplus*3.0-Eminus*Eplus*alphaplus**2*numinus*3.0- &
!       Eminus*Eplus*alphaminus**2*nuplus*3.0-Eminus*Eplus*alphaminus**2*numinus*3.0- &
!       Eminus*Eplus*gamm**2*nuplus*2.0-Eminus*Eplus*gamm**2*numinus*2.0- &
!       Eminus**2*alphaplus*gamm*nuplus*4.0-Eplus**2*alphaminus*gamm*numinus*4.0+ &
!       Eminus**2*alphaplus*gamm*nuplus**2*2.0+Eplus**2*alphaminus*gamm*numinus**2*2.0- &
!       Eminus*Eplus*alphaplus*alphaminus*2.4e1+Eminus*Eplus*alphaplus*gamm*6.0+ &
!       Eminus*Eplus*alphaminus*gamm*6.0+Eminus*Eplus*alphaplus*alphaminus*nuplus*4.0+ &
!       Eminus*Eplus*alphaplus*alphaminus*numinus*4.0+Eminus*Eplus*alphaplus*gamm*nuplus*2.0+ &
!       Eminus*Eplus*alphaplus*gamm*numinus*2.0+Eminus*Eplus*alphaminus*gamm*nuplus*2.0+ &
!       Eminus*Eplus*alphaminus*gamm*numinus*2.0+Eminus*Eplus*alphaplus**2*nuplus*numinus+ &
!       Eminus*Eplus*alphaminus**2*nuplus*numinus+Eminus*Eplus*gamm**2*nuplus*numinus*2.0- &
!       Eminus*Eplus*alphaplus*gamm*nuplus*numinus*2.0-Eminus*Eplus*alphaminus*gamm*nuplus*numinus*2.0))/(d*(alphaplus-alphaminus))
!
!       C(1,1) = 2*mu+lambda
!       C(1,2) = lambda
!       C(1,3) = 0
!       C(2,1) = lambda
!       C(2,2) = 2*mu+lambda
!       C(2,3) = 0
!       C(3,1) = 0
!       C(3,2) = 0
!       C(3,3) = mu
!
!
!
!       dC(1,1) = 2*dmu+dlambda
!       dC(1,2) = dlambda
!       dC(1,3) = 0
!       dC(2,1) = dlambda
!       dC(2,2) = 2*dmu+dlambda
!       dC(2,3) = 0
!       dC(3,1) = 0
!       dC(3,2) = 0
!       dC(3,3) = dmu
!
!
!
!       ! Calculate the inverse determinant of the matrix C
!       detinv = 1/(C(1,1)*C(2,2)*C(3,3) - C(1,1)*C(2,3)*C(3,2)&
!                   - C(1,2)*C(2,1)*C(3,3) + C(1,2)*C(2,3)*C(3,1)&
!                   + C(1,3)*C(2,1)*C(3,2) - C(1,3)*C(2,2)*C(3,1))
!
!       ! Calculate the inverse of the matrix
!          IC(1,1) = +detinv * (C(2,2)*C(3,3) - C(2,3)*C(3,2))
!          IC(2,1) = -detinv * (C(2,1)*C(3,3) - C(2,3)*C(3,1))
!          IC(3,1) = +detinv * (C(2,1)*C(3,2) - C(2,2)*C(3,1))
!          IC(1,2) = -detinv * (C(1,2)*C(3,3) - C(1,3)*C(3,2))
!          IC(2,2) = +detinv * (C(1,1)*C(3,3) - C(1,3)*C(3,1))
!          IC(3,2) = -detinv * (C(1,1)*C(3,2) - C(1,2)*C(3,1))
!          IC(1,3) = +detinv * (C(1,2)*C(2,3) - C(1,3)*C(2,2))
!          IC(2,3) = -detinv * (C(1,1)*C(2,3) - C(1,3)*C(2,1))
!          IC(3,3) = +detinv * (C(1,1)*C(2,2) - C(1,2)*C(2,1))
!
!
!                   P(:,:)=matmul(IC(:,:),dC(:,:))
!
!
!
!          dP(1,1)=P(3,3)+P(1,2)
!          dP(1,2)=P(1,2)
!          dP(1,3)=0
!          dP(2,1)=P(1,2)
!          dP(2,2)=P(3,3)+P(1,2)
!          dP(2,3)=0
!          dP(3,1)=0
!          dP(3,2)=0
!          dP(3,3)=P(3,3)
!
!
!
!       RETURN
!       END SUBROUTINE
! !
! !
!
!
!