!UA scheme for 4d Vlasov in Fluid-scaling with b(x)
!External E
!finite difference solver
!with new IMEX1 and IMEX2
program efd

use fft_m
use mesh_fields_m, only: fields_2d_t, mesh_t, init_mesh, init_fields
use particles_m, only: init_particles_2d, particles_t
use m6_compute_rho_m, only: compute_rho_m6_real

implicit none

type(mesh_t)      :: mesh
type(fields_2d_t) :: f
type(particles_t) :: p

integer, parameter :: ntau = 16
integer, parameter :: npp  = 204800

real(8)    :: xxt(2)
real(8)    :: bx
real(8)    :: ds
real(8)    :: interv
real(8)    :: dtau
real(8)    :: tau(ntau)
real(8)    :: ltau(ntau)
real(8)    :: energy
real(8)    :: Et(2,ntau)
real(8)    :: ave(2)
real(8)    :: ave2(2)
real(8)    :: ave3(2)

complex(8) :: pl(       ntau)
complex(8) :: ql(       ntau)
complex(8) :: xf( ntau,2)
complex(8) :: yf( ntau,2)
complex(8) :: gx(ntau,2)
complex(8) :: gy(ntau,2)
complex(8) :: temp(   ntau,2)
complex(8) :: tilde(  ntau,2)
complex(8) :: h(      ntau,2)
complex(8) :: r(      ntau,2)
complex(8) :: fx(     ntau,2)
complex(8) :: fy(     ntau,2)
complex(8) :: xt(     ntau,2)
complex(8) :: yt(     ntau,2)

real(8) :: time
real(8) :: xmin
real(8) :: xmax
real(8) :: ymin
real(8) :: ymax
integer :: istep
integer :: iplot
integer :: iargc
integer :: n,m
integer :: i
integer :: j
integer :: error

real(8) :: aux1, aux2

character(len=272) :: argv

integer, parameter :: nx = 128
integer, parameter :: ny = 64

integer(8) :: nbpart
integer    :: nstep

real(8) :: alpha
real(8) :: dt
real(8) :: dx
real(8) :: dy
real(8) :: ep
real(8) :: kx
real(8) :: ky
real(8) :: dimx
real(8) :: dimy
real(8) :: tfinal
real(8) :: pi
real(8) :: poids
real(8) :: x1, x2, v1, v2

complex(8), parameter :: im = (0d0, 1d0)

pi    = 4d0 * atan(1d0)
alpha = 0.05d0
kx    = 0.50_8
ky    = 1.0d0
dimx  = 2*pi/kx
dimy  = 2*pi/ky
poids = dimx * dimy

dx = dimx / nx
dy = dimy / ny

dt     = pi/2.d0/(2.0d0**3)!Used to determine N in MRC, not the macro-step
tfinal = pi/2.d0
nstep  = nint(tfinal/dt)

time  = 0.d0

ep   = 0.001d0
dtau = 2.0d0*pi/ntau

call init_fft( ntau, temp(:,1), tilde(:,1) )

m = ntau/2
ltau=(/ (n, n=0,m-1), (n, n=-m,-1 )/)
do i=1,ntau
  tau(i) = (i-1)*dtau
end do

xmin = 0.0_8; xmax = dimx
ymin = 0.0_8; ymax = dimy

nbpart = npp

call init_mesh( mesh, xmin, xmax, nx, ymin, ymax, ny )
call init_fields( f, mesh )
call init_particles_2d( p, nbpart, mesh, alpha, kx )

print"('ep = ', g15.3)", ep
print"('dt = ', g15.3)", dt

print*, sum(p%x(1,:)), sum(p%x(2,:)), sum(p%v(1,:)), sum(p%v(2,:))

do m=1,1!nbpart

    x1 = p%x(1,m)
    x2 = p%x(2,m)
    v1 = p%v(1,m)
    v2 = p%v(2,m)

    time  = 0.d0
    bx    = 1.d0+0.5d0*sin(x1)*sin(x2)
    ds    = dt*bx

    pl(1) = ds
    ql(1) = ds**2/2.0d0

    do i=2,ntau
        pl(i) = ep*im*(exp(-im*ltau(i)*ds/ep)-1.0d0)/ltau(i)
        ql(i) = ep*(ep*(1.0d0-exp(-im*ltau(i)*ds/ep))-im*ltau(i)*ds)/ltau(i)**2
    end do

    xt(:,1) = x1
    xt(:,2) = x2

    yt(:,1) = v1
    yt(:,2) = v2

    !--preparation initial data--
    temp(1,1) = v1/bx
    temp(1,2) = v2/bx
    do n=1,ntau
        h(n,1)=ep*(sin(tau(n))*temp(1,1)-cos(tau(n))*temp(1,2))
        h(n,2)=ep*(sin(tau(n))*temp(1,2)+cos(tau(n))*temp(1,1))
    end do

    xt(:,1)=x1+h(:,1)-h(1,1)
    xt(:,2)=x2+h(:,2)-h(1,2)!xt1st

    p%e(1,m)=(0.5d0*cos(x1/2.d0)*sin(x2))*(1.d0+0.5d0*sin(time))
    p%e(2,m)=(sin(x1/2.d0)*cos(x2))*(1.d0+0.5d0*sin(time))

    do n=1,ntau
        interv=(1.d0+0.5d0*sin(real(xt(n,1)))*sin(real(xt(n,2)))-bx)/bx
        r(n,1) =  interv*v2
        r(n,2) = -interv*v1
    end do
    print*, r(1,1), r(1,2)

    print*, sum(r)
    call fft(r, tilde)
    print*, sum(tilde)
    ave = real(tilde(1,:))/ep!dot{Y}_underline^0th

    print*, " ave : ", ave
    do n=2,ntau
        tilde(n,:)=-im*tilde(n,:)/ltau(n)
    end do

    tilde(1,:)=0.0d0
    call ifft( tilde, r)

    do n=1,ntau
        r(n,1)=ep*(sin(tau(n))*p%e(1,m)+cos(tau(n))*p%e(2,m))/bx+r(n,1)
        r(n,2)=ep*(sin(tau(n))*p%e(2,m)-cos(tau(n))*p%e(1,m))/bx+r(n,2)
    end do

    yt(:,1)=v1+(r(:,1)-r(1,1))
    yt(:,2)=v2+(r(:,2)-r(1,2))!yt1st

    print*, " yt : ",  sum(yt(:,1)), sum(yt(:,2))
    !--more preparation--

    do n=1,ntau
        temp(n,1)=ep*(cos(tau(n))*yt(n,1)+sin(tau(n))*yt(n,2))/bx
        temp(n,2)=ep*(cos(tau(n))*yt(n,2)-sin(tau(n))*yt(n,1))/bx
    end do

    call fft(temp, tilde)

    do n=2,ntau
        tilde(n,:)=-im*tilde(n,:)/ltau(n)
    end do

    tilde(1,:)=0.0d0
    call ifft(tilde, h)

    do n=1,ntau
        h(n,1)=h(n,1)-ep**2/bx*(-cos(tau(n))*ave(1)-sin(tau(n))*ave(2))
        h(n,2)=h(n,2)-ep**2/bx*(-cos(tau(n))*ave(2)+sin(tau(n))*ave(1))!h2nd
    end do

    xt(:,1)=x1+h(:,1)-h(1,1)
    xt(:,2)=x2+h(:,2)-h(1,2)!x2nd,residue O(eps^3)

    print*, " xt : ",  sum(xt(:,1)), sum(xt(:,2))

    p%e(1,m)=(0.5d0*cos(x1/2.d0)*sin(x2))*0.5d0*cos(time)
    p%e(2,m)=(sin(x1/2.d0)*cos(x2))*0.5d0*cos(time)!partial_tE

    print*, p%e(1,1), p%e(2,1)

    do n=1,ntau

        interv=(1.d0+0.5d0*sin(real(xt(n,1)))*sin(real(xt(n,2)))-bx)/bx

        fx(n,1)=interv*ave(2)
        fx(n,2)=-interv*ave(1)

        fy(n,1)=ep/bx*(sin(tau(n))*ave(1)-cos(tau(n))*ave(2))
        fy(n,2)=ep/bx*(cos(tau(n))*ave(1)+sin(tau(n))*ave(2))!partial_sh^1st

        interv=cos(x1)*sin(x2)*fy(n,1)+sin(x1)*cos(x2)*fy(n,2)

        fy(n,1)=interv/bx/2.d0*v2+fx(n,1)
        fy(n,2)=-interv/bx/2.d0*v1+fx(n,2)

        fx(n,1)=ep/bx**2*(-sin(tau(n))*p%e(2,m)+cos(tau(n))*p%e(1,m))
        fx(n,2)=ep/bx**2*(sin(tau(n))*p%e(1,m)+cos(tau(n))*p%e(2,m))

    end do

    temp = fy + fx
    print*, " fx   : ", sum(fx(:,1)), sum(fx(:,2))
    print*, " fy   : ", sum(fy(:,1)), sum(fy(:,2))
    print*, " temp : ", sum(temp)
    print*, ' ep   : ', ep
    print*, ' bx   : ', bx
    print*, ' ave  : ', ave
    stop

    call fft(temp, tilde)

    do n=2,ntau
        fx(n,:)=-im*tilde(n,:)/ltau(n)
        tilde(n,:)=-tilde(n,:)/ltau(n)**2
    end do

    fx(1,:)    = 0.0d0
    tilde(1,:) = 0.0d0

    call ifft(tilde, temp)

    r = - ep * temp

    call ifft(fx, fy)

    gx=fy!partial_sr^1st!!!
    do n=1,ntau
        tilde(n,1)=(cos(tau(n))*fy(n,1)+sin(tau(n))*fy(n,2))/bx
        tilde(n,2)=(cos(tau(n))*fy(n,2)-sin(tau(n))*fy(n,1))/bx
    end do

    call fft(tilde, temp)

    ave2=temp(1,:)/ntau!ddot{X_underline}!!!!
    do n=1,ntau

        p%e(1,m)=(0.5d0*cos(real(xt(n,1))/2.d0)*sin(real(xt(n,2))))*(1.d0+0.5d0*sin(time))
        p%e(2,m)=(sin(real(xt(n,1))/2.d0)*cos(real(xt(n,2))))*(1.d0+0.5d0*sin(time))

        interv=(1.d0+0.5d0*sin(real(xt(n,1)))*sin(real(xt(n,2)))-bx)/bx

        temp(n,1)=interv*yt(n,2)+ep/bx*(-sin(tau(n))*p%e(2,m)+cos(tau(n))*p%e(1,m))
        temp(n,2)=-interv*yt(n,1)+ep/bx*(sin(tau(n))*p%e(1,m)+cos(tau(n))*p%e(2,m))
    end do

    call fft( temp, tilde)

    xf(1,:)=tilde(1,:)/ep!dot{Y_underline}
    do n=2,ntau
        tilde(n,:)=-im*tilde(n,:)/ltau(n)
    end do
    tilde(1,:)=0.0d0
    call ifft(tilde, temp)
    r=r+temp

    yt(:,1)=v1+r(:,1)-r(1,1)
    yt(:,2)=v2+r(:,2)-r(1,2)

    !----end more preparation
    !--even more preparation--

    do n=1,ntau
        temp(n,1)=(cos(tau(n))*r(n,1)+sin(tau(n))*r(n,2))/bx
        temp(n,2)=(cos(tau(n))*r(n,2)-sin(tau(n))*r(n,1))/bx
    end do

    call fft( temp, tilde)

    temp(1,:)=tilde(1,:)
    ave3=temp(1,:)!dot{X_underline}!!!
    interv=cos(x1)*sin(x2)*temp(1,1)+sin(x1)*cos(x2)*temp(1,2)

    fx(1,1)=interv/ep/bx*v2/2.d0
    fx(1,2)=-interv/ep/bx*v1/2.d0

    do n=1,ntau
        temp(n,1)=(1.d0+0.5d0*sin(real(xt(n,1)))*sin(real(xt(n,2)))-bx)/bx
    end do

    call fft(temp(:,1), tilde(:,1))

    fx(1,1)=fx(1,1)+tilde(1,1)/ep*ave(2)
    fx(1,2)=fx(1,2)-tilde(1,1)/ep*ave(1)!ddot{Y}_underline^0th!!!!

    do n=1,ntau
        yf(n,:)=xf(1,:)+fy(n,:)
        temp(n,1)=(cos(tau(n))*yf(n,1)+sin(tau(n))*yf(n,2))
        temp(n,2)=(cos(tau(n))*yf(n,2)-sin(tau(n))*yf(n,1))
    end do

    call fft( temp, tilde)

    do n=2,ntau
        tilde(n,:)=-im*tilde(n,:)/ltau(n)
    end do

    tilde(1,:)=0.0d0

    call ifft( tilde, temp)

    do n=1,ntau
        fy(n,1)=temp(n,1)*ep/bx-ep**2/bx*(-cos(tau(n))*fx(1,1)-sin(tau(n))*fx(1,2))
        fy(n,2)=temp(n,2)*ep/bx-ep**2/bx*(-cos(tau(n))*fx(1,2)+sin(tau(n))*fx(1,1))!partial_sh2!!!
    end do

    call fft( fy, tilde)

    do n=2,ntau
        tilde(n,:)=-im*tilde(n,:)/ltau(n)
    end do
    tilde(1,:)=0.0d0

    call ifft( tilde, temp)

    h=-ep*temp

    do n=1,ntau
        temp(n,1)=ep*(cos(tau(n))*yt(n,1)+sin(tau(n))*yt(n,2))/bx
        temp(n,2)=ep*(cos(tau(n))*yt(n,2)-sin(tau(n))*yt(n,1))/bx
    end do

    call fft( temp, tilde)

    do n=2,ntau
        tilde(n,:)=-im*tilde(n,:)/ltau(n)
    end do

    tilde(1,:)=0.0d0

    call ifft( tilde, temp)

    h = h + temp

    xt(:,1)=x1+h(:,1)-h(1,1)
    xt(:,2)=x2+h(:,2)-h(1,2)

    !--end even more
    !--iteration
    do istep = 1, nstep

        !---imex2 New---
        call compute_fy( xt, yt)

        gy=yt+ds/2.d0*fy

        call fft( gy, fy)

        do n=1,ntau
            fy(n,:)=fy(n,:)/(1.0d0+im*ds/2.d0*ltau(n)/ep)
        end do

        call ifft( fy, yf)!yt(tn+1/2)

        do n=1,ntau
            fx(n,1)=(cos(tau(n))*yf(n,1)+sin(tau(n))*yf(n,2))/bx
            fx(n,2)=(cos(tau(n))*yf(n,2)-sin(tau(n))*yf(n,1))/bx
        end do

        gx = xt + ds/2.d0 * fx

        call fft( gx, fx)

        do n=1,ntau
            fx(n,:)=fx(n,:)/(1.0d0+im*ds/2.d0*ltau(n)/ep)
        end do

        call ifft( fx, xf)!xt(tn+1/2)

        time = time + dt/2.d0

        call compute_fy( xf, yf)

        call fft( fy, gy)
        call fft( yt, yf)

        do n=1,ntau
            fy(n,:)=(yf(n,:)*(1.0d0-im*ds/ep/2.0d0*ltau(n)) &
&            +ds*gy(n,:))/(1.0d0+im*ds/2.0d0*ltau(n)/ep)
        end do

        yf=yt

        call ifft( fy, yt)!yt(tn+1)

        yf=(yt+yf)/2.d0
        do n=1,ntau
            fx(n,1)=(cos(tau(n))*yf(n,1)+sin(tau(n))*yf(n,2))/bx
            fx(n,2)=(cos(tau(n))*yf(n,2)-sin(tau(n))*yf(n,1))/bx
        end do

        call fft( fx, gx)
        call fft( xt, xf)

        do n=1,ntau
            fx(n,:)=(xf(n,:)*(1.0d0-im*ds/ep/2.0d0*ltau(n)) &
        &       +ds*gx(n,:))/(1.0d0+im*ds/2.0d0*ltau(n)/ep)
        end do

        call ifft( fx, xt)!xt(tn+1)

        time=time+dt/2.d0

        !---end imex2 New---

    end do

    call fft( xt,tilde)

    temp(1,:)=0.d0
    do n=1,ntau
        temp(1,:)=temp(1,:)+tilde(n,:)*exp(im*ltau(n)*tfinal*bx/ep)
    end do

    xxt=real(temp(1,:))

    call apply_bc()

    p%x(1,m) = xxt(1)
    p%x(2,m) = xxt(2)

    call fft(yt,tilde)

    temp(1,:)=0.d0
    do n=1,ntau
        temp(1,:)=temp(1,:)+tilde(n,:)*exp(im*ltau(n)*tfinal*bx/ep)
    end do

    p%v(1,m)=real(cos(tfinal*bx/ep)*temp(1,1)+sin(tfinal*bx/ep)*temp(1,2))
    p%v(2,m)=real(cos(tfinal*bx/ep)*temp(1,2)-sin(tfinal*bx/ep)*temp(1,1))

end do
print*, sum(p%v(1,:))+857.95049281063064, sum(p%v(2,:))+593.40700170710875

call compute_rho_m6_real(f, p)
stop
open(unit=851,file='UA3ep0001T1.dat')
do i=1,nx
do j=1,ny
write(851,*)i*dx, j*dy, f%rho(i,j)
end do
write(851,*)
end do
close(851)
!call calcul_energy( p, f,energy )
!open(unit=851,file='UA3ep0001T1v.dat')
!do i=1,nx
!do j=1,ny
!write(851,*)i*dx, j*dy, f%rho(i,j)
!end do
!write(851,*)
!end do
!close(851)

