module invsampling
  use mfft1
  ! use util
  implicit none

  contains

!----------------------------------------------------------------------
! This subroutine distributes particles based on the edges array.
  subroutine pp_inv_sampling_2D(part, npp, fxy, npx, npy, nxv, nyv, edges,&
      &idimp, npmax, idps, ierr, tol, eps, tcheb, tbisc)
    implicit none
    integer, intent(in) :: npx, npy, nxv, nyv, idimp, npmax, idps
    integer, intent(inout) :: npp, ierr
    real, dimension(idimp, npmax), intent(inout) :: part
    real, dimension(nxv, nyv), intent(in) :: fxy
    real, dimension(idps), intent(in) :: edges
    real, intent(in) :: tol, eps
    real, intent(inout) :: tcheb, tbisc

    ! local data
    integer :: kl, kr, npt, k, ly, lyr, joff, nps
    real :: dy
    integer, dimension(1) :: ierr1, iwork1
    double precision, dimension(1) :: sum1, work1
    real, dimension(nyv) :: margy
    real, dimension(npy) :: party
    real, dimension(nxv) :: condx
    real, dimension(npx) :: partx
    double precision :: dnpxy

    nps = npp

    ! marginal distribution in y direction
    margy = (fxy(1, :) + fxy(nxv, :)) * 0.5 + sum(fxy(2:nxv-1, :), 1)
    ! sample margy
    call inv_sampling_1D(margy, party, nyv, npy, tol, eps, tcheb, tbisc, ierr)
    ! error handling
    if (ierr == 1) return

    ! find particle partition on this processor
    kl = minloc(abs(party - edges(1)), 1)
    if (party(kl) <= edges(1)) kl = kl + 1
    kr = minloc(abs(party - edges(2)), 1)
    if (party(kr) > edges(2)) kr = kr - 1
    ! check if particle partition is correct
    ierr = kr - kl
    if (kr < kl) return
    ierr = 0
    ! check if particle overflow will occur
    npt = npp + npx * (kr - kl + 1)
    ! This chunk of code will cause problem if the execution return to the main
    ! program on cerntain processors. Comment out for now.
    ! ierr1(1) = npt
    ! call PPIMAX(ierr1, iwork1, 1)
    ! ierr = ierr1(1)
    ! if (ierr > npmax) return
    ! ierr = 0

    do k = kl, kr
      ! conditional distribution in x direction for a given y
      ly = party(k) + 1
      dy = party(k) - ly + 1
      lyr = ly + 1
      condx = fxy(:, ly) * (1.0 - dy) + fxy(:, lyr) * dy
      ! sample condx
      call inv_sampling_1D(condx, partx, nxv, npx, tol, eps, tcheb, tbisc, ierr)
      ! error handling
      if (ierr == 1) return
      ! store co-ordinates
      joff = npx * (k - kl) + npp
      part(1, joff+1:joff+npx) = partx
      part(2, joff+1:joff+npx) = party(k)
    enddo

    ! update number of particles
    npp = npt
    ! This chunk of code will cause problem if the execution return to the main
    ! program on cerntain processors. Comment out for now.
    ! check if not all particles were distributed
    ! dnpxy = dble(npx) * dble(npy)
    ! sum1(1) = dble(npp - nps)
    ! call PPDSUM(sum1, work1, 1)
    ! dnpxy = sum1(1) - dnpxy
    ! if (dnpxy /= 0.0d0) ierr = -1
    return
  end subroutine

!----------------------------------------------------------------------
! This subroutine distributes particles uniformly across processors.
  ! subroutine pp_inv_sampling_2D(part, npp, fxy, npx, npy, nxv, nyv, kstrt, nvp,&
  !     &idimp, npmax, ierr, tol, eps, tcheb, tbisc)
  !   implicit none
  !   integer, intent(in) :: npx, npy, nxv, nyv, kstrt, nvp, idimp, npmax
  !   integer, intent(inout) :: npp, ierr
  !   real, dimension(idimp, npmax), intent(inout) :: part
  !   real, dimension(nxv, nyv), intent(in) :: fxy
  !   real, intent(in) :: tol, eps
  !   real, intent(inout) :: tcheb, tbisc

  !   ! local data
  !   integer :: mpy, mpys, ks, npt, moff, kk, k, ly, lyr, joff, nps
  !   real :: dy
  !   integer, dimension(1) :: ierr1, iwork1
  !   double precision, dimension(1) :: sum1, work1
  !   real, dimension(nyv) :: margy
  !   real, dimension(npy) :: party
  !   real, dimension(nxv) :: condx
  !   real, dimension(npx) :: partx
  !   double precision :: dnpxy

  !   nps = npp
  !   ! particle distribution constants
  !   ks = kstrt - 1
  !   ! mpy = number of particles per processor in y direction
  !   mpy = (npy - 1) / nvp + 1
  !   mpys = min(mpy, max(0, npy - mpy*ks))
  !   ! check if particle overflow will occur
  !   npt = npp + npx * mpys
  !   ierr1(1) = npt
  !   call PPIMAX(ierr1, iwork1, 1)
  !   ierr = ierr1(1)
  !   if (ierr > npmax) return
  !   ierr = 0

  !   ! marginal distribution in y direction
  !   margy = (fxy(1, :) + fxy(nxv, :)) * 0.5 + sum(fxy(2:nxv-1, :), 1)
  !   ! sample margy
  !   call inv_sampling_1D(margy, party, nyv, npy, tol, eps, tcheb, tbisc, ierr)
  !   ! error handling
  !   if (ierr == 1) return

  !   moff = mpy * ks
  !   do kk = 1, mpys
  !     ! conditional distribution in x direction for a given y
  !     k = moff + kk
  !     ly = party(k) + 1
  !     dy = party(k) - ly + 1
  !     lyr = ly + 1
  !     condx = fxy(:, ly) * (1.0 - dy) + fxy(:, lyr) * dy
  !     ! sample condx
  !     call inv_sampling_1D(condx, partx, nxv, npx, tol, eps, tcheb, tbisc, ierr)
  !     ! error handling
  !     if (ierr == 1) return
  !     ! store co-ordinates
  !     joff = npx * (kk-1) + npp
  !     part(1, joff+1:joff+npx) = partx
  !     part(2, joff+1:joff+npx) = party(k)
  !   enddo

  !   ! update number of particles
  !   npp = npt
  !   ! check if not all particles were distributed
  !   dnpxy = dble(npx) * dble(npy)
  !   sum1(1) = dble(npp - nps)
  !   call PPDSUM(sum1, work1, 1)
  !   dnpxy = sum1(1) - dnpxy
  !   if (dnpxy /= 0.0d0) ierr = -1
  !   return
  ! end subroutine

!----------------------------------------------------------------------
  subroutine inv_sampling_2D(fdata, xsamples, ysamples, nxgrid, nygrid,&
      &nxsample, nysample, tol, eps, tcheb, tbisc, ierr)
    implicit none
    ! fdata: f(x) data on two dimensional grid.
    ! xsamples: position of samples in the x direction; 2D array.
    ! ysamples: position of samples in the y direction; 1D array.
    ! (nxgrid, nygrid): dimension of fdata.
    ! (nxsample, nysample): dimension of xsamples.
    ! nysample: dimension of ysamples.
    ! tol: tolerance in constructing chebyshev coefficients.
    ! eps: error control in bisection method.
    ! tcheb: time spent on calculating chebyshev coefficients.
    ! tbisc: time spent on root-finding with bisection method.
    ! ierr: ierr = 1 success; ierr = 0 failure.
    integer, intent(in) :: nxgrid, nygrid, nxsample, nysample
    real, dimension(nxgrid, nygrid), intent(in) :: fdata
    real, dimension(nxsample, nysample), intent(inout) :: xsamples
    real, dimension(nysample), intent(inout) :: ysamples
    real, intent(in) :: tol, eps
    real, intent(inout) :: tcheb, tbisc
    integer, intent(inout) :: ierr

    ! local data
    real, dimension(nygrid) :: margy
    real, dimension(nxgrid) :: condx
    integer :: j, ly, lyr
    real :: dy

    ! marginal distribution in y
    margy = (fdata(1, :) + fdata(nxgrid, :)) * 0.5 + sum(fdata(2:nxgrid-1, :), 1)
    ! sample margy
    call inv_sampling_1D(margy, ysamples, nygrid, nysample,&
      &tol, eps, tcheb, tbisc, ierr)
    ! error handling
    if (ierr == 1) return

    do j = 1, nysample
      ! conditional distribution in x for a given y
      ly = ysamples(j) + 1
      dy = ysamples(j) - ly + 1
      lyr = ly + 1
      condx = fdata(:, ly) * (1.0 - dy) + fdata(:, lyr) * dy
      ! sample condx
      call inv_sampling_1D(condx, xsamples(:, j), nxgrid, nxsample,&
        &tol, eps, tcheb, tbisc, ierr)
      ! error handling
      if (ierr == 1) return
    enddo
  end subroutine

!----------------------------------------------------------------------
  subroutine inv_sampling_1D(fdata, xsamples, ngrid, nsamples,&
      &tol, eps, tcheb, tbisc, ierr)
    implicit none
    ! fdata: original grid data of f(x).
    ! xsamples: position of samples in the grid coordinate; array.
    ! ngrid: number of original grids.
    ! nsamples: number of samples.
    ! tol: tolerance in constructing chebyshev coefficients.
    ! eps: error control in bisection method.
    ! tcheb: time spent on calculating chebyshev coefficients.
    ! tbisc: time spent on root-finding with bisection method.
    ! ierr: ierr = 1 success; ierr = 0 failure.
    integer, intent(in) :: ngrid, nsamples
    real, dimension(ngrid), intent(in) :: fdata
    real, dimension(nsamples), intent(inout) :: xsamples
    real, intent(in) :: tol, eps
    real, intent(inout) :: tcheb, tbisc
    integer, intent(inout) :: ierr

    ! local data
    real, dimension(ngrid) :: cdfx
    real, dimension(262145) :: coeffx
    integer :: ncutoff
    integer :: j
    real, dimension(nsamples) :: y, xtmp
    integer, dimension(4) :: itime
    double precision :: dtime

    ! cumulative sum
    cdfx = my_cumsum(fdata, ngrid)
    ! normalization
    cdfx = cdfx / cdfx(ngrid)
    ! initialize timer
    call dtimer(dtime, itime, -1)
    ! chebyshev coefficients of cdfx
    call cheb_coeff(cdfx, coeffx, ngrid, ncutoff, tol, ierr)
    ! record time
    call dtimer(dtime, itime, 1)
    tcheb = tcheb + real(dtime)
    ! error handling
    if (ierr == 1) return

    ! initialize timer
    call dtimer(dtime, itime, -1)
    ! inverse transform sampling
    y = (/ ((j - 0.5d0) / real(nsamples), j = 1, nsamples) /)
    xsamples = inv_bisection(coeffx, y, ncutoff, nsamples, eps)
    ! record time
    call dtimer(dtime, itime, 1)
    tbisc = tbisc + real(dtime)

    ! map x back to grid coordinate
    call map_unit_to_grid(xsamples, xtmp, nsamples, ngrid)
    xsamples = xtmp
  end subroutine
!
!
!----------------------------------------------------------------------
  function my_cumsum(pdf, ngrid) result(cdf)
    implicit none
    ! input
    integer, intent(in) :: ngrid
    real, dimension(ngrid), intent(in) :: pdf
    ! output
    real, dimension(ngrid) :: cdf

    ! local data
    integer :: j

    cdf(1) = 0.0
    do j = 2, ngrid
      cdf(j) = cdf(j-1) + (pdf(j-1) + pdf(j)) / 2.0
    enddo
  end function
!
!
!----------------------------------------------------------------------
  function inv_bisection(cdf, y, nc, ny, eps) result(x)
    implicit none
    ! this function finds x = cdf^{-1}(y) using bisection method.
    ! cdf: chebyshev coefficients of cumulative distribution function.
    ! y: random numbers on [0, 1]; array.
    ! nc: effective length of chebyshev coefficients cdf.
    ! ny: number of random numbers y.
    ! eps: error control.
    ! input:
    integer, intent(in) :: nc, ny
    real, dimension(nc), intent(in) :: cdf
    real, dimension(ny), intent(in) :: y
    real, intent(in) :: eps
    ! output:
    real, dimension(ny) :: x

    ! local data
    real, dimension(ny) :: a, b, c, vals, zeros
    logical, dimension(ny) :: I1, I2, I3

    a = -1.0
    b = 1.0
    c = 0.0
    zeros = 0.0

    do while (maxval(abs(b - a), 1) >= eps)
      vals = cheb_clenshaw(c, cdf, ny, nc) - y
      I1 = (vals <= -eps)
      I2 = (vals >= eps)
      I3 = ((.not. I1) .and. (.not. I2))
      a = merge(c, zeros, I1) + merge(a, zeros, I2) + merge(c, zeros, I3)
      b = merge(b, zeros, I1) + merge(c, zeros, I2) + merge(c, zeros, I3)
      c = (a + b) / 2.0
    enddo

    x = c
  end function
