  function efms (evapObj, z, a)

! ======================================================================
!
!  EFMS
!  Fission barrier given by Myers & Swiatecki (PRC 60, 014606, 1999)
!  Note that this fit is only good for Z >= 70; Z <70 results may be
!  suspect!!!  AJS  10/22/03
!
! ====================================================================
! <variables>
!     a   :   the mass of a fissioning nucleus      (IN)
!     z   :   the charge of a fissioning nucleus    (IN)
!   efms  :   fission barrier  [MeV]                (OUT)
!
!    "Last" change: 13-AUG-2003 by NVMokhov
!    Edited by A. J. Sierk, LANL T-16, September, 2003.
!    Edited by AJS, LANL T-2, December, 2011.
!    Edited by LMK, XCP-3, July 2013 (included error protection).
!
! ======================================================================

    use, intrinsic :: iso_fortran_env, only: int32, real64
    use evaporationParams, only: zro, one, two, ato3rd
    use evaporationFissionData, only: shellc

    implicit none
    class(Evaporation), intent(inout) :: evapObj
    real(real64),       intent(in   ) :: a
    real(real64),       intent(in   ) :: z
    real(real64)                      :: efms

    integer(int32) :: ia, in, iz
    real(real64)   :: ai, c, sh, ss, temp, x, xx

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

!    8/15/1999
    real(real64), parameter :: x0 = 48.5428d0
    real(real64), parameter :: x1 = 34.15d0

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

    efms = zro
    iz = nint(z)
    ia = nint(a)

    c = 1.9d0 + (z - 80.d0)/75.d0
    temp = a
    if (temp < div0Lim .and. temp > -div0Lim) then
       temp = div0Lim
       write(evapObj%io%message,1000) '783'
       call evapObj%io%print(4, 3, evapObj%io%message)
    end if
    ai = one - two*(z/temp)
    xx = one - c*ai**2
    ss = xx*ato3rd(ia)**2
    temp = a*xx
    if (temp < div0Lim .and. temp > -div0Lim) then
       temp = div0Lim
       write(evapObj%io%message,1000) '791'
       call evapObj%io%print(4, 3, evapObj%io%message)
    end if
    x = z**2/(temp)
    in = ia - iz
    if (in <= 0 .or. in > 250 .or. iz > 150 .or. iz < 1) then
       sh = zro
    else
       sh = shellc (iz, in)
    endif

    if (x >= x1 .and. x <= x0) then
       efms = ss*f1(x0, x) - sh
    elseif (x >= 20.d0 .and. x < x0) then
       efms = ss*f2(x1, x) - sh
    else
       efms = -one
    endif

    return

! ======================================================================
1000 format("Divide by zero error prevented in 'gem2.f90', line ", A)
! ======================================================================
  end function efms

  function f1 ( x0, t )

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

    use, intrinsic:: iso_fortran_env, only: real64

    implicit none
    real(real64), intent(in   ) :: x0
    real(real64), intent(in   ) :: t
    real(real64)                :: f1

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

    f1 = 1.99749d-4*(x0 - t)**3

    return
! ======================================================================
  end function f1

  function f2 ( x1, t )

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

    use, intrinsic:: iso_fortran_env, only: real64

    implicit none
    real(real64), intent(in   ) :: x1
    real(real64), intent(in   ) :: t
    real(real64)                :: f2

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

    f2 = 5.95553d-1 - 0.124136d0*(t - x1)

    return
! ======================================================================
  end function f2

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

  function radgem(ia)

! ======================================================================
!
!    "Last" change: 13-AUG-2003 by NVMokhov
!    Edited by A. J. Sierk, LANL T-16, September, 2003.
!    Edited by AJS, LANL T-2, December, 2011.
!
!  =====================================================================

    use, intrinsic :: iso_fortran_env, only: int32, real64
    use evaporationParams, only: zro, one, ato3rd

    implicit none
    integer(int32), intent(in   ) :: ia
    real(real64)                  :: radgem

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

    real(real64), parameter :: rho0 = 1.414d0

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

    if (ia < 10) then
       if (ia == 9) radgem = 3.25d0
       if (ia == 8) radgem = 2.83d0
       if (ia == 7) radgem = 2.42d0
       if (ia == 6) radgem = 2.02d0
       if (ia == 5) radgem = 2.02d0
       if (ia <= 4) radgem = 1.2d0
       if (ia == 1) radgem = zro
    else
       radgem = rho0*ato3rd(ia) + one
    endif
    return

! ======================================================================
  end function radgem

  function dost (i, z)

! ======================================================================
!
! <variables>
!   t   : set in subroutine setup
!       This routine was originally in the HETC code.
!
! ======================================================================
!
!    "Last" change: 13-AUG-2003 by NVMokhov
!    Modified by A. J. Sierk, LANL T-16, September, 2003.
!    Edited by AJS, LANL T-2, December, 2011.
!
! ======================================================================

    use, intrinsic :: iso_fortran_env, only: int32, real64
    use evaporationParams, only: one, ten
    use evaporationFissionData, only: t

    implicit none
    integer(int32), intent(in   ) :: i
    real(real64),   intent(in   ) :: z
    real(real64)                  :: dost

    integer(int32) :: n
    real(real64)   :: x

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

!      i = 1 -> Calculate kp
!      i = 2 -> Calculate k_alpha
!      i = 3 -> Calculate cp

! Linear interpolation, flat extrapolation, LMK
    if (z >= 50) then
       dost = t(i,4)
    elseif (z <= 20) then
       dost = t(i,1)
    else
       n = int(z/ten)
       x = ten*(dble(n) + one)
       x = (x - z)/ten
       dost = x*t(i,n-1) + (one - x)*t(i,n)
    endif
    return

! ======================================================================
  end function dost

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

  function rb (evapObj, a1, ia2, z1, iz2, j)

! ======================================================================
!
!  RB
!    Calculate nuclear radius for a geometric cross section
! ====================================================================
!
! <variables>
!     a1  :   mass of nucleus #1                    (IN)
!     z1  :   charge  of nucleus #1                 (IN)
!    ia2  :   mass of nucleus #2                    (IN)
!    iz2  :   charge  of nucleus #2                 (IN)
!     j   :   type of nucleus #2 (index of ejectile)(IN)
!    ck   :   transmission probability              (IN)
!    rb   :   Nuclear radius [fm]                   (OUT)
!
!    "Last" change: 13-AUG-2003 by NVMokhov
!    Edited by A. J. Sierk, LANL T-16, September, 2003.
!    Edited by AJS, LANL T-2, December, 2011.
!    Edited by LMK, XCP-3, July 2013 (included error protection).
!
! ======================================================================

    use, intrinsic :: iso_fortran_env, only: int32, real64
    use evaporationParams, only: zro, one, ato3rd
    use evaporationFissionData, only: aMax

    implicit none
    class(Evaporation), intent(inout) :: evapObj
    real(real64),       intent(in   ) :: a1
    integer(int32),     intent(in   ) :: ia2
    real(real64),       intent(in   ) :: z1
    integer(int32),     intent(in   ) :: iz2
    integer(int32),     intent(in   ) :: j
    real(real64)                      :: rb

    integer(int32) :: ia1, l
    real(real64)   :: a1thrd, a2thrd, r1, r2, rr, rzero, temp, ziz

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

    real(real64), parameter                  :: r0     = 1.5d0
    real(real64), parameter, dimension(aMax) :: rmat = &
         & [ ( 1.12d0*ato3rd(l) - 0.86d0/ato3rd(l), l=1, aMax ) ]

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

    ia1 = nint(a1)
    a1thrd = ato3rd(ia1)
    a2thrd = ato3rd(ia2)

    if (evapObj%options%inverseParameter > zro) then
!   Simple form
       if (evapObj%options%inverseParameter == 10.d0) then
          rr = r0
       else
          rr = evapObj%options%inverseParameter
       endif
       r1 = rr*a1thrd
       r2 = rr*a2thrd
       rb = r1 + r2
    elseif (evapObj%options%inverseParameter == -one .and. j > 6) then
!   Expression in NP A475 (1987) 663 (for heavy ions)
       ziz = z1*dble(iz2)
       temp = one + 9.443d-3*ziz
       if (temp < div0Lim .and. temp > -div0Lim) then
          temp = div0Lim
          write(evapObj%io%message,1000) '1161'
          call evapObj%io%print(4, 3, evapObj%io%message)
       end if
       rzero = 2.173d0*(one + 6.103d-3*ziz)/(temp)
       r1 = a1thrd
       r2 = a2thrd
       rb = rzero*(r1 + r2)
    elseif (evapObj%options%inverseParameter < zro .and. j <= 6) then
!   FB form  ...2001/3/15
       r1 = radgem (ia1)
       r2 = radgem (ia2)
       rb =  r1 + r2
    else
!   Dostrovsky et. al.
       if (j <= 6) then
          if (j > 2) then
             rb  =  a1thrd + a2thrd
          else
             rb  =  a1thrd
          endif
          rb  =  rb*r0
       else
!    Matsuse et al. PRC 26 (1982) 2338
          rb = rmat(ia1) + rmat(ia2) + 2.85d0
       endif
    endif
    return

! ======================================================================
1000 format("Divide by zero error prevented in 'gem2.f90', line ", A)
! ======================================================================
  end function rb

  function rho (evapObj, ia, iz, u, delta, calcVars)