contains

subroutine compute_fy( xt, yt )

    complex(8) :: xt(:,:)
    complex(8) :: yt(:,:)

    do n=1,ntau
        Et(1,n)=(0.5d0*cos(real(xt(n,1))/2.d0)*sin(real(xt(n,2))))*(1.d0+0.5d0*sin(time))
        Et(2,n)=(cos(real(xt(n,2)))*sin(real(xt(n,1))/2.d0))*(1.d0+0.5d0*sin(time))
        interv=(1.d0+0.5d0*sin(real(xt(n,1)))*sin(real(xt(n,2)))-bx)/bx/ep
        temp(n,1)=(cos(tau(n))*Et(1,n)-sin(tau(n))*Et(2,n))/bx
        temp(n,2)=(cos(tau(n))*Et(2,n)+sin(tau(n))*Et(1,n))/bx
        fy(n,1)=temp(n,1)+interv*yt(n,2)
        fy(n,2)=temp(n,2)-interv*yt(n,1)
    end do

end subroutine compute_fy

subroutine apply_bc()

    do while ( xxt(1) > xmax )
        xxt(1) = xxt(1) - dimx
    end do

    do while ( xxt(1) < xmin )
        xxt(1)= xxt(1) + dimx
    end do

    do while ( xxt(2) > ymax )
        xxt(2)  = xxt(2)  - dimy
    end do

    do while ( xxt(2)  < ymin )
        xxt(2) = xxt(2)  + dimy
    end do

end subroutine apply_bc

end program efd


!  SFM  04/06/2013  Code module added for WOlson
!
      SUBROUTINE RADTRAN(UMU, NLYR, TB, BTEMP, LYRTEMP, LYRHGT, KEXT,
     $                  SALB, ASYM, FISOT, EMIS, EBAR, LAMBERT, PRNT)
C
C     CHRIS KUMMEROW
C     INCLUDES ASYMPTOTIC EXPRESSIONS FOR TERM3, TERM4, AND TERM5 IN
C     THE LIMIT OF SMALL EFFECTIVE OPTICAL DEPTHS; BILL OLSON FEB, 1995.
C
!     WSO 04/07/2013  large layer optical depth numerics (double precision) on outgoing radiance
!     WSO 04/07/2013  delta-eddington option
!     WSO 04/07/2013  there are many code changes relative to radtran.f, here

      implicit none

      INTEGER *4 MAXLYR
      PARAMETER    ( MAXLYR = 80 )

      CHARACTER*1  POLN
      LOGICAL LAMBERT, PRNT(3)
      integer ier, imode, icode
      INTEGER NLYR, I, J, NANG, NN
      REAL  UMU, BTEMP, LYRTEMP(0:MAXLYR), LYRHGT(0:MAXLYR),
     $      KEXT(MAXLYR), SALB(MAXLYR), ASYM(MAXLYR)
      REAL  FISOT, EMIS, EBAR

      logical delta
      real *8 fdelta
      real *8 kext_delta(maxlyr)
      real *8 salb_delta(maxlyr)
      real *8 asym_delta(maxlyr)

      real *8 l(maxlyr)
      real *8 h(maxlyr)
      real *8 b0(maxlyr)
      real *8 b1(maxlyr)
      real *8 w(2*maxlyr, 2*maxlyr)
      real *8 btempd
      real *8 bb(2*maxlyr)
      real *8 dp(maxlyr)
      real *8 dm(maxlyr)
      real *8 z(0:maxlyr)
      real *8 mu
      real *8 nu
      real *8 x(2*maxlyr)
      real *8 fisotd
      real *8 emisd
      real *8 ebard

      real *8 xa
      real *8 xb
      real *8 xc
      real *8 xd
      real *8 ya
      real *8 yb
      real *8 yc
      real *8 dz
      real *8 xnu

      real *4 XIUP
      real *4 I_IN(maxlyr+1, 100)
      real *4 IOUT(0:maxlyr)
      real *4 TERM1
      real *4 TERM2
      real *4 TERM3
      real *4 TERM4
      real *4 TERM5
      real *4 TERM4prime
      real *4 TERM5prime
      real *4 tb

!delta-Eddington option
      delta = .false.
      if(.not. delta) then
        do i = 1, nlyr
          kext_delta(i) = dble(kext(i))
          salb_delta(i) = dble(salb(i))
          asym_delta(i) = dble(asym(i))
        end do
      else
        do i = 1, nlyr
          fdelta = dble(asym(i) * asym(i))
          kext_delta(i) = dble((1. - salb(i) * fdelta) * kext(i))
          salb_delta(i) = dble((1. - fdelta) * salb(i) /
     $     (1. - salb(i) * fdelta))
          asym_delta(i) = dble(asym(i) / (1. + asym(i)))
        end do
      end if

      fisotd = dble(fisot)
      emisd = dble(emis)
      ebard = dble(ebar)
      btempd = dble(btemp)

C
c      write(6,'(1x,"umu:  ",f7.2,"  nlyr: ",i5,"  tb: ",f7.2,
c     + "  btemp: ",f7.2,"  fisot: ",f7.2,
c     + /1x,"emis: ",f10.3,"  ebar: ",f10.3,"  lamb: ",l5,
c     + /1x,"  lyrtemp(0): ",f7.2,"  lyrhgt(0): ",f7.2)')
c     + umu,nlyr,tb,btemp,fisot,emis,ebar,lambert,lyrtemp(0),
c     + lyrhgt(0)
c      do j=nlyr,1,-1
c      write(6,'(1x,"lyrtemp: ",f7.2,"  lyrhgt: ",f7.2,
c     + "  kext: ",f10.4,"  salb: ",f10.4,"  asym: ",f10.4)')
c     + lyrtemp(j),lyrhgt(j),kext(j),salb(j),asym(j)
c      end do
C                                CALCULATE SOME CONSTANTS
      Z(0) = dble(LYRHGT(0))
      DO 20  J = 1,NLYR
        Z(J)  = dble(LYRHGT(J))
        B0(J) = dble(LYRTEMP(J-1))
        B1(J) = dble((LYRTEMP(J) - LYRTEMP(J-1))/
     $   (LYRHGT(J) - LYRHGT(J-1)))
        L(J) = dsqrt(3.*KEXT_delta(J)*KEXT_delta(J)*
     $         (1. - SALB_delta(J))*
     $         (1. - SALB_delta(J)*ASYM_delta(J)))
        H(J) = dble(1.5*KEXT_delta(J)*
     $   (1. - SALB_delta(J)*ASYM_delta(J)))
  20  CONTINUE

C     FILL IN THE MATRIX ELEMENTS WHICH FORM THE BOUNDARY CONDITIONS
C     AT THE TOP, BOTTOM AND LAYER INTERFACES OF THE CLOUD.  THERE ARE
C     TWO QUANTITIES, D+ "DP", AND D- "DM" AT EACH BOUNDARY, SO THE
C     MATRIX HAS DIMENSIONS  2*NLYR BY 2*NLYR.
C     ORDER OF D'S:  D+(1),D-(1),D+(2),D-(2), .... , D+(NLYR),D-(NLYR)

C     SET ALL MATRIX ELEMENTS TO ZERO
      DO 45  I = 1,2*NLYR
       DO 45  J = 1,2*NLYR
        W(I,J) = 0.d0
  45  CONTINUE

C     FILL IN THE NON-ZERO MATRIX ELEMENTS
      W(1,1)   = ((ebard - 2.d0)*L(1)/H(1)) + ebard
      W(1,2)   = ((2.d0 - ebard)*L(1)/H(1)) + ebard
      DO 50  I = 2,2*(NLYR-1),2
       W(I,I-1)   =
     $  (1.d0 - L(I/2)/H(I/2))*dexp(+L(I/2)*(Z(I/2)-Z(I/2-1)))
       W(I,I  )   =  (1.d0 + L(I/2)/H(I/2))*
     $  dexp(-L(I/2)*(Z(I/2)-Z(I/2-1)))
       W(I,I+1)   = -(1.d0 - L(I/2+1)/H(I/2+1))
       W(I,I+2)   = -(1.d0 + L(I/2+1)/H(I/2+1))

       W(I+1,I-1) =  (1.d0 + L(I/2)/H(I/2))*
     $  dexp(+L(I/2)*(Z(I/2)-Z(I/2-1)))
       W(I+1,I)   =  (1.d0 - L(I/2)/H(I/2))*
     $  dexp(-L(I/2)*(Z(I/2)-Z(I/2-1)))
       W(I+1,I+1) = -(1.d0 + L(I/2+1)/H(I/2+1))
       W(I+1,I+2) = -(1.d0 - L(I/2+1)/H(I/2+1))
c        write(*,*) (w(i,i+j),j=-2,2)
  50  CONTINUE
      W(2*NLYR,2*NLYR-1) =  (1.d0 + L(NLYR)/H(NLYR))*dexp(+L(NLYR)*
     $                       (Z(NLYR)-Z(NLYR-1)))
      W(2*NLYR,2*NLYR)   =  (1.d0 - L(NLYR)/H(NLYR))*dexp(-L(NLYR)*
     $                       (Z(NLYR)-Z(NLYR-1)))

C     FILL IN THE ROW OF CONSTANTS IN THE LINEAR EQUATIONS
      BB(1)    = ebard*btempd - ebard*B0(1) - (ebard - 2.d0)*B1(1)/H(1)
      DO 55  I = 2,2*(NLYR-1),2
       BB(I)   =  + B1(I/2)/H(I/2) - B1(I/2+1)/H(I/2+1)
       BB(I+1) =  - B1(I/2)/H(I/2) + B1(I/2+1)/H(I/2+1)
  55  CONTINUE
      BB(2*NLYR)  =  fisotd - B0(NLYR) - B1(NLYR)*(Z(NLYR)
     $               - Z(NLYR-1) + 1.d0/H(NLYR))
C
C
C     MATRIX INVERSION IN DONE IN SUBROUTINE LINPAK
c      write(*,*) bb
c      write(*,*) b1
c      stop
      imode=0
      call band(imode,2*nlyr,w,bb,icode)
!      call linsysa(w,bb,x,2*nlyr,2*maxlyr,ier)

!     CALL LINPAK(NLYR, W, BB, RCOND)
!      do i=1,2*nlyr
!         write(*,*) x(i), bb(i)
!      enddo
!      stop
!

      do i=1,2*nlyr
!         bb(i)=x(i)
      enddo
!      do i = 1, nlyr
!        write(*, '("i: ", i5, "  bbim1: ", e15.6,
!     $   "  bbi: ", e15.6)') i, bb(2*i-1), bb(2*i)
!      enddo
c     write(*,*) bb
c     stop
C
c     WRITE(*,*) ' '
c     IF ( PRNT(2) ) WRITE(4,*) ' '
      DO 60  I = 1,NLYR
       DP(I) = BB(2*I-1)
       DM(I) = BB(2*I)
c       WRITE(6,653) I, DP(I), I, DM(I)
c       IF ( PRNT(2) )  WRITE(4,653) I, DP(I), I, DM(I)
  60  CONTINUE
 653  FORMAT(10X,'D+ (',I2,') = ',E11.4,6X,'D-(',I2,') = ',E11.4)

C     AFTER D'S ARE KNOWN, CALCULATE SURFACE RADIANCE

      MU = dble(UMU)
      NU = dble(-UMU)
C     FOR THE FOLLOWING CALCULATIONS, REFER TO APPENDIX B OF THESIS
C     *********************************************************************

      IF ( LAMBERT ) THEN
C      CALCULATE THE DOWNWELLING FLUX THROUGH THE ATMOSPHERE AT 81 ANGLES
       NANG = 81
       DO 997  NN = 1,NANG
        XNU = -(2.d0*NN - 1.d0)/(NANG*2.d0)
        I_IN(NLYR+1,NN) = fisotd
C       LOOP THROUGH THE REMAINING LAYERS
        DO 100  J = NLYR,1,-1
C        CALCULATE RADIANCE FROM TOP OF LAYER "J"
         XA = B0(J) - 1.5d0*SALB_delta(J)*ASYM_delta(J)*XNU*B1(J)/H(J)
         XB = B1(J)
         XC = SALB_delta(J)*DP(J)*
     $    (1.d0 - 1.5d0*ASYM_delta(J)*XNU*L(J)/H(J))
         XD = SALB_delta(J)*DM(J)*
     $    (1.d0 + 1.5d0*ASYM_delta(J)*XNU*L(J)/H(J))
         YA = KEXT_delta(J)/XNU
         YB = YA + L(J)
         YC = YA - L(J)
         DZ = Z(J) - Z(J-1)

         TERM1 = I_IN(J+1,NN)*dexp(YA*DZ)
         TERM2 = XA*(1. - dexp(YA*DZ))
c     new tests
         if(dabs(ya*dz) .lt. 1.d-5) then
           term3=-xb*ya*dz*dz
         else
           TERM3 = XB/YA*(dexp(YA*DZ)*(1.d0 - YA*DZ) - 1.d0)
         end if
         if(dabs(yb*dz) .lt. 1.d-5) then
           term4=-xc*ya*dz
         else
           TERM4 = XC*YA/YB*(1.d0 - dexp(YB*DZ))
         end if
         if(dabs(yc*dz) .lt. 1.d-5) then
           term5=-xd*ya*dz
         else
           TERM5 = XD*YA/YC*(1.d0 - dexp(YC*DZ))
         end if
         I_IN(J,NN) = TERM1 + TERM2 + TERM3 + TERM4 + TERM5
!        write(6,'(1x,"lev: ",i5,"  ang: ",i5,"  term1: ",f10.4,
!     +            "  term2: ",f10.4,"  term3: ",f10.4,"  term4: ",f10.4,
!     +            "  term5: ",f10.4,"  tbdn: ",f7.2)')
!     +   j,nn,term1,term2,term3,term4,term5,i_in(j,nn)
  100   CONTINUE
  997  CONTINUE
C
C      CALCULATE THE TOTAL DOWNWELLING FLUX REACHING THE SURFACE
       XIUP = 0.
       DO 47  NN = 1,NANG
        XIUP = XIUP + I_IN(1,NN)*(1./NANG)*(2.*NN-1.)/(2.*NANG)
  47   CONTINUE
       XIUP = 2.*XIUP
c       write(6,'(1x,"xiup: ",f7.2)') xiup
C
      ELSE

C      CALCULATE THE DOWNWELLING FLUX THROUGH THE ATMOSPHERE AT ANGLE MU
       NN = 22                      ! THIS IS A DUMMY INDEX
       I_IN(NLYR+1,NN) = fisotd
C      LOOP THROUGH THE REMAINING LAYERS
       DO 110  J = NLYR,1,-1
C       CALCULATE RADIANCE FROM TOP OF LAYER "J"
        XA = B0(J) - 1.5d0*SALB_delta(J)*ASYM_delta(J)*NU*B1(J)/H(J)
        XB = B1(J)
        XC = SALB_delta(J)*DP(J)*
     $   (1.d0 - 1.5d0*ASYM_delta(J)*NU*L(J)/H(J))
        XD = SALB_delta(J)*DM(J)*
     $   (1.d0 + 1.5d0*ASYM_delta(J)*NU*L(J)/H(J))
        YA = KEXT_delta(J)/NU
        YB = YA + L(J)
        YC = YA - L(J)
        DZ = Z(J) - Z(J-1)

        TERM1 = I_IN(J+1,NN)*dexp(YA*DZ)
        TERM2 = XA*(1. - dexp(YA*DZ))
c     new tests
        if(dabs(ya*dz) .lt. 1.d-5) then
          term3=-xb*ya*dz*dz
        else
          TERM3 = XB/YA*(dexp(YA*DZ)*(1.d0 - YA*DZ) - 1.d0)
        end if
        if(dabs(yb*dz) .lt. 1.d-5) then
          term4=-xc*ya*dz
        else
          TERM4 = XC*YA/YB*(1. - dexp(YB*DZ))
        end if
        if(abs(yc*dz) .lt. 1.d-5) then
          term5=-xd*ya*dz
        else
          TERM5 = XD*YA/YC*(1.d0 - dexp(YC*DZ))
        end if
        I_IN(J,NN) = TERM1 + TERM2 + TERM3 + TERM4 + TERM5
!        write(*, '("down layer: ", i5, "  i_in: ", e15.6,
!     $   "  ya: ", e15.6, "  dz: ", e15.6, "  exp(ya*dz): ", e15.6,
!     $   "  yc: ", e15.6, "  exp(yc*dz): ", e15.6, "  term1: ", e15.6,
!     $   "  term2: ", e15.6, "  term3: ", e15.6,
!     $   "  term4: ", e15.6, "  term5: ", e15.6)')
!     $   J, I_IN(J+1,NN), YA, DZ, dexp(YA*DZ), YC, dexp(YC*DZ),
!     $   TERM1, TERM2, TERM3, TERM4, TERM5
  110  CONTINUE
       XIUP = I_IN(1,22)
C
      ENDIF

C
C
      IOUT(0) = emisd*btempd + (1.d0 - emisd)*XIUP
      DO 101  J = 1,NLYR