!
!
!----------------------------------------------------------------------
  function cheb_clenshaw(x, c, nx, nc) result(sum_cheb)
    implicit none
    ! clenshaw algorithm to perform the sum:
    ! output = c_0 * T_0(x) + c_1 * T_1(x) + ... + c_n * T_n(x).
    ! x: independent variable; array.
    ! c: coefficient of the chebyshev sum.
    ! nx: number of x points to be evaluated.
    ! nc: effective length of chebyshev coefficients.
    ! input
    integer, intent(in) :: nx, nc
    real, dimension(nx), intent(in) :: x
    real, dimension(nc), intent(in) :: c
    ! output
    real, dimension(nx) :: sum_cheb

    ! local data
    real, dimension(nx) :: bk1, bk2, xx, bk
    integer :: k

    bk1 = 0.0
    bk2 = 0.0
    xx = 2.0 * x

    do k = nc, 1, -1
      bk = c(k) + xx * bk1 - bk2
      bk2 = bk1
      bk1 = bk
    enddo

    sum_cheb = bk1 - x * bk2
  end function
!
!
!----------------------------------------------------------------------
  subroutine cheb_coeff(fdata, coeffs, nf, ncutoff, tol, ierr)
    implicit none
    ! fdata: original data of f(x).
    ! coeffs: chebyshev coefficients (c_0, c_1, ..., c_n) of f(x).
    ! f(x) = c_0 * T_0(x) + c_1 * T_1(x) + ... + c_n * T_n(x).
    ! c_k = inverse discrete chebyshev transform of f(x).
    ! ncutoff: the number of non-negligible chebyshev coefficients.
    ! tol: target relative accuracy used in standard chop.
    ! ierr: ierr = 1, construction failed; ierr = 0, construction succeeded.
    integer, intent(in) :: nf
    real, dimension(nf), intent(in) :: fdata
    real, dimension(262145), intent(inout) :: coeffs
    integer, intent(inout) :: ncutoff
    real, intent(in) :: tol
    integer, intent(inout) :: ierr

    ! local data
    integer :: j
    integer :: n
    real, dimension(262145) :: x, mapx

    ! nf = size(fdata, 1)

    do j = 4, 18
      ! n: number of chebyshev points.
      ! the degree of chebyshev polynomial is n-1.
      n = 2**j + 1
      ! chebyshev points.
      call chebpts(x, n)
      ! map chebyshev points to original grid.
      call map_unit_to_grid(x, mapx, n, nf)
      ! evaluate f(x) at chebyshev points.
      call interp1d(mapx, fdata, coeffs, n, nf)
      ! discrete chebyshev transform.
      call DCT(coeffs, n-1, j+1)
      ! truncate negligible chebyshev coefficients.
      call cheb_standardChop(coeffs, n, ncutoff, tol)
      ! ncutoff represents the number of non-negligible chebyshev coefficients.
      ! we are happy if ncutoff < n.
      if (ncutoff < n) exit
    enddo

    if (n == (2**18 + 1)) then
      ierr = 1
    else
      ierr = 0
    endif

    return
  end subroutine
!
!
!----------------------------------------------------------------------
  subroutine chebpts(x, n)
    implicit none
    ! x: chebyshev points to be generated.
    ! n: number of chebyshev points.
    integer, intent(in) :: n
    real, dimension(:), intent(inout) :: x

    ! local data
    integer :: j

    x(:n) = (/ (j - 1, j = 1, n) /)
    x(:n) = cos(x(:n) / real(n - 1) * 3.14159265358979)
  end subroutine
!
!
!----------------------------------------------------------------------
  subroutine map_unit_to_grid(xunit, xgrid, nx, ngrid)
    ! map xunit on [-1, 1] to grid coordinate [0, ngrid-1]
    implicit none
    ! xunit: chebyshev points on the interval [-1, 1].
    ! xgrid: points on the grid coordinate [0, ngrid-1].
    ! nx: number of data points.
    ! ngrid: number of original grids of f(x).
    integer, intent(in) :: nx, ngrid
    real, dimension(nx), intent(in) :: xunit
    real, dimension(ngrid), intent(inout) :: xgrid

    xgrid(:nx) = (xunit(:nx) + 1.0) / 2.0 * real(ngrid - 1)
  end subroutine
!
!
!----------------------------------------------------------------------
  subroutine map_grid_to_unit(xgrid, xunit, ngrid)
    ! map xgrid on grid coordinate [0, ngrid-1] to [-1, 1].
    implicit none
    ! xgrid: points on the grid coordinate [0, ngrid-1].
    ! xunit: points on the unit interval [-1, 1].
    ! ngrid: number of original grids.
    integer, intent(in) :: ngrid
    real, dimension(ngrid), intent(in) :: xgrid
    real, dimension(ngrid), intent(inout) :: xunit

    xunit = xgrid / real(ngrid - 1) * 2.0 - 1.0
  end subroutine
!
!
!----------------------------------------------------------------------
  subroutine interp1d(xa, fx, fxa, n, ngrid)
    implicit none
    ! xa: abscissa values for output.
    ! fx: function values at original grids.
    ! fxa: function values at xa.
    ! n: number of chebyshev points.
    ! ngrid: number of original grids of f(x).
    integer, intent(in) :: n, ngrid
    real, dimension(n), intent(in) :: xa
    real, dimension(ngrid), intent(in) :: fx
    real, dimension(n), intent(inout) :: fxa

    ! local data
    integer :: j
    integer :: lx, lxr
    real :: dx
    real, dimension(ngrid+1) :: fx1

    ! special case: xa = ngrid - 1. lxr exceeds ngrid.
    fx1(1:ngrid) = fx
    fx1(ngrid+1) = 0.0

    do j = 1, n
      lx = xa(j) + 1
      dx = xa(j) - lx + 1
      lxr = lx + 1
      fxa(j) = fx1(lx) * (1.0 - dx) + fx1(lxr) * dx
    enddo
  end subroutine
!
!
!----------------------------------------------------------------------
  subroutine DCT(fx, n, indx)
    implicit none
    ! fx input: f(x) evaluated at the chebyshev points.
    ! fx output: chebyshev coefficients.
    ! n: degree of chebyshev polynomials.
    ! n + 1: number of chebyshev points.
    ! indx: 2**indx = 2*n ---> indx = log2(n) + 1
    integer, intent(in) :: n, indx
    real, dimension(n+1), intent(inout) :: fx

    ! local data
    real, dimension(2*n) :: fxx
    integer, dimension(n) :: mixup
    complex, dimension(n) :: sct
    integer :: isign
    ! Note: tfft will not be returned to the higher level subroutine
    ! because we use a separate timer in the higher level.
    ! keep tfft for compatibility with the mfft1 module.
    real :: tfft = 0.0

    ! extend fx from [0, 1, ..., n] to [0, 1, ..., 2n-1]
    fxx(:(n+1)) = fx(:(n+1))
    fxx((n+2):) = fx(n:2:-1)

    ! prepare fft tables: update mixup, sct.
    call mfft1_init(mixup, sct, indx)
    ! inverse FFT
    isign = -1
    call mfft1r(fxx, isign, mixup, sct, tfft, indx)
    ! take real part of the coefficients
    ! and scale the interior points: modes [1, 2, 3, ..., n-1].
    ! mode 0.
    fx(1) = fxx(1)
    ! mode n.
    fx(n+1) = fxx(2)
    ! modes [1, 2, 3, ..., n-1].
    fx(2:n) = 2.0 * fxx(3::2)
  end subroutine
!
!
!----------------------------------------------------------------------
  subroutine cheb_standardChop(coeffs, n, ncutoff, tol)
    implicit none
    ! This subroutine is a direct translation of standardChop in
    ! the Chebfun software system.
    ! coeffs: chebyshev coefficients.
    ! n: number of input chebyshev coefficients.
    ! ncutoff: number of output chebyshev coefficients.
    integer, intent(in) :: n
    real, dimension(n), intent(in) :: coeffs
    integer, intent(inout) :: ncutoff
    real, intent(in) :: tol

    ! local data
    real, dimension(n) :: b, m, envelope
    integer :: j
    integer :: plateauPoint, j2
    real :: e1, e2, r
    logical :: plateau
    integer :: j3, d
    real, dimension(:), allocatable :: cc

    ncutoff = n

    ! step 1: convert coeffs to a nonincreasing envelope normalized
    ! to begin with value 1.
    b = abs(coeffs(:n))
    m = b(n)
    do j = n-1, 1, -1
      m(j) = max(b(j), m(j+1))
    enddo
    if (m(1) == 0) then
      ncutoff = 1
      return
    endif
    envelope = m / m(1)

    ! step 2: find a plateauPoint, if any.
    plateauPoint = n
    j2 = n
    do j = 2, n
      j2 = nint(1.25 * j + 5)
      if (j2 > n) return
      e1 = envelope(j)
      e2 = envelope(j2)
      r = 3.0 * (1.0 - log(e1) / log(tol))
      plateau = (e1 == 0) .or. (e2 / e1 > r)
      if (plateau) then
        plateauPoint = j - 1
        exit
      endif
    enddo

    ! step 3
    if (envelope(plateauPoint) == 0) then
      ncutoff = plateauPoint
    else
      j3 = count(envelope >= tol**(7.0/6.0))
      if (j3 < j2) then
        j2 = j3 + 1
        envelope(j2) = tol**(7.0/6.0)
      endif
      allocate(cc(j2))
      cc = log10(envelope(:j2))
      ! cc = cc + linspace(0.0, (-1.0/3.0) * log10(tol), j2)
      cc = cc + (/ (-1.0/3.0*log10(tol) * (j - 1) / real(j2 - 1), j = 1, j2) /)
      d = minloc(cc, 1)
      ncutoff = max(d - 1, 1)
    endif
  end subroutine
!
end module


      SUBROUTINE CLAKF2( M, N, A, LDA, B, D, E, Z, LDZ )
*
*  -- LAPACK test routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            LDA, LDZ, M, N
*     ..
*     .. Array Arguments ..
      COMPLEX            A( LDA, * ), B( LDA, * ), D( LDA, * ),
     $                   E( LDA, * ), Z( LDZ, * )