! ======================================================================
!
!    Calculates unnormalized level density as a function of energy.
!
!     variable       IN/OUT
!     ia             IN        mass before emission (=A)
!     iz             IN        charge before emission (=Z)
!     u              IN        excitation energy before emission
!     delta          IN        pairing energy
!     smalla         IN        level density parameter at U
!
! -------------------------------------------------------------------
!    "Last" change: 13-AUG-2003 by NVMokhov
!    Edited by A. J. Sierk, LANL T-16, September, 2003.
!    Modified by AJS, January, 2005.
!    Edited by AJS, LANL T-2, December, 2011.
!    Edited by LMK, XCP-3, July 2013 (included error protection).
!
! ======================================================================

    use, intrinsic :: iso_fortran_env, only: int32, real64
    use evaporationParams, only: two
    use evaporationFissionData, only: ux0

    implicit none
    class(Evaporation), intent(inout) :: evapObj
    integer(int32),     intent(in   ) :: ia
    integer(int32),     intent(in   ) :: iz
    real(real64),       intent(in   ) :: u
    real(real64),       intent(in   ) :: delta
    type(evaporationCalculation), intent(in   ) :: calcVars
    real(real64)                      :: rho

    integer(int32) :: nn
    real(real64)   :: ex0, s0, smalla14, temp, umd, umd14, ut

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

    ex0 = ux0(ia) + delta
    s0 = two*sqrt(abs(calcVars%smalla0*u))
    if (u >= ex0) then
!  Eq. (44) of CEM03 Manual: [modified by mysterious exp(-s0) factor]
       smalla14 = sqrt(sqrt(abs(calcVars%smalla0)))
       umd = u - delta
       umd14 = sqrt(sqrt(abs(umd)))
       temp = smalla14*umd*umd14
       if (temp < div0Lim .and. temp > -div0Lim) then
          temp = div0Lim
          write(evapObj%io%message,1000) '1287'
          call evapObj%io%print(4, 3, evapObj%io%message)
       end if
       rho = exp(two*sqrt(abs(calcVars%smalla0*umd)) - s0) &
            & /(temp)
    else
!  Eq. (46) of CEM03 Manual: [modified by mysterious exp(-s0) factor]
       nn = ia - iz
       ut = u*evapObj%data%taux0(iz,nn)
       rho = evapObj%data%fact10(iz,nn) * evapObj%data%taux0(iz,nn) * &
            & exp(ut + evapObj%data%sx0(iz,nn) - s0)
    endif
    return

! ======================================================================
1000 format("Divide by zero error prevented in 'gem2.f90', line ", A)
! ======================================================================
  end function rho

  function pe (evapObj, e, q, delta, bet, tau, e0, ex, smalla, x, calcVars)

! ======================================================================
!
!   The unnormalized emission probability for evaporation of a particle
!   as a function of energy
!
!   variable :   IN/OUT
!     e      :     IN      excitation energy of nucleus before emission
!     q      :     IN      Q-value
!     delta  :     IN      pairing energy
!     bet    :     IN      beta in the Dostrovsky inverse cross section
!                          approximation; beta for n, -V for chgd. par.
!     tau    :     IN      auxiliary quantity for low excitation energy
!                          defined in EYE subroutine
!     e0     :     IN      auxiliary quantity; defined after Eq. (46)
!     ex     :     IN      auxiliary quantity; point of joining of the
!                          low e and high e approximations to l. d. parm.
!                          = Ux0 + delta; Ux0 defined in EYE
!    smalla  :     IN      level-density parameter
!     x      :     IN      independent variable; KE of ejectile
!     pe     :    OUT      unnormalized emission probability as a funct
!                          of outgoing KE; see Eq. (39) of CEM03 man'l.
!
!    Called by: CALR, SELECTE
!
!    "Last" change: 13-AUG-2003 by NVMokhov
!    Modified by A. J. Sierk, LANL T-16, September, 2003.
!    Edited by A. J. Sierk, LANL T-2, February, 2009.
!    Edited by AJS, LANL T-2, December, 2011.
!
! ======================================================================

    use, intrinsic :: iso_fortran_env, only: real64
    use evaporationParams, only: zro, two

    implicit none
    class(Evaporation), intent(inout) :: evapObj
    real(real64),       intent(in   ) :: e
    real(real64),       intent(in   ) :: q
    real(real64),       intent(in   ) :: delta
    real(real64),       intent(in   ) :: bet
    real(real64),       intent(in   ) :: tau
    real(real64),       intent(in   ) :: e0
    real(real64),       intent(in   ) :: ex
    real(real64),       intent(in   ) :: smalla
    real(real64),       intent(in   ) :: x
    type(evaporationCalculation), intent(in   ) :: calcVars
    real(real64)                      :: pe

    real(real64)   :: eqex, eqx, s0, sqax, temp, xxx

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

    if (e - q <= zro) then
       pe = zro
       return
    endif
    s0 = two*sqrt(abs(calcVars%smalla0*e))
    eqx = e - q - x
    eqex = e - q - ex
    if (x > eqex .and. eqx >= zro) then
       temp = tau
       if (temp < div0Lim .and. temp > -div0Lim) then
          temp = div0Lim
          write(evapObj%io%message,1000) '1542'
          call evapObj%io%print(4, 3, evapObj%io%message)
       end if
       pe = exp((eqx - e0)/temp - s0)/temp
!  Modified 2001/4/13:
    elseif (x >= zro .and. x <= eqex) then
       xxx = eqx - delta
       sqax = sqrt(abs(smalla*xxx))
       pe = exp(two*sqax - s0)
       temp = sqax
       if (temp < div0Lim .and. temp > -div0Lim) then
          temp = div0Lim
          write(evapObj%io%message,1000) '1553'
          call evapObj%io%print(4, 3, evapObj%io%message)
       end if
       pe = pe/sqrt(abs(temp))
       temp = xxx
       if (temp < div0Lim .and. temp > -div0Lim) then
          temp = div0Lim
          write(evapObj%io%message,1000) '1559'
          call evapObj%io%print(4, 3, evapObj%io%message)
       end if
       pe = pe/temp
    else
       pe = zro
    endif
    pe = pe*(x + bet)
    return

! ======================================================================
1000 format("Divide by zero error prevented in 'gem2.f90', line ", A)
! ======================================================================
  end function pe

  subroutine calr (evapObj, aa, zz, u, q, v, delta, r, calcVars)

! ======================================================================
!
!    Called by: GAMMA
!
!    Calls: GETA, PE
!
!    Decay width
!    Related to the probability for emission under the barrier of an
!    evaporated complex particle (AJS)
!
!     variable       IN/OUT
!     aa             IN        residual mass after emission (=A-Aj)
!     zz             IN        charge number of res nuclei after emission
!     u              IN        excitation energy of nuclei before emission
!     q              IN        Q-value
!     v              IN        kv in the equation
!     delta          IN        pairing energy
!     r              OUT       r in the equation
! -------------------------------------------------------------------
!    "Last" change: 13-AUG-2003 by NVMokhov
!    Modified by A. J. Sierk, LANL T-16, September, 2003.
!    Edited by AJS, LANL T-2, December, 2011.
!    Edited by LMK, XCP-3, July 2013 (included error protection).
!
! ======================================================================

    use, intrinsic :: iso_fortran_env, only: int32, real64
    use evaporationParams, only: zro, one ,two

    implicit none
    class(Evaporation), intent(inout) :: evapObj
    real(real64),       intent(in   ) :: aa
    real(real64),       intent(in   ) :: zz
    real(real64),       intent(in   ) :: u
    real(real64),       intent(in   ) :: q
    real(real64),       intent(in   ) :: v
    real(real64),       intent(in   ) :: delta
    real(real64),       intent(  out) :: r
    type(evaporationCalculation), intent(inout) :: calcVars

    integer(int32) :: ifuri, imax, isdum, izz, nn
    real(real64)   :: aaa, alpha, ax, dt, e0, emin, ex, sx, tau, &
         & temp, tempOld, temp2, ux, x, xold, xxx

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

    izz = nint (zz)
    nn = nint (aa - zz)
    temp = zz
    if (temp < div0Lim .and. temp > -div0Lim) then
       temp = div0Lim
       write(evapObj%io%message,1000) '1625'
       call evapObj%io%print(4, 3, evapObj%io%message)
    end if
    alpha = 0.869d0 + 9.91d0/temp
    temp = aa
    if (temp < div0Lim .and. temp > -div0Lim) then
       temp = div0Lim
       write(evapObj%io%message,1000) '1631'
       call evapObj%io%print(4, 3, evapObj%io%message)
    end if
    ux = 2.5d0 + 150.d0/temp
    ex = ux + delta
    ax = geta (evapObj%data%alev(), ex, izz, nn, isdum)
    temp = ux
    if (temp < div0Lim .and. temp > -div0Lim) then
       temp = div0Lim
       write(evapObj%io%message,1000) '1639'
       call evapObj%io%print(4, 3, evapObj%io%message)
    end if
    tau = sqrt(abs(ax/temp)) - 1.5d0/temp
    temp = tau
    if (temp < div0Lim .and. temp > -div0Lim) then
       temp = div0Lim
       write(evapObj%io%message,1000) '1645'
       call evapObj%io%print(4, 3, evapObj%io%message)
    end if
    tau = one/temp
    sx = two*sqrt(abs(ax*ux))
    e0 = ex - tau*(log(tau) - 0.25d0*log(ax) - 1.25d0*log(ux) + sx)