C      CALCULATE THE UPWELLING RADIANCES AT THE TOP OF EACH LAYER J
       XA = B0(J) - 1.5d0*SALB_delta(J)*ASYM_delta(J)*MU*B1(J)/H(J)
       XB = B1(J)
       XC = SALB_delta(J)*DP(J)*
     $  (1.d0 - 1.5d0*ASYM_delta(J)*MU*L(J)/H(J))
       XD = SALB_delta(J)*DM(J)*
     $  (1.d0 + 1.5d0*ASYM_delta(J)*MU*L(J)/H(J))
       YA = KEXT_delta(J)/MU
       YB = YA + L(J)
       YC = YA - L(J)
       DZ = Z(J) - Z(J-1)

       TERM1 = IOUT(J-1)*dexp(-YA*DZ)
       TERM2 = XA*(1.d0 - dexp(-YA*DZ))
c     new tests
       if(dabs(ya*dz) .lt. 1.d-5) then
         term3=0.
       else
         TERM3 = XB/YA*(YA*DZ - 1.d0 + dexp(-YA*DZ))
       end if
       if(dabs(yb*dz) .lt. 1.d-5) then
         TERM4=xc*ya*dz*dexp(-ya*dz)
       else
         TERM4 = XC*YA/YB*(dexp((YB-YA)*DZ) - dexp(-YA*DZ))
       end if
       if(dabs(yc*dz) .lt. 1.d-5) then
         TERM5=xd*ya*dz*dexp(-ya*dz)
         TERM5prime=xd*ya*dz*dexp(-ya*dz)
       else
!modification for large optical depth in layer
         TERM5 = XD*YA/YC*dexp(-YA*DZ)*(dexp(YC*DZ) - 1.d0)
         TERM5prime = XD*YA/YC*(dexp(-L(J)*DZ) - dexp(-YA*DZ))
       end if
!       IOUT(J) = TERM1 + TERM2 + TERM3 + TERM4 + TERM5
!        write(*, '("up   layer: ", i5, "  i_ou: ", e13.6,
!     $   "  ya: ", e13.6, "  exp: ", e13.6, "  L: ", e13.6,
!     $   "  yb: ", e13.6, "  exp: ", e13.6, "  term1: ", e13.6,
!     $   "  term2: ", e13.6, "  term3: ", e13.6,
!     $   "  term4: ", e13.6, "  term5: ", e13.6, "  term5prime: ", e13.6)')
!     $   J, IOUT(J-1), YA, dexp(-YA*DZ), L(J), YB, dexp(-L(J)*DZ),
!     $   TERM1, TERM2, TERM3, TERM4, TERM5, TERM5prime
       IOUT(J) = TERM1 + TERM2 + TERM3 + TERM4 + TERM5prime
  101 CONTINUE
C
C
c      WRITE(*,*) ' '
c      IF ( PRNT(2) )  WRITE(4,*) ' '
      DO 44  J = 0,NLYR
c       WRITE(*,77) NLYR+1-J, I_IN(NLYR+1-J,22), NLYR-J, IOUT(NLYR-J)
c       IF ( PRNT(2) ) WRITE(4,77) NLYR+1-J, I_IN(NLYR+1-J,22),
c     $                NLYR-J, IOUT(NLYR-J)
  44  CONTINUE
  77  FORMAT(10X,'Iin(',I2,') = ',F7.1,10X,'Iout(',I2,') = ',F7.1)

C
      TB = IOUT(NLYR)
!      write(*,*) tb
      RETURN
      END


c
c
c     =====================================================
      subroutine rpt2(ixy,maxm,meqn,mwaves,mbc,mx,
     &                  ql,qr,aux1,aux2,aux3,
     &			imp,asdq,bmasdq,bpasdq)
c     =====================================================
      implicit double precision (a-h,o-z)
c
c     # Riemann solver in the transverse direction for the Euler
c     # equations  on a curvilinear grid.
c
c     # Split asdq (= A^* \Delta q, where * = + or -)
c     # into down-going flux difference bmasdq (= B^- A^* \Delta q)
c     #    and up-going flux difference bpasdq (= B^+ A^* \Delta q)
c
c     # Use the same idea as in rpn2 but now rotate into the direction
c     # normal to the cell edge above or below this cell.
c
c     # Uses Roe averages
c
      dimension     ql(1-mbc:maxm+mbc, meqn)
      dimension     qr(1-mbc:maxm+mbc, meqn)
      dimension   asdq(1-mbc:maxm+mbc, meqn)
      dimension bmasdq(1-mbc:maxm+mbc, meqn)
      dimension bpasdq(1-mbc:maxm+mbc, meqn)
      dimension   aux1(1-mbc:maxm+mbc, 7)
      dimension   aux2(1-mbc:maxm+mbc, 7)
      dimension   aux3(1-mbc:maxm+mbc, 7)
c
      parameter (maxm2 = 502)  !# assumes at most 500x500 grid with mbc=2
      dimension delta(4)
      dimension u2v2(-1:maxm2),
     &       u(-1:maxm2),v(-1:maxm2),enth(-1:maxm2),a(-1:maxm2),
     &       g1a2(-1:maxm2),euv(-1:maxm2)
      dimension ax(-1:maxm2)
      dimension ay(-1:maxm2)
      dimension wave(-1:maxm2, 4, 3)
      dimension    s(-1:maxm2, 3)
      common /param/ gamma, gamma1
c
      if (-1.gt.1-mbc .or. maxm2 .lt. maxm+mbc) then
	 write(6,*) 'need to increase maxm2 in rpt2'
	 stop
      endif
c
c
      if (ixy.eq.1) then
          inx = 4
          iny = 5
          ilenrat = 6
        else
          inx = 1
          iny = 2
          ilenrat = 3
        endif
c
c        # imp is used to flag whether wave is going to left or right,
c        # since states and grid orientation are different on each side.
c
         if (imp.eq.1) then
c            # asdq = amdq, moving to left
             ix1 = 2-mbc
	     ixm1 = mx+mbc
           else
c            # asdq = apdq, moving to right
             ix1 = 1-mbc
	     ixm1 = mx+mbc
           endif
c
c        --------------
c        # up-going:
c        --------------
c

c       # determine rotation matrix for interface above cell, using aux3
c               [ ax  ay ]
c               [-ay  ax ]
c
        do i=ix1,ixm1
c
         if (imp.eq.1) then
             i1 = i-1
           else
             i1 = i
           endif
c
           ax(i) = aux3(i1,inx)
           ay(i) = aux3(i1,iny)
	   pres = gamma1*(ql(i1,4)  - 0.5d0*(ql(i1,2)**2 +
     &            ql(i1,3)**2)/ql(i1,1))
           u(i) = (ax(i)*ql(i1,2) + ay(i)*ql(i1,3)) / ql(i1,1)
           v(i) = (-ay(i)*ql(i1,2) + ax(i)*ql(i1,3)) / ql(i1,1)
	   enth(i) = (ql(i1,4)+pres) / ql(i1,1)
	   u2v2(i) = u(i)**2 + v(i)**2
           a2 = gamma1*(enth(i) - .5d0*u2v2(i))
           a(i) = dsqrt(a2)
	   g1a2(i) = gamma1 / a2
	   euv(i) = enth(i) - u2v2(i)
           enddo
c
c
c     # now split asdq into waves:
c
      do 20 i = ix1,ixm1
         delta(1) = asdq(i,1)
         delta(2) = ax(i)*asdq(i,2) + ay(i)*asdq(i,3)
         delta(3) = -ay(i)*asdq(i,2) + ax(i)*asdq(i,3)
         delta(4) = asdq(i,4)

         a3 = g1a2(i) * (euv(i)*delta(1)
     &      + u(i)*delta(2) + v(i)*delta(3) - delta(4))
         a2 = delta(3) - v(i)*delta(1)
         a4 = (delta(2) + (a(i)-u(i))*delta(1) - a(i)*a3) / (2.d0*a(i))
         a1 = delta(1) - a3 - a4

c
c        # Compute the waves.
c
         wave(i,1,1) = a1
         wave(i,2,1) = a1*(u(i)-a(i))
         wave(i,3,1) = a1*v(i)
         wave(i,4,1) = a1*(enth(i) - u(i)*a(i))
         s(i,1) = (u(i)-a(i))
c
         wave(i,1,2) = a3
         wave(i,2,2) = a3*u(i)
         wave(i,3,2) = a3*v(i) + a2
         wave(i,4,2) = a3*0.5d0*u2v2(i)  + a2*v(i)
         s(i,2) = u(i)
c
         wave(i,1,3) = a4
         wave(i,2,3) = a4*(u(i)+a(i))
         wave(i,3,3) = a4*v(i)
         wave(i,4,3) = a4*(enth(i)+u(i)*a(i))
         s(i,3) = (u(i)+a(i))

   20    continue
c
c
c    # compute flux difference bpasdq
c    --------------------------------
c
      do 40 m=1,meqn
         do 40 i=ix1,ixm1
	    bpasdq(i,m) = 0.d0
	    do 30 mw=1,mwaves
	       bpasdq(i,m) = bpasdq(i,m) + dmax1(s(i,mw),0.d0)
     &                        *wave(i,m,mw)*aux3(i1,ilenrat)
   30          continue
   40       continue
c
c     # rotate momentum components:
      do 50 i=ix1,ixm1
	 bpasdq2 = ax(i)*bpasdq(i,2) - ay(i)*bpasdq(i,3)
	 bpasdq3 = ay(i)*bpasdq(i,2) + ax(i)*bpasdq(i,3)
	 bpasdq(i,2) = bpasdq2
	 bpasdq(i,3) = bpasdq3
   50    continue
c
c        --------------
c        # down-going:
c        --------------
c

c       # determine rotation matrix for interface below cell, using aux2
c               [ ax  ay ]
c               [-ay  ax ]
c
        do i=ix1,ixm1
c
         if (imp.eq.1) then
             i1 = i-1
           else
             i1 = i
           endif
c
           ax(i) = aux2(i1,inx)
           ay(i) = aux2(i1,iny)
	   pres = gamma1*(ql(i1,4)  - 0.5d0*(ql(i1,2)**2 +
     &            ql(i1,3)**2)/ql(i1,1))
           u(i) = (ax(i)*ql(i1,2) + ay(i)*ql(i1,3)) / ql(i1,1)
           v(i) = (-ay(i)*ql(i1,2) + ax(i)*ql(i1,3)) / ql(i1,1)
	   enth(i) = (ql(i1,4)+pres) / ql(i1,1)
	   u2v2(i) = u(i)**2 + v(i)**2
           a2 = gamma1*(enth(i) - .5d0*u2v2(i))
           a(i) = dsqrt(a2)
	   g1a2(i) = gamma1 / a2
	   euv(i) = enth(i) - u2v2(i)
           enddo
c
c
c
c     # now split asdq into waves:
c
      do 80 i = ix1,ixm1
         delta(1) = asdq(i,1)
         delta(2) = ax(i)*asdq(i,2) + ay(i)*asdq(i,3)
         delta(3) = -ay(i)*asdq(i,2) + ax(i)*asdq(i,3)
         delta(4) = asdq(i,4)

         a3 = g1a2(i) * (euv(i)*delta(1)
     &      + u(i)*delta(2) + v(i)*delta(3) - delta(4))
         a2 = delta(3) - v(i)*delta(1)
         a4 = (delta(2) + (a(i)-u(i))*delta(1) - a(i)*a3) / (2.d0*a(i))
         a1 = delta(1) - a3 - a4

c
c        # Compute the waves.

         wave(i,1,1) = a1
         wave(i,2,1) = a1*(u(i)-a(i))
         wave(i,3,1) = a1*v(i)
         wave(i,4,1) = a1*(enth(i) - u(i)*a(i))
         s(i,1) = (u(i)-a(i))
c
         wave(i,1,2) = a3
         wave(i,2,2) = a3*u(i)
         wave(i,3,2) = a3*v(i) + a2
         wave(i,4,2) = a3*0.5d0*u2v2(i)  + a2*v(i)
         s(i,2) = u(i)
c
         wave(i,1,3) = a4
         wave(i,2,3) = a4*(u(i)+a(i))
         wave(i,3,3) = a4*v(i)
         wave(i,4,3) = a4*(enth(i)+u(i)*a(i))
         s(i,3) = (u(i)+a(i))
c
   80    continue
c
c
c    # compute flux difference bmasdq
c    --------------------------------
c
      do 100 m=1,meqn
         do 100 i=ix1,ixm1
	    bmasdq(i,m) = 0.d0
	    do 90 mw=1,mwaves
	       bmasdq(i,m) = bmasdq(i,m) + dmin1(s(i,mw), 0.d0)
     &                        *wave(i,m,mw)*aux2(i1,ilenrat)
   90          continue
  100       continue
c
c     # rotate momentum components:
      do 150 i=ix1,ixm1
	 bmasdq2 = ax(i)*bmasdq(i,2) - ay(i)*bmasdq(i,3)
	 bmasdq3 = ay(i)*bmasdq(i,2) + ax(i)*bmasdq(i,3)
	 bmasdq(i,2) = bmasdq2
	 bmasdq(i,3) = bmasdq3
  150    continue
c
c
      return
      end


!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
! Fortran module for SPEC problems
! outputs contravariant Bfield given (s, theta zeta) coordinates
! adapted bfield.f90 in SPEC main code
! written by Zhisong Qu (zhisong.qu@anu.edu.au)
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!

MODULE SPECbfield

  CONTAINS

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

  SUBROUTINE get_bfield( zeta, st, Bst )
!f2py threadsafe

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

    USE SPECtypedefns, ONLY : REAL_KIND

    USE SPECconstants, ONLY : zero, one, half, two

    USE SPECvariables

    USE SPECbasefn

    IMPLICIT NONE

    REAL(KIND=REAL_KIND), INTENT(IN)   :: zeta,  st(2)
    REAL(KIND=REAL_KIND), INTENT(OUT)  ::       Bst(2)

    INTEGER              :: lvol, ii, ll, mi, ni
    REAL(KIND=REAL_KIND) :: teta, lss, sbar, arg, carg, sarg, dBu(1:3)
    REAL(KIND=REAL_KIND) :: cheby(0:Lrad,0:1), zernike(0:Lrad,0:Mpol,0:1)

    REAL(KIND=REAL_KIND) :: TT(0:Lrad,0:1) ! this is almost identical to cheby; 17 Dec 15;

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

    lvol = ivol ;  ! short hand

    Bst(1:2) = (/ zero , zero /) ! set default intent out; this should cause a compilation error IF Node.ne.2;

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

    lss = st(1) ; teta = st(2)

    IF( Lcoordinatesingularity ) sbar = MAX( ( lss + one ) * half, zero )

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

    IF (Lcoordinatesingularity) THEN
      CALL get_zernike(sbar, Lrad, Mpol, zernike(:,:,0:1))
    ELSE
      CALL get_cheby(lss, Lrad, cheby(0:Lrad,0:1))
    END IF

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

    dBu(1:3) = zero ! initialize summation;

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

    DO ii = 1, mn ; mi = im(ii) ; ni = in1(ii) ; arg = mi * teta - ni * zeta ; carg = COS(arg) ; sarg = SIN(arg) ! shorthand; 20 Apr 13;

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

      IF( Lcoordinatesingularity ) THEN ! regularization factor depends on mi; 17 Dec 15;

        DO ll = 0, Lrad ; TT(ll,0:1) = (/        zernike(ll,mi,0),        zernike(ll,mi,1)*half                      /)
        ENDDO

      ELSE

        DO ll = 0, Lrad ; TT(ll,0:1) = (/             cheby(ll,0),             cheby(ll,1)                           /)
        ENDDO

      ENDIF ! end of IF( Lcoordinatesingularity ) ; 16 Jan 15;

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

    ! DO ll = 0, Lrad ! loop over Chebyshev summation; 20 Feb 13;
    !   ;dBu(1) = dBu(1) + ( - mi * Aze(ll+1,ii) - ni * Ate(ll+1,ii) ) * TT(ll,0) * sarg
    !   ;dBu(2) = dBu(2) + (                                  -      Aze(ll+1,ii) ) * TT(ll,1) * carg
    !   ;dBu(3) = dBu(3) + (        Ate(ll+1,ii)                                  ) * TT(ll,1) * carg
    !   IF( NOTstellsym ) THEN ! include non-symmetric harmonics; 28 Jan 13;
    !   dBu(1) = dBu(1) + ( + mi * Azo(ll+1,ii) + ni * Ato(ll+1,ii) ) * TT(ll,0) * carg
    !   dBu(2) = dBu(2) + (                                  -      Azo(ll+1,ii) ) * TT(ll,1) * sarg
    !   dBu(3) = dBu(3) + (        Ato(ll+1,ii)                                  ) * TT(ll,1) * sarg
    !   ENDIF
    ! ENDDO ! end of DO ll; 10 Dec 15;

      dBu(1) = dBu(1) + SUM(( - mi * Aze(1:Lrad+1,ii)- ni * Ate(1:Lrad+1,ii) ) * TT(0:Lrad, 0)) * sarg
      dBu(2) = dBu(2) + SUM((                        -      Aze(1:Lrad+1,ii) ) * TT(0:Lrad, 1)) * carg
      dBu(3) = dBu(3) + SUM((        Ate(1:Lrad+1,ii)                        ) * TT(0:Lrad, 1)) * carg

      IF( NOTstellsym ) THEN
        dBu(1) = dBu(1) + SUM(( + mi * Azo(1:Lrad+1,ii) + ni * Ato(1:Lrad+1,ii) ) * TT(0:Lrad,0)) * carg
        dBu(2) = dBu(2) + SUM((                         -      Azo(1:Lrad+1,ii) ) * TT(0:Lrad,1)) * sarg
        dBu(3) = dBu(3) + SUM((        Ato(1:Lrad+1,ii)                         ) * TT(0:Lrad,1)) * sarg
      ENDIF
  !-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!

    ENDDO ! end of DO ii = 1, mn;

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

    Bst(1:2) = dBu(1:2) / dBu(3) ! normalize field line equations to toroidal field; 20 Apr 13;

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

  END SUBROUTINE get_bfield

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