*     ..
*
*  Purpose
*  =======
*
*  Form the 2*M*N by 2*M*N matrix
*
*         Z = [ kron(In, A)  -kron(B', Im) ]
*             [ kron(In, D)  -kron(E', Im) ],
*
*  where In is the identity matrix of size n and X' is the transpose
*  of X. kron(X, Y) is the Kronecker product between the matrices X
*  and Y.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          Size of matrix, must be >= 1.
*
*  N       (input) INTEGER
*          Size of matrix, must be >= 1.
*
*  A       (input) COMPLEX, dimension ( LDA, M )
*          The matrix A in the output matrix Z.
*
*  LDA     (input) INTEGER
*          The leading dimension of A, B, D, and E. ( LDA >= M+N )
*
*  B       (input) COMPLEX, dimension ( LDA, N )
*  D       (input) COMPLEX, dimension ( LDA, M )
*  E       (input) COMPLEX, dimension ( LDA, N )
*          The matrices used in forming the output matrix Z.
*
*  Z       (output) COMPLEX, dimension ( LDZ, 2*M*N )
*          The resultant Kronecker M*N*2 by M*N*2 matrix (see above.)
*
*  LDZ     (input) INTEGER
*          The leading dimension of Z. ( LDZ >= 2*M*N )
*
*  ====================================================================
*
*     .. Parameters ..
      COMPLEX            ZERO
      PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ) )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IK, J, JK, L, MN, MN2
*     ..
*     .. External Subroutines ..
      EXTERNAL           CLASET
*     ..
*     .. Executable Statements ..
*
*     Initialize Z
*
      MN = M*N
      MN2 = 2*MN
      CALL CLASET( 'Full', MN2, MN2, ZERO, ZERO, Z, LDZ )
*
      IK = 1
      DO 50 L = 1, N
*
*        form kron(In, A)
*
         DO 20 I = 1, M
            DO 10 J = 1, M
               Z( IK+I-1, IK+J-1 ) = A( I, J )
   10       CONTINUE
   20    CONTINUE
*
*        form kron(In, D)
*
         DO 40 I = 1, M
            DO 30 J = 1, M
               Z( IK+MN+I-1, IK+J-1 ) = D( I, J )
   30       CONTINUE
   40    CONTINUE
*
         IK = IK + M
   50 CONTINUE
*
      IK = 1
      DO 90 L = 1, N
         JK = MN + 1
*
         DO 80 J = 1, N
*
*           form -kron(B', Im)
*
            DO 60 I = 1, M
               Z( IK+I-1, JK+I-1 ) = -B( J, L )
   60       CONTINUE
*
*           form -kron(E', Im)
*
            DO 70 I = 1, M
               Z( IK+MN+I-1, JK+I-1 ) = -E( J, L )
   70       CONTINUE
*
            JK = JK + M
   80    CONTINUE
*
         IK = IK + M
   90 CONTINUE
*
      RETURN
*
*     End of CLAKF2
*
      END


!
! This file is released under terms of BSD license
! See LICENSE file for more information
!
! Test the OMNI Compiler kind specifier
!

PROGRAM constant_kind
  USE mo_column
  REAL(KIND=dp) :: a
  REAL(KIND=sp) :: b
  REAL(KIND=dp) :: c

  a = 10.0_dp
  b = 8.0_sp
  c = a + b + 15.0_sp

END PROGRAM constant_kind


  !============================================================================!
    subroutine Multiphase_Mod_Vof_Momentum_Contribution(mult, i, b)
  !----------------------------------------------------------------------------!
  !   Computes Surface tension and Gravity sources for Momentum Equation if    !
  !   a two-phase flow calculation is performed.                               !
  !----------------------------------------------------------------------------!
    implicit none
  !---------------------------------[Arguments]--------------------------------!
    type(Multiphase_Type), target :: mult
    real,                  target :: b(:)
    integer                       :: i
  !-----------------------------------[Locals]---------------------------------!
    type(Field_Type), pointer :: flow
    type(Grid_Type),  pointer :: grid
    type(Var_Type),   pointer :: vof
    integer                   :: s, c, c1, c2
    real                      :: dotprod, epsloc
    real,             pointer :: si(:), sj(:), sk(:)
    real                      :: corr_x, corr_y, corr_z
  !============================================================================!

    ! Take aliases
    flow   => mult % pnt_flow
    grid   => mult % pnt_grid
    vof    => mult % vof
    si     => grid % sx
    sj     => grid % sy
    sk     => grid % sz

    epsloc = epsilon(epsloc)

    ! Surface tension contribution
    if (mult % surface_tension > TINY) then

      select case(i)
        case(1)
          do c = 1, grid % n_cells
            b(c) = b(c) + mult % surface_tension * mult % curv(c)     &
                                                 * vof % x(c)         &
                                                 * grid % vol(c)
          end do
        case(2)
          do c = 1, grid % n_cells
            b(c) = b(c) + mult % surface_tension * mult % curv(c)     &
                                                 * vof % y(c)         &
                                                 * grid % vol(c)
          end do
        case(3)
          do c = 1, grid % n_cells
            b(c) = b(c) + mult % surface_tension * mult % curv(c)     &
                                                 * vof % z(c)         &
                                                 * grid % vol(c)
          end do

      end select

    end if

    ! Body force contribution (gravity)
    if(sqrt(grav_x ** 2 + grav_y ** 2 + grav_z ** 2) >= TINY) then

      select case(i)

        case(1)

          if( .not. allocated(mult % body_fx)) then
            allocate(mult % body_fx(-grid % n_bnd_cells:grid % n_cells))
            allocate(mult % body_fy(-grid % n_bnd_cells:grid % n_cells))
            allocate(mult % body_fz(-grid % n_bnd_cells:grid % n_cells))
          end if

          mult % body_fx = 0.0; mult % body_fy = 0.0; mult % body_fz = 0.0

          do s = 1, grid % n_faces
            c1 = grid % faces_c(1,s)
            c2 = grid % faces_c(2,s)

            dotprod = ( (grid % xf(s) - grid % xc(c1)) * grav_x  &
                      + (grid % yf(s) - grid % yc(c1)) * grav_y  &
                      + (grid % zf(s) - grid % zc(c1)) * grav_z )

            mult % body_fx(c1) = mult % body_fx(c1)                      &
                               + flow % density_f(s) * si(s) * dotprod
            mult % body_fy(c1) = mult % body_fy(c1)                      &
                               + flow % density_f(s) * sj(s) * dotprod
            mult % body_fz(c1) = mult % body_fz(c1)                      &
                               + flow % density_f(s) * sk(s) * dotprod

            if (c2 > 0) then
              ! Correction for periodic faces:
              call Grid_Mod_Correction_Periodicity(grid, s,   &
                                                   corr_x, corr_y, corr_z)

              dotprod = ( (( grid % xf(s) + corr_x)      &
                           - grid % xc(c2)) * grav_x     &
                        + (( grid % yf(s) + corr_y)      &
                           - grid % yc(c2)) * grav_y     &
                        + (( grid % zf(s) + corr_z)      &
                           - grid % zc(c2)) * grav_z )

              mult % body_fx(c2) = mult % body_fx(c2)                      &
                                 - flow % density_f(s) * si(s) * dotprod
              mult % body_fy(c2) = mult % body_fy(c2)                      &
                                 - flow % density_f(s) * sj(s) * dotprod
              mult % body_fz(c2) = mult % body_fz(c2)                      &
                                 - flow % density_f(s) * sk(s) * dotprod

            end if
          end do

        call Grid_Mod_Exchange_Cells_Real(grid, mult % body_fx)
        call Grid_Mod_Exchange_Cells_Real(grid, mult % body_fy)
        call Grid_Mod_Exchange_Cells_Real(grid, mult % body_fz)

        do c = 1, grid % n_cells
          b(c) = b(c) + mult % body_fx(c)
        end do

      case(2)

        do c = 1, grid % n_cells
          b(c) = b(c) + mult % body_fy(c)
        end do

      case(3)

        do c = 1, grid % n_cells
          b(c) = b(c) + mult % body_fz(c)
        end do

    end select

  end if

  end subroutine


function PorosCoeff(NodeNum,Temp,Pres,ToDrain)
!***********************************************************************
! Copyright 2011 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!function PorosCoeff(NodeNum,Temp,Pres,ToDrain) result(Answer)
! Input:node number, temperature (C), pressure(MPa), increase in
!       pressure over last timestep, initial and current porosity,
!       and whether to allow for collapse after fluid drainage (1
!       for yes and 0 for no)
! Output: factor by which to increase the porosity due to the
!         melting of ice and drainage (result will be < 1)

use comdi, only: MaxDrainPart,InitPoros,InitPres
implicit none
real*8 Answer,VolumeRatio,TLower,TUpper,RelRampPos,Temp,PhasePart,   &
   DrainFormula,Pres,DrainCoeff,PorosCoeff
! RefPres is the pressure at which the porosity reaches a minimum
! when drainage is turned on; MinPoros is the minimum allowed
! porosity
real*8, parameter :: RefPres = 0.1D0, MinPoros = 0.3
integer :: ToDrain,NodeNum,DrainFlag

! liquid H2O to ice volume ratio
VolumeRatio = 0.9

! lower and upper bounds of the phase change ramp
Tlower = -0.25
Tupper =  0.25

! fraction of distance up ramp relative to Tlower
RelRampPos = (Temp-Tlower)/(Tupper-Tlower)
if (RelRampPos > 1.0) then
   RelRampPos = 1.0
elseif (RelRampPos < 0.0) then
   RelRampPos = 0.0
end if

if ((InitPres(NodeNum)-RefPres).ne.0.0) then
   DrainFormula = MinPoros + &
      (VolumeRatio*InitPoros(NodeNum) - MinPoros)* &
      (Pres-RefPres)/(InitPres(NodeNum)-RefPres)
else
   DrainFormula = VolumeRatio*InitPoros(NodeNum)
end if

PorosCoeff = (1.0-RelRampPos) + &
         RelRampPos*DrainFormula/InitPoros(NodeNum)
! for analytic solution only!
!Answer = (MinPoros + 3.0*(Pres-RefPres))/0.6
end


 module localblocks
   use precisions
   implicit none
!---------------------FOR BLOCK LANCZOS ROUTINE------------------------------
! dimblock: is used to keep track of the size of our blocks of lanczos vectors
! nvec: serves as our main index through row space of block_1, and block_2
! block_1, block_2: analog of vec1 and vec2 in standard lanczos
! We define  block_1(dimblock, v1s:v1e) and block2(dimblock, v2s:v2e)

! RMZ - 8/18

integer :: dimblock !number of vectors in the columnspace of a block
integer :: block_flag ! used for lanczos_p to switch over to block lanczos routine
integer :: dimlanc ! dim of lanczos matrix
character :: piv_flag
real(kind=lanc_prec), allocatable, target :: block_1(:,:), block_2(:,:) !block* is taken by fortran intrinsic
! ADDED  BY CWJ IN 7.8.8, 11/2018 to allow reduction after Hmult
! block_i(ivec,istate) = blockvec_i( ivec + (istate-1)*dimblock)
! allocate blockvec_1(1+dimblock*(v1s-1):dimblock*v1e), etc
!
real(kind=lanc_prec), allocatable, target :: blockvec_1(:),blockvec_2(:)

! VARIABLES FOR BLOCK STRENGTH FUNCTIONS -- added 7.9.4 ----

integer, allocatable :: pivot_choice(:)
real(kind=8), allocatable :: dnormblock(:)
end module localblocks


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2018 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine shape26h(xi,et,ze,xl,xsj,shp,iflag,konl)
!
!     shape functions and derivatives for a 26-node quadratic
!     isoparametric brick element. -1<=xi,et,ze<=1
!
!     iflag=1: calculate only the value of the shape functions
!     iflag=2: calculate the value of the shape functions and
!              the Jacobian determinant
!     iflag=3: calculate the value of the shape functions, the
!              value of their derivatives w.r.t. the global
!              coordinates and the Jacobian determinant
!
      implicit none
!
      integer i,j,k,iflag,konl(26),jf(3,6),ifaceq(8,6)
!
      real*8 shp(4,26),xs(3,3),xsi(3,3),xl(3,26),shpe(4,26),dd,
     &  dd1,dd2,dd3,xi,et,ze,xsj,omg,omh,omr,opg,oph,opr,
     &  tpgphpr,tmgphpr,tmgmhpr,tpgmhpr,tpgphmr,tmgphmr,tmgmhmr,tpgmhmr,
     &  omgopg,omhoph,omropr,omgmopg,omhmoph,omrmopr,fxi(3),fet(3),
     &  fze(3),dfxi(3),dfet(3),dfze(3)
!
      intent(in) xi,et,ze,xl,iflag,konl
!
      intent(out) shp,xsj
!
      jf=reshape((/2,2,1,2,2,3,2,1,2,3,2,2,2,3,2,1,2,2/),(/3,6/))
!
      ifaceq=reshape(( /4,3,2,1,11,10,9,12,
     &                  5,6,7,8,13,14,15,16,
     &                  1,2,6,5,9,18,13,17,
     &                  2,3,7,6,10,19,14,18,
     &                  3,4,8,7,11,20,15,19,
     &                  4,1,5,8,12,17,16,20/),(/8,6/))
!
!     shape functions in one dimension
!
      fxi(1)=xi*(xi-1.d0)/2.d0
      fxi(2)=(1.d0-xi)*(1.d0+xi)
      fxi(3)=xi*(xi+1.d0)/2.d0
!
      fet(1)=et*(et-1.d0)/2.d0
      fet(2)=(1.d0-et)*(1.d0+et)
      fet(3)=et*(et+1.d0)/2.d0
!
      fze(1)=ze*(ze-1.d0)/2.d0
      fze(2)=(1.d0-ze)*(1.d0+ze)
      fze(3)=ze*(ze+1.d0)/2.d0
!
!     shape functions and their glocal derivatives
!
      omg=1.d0-xi
      omh=1.d0-et
      omr=1.d0-ze
      opg=1.d0+xi
      oph=1.d0+et
      opr=1.d0+ze
      tpgphpr=opg+oph+ze
      tmgphpr=omg+oph+ze
      tmgmhpr=omg+omh+ze
      tpgmhpr=opg+omh+ze
      tpgphmr=opg+oph-ze
      tmgphmr=omg+oph-ze
      tmgmhmr=omg+omh-ze
      tpgmhmr=opg+omh-ze
      omgopg=omg*opg/4.d0
      omhoph=omh*oph/4.d0
      omropr=omr*opr/4.d0
      omgmopg=(omg-opg)/4.d0
      omhmoph=(omh-oph)/4.d0
      omrmopr=(omr-opr)/4.d0
!
!     shape functions
!
      shp(4, 1)=-omg*omh*omr*tpgphpr/8.d0
      shp(4, 2)=-opg*omh*omr*tmgphpr/8.d0
      shp(4, 3)=-opg*oph*omr*tmgmhpr/8.d0
      shp(4, 4)=-omg*oph*omr*tpgmhpr/8.d0
      shp(4, 5)=-omg*omh*opr*tpgphmr/8.d0
      shp(4, 6)=-opg*omh*opr*tmgphmr/8.d0
      shp(4, 7)=-opg*oph*opr*tmgmhmr/8.d0
      shp(4, 8)=-omg*oph*opr*tpgmhmr/8.d0
      shp(4, 9)=omgopg*omh*omr
      shp(4,10)=omhoph*opg*omr
      shp(4,11)=omgopg*oph*omr
      shp(4,12)=omhoph*omg*omr
      shp(4,13)=omgopg*omh*opr
      shp(4,14)=omhoph*opg*opr
      shp(4,15)=omgopg*oph*opr
      shp(4,16)=omhoph*omg*opr
      shp(4,17)=omropr*omg*omh
      shp(4,18)=omropr*opg*omh
      shp(4,19)=omropr*opg*oph
      shp(4,20)=omropr*omg*oph
!
!     correction for the extra nodes in the middle of the faces
!
      do i=1,6
         if(konl(20+i).eq.konl(20)) then
!
!           no extra node in this face
!
            shp(4,20+i)=0.d0
         else
            shp(4,20+i)=fxi(jf(1,i))*fet(jf(2,i))*fze(jf(3,i))
            do j=1,4
               shp(4,ifaceq(j,i))=shp(4,ifaceq(j,i))+shp(4,20+i)/4.d0
            enddo
            do j=5,8
               shp(4,ifaceq(j,i))=shp(4,ifaceq(j,i))-shp(4,20+i)/2.d0
            enddo
         endif
      enddo
!
      if(iflag.eq.1) return
!
!     derivative of the shape functions in one dimension
!
      dfxi(1)=(2.d0*xi-1.d0)/2.d0
      dfxi(2)=-2.d0*xi
      dfxi(3)=(2.d0*xi+1.d0)/2.d0
!
      dfet(1)=(2.d0*et-1.d0)/2.d0
      dfet(2)=-2.d0*et
      dfet(3)=(2.d0*et+1.d0)/2.d0
!
      dfze(1)=(2.d0*ze-1.d0)/2.d0
      dfze(2)=-2.d0*ze
      dfze(3)=(2.d0*ze+1.d0)/2.d0
!
!     local derivatives of the shape functions: xi-derivative
!
      shpe(1, 1)=omh*omr*(tpgphpr-omg)/8.d0
      shpe(1, 2)=(opg-tmgphpr)*omh*omr/8.d0
      shpe(1, 3)=(opg-tmgmhpr)*oph*omr/8.d0
      shpe(1, 4)=oph*omr*(tpgmhpr-omg)/8.d0
      shpe(1, 5)=omh*opr*(tpgphmr-omg)/8.d0
      shpe(1, 6)=(opg-tmgphmr)*omh*opr/8.d0
      shpe(1, 7)=(opg-tmgmhmr)*oph*opr/8.d0
      shpe(1, 8)=oph*opr*(tpgmhmr-omg)/8.d0
      shpe(1, 9)=omgmopg*omh*omr
      shpe(1,10)=omhoph*omr
      shpe(1,11)=omgmopg*oph*omr
      shpe(1,12)=-omhoph*omr
      shpe(1,13)=omgmopg*omh*opr
      shpe(1,14)=omhoph*opr
      shpe(1,15)=omgmopg*oph*opr
      shpe(1,16)=-omhoph*opr
      shpe(1,17)=-omropr*omh
      shpe(1,18)=omropr*omh
      shpe(1,19)=omropr*oph
      shpe(1,20)=-omropr*oph
!
!     correction for the extra nodes in the middle of the faces
!
      do i=1,6
         if(konl(20+i).eq.konl(20)) then
!
!           no extra node in this face
!
            shpe(1,20+i)=0.d0
         else
            shpe(1,20+i)=dfxi(jf(1,i))*fet(jf(2,i))*fze(jf(3,i))
            do j=1,4
               shpe(1,ifaceq(j,i))=shpe(1,ifaceq(j,i))+shpe(1,20+i)/4.d0
            enddo
            do j=5,8
               shpe(1,ifaceq(j,i))=shpe(1,ifaceq(j,i))-shpe(1,20+i)/2.d0
            enddo
         endif
      enddo
!
!     local derivatives of the shape functions: eta-derivative
!
      shpe(2, 1)=omg*omr*(tpgphpr-omh)/8.d0
      shpe(2, 2)=opg*omr*(tmgphpr-omh)/8.d0
      shpe(2, 3)=opg*(oph-tmgmhpr)*omr/8.d0
      shpe(2, 4)=omg*(oph-tpgmhpr)*omr/8.d0
      shpe(2, 5)=omg*opr*(tpgphmr-omh)/8.d0
      shpe(2, 6)=opg*opr*(tmgphmr-omh)/8.d0
      shpe(2, 7)=opg*(oph-tmgmhmr)*opr/8.d0
      shpe(2, 8)=omg*(oph-tpgmhmr)*opr/8.d0
      shpe(2, 9)=-omgopg*omr
      shpe(2,10)=omhmoph*opg*omr
      shpe(2,11)=omgopg*omr
      shpe(2,12)=omhmoph*omg*omr
      shpe(2,13)=-omgopg*opr
      shpe(2,14)=omhmoph*opg*opr
      shpe(2,15)=omgopg*opr
      shpe(2,16)=omhmoph*omg*opr
      shpe(2,17)=-omropr*omg
      shpe(2,18)=-omropr*opg
      shpe(2,19)=omropr*opg
      shpe(2,20)=omropr*omg
!
!     correction for the extra nodes in the middle of the faces
!
      do i=1,6
         if(konl(20+i).eq.konl(20)) then
!
!           no extra node in this face
!
            shpe(2,20+i)=0.d0
         else
            shpe(2,20+i)=fxi(jf(1,i))*dfet(jf(2,i))*fze(jf(3,i))
            do j=1,4
               shpe(2,ifaceq(j,i))=shpe(2,ifaceq(j,i))+shpe(2,20+i)/4.d0
            enddo
            do j=5,8
               shpe(2,ifaceq(j,i))=shpe(2,ifaceq(j,i))-shpe(2,20+i)/2.d0
            enddo
         endif
      enddo
!
!     local derivatives of the shape functions: zeta-derivative
!
      shpe(3, 1)=omg*omh*(tpgphpr-omr)/8.d0
      shpe(3, 2)=opg*omh*(tmgphpr-omr)/8.d0
      shpe(3, 3)=opg*oph*(tmgmhpr-omr)/8.d0
      shpe(3, 4)=omg*oph*(tpgmhpr-omr)/8.d0
      shpe(3, 5)=omg*omh*(opr-tpgphmr)/8.d0
      shpe(3, 6)=opg*omh*(opr-tmgphmr)/8.d0
      shpe(3, 7)=opg*oph*(opr-tmgmhmr)/8.d0
      shpe(3, 8)=omg*oph*(opr-tpgmhmr)/8.d0
      shpe(3, 9)=-omgopg*omh
      shpe(3,10)=-omhoph*opg
      shpe(3,11)=-omgopg*oph
      shpe(3,12)=-omhoph*omg
      shpe(3,13)=omgopg*omh
      shpe(3,14)=omhoph*opg
      shpe(3,15)=omgopg*oph
      shpe(3,16)=omhoph*omg
      shpe(3,17)=omrmopr*omg*omh
      shpe(3,18)=omrmopr*opg*omh
      shpe(3,19)=omrmopr*opg*oph
      shpe(3,20)=omrmopr*omg*oph
!
!     correction for the extra nodes in the middle of the faces
!
      do i=1,6
         if(konl(20+i).eq.konl(20)) then
!
!           no extra node in this face
!
            shpe(3,20+i)=0.d0
         else
            shpe(3,20+i)=fxi(jf(1,i))*fet(jf(2,i))*dfze(jf(3,i))
            do j=1,4
               shpe(3,ifaceq(j,i))=shpe(3,ifaceq(j,i))+shpe(3,20+i)/4.d0
            enddo
            do j=5,8
               shpe(3,ifaceq(j,i))=shpe(3,ifaceq(j,i))-shpe(3,20+i)/2.d0
            enddo
         endif
      enddo
!
!     computation of the local derivative of the global coordinates
!     (xs)
!
      do i=1,3
        do j=1,3
          xs(i,j)=0.d0
          do k=1,26
            xs(i,j)=xs(i,j)+xl(i,k)*shpe(j,k)
          enddo
        enddo
      enddo
!
!     computation of the jacobian determinant
!
      dd1=xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2)
      dd2=xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3)
      dd3=xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1)
      xsj=xs(1,1)*dd1+xs(1,2)*dd2+xs(1,3)*dd3
!
      if(iflag.eq.2) return
!
      dd=1.d0/xsj
!
!     computation of the global derivative of the local coordinates
!     (xsi) (inversion of xs)
!
      xsi(1,1)=dd1*dd
      xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))*dd
      xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))*dd
      xsi(2,1)=dd2*dd
      xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))*dd
      xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))*dd
      xsi(3,1)=dd3*dd
      xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))*dd
      xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))*dd