!   ..Calculate exact decay width
    imax = 1000
    emin = v*0.1d0
    xold = zro
    tempold = zro
    r = zro
    do ifuri = 0,imax
       xxx = u - q - v
       temp = dble(imax)
       if (temp < div0Lim .and. temp > -div0Lim) then
          temp = div0Lim
          write(evapObj%io%message,1000) '1662'
          call evapObj%io%print(4, 3, evapObj%io%message)
       end if
       x = emin + xxx*dble(ifuri)/temp
       aaa = geta (evapObj%data%alev(), xxx, izz, nn, isdum)
       temp = evapObj%pe (u, q, delta, -v, tau, e0, ex, aaa, x, calcVars)
       if (x < v+one) then
          temp2 = x - v
          if (temp2 < div0Lim .and. temp2 > -div0Lim) then
             temp2 = div0Lim
             write(evapObj%io%message,1000) '1671'
             call evapObj%io%print(4, 3, evapObj%io%message)
          end if
          temp = temp/(temp2)
          temp2 = one + v
          if (temp2 < div0Lim .and. temp2 > -div0Lim) then
             temp2 = div0Lim
             write(evapObj%io%message,1000) '1677'
             call evapObj%io%print(4, 3, evapObj%io%message)
          end if
          temp = temp/(temp)*exp(alpha*(x - v - one))*x
       endif
       dt = (tempold + temp)*(x - xold)/two
       r = r + dt
       temp2 = r
       if (temp2 < div0Lim .and. temp2 > -div0Lim) then
          temp2 = div0Lim
          write(evapObj%io%message,1000) '1686'
          call evapObj%io%print(4, 3, evapObj%io%message)
       end if
       if (x > v .and. (dt/temp2) < 1.d-4) return
       xold = x
       tempold = temp
    end do
    return

! ======================================================================
1000 format("Divide by zero error prevented in 'gem2.f90', line ", A)
! ======================================================================
  end subroutine calr

  function ckcal (j, z, a)

! ====================================================================
!
! <variables>
!     j   :   ejectile  ID                      (IN)
!     a   :   mass of daughter nucleus          (IN)
!     z   :   charge  of daughter nucleus       (IN)
!
! ====================================================================
!
!    "Last" change: 13-AUG-2003 by NVMokhov
!    Modified by A. J. Sierk, LANL T-16, September, 2003.
!    Edited by AJS, LANL T-2, December, 2011.
!
! ======================================================================

    use, intrinsic :: iso_fortran_env, only: int32, real64
    use evaporationParams, only: zro, one

    implicit none
    integer(int32), intent(in   ) :: j
    real(real64),   intent(in   ) :: z
    real(real64),   intent(in   ) :: a
    real(real64)                  :: ckcal

    integer(int32) :: i

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

    integer(int32), parameter :: jul = 65
    real(real64), dimension(jul), parameter :: c1 = &
         & [     0.0615d0, 0.0556d0, 0.0530d0, 0.0484d0, 0.0468d0, &
         &       0.0440d0, 0.0423d0, 0.0419d0, 0.0409d0, 0.0404d0, 0.0395d0, &
         &       0.0397d0, 0.0382d0, 0.0378d0, 0.0374d0, 0.0370d0, 0.0380d0, &
         &       0.0368d0, 0.0362d0, 0.0358d0, 0.0354d0, 0.0358d0, 0.0352d0, &
         &       0.0349d0, 0.0351d0, 0.0353d0, 0.0354d0, 0.0353d0, 0.0352d0, &
         &       0.0353d0, 0.0352d0, 0.0349d0, 0.0348d0, 0.0346d0, 0.0347d0, &
         &       0.0345d0, 0.0345d0, 0.0344d0, 0.0344d0, 0.0343d0, 0.0345d0, &
         &       0.0342d0, 0.0344d0, 0.0346d0, 0.0346d0, 0.0347d0, 0.0346d0, &
         &       0.0345d0, 0.0345d0, 0.0346d0, 0.0347d0, 0.0347d0, 0.0347d0, &
         &       0.0346d0, 0.0347d0, 0.0347d0, 0.0347d0, 0.0346d0, 0.0345d0, &
         &       0.0346d0, 0.0347d0, 0.0347d0, 0.0347d0, 0.0347d0, 0.0347d0  ]

    real(real64), dimension(jul), parameter :: c2 = &
         & [     0.0167d0, 0.0135d0, 0.0134d0, 0.0122d0, 0.0122d0, &
         &       0.0116d0, 0.0111d0, 0.0110d0, 0.0107d0, 0.0105d0, 0.0106d0, &
         &       0.0105d0, 0.0101d0, 0.0097d0, 0.0100d0, 0.0104d0, 0.0098d0, &
         &       0.0099d0, 0.0101d0, 0.0103d0, 0.0104d0, 0.0098d0, 0.0099d0, &
         &       0.0099d0, 0.0096d0, 0.0094d0, 0.0096d0, 0.0101d0, 0.0090d0, &
         &       0.0092d0, 0.0097d0, 0.0103d0, 0.0109d0, 0.0114d0, 0.0104d0, &
         &       0.0109d0, 0.0114d0, 0.0119d0, 0.0123d0, 0.0128d0, 0.0130d0, &
         &       0.0122d0, 0.0125d0, 0.0128d0, 0.0131d0, 0.0134d0, 0.0147d0, &
         &       0.0151d0, 0.0155d0, 0.0159d0, 0.0162d0, 0.0166d0, 0.0169d0, &
         &       0.0140d0, 0.0143d0, 0.0148d0, 0.0152d0, 0.0156d0, 0.0126d0, &
         &       0.0129d0, 0.0132d0, 0.0137d0, 0.0141d0, 0.0145d0, 0.0149d0 ]

    real(real64), dimension(jul), parameter :: c3 = &
         & [     0.3227d0, 0.4067d0, 0.4374d0, 0.4938d0, 0.5120d0, &
         &       0.5460d0, 0.5691d0, 0.5735d0, 0.5856d0, 0.5953d0, 0.6035d0, &
         &       0.6029d0, 0.6216d0, 0.6310d0, 0.6341d0, 0.6370d0, 0.6262d0, &
         &       0.6421d0, 0.6460d0, 0.6499d0, 0.6537d0, 0.6527d0, 0.6573d0, &
         &       0.6616d0, 0.6648d0, 0.6668d0, 0.6679d0, 0.6680d0, 0.6696d0, &
         &       0.6709d0, 0.6714d0, 0.6717d0, 0.6718d0, 0.6718d0, 0.6747d0, &
         &       0.6750d0, 0.6751d0, 0.6751d0, 0.6750d0, 0.6748d0, 0.6746d0, &
         &       0.6781d0, 0.6781d0, 0.6779d0, 0.6778d0, 0.6778d0, 0.6844d0, &
         &       0.6839d0, 0.6833d0, 0.6829d0, 0.6823d0, 0.6818d0, 0.6812d0, &
         &       0.6827d0, 0.6823d0, 0.6818d0, 0.6813d0, 0.6808d0, 0.6810d0, &
         &       0.6809d0, 0.6808d0, 0.6804d0, 0.6801d0, 0.6796d0, 0.6792d0 ]

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

    if (j <= 1 .or. z <= zro .or. a < one) then
       ckcal = zro
    else
       i = min(j-1,jul)
       ckcal = c1(i)*log(z) + c2(i)*log(a) + c3(i)
    endif

    return

! ======================================================================
  end function ckcal


!-------------------------------------------------------------------------------
! Copyright (c) 2016 The University of Tokyo
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> \brief  Eight-node hexagonal element with imcompatible mode
!> \see R.L.Taylor,P.J.Bereford, and E.L.Wilson, "A Nonconforming element
!>  for Stress Analysis", Intl. J. Numer. Methods Engng, 10(6), pp1211-1219
!>  ,1976
module m_static_LIB_3dIC

  use hecmw, only : kint, kreal
  use m_utilities
  use elementInfo

  implicit none