subroutine get_bfield_tangent( zeta, st, Bst )
!f2py threadsafe
!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!

    USE SPECtypedefns, ONLY : REAL_KIND

    USE SPECconstants, ONLY : zero, one, half, two

    USE SPECvariables

    USE SPECbasefn

    IMPLICIT NONE

    REAL(KIND=REAL_KIND), INTENT(IN)   :: zeta,  st(6)
    REAL(KIND=REAL_KIND), INTENT(OUT)  ::       Bst(6)

    INTEGER              :: lvol, ii, ll, mi, ni
    REAL(KIND=REAL_KIND) :: teta, lss, sbar, arg, carg, sarg, dBu(1:3,0:2)
    REAL(KIND=REAL_KIND) :: cheby(0:Lrad,0:2), zernike(0:Lrad,0:Mpol,0:2)

    REAL(KIND=REAL_KIND) :: TT(0:Lrad,0:2) ! this is almost identical to cheby; 17 Dec 15;

    REAL(KIND=REAL_KIND) :: M(2,2), deltax(2,2), gBzeta

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

    lvol = ivol ;

    Bst = zero ! set default intent out

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

    lss = st(1) ; teta = st(2) ;

    ! the perturbation
    deltax(1:2,1) = st(3:4);
    deltax(1:2,2) = st(5:6);

    IF( Lcoordinatesingularity ) sbar = MAX( ( lss + one ) * half, zero )

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

    IF (Lcoordinatesingularity) THEN
      CALL get_zernike_d2(sbar, Lrad, Mpol, zernike(0:Lrad,:,0:2))
    ELSE
      CALL get_cheby_d2(lss, Lrad, cheby(0:Lrad,0:2))
    END IF

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

    dBu(1:3,0:2) = zero ! initialize summation;

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

    DO ii = 1, mn ; mi = im(ii) ; ni = in1(ii) ; arg = mi * teta - ni * zeta ; carg = COS(arg) ; sarg = SIN(arg) ! shorthand; 20 Apr 13;

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

      IF( Lcoordinatesingularity ) THEN ! regularization factor depends on mi; 17 Dec 15;

        DO ll = 0, Lrad ; TT(ll,0:2) = (/        zernike(ll,mi,0),        zernike(ll,mi,1)*half , zernike(ll,mi,2)*half*half /)
        ENDDO

      ELSE

        DO ll = 0, Lrad ; TT(ll,0:2) = (/             cheby(ll,0),             cheby(ll,1)       ,cheby(ll,2)               /)
        ENDDO

      ENDIF ! end of IF( Lcoordinatesingularity ) ; 16 Jan 15;

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

      ! no derivative
      ;dBu(1,0) = dBu(1,0) + SUM(( - mi * Aze(1:Lrad+1,ii) - ni * Ate(1:Lrad+1,ii) ) * TT(0:Lrad,0)) * sarg
      ;dBu(2,0) = dBu(2,0) + SUM((                         -      Aze(1:Lrad+1,ii) ) * TT(0:Lrad,1)) * carg
      ;dBu(3,0) = dBu(3,0) + SUM((        Ate(1:Lrad+1,ii)                         ) * TT(0:Lrad,1)) * carg
      ! ds
      ;dBu(1,1) = dBu(1,1) + SUM(( - mi * Aze(1:Lrad+1,ii) - ni * Ate(1:Lrad+1,ii) ) * TT(0:Lrad,1)) * sarg
      ;dBu(2,1) = dBu(2,1) + SUM((                         -      Aze(1:Lrad+1,ii) ) * TT(0:Lrad,2)) * carg
      ;dBu(3,1) = dBu(3,1) + SUM((        Ate(1:Lrad+1,ii)                         ) * TT(0:Lrad,2)) * carg
      ! dtheta
      ;dBu(1,2) = dBu(1,2) + mi * SUM(( - mi * Aze(1:Lrad+1,ii) - ni * Ate(1:Lrad+1,ii) ) * TT(0:Lrad,0)) * carg
      ;dBu(2,2) = dBu(2,2) - mi * SUM((                         -      Aze(1:Lrad+1,ii) ) * TT(0:Lrad,1)) * sarg
      ;dBu(3,2) = dBu(3,2) - mi * SUM((        Ate(1:Lrad+1,ii)                         ) * TT(0:Lrad,1)) * sarg
      IF( NOTstellsym ) THEN ! include non-symmetric harmonics; 28 Jan 13;
        ! no derivative
        dBu(1,0) = dBu(1,0) + SUM(( + mi * Azo(1:Lrad+1,ii) + ni * Ato(1:Lrad+1,ii) ) * TT(0:Lrad,0)) * carg
        dBu(2,0) = dBu(2,0) + SUM((                         -      Azo(1:Lrad+1,ii) ) * TT(0:Lrad,1)) * sarg
        dBu(3,0) = dBu(3,0) + SUM((        Ato(1:Lrad+1,ii)                         ) * TT(0:Lrad,1)) * sarg
        ! ds
        dBu(1,1) = dBu(1,1) + SUM(( + mi * Azo(1:Lrad+1,ii) + ni * Ato(1:Lrad+1,ii) ) * TT(0:Lrad,1)) * carg
        dBu(2,1) = dBu(2,1) + SUM((                         -      Azo(1:Lrad+1,ii) ) * TT(0:Lrad,2)) * sarg
        dBu(3,1) = dBu(3,1) + SUM((        Ato(1:Lrad+1,ii)                         ) * TT(0:Lrad,2)) * sarg
        ! dtheta
        dBu(1,2) = dBu(1,2) - mi * SUM(( + mi * Azo(1:Lrad+1,ii) + ni * Ato(1:Lrad+1,ii) ) * TT(0:Lrad,0)) * sarg
        dBu(2,2) = dBu(2,2) + mi * SUM((                         -      Azo(1:Lrad+1,ii) ) * TT(0:Lrad,1)) * carg
        dBu(3,2) = dBu(3,2) + mi * SUM((        Ato(1:Lrad+1,ii)                         ) * TT(0:Lrad,1)) * carg
      ENDIF

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

    ENDDO ! end of DO ii = 1, mn;

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

    gBzeta = dBu(3,0) ! gBzeta is returned through global; 20 Apr 13;

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

    Bst(1:2) = dBu(1:2,0) / gBzeta ! normalize field line equations to toroidal field; 20 Apr 13;

    ! assemble the tangent matrix
    M(1,1) = (dBu(1,1) * dBu(3,0) - dBu(3,1) * dBu(1,0)) / gBzeta**2   ! d(Bs/Bz)/ds
    M(1,2) = (dBu(1,2) * dBu(3,0) - dBu(3,2) * dBu(1,0)) / gBzeta**2   ! d(Bs/Bz)/dt
    M(2,1) = (dBu(2,1) * dBu(3,0) - dBu(3,1) * dBu(2,0)) / gBzeta**2   ! d(Bt/Bz)/ds
    M(2,2) = (dBu(2,2) * dBu(3,0) - dBu(3,2) * dBu(2,0)) / gBzeta**2   ! d(Bt/Bz)/dt

    deltax = MATMUL(M, deltax)

    Bst(3:4) = deltax(1:2,1)
    Bst(5:6) = deltax(1:2,2)

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

  END SUBROUTINE get_bfield_tangent

! !-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!-!
END MODULE SPECbfield


      PROGRAM SOMNEC(INPUT,OUTPUT,TAPE21)
C
C     PROGRAM TO GENERATE NEC INTERPOLATION GRIDS FOR FIELDS DUE TO
C     GROUND.  FIELD COMPONENTS ARE COMPUTED BY NUMERICAL EVALUATION
C     PF MODIFIED SOMMERFELD INTEGRALS.
C
      COMPLEX CK1,CK1SQ,ERV,EZV,ERH,EPH,AR1,AR2,AR3,EPSCF,CKSM,CT1,CT2,C
     1T3,CL1,CL2,CON
      COMMON /EVLCOM/ CKSM,CT1,CT2,CT3,CK1,CK1SQ,CK2,CK2SQ,TKMAG,TSMAG,C
     1K1R,ZPH,RHO,JH
      COMMON /GGRID/ AR1(11,10,4),AR2(17,5,4),AR3(9,8,4),EPSCF,DXA(3),DY
     1A(3),XSA(3),YSA(3),NXA(3),NYA(3)
      DIMENSION LCOMP(4)
      DATA NXA/11,17,9/,NYA/10,5,8/,XSA/0.,.2,.2/,YSA/0./0./.3490658504/
      DATA DXA/.02,.05,.1/,DYA/.1745329252,.0872664626,.1745329252/
      DATA LCOMP/3HERV,3HEZV,3HERH,3HEPH/
C
C     READ GROUND PARAMETERS - EPR = RELATIVE DIELECTRIC CONSTANT
C                              SIG = CONDUCTIVITY (MHOS/M)
C                              FMHZ = FREQUENCY (MHZ)
C                              IPT = 1 TO PRINT GRIDS.  =0 OTHERWISE.
C     IF SIG .LT. 0. THEN COMPLEX DIELECTRIC CONSTANT = EPR + J*SIG
C     AND FMHZ IS NOT USED
C
      READ 15, EPR,SIG,FMHZ,IPT
      IF (SIG.LT.0.) GO TO 1
      WLAM=299.8/FMHZ
      EPSCF=CMPLX(EPR,-SIG*WLAM*59.96)
      GO TO 2
1     EPSCF=CMPLX(EPR,SIG)
2     CALL SECOND (TST)
      CK2=6.283185308
      CK2SQ=CK2*CK2
C
C     SOMMERFELD INTEGRAL EVALUATION USES EXP(-JWT), NEC USES EXP(+JWT),
C     HENCE NEED CONJG(EPSCF).  CONJUGATE OF FIELDS OCCURS IN SUBROUTINE
C     EVLUA.
C
      CK1SQ=CK2SQ*CONJG(EPSCF)
      CK1=CSQRT(CK1SQ)
      CK1R=REAL(CK1)
      TKMAG=100.*CABS(CK1)
      TSMAG=100.*CK1*CONJG(CK1)
      CKSM=CK2SQ/(CK1SQ+CK2SQ)
      CT1=.5*(CK1SQ-CK2SQ)
      ERV=CK1SQ*CK1SQ
      EZV=CK2SQ*CK2SQ
      CT2=.125*(ERV-EZV)
      ERV=ERV*CK1SQ
      EZV=EZV*CK2SQ
      CT3=.0625*(ERV-EZV)
C
C     LOOP OVER 3 GRID REGIONS
C
      DO 6 K=1,3
      NR=NXA(K)
      NTH=NYA(K)
      DR=DXA(K)
      DTH=DYA(K)
      R=XSA(K)-DR
      IRS=1
      IF (K.EQ.1) R=XSA(K)
      IF (K.EQ.1) IRS=2
C
C     LOOP OVER R.  (R=SQRT(RHO**2 + (Z+H)**2))
C
      DO 6 IR=IRS,NR
      R=R+DR
      THET=YSA(K)-DTH
C
C     LOOP OVER THETA.  (THETA=ATAN((Z+H)/RHO))
C
      DO 6 ITH=1,NTH
      THET=THET+DTH
      RHO=R*COS(THET)
      ZPH=R*SIN(THET)
      IF (RHO.LT.1.E-7) RHO=1.E-8
      IF (ZPH.LT.1.E-7) ZPH=0.
      CALL EVLUA (ERV,EZV,ERH,EPH)
      RK=CK2*R
      CON=-(0.,4.77147)*R/CMPLX(COS(RK),-SIN(RK))
      GO TO (3,4,5), K
3     AR1(IR,ITH,1)=ERV*CON
      AR1(IR,ITH,2)=EZV*CON
      AR1(IR,ITH,3)=ERH*CON
      AR1(IR,ITH,4)=EPH*CON
      GO TO 6
4     AR2(IR,ITH,1)=ERV*CON
      AR2(IR,ITH,2)=EZV*CON
      AR2(IR,ITH,3)=ERH*CON
      AR2(IR,ITH,4)=EPH*CON
      GO TO 6
5     AR3(IR,ITH,1)=ERV*CON
      AR3(IR,ITH,2)=EZV*CON
      AR3(IR,ITH,3)=ERH*CON
      AR3(IR,ITH,4)=EPH*CON
6     CONTINUE
C
C     FILL GRID 1 FOR R EQUAL TO ZERO.
C
      CL2=-(0.,188.370)*(EPSCF-1.)/(EPSCF+1.)
      CL1=CL2/(EPSCF+1.)
      EZV=EPSCF*CL1
      THET=-DTH
      NTH=NYA(1)
      DO 9 ITH=1,NTH
      THET=THET+DTH
      IF (ITH.EQ.NTH) GO TO 7
      TFAC2=COS(THET)
      TFAC1=(1.-SIN(THET))/TFAC2
      TFAC2=TFAC1/TFAC2
      ERV=EPSCF*CL1*TFAC1
      ERH=CL1*(TFAC2-1.)+CL2
      EPH=CL1*TFAC2-CL2
      GO TO 8
7     ERV=0.
      ERH=CL2-.5*CL1
      EPH=-ERH
8     AR1(1,ITH,1)=ERV
      AR1(1,ITH,2)=EZV
      AR1(1,ITH,3)=ERH
9     AR1(1,ITH,4)=EPH
      CALL SECOND (TIM)
C
C     WRITE GRID ON TAPE21
C
      WRITE (21) AR1,AR2,AR3,EPSCF,DXA,DYA,XSA,YSA,NXA,NYA
      REWIND 21
      IF (IPT.EQ.0) GO TO 14
C
C     PRINT GRID
C
      PRINT 17, EPSCF
      DO 13 K=1,3
      NR=NXA(K)
      NTH=NYA(K)
      PRINT 18, K,XSA(K),DXA(K),NR,YSA(K),DYA(K),NTH
      DO 13 L=1,4
      PRINT 19, LCOMP(L)
      DO 13 IR=1,NR
      GO TO (10,11,12), K
10    PRINT 20, IR,(AR1(IR,ITH,L),ITH=1,NTH)
      GO TO 13
11    PRINT 20, IR,(AR2(IR,ITH,L),ITH=1,NTH)
      GO TO 13
12    PRINT 20, IR,(AR3(IR,ITH,L),ITH=1,NTH)
13    CONTINUE
14    TIM=TIM-TST
      PRINT 16,TIM
      STOP
C
15    FORMAT (3E10,3,I5)
16    FORMAT (6H TIME=,E12.5)
17    FORMAT (30H1NEC GROUND INTERPOLATION GRID,/,21H DIELECTRIC CONSTAN
     1T=,2E12.5)