!
!     computation of the global derivatives of the shape functions
!
      do k=1,26
        do j=1,3
          shp(j,k)=shpe(1,k)*xsi(1,j)+shpe(2,k)*xsi(2,j)
     &          +shpe(3,k)*xsi(3,j)
        enddo
      enddo
!
      return
      end


c-----------------------------------------------------------------------
      subroutine iylm(thmin,thmax,w,lmax1,nw,v)
      integer lmax1,nw
      real*8 thmin,thmax,w(nw)
c        work array (could be automatic if compiler supports it)
      real*8 v(lmax1)
c
c        parameters
      include 'pi.par'
c        data variables
      real*8 tiny
c        local (automatic) variables
      integer lm,lmx1,qphi
      real*8 ri,phi,zi,ci,si,ph,dph
c *
c * w_lm = integral from thmin to thmax Y_lm(th,0) sin th d th
c *
c * ISN'T THERE A FASTER WAY OF DOING THIS?
c * I can find an expansion in incomplete beta functions,
c * but the expansion is not much shorter, and not as pretty.
c *
c  Input: thmin, thmax = minimum, maximum polar angle in radians.
c         lmax1 = lmax+1 where lmax is maximum desired l of transform.
c         nw = [(lmax+1)*(lmax+2)]/2 .
c Output: w(lm) = integral from thmax to thmin Y_lm(th,0) d cos th .
c Work array: v should be dimensioned at least lmax1 .
c
      data tiny /1.d-30/
c
      do 120 lm=1,nw
        w(lm)=0.d0
  120 continue
c        upper latitude term
      ri=0.d0
      zi=1.d0
      phi=0.d0
      ph=0.d0
      dph=-tiny
      if (thmin.eq.0.d0.or.thmin.eq.PI) then
        si=0.d0
        lmx1=1
      else
        si=sin(thmin)
        lmx1=lmax1
      endif
      ci=cos(thmin)
      call wlm(w,lmx1,1,nw,ri,phi,0,zi,ci,si,ph,dph,v)
c        lower latitude term
      dph=tiny
      if (thmax.eq.0.d0.or.thmax.eq.PI) then
        si=0.d0
        lmx1=1
      else
        si=sin(thmax)
        lmx1=lmax1
      endif
      ci=cos(thmax)
      call wlm(w,lmx1,1,nw,ri,phi,0,zi,ci,si,ph,dph,v)
c        longitude term
      ri=1.d0
      zi=0.d0
      ci=0.d0
      si=1.d0
      phi=tiny
      qphi=-1
      ph=PI-(thmin+thmax)/2.d0
      dph=thmax-thmin
      call wlm(w,lmax1,1,nw,ri,phi,qphi,zi,ci,si,ph,dph,v)
      do 140 lm=1,nw
        w(lm)=w(lm)/tiny
  140 continue
      return
      end
c


            program main
            DOUBLE precision A(250,250), B(250,250),u1(250)
            DOUBLE precision u2(250), v1(250), v2(250)
            DOUBLE precision w(250), x(250), y(250), z(250)
            DOUBLE precision t_start, t_end

            integer i, j
            m = 250;
            n = 250;

            alpha = 1.0
            beta = 1.0

            do i = 1, 250
            do j = 1, 250
            B(i,j) = 1;
            end do
            u1(i)  = 1;
            u2(i)  = 1;
            v1(i)  = 1;
            v2(i)  = 1;
            w(i)  = 1;
            x(i)  = 1;
            y(i)  = 1;
            z(i)  = 1;
            end do

            call rtclock (t_start)

            call dcopy(m * n, A, 1, B, 1);
            call dger(m, n, 1.0, u1, 1, v1 , 1, B, m);
            call dger(m, n, 1.0, u2, 1, v2 , 1, B, m);
            call dcopy(n,z,1,x,1)
            call dgemv('T', m, n, beta, B, m, y, 1, 1.0, x, 1);
            call dgemv('N', m, n, alpha, B, m, x, 1, 0.0, w, 1);
            call rtclock (t_end)
            write(*, 900) t_end-t_start
900         format (F10.6)
            end