contains

  !>  CALCULATION STIFF Matrix for C3D8IC ELEMENT
  !----------------------------------------------------------------------*
  subroutine STF_C3D8IC &
      (etype, nn, ecoord, gausses, stiff, cdsys_ID, coords, &
      time, tincr, u, aux, temperature)
    !----------------------------------------------------------------------*

    use mMechGauss
    use m_MatMatrix
    use m_common_struct
    use m_static_LIB_3d, only: GEOMAT_C3

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

    integer(kind=kint), intent(in)  :: etype                !< element type, not used here
    integer(kind=kint), intent(in)  :: nn                   !< number of elements nodes
    real(kind=kreal), intent(in)    :: ecoord(3, nn)        !< nodal coord of curr element
    type(tGaussStatus), intent(in)  :: gausses(:)           !< Info of qudrature points
    real(kind=kreal), intent(out)   :: stiff(:, :)          !< stiffness matrix
    integer(kind=kint), intent(in)  :: cdsys_ID
    real(kind=kreal), intent(inout) :: coords(3, 3)         !< variables to define matreial coordinate system
    real(kind=kreal), intent(in)    :: time                 !< current time
    real(kind=kreal), intent(in)    :: tincr                !< time increment
    real(kind=kreal), intent(in), optional :: u(3, nn)      !< nodal displacemwent
    real(kind=kreal), intent(in), optional :: aux(3, 3)     !< enhanced disp of bending mode
    real(kind=kreal), intent(in), optional :: temperature(nn) !< temperature

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

    integer(kind=kint) :: flag
    integer(kind=kint), parameter :: ndof = 3
    real(kind=kreal) :: D(6, 6), B(6, ndof*(nn+3)), DB(6, ndof*(nn+3))
    real(kind=kreal) :: gderiv(nn+3, 3), stress(6)
    real(kind=kreal) :: xj(9, 9), jacobian(3, 3), inverse(3, 3)
    real(kind=kreal) :: tmpstiff((nn+3)*3, (nn+3)*3), tmpk(nn*3, 9)
    real(kind=kreal) :: det, wg, elem(3, nn), mat(6, 6)
    integer(kind=kint) :: i, j, LX
    integer(kind=kint) :: serr
    real(kind=kreal) :: naturalCoord(3), unode(3, nn+3)
    real(kind=kreal) :: gdispderiv(3, 3), coordsys(3, 3)
    real(kind=kreal) :: B1(6, ndof*(nn+3))
    real(kind=kreal) :: Smat(9, 9)
    real(kind=kreal) :: BN(9, ndof*(nn+3)), SBN(9, ndof*(nn+3))
    real(kind=kreal) :: spfunc(nn), temp

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

    if( present(u) .AND. present(aux) ) then
      unode(:, 1:nn)      = u(:, :)
      unode(:, nn+1:nn+3) = aux(:, :)
    end if

    ! we suppose the same material type in the element
    flag = gausses(1)%pMaterial%nlgeom_flag
    if( .not. present(u) ) flag = INFINITE    ! enforce to infinite deformation analysis
    elem(:, :) = ecoord(:, :)
    if( flag == UPDATELAG ) elem(:, :) = ecoord(:, :)+unode(:, 1:nn)

    ! --- Inverse of Jacobian at elemental center
    naturalcoord(:) = 0.0D0
    call getJacobian(etype, nn, naturalcoord, elem, det, jacobian, inverse)
    inverse(:, :)= inverse(:, :)*det
    ! ---- We now calculate stiff matrix include imcompatible mode
    !    [   Kdd   Kda ]
    !    [   Kad   Kaa ]
    tmpstiff(:, :) = 0.0D0
    B1(1:6, 1:(nn+3)*ndof) = 0.0D0
    BN(1:9, 1:(nn+3)*ndof) = 0.0D0

    do LX = 1, NumOfQuadPoints(etype)

      call getQuadPoint(etype, LX, naturalCoord)
      call getGlobalDeriv( etype, nn, naturalcoord, elem, det, gderiv(1:nn, 1:3) )

      if( cdsys_ID > 0 ) then
        call set_localcoordsys( coords, g_LocalCoordSys(cdsys_ID), coordsys(:, :), serr )
        if( serr == -1 ) stop "Fail to setup local coordinate"
        if( serr == -2 ) then
          write(*, *) "WARNING! Cannot setup local coordinate, it is modified automatically"
        end if
      end if

      if( present(temperature) ) then
        call getShapeFunc( etype, naturalcoord, spfunc )
        temp = dot_product( temperature, spfunc )
        call MatlMatrix( gausses(LX), D3, D, time, tincr, coordsys, temp )
      else
        call MatlMatrix( gausses(LX), D3, D, time, tincr, coordsys )
      end if

      if( flag == UPDATELAG ) then
        call GEOMAT_C3( gausses(LX)%stress, mat )
        D(:, :) = D(:, :)-mat
      endif

      ! -- Derivative of shape function of imcompatible mode --
      !     [ -2*a   0,   0   ]
      !     [   0,  -2*b, 0   ]
      !     [   0,   0,  -2*c ]
      ! we don't call getShapeDeriv but use above value directly for computation efficiency
      gderiv(nn+1, :) = -2.0D0*naturalcoord(1)*inverse(1, :)/det
      gderiv(nn+2, :) = -2.0D0*naturalcoord(2)*inverse(2, :)/det
      gderiv(nn+3, :) = -2.0D0*naturalcoord(3)*inverse(3, :)/det

      wg = getWeight(etype, LX)*det
      B(1:6, 1:(nn+3)*ndof)=0.0D0
      do j = 1, nn+3
        B(1, 3*j-2) = gderiv(j, 1)
        B(2, 3*j-1) = gderiv(j, 2)
        B(3, 3*j  ) = gderiv(j, 3)
        B(4, 3*j-2) = gderiv(j, 2)
        B(4, 3*j-1) = gderiv(j, 1)
        B(5, 3*j-1) = gderiv(j, 3)
        B(5, 3*j  ) = gderiv(j, 2)
        B(6, 3*j-2) = gderiv(j, 3)
        B(6, 3*j  ) = gderiv(j, 1)
      end do

      ! calculate the BL1 matrix ( TOTAL LAGRANGE METHOD )
      if( flag == TOTALLAG ) then
        ! ---dudx(i,j) ==> gdispderiv(i,j)
        gdispderiv(1:ndof,1:ndof) = matmul( unode(1:ndof, 1:nn+3), gderiv(1:nn+3, 1:ndof) )
        do j = 1, nn+3

          B1(1, 3*j-2) = gdispderiv(1, 1)*gderiv(j, 1)
          B1(1, 3*j-1) = gdispderiv(2, 1)*gderiv(j, 1)
          B1(1, 3*j  ) = gdispderiv(3, 1)*gderiv(j, 1)
          B1(2, 3*j-2) = gdispderiv(1, 2)*gderiv(j, 2)
          B1(2, 3*j-1) = gdispderiv(2, 2)*gderiv(j, 2)
          B1(2, 3*j  ) = gdispderiv(3, 2)*gderiv(j, 2)
          B1(3, 3*j-2) = gdispderiv(1, 3)*gderiv(j, 3)
          B1(3, 3*j-1) = gdispderiv(2, 3)*gderiv(j, 3)
          B1(3, 3*j  ) = gdispderiv(3, 3)*gderiv(j, 3)
          B1(4, 3*j-2) = gdispderiv(1, 2)*gderiv(j, 1)+gdispderiv(1, 1)*gderiv(j, 2)
          B1(4, 3*j-1) = gdispderiv(2, 2)*gderiv(j, 1)+gdispderiv(2, 1)*gderiv(j, 2)
          B1(4, 3*j  ) = gdispderiv(3, 2)*gderiv(j, 1)+gdispderiv(3, 1)*gderiv(j, 2)
          B1(5, 3*j-2) = gdispderiv(1, 2)*gderiv(j, 3)+gdispderiv(1, 3)*gderiv(j, 2)
          B1(5, 3*j-1) = gdispderiv(2, 2)*gderiv(j, 3)+gdispderiv(2, 3)*gderiv(j, 2)
          B1(5, 3*j  ) = gdispderiv(3, 2)*gderiv(j, 3)+gdispderiv(3, 3)*gderiv(j, 2)
          B1(6, 3*j-2) = gdispderiv(1, 3)*gderiv(j, 1)+gdispderiv(1, 1)*gderiv(j, 3)
          B1(6, 3*j-1) = gdispderiv(2, 3)*gderiv(j, 1)+gdispderiv(2, 1)*gderiv(j, 3)
          B1(6, 3*j  ) = gdispderiv(3, 3)*gderiv(j, 1)+gdispderiv(3, 1)*gderiv(j, 3)

        end do
        ! ---BL = BL0 + BL1
        do j = 1, (nn+3)*ndof
          B(:, j) = B(:, j)+B1(:, j)
        end do

      end if

      DB(1:6, 1:(nn+3)*ndof) = matmul( D, B(1:6, 1:(nn+3)*ndof) )
      forall( i=1:(nn+3)*ndof, j=1:(nn+3)*ndof )
        tmpstiff(i, j) = tmpstiff(i, j)+dot_product( B(:, i), DB(:, j) )*wg
      end forall

      ! calculate the stress matrix ( TOTAL LAGRANGE METHOD )
      if( flag == TOTALLAG .OR. flag == UPDATELAG ) then
        stress(1:6) = gausses(LX)%stress
        do j = 1, nn+3
          BN(1, 3*j-2) = gderiv(j, 1)
          BN(2, 3*j-1) = gderiv(j, 1)
          BN(3, 3*j  ) = gderiv(j, 1)
          BN(4, 3*j-2) = gderiv(j, 2)
          BN(5, 3*j-1) = gderiv(j, 2)
          BN(6, 3*j  ) = gderiv(j, 2)
          BN(7, 3*j-2) = gderiv(j, 3)
          BN(8, 3*j-1) = gderiv(j, 3)
          BN(9, 3*j  ) = gderiv(j, 3)
        end do
        Smat(:, :) = 0.0D0
        do j = 1, 3
          Smat(j  , j  ) = stress(1)
          Smat(j  , j+3) = stress(4)
          Smat(j  , j+6) = stress(6)
          Smat(j+3, j  ) = stress(4)
          Smat(j+3, j+3) = stress(2)
          Smat(j+3, j+6) = stress(5)
          Smat(j+6, j  ) = stress(6)
          Smat(j+6, j+3) = stress(5)
          Smat(j+6, j+6) = stress(3)
        end do
        SBN(1:9, 1:(nn+3)*ndof) = matmul( Smat(1:9, 1:9), BN(1:9, 1:(nn+3)*ndof) )
        forall( i=1:(nn+3)*ndof, j=1:(nn+3)*ndof )
          tmpstiff(i, j) = tmpstiff(i, j)+dot_product( BN(:, i), SBN(:, j) )*wg
        end forall
      end if

    end do

    ! -----Condense tmpstiff to stiff
    xj(1:9, 1:9)= tmpstiff(nn*ndof+1:(nn+3)*ndof, nn*ndof+1:(nn+3)*ndof)
    call calInverse(9, xj)
    tmpk = matmul( tmpstiff( 1:nn*ndof, nn*ndof+1:(nn+3)*ndof ), xj )
    stiff(1:nn*ndof, 1:nn*ndof) = tmpstiff(1:nn*ndof, 1:nn*ndof)-matmul( tmpk, tmpstiff(nn*ndof+1:(nn+3)*ndof, 1:nn*ndof)  )

  end subroutine STF_C3D8IC

  !> Update strain and stress inside element
  !---------------------------------------------------------------------*
  subroutine UPDATE_C3D8IC                                   &
      (etype,nn,ecoord, u, du, ddu, cdsys_ID, coords, &
      qf, gausses, iter, time, tincr, aux, ddaux, TT, T0, TN )
    !---------------------------------------------------------------------*

    use m_fstr
    use mMaterial
    use mMechGauss
    use m_MatMatrix
    use m_ElastoPlastic
    use m_utilities
    use m_static_LIB_3d

    integer(kind=kint), intent(in)    :: etype         !< \param [in] element type
    integer(kind=kint), intent(in)    :: nn            !< \param [in] number of elemental nodes
    real(kind=kreal), intent(in)      :: ecoord(3, nn) !< \param [in] coordinates of elemental nodes
    real(kind=kreal), intent(in)      :: u(3, nn)      !< \param [in] nodal displacements
    real(kind=kreal), intent(in)      :: du(3, nn)     !< \param [in] increment of nodal displacements
    real(kind=kreal), intent(in)      :: ddu(3, nn)    !< \param [in] correction of nodal displacements
    integer(kind=kint), intent(in)    :: cdsys_ID
    real(kind=kreal), intent(inout)   :: coords(3, 3)  !< variables to define matreial coordinate system
    real(kind=kreal), intent(out)     :: qf(nn*3)      !< \param [out] Internal Force
    type(tGaussStatus), intent(inout) :: gausses(:)    !< \param [out] status of qudrature points
    integer, intent(in)               :: iter
    real(kind=kreal), intent(in)      :: time          !< current time
    real(kind=kreal), intent(in)      :: tincr         !< time increment
    real(kind=kreal), intent(inout)   :: aux(3, 3)     !< \param [in] incompatible dof
    real(kind=kreal), intent(out)     :: ddaux(3, 3)   !< \param [in] increment of incompatible dof
    real(kind=kreal), intent(in), optional :: TT(nn)   !< current temperature
    real(kind=kreal), intent(in), optional :: T0(nn)   !< reference temperature
    real(kind=kreal), intent(in), optional :: TN(nn)   !< reference temperature

    ! LCOAL VARIAVLES
    integer(kind=kint) :: flag
    integer(kind=kint), parameter :: ndof = 3
    real(kind=kreal)   :: D(6,6), B(6,ndof*(nn+3)), B1(6,ndof*(nn+3)), spfunc(nn), ina(1)
    real(kind=kreal)   :: BN(9,ndof*(nn+3)), DB(6, ndof*(nn+3)), stress(6), Smat(9, 9), SBN(9, ndof*(nn+3))
    real(kind=kreal)   :: gderiv(nn+3,3), gderiv0(nn+3,3), gdispderiv(3,3), F(3,3), det, det0, WG, ttc, tt0, ttn
    integer(kind=kint) :: i, j, LX, mtype, serr
    real(kind=kreal)   :: naturalCoord(3), rot(3,3), mat(6,6), EPSTH(6)
    real(kind=kreal)   :: totaldisp(3,nn+3), elem(3,nn), elem1(3,nn), coordsys(3,3), tm(6,6)
    real(kind=kreal)   :: dstrain(6)
    real(kind=kreal)   :: alpo(3)
    logical            :: ierr, matlaniso
    real(kind=kreal)   :: stiff_ad(9, nn*3), stiff_aa(9, 9), qf_a(9)
    real(kind=kreal)   :: xj(9, 9)
    real(kind=kreal)   :: tmpforce(9), tmpdisp(9), tmp_d(nn*3), tmp_a(9)
    real(kind=kreal)   :: jacobian(3, 3), inverse(3, 3), inverse1(3, 3), inverse0(3, 3)

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

    totaldisp(:, 1:nn)      = u(:, :) + du(:, :) - ddu(:, :)
    totaldisp(:, nn+1:nn+3) = aux(:, :)

    ! we suppose the same material type in the element
    flag = gausses(1)%pMaterial%nlgeom_flag
    elem(:, :) = ecoord(:, :)
    if( flag == UPDATELAG ) elem(:, :) = ecoord(:, :)+totaldisp(:, 1:nn)

    ! --- Inverse of Jacobian at elemental center
    naturalcoord(:) = 0.0D0
    call getJacobian(etype, nn, naturalcoord, elem, det, jacobian, inverse)
    inverse(:, :)= inverse(:, :)*det
    ! ---- We now calculate stiff matrix include imcompatible mode
    !    [   Kdd   Kda ]
    !    [   Kad   Kaa ]
    stiff_ad(:, :) = 0.0D0
    stiff_aa(:, :) = 0.0D0
    B1(1:6, 1:(nn+3)*ndof) = 0.0D0
    BN(1:9, 1:(nn+3)*ndof) = 0.0D0

    do LX = 1, NumOfQuadPoints(etype)

      call getQuadPoint(etype, LX, naturalCoord)
      call getGlobalDeriv( etype, nn, naturalcoord, elem, det, gderiv(1:nn, 1:3) )

      if( cdsys_ID > 0 ) then
        call set_localcoordsys( coords, g_LocalCoordSys(cdsys_ID), coordsys(:, :), serr )
        if( serr == -1 ) stop "Fail to setup local coordinate"
        if( serr == -2 ) then
          write(*, *) "WARNING! Cannot setup local coordinate, it is modified automatically"
        end if
      end if

      if( present(tt) ) then
        call getShapeFunc( etype, naturalcoord, spfunc )
        ttc = dot_product( tt, spfunc )
        call MatlMatrix( gausses(LX), D3, D, time, tincr, coordsys, ttc )
      else
        call MatlMatrix( gausses(LX), D3, D, time, tincr, coordsys )
      end if

      if( flag == UPDATELAG ) then
        call GEOMAT_C3( gausses(LX)%stress, mat )
        D(:, :) = D(:, :)-mat
      endif

      ! -- Derivative of shape function of imcompatible mode --
      !     [ -2*a   0,   0   ]
      !     [   0,  -2*b, 0   ]
      !     [   0,   0,  -2*c ]
      ! we don't call getShapeDeriv but use above value directly for computation efficiency
      gderiv(nn+1, :) = -2.0D0*naturalcoord(1)*inverse(1, :)/det
      gderiv(nn+2, :) = -2.0D0*naturalcoord(2)*inverse(2, :)/det
      gderiv(nn+3, :) = -2.0D0*naturalcoord(3)*inverse(3, :)/det

      wg = getWeight(etype, LX)*det
      B(1:6, 1:(nn+3)*ndof)=0.0D0
      do j = 1, nn+3
        B(1, 3*j-2) = gderiv(j, 1)
        B(2, 3*j-1) = gderiv(j, 2)
        B(3, 3*j  ) = gderiv(j, 3)
        B(4, 3*j-2) = gderiv(j, 2)
        B(4, 3*j-1) = gderiv(j, 1)
        B(5, 3*j-1) = gderiv(j, 3)
        B(5, 3*j  ) = gderiv(j, 2)
        B(6, 3*j-2) = gderiv(j, 3)
        B(6, 3*j  ) = gderiv(j, 1)
      end do

      ! calculate the BL1 matrix ( TOTAL LAGRANGE METHOD )
      if( flag == TOTALLAG ) then
        ! ---dudx(i,j) ==> gdispderiv(i,j)
        gdispderiv(1:ndof,1:ndof) = matmul( totaldisp(1:ndof, 1:nn+3), gderiv(1:nn+3, 1:ndof) )
        do j = 1, nn+3

          B1(1, 3*j-2) = gdispderiv(1, 1)*gderiv(j, 1)
          B1(1, 3*j-1) = gdispderiv(2, 1)*gderiv(j, 1)
          B1(1, 3*j  ) = gdispderiv(3, 1)*gderiv(j, 1)
          B1(2, 3*j-2) = gdispderiv(1, 2)*gderiv(j, 2)
          B1(2, 3*j-1) = gdispderiv(2, 2)*gderiv(j, 2)
          B1(2, 3*j  ) = gdispderiv(3, 2)*gderiv(j, 2)
          B1(3, 3*j-2) = gdispderiv(1, 3)*gderiv(j, 3)
          B1(3, 3*j-1) = gdispderiv(2, 3)*gderiv(j, 3)
          B1(3, 3*j  ) = gdispderiv(3, 3)*gderiv(j, 3)
          B1(4, 3*j-2) = gdispderiv(1, 2)*gderiv(j, 1)+gdispderiv(1, 1)*gderiv(j, 2)
          B1(4, 3*j-1) = gdispderiv(2, 2)*gderiv(j, 1)+gdispderiv(2, 1)*gderiv(j, 2)
          B1(4, 3*j  ) = gdispderiv(3, 2)*gderiv(j, 1)+gdispderiv(3, 1)*gderiv(j, 2)
          B1(5, 3*j-2) = gdispderiv(1, 2)*gderiv(j, 3)+gdispderiv(1, 3)*gderiv(j, 2)
          B1(5, 3*j-1) = gdispderiv(2, 2)*gderiv(j, 3)+gdispderiv(2, 3)*gderiv(j, 2)
          B1(5, 3*j  ) = gdispderiv(3, 2)*gderiv(j, 3)+gdispderiv(3, 3)*gderiv(j, 2)
          B1(6, 3*j-2) = gdispderiv(1, 3)*gderiv(j, 1)+gdispderiv(1, 1)*gderiv(j, 3)
          B1(6, 3*j-1) = gdispderiv(2, 3)*gderiv(j, 1)+gdispderiv(2, 1)*gderiv(j, 3)
          B1(6, 3*j  ) = gdispderiv(3, 3)*gderiv(j, 1)+gdispderiv(3, 1)*gderiv(j, 3)

        end do
        ! ---BL = BL0 + BL1
        do j = 1, (nn+3)*ndof
          B(:, j) = B(:, j)+B1(:, j)
        end do

      end if

      DB(1:6, 1:(nn+3)*ndof) = matmul( D, B(1:6, 1:(nn+3)*ndof) )
      forall( i=1:3*ndof, j=1:nn*ndof )
        stiff_ad(i, j) = stiff_ad(i, j)+dot_product( B(:, nn*ndof+i), DB(:, j) )*wg
      end forall
      forall( i=1:3*ndof, j=1:3*ndof )
        stiff_aa(i, j) = stiff_aa(i, j)+dot_product( B(:, nn*ndof+i), DB(:, nn*ndof+j) )*wg
      end forall

      ! calculate the stress matrix ( TOTAL LAGRANGE METHOD )
      if( flag == TOTALLAG .OR. flag == UPDATELAG ) then
        stress(1:6) = gausses(LX)%stress
        do j = 1, nn+3
          BN(1, 3*j-2) = gderiv(j, 1)
          BN(2, 3*j-1) = gderiv(j, 1)
          BN(3, 3*j  ) = gderiv(j, 1)
          BN(4, 3*j-2) = gderiv(j, 2)
          BN(5, 3*j-1) = gderiv(j, 2)
          BN(6, 3*j  ) = gderiv(j, 2)
          BN(7, 3*j-2) = gderiv(j, 3)
          BN(8, 3*j-1) = gderiv(j, 3)
          BN(9, 3*j  ) = gderiv(j, 3)
        end do
        Smat(:, :) = 0.0D0
        do j = 1, 3
          Smat(j  , j  ) = stress(1)
          Smat(j  , j+3) = stress(4)
          Smat(j  , j+6) = stress(6)
          Smat(j+3, j  ) = stress(4)
          Smat(j+3, j+3) = stress(2)
          Smat(j+3, j+6) = stress(5)
          Smat(j+6, j  ) = stress(6)
          Smat(j+6, j+3) = stress(5)
          Smat(j+6, j+6) = stress(3)
        end do
        SBN(1:9, 1:(nn+3)*ndof) = matmul( Smat(1:9, 1:9), BN(1:9, 1:(nn+3)*ndof) )
        forall( i=1:3*ndof, j=1:nn*ndof )
          stiff_ad(i, j) = stiff_ad(i, j)+dot_product( BN(:, nn*ndof+i), SBN(:, j) )*wg
        end forall
        forall( i=1:3*ndof, j=1:3*ndof )
          stiff_aa(i, j) = stiff_aa(i, j)+dot_product( BN(:, nn*ndof+i), SBN(:, nn*ndof+j) )*wg
        end forall
      end if

    end do

    ! -----recover incompatible dof of nodal displacement
    xj(1:3*ndof, 1:3*ndof)= stiff_aa(1:3*ndof, 1:3*ndof)
    call calInverse(3*ndof, xj)
    ! ---  [Kad] * ddu
    do i=1,nn
      tmp_d((i-1)*ndof+1:i*ndof) = ddu(1:ndof, i)
    enddo
    tmpforce(1:3*ndof) = matmul( stiff_ad(1:3*ndof, 1:nn*ndof), tmp_d(1:nn*ndof) )
    ! ---  ddaux = -[Kaa]-1 * ([Kad] * ddu)
    tmp_a(1:3*ndof) = -matmul( xj(1:3*ndof, 1:3*ndof), tmpforce(1:3*ndof) )
    do i=1,3
      ddaux(1:ndof, i) = tmp_a((i-1)*ndof+1:i*ndof)
    enddo

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

    totaldisp(:,1:nn) = u(:,:)+ du(:,:)
    totaldisp(:,nn+1:nn+3) = aux(:,:) + ddaux(:,:)

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

    qf(:) = 0.0D0
    qf_a(:) = 0.0D0

    stiff_ad(:, :) = 0.0D0
    stiff_aa(:, :) = 0.0D0

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

    if( flag == UPDATELAG ) then
      elem(:,:) = (0.5D0*du(:,:)+u(:,:) ) +ecoord(:,:)
      elem1(:,:) = (du(:,:)+u(:,:) ) +ecoord(:,:)
      ! elem = elem1
      totaldisp(:,1:nn) = du(:,:)
      if( iter == 1 ) aux(:,:) = 0.0D0   !--- is this correct???
      totaldisp(:,nn+1:nn+3) = aux(:,:)
    end if

    matlaniso = .FALSE.
    if( present(TT) .and. cdsys_ID > 0 ) then
      ina = TT(1)
      call fetch_TableData( MC_ORTHOEXP, gausses(1)%pMaterial%dict, alpo(:), ierr, ina )
      if( .not. ierr ) matlaniso = .true.
    end if

    ! --- Inverse of Jacobian at elemental center
    naturalcoord(:) = 0.0D0
    call getJacobian(etype, nn, naturalcoord, elem, det, jacobian, inverse)
    inverse(:, :)= inverse(:, :)*det
    if( flag == UPDATELAG ) then
      call getJacobian(etype, nn, naturalcoord, elem1, det, jacobian, inverse1)
      inverse1(:, :)= inverse1(:, :)*det
      call getJacobian(etype, nn, naturalcoord, ecoord, det, jacobian, inverse0)
      inverse0(:, :)= inverse0(:, :)*det !for deformation gradient F
    endif

    do LX = 1, NumOfQuadPoints(etype)

      mtype = gausses(LX)%pMaterial%mtype

      call getQuadPoint( etype, LX, naturalCoord(:) )
      call getGlobalDeriv(etype, nn, naturalcoord, elem, det, gderiv)

      if( cdsys_ID > 0 ) then
        call set_localcoordsys( coords, g_LocalCoordSys(cdsys_ID), coordsys(:,:), serr )
        if( serr == -1 ) stop "Fail to setup local coordinate"
        if( serr == -2 ) then
          write(*, *) "WARNING! Cannot setup local coordinate, it is modified automatically"
        end if
      end if

      ! ========================================================
      ! UPDATE STRAIN and STRESS
      ! ========================================================

      ! Thermal Strain
      EPSTH = 0.0D0
      if( present(tt) .AND. present(t0) ) then
        call getShapeFunc(etype, naturalcoord, spfunc)
        ttc = dot_product(TT, spfunc)
        tt0 = dot_product(T0, spfunc)
        ttn = dot_product(TN, spfunc)
        call Cal_Thermal_expansion_C3( tt0, ttc, gausses(LX)%pMaterial, coordsys, matlaniso, EPSTH )
      end if

      ! -- Derivative of shape function of imcompatible mode --
      !     [ -2*a   0,   0   ]
      !     [   0,  -2*b, 0   ]
      !     [   0,   0,  -2*c ]
      ! we don't call getShapeDeriv but use above value directly for computation efficiency
      gderiv(nn+1, :) = -2.0D0*naturalcoord(1)*inverse(1, :)/det
      gderiv(nn+2, :) = -2.0D0*naturalcoord(2)*inverse(2, :)/det
      gderiv(nn+3, :) = -2.0D0*naturalcoord(3)*inverse(3, :)/det

      ! Small strain
      gdispderiv(1:ndof, 1:ndof) = matmul( totaldisp(1:ndof, 1:nn+3), gderiv(1:nn+3, 1:ndof) )
      dstrain(1) = gdispderiv(1, 1)
      dstrain(2) = gdispderiv(2, 2)
      dstrain(3) = gdispderiv(3, 3)
      dstrain(4) = ( gdispderiv(1, 2)+gdispderiv(2, 1) )
      dstrain(5) = ( gdispderiv(2, 3)+gdispderiv(3, 2) )
      dstrain(6) = ( gdispderiv(3, 1)+gdispderiv(1, 3) )
      dstrain(:) = dstrain(:)-EPSTH(:)   ! allright?

      F(1:3,1:3) = 0.d0; F(1,1)=1.d0; F(2,2)=1.d0; F(3,3)=1.d0; !deformation gradient
      if( flag == INFINITE ) then
        gausses(LX)%strain(1:6) = dstrain(1:6)+EPSTH(:)
        F(1:3,1:3) = F(1:3,1:3) + gdispderiv(1:3,1:3)

      else if( flag == TOTALLAG ) then
        ! Green-Lagrange strain
        dstrain(1) = dstrain(1)+0.5d0*dot_product( gdispderiv(:, 1), gdispderiv(:, 1) )
        dstrain(2) = dstrain(2)+0.5d0*dot_product( gdispderiv(:, 2), gdispderiv(:, 2) )
        dstrain(3) = dstrain(3)+0.5d0*dot_product( gdispderiv(:, 3), gdispderiv(:, 3) )
        dstrain(4) = dstrain(4)+( gdispderiv(1, 1)*gdispderiv(1, 2)                                     &
          +gdispderiv(2, 1)*gdispderiv(2, 2)+gdispderiv(3, 1)*gdispderiv(3, 2) )
        dstrain(5) = dstrain(5)+( gdispderiv(1, 2)*gdispderiv(1, 3)                                     &
          +gdispderiv(2, 2)*gdispderiv(2, 3)+gdispderiv(3, 2)*gdispderiv(3, 3) )
        dstrain(6) = dstrain(6)+( gdispderiv(1, 1)*gdispderiv(1, 3)                                     &
          +gdispderiv(2, 1)*gdispderiv(2, 3)+gdispderiv(3, 1)*gdispderiv(3, 3) )

        gausses(LX)%strain(1:6) = dstrain(1:6)+EPSTH(:)

      else if( flag == UPDATELAG ) then
        !  CALL GEOMAT_C3( gausses(LX)%stress, mat )
        !  D(:, :) = D(:, :)+mat(:, :)
        rot = 0.0D0
        rot(1, 2)= 0.5d0*(gdispderiv(1, 2)-gdispderiv(2, 1) );  rot(2, 1) = -rot(1, 2)
        rot(2, 3)= 0.5d0*(gdispderiv(2, 3)-gdispderiv(3, 2) );  rot(3, 2) = -rot(2, 3)
        rot(1, 3)= 0.5d0*(gdispderiv(1, 3)-gdispderiv(3, 1) );  rot(3, 1) = -rot(1, 3)

        gausses(LX)%strain(1:6) = gausses(LX)%strain_bak(1:6)+ dstrain(1:6)+EPSTH(:)
        call getGlobalDeriv(etype, nn, naturalcoord, ecoord, det0, gderiv0)
        gderiv0(nn+1, :) = -2.0D0*naturalcoord(1)*inverse0(1, :)/det0
        gderiv0(nn+2, :) = -2.0D0*naturalcoord(2)*inverse0(2, :)/det0
        gderiv0(nn+3, :) = -2.0D0*naturalcoord(3)*inverse0(3, :)/det0
        F(1:3,1:3) = F(1:3,1:3) + matmul( u(1:ndof, 1:nn+3)+du(1:ndof, 1:nn+3), gderiv0(1:nn+3, 1:ndof) )

      end if

      ! Update stress
      if( present(tt) .AND. present(t0) ) then
        call Update_Stress3D( flag, gausses(LX), rot, dstrain, F, coordsys, time, tincr, ttc, tt0, ttn )
      else
        call Update_Stress3D( flag, gausses(LX), rot, dstrain, F, coordsys, time, tincr )
      end if

      ! ========================================================
      ! calculate the internal force ( equivalent nodal force )
      ! ========================================================
      ! Small strain
      B(1:6, 1:(nn+3)*ndof) = 0.0D0
      do J=1,nn+3
        B(1,3*j-2) = gderiv(j, 1)
        B(2,3*j-1) = gderiv(j, 2)
        B(3,3*j  ) = gderiv(j, 3)
        B(4,3*j-2) = gderiv(j, 2)
        B(4,3*j-1) = gderiv(j, 1)
        B(5,3*j-1) = gderiv(j, 3)
        B(5,3*j  ) = gderiv(j, 2)
        B(6,3*j-2) = gderiv(j, 3)
        B(6,3*j  ) = gderiv(j, 1)
      end do

      ! calculate the BL1 matrix ( TOTAL LAGRANGE METHOD )
      if( flag == INFINITE ) then

      else if( flag == TOTALLAG ) then

        gdispderiv(1:ndof, 1:ndof) = matmul( totaldisp(1:ndof, 1:nn+3), gderiv(1:nn+3, 1:ndof) )
        B1(1:6, 1:(nn+3)*ndof)=0.0D0
        do j = 1,nn+3
          B1(1, 3*j-2) = gdispderiv(1, 1)*gderiv(j, 1)
          B1(1, 3*j-1) = gdispderiv(2, 1)*gderiv(j, 1)
          B1(1, 3*j  ) = gdispderiv(3, 1)*gderiv(j, 1)
          B1(2, 3*j-2) = gdispderiv(1, 2)*gderiv(j, 2)
          B1(2, 3*j-1) = gdispderiv(2, 2)*gderiv(j, 2)
          B1(2, 3*j  ) = gdispderiv(3, 2)*gderiv(j, 2)
          B1(3, 3*j-2) = gdispderiv(1, 3)*gderiv(j, 3)
          B1(3, 3*j-1) = gdispderiv(2, 3)*gderiv(j, 3)
          B1(3, 3*j  ) = gdispderiv(3, 3)*gderiv(j, 3)
          B1(4, 3*j-2) = gdispderiv(1, 2)*gderiv(j, 1)+gdispderiv(1, 1)*gderiv(j, 2)
          B1(4, 3*j-1) = gdispderiv(2, 2)*gderiv(j, 1)+gdispderiv(2, 1)*gderiv(j, 2)
          B1(4, 3*j  ) = gdispderiv(3, 2)*gderiv(j, 1)+gdispderiv(3, 1)*gderiv(j, 2)
          B1(5, 3*j-2) = gdispderiv(1, 2)*gderiv(j, 3)+gdispderiv(1, 3)*gderiv(j, 2)
          B1(5, 3*j-1) = gdispderiv(2, 2)*gderiv(j, 3)+gdispderiv(2, 3)*gderiv(j, 2)
          B1(5, 3*j  ) = gdispderiv(3, 2)*gderiv(j, 3)+gdispderiv(3, 3)*gderiv(j, 2)
          B1(6, 3*j-2) = gdispderiv(1, 3)*gderiv(j, 1)+gdispderiv(1, 1)*gderiv(j, 3)
          B1(6, 3*j-1) = gdispderiv(2, 3)*gderiv(j, 1)+gdispderiv(2, 1)*gderiv(j, 3)
          B1(6, 3*j  ) = gdispderiv(3, 3)*gderiv(j, 1)+gdispderiv(3, 1)*gderiv(j, 3)
        end do
        ! BL = BL0 + BL1
        do j=1,(nn+3)*ndof
          B(:,j) = B(:,j)+B1(:,j)
        end do

      else if( flag == UPDATELAG ) then

        call getGlobalDeriv(etype, nn, naturalcoord, elem1, det, gderiv(1:nn,1:3))

        ! -- Derivative of shape function of imcompatible mode --
        !     [ -2*a   0,   0   ]
        !     [   0,  -2*b, 0   ]
        !     [   0,   0,  -2*c ]
        ! we don't call getShapeDeriv but use above value directly for computation efficiency
        gderiv(nn+1, :) = -2.0D0*naturalcoord(1)*inverse1(1, :)/det
        gderiv(nn+2, :) = -2.0D0*naturalcoord(2)*inverse1(2, :)/det
        gderiv(nn+3, :) = -2.0D0*naturalcoord(3)*inverse1(3, :)/det

        B(1:6, 1:(nn+3)*ndof) = 0.0D0
        do j = 1, nn+3
          B(1, 3*J-2) = gderiv(j, 1)
          B(2, 3*J-1) = gderiv(j, 2)
          B(3, 3*J  ) = gderiv(j, 3)
          B(4, 3*J-2) = gderiv(j, 2)
          B(4, 3*J-1) = gderiv(j, 1)
          B(5, 3*J-1) = gderiv(j, 3)
          B(5, 3*J  ) = gderiv(j, 2)
          B(6, 3*J-2) = gderiv(j, 3)
          B(6, 3*J  ) = gderiv(j, 1)
        end do

      end if

      WG=getWeight( etype, LX )*DET

      DB(1:6, 1:(nn+3)*ndof) = matmul( D, B(1:6, 1:(nn+3)*ndof) )
      forall( i=1:3*ndof, j=1:nn*ndof )
        stiff_ad(i, j) = stiff_ad(i, j)+dot_product( B(:, nn*ndof+i), DB(:, j) )*wg
      end forall
      forall( i=1:3*ndof, j=1:3*ndof )
        stiff_aa(i, j) = stiff_aa(i, j)+dot_product( B(:, nn*ndof+i), DB(:, nn*ndof+j) )*wg
      end forall

      ! calculate the Internal Force
      qf(1:nn*ndof)                                                          &
        = qf(1:nn*ndof)+matmul( gausses(LX)%stress(1:6), B(1:6,1:nn*ndof) )*WG
      qf_a(1:3*ndof)                                                         &
        = qf_a(1:3*ndof)+matmul( gausses(LX)%stress(1:6), B(1:6,nn*ndof+1:(nn+3)*ndof) )*WG
    end do

    ! condence ( qf - [Kda] * [Kaa]-1 * qf_a )
    xj(1:9, 1:9)= stiff_aa(1:3*ndof, 1:3*ndof)
    call calInverse(9, xj)
    tmpdisp(:) = matmul( xj(:,:), qf_a(:) )
    do i=1,nn*ndof
      qf(i) = qf(i) - dot_product( stiff_ad(:,i), tmpdisp(:) )
    enddo
  end subroutine UPDATE_C3D8IC

  !>  This subroutine calculatess thermal loading
  !----------------------------------------------------------------------*
  subroutine TLOAD_C3D8IC &
      (etype, nn, xx, yy, zz, tt, t0, &
      gausses, VECT, cdsys_ID, coords)
    !----------------------------------------------------------------------*

    use m_fstr
    use mMechGauss
    use m_MatMatrix
    use m_common_struct

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

    integer(kind=kint), parameter     :: ndof=3
    integer(kind=kint), intent(in)    :: etype                   !< element type, not used here
    integer(kind=kint), intent(in)    :: nn                      !< number of element nodes
    real(kind=kreal), intent(in)      :: xx(nn), yy(nn), zz(nn)  !< nodes coordinate of element
    real(kind=kreal), intent(in)      :: tt(nn), t0(nn)          !< current and ref temprature
    type(tGaussStatus), intent(inout) :: gausses(:)              !< info about qudrature points
    real(kind=kreal), intent(out)     :: VECT(nn*ndof)           !< load vector
    integer(kind=kint), intent(in)    :: cdsys_ID
    real(kind=kreal), intent(inout)   :: coords(3, 3)            !< variables to define matreial coordinate system

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

    real(kind=kreal) :: ALP, ALP0
    real(kind=kreal) :: D(6, 6), B(6, ndof*(nn+3)), DB_a(6, ndof*3)
    real(kind=kreal) :: det, wg, ecoord(3, nn)
    integer(kind=kint) :: i, j, IC, serr
    real(kind=kreal) :: EPSTH(6), SGM(6), H(nn), alpo(3), alpo0(3), coordsys(3, 3), xj(9, 9)
    real(kind=kreal) :: naturalcoord(3), gderiv(nn+3, 3)
    real(kind=kreal) :: jacobian(3, 3),inverse(3, 3)
    real(kind=kreal) :: stiff_da(nn*3, 3*3), stiff_aa(3*3, 3*3)
    real(kind=kreal) :: VECT_a(3*3)
    real(kind=kreal) :: icdisp(9)
    real(kind=kreal) :: TEMPC, TEMP0, THERMAL_EPS, tm(6, 6), outa(1), ina(1)
    logical :: ierr, matlaniso

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

    matlaniso = .FALSE.
    if( cdsys_ID > 0 ) then   ! cannot define aniso exapansion when no local coord defined
      ina = TT(1)
      call fetch_TableData( MC_ORTHOEXP, gausses(1)%pMaterial%dict, alpo(:), ierr, ina )
      if( .not. ierr ) matlaniso = .true.
    end if

    ecoord(1, :) = XX(:)
    ecoord(2, :) = YY(:)
    ecoord(3, :) = ZZ(:)
    ! ---- Calculate enhanced displacement at first
    ! --- Inverse of Jacobian at elemental center
    naturalcoord(:) = 0.0D0
    call getJacobian(etype, nn, naturalcoord, ecoord, det, jacobian, inverse)
    inverse(:, :) = inverse(:, :)*det
    ! ---- We now calculate stiff matrix include imcompatible mode
    !    [   Kdd   Kda ]
    !    [   Kad   Kaa ]
    stiff_da(:, :) = 0.0D0
    stiff_aa(:, :) = 0.0D0
    B(1:6, 1:(nn+3)*ndof) = 0.0D0
    VECT(1:nn*ndof) = 0.0D0
    VECT_a(1:3*ndof) = 0.0D0

    do IC = 1, NumOfQuadPoints(etype)

      call getQuadPoint(etype, IC, naturalCoord)
      call getGlobalDeriv( etype, nn, naturalcoord, ecoord, det, gderiv(1:nn, 1:3) )

      if( cdsys_ID > 0 ) then
        call set_localcoordsys( coords, g_LocalCoordSys(cdsys_ID), coordsys(:, :), serr )
        if( serr == -1 ) stop "Fail to setup local coordinate"
        if( serr == -2 ) then
          write(*,*) "WARNING! Cannot setup local coordinate, it is modified automatically"
        end if
      end if

      call getShapeFunc( etype, naturalcoord, H(1:nn) )
      TEMPC = dot_product( H(1:nn), TT(1:nn) )
      TEMP0 = dot_product( H(1:nn), T0(1:nn) )
      call MatlMatrix( gausses(IC), D3, D, 1.d0, 1.0D0, coordsys, TEMPC )

      ! -- Derivative of shape function of imcompatible mode --
      !     [ -2*a   0,   0   ]
      !     [   0,  -2*b, 0   ]
      !     [   0,   0,  -2*c ]
      ! we don't call getShapeDeriv but use above value directly for computation efficiency
      gderiv(nn+1, :) = -2.0D0*naturalcoord(1)*inverse(1, :)/det
      gderiv(nn+2, :) = -2.0D0*naturalcoord(2)*inverse(2, :)/det
      gderiv(nn+3, :) = -2.0D0*naturalcoord(3)*inverse(3, :)/det

      wg = getWeight(etype, IC)*det
      do j = 1, nn+3
        B(1, 3*j-2) = gderiv(j, 1)
        B(2, 3*j-1) = gderiv(j, 2)
        B(3, 3*j  ) = gderiv(j, 3)
        B(4, 3*j-2) = gderiv(j, 2)
        B(4, 3*j-1) = gderiv(j, 1)
        B(5, 3*j-1) = gderiv(j, 3)
        B(5, 3*j  ) = gderiv(j, 2)
        B(6, 3*j-2) = gderiv(j, 3)
        B(6, 3*j  ) = gderiv(j, 1)
      end do

      DB_a(1:6, 1:3*ndof) = matmul( D, B(1:6, nn*ndof+1:(nn+3)*ndof) )
      forall( i=1:nn*ndof, j=1:3*ndof )
        stiff_da(i, j) = stiff_da(i, j) + dot_product( B(1:6, i), DB_a(1:6, j) ) * wg
      end forall
      forall( i=1:3*ndof, j=1:3*ndof )
        stiff_aa(i, j) = stiff_aa(i, j) + dot_product( B(1:6, nn*ndof+i), DB_a(1:6, j) ) * wg
      end forall

      ina(1) = TEMPC
      if( matlaniso ) then
        call fetch_TableData( MC_ORTHOEXP, gausses(IC)%pMaterial%dict, alpo(:), ierr, ina )
        if( ierr ) stop "Fails in fetching orthotropic expansion coefficient!"
      else
        call fetch_TableData( MC_THEMOEXP, gausses(IC)%pMaterial%dict, outa(:), ierr, ina )
        if( ierr ) outa(1) = gausses(IC)%pMaterial%variables(M_EXAPNSION)
        alp = outa(1)
      end if
      ina(1) = TEMP0
      if( matlaniso  ) then
        call fetch_TableData( MC_ORTHOEXP, gausses(IC)%pMaterial%dict, alpo0(:), ierr, ina )
        if( ierr ) stop "Fails in fetching orthotropic expansion coefficient!"
      else
        call fetch_TableData( MC_THEMOEXP, gausses(IC)%pMaterial%dict, outa(:), ierr, ina )
        if( ierr ) outa(1) = gausses(IC)%pMaterial%variables(M_EXAPNSION)
        alp0 = outa(1)
      end if

      !**
      !** THERMAL strain
      !**
      if( matlaniso ) then
        do j = 1, 3
          EPSTH(j) = ALPO(j)*(TEMPC-ref_temp)-alpo0(j)*(TEMP0-ref_temp)
        end do
        EPSTH(4:6) = 0.0D0
        call transformation(coordsys, tm)
        EPSTH(:) = matmul( EPSTH(:), tm  ) ! to global coord
        EPSTH(4:6) = EPSTH(4:6)*2.0D0
      else
        THERMAL_EPS = ALP*(TEMPC-ref_temp)-alp0*(TEMP0-ref_temp)
        EPSTH(1:3) = THERMAL_EPS
        EPSTH(4:6) = 0.0D0
      end if

      !**
      !** SET SGM  {s}=[D]{e}
      !**
      SGM(:) = matmul( D(:, :), EPSTH(:) )

      !**
      !** CALCULATE LOAD {F}=[B]T{e}
      !**
      VECT(1:nn*ndof) = VECT(1:nn*ndof)+matmul( SGM(1:6), B(1:6, 1:nn*ndof) )*wg
      VECT_a(1:3*ndof) = VECT_a(1:3*ndof)+matmul( SGM(1:6), B(1:6, nn*ndof+1:(nn+3)*ndof) )*wg

    end do

    ! --- condense vect
    xj(1:9,1:9)= stiff_aa(1:9, 1:9)
    call calInverse(9, xj)
    ! ---  [Kaa]-1 * fa
    icdisp(1:9) = matmul( xj(:, :), VECT_a(1:3*ndof) )
    ! ---  fd - [Kda] * [Kaa]-1 * fa
    VECT(1:nn*ndof) = VECT(1:nn*ndof) - matmul( stiff_da(1:nn*ndof, 1:3*ndof), icdisp(1:3*ndof) )

  end subroutine TLOAD_C3D8IC