18    FORMAT (///,5H GRID,I2,/,4X,5HR(1)=,F7.4,4X,3HDR=,F7.4,4X,3HNR=,I3
     1,/,9H THET(1)=,F7.4,3X,4HDTH=,F7.4,3X,4HNTH=,I3,//)
19    FORMAT (///,A3)
20    FORMAT (4H IR=,I3,/,1X,(10E12.5))
      END


! This file is a part of JuliaFEM.
! License is MIT: see https://github.com/JuliaFEM/UMAT.jl/blob/master/LICENSE
SUBROUTINE UMAT(STRESS,STATEV,DDSDDE,SSE,SPD,SCD,&
	RPL,DDSDDT,DRPLDE,DRPLDT,&
	STRAN,DSTRAN,TIME,DTIME,TEMP,DTEMP,PREDEF,DPRED,CMNAME,&
	NDI,NSHR,NTENS,NSTATV,PROPS,NPROPS,COORDS,DROT,PNEWDT,&
	CELENT,DFGRD0,DFGRD1,NOEL,NPT,LAYER,KSPT,KSTEP,KINC)

implicit none
! Rate-independent Gurson-Tveergaad-Needleman porous plasticity model
!INCLUDE'ABA_PARAM.INC'

CHARACTER*80 CMNAME
REAL*8,INTENT(INOUT) :: STRESS(NTENS),STATEV(NSTATV),&
DDSDDE(NTENS,NTENS),DDSDDT(NTENS),DRPLDE(NTENS),&
STRAN(NTENS),DSTRAN(NTENS),TIME(2),PREDEF(1),DPRED(1),&
PROPS(NPROPS),COORDS(3),DROT(3,3),DFGRD0(3,3),DFGRD1(3,3)

REAL*8,INTENT(INOUT) :: SSE,SPD,SCD,RPL,DRPLDT,DTIME,TEMP,DTEMP,&
	PNEWDT,CELENT
integer,intent(inout) :: NDI,NSHR,NOEL,NPT,LAYER,NTENS,NSTATV,&
	KSPT,KSTEP,KINC,NPROPS

INTEGER :: I,J,MAXITERS,DISP
REAL*8 :: tol,res
REAL*8 :: f0,fc,ff,fn,sn,en,qinf,b,C,ga,EE,nu,syield
REAL*8 :: K,G,la
REAL*8 :: q1,q2,q3,fu
REAL*8 :: pi,A
REAL*8 :: DEp,DEq,ep,f
REAL*8 :: ft,dftdf,epn,fnn
REAL*8 :: p,q,sflow,phi,cosht,sinht,dphidq,dphidp
REAL*8,DIMENSION(6) :: STRIAL,X,EELAS,EPLAS,BETA,DEin,N,onevec,DSTRESS,BETAiter
REAL*8,DIMENSION(6,6) :: CELAS
REAL*8 :: eratio,qiter,piter,phiter,dpderatio,dqderatio
! Constants
pi=3.14159265358979
tol = 1e-6
MAXITERS = 20
IF (KSTEP==2) THEN
	DISP=0
ELSE
	DISP=0
END IF
IF (DISP>=1) THEN
	PRINT *, "***** NEW INCREMENT IN MAIN ROUTINE! STEP:", KSTEP, " *****"
	PRINT *, "TIME:", TIME(1), "DTIME:", DTIME
END IF
!Load properties
call LoadPROPS(f0,fc,ff,fn,sn,en,qinf,b,C,ga,EE,nu,syield,PROPS,NPROPS,DISP)

!Bulk and shear moduli
K=EE/(3.0*(1.0-nu))
G=EE/(2.0*(1.0+nu))
la=K-2.0/3.0*G

!Tvergaard values for periodic void distributions
q1=1.5
q2=1.0
q3=q1**2

!Effective porosity at failure
fu=(q1-SQRT(q1**2-q3))/q3

! Load state variables
call LoadSTATEV(f,ep,DEp,DEq,EELAS,EPLAS,X,STATEV,NSTATV,&
	NTENS,NDI,NSHR,DROT,DISP)

IF (STATEV(NSTATV)==0) THEN
	! Initialize porosity
	f = f0
	STATEV(NSTATV)=1
END IF
!Effective linear elasticity tensor CELAS
CELAS(1:NTENS,1:NTENS)=0.0
DO I=1,NDI
	DO J=1,NDI
		CELAS(I,J)=la
	END DO
	CELAS(I,I)=2.0*G+la
END DO
DO I=NDI+1,NTENS
	CELAS(I,I)=G
END DO

! Trial stress
STRIAL=MATMUL(CELAS,EELAS+DSTRAN)
! Relative stress
BETA=STRIAL-X

! Calculate pressure and von mises
	call pressure(BETA,p)
	call vonmises(BETA,q)

! Flow stress
sflow = syield+qinf*(1.0-exp(-b*ep))

! Update effective porosity and its derivative
	call Updateft(f,ft,dftdf,fu,fc,ff)

! Yield function
	call mcosh(1.5*q2*p/sflow,cosht)
	call msinh(1.5*q2*p/sflow,sinht)
phi = (q/sflow)**2 + 2.0*ft*q1*cosht-(1.0+q3*ft**2)
IF (DISP>=2) THEN
	print *, "Phi:", phi
	print *, "Pressure:", p, "Von Mises:", q
END IF
IF (phi<0.0) THEN
	! Elastic step
	! Update state variables
	IF (DISP>=2) THEN
		print *, "EELAS(n):"
		print *, EELAS
		print *, "DSTRAN:"
		print *, DSTRAN
		print *, "STRESS(n):"
		print *, STRESS
		print *, "STRIAL:"
		print *, STRIAL
	END IF
	EELAS = EELAS+DSTRAN
	EPLAS = EPLAS
	X = X
	call UpdateSTATEV(f,ep,DEp,DEq,EELAS,EPLAS,X,STATEV,NSTATV,NTENS,DISP)
	! Update STRESS
	STRESS=STRIAL
	! Update DDSDDE
	DDSDDE = CELAS
ELSE
	IF (DISP>=2) THEN
		print *, "***** Yielding *****"
	END IF
	fnn = f
	! Plastic step
	! 22.11.2013 Added estimation for ratio of elasticity
	DSTRESS = MATMUL(CELAS,DSTRAN)
	onevec=(/1.0,1.0,1.0,0.0,0.0,0.0/)
	N = 1.5*(BETA+p*onevec)/q
	dpderatio = -1.0/3.0*(DSTRESS(1)+DSTRESS(2)+DSTRESS(3))
	dqderatio = DOT_PRODUCT(N(1:3),DSTRESS(1:3))+2*DOT_PRODUCT(N(4:6),DSTRESS(4:6))

	res = 1000.0
	! Initial guess: ratio of elasticity = 0.1
	eratio=0.1
	DO I=1,MAXITERS
		BETAiter=STRESS+(1.0-eratio)*DSTRESS-X
			call pressure(BETAiter,piter)
			call vonmises(BETAiter,qiter)
		! Yield function
		call mcosh(1.5*q2*piter/sflow,cosht)
		call msinh(1.5*q2*piter/sflow,sinht)
		phiter = (qiter/sflow)**2 + 2.0*ft*q1*cosht-(1.0+q3*ft**2)
		dphidq=2.0*qiter/sflow**2
		dphidp=3.0*q1*q2*ft/sflow*sinht
		eratio = eratio + phiter/(dphidp*dpderatio + dphidq*dqderatio)
		res = ABS(phiter)
		IF (res<tol) EXIT
	END DO
	IF ((res>tol) .OR. (eratio<0) .OR. (eratio>1) .OR. (eratio/=eratio)) THEN
		IF (DISP>=2) THEN
			print *, "Failed elasticity ratio:", eratio
		END IF
		eratio = 0.0
	END IF
	IF (DISP>=2) THEN
		print *, "Elasticity ratio:", eratio
	END IF

	res = 1000.0
	! 12.11.2013 Changed plastic starting-guess
	! Close to ideal-plastic starting guess
	! Least-squares method, N:N = 3/2
	DEp = (1.0-eratio)*(DSTRAN(1)+DSTRAN(2)+DSTRAN(3))
	DEq = 2.0/3.0*DOT_PRODUCT(N,(1.0-eratio)*DSTRAN-DEp/3.0*onevec)
	!DEq = 2.0/3.0*(DOT_PRODUCT(N(1:3),(1.0-eratio)*DSTRAN(1:3)-DEp/3.0)+2*DOT_PRODUCT(N(4:6),(1.0-eratio)*DSTRAN(4:6)))
	IF ((DEq==0) .and. (DEp==0)) THEN
		DEq = tol
	END IF

	! 19.11.2013 Extended starting guess to f and ep as well
	epn = ep
	fnn = f
	ep = ep + (-p*DEp + q*DEq)/((1.0-f)*sflow)
	IF (p<0) THEN
		A=fn*exp(-0.5*(-en + ep)**2/sn**2)/(sqrt(2.0*pi)*sn)
		f = f + (1-f)*DEp + A*(ep-epn)
	ELSE
		f = f + (1-f)*DEp
	END IF

	! Returns iteration variables: f, ep, DEp, DEq and residual res
	IF (DISP>=2) THEN
		print *, "EELAS(n):"
		print *, EELAS
		print *, "DSTRAN:"
		print *, DSTRAN
		print *, "STRESS(n):"
		print *, STRESS
		print *, "STRIAL:"
		print *, STRIAL
		print *, "X(n):"
		print *, X
		print *, "f(n), ep(n)"
		print *, fnn, epn
		print *, "DEp(n), DEq(n)"
		print *, DEp, DEq
	END IF
	! Analytical tangent added 19.11.2013, Calculated inside PlasticIteration
	call PlasticIteration(f,ep,DEp,DEq,DDSDDE,STRIAL,X,epn,fnn,MAXITERS,TOL,PROPS,&
		NPROPS,NTENS,NDI,res,DISP)
	IF (res>tol) THEN
		PRINT *, "Plastic iteration failed at",TIME(1),"in element", NOEL, " in point", NPT
		PNEWDT=0.5
	END IF
	IF (DISP>=2) THEN
		print *, "f(n+1), ep(n+1)"
		print *, f, ep
		print *, "DEp(n+1), DEq(n+1)"
		print *, DEp, DEq
	END IF

	DEin = EPLAS
	! Update STRESS,X,DEin
	call UpdateStress(f,ep,DEp,DEq,STRIAL,X,PROPS,NPROPS,STRESS,DEin,fnn,NTENS,NDI,DISP)
	IF (DISP>=2) THEN
		print *, "STRESS(n+1):"
		print *, STRESS
		print *, "X(n+1):"
		print *, X
	END IF

	! Update internal strains using return mapping algorithms
	EELAS = EELAS+DSTRAN-DEin
	EPLAS = EPLAS+DEin
	IF (DISP>=2) THEN
		print *, "EELAS(n+1):"
		print *, EELAS
	END IF

	! Update state variables
	call UpdateSTATEV(f,ep,DEp,DEq,EELAS,EPLAS,X,STATEV,NSTATV,NTENS,DISP)

	! Disabled 19.11.2013 for the Analytical consistent tangent to be enabled
	! Calculate Numerical consistent tangent DDSDDE
	! using Forward-difference method
	!DISP=5
	!call NumericalConsistentTangent(STRESS,STATEV,DSTRAN,DDSDDE,NDI,&
	!	NSHR,NTENS,NSTATV,PROPS,NPROPS,DROT,DISP)
	IF (DISP>=2) THEN
		print *, "DDSDDE:"
		print *, DDSDDE
	END IF
	DISP=0
END IF
END SUBROUTINE
subroutine MVector(S)
	implicit none
	real(8),dimension(6), intent(inout) :: S
	S(4:6)=S(4:6)*sqrt(2.0)
end subroutine
subroutine MiVector(S)
	implicit none
	real(8),dimension(6), intent(inout) :: S
	S(4:6)=S(4:6)/sqrt(2.0)
end subroutine
subroutine MMatrix(S)
	implicit none
	real(8),dimension(6,6), intent(inout) :: S
	S(4:6,1:3) = S(4:6,1:3)*sqrt(2.0)
	S(1:3,4:6) = S(1:3,4:6)*sqrt(2.0)
	S(4:6,4:6) = S(4:6,4:6)*2.0
end subroutine
subroutine MiMatrix(S)
	implicit none
	real(8),dimension(6,6), intent(inout) :: S
	S(4:6,1:3) = S(4:6,1:3)/sqrt(2.0)
	S(1:3,4:6) = S(1:3,4:6)/sqrt(2.0)
	S(4:6,4:6) = S(4:6,4:6)/2.0
end subroutine
subroutine UpdateStress(f,ep,DEp,DEq,STRIAL,X,PROPS,&
	NPROPS,STRESS,DEin,fnn,NTENS,NDI,DISP)
	implicit none

	real(8),intent(in) :: DEp,DEq,ep,f
	real(8),dimension(6),intent(in) :: STRIAL
	real(8),dimension(6),intent(inout) :: STRESS,X,DEin
	integer,intent(in) :: NPROPS
	real(8),dimension(NPROPS),intent(in) :: PROPS
	real(8),intent(in) :: fnn
	integer,intent(in) :: NTENS,NDI,DISP
	real(8),dimension(6) :: onevec,N,BETAplus
	real(8),dimension(6,6) :: CELAS
	integer :: I, J
	real(8) :: f0,fc,ff,fn,sn,en,qinf,b,C,ga,EE,nu,syield,K,G,la
	real(8) :: q1,q2,q3,fu
	real(8) :: T,s,Ds,Deinscl,q,p,qplus,pplus
	real(8) :: ft,dftdf,ftn,dftndf
	IF (DISP>=1) THEN
		print *, "***** Updating STRESS *****"
	END IF
	call LoadPROPS(f0,fc,ff,fn,sn,en,qinf,b,C,ga,EE,nu,syield,PROPS,NPROPS,DISP)
	!Bulk and shear moduli
	K=EE/(3.0*(1.0-nu))
	G=EE/(2.0*(1.0+nu))
	!la=K-2.0/3.0*G

	!Tvergaard values for periodic void distributions
	q1=1.5
	q2=1.0
	q3=q1**2

	! Elasticity tensor CELAS
	!CELAS(1:NTENS,1:NTENS)=0.0
	!DO I=1,NDI
	!	DO J=1,NDI
	!		CELAS(I,J)=la
	!	END DO
	!	CELAS(I,I)=2.0*G+la
	!END DO
	!DO I=NDI+1,NTENS
	!	CELAS(I,I)=G
	!END DO

	!Effective porosity at failure
	fu=(q1-SQRT(q1**2-q3))/q3

	call Updateft(fnn,ftn,dftndf,fu,fc,ff)
	call Updateft(f,ft,dftdf,fu,fc,ff)

	s=1.0-ft/fu
	Ds=(ftn-ft)/fu
	Deinscl=SQRT(2.0/9.0*DEp**2+DEq**2)
	T=1.0-Ds/s+s*ga*Deinscl

	BETAplus = STRIAL-X/T
	! Calculate p and q
	call pressure(BETAplus,pplus)
	call vonmises(BETAplus,qplus)

	p = pplus+(K+2.0/9.0*C/T*s)*DEp
	q = qplus-(G+1.0/3.0*C/T*s)*3.0*DEq

	onevec = (/1.0,1.0,1.0,0.0,0.0,0.0/)

	!N=(BETAplus+pplus*onevec)/(2.0/3.0*q+(G+1.0/3.0*C/T*s)*2.0*DEq)
	! Changed 12.11.2013 - more compact form
	N = 1.5*(BETAplus+pplus*onevec)/(q+(3.0*G+C/T*s)*DEq)
	DEin=1.0/3.0*DEp*onevec+DEq*N
	DO I=NDI+1,NTENS
		DEin(I) = DEin(I)*2.0
	END DO
	X = (2.0/3.0*C*DEin*s+X)/T
	STRESS = STRIAL-K*DEp*onevec-2.0*G*DEq*N
	!STRESS = STRIAL-MATMUL(CELAS,DEin)
	IF (DISP>=1) THEN
		print *, "***** STRESS updated *****"
	END IF
end subroutine
subroutine PlasticIteration(f,ep,DEp,DEq,DDSDDE,STRIAL,X,epn,fnn,MAXITERS,TOL,&
	PROPS,NPROPS,NTENS,NDI,res,DISP)
	implicit none
	real(8),intent(inout) :: DEp,DEq,ep,f
	real(8),dimension(6,6),intent(inout) :: DDSDDE
	real(8),dimension(6),intent(in) :: STRIAL,X
	integer,intent(in) :: NPROPS,MAXITERS,DISP,NTENS,NDI
	real(8),dimension(NPROPS),intent(in) :: PROPS
	real(8),intent(in) :: TOL,epn,fnn
	real(8),intent(inout) :: res
	real(8), dimension(4,4) :: ALIN
	real(8), dimension(4) :: BLIN, dXLIN
	real(8), dimension(6) :: BETAplus
	real(8) :: f0,fc,ff,fn,sn,en,qinf,b,C,ga,EE,nu,syield,K,G,la
	real(8) :: q1,q2,q3,fu,pi
	real(8) :: T,s,Ds,Deinscl,q,p,Depscl
	real(8) :: ft,dftdf,ftn,dftndf,Df
	real(8) :: sinht,cosht
	real(8) :: pplus,qplus
	real(8) :: sflow, dsflowdep, A, dAdep
	real(8) :: dTdDEp, dTdDEq, dTdep, dTdf
	real(8) :: dpdDEp, dpdDEq, dpdep,dpdf
	real(8) :: dqdDEp, dqdDEq, dqdep,dqdf
	real(8) :: mult1,mult2,mult3,mult4
	real(8) :: dphidq, dphidq2, dphidp, dphidpdf, dphidp2
	real(8) :: dphidqdsflow,dphidpdsflow,dphidsflow
	real(8) :: F1, dF1dDEp, dF1dDEq, dF1dep, dF1df
	real(8) :: F2, dF2dDEp, dF2dDEq, dF2dep, dF2df
	real(8) :: G1, dG1dDEp, dG1dDEq, dG1dep, dG1df
	real(8) :: G2, dG2dDEp, dG2dDEq, dG2dep, dG2df
	integer :: I,J
	real(8), dimension(2,2) :: Amat2,Bmat2,Cmat2
	real(8), dimension(2) :: bvec2
	real(8), dimension(6) :: N, onevec, dG1dstr, dG2dstr, dF1dstr, dF2dstr
	real(8), dimension(6) :: dpdstr, dqdstr, dH1dstr, dH2dstr
	real(8), dimension(6) :: dNdT
	real(8), dimension(6) :: B1,B2,Bp,Bq,Bep,Bf
	real(8), dimension(6,6) :: dNdstr,PP,tempmat6,QQ,tempmat7,CELAS
	real(8), dimension(3,3,3,3) :: Itensor, Ptensor,Qtensor,Ctensor,Dtensor,tensor1,tensor2
	real(8) :: qe,dH1dDEp,dH1dDEq,dH2dDEp,dH2dDEq
	real(8) :: resn

	IF (DISP>=1) THEN
		print *, "***** Inside PlasticIteration *****"
	END IF
	call LoadPROPS(f0,fc,ff,fn,sn,en,qinf,b,C,ga,EE,nu,syield,PROPS,NPROPS,DISP)
	pi=3.14159265358979

	!Bulk and shear moduli
	K=EE/(3.0*(1.0-nu))
	G=EE/(2.0*(1.0+nu))
	la=K-2.0/3.0*G
	!Effective linear elasticity tensor CELAS
	CELAS(1:NTENS,1:NTENS)=0.0
	DO I=1,NDI
		DO J=1,NDI
			CELAS(I,J)=la
		END DO
		CELAS(I,I)=2.0*G+la
	END DO
	DO I=NDI+1,NTENS
		CELAS(I,I)=G
	END DO

	!Tvergaard values for periodic void distributions
	q1=1.5
	q2=1.0
	q3=q1**2

	!Effective porosity at failure
	fu=(q1-SQRT(q1**2-q3))/q3

	call Updateft(f,ftn,dftndf,fu,fc,ff)
	if (res<tol) THEN
		res=1.5*tol
	END IF
	IF (DISP>=1) THEN
		print *, "***** Starting PlasticIteration *****"
	END IF
	IF (DISP>=3) THEN
		print *, "f, ep"
		print *, f, ep
		print *, "DEp, DEq"
		print *, DEp, DEq
		print *, "STRIAL:"
		print *, STRIAL
		print *, "X(n):"
		print *, X
	END IF
	! Plastic iterations
	do I=1,MAXITERS
		IF (DISP>=3) THEN
			print *, "***** Iteration", I, " *****"
			print *, "f, ep"
			print *, f, ep
			print *, "DEp, DEq"
			print *, DEp, DEq
		END IF
		! 22.11.2013 -  Added divergence control
		resn=res
		! Update ft and dftdf
		call Updateft(f,ft,dftdf,fu,fc,ff)
		s=1.0-ft/fu
		Ds=(ftn-ft)/fu
		Deinscl=SQRT(2.0/9.0*DEp**2+DEq**2)
		!print *, "s:", s, "Ds:", Ds
		T=1.0-Ds/s+s*ga*Deinscl
		!print *, "Deinscl:", Deinscl, "dftdf:", dftdf
		BETAplus = STRIAL-X/T
		sflow=syield+qinf*(1.0-exp(-b*ep))
		dsflowdep=b*qinf*exp(-b*ep)

		!print *, "Sflow:", sflow, "T:", T

		A=fn*exp(-0.5*(-en + ep)**2/sn**2)/(sqrt(2.0*pi)*sn)
		dAdep=-(ep-en)/sn**2*A

		!print *, "A:", A

		! Calculate p and q
		call pressure(BETAplus,pplus)
		call vonmises(BETAplus,qplus)

		p = pplus+(K+2.0/9.0*C/T*s)*DEp
		q = qplus-(G+1.0/3.0*C/T*s)*3.0*DEq
		IF (DISP>=3) THEN
			print *, "Pressure:", p, "Von Mises:", q
		END IF
		call msinh(1.5*q2*p/sflow,sinht)
		call mcosh(1.5*q2*p/sflow,cosht)
		!print *, "sinh*:", sinht, "cosh*:", cosht

		! Derivatives
		dTdDEp = 2.0*ga*s*DEp/(9.0*Deinscl)
		dTdDEq = ga*s*DEq/Deinscl
		dTdep = 0.0
		dTdf = dftdf*(1.0/(fu-ft)-(ftn-ft)/(fu-ft)**2-ga*Deinscl/fu) ! Different in Metzger 2009

		dpdDEp = K-(X(1)+X(2)+X(3))/(3.0*T**2)*dTdDEp-2.0*C*DEp*s/(9.0*T**2)*dTdDEp+2.0*C*s/(9.0*T)
		dpdDEq = -(X(1)+X(2)+X(3))/(3.0*T**2)*dTdDEq-2.0*C*DEp*s/(9.0*T**2)*dTdDEq
		dpdep = -(X(1)+X(2)+X(3))/(3.0*T**2)*dTdep-2.0*C*DEp*s/(9.0*T**2)*dTdep
		dpdf = -(X(1)+X(2)+X(3))/(3.0*T**2)*dTdf-2.0*C*DEp*s/(9.0*T**2)*dTdf-2.0*C*DEp/(9.0*T*fu)*dftdf

		!mult1 = STRIAL(1)**2+STRIAL(2)**2+STRIAL(3)**2+2.0*(STRIAL(4)**2+STRIAL(5)**2+STRIAL(6)**2)
		!mult2 = 2.0*(STRIAL(1)*X(1)+STRIAL(2)*X(2)+STRIAL(3)*X(3)+2.0*(STRIAL(4)*X(4)+STRIAL(5)*X(5)+STRIAL(6)*X(6)))
		!mult3 = X(1)**2+X(2)**2+X(3)**2+2.0*(X(4)**2+X(5)**2+X(6)**2)
		!mult4 = (1.5*mult2/T**2-3.0*mult3/T**3)/SQRT(6.0*(mult1-mult2/T+mult3/T**2))

		mult4 = (0.25*(2*X(1)/T**2 - 2*X(2)/T**2)*(STRIAL(1) - STRIAL(2) - X(1)/T + X(2)/T)&
			+ 0.25*(2*X(1)/T**2 - 2*X(3)/T**2)*(STRIAL(1) - STRIAL(3) - X(1)/T + X(3)/T)&
			+ 0.25*(2*X(2)/T**2 - 2*X(3)/T**2)*(STRIAL(2) - STRIAL(3) - X(2)/T + X(3)/T)&
			+ 3.0*X(4)*(STRIAL(4) - X(4)/T)/T**2 + 3.0*X(5)*(STRIAL(5) - X(5)/T)/T**2&
			+ 3.0*X(6)*(STRIAL(6) - X(6)/T)/T**2)/sqrt(3.0*(STRIAL(4) - X(4)/T)**2&
			+ 3.0*(STRIAL(5) - X(5)/T)**2 + 3.0*(STRIAL(6) - X(6)/T)**2&
			+ 0.5*(STRIAL(1) - STRIAL(2) - X(1)/T + X(2)/T)**2&
			+ 0.5*(STRIAL(1) - STRIAL(3) - X(1)/T + X(3)/T)**2&
			+ 0.5*(STRIAL(2) - STRIAL(3) - X(2)/T + X(3)/T)**2)

		dqdDEp = mult4*dTdDEp&
			+C*s*DEq/T**2*dTdDEp
		dqdDEq = mult4*dTdDEq&
			+C*s*DEq/T**2*dTdDEq-3.0*G-C*s/T
		dqdep = mult4*dTdep&
			+C*s*DEq/T**2*dTdep
		dqdf = mult4*dTdf&
			+C*DEq*(s/T**2*dTdf+dftdf/(T*fu))

		! Equation 1
		dphidq=2.0*q/sflow**2
		dphidq2=2.0/sflow**2
		dphidp=3.0*q1*q2*ft/sflow*sinht
		dphidpdf=3.0*q1*q2*dftdf/sflow*sinht
		dphidp2=4.5*q1*q2**2*ft/sflow**2*cosht
		dphidqdsflow = -4.0*q/sflow**3
		dphidpdsflow = -4.5*ft*p*q1*q2**2*cosht/sflow**3&
			-3.0*ft*q1*q2*sinht/sflow**2
		F1 = DEp*dphidq+DEq*dphidp

		dF1dDEp = dphidq+DEp*dphidq2*dqdDEp+DEq*dphidp2*dpdDEp
		dF1dDEq = DEp*dphidq2*dqdDEq+dphidp+DEq*dphidp2*dpdDEq
		dF1dep = DEp*(dphidq2*dqdep+dphidqdsflow*dsflowdep)&
			+ DEq*(dphidp2*dpdep+dphidpdsflow*dsflowdep)
		dF1df = DEp*(dphidq2*dqdf) + DEq*(dphidp2*dpdf+dphidpdf)

		! Equation 2
		F2 = (q/sflow)**2+2.0*ft*q1*cosht-(1.0+q3*ft**2)
		dphidsflow = -3.0*ft*p*q1*q2*sinht/sflow**2 - 2.0*q**2/sflow**3
		dF2dDEp = dphidq*dqdDEp + dphidp*dpdDEp
		dF2dDEq = dphidq*dqdDEq + dphidp*dpdDEq
		dF2dep = dphidq*dqdep + dphidp*dpdep + dphidsflow*dsflowdep
		dF2df = dphidq*dqdf + 2.0*dftdf*q1*cosht + dphidp*dpdf-2.0*q3*dftdf*ft

		! Equation 3
		Depscl = (-p*DEp+q*DEq)/((1.0-f)*sflow)
		G1 = (ep-epn)-Depscl
		dG1dDEp = -(-dpdDEp*DEp-p+dqdDEp*DEq)/((1.0-f)*sflow)
		dG1dDEq = -(-dpdDEq*DEp+dqdDEq*DEq+q)/((1.0-f)*sflow)
		dG1dep = 1.0 - (-dpdep*DEp+dqdep*DEq)/((1.0-f)*sflow) + (-p*DEp+q*DEq)/((1.0-f)*sflow**2)*dsflowdep
		dG1df = -(-dpdf*DEp+dqdf*DEq)/((1.0-f)*sflow) - (-p*DEp+q*DEq)/((1.0-f)**2*sflow)

		! Equation 4
		IF (p<0) THEN
			! Nucleation term is only active under hydrostatic tension p<0
			! Condition added 11.11.2013
			Df = (1.0-f)*DEp+A*Depscl
			!Df = (1.0-f)*DEp+A*(ep-epn)
			G2 = (f-fnn)-Df
			!dG2dDEp = f-1.0
			!dG2dDEq = 0.0
			!dG2dep = -dAdep*(ep-epn)-A
			!dG2df = 1.0+DEp
			dG2dDEp = -(1.0-f)+A*dG1dDEp
			dG2dDEq = A*dG1dDEq
			dG2dep = -dAdep*Depscl + A*(dG1dep-1.0)
			dG2df = 1.0 + DEp + A*dG1df
		ELSE
			! Only growth is active under hydrostatic compression p>0
			! Condition added 11.11.2013
			Df = (1.0-f)*DEp
			G2 = (f-fnn)-Df
			dG2dDEp = f-1.0
			dG2dDEq = 0.0
			dG2dep = 0.0
			dG2df = 1.0+DEp
		END IF

		!Linearized system for Newton's iterations
		ALIN(1,1)=dF1dDEp
		ALIN(2,1)=dF1dDEq
		ALIN(3,1)=dF1dep
		ALIN(4,1)=dF1df
		ALIN(1,2)=dF2dDEp
		ALIN(2,2)=dF2dDEq
		ALIN(3,2)=dF2dep
		ALIN(4,2)=dF2df
		ALIN(1,3)=dG1dDEp
		ALIN(2,3)=dG1dDEq
		ALIN(3,3)=dG1dep
		ALIN(4,3)=dG1df
		ALIN(1,4)=dG2dDEp
		ALIN(2,4)=dG2dDEq
		ALIN(3,4)=dG2dep
		ALIN(4,4)=dG2df

		BLIN=-1.0*(/F1,F2,G1,G2/)

		!Convergence check
		res=0.0
		do J=1,4
			if (abs(BLIN(J))>res) then
				res=abs(BLIN(J))
			end if
		end do
		IF (DISP>=3) THEN
			print *, "Residual:", res
		END IF

		! Solve linear system
		IF (DISP>=3) THEN
			print *, "ALIN"
			print *, ALIN
			print *, "BLIN"
			print *, BLIN
		END IF
		call LinearSolve(TRANSPOSE(ALIN),4,BLIN,dXLIN)

		IF (DISP>=3) THEN
			print *, "dXLIN"
			print *, dXLIN
		END IF

		!Update variables
		DEp=DEp+dXLIN(1)
		DEq=DEq+dXLIN(2)
		ep=ep+dXLIN(3)
		f=f+dXLIN(4)
		! 22.11.2013 - Divergence control
		IF ((res<=TOL) .OR. (res>resn)) EXIT
	end do
	! 18.11.2013 Added Analytical Consistent Tangent
	BETAplus = STRIAL-X/T
	! Calculate p and q
	call pressure(BETAplus,pplus)
	call vonmises(BETAplus,qplus)

	p = pplus+(K+2.0/9.0*C/T*s)*DEp
	q = qplus-(G+1.0/3.0*C/T*s)*3.0*DEq
	qe = q + 3.0*G*DEq

	onevec = (/1.0,1.0,1.0,0.0,0.0,0.0/)
	tempmat6(1:6,1:6) = 0.0
	tempmat7(1:6,1:6) = 0.0
	N = 1.5*(BETAplus+pplus*onevec)/qplus

	! Determine derivatives d/dstr
	dpdstr = -1.0/3.0*onevec
	dqdstr = N
	dF1dstr = dphidp2*dpdstr*DEq + dphidq2*dqdstr*DEp
	dF2dstr = dphidp*dpdstr + dphidq*dqdstr
	dG1dstr = -(-dpdstr*DEp+dqdstr*DEq)/((1.0-f)*sflow)
	IF (p<0) THEN
		dG2dstr = A*dG1dstr
	ELSE
		dG2dstr = 0.0*onevec
	END IF
	! Total differentiation of equations 3 and 4
	! Solve variations varep, varf using static condensation from 2x2 system
	Amat2 = ALIN(3:4,3:4)
	Bmat2 = -1.0*ALIN(1:2,3:4)
	call MatrixInverse2(Amat2, Cmat2)
	Amat2 = MATMUL(Cmat2,Bmat2)
	dH1dDEp = Amat2(1,1)
	dH1dDEq = Amat2(2,1)
	dH1dstr = -(Cmat2(1,1)*dG1dstr+Cmat2(2,1)*dG2dstr)
	dH2dDEp = Amat2(1,2)
	dH2dDEq = Amat2(2,2)
	dH2dstr = -(Cmat2(1,2)*dG1dstr+Cmat2(2,2)*dG2dstr)
	! Variations of internal variables are expressed using varDEp, varDEq and varstr:
	! varep = dH1dDEp*varDEp + dH1dDEq*varDEq + DOT_PRODUCT(dH1dstr,varstr)
	! varf = dH2dDEp*varDEp + dH2dDEq*varDEq + DOT_PRODUCT(dH2dstr,varstr)

	! Total differentiation of equations 1 and 2 with respect to DEp, DEq, ep, f, STRIAL
	! Expressing varep and varf using the above relations => varDEp, varDEq, varstr
	Amat2 = ALIN(1:2,1:2)
	Amat2(1,1) = Amat2(1,1) + dF1dep*dH1dDEp + dF1df*dH2dDEp
	Amat2(2,1) = Amat2(2,1) + dF1dep*dH1dDEq + dF1df*dH2dDEq
	Amat2(1,2) = Amat2(1,2) + dF2dep*dH1dDEp + dF2df*dH2dDEp
	Amat2(2,2) = Amat2(2,2) + dF2dep*dH1dDEq + dF2df*dH2dDEq
	B1 = -1.0*(dF1dstr + dF1dep*dH1dstr + dF1df*dH2dstr)
	B2 = -1.0*(dF2dstr + dF2dep*dH1dstr + dF2df*dH2dstr)
	call MatrixInverse2(Amat2,Cmat2)
	! Variation mapping operators
	! dDEp = Bp:dSTRIAL
	! dDEq = Bq:dSTRIAL
	! dep = Bep:dSTRIAL
	! df = Bf:dSTRIAL
	Bp = Cmat2(1,1)*B1 + Cmat2(2,1)*B2
	Bq = Cmat2(1,2)*B1 + Cmat2(2,2)*B2
	Bep = dH1dDEp*Bp + dH1dDEq*Bq + dH1dstr
	Bf = dH2dDEp*Bp + dH2dDEq*Bq + dH2dstr

	dNdT = -1.5*X/(qplus*T**2)-N/qplus*mult4

	!call OUTER_PRODUCT(N,N,tempmat6,6)
	!PP(1:6,1:6) = 0.0
	!PP(1:3,1) = (/2.0/3.0, -1.0/3.0, -1.0/3.0/)
	!PP(1:3,2) = (/-1.0/3.0, 2.0/3.0, -1.0/3.0/)
	!PP(1:3,3) = (/-1.0/3.0, -1.0/3.0, 2.0/3.0/)
	!PP(4,4) = 1.0
	!PP(5,5) = 1.0
	!PP(6,6) = 1.0
	!dNdstr = (1.5*PP-tempmat6)/qe
	!call OUTER_PRODUCT(onevec,Bp,tempmat6,6)
	!QQ = 1.0/3.0*tempmat6
	!call OUTER_PRODUCT(N,Bq,tempmat6,6)
	!QQ = QQ + tempmat6
	!! Build Dn/Dstr
	!! dNdT*dTdDEp*varDEp
	!call OUTER_PRODUCT(dNdT,Bp,tempmat7,6)
	!tempmat6 = dTdDEp*tempmat7
	!! dNdT*dTdDEq*varDEq
	!call OUTER_PRODUCT(dNdT,Bq,tempmat7,6)
	!tempmat6 = tempmat6 + dTdDEq*tempmat7
	!! dNdT*dTdep*varep
	!call OUTER_PRODUCT(dNdT,Bep,tempmat7,6)
	!tempmat6 = tempmat6 + dTdep*tempmat7
	!! dNdT*dTdf*varf
	!call OUTER_PRODUCT(dNdT,Bf,tempmat7,6)
	!tempmat6 = tempmat6 + dTdf*tempmat7
	!! Add dNdstr
	!tempmat6 = tempmat6 + dNdstr
	!! Combine to Q matrix
	!QQ = QQ + tempmat6*DEq
	!DDSDDE = CELAS - MATMUL(TRANSPOSE(CELAS),MATMUL(QQ,CELAS))

	! 20.11.2013 Added tensor calculus here

	! Fourth order identity tensor "Itensor"
	call IdentityTensor(Itensor)
	! Projection tensor "Ptensor"
	call TensorDyad(onevec,onevec,tensor1)
	Ptensor = Itensor-1.0/3.0*tensor1
	! Elasticity tensor "Ctensor"
	CTensor = K*tensor1+2.0*G*Ptensor

	! Calculate variation of N
	! dN/dstr
	call TensorDyad(N,N,tensor1)
	tensor2 = (1.5*Ptensor-tensor1)/qe
	call TensorDyad(dNdT,dTdDEp*Bp+dTdDEq*Bq+dTdep*Bep+dTdf*Bf,tensor1)
	! variation of var(N)/var(str)
	tensor2 = tensor2 + tensor1

	! Build Q tensor
	Qtensor = tensor2*DEq
	call TensorDyad(N,Bq,tensor1)
	Qtensor = Qtensor + tensor1
	call TensorDyad(onevec,Bp,tensor1)
	Qtensor = Qtensor + 1.0/3.0*tensor1

	! Calculate C_ijst Q_stpq C_pqkl
	call TensorQuad(Ctensor,Qtensor,Ctensor,tensor1)
	DTensor = CTensor - tensor1

	! Return 4th order tensor to 6x6 matrix
	call reduce4tensor(DTensor, DDSDDE)

	IF (DISP>=1) THEN
		print *, '***** Finished PlasticIteration *****'
	END IF
end subroutine
subroutine LoadPROPS(f0,fc,ff,fn,sn,en,qinf,b,C,ga,EE,nu,syield,PROPS,NPROPS,DISP)
	implicit none
	real(8),intent(inout) :: f0,fc,ff,fn,sn,en,qinf,b,C,ga,EE,nu,syield
	integer, intent(in) :: NPROPS,DISP
	real(8),dimension(NPROPS), intent(in) :: PROPS
	IF (DISP>=1) THEN
		print *, '***** Loading PROPS *****'
	END IF
	!Properties for porosity
	f0=PROPS(1)!f0,initial porosity[GJS-700:0.02,GJV-450:0.05,GJL-250:0.125]
	fc=PROPS(2)!fc,critical porosity[0.0325,0.08,1.0]
	ff=PROPS(3)!ff,failure porosity[0.25,0.1,1.0]
	fn=PROPS(4)!fn,volume fraction of graphite inclusions[0.04,0.1,0.25]
	sn=PROPS(5)!sn,standard deviation of graphite inclusions[0.001,0.001,-]
	en=PROPS(6)!en,mean value of graphite inclusions[0.0,0.0,-]
	qinf=PROPS(7)!Isotropic hardening amplitude
	b=PROPS(8)!Isotropic hardening exponent sflow=syield+qinf*(1-EXP(-b*ep))
	C=PROPS(9)!Cyclic hardening parameter
	ga=PROPS(10)!Cyclic saturation parameter. In von Mises plasticity C/ga=qinf,ga=b
	EE=PROPS(11)!Young's modulus
	nu=PROPS(12)!Poisson's ratio
	syield=PROPS(13)!Yield stress
	IF (DISP>=1) THEN
		print *, '***** PROPS Loaded *****'
	END IF
end subroutine
subroutine LoadSTATEV(f,ep,DEp,DEq,EELAS,EPLAS,X,STATEV,NSTATV,NTENS,NDI,NSHR,DROT,DISP)
	implicit none
	real(8),intent(inout) :: f,ep,DEp,DEq
	integer,intent(in) :: NSTATV,NTENS,NDI,NSHR,DISP
	real(8),dimension(6),intent(inout) :: EELAS,EPLAS,X
	real(8),dimension(NSTATV),intent(in) :: STATEV
	real(8),dimension(3,3),intent(in) :: DROT
	IF (DISP>=1) THEN
		print *, '***** Loading STATEV *****'
	END IF
	!STATEV(1)=f:Porosity
	f = STATEV(1)
	!STATEV(2)=ep:equivalent plastic strain
	ep=STATEV(2)
	!STATEV(3)=DEp: Hydrostatic inelastic strain increment
	DEp=STATEV(3)
	!STATEV(4)=DEp: Deviatoric inelastic strain increment
	DEq=STATEV(4)
	!ROTATE TENSORS
	!STATEV(5)...STATEV(10)=EELAS
	CALL ROTSIG(STATEV(5),DROT,EELAS,2,NDI,NSHR)
	!STATEV(11)...STATEV(16)=EPLAS
	CALL ROTSIG(STATEV(5+NTENS),DROT,EPLAS,2,NDI,NSHR)
	!STATEV(17)...STATEV(22)=X
	CALL ROTSIG(STATEV(5+2*NTENS),DROT,X,1,NDI,NSHR)
	IF (DISP>=1) THEN
		print *, '***** STATEV Loaded *****'
	END IF
end subroutine
subroutine UpdateSTATEV(f,ep,DEp,DEq,EELAS,EPLAS,X,STATEV,NSTATV,NTENS,DISP)
	implicit none
	real(8),intent(in) :: f,ep,DEp,DEq
	integer,intent(in) :: NSTATV,NTENS,DISP
	real(8),dimension(6),intent(in) :: EELAS,EPLAS,X
	real(8),dimension(NSTATV),intent(inout) :: STATEV
	integer :: I
	IF (DISP>=1) THEN
		print *, '***** Updating STATEV *****'
	END IF
	STATEV(1)=f
	STATEV(2)=ep
	STATEV(3)=DEp
	STATEV(4)=DEq
	DO I=1,NTENS
		STATEV(4+I)=EELAS(I)
		STATEV(4+I+NTENS)=EPLAS(I)
		STATEV(4+I+2*NTENS)=X(I)
	END DO
	IF (DISP>=1) THEN
		print *, '***** STATEV Updated *****'
	END IF
end subroutine
subroutine Updateft(f,ft,dftdf,fu,fc,ff)
	implicit none
	real(8),intent(in) :: f,fu,fc,ff
	real(8),intent(inout) :: ft,dftdf
	real(8) :: df,k,a,b,c
	k = (fu-fc)/(ff-fc)
	df = 0.1*fc
	if (f<=(fc-df)) then
		ft = f
		dftdf = 1.0
	elseif ((f>(fc-df)) .and. (f<=(fc+df))) then
		a = (k-1.0)/(4.0*df)
		b = fc+(1.0+k)/(1.0-k)*df
		c = fc+k/(1-k)*df
		ft = a*(f-b)**2+c
		dftdf = 2*a*(f-b)
	else
		ft = fc + k*(f-fc)
		dftdf = k
	end if
end subroutine
subroutine IdentityTensor(II)
	implicit none
	real(8), dimension(3,3,3,3), intent(inout) :: II
	integer :: i,j,k,l
	DO i=1,3
		DO j=1,3
			DO k=1,3
				DO l=1,3
					II(i,j,k,l) = 0.5*(Delta(i,k)*Delta(j,l) + Delta(i,l)*Delta(j,k))
				END DO
			END DO
		END DO
	END DO
CONTAINS
	REAL function Delta(i,j)
		implicit none
		integer, intent(in) :: i,j
		IF (i==j) THEN
			Delta = 1.0
		ELSE
			Delta = 0.0
		END IF
	END FUNCTION Delta
end subroutine
subroutine TensorDyad(a,b,AAt)
	implicit none
	real(8), dimension(6), intent(in) :: a,b
	real(8), dimension(3,3,3,3), intent(inout) :: AAt
	real(8), dimension(3,3) :: at,bt
	integer :: i,j,k,l

	! Convert vectors to tensor
	call vector2tensor(a,at)
	call vector2tensor(b,bt)

	! Calculate A_ijkl = a_ij b_kl
	DO i=1,3
		DO j=1,3
			DO k=1,3
				DO l=1,3
					AAt(i,j,k,l) = at(i,j)*bt(k,l)
				END DO
			END DO
		END DO
	END DO
end subroutine
subroutine TensorProd(A,B,RES)
	implicit none
	real(8), dimension(3,3,3,3), intent(inout) :: A,B,RES
	integer :: i,j,k,l,s,t
	! Calculates C_ijkl = A_ijst B_stkl
	RES(1:3,1:3,1:3,1:3) = 0.0
	DO i=1,3
		DO j=1,3
			DO k=1,3
				DO l=1,3
					DO s=1,3
						DO t=1,3
							RES(i,j,k,l) = RES(i,j,k,l) + A(i,j,s,t)*B(s,t,k,l)
						END DO
					END DO
				END DO
			END DO
		END DO
	END DO
end subroutine
subroutine TensorQuad(A,B,C,RES)
	implicit none
	real(8), dimension(3,3,3,3), intent(inout) :: A,B,C,RES
	real(8), dimension(3,3,3,3) :: temp
	! Calculates D_ijkl = A_ijst B_stpq C_pqkl
	call TensorProd(B,C,temp)
	call TensorProd(A,temp,RES)
end subroutine
subroutine vector2tensor(a,AA)
	implicit none
	real(8), dimension(6), intent(in) :: a
	real(8), dimension(3,3), intent(inout) :: AA
	AA(1,1) = a(1)
	AA(2,2) = a(2)
	AA(3,3) = a(3)
	AA(3,2) = a(4)
	AA(2,3) = a(4)
	AA(1,3) = a(5)
	AA(3,1) = a(5)
	AA(1,2) = a(6)
	AA(2,1) = a(6)
end subroutine
subroutine reduce4tensor(AAt, AA)
	implicit none
	real(8), dimension(3,3,3,3), intent(in) :: AAt
	real(8), dimension(6,6), intent(inout) :: AA
	integer, dimension(2,6) :: idx
	integer :: row, col,i,j,k,l
	! Mapping for the indices
	idx(1,:) = (/1,2,3,2,1,1/)
	idx(2,:) = (/1,2,3,3,3,2/)
	DO row=1,6
		i = idx(1,row)
		j = idx(2,row)
		DO col=1,6
			k = idx(1,col)
			l = idx(2,col)
			AA(row,col) = AAt(i,j,k,l)
		END DO
	END DO
end subroutine
subroutine MatrixInverse2(A,Ainv)
	implicit none
	real(8), dimension(2,2), intent(in) :: A
	real(8), dimension(2,2), intent(inout) :: Ainv
	real(8) :: detA
	detA = A(1,1)*A(2,2)-A(1,2)*A(2,1)
	Ainv(1,1) = A(2,2)/detA
	Ainv(2,1) = -A(2,1)/detA
	Ainv(1,2) = -A(1,2)/detA
	Ainv(2,2) = A(1,1)/detA
end subroutine
subroutine OUTER_PRODUCT(a,b,C,n)
	implicit none
	real(8), intent(in) :: a(n),b(n)
	integer, intent(in) :: n
	real(8), intent(inout) :: C(n,n)
	integer :: i,j
	do i=1,n
		do j=1,n
			C(i,j) = a(j)*b(i)
		end do
	end do
end subroutine
subroutine LinearSolve(A,n,b,x)
	implicit none

	real(8),intent(in) :: A(n,n),b(n)
	integer,intent(in) :: n
	real(8),intent(inout) :: x(n)
	real(8) :: c(1,n)

	integer :: ipiv(n),info,nrhs,lda,ldb

	nrhs=1
	lda=n
	ldb=n
	c(1,1:n)=b(1:n)
	call dgesv(n,nrhs,A,lda,ipiv,c,ldb,info)
	x(1:n)=c(1,1:n)
end subroutine
subroutine pressure(S,p)
	implicit none
	real(8), dimension(6), intent(in) :: S
	real(8), intent(inout) :: p
	p = -(S(1)+S(2)+S(3))/3.0
end subroutine
subroutine vonmises(S,q)
	implicit none
	real(8), dimension(6), intent(in) :: S
	real(8), intent(inout) :: q
	!real(8) :: p
	!real(8),dimension(6)::onevec
	q = sqrt(0.5*((S(1)-S(2))**2+(S(2)-S(3))**2+(S(1)-S(3))**2&
		+6.0*(S(4)**2+S(5)**2+S(6)**2)))
	!call pressure(S,p)
	!onevec=(/1.0,1.0,1.0,0.0,0.0,0.0/)
	!q = sqrt(1.5*DOT_PRODUCT(S+p*onevec,S+p*onevec))
end subroutine
subroutine mcosh(x,c)
	implicit none
	real(8),intent(in) :: x
	real(8),intent(inout) :: c
	real(8) :: xc
	xc = 30.0
	if (abs(x)<=xc) then
		c = cosh(x)
	else
		c = cosh(xc)+sinh(xc)*(abs(x)-xc)+0.5*cosh(xc)*(abs(x)-xc)**2
	end if
end subroutine
subroutine msinh(x,s)
	implicit none
	real(8), intent(in) :: x
	real(8), intent(inout) :: s
	real(8) :: xc
	xc = 30.0
	if (abs(x)<=xc) then
		s = sinh(x)
	else
		s = (cosh(xc)+sinh(xc)*(abs(x)-xc)+0.5*cosh(xc)*(abs(x)-xc)**2)*x/abs(x)
	end if
end subroutine
subroutine NumericalConsistentTangent(STRESS,STATEV,DSTRAN,DDSDDE,NDI,NSHR,NTENS,NSTATV,PROPS,NPROPS,DROT,DISP)
	implicit none
	REAL*8,INTENT(IN) :: STRESS(NTENS),STATEV(NSTATV),&
		DSTRAN(NTENS),PROPS(NPROPS),DROT(3,3)
	REAL*8,INTENT(INOUT) :: DDSDDE(NTENS,NTENS)
	integer,intent(in) :: NDI,NSHR,NTENS,NSTATV,NPROPS,DISP
	INTEGER :: I,J,MAXITERS
	REAL*8 :: tol,res
	REAL*8 :: f0,fc,ff,fn,sn,en,qinf,b,C,ga,EE,nu,syield
	REAL*8 :: K,G,la
	REAL*8 :: q1,q2,q3,fu
	REAL*8 :: pi,cosht,sinht,dphidq,dphidp
	REAL*8 :: DEp,DEq,ep,f,fnn
	REAL*8 :: ft, dftdf,ftn
	REAL*8 :: p,q,sflow,phi,qplus,pplus
	REAL*8 :: eps,eta,typx
	REAL*8,DIMENSION(6) :: STRIAL,X,EELAS,EPLAS,BETA,DEin,DSTRAIN,STRESSI,BETAplus,STRAIN
	REAL*8,DIMENSION(6) :: N,onevec
	REAL*8,DIMENSION(6,6) :: CELAS
	REAL*8,DIMENSION(3,3) :: IdentityMatrix
	! Constants
	pi=3.14159265358979
	tol = 1e-9
	MAXITERS = 20

	IF (DISP>=1) THEN
		print *, '***** Inside NumericalConsistentTangent *****'
	END IF
	! Metzger values
	!typx=1.0e-9
	typx=1.0
	eta=1.0e-5
	IdentityMatrix(1:3,1) = (/1.0, 0.0, 0.0/)
	IdentityMatrix(1:3,2) = (/0.0, 1.0, 0.0/)
	IdentityMatrix(1:3,3) = (/0.0, 0.0, 1.0/)

	!Load properties
	call LoadPROPS(f0,fc,ff,fn,sn,en,qinf,b,C,ga,EE,nu,syield,PROPS,NPROPS,DISP)

	!Bulk and shear moduli
	K=EE/(3.0*(1.0-nu))
	G=EE/(2.0*(1.0+nu))
	la=K-2.0/3.0*G

	!Tvergaard values for periodic void distributions
	q1=1.5
	q2=1.0
	q3=q1**2

	!Effective porosity at failure
	fu=(q1-SQRT(q1**2-q3))/q3

	! Load state variables
	call LoadSTATEV(f,ep,DEp,DEq,EELAS,EPLAS,X,STATEV,NSTATV,&
		NTENS,NDI,NSHR,IdentityMatrix,DISP)

	fnn = f
	!Effective linear elasticity tensor CELAS
	CELAS(1:NTENS,1:NTENS)=0.0
	DO I=1,NDI
		DO J=1,NDI
			CELAS(I,J)=la
		END DO
		CELAS(I,I)=2.0*G+la
	END DO
	DO I=NDI+1,NTENS
		CELAS(I,I)=G
	END DO

	!DEp = DEp/10.0
	!DEq = DEq/10.0

	DO I=1,NTENS
		IF (ABS(EELAS(I)+EPLAS(I))>typx) THEN
			eps=eta*ABS(EELAS(I)+EPLAS(I))*SIGN(1.0,DSTRAN(I))
		ELSE
			eps=eta*typx*SIGN(1.0,DSTRAN(I))
		END IF
		! Metzger values for perturbation
		!IF (ABS(DSTRAN(I))>typx) THEN
		!	eps = sqrt(eta)*DSTRAN(I)
		!ELSE
		!	eps = sqrt(eta)*typx*SIGN(1.0,DSTRAN(I))
		!END IF
		DSTRAIN(1:NTENS)=0.0
		DSTRAIN(I)=eps
		! Trial stress
		STRIAL=MATMUL(CELAS,EELAS+DSTRAIN)
		IF (DISP>=3) THEN
			print *, "DSTRAIN"
			print *, DSTRAIN
			print *, "STRESS(n):"
			print *, STRESS
			print *, "STRIAL:"
			print *, STRIAL
			print *, "X(n):"
			print *, X
		END IF
		! Relative stress
		BETA=STRIAL-X

		call pressure(BETA,p)
		call vonmises(BETA,q)
		IF (DISP>=3) THEN
			print *, "Pressure:", p, "Von Mises:", q
		END IF
		! Flow stress
		sflow = syield+qinf*(1.0-exp(-b*ep))

		! Update effective porosity and its derivative
		call Updateft(f,ft,dftdf,fu,fc,ff)

		! Yield function
		call mcosh(1.5*q2*p/sflow,cosht)
		call msinh(1.5*q2*p/sflow,sinht)
		phi = (q/sflow)**2 + 2.0*ft*q1*cosht-(1.0+q3*ft**2)
		IF (phi<0.0) THEN
			! Elastic step
			! Update DDSDDE
			DDSDDE(1:NTENS,I) = CELAS(1:NTENS,I)
			IF (DISP>=2) THEN
				PRINT *, "***** Elastic step *****"
			END IF
		ELSE
			! Plastic step
			res = 1.0
			! 12.11.2013 Changed plastic starting-guess
			! Close to ideal-plastic starting guess
			! Least-squares method, N:N = 3/2
			DEp = DSTRAIN(1)+DSTRAIN(2)+DSTRAIN(3)
			!IF (ABS(DEp)<TOL) THEN
			!	DEp = tol*sign(1.0,DEp)
			!END IF
			onevec=(/1.0,1.0,1.0,0.0,0.0,0.0/)
			N = 1.5*(BETA+p*onevec)/q
			DEq = 2.0/3.0*DOT_PRODUCT(N,DSTRAIN-DEp/3.0*onevec)
			! Returns iteration variables: f, ep, DEp, DEq and residual res
			call PlasticIteration(f,ep,DEp,DEq,DDSDDE,STRIAL,X,0.0,fnn,MAXITERS,TOL,&
				PROPS,NPROPS,NTENS,NDI,res,DISP-1)
			! Check for convergence
			IF (res>tol) THEN
				PRINT *, "***** Plastic iteration failed at consistent tangent iteration direction", I, "*****"
			!	PRINT *, "***** Using elastic tangent *****"
			!	DDSDDE(1:NTENS,I) = CELAS(1:NTENS,I)
			ELSE
				DEin = EPLAS
				! Update STRESS,X,DEin
				call UpdateStress(f,ep,DEp,DEq,STRIAL,X,PROPS,NPROPS,&
					STRESSI,DEin,fnn,NTENS,NDI,DISP)
				DDSDDE(1:NTENS,I) = (STRESSI-STRESS)/eps
			END IF
		END IF
	END DO
	IF (DISP>=1) THEN
		print *, '***** Finished NumericalConsistentTangent *****'
	END IF
end subroutine


SUBROUTINE transf1(ne_new,nnod,ng,coorn,coora,l_old,l_new,sg_new,strnd)

  ! transfers data from the old mesh to the new one (from old nodes to new Gauss points)

  USE lispa0
  USE ctrl_db, ONLY : ndime
  IMPLICIT NONE

  ! dummy arguments
  INTEGER (kind=4), INTENT(IN) :: ne_new, &       ! number of elements in the new mesh
                                  nnod,   &       ! number of nodes per elemen (new)
                                  ng              ! number of Gauss points
  INTEGER (kind=4), POINTER    :: l_old(:,:),  &  ! connectivities of old elements
                                  l_new(:,:)      ! connectivities of new elements
  REAL (kind=8), INTENT(IN)    :: coorn(:,:),  &  ! coordinates of new points
                                  coora(:,:)      ! coordinates of old points

  REAL (kind=8), POINTER :: &
                      sg_new(:,:),  &  ! internal variables at gauss points (new mesh)
                      strnd(:,:)       ! internal variables at nodes (old mesh)

  ! local
  INTEGER (kind=4) :: i, j, k, ie, ip, lj, ne_old, nepe, nnode, &
                      nvarg, l(3,2),io,np,ig,ng1
  REAL (kind=8) :: xn(ndime), xx(ndime,nnod),x(ndime,3), ar(3), area, det2, tol, tiny
  REAL (kind=8) :: posgp(2), shape(nnod,ng),deriv(nnod,2),xi,eta
  REAL (kind=8), PARAMETER ::  SMALL=5.0D-2    !tolerance in proyection
  REAL (kind=8), PARAMETER ::  tol0 =1.0D-4    !tolerance in bounding-box
  REAL (kind=8), POINTER ::  ftot(:)

  INTERFACE
    INCLUDE 'nonear.h'
  END INTERFACE

  nnode  = SIZE(l_old,1)       !number of nodes per element in previous mesh
  ne_old = SIZE(l_old,2)       !number of elements in previous mesh
  nvarg  = SIZE(strnd,1)       !number of internal variables to transfer
  ALLOCATE (ftot(nvarg))
  IF (nnod == 4) THEN
    posgp = (/ -0.577350269189626D+00, 0.577350269189626D+00 /)
    ng1 = 2
  ELSE !IF (nnod == 3) THEN
    posgp = (/  0.333333333333333D+00, 0d0  /)
    ng1 = 1
  END IF

  !      gauss points shape and derivatives of nodal functions

  k = 0
  DO i=1,ng1
    xi = posgp(i)
    DO j=1,ng1
      k = k+1
      eta = posgp(j)
      CALL shape3(deriv(1,1),shape(1,k),xi,eta,nnod)
    END DO
  END DO

  !       reserve space for Gauss variables, velocities and auxiliar array
  ! initialzes tolerances in bounding box and local area coordinates
  tol = MAXVAL(coorn(1,:)) - MINVAL(coorn(1,:))
  tol = MAX(MAXVAL(coorn(2,:)) - MINVAL(coorn(2,:)),tol)*tol0 !bounding box tolerance
  tiny = small                                                !local coord tolerance
  ! loop over new elements

  ie = 1         !initializes first element to look in
  ig = 0         !initializes New Gauss point pointer
  DO ip = 1, ne_new       !for each new element
    xx = coorn(:,l_new(:,ip))  !coordinates
    L10: DO k=1,ng                    !for each New gauss point
      xn = MATMUL(xx,shape(:,k)) ! coordinates of new gauss points
      ig = ig+1                  ! gauss point order
      ! loop over all the elements in the old mesh to find its proyection
      io = ie                  !remember first searched element
15    np = 0                   !number of elements with proyection
      L15: DO                  !loop until proyection found

        CALL trian(nnode,l_old(1:nnode,ie),l,nepe)   !divide Quadrilateral element in Triangle

        L20: DO i=1,nepe  ! number of sub-triangles in an element (1 for Triangles)

          x(:,:) = coora(:,l(:,i))                   !triangle coordinates

          ! discard an element if this point is outside its boundingbox
          IF (nonear (xn, x, ndime,tol)) CYCLE L20
          np = np+1
          ! element area
          area  = det2(x(1,1),x(1,2),x(1,3),ndime,.TRUE.)

          ! three subelements (natural triangular coordinates)
          ar(1) = det2(x(1,2), x(1,3), xn, ndime,.FALSE.) / area
          IF (ar(1) < -TINY) CYCLE L20

          ar(2) = det2(x(1,3), x(1,1), xn, ndime,.FALSE.) / area
          IF (ar(2) < -TINY) CYCLE L20

          ar(3) = 1d0 -ar(1) -ar(2)
          !ar(3) = det2(x(1,1), x(1,2), xn, ndime,.FALSE.) / area
          IF (ar(3) < -TINY) CYCLE L20

          ! interpolate using area coordinates
          ftot = 0d0           !initializes variables
          DO j=1,3             !for each node
            lj = l(j,i)        !associated node
            ftot(:) = ftot(:) + strnd(:,lj)*ar(j)  !internal variables
          END DO
          sg_new(:,ig) = ftot(:)
          CYCLE L10  ! jump out - don't check any more elements

        END DO L20   !loop over individual triangles
        ie = MOD(ie,ne_old) + 1  !new element (if passed end of the list, back to first)
        IF( ie == io )EXIT       !if back to the first element tested =>EXIT
      END DO L15
      WRITE(lures,*,ERR=9999) ip,'  not placed, FATAL'   !proyection not found => ERROR
      WRITE(55,*,ERR=9999) ip,'  not placed, FATAL'      !proyection not found => ERROR
      PRINT *, ip,'  not placed, FATAL'                  !proyection not found => ERROR
      IF( np == 0 )THEN
        tol = tol*2d0  !increase bounding-box tolerance
      ELSE IF ( np == 1 ) THEN
        tol = tol*2d0  !increase bounding-box tolerance
        tiny= 2d0*tiny !increase local coordinate tolerance
      ELSE
        tiny= 2d0*tiny !increase local coordinate tolerance
      END IF
      GO TO 15   !loop again with a larger tolerance
      !STOP
    END DO L10
  END DO   ! end of new point loop
RETURN
 9999 CALL runen2('')
END SUBROUTINE transf1


*> \brief \b DROTMG
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM)
*
*       .. Scalar Arguments ..
*       DOUBLE PRECISION DD1,DD2,DX1,DY1
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION DPARAM(5)
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>    CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
*>    THE SECOND COMPONENT OF THE 2-VECTOR  (DSQRT(DD1)*DX1,DSQRT(DD2)*>    DY2)**T.
*>    WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
*>
*>    DFLAG=-1.D0     DFLAG=0.D0        DFLAG=1.D0     DFLAG=-2.D0
*>
*>      (DH11  DH12)    (1.D0  DH12)    (DH11  1.D0)    (1.D0  0.D0)
*>    H=(          )    (          )    (          )    (          )
*>      (DH21  DH22),   (DH21  1.D0),   (-1.D0 DH22),   (0.D0  1.D0).
*>    LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22
*>    RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE
*>    VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.)
*>
*>    THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
*>    INEXACT.  THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
*>    OF DD1 AND DD2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
*>
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in,out] DD1
*> \verbatim
*>          DD1 is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in,out] DD2
*> \verbatim
*>          DD2 is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in,out] DX1
*> \verbatim
*>          DX1 is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] DY1
*> \verbatim
*>          DY1 is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[out] DPARAM
*> \verbatim
*>          DPARAM is DOUBLE PRECISION array, dimension (5)
*>     DPARAM(1)=DFLAG
*>     DPARAM(2)=DH11
*>     DPARAM(3)=DH21
*>     DPARAM(4)=DH12
*>     DPARAM(5)=DH22
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2017
*
*> \ingroup double_blas_level1
*
*  =====================================================================
      SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM)