*     TB03AD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          MAXMP
      PARAMETER        ( MAXMP = MAX( MMAX, PMAX ) )
      INTEGER          LDA, LDB, LDC, LDD, LDPCO1, LDPCO2, LDQCO1,
     $                 LDQCO2, LDVCO1, LDVCO2, NMAXP1
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = MAXMP,
     $                   LDD = MAXMP, LDPCO1 = MAXMP, LDPCO2 = MAXMP,
     $                   LDQCO1 = MAXMP, LDQCO2 = MAXMP, LDVCO1 = MAXMP,
     $                   LDVCO2 = NMAX, NMAXP1 = NMAX+1 )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX + MAXMP )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( NMAX + MAX( NMAX, 3*MAXMP ),
     $                                 MAXMP*( MAXMP + 2 ) ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INDBLK, INFO, J, K, KPCOEF, M, N, NR, P, PORM,
     $                 PORP
      CHARACTER*1      EQUIL, LERI
      LOGICAL          LLERI
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MAXMP), C(LDC,NMAX),
     $                 D(LDD,MAXMP), DWORK(LDWORK),
     $                 PCOEFF(LDPCO1,LDPCO2,NMAXP1),
     $                 QCOEFF(LDQCO1,LDQCO2,NMAXP1),
     $                 VCOEFF(LDVCO1,LDVCO2,NMAXP1)
      INTEGER          INDEX(MAXMP), IWORK(LIWORK)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         TB03AD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, TOL, LERI, EQUIL
      LLERI = LSAME( LERI, 'L' )
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99987 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99986 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1,M ), I = 1,N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99985 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
*              Find the right pmr which is equivalent to the ssr
*              C*inv(sI-A)*B+D.
               CALL TB03AD( LERI, EQUIL, N, M, P, A, LDA, B, LDB, C,
     $                      LDC, D, LDD, NR, INDEX, PCOEFF, LDPCO1,
     $                      LDPCO2, QCOEFF, LDQCO1, LDQCO2, VCOEFF,
     $                      LDVCO1, LDVCO2, TOL, IWORK, DWORK, LDWORK,
     $                      INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99997 ) NR
                  DO 20 I = 1, NR
                     WRITE ( NOUT, FMT = 99996 ) ( A(I,J), J = 1,NR )
   20             CONTINUE
                  INDBLK = 0
                  DO 40 I = 1, N
                     IF ( IWORK(I).NE.0 ) INDBLK = INDBLK + 1
   40             CONTINUE
                  WRITE ( NOUT, FMT = 99995 ) ( IWORK(I), I = 1,INDBLK )
                  WRITE ( NOUT, FMT = 99994 )
                  DO 60 I = 1, NR
                     WRITE ( NOUT, FMT = 99996 ) ( B(I,J), J = 1,M )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99993 )
                  DO 80 I = 1, P
                     WRITE ( NOUT, FMT = 99996 ) ( C(I,J), J = 1,NR )
   80             CONTINUE
                  IF ( LLERI ) THEN
                     PORM = P
                     PORP = M
                     WRITE ( NOUT, FMT = 99992 ) INDBLK
                  ELSE
                     PORM = M
                     PORP = P
                     WRITE ( NOUT, FMT = 99991 ) INDBLK
                  END IF
                  WRITE ( NOUT, FMT = 99990 ) ( INDEX(I), I = 1,PORM )
                  KPCOEF = 0
                  DO 100 I = 1, PORM
                     KPCOEF = MAX( KPCOEF, INDEX(I) )
  100             CONTINUE
                  KPCOEF = KPCOEF + 1
                  WRITE ( NOUT, FMT = 99989 )
                  DO 140 I = 1, PORM
                     DO 120 J = 1, PORM
                        WRITE ( NOUT, FMT = 99996 )
     $                        ( PCOEFF(I,J,K), K = 1,KPCOEF )
  120                CONTINUE
  140             CONTINUE
                  WRITE ( NOUT, FMT = 99988 )
                  IF ( LLERI ) THEN
                     DO 180 I = 1, PORM
                        DO 160 J = 1, PORP
                           WRITE ( NOUT, FMT = 99996 )
     $                           ( QCOEFF(I,J,K), K = 1,KPCOEF )
  160                   CONTINUE
  180                CONTINUE
                  ELSE
                     DO 220 I = 1, PORP
                        DO 200 J = 1, PORM
                           WRITE ( NOUT, FMT = 99996 )
     $                           ( QCOEFF(I,J,K), K = 1,KPCOEF )
  200                   CONTINUE
  220                CONTINUE
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' TB03AD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from TB03AD = ',I2)
99997 FORMAT (' The order of the minimal state-space representation = ',
     $       I2,//' The transformed state dynamics matrix of a minimal',
     $       ' realization is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' and the dimensions of its diagonal blocks are ',/20(I5)
     $       )
99994 FORMAT (/' The transformed input/state matrix of a minimal reali',
     $       'zation is ')
99993 FORMAT (/' The transformed state/output matrix of a minimal real',
     $       'ization is ')
99992 FORMAT (/' The observability index of the transformed minimal sy',
     $       'stem representation = ',I2)
99991 FORMAT (/' The controllability index of the transformed minimal ',
     $       'system representation = ',I2)
99990 FORMAT (/' INDEX is ',/20(I5))
99989 FORMAT (/' The denominator matrix P(s) is ')
99988 FORMAT (/' The numerator matrix Q(s) is ')
99987 FORMAT (/' N is out of range.',/' N = ',I5)
99986 FORMAT (/' M is out of range.',/' M = ',I5)
99985 FORMAT (/' P is out of range.',/' P = ',I5)
      END