end module m_static_LIB_3dIC


      double complex function F42meF(psq,qsq,s,t)
c--- note: ordering of arguments to function is taken from, e.g.
c---       arXiV:0804.4149v3 (App. B) and not hep-ph/0607139 (Eq. 22)
      implicit none
c      include 'scale.f'
      double precision s,t,psq,qsq
c      double precision den
c      double complex qlI4,qlI3
      double complex Lsm1_2me
c      den=s*t-psq*qsq
c--- note: added a factor of 1/2 here
c      F42meF=
c     . +den*qlI4(0d0,psq,0d0,qsq,s,t,0d0,0d0,0d0,0d0,musq,0)/2d0
c     . -  s*qlI3(0d0,0d0,s,0d0,0d0,0d0,musq,0)
c     . -  t*qlI3(0d0,0d0,t,0d0,0d0,0d0,musq,0)
c     . +psq*qlI3(0d0,0d0,psq,0d0,0d0,0d0,musq,0)
c     . +qsq*qlI3(0d0,0d0,qsq,0d0,0d0,0d0,musq,0)

c--- NOTE: checked on 8/30/09 that Lsm1_2me == (expression above)
      F42meF=Lsm1_2me(s,t,psq,qsq)

      return
      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 Matrix_Count_Row_Int(m,n,Matrix,Count_Row,Num_Once)
C     count number of each row

      implicit none
      integer i,j,m,n
      integer Num_Once
      integer Matrix(m,n),Count_Row(m)
      integer Vector_1(n),Vector_2(n)

      do i=1,m
          Count_Row(i)=1
          Vector_1 = Matrix(i,:)
          do j=1,m
              if(j.ne.i)then
                  Vector_2 = Matrix(j,:)
                  if ((MaxVal(Vector_1-Vector_2).eq.0).and.
     &                (MinVal(Vector_1-Vector_2).eq.0)) then
                      Count_Row(i) = Count_Row(i) + 1
                  end if
              end if
          end do
      end do

      Num_Once =0
      do i=1,m
          if (Count_Row(i).eq.1)then
              Num_Once = Num_Once +1
          end if
      end do

      return
      END SUBROUTINE Matrix_Count_Row_Int


subroutine array_routine(invar, outvar, n)

! Loop over an array instead of multiplying single numbers

integer*8 :: n

real*8, intent(in) :: invar(n)
real*8, intent(out) :: outvar(n)

integer*8 :: i

do i = 1,n

   outvar(i) = 2.0 * invar(i)

end do

end