*
*  -- Reference BLAS level1 routine (version 3.8.0) --
*  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2017
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION DD1,DD2,DX1,DY1
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION DPARAM(5)
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,DP1,DP2,DQ1,DQ2,DTEMP,
     $                 DU,GAM,GAMSQ,ONE,RGAMSQ,TWO,ZERO
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC DABS
*     ..
*     .. Data statements ..
*
      DATA ZERO,ONE,TWO/0.D0,1.D0,2.D0/
      DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/
*     ..

      IF (DD1.LT.ZERO) THEN
*        GO ZERO-H-D-AND-DX1..
         DFLAG = -ONE
         DH11 = ZERO
         DH12 = ZERO
         DH21 = ZERO
         DH22 = ZERO
*
         DD1 = ZERO
         DD2 = ZERO
         DX1 = ZERO
      ELSE
*        CASE-DD1-NONNEGATIVE
         DP2 = DD2*DY1
         IF (DP2.EQ.ZERO) THEN
            DFLAG = -TWO
            DPARAM(1) = DFLAG
            RETURN
         END IF
*        REGULAR-CASE..
         DP1 = DD1*DX1
         DQ2 = DP2*DY1
         DQ1 = DP1*DX1
*
         IF (DABS(DQ1).GT.DABS(DQ2)) THEN
            DH21 = -DY1/DX1
            DH12 = DP2/DP1