subroutine residual_func(snes_in, stateVector, residualVector, ctx, localerr)
#include <petsc/finclude/petscsnes.h>
   use petscsnes
   use contexts
   use grids
   use input
   use geometry
   use mp
   use diffusion
   use source
   implicit none
   SNES:: snes_in
   PetscScalar,dimension(:),intent(in):: stateVector
   PetscScalar,dimension(:),intent(inout):: residualVector
   type(resContext):: ctx
   PetscErrorCode:: localerr
   real,dimension(:),allocatable:: Efield
   integer :: idx, ir, ip, ix, idx_rp1, idx_rm1, idx_pp1, idx_pm1, idx_xp1, idx_xm1
   real :: delta_t, t, temp
   real :: jacob_rl,jacob_rr,jacob_pl,jacob_pr,jacob_xl,jacob_xr
   real :: jacob_rm1,jacob_rp1,jacob_pm1,jacob_pp1,jacob_xm1,jacob_xp1, jacob_c
   real :: Dr_l, Dr_r, Dp_l, Dp_r, Dx_l, Dx_r, Ar_l, Ar_r, Ap_l, Ap_r, Ax_l, Ax_r

   allocate(Efield(Nr))

   select case (efield_option)
   case ("none")
      Efield(:) = 0.0
   case ("inductive")
      Efield(:) = stateVector(Nr*Np*Nx+1:Nr*Np*Nx+Nr)
   end select

   t = ctx%time
   delta_t = ctx%delta_t

   do idx = firstLocalRow, lastLocalRow
      ir = get_idx_r(idx)
      ip = get_idx_p(idx)
      ix = get_idx_x(idx)

      idx_rp1 = get_idx(ir+1,ip,ix)
      idx_rm1 = get_idx(ir-1,ip,ix)
      idx_pp1 = get_idx(ir,ip+1,ix)
      idx_pm1 = get_idx(ir,ip-1,ix)
      idx_xp1 = get_idx(ir,ip,ix+1)
      idx_xm1 = get_idx(ir,ip,ix-1)

      ! Coordinate Jacobian defined in cell center
      jacob_c = jacob(rgrid(ir),pgrid(ip),xgrid(ix))

      temp = 0.0

      if (ir == 1) then
         jacob_rr = jacob(rgrid_edge(ir+1),pgrid(ip),xgrid(ix))
         jacob_rp1 = jacob(rgrid(ir+1),pgrid(ip),xgrid(ix))

         Ar_r = jacob_rr*Ar(rgrid_edge(ir+1),pgrid(ip),xgrid(ix),t)
         Dr_r = jacob_c*Drr(rgrid(ir),pgrid(ip),pgrid(ix),t)*jacob_rp1*Drr(rgrid(ir+1),pgrid(ip),xgrid(ix),t) * ( rgrid(ir+1) - rgrid(ir) ) / &
            ( (rgrid(ir+1)-rgrid_edge(ir+1))*jacob_c*Drr(rgrid(ir),pgrid(ip),xgrid(ix),t) + (rgrid_edge(ir+1)-rgrid(ir))*jacob_rp1*Drr(rgrid(ir+1),pgrid(ip),xgrid(ix),t) )

         temp=temp+ Ar_r * stateVector( get_idx(ir_upwind(ir+1,ip,ix),ip,ix) ) / (rgrid_edge(ir+1)-rgrid_edge(ir))
         temp=temp- (Dr_r/( (rgrid(ir+1)-rgrid(ir))*(rgrid_edge(ir+1)-rgrid_edge(ir)))) * (stateVector(idx_rp1) - stateVector(idx))
      else if (ir == Nr) then
         jacob_rl = jacob(rgrid_edge(ir),pgrid(ip),xgrid(ix))
         jacob_rr = jacob(rgrid_edge(ir+1),pgrid(ip),xgrid(ix))
         jacob_rm1 = jacob(rgrid(ir-1),pgrid(ip),xgrid(ix))

         Ar_l = jacob_rl*Ar(rgrid_edge(ir),pgrid(ip),xgrid(ix),t)
         Ar_r = jacob_rr*Ar(rgrid_edge(ir+1),pgrid(ip),xgrid(ix),t)

         Dr_l = jacob_rm1*Drr(rgrid(ir-1),pgrid(ip),pgrid(ix),t)*jacob_c*Drr(rgrid(ir),pgrid(ip),xgrid(ix),t) * ( rgrid(ir) - rgrid(ir-1) ) / &
            ( (rgrid(ir)-rgrid_edge(ir)) * jacob_rm1*Drr(rgrid(ir-1),pgrid(ip),xgrid(ix),t) + (rgrid_edge(ir+1)-rgrid(ir))*jacob_c*Drr(rgrid(ir),pgrid(ip),xgrid(ix),t) )

         Dr_r = jacob_c*Drr(rgrid(ir),pgrid(ip),pgrid(ix),t)*jacob_rp1*Drr(rgrid(ir+1),pgrid(ip),xgrid(ix),t) * ( rgrid(ir+1) - rgrid(ir) ) / &
            ( (rgrid(ir+1)-rgrid_edge(ir+1))*jacob_c*Drr(rgrid(ir),pgrid(ip),xgrid(ix),t) + (rgrid_edge(ir+1)-rgrid(ir))*jacob_rp1*Drr(rgrid(ir+1),pgrid(ip),xgrid(ix),t) )

         temp=temp- Ar_l * stateVector( get_idx(ir_upwind(ir,ip,ix),ip,ix) ) / (rgrid_edge(ir+1)-rgrid_edge(ir))
         temp=temp+ 0.0

         ! Use a "ghost" cell with vanishing state vector. This cell has a width equal to the last r cell
         temp=temp+ (Dr_l/( (rgrid(ir)-rgrid(ir-1))*(rgrid_edge(ir+1)-rgrid_edge(ir)))) * ( stateVector(idx) - stateVector(idx_rm1) )
         temp=temp- (Dr_r/( (rgrid(ir)-rgrid(ir-1))*(rgrid_edge(ir+1)-rgrid_edge(ir)))) * (0.0 - stateVector(idx))

      else
         jacob_rl = jacob(rgrid_edge(ir),pgrid(ip),xgrid(ix))
         jacob_rr = jacob(rgrid_edge(ir+1),pgrid(ip),xgrid(ix))
         jacob_rm1 = jacob(rgrid(ir-1),pgrid(ip),xgrid(ix))
         jacob_rp1 = jacob(rgrid(ir+1),pgrid(ip),xgrid(ix))

         Ar_l = jacob_rl*Ar(rgrid_edge(ir),pgrid(ip),xgrid(ix),t)
         Ar_r = jacob_rr*Ar(rgrid_edge(ir+1),pgrid(ip),xgrid(ix),t)

         Dr_l = jacob_rm1*Drr(rgrid(ir-1),pgrid(ip),pgrid(ix),t)*jacob_c*Drr(rgrid(ir),pgrid(ip),xgrid(ix),t) * ( rgrid(ir) - rgrid(ir-1) ) / &
            ( (rgrid(ir)-rgrid_edge(ir)) * jacob_rm1*Drr(rgrid(ir-1),pgrid(ip),xgrid(ix),t) + (rgrid_edge(ir+1)-rgrid(ir))*jacob_c*Drr(rgrid(ir),pgrid(ip),xgrid(ix),t) )

         Dr_r = jacob_c*Drr(rgrid(ir),pgrid(ip),pgrid(ix),t)*jacob_rp1*Drr(rgrid(ir),pgrid(ip),xgrid(ix),t) * ( rgrid(ir) - rgrid(ir-1) ) / &
            ( (rgrid(ir)-rgrid_edge(ir))*jacob_c*Drr(rgrid(ir),pgrid(ip),xgrid(ix),t) + (rgrid_edge(ir+1)-rgrid(ir))*jacob_rp1*Drr(rgrid(ir),pgrid(ip),xgrid(ix),t) )

         temp=temp- Ar_l * stateVector( get_idx(ir_upwind(ir,ip,ix),ip,ix) ) / (rgrid_edge(ir+1)-rgrid_edge(ir))
         if (ir_upwind(ir+1,ip,ix) > Nr) then
            temp = temp+0.0
         else
            temp=temp+ Ar_r * stateVector( get_idx(ir_upwind(ir+1,ip,ix),ip,ix) ) / (rgrid_edge(ir+1)-rgrid_edge(ir))
         end if

         temp=temp+ (Dr_l/( (rgrid(ir)-rgrid(ir-1))*(rgrid_edge(ir+1)-rgrid_edge(ir)))) * ( stateVector(idx) - stateVector(idx_rm1) )
         temp=temp- (Dr_r/( (rgrid(ir+1)-rgrid(ir))*(rgrid_edge(ir+1)-rgrid_edge(ir)))) * (0.0 - stateVector(idx))
      end if

      if (ip == 1) then
         jacob_pr = jacob(rgrid(ir),pgrid_edge(ip+1),xgrid(ix))
         jacob_pp1 = jacob(rgrid(ir),pgrid(ip+1),xgrid(ix))

         Ap_r = jacob_pr*Ar(rgrid(ir),pgrid_edge(ip+1),xgrid(ix),t)
         Dp_r = jacob_c*Dpp(rgrid(ir),pgrid(ip),pgrid(ix),t)*jacob_pp1*Dpp(rgrid(ir),pgrid(ip+1),xgrid(ix),t) * ( pgrid(ip+1) - pgrid(ip) ) / &
            ( (pgrid(ip+1)-pgrid_edge(ip+1))*jacob_c*Dpp(rgrid(ir),pgrid(ip),xgrid(ix),t) + (pgrid_edge(ip+1)-pgrid(ip))*jacob_pp1*Dpp(rgrid(ir),pgrid(ip+1),xgrid(ix),t) )

         if (ip_upwind(ir,ip+1,ix) < 1) then
            temp=temp+ 0.0
         else
            temp=temp+ Ap_r * stateVector( get_idx(ir,ip_upwind(ir,ip+1,ix),ix) ) / (pgrid_edge(ip+1)-pgrid_edge(ip))
         end if
         ! Use a "ghost" cell with vanishing state vector. This cell has a width equal to the last p cell
         temp=temp- (Dp_r/( (pgrid(ip)-pgrid(ip-1))*(pgrid_edge(ip+1)-pgrid_edge(ip)))) * (0.0 - stateVector(idx))
      else if (ip == Np) then
         jacob_pl = jacob(rgrid(ir),pgrid_edge(ip),xgrid(ix))
         jacob_pr = jacob(rgrid(ir),pgrid_edge(ip+1),xgrid(ix))
         jacob_pm1 = jacob(rgrid(ir),pgrid(ip-1),xgrid(ix))
         jacob_pp1 = jacob(rgrid(ir),pgrid(ip+1),xgrid(ix))

         Ap_l = jacob_pl*Ar(rgrid(ir),pgrid_edge(ip),xgrid(ix),t)
         Ap_r = jacob_pr*Ar(rgrid(ir),pgrid_edge(ip+1),xgrid(ix),t)

         Dp_l = jacob_pm1*Dpp(rgrid(ir),pgrid(ip-1),pgrid(ix),t)*jacob_c*Dpp(rgrid(ir),pgrid(ip),xgrid(ix),t) * ( pgrid(ip) - pgrid(ip-1) ) / &
            ( (pgrid(ip)-pgrid_edge(ip))*jacob_pm1*Dpp(rgrid(ir),pgrid(ip-1),xgrid(ix),t) + (pgrid_edge(ip+1)-pgrid(ip))*jacob_c**Dpp(rgrid(ir),pgrid(ip),xgrid(ix),t) )

         Dp_r = jacob_c*Dpp(rgrid(ir),pgrid(ip),pgrid(ix),t)*jacob_pp1*Dpp(rgrid(ir),pgrid(ip),xgrid(ix),t) * ( pgrid(ip) - pgrid(ip-1) ) / &
            ( (pgrid(ip)-pgrid_edge(ip))*jacob_c*Dpp(rgrid(ir),pgrid(ip),xgrid(ix),t) + (pgrid_edge(ip+1)-pgrid(ip))*jacob_pp1*Dpp(rgrid(ir),pgrid(ip),xgrid(ix),t) )

         temp=temp- Ap_l * stateVector( get_idx(ir,ip_upwind(ir,ip,ix),ix) ) / (pgrid_edge(ip+1)-pgrid_edge(ip))
         if (ip_upwind(ir,ip+1,ix) > Np) then
            temp=temp+0.0
         else
            temp=temp+ Ap_r * stateVector( get_idx(ir,ip_upwind(ir,ip+1,ix),ix) ) / (pgrid_edge(ip+1)-pgrid_edge(ip))
         end if

         temp=temp+ (Dp_l/( (pgrid(ip)-pgrid(ip-1))*(pgrid_edge(ip+1)-pgrid_edge(ip)))) * ( stateVector(idx) - stateVector(idx_pm1) )
         temp=temp- (Dp_r/( (pgrid(ip+1)-pgrid(ip))*(pgrid_edge(ip+1)-pgrid_edge(ip)))) * (0.0 - stateVector(idx))

      else
         jacob_pl = jacob(rgrid(ir),pgrid_edge(ip),xgrid(ix))
         jacob_pr = jacob(rgrid(ir),pgrid_edge(ip+1),xgrid(ix))
         jacob_pm1 = jacob(rgrid(ir),pgrid(ip-1),xgrid(ix))
         jacob_pp1 = jacob(rgrid(ir),pgrid(ip+1),xgrid(ix))

         Ap_l = jacob_pl*Ar(rgrid(ir),pgrid_edge(ip),xgrid(ix),t)
         Ap_r = jacob_pr*Ar(rgrid(ir),pgrid_edge(ip+1),xgrid(ix),t)

         Dp_l = jacob_pm1*Dpp(rgrid(ir),pgrid(ip-1),pgrid(ix),t)*jacob_c*Dpp(rgrid(ir),pgrid(ip),xgrid(ix),t) * ( pgrid(ip) - pgrid(ip-1) ) / &
            ( (pgrid(ip)-pgrid_edge(ip))*jacob_pm1*Dpp(rgrid(ir),pgrid(ip-1),xgrid(ix),t) + (pgrid_edge(ip+1)-pgrid(ip))*jacob_c**Dpp(rgrid(ir),pgrid(ip),xgrid(ix),t) )

         Dp_r = jacob_c*Dpp(rgrid(ir),pgrid(ip),pgrid(ix),t)*jacob_pp1*Dpp(rgrid(ir),pgrid(ip+1),xgrid(ix),t) * ( pgrid(ip+1) - pgrid(ip) ) / &
            ( (pgrid(ip+1)-pgrid_edge(ip+1))*jacob_c*Dpp(rgrid(ir),pgrid(ip),xgrid(ix),t) + (pgrid_edge(ip+1)-pgrid(ip))*jacob_pp1*Dpp(rgrid(ir),pgrid(ip+1),xgrid(ix),t) )
         temp=temp- Ap_l * stateVector( get_idx(ir,ip_upwind(ir,ip,ix),ix) ) / (pgrid_edge(ip+1)-pgrid_edge(ip))
         temp=temp+ Ap_r * stateVector( get_idx(ir,ip_upwind(ir,ip+1,ix),ix) ) / (pgrid_edge(ip+1)-pgrid_edge(ip))

         temp=temp+ (Dp_l/( (pgrid(ip)-pgrid(ip-1))*(pgrid_edge(ip+1)-pgrid_edge(ip)))) * ( stateVector(idx) - stateVector(idx_pm1) )
         temp=temp- (Dp_r/( (pgrid(ip+1)-pgrid(ip))*(pgrid_edge(ip+1)-pgrid_edge(ip)))) * (stateVector(idx_pp1) - stateVector(idx))
      end if

      if (ix == 1) then
         jacob_xr = jacob(rgrid(ir),pgrid(ip),xgrid_edge((ix+1)))
         jacob_xp1 = jacob(rgrid(ir),pgrid(ip),xgrid(ix+1))

         Ax_r = jacob_xr*Ar(rgrid(ir),pgrid(ip),xgrid_edge(ix+1),t)
         Dx_r = jacob_c*Dxx(rgrid(ir),pgrid(ip),pgrid(ix),t)*jacob_xp1*Dxx(rgrid(ir),pgrid(ip),xgrid(ix+1),t) * ( xgrid(ix+1) - xgrid(ix) ) / &
            ( (xgrid(ix+1)-xgrid_edge(ix+1))*jacob_c*Dxx(rgrid(ir),pgrid(ip),xgrid(ix),t) + (xgrid_edge(ix+1)-xgrid(ix))*jacob_xp1*Dxx(rgrid(ir),pgrid(ip),xgrid(ix+1),t) )

         temp=temp+ Ax_r * stateVector( get_idx(ir,ip,ix_upwind(ir,ip,ix+1)) ) / (xgrid_edge(ix+1)-xgrid_edge(ix))
         temp=temp- (Dx_r/( (xgrid(ix+1)-xgrid(ix))*(xgrid_edge(ix+1)-pgrid_edge(ix)))) * (stateVector(idx_xp1) - stateVector(idx))
      else if (ix == Nx) then
         jacob_xl = jacob(rgrid(ir),pgrid(ip),xgrid_edge(ix))
         jacob_xm1 = jacob(rgrid(ir),pgrid(ip),xgrid(ix-1))

         Ax_l = jacob_xl*Ar(rgrid(ir),pgrid(ip),xgrid_edge(ix),t)
         Dx_l = jacob_xm1*Dxx(rgrid(ir),pgrid(ip),pgrid(ix-1),t)*jacob_c*Dxx(rgrid(ir),pgrid(ip),xgrid(ix),t) * ( xgrid(ix) - xgrid(ix-1) ) / &
            ( (xgrid(ix)-xgrid_edge(ix))*jacob_xm1*Dxx(rgrid(ir),pgrid(ip),xgrid(ix-1),t) + (xgrid_edge(ix+1)-xgrid(ix))*jacob_c*Dxx(rgrid(ir),pgrid(ip),xgrid(ix),t) )

         temp=temp- Ax_l * stateVector( get_idx(ir,ip,ix_upwind(ir,ip,ix)) ) / (xgrid_edge(ix+1)-xgrid_edge(ix))
         temp=temp+ (Dx_l/( (xgrid(ix)-xgrid(ix-1))*(xgrid_edge(ix+1)-pgrid_edge(ix)))) * ( stateVector(idx) - stateVector(idx_xm1) )
      else
         jacob_xl = jacob(rgrid(ir),pgrid(ip),xgrid_edge(ix))
         jacob_xr = jacob(rgrid(ir),pgrid(ip),xgrid_edge((ix+1)))

         jacob_xm1 = jacob(rgrid(ir),pgrid(ip),xgrid(ix-1))
         jacob_xp1 = jacob(rgrid(ir),pgrid(ip),xgrid(ix+1))

         ! Pre-defining the advection and diffusion coefficients. Will probably save this to arrays later
         Ax_l = jacob_xl*Ar(rgrid(ir),pgrid(ip),xgrid_edge(ix),t)
         Ax_r = jacob_xr*Ar(rgrid(ir),pgrid(ip),xgrid_edge(ix+1),t)

         Dx_l = jacob_xm1*Dxx(rgrid(ir),pgrid(ip),pgrid(ix-1),t)*jacob_c*Dxx(rgrid(ir),pgrid(ip),xgrid(ix),t) * ( xgrid(ix) - xgrid(ix-1) ) / &
            ( (xgrid(ix)-xgrid_edge(ix))*jacob_xm1*Dxx(rgrid(ir),pgrid(ip),xgrid(ix-1),t) + (xgrid_edge(ix+1)-xgrid(ix))*jacob_c*Dxx(rgrid(ir),pgrid(ip),xgrid(ix),t) )

         Dx_r = jacob_c*Dxx(rgrid(ir),pgrid(ip),pgrid(ix),t)*jacob_xp1*Dxx(rgrid(ir),pgrid(ip),xgrid(ix+1),t) * ( xgrid(ix+1) - xgrid(ix) ) / &
            ( (xgrid(ix+1)-xgrid_edge(ix+1))*jacob_c*Dxx(rgrid(ir),pgrid(ip),xgrid(ix),t) + (xgrid_edge(ix+1)-xgrid(ix))*jacob_xp1*Dxx(rgrid(ir),pgrid(ip),xgrid(ix+1),t) )

         temp=temp- Ax_l * stateVector( get_idx(ir,ip,ix_upwind(ir,ip,ix)) ) / (xgrid_edge(ix+1)-xgrid_edge(ix))
         temp=temp+ Ax_r * stateVector( get_idx(ir,ip,ix_upwind(ir,ip,ix+1)) ) / (xgrid_edge(ix+1)-xgrid_edge(ix))

         temp=temp+ (Dx_l/( (xgrid(ix)-xgrid(ix-1))*(xgrid_edge(ix+1)-pgrid_edge(ix)))) * ( stateVector(idx) - stateVector(idx_xm1) )
         temp=temp- (Dx_r/( (xgrid(ix+1)-xgrid(ix))*(xgrid_edge(ix+1)-pgrid_edge(ix)))) * (stateVector(idx_xp1) - stateVector(idx))
      end if

      ! Coordinate jacobian defined on cell faces

      !      residualVector(idx) = temp + ( (stateVector(idx) - ctx%prevStateVector(idx))/delta_t) - sourcefunc(rgrid(ir),pgrid(ip),xgrid(ix),t)
            residualVector(idx) = temp + ( (stateVector(idx) - 0.0) - sourcefunc(rgrid(ir),pgrid(ip),xgrid(ix),t))
   end do

end subroutine residual_func

subroutine jacobian_func(snes_in, stateVector, matrix_local, matrix_pc, context, localerr)
#include <petsc/finclude/petscsnes.h>
   use petscsnes
   use contexts
   implicit none
   SNES:: snes_in
   Vec,intent(in):: stateVector
   Mat:: matrix_local, matrix_pc
   type(resContext):: context
   PetscErrorCode:: localerr

end subroutine jacobian_func


module mod_fgmres_standard
#include <messenger.h>
    use mod_kinds,                  only: rk, ik
    use mod_constants,              only: DIAG, ZERO, TWO
    use mod_inv,                    only: inv
    use mod_gaussseidel_standard,   only: gaussseidel_autodiff
    use DNAD_D
    implicit none

contains

    !> Solution routine
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/24/2016
    !!
    !!
    !!
    !--------------------------------------------------------------
    subroutine fgmres_standard(A,x,b)
        real(rk), dimension(:,:),   intent(in)               :: A
        real(rk), dimension(:),     intent(inout)            :: x
        real(rk), dimension(:),     intent(in)               :: b

        real(rk), dimension(:), allocatable     :: r0, w, x0
        real(rk), allocatable                   :: v(:,:), z(:,:)
        real(rk),            allocatable        :: h(:,:), h_square(:,:)
        real(rk),            allocatable        :: p(:), y(:), c(:), s(:), p_dim(:), y_dim(:)
        real(rk)                                :: pj, pjp, h_ij, h_ipj

        integer(ik) :: ierr, isol, nvecs, mrestart
        integer(ik) :: i, j, k, l
        real(rk)    :: res, gam, tol

        logical     :: converged = .false.

        tol = 1.e-11_rk

        !
        ! Set GMRES parameters
        !
        mrestart = 200

        !
        ! Allocate and initialize Krylov vectors V
        !
        allocate(v(size(x),mrestart+1),  &
                 z(size(x),mrestart+1), stat=ierr)
        if (ierr /= 0) call AllocationError

        !
        ! Allocate hessenberg matrix to store orthogonalization
        !
        allocate(h(mrestart + 1, mrestart), stat=ierr)
        if (ierr /= 0) call AllocationError
        h = ZERO

        !
        ! Allocate vectors for solving hessenberg system
        !
        allocate(p(mrestart+1), &
                 y(mrestart+1), &
                 c(mrestart+1), &
                 s(mrestart+1), stat=ierr)
        if (ierr /= 0) call AllocationError
        p = ZERO
        y = ZERO
        c = ZERO
        s = ZERO

        !
        ! Set initial solution x. ZERO
        !
        x0 = x
        x0 = ZERO
        x  = ZERO

        res = 1._rk
        do while (res > tol)

            !
            ! Clear working variables
            !
            v = ZERO
            z = ZERO

            p = ZERO
            y = ZERO
            c = ZERO
            s = ZERO
            h = ZERO

            !
            ! Compute initial residual r0, residual norm, and normalized r0
            !
            r0      = b - matmul(A,x)

            v(:,1) = r0/norm2(r0)
            p(1)   = norm2(r0)
            !
            ! Outer GMRES Loop
            !
            nvecs = 0
            do j = 1, mrestart
                nvecs = nvecs + 1

                !
                ! Compute w = Av for the current iteration
                !
                w = matmul(A,v(:,j))

                !
                ! Orthogonalization loop
                !
                do i = 1,j
                    h(i,j) = dot_product(w,v(:,i))
                    w  = w - h(i,j)*v(:,i)
                end do
                h(j+1,j) = norm2(w)

                !
                ! Compute next Krylov vector
                !
                v(:,j+1) = w/h(j+1,j)

                !
                ! Previous Givens rotations on h
                !
                if (j /= 1) then
                    do i = 1,j-1
                        ! Need temp values here so we don't directly overwrite the h(i,j) and h(i+1,j) values
                        h_ij     = c(i)*h(i,j)  +  s(i)*h(i+1,j)
                        h_ipj    = -s(i)*h(i,j)  +  c(i)*h(i+1,j)

                        h(i,j)    = h_ij
                        h(i+1,j)  = h_ipj
                    end do
                end if

                !
                ! Compute next rotation
                !
                gam  = sqrt( h(j,j)*h(j,j)  +  h(j+1,j)*h(j+1,j) )
                c(j) = h(j,j)/gam
                s(j) = h(j+1,j)/gam

                !
                ! Givens rotation on h
                !
                h(j,j)   = gam
                h(j+1,j) = ZERO

                !
                ! Givens rotation on p. Need temp values here so we aren't directly overwriting the p(j) value until we want to
                !
                pj = c(j)*p(j)
                pjp = -s(j)*p(j)

                p(j)     = pj
                p(j+1)   = pjp

                !
                ! Test exit conditions
                !
                res = abs(p(j+1))
                converged = (res < tol)

                if ( converged ) then
                    exit
                end if

            end do  ! Outer GMRES Loop - m

            !
            ! Solve upper-triangular system y = hinv * p
            !
            if (allocated(h_square)) then
                deallocate(h_square,p_dim,y_dim)
            end if

            allocate(h_square(nvecs,nvecs), &
                    p_dim(nvecs),      &
                    y_dim(nvecs), stat=ierr)
            if (ierr /= 0) call AllocationError

            !
            ! Store h and p values to appropriately sized matrices
            !
            do l=1,nvecs
                do k=1,nvecs
                    h_square(k,l) = h(k,l)
                end do
                p_dim(l) = p(l)
            end do

            !
            ! Solve the system
            !
            h_square = inv(h_square)
            y_dim = matmul(h_square,p_dim)

            !
            ! Reconstruct solution
            !
            x = x0
            do isol = 1,nvecs
                !x = x + y_dim(isol)*z(isol)
                x = x + y_dim(isol)*v(:,isol)
            end do

            !
            ! Test exit condition
            !
            if ( converged ) then
                exit
            else
                x0 = x
            end if

        end do   ! while

    end subroutine fgmres_standard

    !>  Solve linear system of equations Ax=b when x,b are automatic
    !!  differentiation datatypes.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/9/2018
    !!
    !--------------------------------------------------------------
    subroutine fgmres_autodiff(A,x,b)
        real(rk),   dimension(:,:),     intent(in)      :: A
        type(AD_D), dimension(:),       intent(inout)   :: x
        type(AD_D), dimension(:),       intent(in)      :: b

        !real(rk), dimension(:), allocatable     :: r0, w, x0
        !real(rk), allocatable                   :: v(:,:), z(:,:)
        !real(rk),            allocatable        :: h(:,:), h_square(:,:)
        !real(rk),            allocatable        :: p(:), y(:), c(:), s(:), p_dim(:), y_dim(:)
        !real(rk)                                :: pj, pjp, h_ij, h_ipj

        type(AD_D), dimension(:),   allocatable     :: r0, w, x0
        type(AD_D),                 allocatable     :: v(:,:), z(:,:)
        type(AD_D),                 allocatable     :: h(:,:), h_square(:,:)
        type(AD_D),                 allocatable     :: p(:), y(:), c(:), s(:), p_dim(:), y_dim(:)
        type(AD_D)                                  :: pj, pjp, h_ij, h_ipj, gam, res, r0norm
        real(rk)    :: tol

        integer(ik) :: ierr, isol, nvecs, mrestart
        integer(ik) :: i, j, k, l

        logical     :: converged = .false.

        tol = 1.e-11_rk

        !
        ! Set GMRES parameters
        !
        mrestart = 200

        !
        ! Allocate and initialize Krylov vectors V
        !
        allocate(v(size(x),mrestart+1),  &
                 z(size(x),mrestart+1), stat=ierr)
        if (ierr /= 0) call AllocationError
        v(:,:) = b(1)
        z(:,:) = b(1)
        v(:,:) = ZERO
        z(:,:) = ZERO

        !
        ! Allocate hessenberg matrix to store orthogonalization
        !
        allocate(h(mrestart + 1, mrestart), stat=ierr)
        if (ierr /= 0) call AllocationError
        h(:,:) = b(1)
        h = ZERO

        !
        ! Allocate vectors for solving hessenberg system
        !
        allocate(p(mrestart+1), &
                 y(mrestart+1), &
                 c(mrestart+1), &
                 s(mrestart+1), stat=ierr)
        if (ierr /= 0) call AllocationError
        p(:) = b(1)
        y(:) = b(1)
        c(:) = b(1)
        s(:) = b(1)
        p = ZERO
        y = ZERO
        c = ZERO
        s = ZERO

        !
        ! Set initial solution x. ZERO
        !
        x = b
        x = ZERO

        x0 = x
        x0 = ZERO
        x  = ZERO

        res = b(1)
        res = 1._rk
        do while (res > tol)

            !
            ! Clear working variables
            !
            v = ZERO
            z = ZERO

            p = ZERO
            y = ZERO
            c = ZERO
            s = ZERO
            h = ZERO

            !
            ! Compute initial residual r0, residual norm, and normalized r0
            !
            r0 = b - matmul(A,x)

            r0norm = norm2(r0)

            !v(:,1) = r0/norm2(r0)
            v(:,1) = r0/r0norm
            p(1)   = norm2(r0)
            !v(:,1) = r0/norm2_ad(r0)
            !p(1)   = norm2_ad(r0)
            !
            ! Outer GMRES Loop
            !
            nvecs = 0
            do j = 1, mrestart
                nvecs = nvecs + 1

                !
                ! Compute w = Av for the current iteration
                !
                w = matmul(A,v(:,j))

                !
                ! Orthogonalization loop
                !
                do i = 1,j
                    h(i,j) = dot_product(w,v(:,i))
                    !h(i,j) = dot_product_ad(w,v(:,i))
                    w  = w - h(i,j)*v(:,i)
                end do

                h(j+1,j) = norm2(w)
                !h(j+1,j) = norm2_ad(w)

                !
                ! Compute next Krylov vector
                !
                v(:,j+1) = w/h(j+1,j)

                !
                ! Previous Givens rotations on h
                !
                if (j /= 1) then
                    do i = 1,j-1
                        ! Need temp values here so we don't directly overwrite the h(i,j) and h(i+1,j) values
                        h_ij   = c(i)*h(i,j)  + s(i)*h(i+1,j)
                        h_ipj  = -s(i)*h(i,j) + c(i)*h(i+1,j)

                        h(i,j)    = h_ij
                        h(i+1,j)  = h_ipj
                    end do
                end if

                !
                ! Compute next rotation
                !
                gam  = sqrt( h(j,j)*h(j,j)  +  h(j+1,j)*h(j+1,j) )
                c(j) = h(j,j)/gam
                s(j) = h(j+1,j)/gam

                !
                ! Givens rotation on h
                !
                h(j,j)   = gam
                h(j+1,j) = ZERO

                !
                ! Givens rotation on p. Need temp values here so we aren't directly overwriting the p(j) value until we want to
                !
                pj = c(j)*p(j)
                pjp = -s(j)*p(j)

                p(j)     = pj
                p(j+1)   = pjp

                !
                ! Test exit conditions
                !
                res = abs(p(j+1))
                print*, res%x_ad_
                converged = (res < tol)

                if ( converged ) then
                    exit
                end if

            end do  ! Outer GMRES Loop - m

            !
            ! Solve upper-triangular system y = hinv * p
            !
            if (allocated(h_square)) then
                deallocate(h_square,p_dim,y_dim)
            end if

            allocate(h_square(nvecs,nvecs), &
                    p_dim(nvecs),      &
                    y_dim(nvecs), stat=ierr)
            if (ierr /= 0) call AllocationError

            !
            ! Store h and p values to appropriately sized matrices
            !
            do l=1,nvecs
                do k=1,nvecs
                    h_square(k,l) = h(k,l)
                end do
                p_dim(l) = p(l)
            end do

            !
            ! Solve the system
            !
            !h_square = inv(h_square)
            !y_dim = matmul(h_square,p_dim)
            print*, '   calling gauss-seidel...'
            call gaussseidel_autodiff(h_square,y_dim,p_dim)
            print*, '   done with gauss-seidel.'

            !
            ! Reconstruct solution
            !
            x = x0
            do isol = 1,nvecs
                !x = x + y_dim(isol)*z(isol)
                x = x + y_dim(isol)*v(:,isol)
            end do

            !
            ! Test exit condition
            !
            if ( converged ) then
                exit
            else
                x0 = x
            end if

        end do   ! while

    end subroutine fgmres_autodiff
    !***************************************************************

end module mod_fgmres_standard


C23456789012345678901234567890123456789012345678901234567890123456789012
C11111111122222222223333333333444444444455555555556666666666777777777777
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C     UMAT_ECL_TEMP.for                                                C
C     Elasticity CLasical theory                                       C
C     Temperature dependent material properties                        C
C                                                                      C
C     SUBROUTINE UMAT                                                  C
C                                                                      C
C     ISOTROPIC ELASTICITY                                             C
C     CANNOT BE USED FOR PLANE STRESS                                  C
C     NTENS: LENGTH OF STRESS VECTOR                                   C
C     NDI:   NUMBER OF NORMAL STRESS COMPONENTS                        C
C                                                                      C
C     UNIVERSIDAD EAFIT                                                C
C     LABORATORIO DE MECANICA APLICADA                                 C
C     BLOQUE 14-PISO 2                                                 C
C     MEDELLIN, COLOMBIA                                               C
C                                                                      C
C     LAST UPDATED APRIL 16/2015                                       C
C                                                                      C
C     LOCAL ARRAYS                                                     C
C                                                                      C
C     PROPS(1) - E1                                                    C
C     PROPS(2).- E2                                                    C
C     PROPS(3) - G1                                                    C
C     PROPS(4) - G2                                                    C
C     PROPS(5) - CTE                                                   C
C                                                                      C
C     DDSDDE() - MATERIAL JACOBIAN                                     C
C     STRESS() - UPDATED STRESS VECTOR                                 C
C                                                                      C
C     STATE VARIABLES DEFINITION                                       C
C                                                                      C
C      1-4: Elastic strain vector                                      C
C      5-8: Thermal strain vector                                      C
C                                                                      C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      SUBROUTINE UMAT(STRESS, STATEV, DDSDDE, SSE, SPD, SCD, RPL,
     1DDSDDT, DRPLDE, DRPLDT, STRAN, DSTRAN, TIME, DTIME, TEMP,
     2DTEMP, PREDEF, DPRED, CMNAME, NDI, NSHR, NTENS, NSTATV,
     3PROPS, NPROPS, COORDS, DROT, PNEWDT, CELENT, DFGRD0,
     4DFGRD1, NOEL, NPT, LAYER, KSPT, KSTEP, KINC)