*
            DU = ONE - DH12*DH21
*
           IF (DU.GT.ZERO) THEN
             DFLAG = ZERO
             DD1 = DD1/DU
             DD2 = DD2/DU
             DX1 = DX1*DU
           ELSE
*            This code path if here for safety. We do not expect this
*            condition to ever hold except in edge cases with rounding
*            errors. See DOI: 10.1145/355841.355847
             DFLAG = -ONE
             DH11 = ZERO
             DH12 = ZERO
             DH21 = ZERO
             DH22 = ZERO
*
             DD1 = ZERO
             DD2 = ZERO
             DX1 = ZERO
           END IF
         ELSE

            IF (DQ2.LT.ZERO) THEN
*              GO ZERO-H-D-AND-DX1..
               DFLAG = -ONE
               DH11 = ZERO
               DH12 = ZERO
               DH21 = ZERO
               DH22 = ZERO
*
               DD1 = ZERO
               DD2 = ZERO
               DX1 = ZERO
            ELSE
               DFLAG = ONE
               DH11 = DP1/DP2
               DH22 = DX1/DY1
               DU = ONE + DH11*DH22
               DTEMP = DD2/DU
               DD2 = DD1/DU
               DD1 = DTEMP
               DX1 = DY1*DU
            END IF
         END IF

*     PROCEDURE..SCALE-CHECK
         IF (DD1.NE.ZERO) THEN
            DO WHILE ((DD1.LE.RGAMSQ) .OR. (DD1.GE.GAMSQ))
               IF (DFLAG.EQ.ZERO) THEN
                  DH11 = ONE
                  DH22 = ONE
                  DFLAG = -ONE
               ELSE
                  DH21 = -ONE
                  DH12 = ONE
                  DFLAG = -ONE
               END IF
               IF (DD1.LE.RGAMSQ) THEN
                  DD1 = DD1*GAM**2
                  DX1 = DX1/GAM
                  DH11 = DH11/GAM
                  DH12 = DH12/GAM
               ELSE
                  DD1 = DD1/GAM**2
                  DX1 = DX1*GAM
                  DH11 = DH11*GAM
                  DH12 = DH12*GAM
               END IF
            ENDDO
         END IF

         IF (DD2.NE.ZERO) THEN
            DO WHILE ( (DABS(DD2).LE.RGAMSQ) .OR. (DABS(DD2).GE.GAMSQ) )
               IF (DFLAG.EQ.ZERO) THEN
                  DH11 = ONE
                  DH22 = ONE
                  DFLAG = -ONE
               ELSE
                  DH21 = -ONE
                  DH12 = ONE
                  DFLAG = -ONE
               END IF
               IF (DABS(DD2).LE.RGAMSQ) THEN
                  DD2 = DD2*GAM**2
                  DH21 = DH21/GAM
                  DH22 = DH22/GAM
               ELSE
                  DD2 = DD2/GAM**2
                  DH21 = DH21*GAM
                  DH22 = DH22*GAM
               END IF
            END DO
         END IF

      END IF

      IF (DFLAG.LT.ZERO) THEN
         DPARAM(2) = DH11
         DPARAM(3) = DH21
         DPARAM(4) = DH12
         DPARAM(5) = DH22
      ELSE IF (DFLAG.EQ.ZERO) THEN
         DPARAM(3) = DH21
         DPARAM(4) = DH12
      ELSE
         DPARAM(2) = DH11
         DPARAM(5) = DH22
      END IF

      DPARAM(1) = DFLAG
      RETURN
      END


      DOUBLE PRECISION FUNCTION DT_XMHMD(Ecm,Ib,Mode)

C***********************************************************************
C Diffractive mass in high mass single/double diffractive events.      *
C This version dated 11.02.95 is written by S. Roesler                 *
C***********************************************************************

      IMPLICIT NONE
      DOUBLE PRECISION DT_RNDM , DT_SAMPEX , Ecm , OHALF , ONE , r ,
     &                 rr , xcolow , xdiff , xdimax , xdimin , xh , ZERO
      INTEGER Ib , kloop , Mode
      SAVE

      INCLUDE 'inc/dtflka'

      PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)

C kinematics of diffractive interactions (DTUNUC 1.x)
      INCLUDE 'inc/dtdiki'

C     DATA XCOLOW /0.05D0/
      DATA xcolow/0.15D0/

      DT_XMHMD = ZERO
      xh = XPH(2)
      IF ( Mode.EQ.2 ) xh = XTH(2)

C minimum Pomeron-x for high-mass diffraction
C (adjusted to get a smooth transition between HM and LM component)
      r = DT_RNDM(xh)
      xdimin = (3.0D0+400.0D0*r**2)/(xh*Ecm**2)
      IF ( Ecm.LE.300.0D0 ) THEN
         rr = (1.0D0-EXP(-((Ecm/140.0D0)**4)))
         xdimin = (3.0D0+400.0D0*(r**2)*rr)/(xh*Ecm**2)
      END IF
C maximum Pomeron-x for high-mass diffraction
C (coherence condition, adjusted to fit to experimental data)
      IF ( Ib.NE.0 ) THEN
C   baryon-diffraction
         xdimax = xcolow*(1.0D0+EXP(-((Ecm/420.0D0)**2)))
      ELSE
C   meson-diffraction
         xdimax = xcolow*(1.0D0+4.0D0*EXP(-((Ecm/420.0D0)**2)))
      END IF
C check boundaries
      IF ( xdimin.GE.xdimax ) xdimin = OHALF*xdimax

      kloop = 0
 100  kloop = kloop + 1
C sample Pomeron-x from 1/x-distribution (critical Pomeron)
      IF ( kloop.GT.20 ) RETURN
      xdiff = DT_SAMPEX(xdimin,xdimax)
C corr. diffr. mass
      DT_XMHMD = Ecm*SQRT(xdiff)
      IF ( DT_XMHMD.LT.2.5D0 ) GOTO 100

      END FUNCTION