C
      INCLUDE 'ABA_PARAM.INC'
C
      CHARACTER*80 CMNAME
C
      DIMENSION STRESS(NTENS), STATEV(NSTATV),DDSDDE(NTENS, NTENS),
     1DDSDDT(NTENS),DRPLDE(NTENS),STRAN(NTENS),DSTRAN(NTENS),TIME(2),
     2PREDEF(1), DPRED(1), PROPS(NPROPS),COORDS(3),DROT(3, 3),
     3 DFGRD0(3, 3), DFGRD1(3, 3)
C
      DIMENSION DS(NTENS),DSTRTHER(NTENS),DSTRANM(NTENS),EELAS(NTENS),
     1ETHER(NTENS)
C
      PARAMETER (ZERO=0.D0, ONE=1.D0, TWO=2.D0, THREE=3.D0, SIX=6.0D0,
     1           ENUMAX=0.4999D0, NEWTON=10, TOLER=1.0D-7,MAXITER=30,
     2           FOUR=4.D0)
C
C**********************************************************************
C               C L A S S I C A L    E L A S T I C I T Y
C**********************************************************************
C
      DO K1=1, NTENS
        EELAS(K1)=STATEV(K1)
        ETHER(K1)=STATEV(K1+NTENS)
      END DO
C
C     Temperature at the end of the step
C
      THETA=TEMP
      DTHETA=DTEMP
C
C     Temperature Dependent Elastic properties
C
      EMOD=(PROPS(1)+PROPS(2)*THETA)*1000.0
C                              Shear modulus
      GMOD=(PROPS(3)+PROPS(4)*THETA)*1000.0
C                              Poisson's ratio
      ENU=(EMOD/(TWO*GMOD))-ONE
C                              Coefficient of thermal expansion
      CTE=PROPS(5)
C
      EBULK3=EMOD/(ONE-TWO*ENU)
      EG2=two*GMOD
      EG=GMOD
      EG3=THREE*EG
      ELAM=(EBULK3-EG2)/THREE
C
C     Elastic stiffness
C
      DO K1=1, 3
        DO K2=1, 3
          DDSDDE(K2, K1)=ELAM
        END DO
        DDSDDE(K1, K1)=EG2+ELAM
      END DO
      DO K1=4, 4
        DDSDDE(K1, K1)=EG
      END DO
C
C     Thermal strain increment
C
      CALL KCLEAR(DSTRTHER,NTENS,1)
      DO K1=1,NDI
        DSTRTHER(K1)=CTE*DTHETA
      END DO
C
C     Mechanical strain increment
C
      DO K1=1,NDI
        DSTRANM(K1)=DSTRAN(K1)-DSTRTHER(K1)
      END DO
      DSTRANM(NDI+1)=DSTRAN(NDI+1)
C
C     Elastic strain
C
      DO K1=1,NDI
        EELAS(K1)=EELAS(K1)+DSTRANM(K1)
        ETHER(K1)=ETHER(K1)+DSTRTHER(K1)
      END DO
C
C
C     Calculate the stress increment and
C     updates the stress vector.
C
      CALL KMAVEC(DDSDDE,NTENS,NTENS,DSTRANM,DS)
      CALL KUPDVEC(STRESS,NTENS,DS)
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C             M A T R I X   H A N D L I N G                            C
C-------------U T I L I T I E S   B L O C K--------------              C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE KCLEAR(A,N,M)                                        C
C      Clear a real matrix                                             C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE KCLEAR(A,N,M)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER(ZERO=0.0D0)
      DIMENSION A(N,M)
C
      DO I=1,N
        DO J=1,M
          A(I,J)=ZERO
        END DO
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE KMMULT(A,NRA,NCA,B,NRB,NCB,C)                        C
C      Real matrix product                                             C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE KMMULT(A,NRA,NCA,B,NRB,NCB,C)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(ZERO=0.D0)
      DIMENSION A(NRA,NCA),B(NRB,NCB),C(NRA,NCB)
C
      CALL KCLEAR(C,NRA,NCB)
      DUM=ZERO
      DO I=1,NRA
        DO J=1,NCB
         DO K=1,NCA
           DUM=DUM+A(I,K)*B(K,J)
          END DO
          C(I,J)=DUM
          DUM=ZERO
        END DO
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE KSMULT(A,NR,NC,S)                                    C
C      Matrix times a scalar.                                          C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE KSMULT(A,NR,NC,S)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION A(NR,NC)
C
      DO I=1,NR
        DO J=1,NC
          DUM=A(I,J)
          A(I,J)=S*DUM
          DUM=0.D0
        END DO
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE KUPDMAT(A,NR,NC,B)                                   C
C      Updates an existing matrix with an incremental matrix.          C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE KUPDMAT(A,NR,NC,B)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(ZERO=0.D0)
C
      DIMENSION A(NR,NC),B(NR,NC)
C
      DO I=1,NR
        DO J=1,NC
          DUM=A(I,J)
          A(I,J)=ZERO
          A(I,J)=DUM+B(I,J)
          DUM=ZERO
        END DO
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE KMTRAN(A,NRA,NCA,B)                                  C
C      Matrix transpose                                                C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE KMTRAN(A,NRA,NCA,B)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION A(NRA,NCA),B(NCA,NRA)
C
      CALL KCLEAR(B,NCA,NRA)
      DO I=1,NRA
       DO J=1,NCA
         B(J,I)=A(I,J)
        END DO
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE KMAVEC(A,NRA,NCA,B,C)                                C
C      Real matrix times vector                                        C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE KMAVEC(A,NRA,NCA,B,C)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(ZERO=0.D0)
      DIMENSION A(NRA,NCA),B(NCA),C(NRA)
C
      CALL KCLEARV(C,NRA)
C
      DO K1=1,NRA
        DO K2=1,NCA
          C(K1)=C(K1)+A(K1,K2)*B(K2)
        END DO
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE KCLEARV(A,N)                                         C
C      Clear a real vector                                             C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE KCLEARV(A,N)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER(ZERO=0.0D0)
C
      DIMENSION A(N)
C
      DO I=1,N
        A(I)=ZERO
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE KUPDVEC(A,NR,B)                                      C
C      Updates an existing vector with an incremental vector.          C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE KUPDVEC(A,NR,B)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(ZERO=0.D0)
C
      DIMENSION A(NR),B(NR)
C
      DO I=1,NR
        DUM=A(I)
        A(I)=ZERO
        A(I)=DUM+B(I)
        DUM=ZERO
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE KVECSUB(A,NRA,B,NRB,C)                               C
C      Substracts one column vector from another column vector         C
C      IFLAG=0 for substraction                                        C
C      IFLAG=1 for addition                                            C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE KVECSUB(A,NRA,B,NRB,C,IFLAG)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ONE=1.0D0, ONENEG=-1.0D0)
C
      DIMENSION A(NRA,1),B(NRB,1),C(NRB,1)
C
      SCALAR=ONENEG
C
      IF (IFLAG.EQ.1) SCALAR=ONE
C
      DO I=1,NRA
        C(I,1)=A(I,1)+B(I,1)*SCALAR
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE KMATSUB(A,NRA,NCA,B,C,IFLAG)                         C
C      Substracts one rectangular matrix from another rectangular      C
C      matrix                                                          C
C      IFLAG=0 for substraction                                        C
C      IFLAG=1 for addition                                            C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE KMATSUB(A,NRA,NCA,B,C,IFLAG)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ONE=1.0D0, ONENEG=-1.0D0)
C
      DIMENSION A(NRA,NCA),B(NRA,NCA),C(NRA,NCA)
C
      CALL KCLEAR(C,NRA,NCA)
C
      SCALAR=ONENEG
C
      IF (IFLAG.EQ.1) SCALAR=ONE
C
      DO I=1,NRA
        DO J=1,NCA
          C(I,J)=A(I,J)+B(I,J)*SCALAR
        END DO
      END DO
C
      RETURN
C
      END
C
C11111111122222222223333333333444444444455555555556666666666777777777777
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C     SUBROUTINE IDENTITY                                              C
C     CREATES AN IDENTITY MATRIX OF DIMENSIONS NDIM,NDIM               C
C                                                                      C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      SUBROUTINE KIDENTITY(DEL,NDIM)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER(ONE=1.D0)
C
      DIMENSION DEL(NDIM,NDIM)
C
      CALL KCLEAR(DEL,NDIM,NDIM)
C
      DO K1=1,NDIM
        DEL(K1,K1)=ONE
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE KINVERSE                                                 C
C                                                                      C
C   IVEERSE OF A MATRIX USING LU DECOMPOSITION                         C
C   TAKEN FROM NUMERICAL RECIPES By Press et al                        C
C                                                                      C
C   A   Matrix to be inverted.                                         C
C   Y   Inverse of A                                                   C
C   N   Dimension                                                      C
C                                                                      C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE KINVERSE(A,Y,NP,N)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ZERO=0.D0,ONE=1.D0)
C
      DIMENSION A(NP,NP),Y(NP,NP),INDX(NP),AUX(NP,NP)
C
      CALL KCLEAR(AUX,NP,NP)
      CALL KCOPYMAT(A,AUX,N)
C
      DO I=1,N
        DO J=1,N
          Y(I,J)=ZERO
        END DO
        Y(I,I)=ONE
      END DO
      CALL KLUDCMP(AUX,N,NP,INDX,D)
      DO J=1,N
        CALL KLUBKSB(AUX,N,NP,INDX,Y(1,J))
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE KLUDCMP                                                 C
C                                                                      C
C   LU MATRIX DECOMPOSITION                                            C
C   TAKEN FROM NUMERICAL RECIPES By Press et al                        C
C                                                                      C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE KLUDCMP(A,N,NP,INDX,D)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER(NMAX=500,TINY=1.0E-20,ZERO=0.D0,ONE=1.D0)
C
      DIMENSION INDX(N),A(NP,NP),VV(NMAX)
C
      D=ONE
      DO I=1,N
        AAMAX=ZERO
        DO J=1,N
          IF(ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
        END DO
        IF(AAMAX.EQ.0.) PAUSE 'SINGULAR MATRIX IN LUDCMP'
        VV(I)=ONE/AAMAX
      END DO
C
      DO J=1,N
        DO I=1,J-1
          SUM=A(I,J)
          DO K=1,I-1
            SUM=SUM-A(I,K)*A(K,J)
          END DO
          A(I,J)=SUM
        END DO
        AAMAX=ZERO
        DO I=J,N
          SUM=A(I,J)
          DO K=1,J-1
            SUM=SUM-A(I,K)*A(K,J)
          END DO
          A(I,J)=SUM
          DUM=VV(I)*ABS(SUM)
          IF(DUM.GE.AAMAX) THEN
             IMAX=I
             AAMAX=DUM
          END IF
        END DO
        IF(J.NE.IMAX) THEN
           DO K=1,N
             DUM=A(IMAX,K)
             A(IMAX,K)=A(J,K)
             A(J,K)=DUM
           END DO
           D=-D
           VV(IMAX)=-VV(J)
        END IF
        INDX(J)=IMAX
        IF(A(J,J).EQ.0.) A(J,J)=TINY
        IF(J.NE.N) THEN
           DUM=ONE/A(J,J)
           DO I=J+1,N
             A(I,J)=A(I,J)*DUM
           END DO
        END IF
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE KLUBKSB                                                 C
C                                                                      C
C   FORWARD SUBSTITUTION                                               C
C   TAKEN FROM NUMERICAL RECIPES By Press et al                        C
C                                                                      C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE KLUBKSB(A,N,NP,INDX,B)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ZERO=0.D0)
C
      DIMENSION INDX(N),A(NP,NP),B(NP)
C
      II=0
      DO I=1,N
        LL=INDX(I)
        SUM=B(LL)
        B(LL)=B(I)
        IF(II.NE.0) THEN
           DO J=II,I-1
             SUM=SUM-A(I,J)*B(J)
           END DO
        ELSE IF(SUM.NE.ZERO) THEN
           II=I
        END IF
        B(I)=SUM
      END DO
C
      DO I=N,1,-1
        SUM=B(I)
        DO J=I+1,N
          SUM=SUM-A(I,J)*B(J)
        END DO
        B(I)=SUM/A(I,I)
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C     SUBROUTINE KCOPYMAT                                              C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      SUBROUTINE KCOPYMAT(A,B,N)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      DIMENSION A(N,N),B(N,N)
C
      CALL KCLEAR(B,N,N)
C
      DO K1=1,N
        DO K2=1,N
          B(K1,K2)=A(K1,K2)
        END DO
      END DO
C
      RETURN
C
      END