#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! ZUFSFI (Zomplex Unitary hessenberg Factored Singleshift Francis Iteration)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes one iteration of Francis' singleshift
! algorithm on a unitary upper hessenberg matrix that is stored as a
! product of givens rotations and a complex diagonal matrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  COMPZ           CHARACTER
!                    'N': no eigenvectors
!                    'I': eigenvectors, initializing Z to the identity
!                    'V': eigenvectors, assume Z already initialized
!
!  N               INTEGER
!                    dimension of matrix
!
!  STR             INTEGER
!                    index of the top most givens rotation where
!                    the iteration begins
!
!  STP             INTEGER
!                    index of the bottom most givens rotation where
!                    the iteration ends
!
!  Q               REAL(8) array of dimension (3*(N-1))
!                    array of generators for givens rotations
!
!  D               REAL(8) array of dimension (2*N)
!                    array of generators for complex diagonal matrix
!
!  Z               COMPLEX(8) array of dimension (N,N)
!                    if COMPZ = 'N' unused
!                    if COMPZ = 'I' stores eigenvectors in Z
!                    if COMPZ = 'V' update Z to store eigenvectors
!
!  ITCNT           INTEGER
!                   Contains the number of iterations since last deflation
!
! OUTPUT VARIABLES:
!
!  INFO            INTEGER
!                   INFO = 0 implies successful computation
!                   INFO = -1 implies COMPZ is invalid
!                   INFO = -2 implies N is invalid
!                   INFO = -3 implies STR is invalid
!                   INFO = -4 implies STP is invalid
!                   INFO = -7 implies Z is invalid
!                   INFO = -8 implies ITCNT is invalid
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine ZUFSFI(COMPZ,N,STR,STP,Q,D,Z,ITCNT,INFO)

  implicit none

  ! input variables
  character, intent(in) :: COMPZ
  integer, intent(in) :: N, STR, STP
  integer, intent(inout) :: ITCNT, INFO
  real(8), intent(inout) :: Q(3*(N-1)), D(2*N)
  complex(8), intent(inout) :: Z(N,N)

  ! compute variables
  integer :: ii, ind1, ind2
  real(8) :: s1, s2
  real(8) :: bulge(3),binv(3)
  complex(8) :: shift
  complex(8) :: block(2,2), temp(2,2), eigs(2)

  ! initialize INFO
  INFO = 0

  ! check input in debug mode
  if (DEBUG) then

    ! check COMPZ
    if ((COMPZ.NE.'N').AND.(COMPZ.NE.'I').AND.(COMPZ.NE.'V')) then
      INFO = -1
      call UARERR(__FILE__,__LINE__,"COMPZ must be 'N', 'I' or 'V'",INFO,INFO)
      return
    end if

    ! check N
    call IARNAN(N,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"N is invalid",INFO,-2)
      return
    end if
    call IARINF(N,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"N is invalid",INFO,-2)
      return
    end if
    if (N < 2) then
      INFO = -2
      call UARERR(__FILE__,__LINE__,"N must be at least 2",INFO,INFO)
      return
    end if

    ! check STR
    if ((STR < 1).OR.(STR > N-1)) then
      INFO = -3
      call UARERR(__FILE__,__LINE__,"STR must 1 <= STR <= N-1",INFO,INFO)
      return
    end if

    ! check STP
    if ((STP < STR).OR.(STP > N-1)) then
      INFO = -4
      call UARERR(__FILE__,__LINE__,"STP must STR <= STP <= N-1",INFO,INFO)
      return
    end if

    ! check Z
    if (COMPZ.EQ.'V') then
      call ZARACH2(N,N,Z,INFO)
      if (INFO.NE.0) then
        call UARERR(__FILE__,__LINE__,"Z is invalid",INFO,-7)
        return
      end if
    end if

    ! check ITCNT
    call IARNAN(ITCNT,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"ITCNT is invalid",INFO,-8)
      return
    end if
    call IARINF(ITCNT,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"ITCNT is invalid",INFO,-8)
      return
    end if
    if (ITCNT < 0) then
      INFO = -8
      call UARERR(__FILE__,__LINE__,"ITCNT must be non-negative",INFO,INFO)
      return
    end if

  end if

  ! compute a nonzero shift
  ! random shift
  if(mod(ITCNT+1,11) == 0)then
    call random_number(s1)
    call random_number(s2)
    shift = cmplx(s1,s2,kind=8)

  ! wilkinson shift
  else
    ! get 2x2 block
    call ZUFTDB(N,STP,Q,D,block,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"ZUFTDB failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! compute eigenvalues and eigenvectors
    call ZTTEEV(block,eigs,temp,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"ZTTEEV failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! choose wikinson shift
    if(abs(block(2,2)-eigs(1)) < abs(block(2,2)-eigs(2)))then
      shift = eigs(1)
    else
      shift = eigs(2)
    end if

  end if

  ! project shift onto unit circle
  if (abs(shift) .EQ. 0d0) then
    shift = cmplx(1d0,0d0,kind=8)
  end if
  shift = shift/abs(shift)

  ! build bulge
  call ZUFCFT(N,STR,Q,D,shift,bulge,INFO)

  ! check INFO in debug mode
  if (DEBUG) then
    call UARERR(__FILE__,__LINE__,"ZUFCFT failed",INFO,INFO)
    if (INFO.NE.0) then
      return
    end if
  end if

  ! bulge inverse
  binv(1) = bulge(1)
  binv(2) = -bulge(2)
  binv(3) = -bulge(3)

  ! fusion at top
  call ZUFFGR('T',N,STR,STP,Q,D,binv,INFO)

  ! check INFO in debug mode
  if (DEBUG) then
    call UARERR(__FILE__,__LINE__,"ZUFFGR failed",INFO,INFO)
    if (INFO.NE.0) then
      return
    end if
  end if

  ! main chasing loop
  do ii=STR,(STP-1)

    ! update eigenvectors
    if (COMPZ .NE. 'N')then
      temp(1,1) = cmplx(bulge(1),bulge(2),kind=8)
      temp(2,1) = cmplx(bulge(3),0d0,kind=8)
      temp(1,2) = -temp(2,1)
      temp(2,2) = conjg(temp(1,1))
      Z(:,ii:(ii+1)) = matmul(Z(:,ii:(ii+1)),temp)
    end if

    ! set indices
    ind1 = 2*(ii-1) + 1
    ind2 = ind1+3

    ! through diag
    call ZARGTD('R',D(ind1:ind2),bulge,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"ZARGTD failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

    ! set indices
    ind1 = 3*(ii-1) + 1
    ind2 = ind1+2

    ! through Q
    call ZARGTO(Q(ind1:ind2),Q((ind1+3):(ind2+3)),bulge,INFO)

    ! check INFO in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"ZARGTO failed",INFO,INFO)
      if (INFO.NE.0) then
        return
      end if
    end if

  end do

  ! update eigenvectors
  if (COMPZ .NE. 'N')then
    temp(1,1) = cmplx(bulge(1),bulge(2),kind=8)
    temp(2,1) = cmplx(bulge(3),0d0,kind=8)
    temp(1,2) = -temp(2,1)
    temp(2,2) = conjg(temp(1,1))
    Z(:,STP:(STP+1)) = matmul(Z(:,STP:(STP+1)),temp)
  end if

  ! fusion at bottom
  call ZUFFGR('B',N,STR,STP,Q,D,bulge,INFO)

  ! check INFO in debug mode
  if (DEBUG) then
    call UARERR(__FILE__,__LINE__,"ZUFFGR failed",INFO,INFO)
    if (INFO.NE.0) then
      return
    end if
  end if

  ! update ITCNT
  ITCNT = ITCNT + 1

end subroutine ZUFSFI


!==============================================================================!
  subroutine Multiphase_Mod_Vof_Heavyside_Function(mult)
!------------------------------------------------------------------------------!
!   Computes the Heavyside function, necessary for Brackbill's CSF approach    !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Work_Mod, only: heavy_side => r_cell_13
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Multiphase_Type), target :: mult
!-----------------------------------[Locals]-----------------------------------!
  type(Field_Type), pointer :: flow
  type(Grid_Type),  pointer :: grid
  type(Var_Type),   pointer :: vof
  type(Var_Type),   pointer :: dist_func
  integer                   :: c, s, c1, c2
  real                      :: eps_grid
!==============================================================================!

  flow      => mult % pnt_flow
  grid      => mult % pnt_grid
  vof       => mult % vof
  dist_func => mult % dist_func

  do c = 1, grid % n_cells

    eps_grid = 1.5 * grid % vol(c) ** ONE_THIRD

    if (dist_func % n(c) > eps_grid) then
      heavy_side(c) = 1.0
    else if (dist_func % n(c) < -eps_grid) then
      heavy_side(c) = 0.0
    else
      heavy_side(c) = 0.5 * ( 1.0 + dist_func % n(c) / eps_grid       &
                            + 1.0 / PI * sin(PI * dist_func % n(c)    &
                            / eps_grid))
    end if

  end do

  ! Values at boundaries
  do s = 1, grid % n_faces
    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)
    if (c2 < 0) then
      heavy_side(c2) = heavy_side(c1)
    end if
  end do

  ! Find gradients
  call Field_Mod_Grad_Component(flow, heavy_side, 1, vof % x)
  call Field_Mod_Grad_Component(flow, heavy_side, 2, vof % y)
  call Field_Mod_Grad_Component(flow, heavy_side, 3, vof % z)

  ! Store Heavyside function for the pressure correction step
  dist_func % oo = heavy_side

  end subroutine


      real(kind(0.0d0)) function dnrm2 (n, dx, incx)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  double
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
      implicit none
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      integer , intent(in) :: n
      integer , intent(in) :: incx
      real(double) , intent(in) :: dx(1)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      integer :: i, ix, j, next
      real(double) :: cutlo, cuthi, hitest, sum, xmax, zero, one
!-----------------------------------------------
      data zero, one/ 0.0D0, 1.0D0/
!
!     euclidean norm of the n-vector stored in dx() with storage
!     increment incx .
!     if    n .le. 0 return with result = 0.
!     if n .ge. 1 then incx must be .ge. 1
!
!           c.l.lawson, 1978 jan 08
!     modified to correct problem with negative increment, 8/21/90.
!     modified to correct failure to update ix, 1/25/92.
!
!     four phase method     using two built-in constants that are
!     hopefully applicable to all machines.
!         cutlo = maximum of  dsqrt(u/eps)  over all known machines.
!         cuthi = minimum of  dsqrt(v)      over all known machines.
!     where
!         eps = smallest no. such that eps + 1. .gt. 1.
!         u   = smallest positive no.   (underflow limit)
!         v   = largest  no.            (overflow  limit)
!
!     brief outline of algorithm..
!
!     phase 1    scans zero components.
!     move to phase 2 when a component is nonzero and .le. cutlo
!     move to phase 3 when a component is .gt. cutlo
!     move to phase 4 when a component is .ge. cuthi/m
!     where m = n for x() real and m = 2*n for complex.
!
!     values for cutlo and cuthi..
!     from the environmental parameters listed in the imsl converter
!     document the limiting values are as follows..
!     cutlo, s.p.   u/eps = 2**(-102) for  honeywell.  close seconds are
!                   univac and dec at 2**(-103)
!                   thus cutlo = 2**(-51) = 4.44089e-16
!     cuthi, s.p.   v = 2**127 for univac, honeywell, and dec.
!                   thus cuthi = 2**(63.5) = 1.30438e19
!     cutlo, d.p.   u/eps = 2**(-67) for honeywell and dec.
!                   thus cutlo = 2**(-33.5) = 8.23181d-11
!     cuthi, d.p.   same as s.p.  cuthi = 1.30438d19
!     data cutlo, cuthi / 8.232d-11,  1.304d19 /
!     data cutlo, cuthi / 4.441e-16,  1.304e19 /
      data cutlo, cuthi/ 8.232D-11, 1.304D19/
!
      if (n <= 0) then
         dnrm2 = zero
      else
!
         next = 30
         sum = zero
         i = 1
         if (incx < 0) i = ((-n) + 1)*incx + 1
         ix = 1
!                                                 begin main loop
   20    continue
         if (next == 30) go to 30
         if (next == 50) go to 50
         if (next == 70) go to 70
         if (next == 110) go to 110
   30    continue
         if (dabs(dx(i)) > cutlo) go to 85
         next = 50
         xmax = zero
!
!                        phase 1.  sum is zero
!
   50    continue
         if (dx(i) == zero) go to 200
         if (dabs(dx(i)) > cutlo) go to 85
!
!                                prepare for phase 2.
         next = 70
         go to 105
!
!                                prepare for phase 4.
!
  100    continue
         ix = j
         next = 110
         sum = (sum/dx(i))/dx(i)
  105    continue
         xmax = dabs(dx(i))
         go to 115
!
!                   phase 2.  sum is small.
!                             scale to avoid destructive underflow.
!
   70    continue
         if (dabs(dx(i)) > cutlo) go to 75
!
!                     common code for phases 2 and 4.
!                     in phase 4 sum is large.  scale to avoid overflow.
!
  110    continue
         if (dabs(dx(i)) <= xmax) go to 115
         sum = one + sum*(xmax/dx(i))**2
         xmax = dabs(dx(i))
         go to 200
!
  115    continue
         sum = sum + (dx(i)/xmax)**2
         go to 200
!
!
!                  prepare for phase 3.
!
   75    continue
         sum = (sum*xmax)*xmax
!
!
!     for real or d.p. set hitest = cuthi/n
!     for complex      set hitest = cuthi/(2*n)
!
   85    continue
         hitest = cuthi/float(n)
!
!                   phase 3.  sum is mid-range.  no scaling.
!
         do j = ix, n
            if (dabs(dx(i)) >= hitest) go to 100
            sum = sum + dx(i)**2
            i = i + incx
         end do
         dnrm2 = dsqrt(sum)
         go to 300
!
  200    continue
         ix = ix + 1
         i = i + incx
         if (ix <= n) go to 20
!
!              end of main loop.
!
!              compute square root and adjust for scaling.
!
         dnrm2 = xmax*dsqrt(sum)
      endif
  300 continue
      return
      end function dnrm2


! Gamma Probability Computation
!   Hiroyuki Okamura, Hiroshima University
!   okamu@rel.hiroshima-u.ac.jp

module gamma
  implicit none
!  double precision, parameter :: npi = 3.14159265358979324d0
  double precision, private, parameter :: log2pi = 1.83787706640934548d0
  double precision, private, parameter :: logpi = 1.14472988584940017d0
  integer, private, parameter :: CN = 8
  double precision, private, parameter :: &
    B0 = 1.0d0, B1 = -1.0d0 / 2.0d0, &
    B2 = 1.0d0 / 6.0d0, B4 = -1.0d0 / 30.0d0, &
    B6 = 1.0d0 / 42.0d0, B8 = -1.0d0 / 30.0d0, &
    B10 = 5.0d0 / 66.0d0, B12 = -691.0d0 / 2730.0d0, &
    B14 = 7.0d0 / 6.0d0, B16 = -3617.0d0 / 510.0d0
  integer, private, parameter :: factmax = 20
  double precision, private, parameter :: nfact(0:factmax) = (/ &
    1.0d0, 1.0d0, 2.0d0, 6.0d0, 24.0d0, &
    120.0d0, 720.0d0, 5040.0d0, 40320.0d0, 362880.0d0, 3628800.0d0, &
    39916800.0d0, 479001600.0d0, 6227020800.0d0, 87178291200.0d0, &
    1307674368000.0d0, 20922789888000.0d0, 355687428096000.0d0, &
    6402373705728000.0d0, 121645100408832000.0d0, &
    2432902008176640000.0d0 /)
  double precision, private, parameter :: lognfact(0:factmax) = (/ &
    0.0d0, 0.0d0, &
    0.6931471805599453d0, 1.791759469228055d0, &
    3.1780538303479458d0, 4.787491742782046d0, 6.579251212010101d0, &
    8.525161361065415d0, 10.60460290274525d0, 12.801827480081469d0, &
    15.104412573075516d0, 17.502307845873887d0, 19.987214495661885d0, &
    22.552163853123425d0, 25.19122118273868d0, 27.89927138384089d0, &
    30.671860106080672d0, 33.50507345013689d0, 36.39544520803305d0, &
    39.339884187199495d0, 42.335616460753485d0 /)
  public fact, logfact, loggamma, psi, polygamma

contains
  function fact(s)
    integer, intent(in) :: s
    double precision :: fact
    if (s <= factmax) then
       fact = nfact(s)
    else
       fact = exp(loggamma(dble(s + 1)))
    end if
  end function fact

  function logfact(s)
    integer, intent(in) :: s
    double precision :: logfact
    if (s <= factmax) then
       logfact = lognfact(s)
    else
       logfact = loggamma(dble(s + 1))
    end if
  end function logfact

  function loggamma(s)
    double precision, intent(in) :: s
    double precision :: loggamma
    double precision :: x, v, w
    x = s
    v = 1.0d0
    do while (x < CN)
       v = v * x
       x = x + 1.0d0
    end do
    w = 1.0d0 / (x * x)
    loggamma = ((((((((B16 / (16.0d0 * 15.0d0)) * w &
         + (B14 / (14.0d0 * 13.0d0))) * w &
         + (B12 / (12.0d0 * 11.0d0))) * w &
         + (B10 / (10.0d0 * 9.0d0))) * w &
         + (B8 / (8.0d0 * 7.0d0))) * w &
         + (B6 / (6.0d0 * 5.0d0))) * w &
         + (B4 / (4.0d0 * 3.0d0))) * w &
         + (B2 / (2.0d0 * 1.0d0))) / x &
         + 0.5d0 * log2pi - log(v) - x + (x - 0.5d0) * log(x)
    return
  end function loggamma

  function psi(s)
    double precision, intent(in) :: s
    double precision :: psi
    double precision :: x, v, w
    x = s
    v = 0.0d0
    do while (x < CN)
       v = v + 1.0d0 / x
       x = x + 1.0d0
    end do
    w = 1.0d0 / (x * x)
    v = v + ((((((((B16 / 16.0d0) * w &
         + (B14 / 14.0d0)) * w &
         + (B12 / 12.0d0)) * w &
         + (B10 / 10.0d0)) * w &
         + (B8 / 8.0d0)) * w &
         + (B6 / 6.0d0)) * w &
         + (B4 / 4.0d0)) * w &
         + (B2 / 2.0d0)) * w &
         + 0.5d0 / x
    psi = log(x) - v
  end function psi

  function polygamma(n, s)
    integer, intent(in) :: n
    double precision, intent(in) :: s
    double precision :: polygamma
    integer :: k
    double precision :: x, t, u, v, w
    x = s
    u = 1.0d0
    do k = 1-n, -1
       u = u * k
    end do
    v = 0.0d0
    do while (x < CN)
       v = v + 1.0d0 / x**(n+1)
       x = x + 1.0d0
    end do
    w = x * x
    t = (((((((B16 &
         * (n + 15.0d0) * (n + 14.0d0) / (16.0d0 * 15.0d0 * w) + B14) &
         * (n + 13.0d0) * (n + 12.0d0) / (14.0d0 * 13.0d0 * w) + B12) &
         * (n + 11.0d0) * (n + 10.0d0) / (12.0d0 * 11.0d0 * w) + B10) &
         * (n +  9.0d0) * (n +  8.0d0) / (10.0d0 *  9.0d0 * w) + B8) &
         * (n +  7.0d0) * (n +  6.0d0) / ( 8.0d0 *  7.0d0 * w) + B6) &
         * (n +  5.0d0) * (n +  4.0d0) / ( 6.0d0 *  5.0d0 * w) + B4) &
         * (n +  3.0d0) * (n +  2.0d0) / ( 4.0d0 *  3.0d0 * w) + B2) &
         * (n +  1.0d0) * n / (2.0d0 * 1.0d0 * w) + 0.5d0 * n / x + 1.0d0
    polygamma = u * (t / x**n + n*v)
  end function polygamma

end module gamma


PROGRAM FCT

USE glodata
USE readin,ONLY:readnml
USE procgrid,ONLY:calgrid
USE oalloc,ONLY:alloc
USE odealloc,ONLY:dealloc
USE inij,ONLY:initij

IMPLICIT NONE

CALL readnml('external_input.txt') ! read input data (geometry)
permea_vacuum = 4.0*3.14/10000000.0
cond_copper = 5.96*10000000.0
relapermea_copper = 0.999994

CALL calgrid() ! discretize the geometry

CALL alloc(A_z_old,Nx+1,Ny+1)
CALL alloc(A_z_new,Nx+1,Ny+1)
CALL alloc(J_z,Nx+1,Ny+1)
CALL alloc(B_x,Nx+1,Ny+1)
CALL alloc(B_y,Nx+1,Ny+1)

CALL initij() ! initialize J field, which is uniform under static field

! initial conditions
A_z_old(2:Nx,2:Ny) = 0.0
! end of initialization

! boundary conditions
! Dirichlet
A_z_old(1,1:Ny+1) = 0.0
A_z_old(2:Nx,Ny+1) = 0.0
A_z_old(2:Nx,1) = 0.0
A_z_old(Nx+1,1:Ny+1) = 0.0
! end of assigning boundary conditions

A_z_new = A_z_old

! perform time stepping
DO istep = 1,Nstep

  DO j = 2,Ny-1
     DO i = 2,Nx-1

        IF((i.EQ.N_core_x+N_core_wind_x+1).AND.(j.EQ.N_dis_wind+1))THEN! calculate interface #4, copper air
           A_z_new(i,j) = (relapermea_copper/(3.0*relapermea_copper+1.0))&
                          *(A_z_old(i-1,j) + A_z_old(i,j-1))&
                          +((relapermea_copper+1.0)/(2.0*(3.0*relapermea_copper+1.0)))&
                          *(A_z_old(i+1,j) + A_z_old(i,j+1))&
                          +((relapermea_copper*permea_vacuum)&
                          /(4.0*(3.0*relapermea_copper+1.0)))&
                          *grid_size*grid_size*J_z(i,j)

        ELSEIF((i.EQ.N_core_x+1).AND.(j.EQ.N_win_width+1))THEN! calculate interface #3, air core
           A_z_new(i,j) = (1.0/(3.0+relapermea_core))&
                          *(A_z_old(i,j+1) + A_z_old(i-1,j))&
                          +((1.0+relapermea_core)/(2.0*(3.0+relapermea_core)))&
                          *(A_z_old(i,j-1) + A_z_old(i+1,j))

        ELSEIF((i.EQ.N_core_x+N_core_wind_x+1).AND.(j.EQ.N_dis_wind+N_wind_y+1))THEN! calculate interface #3, copper air
           A_z_new(i,j) = (relapermea_copper/(3.0*relapermea_copper+1.0))&
                          *(A_z_old(i,j+1) + A_z_old(i-1,j))&
                          +((relapermea_copper+1.0)/(2.0*(3.0*relapermea_copper+1.0)))&
                          *(A_z_old(i,j-1) + A_z_old(i+1,j))&
                          +((relapermea_copper*permea_vacuum)&
                          /(4.0*(3.0*relapermea_copper+1.0)))&
                          *grid_size*grid_size*J_z(i,j)

        ELSEIF((i.EQ.N_core_x+N_bump_x+1).AND.(j.EQ.N_bump_y+1))THEN! calculate interface #5, core air
           A_z_new(i,j) = (relapermea_core/(3.0*relapermea_core+1.0))&
                          *(A_z_old(i+1,j) + A_z_old(i,j+1))&
                          +((1.0+relapermea_core)/(2.0*(3.0*relapermea_core+1)))&
                          *(A_z_old(i-1,j) + A_z_old(i,j-1))

        ELSEIF((i.EQ.N_core_x+N_core_wind_x+N_wind_x+1).AND.(j.EQ.N_dis_wind+1))THEN! calculate interface #6, copper air
           A_z_new(i,j) = (relapermea_copper/(3.0*relapermea_copper+1.0))&
                          *(A_z_old(i+1,j) + A_z_old(i,j-1))&
                          +((relapermea_copper+1.0)/(2.0*(3.0*relapermea_copper+1.0)))&
                          *(A_z_old(i-1,j) + A_z_old(i,j+1))&
                          +((relapermea_copper*permea_vacuum)&
                          /(4.0*(3.0*relapermea_copper+1.0)))&
                          *grid_size*grid_size*J_z(i,j)

        ELSEIF((i.EQ.Nx-N_core_x+1).AND.(j.EQ.N_win_width+1))THEN! calculate interface #5, air core
           A_z_new(i,j) = (1.0/(3.0+relapermea_core))&
                          *(A_z_old(i+1,j) + A_z_old(i,j+1))&
                          +((1.0+relapermea_core)/(2.0*(3.0+relapermea_core)))&
                          *(A_z_old(i-1,j) + A_z_old(i,j-1))

        ELSEIF((i.EQ.N_core_x+N_core_wind_x+N_wind_x+1).AND.(j.EQ.N_dis_wind+N_wind_y+1))THEN! calculate interface #5, copper air
           A_z_new(i,j) = (1.0/(3.0+relapermea_core))&
                          *(A_z_old(i+1,j) + A_z_old(i,j+1))&
                          +((1.0+relapermea_core)/(2.0*(3.0+relapermea_core)))&
                          *(A_z_old(i-1,j) + A_z_old(i,j-1))&
                          +((relapermea_copper*permea_vacuum)&
                          /(4.0*(3.0*relapermea_copper+1.0)))&
                          *grid_size*grid_size*J_z(i,j)

        ELSEIF((i.EQ.Nx-N_core_x-N_bump_x+1).AND.(j.EQ.N_bump_y+1))THEN! calculate interface #3, core air
           A_z_new(i,j) = (relapermea_core/(3.0*relapermea_core+1.0))&
                          *(A_z_old(i,j+1) + A_z_old(i-1,j))&
                          +((relapermea_core+1.0)/(2.0*(3.0*relapermea_core+1.0)))&
                          *(A_z_old(i,j-1) + A_z_old(i+1,j))

        ELSEIF((i.EQ.N_core_x+1).AND.(j.GE.N_bump_y+2).AND.(j.LE.N_win_width))THEN! calculate A at interface #1, core and air
           A_z_new(i,j) = 0.25*(((2.0*relapermea_core)/(relapermea_core+1.0))&
                          *A_z_old(i+1,j) + A_z_old(i,j+1)&
                          + (2.0/(relapermea_core+1.0))*A_z_old(i-1,j)&
                          + A_z_old(i,j-1))

        ELSEIF((i.EQ.N_core_x+N_bump_x+1).AND.(j.GE.2).AND.(j.LE.N_bump_y))THEN! calculate A at interface #1, core and air
           A_z_new(i,j) = 0.25*(((2.0*relapermea_core)/(relapermea_core+1.0))&
                          *A_z_old(i+1,j) + A_z_old(i,j+1)&
                          + (2.0/(relapermea_core+1.0))*A_z_old(i-1,j)&
                          + A_z_old(i,j-1))

        ELSEIF((i.EQ.Nx-N_core_x+1).AND.(j.GE.N_bump_y+2).AND.(j.LE.N_win_width))THEN! calculate A at interface #1, air and core
           A_z_new(i,j) = 0.25*(((2.0)/(1.0+relapermea_core))&
                          *A_z_old(i+1,j) + A_z_old(i,j+1)&
                          + (2.0*relapermea_core/(1.0+relapermea_core))*A_z_old(i-1,j)&
                          + A_z_old(i,j-1))

        ELSEIF((i.EQ.Nx-N_core_x-N_bump_x+1).AND.(j.GE.2).AND.(j.LE.N_bump_y))THEN! calculate A at interface #1, air and core
           A_z_new(i,j) = 0.25*(((2.0)/(1.0+relapermea_core))&
                          *A_z_old(i+1,j) + A_z_old(i,j+1)&
                          + (2.0*relapermea_core/(1.0+relapermea_core))*A_z_old(i-1,j)&
                          + A_z_old(i,j-1))

        ELSEIF((i.EQ.N_core_x+N_core_wind_x+1).AND.(j.GE.N_dis_wind+2)&
              .AND.(j.LE.N_dis_wind+N_wind_y))THEN! calculate A at interface #1, air and copper
           A_z_new(i,j) = 0.25*((2.0/(1.0+relapermea_copper))*A_z_old(i+1,j)&
                          + A_z_old(i,j+1) + ((2.0*relapermea_copper)&
                          /(1.0+relapermea_copper))&
                          *A_z_old(i-1,j) + A_z_old(i,j-1)&
                          + (relapermea_copper*permea_vacuum&
                          /(1.0 + relapermea_copper))&
                          *grid_size*grid_size*J_z(i,j))

        ELSEIF((i.EQ.N_core_x+N_core_wind_x+N_wind_x+1).AND.(j.GE.N_dis_wind+2)&
              .AND.(j.LE.N_dis_wind+N_wind_y))THEN! calculate A at interface #1, copper and air
           A_z_new(i,j) = 0.25*((2.0*relapermea_copper/(relapermea_copper+1.0))&
                          *A_z_old(i+1,j)&
                          + A_z_old(i,j+1) + ((2.0)&
                          /(1.0+relapermea_copper))&
                          *A_z_old(i-1,j) + A_z_old(i,j-1)&
                          + (relapermea_copper*permea_vacuum&
                          /(1.0 + relapermea_copper))&
                          *grid_size*grid_size*J_z(i,j))

        ELSEIF((i.GE.N_core_x+2).AND.(i.LE.Nx-N_core_x).AND.(j.EQ.N_win_width+1))THEN! calculate A at interface #2, core and air
           A_z_new(i,j) = 0.25*(A_z_old(i+1,j) + (2.0/(relapermea_core+1))&
                           *A_z_old(i,j+1) + A_z_old(i-1,j)&
                           + ((2.0*relapermea_core)/(relapermea_core+1.0))&
                           *A_z_old(i,j-1))

        ELSEIF((i.GE.N_core_x+N_core_wind_x+2).AND.(i.LE.N_core_x+N_core_wind_x+N_wind_x).AND.&
               (j.EQ.N_dis_wind+N_wind_y+1))THEN! calculate A at interface #2, air and copper
           A_z_new(i,j) = 0.25*(A_z_old(i+1,j)&
                           + ((2.0*relapermea_copper)/(1.0 + relapermea_copper))&
                           *A_z_old(i,j+1) + A_z_old(i-1,j) + (2.0/(1.0 + &
                           relapermea_copper))*A_z_old(i,j-1) + (relapermea_copper&
                           *permea_vacuum/(1.0 + relapermea_copper))&
                           *grid_size*grid_size*J_z(i,j))

        ELSEIF((i.GE.N_core_x+2).AND.(i.LE.N_core_x+N_bump_x).AND.&
               (j.EQ.N_bump_y+1))THEN! calculate A at interface #2, air and core
           A_z_new(i,j) = 0.25*(A_z_old(i+1,j)&
                           + ((2.0*relapermea_core)/(1.0 + relapermea_core))&
                           *A_z_old(i,j+1) + A_z_old(i-1,j) + (2.0/(1.0 + &
                           relapermea_core))*A_z_old(i,j-1))

        ELSEIF((i.GE.Nx-N_core_x-N_bump_x+2).AND.(i.LE.Nx-N_core_x).AND.&
               (j.EQ.N_bump_y+1))THEN! calculate A at interface #2, air and core
           A_z_new(i,j) = 0.25*(A_z_old(i+1,j)&
                           + ((2.0*relapermea_core)/(1.0 + relapermea_core))&
                           *A_z_old(i,j+1) + A_z_old(i-1,j) + (2.0/(1.0 + &
                           relapermea_core))*A_z_old(i,j-1))

        ELSEIF((i.GE.N_core_x+N_core_wind_x+2).AND.(i.LE.N_core_x+N_core_wind_x+N_wind_x).AND.&
               (j.EQ.N_dis_wind+1))THEN! calculate A at interface #2, copper and air
           A_z_new(i,j) = 0.25*(A_z_old(i+1,j) + (2.0/(relapermea_copper+1.0))&
                          *A_z_old(i,j+1) + A_z_old(i-1,j)&
                           + ((2.0*relapermea_copper)/(relapermea_copper+1.0))&
                           *A_z_old(i,j-1) + (relapermea_copper*permea_vacuum/&
                           (relapermea_copper+1.0))&
                           *grid_size*grid_size*J_z(i,j))

        ELSE! calculate A within the same material
            IF((i.LE.N_core_x).OR.(j.GE.N_win_width+2).OR.(i.GE.Nx-N_core_x+2))THEN
              permea_cal = permea_vacuum*relapermea_core
            ELSEIF((i.GE.N_core_x+1).AND.(i.LE.N_core_x+N_bump_x).AND.&
                  (j.GE.2).AND.(j.LE.N_bump_y))THEN!
              permea_cal = permea_vacuum*relapermea_core
            ELSEIF((i.GE.Nx-N_core_x-N_bump_x+2).AND.(i.LE.Nx-N_core_x+1).AND.&
                  (j.GE.2).AND.(j.LE.N_bump_y))THEN!
              permea_cal = permea_vacuum*relapermea_core
            ELSEIF((i.GE.N_core_x+N_core_wind_x+2).AND.(i.LE.N_core_x+N_core_wind_x+N_wind_x)&
                   .AND.(j.GE.N_dis_wind+2).AND.(j.LE.N_dis_wind+N_wind_y))THEN
              permea_cal = permea_vacuum*relapermea_copper
            ELSE
              permea_cal = permea_vacuum
            ENDIF
            A_z_new(i,j) = 0.25*(A_z_old(i+1,j) + A_z_old(i,j+1) &
                                 + A_z_old(i-1,j) + A_z_old(i,j-1) &
                                 + grid_size*grid_size*permea_cal*J_z(i,j))
        ENDIF

     ENDDO
  ENDDO

  A_z_old = A_z_new

  IF(istep.EQ.Nstep)THEN
    OPEN(10,FILE = 'A_old.dat')
    DO j = 1,Ny+1
       DO i = 1,Nx+1
          WRITE(10,'(3E12.4)') REAL(i-1)*grid_size,REAL(j-1)*grid_size,A_z_old(i,j)
       ENDDO
       WRITE(10,'(A)')
    ENDDO
    CLOSE(10)
  ENDIF

ENDDO
! end of do loop for time stepping

PRINT*,'Nx = ',Nx
PRINT*,'Ny = ',Ny
PRINT*,'istep = ',istep
PRINT*,'N_core_x = ',N_core_x
PRINT*,'N_bump_x = ',N_bump_x
PRINT*,'N_bump_y = ',N_bump_y
PRINT*,'N_dis_wind = ',N_dis_wind
PRINT*,'N_core_wind_x = ',N_core_wind_x
PRINT*,'N_wind_x = ',N_wind_x
PRINT*,'N_wind_y = ',N_wind_y

!CALL dealloc(A_z_old)
!CALL dealloc(A_z_new)
!CALL dealloc(J_z)

OPEN(10,FILE = 'A_new.dat')
DO j = 1,Ny+1
   DO i = 1,Nx+1
      WRITE(10,'(3E12.4)') REAL(i-1)*grid_size,REAL(j-1)*grid_size,A_z_old(i,j)
   ENDDO
   WRITE(10,'(A)')
ENDDO
CLOSE(10)

! calculate B_x and B_y
DO j = 1,Ny+1
     DO i = 1,Nx+1
        IF((i.EQ.1).AND.(j.GE.1).AND.(j.LE.Ny))THEN
          B_x(i,j) = (A_z_old(i,j+1)-A_z_old(i,j))/(grid_size)
          B_y(i,j) = -(A_z_old(i+1,j)-A_z_old(i,j))/(grid_size)
        ELSEIF((j.EQ.Ny+1).AND.(i.GE.1).AND.(i.LE.Nx))THEN
          B_x(i,j) = (A_z_old(i,j)-A_z_old(i,j-1))/(grid_size)
          B_y(i,j) = -(A_z_old(i+1,j)-A_z_old(i,j))/(grid_size)
        ELSEIF((i.EQ.Nx+1).AND.(j.GE.2).AND.(j.LE.Ny+1))THEN
          B_x(i,j) = (A_z_old(i,j)-A_z_old(i,j-1))/(grid_size)
          B_y(i,j) = -(A_z_old(i,j)-A_z_old(i-1,j))/(grid_size)
        ELSEIF((j.EQ.1).AND.(i.GE.2).AND.(i.LE.Nx+1))THEN
          B_x(i,j) = (A_z_old(i,j+1)-A_z_old(i,j))/(grid_size)
          B_y(i,j) = -(A_z_old(i,j)-A_z_old(i-1,j))/(grid_size)
        ELSE
          B_x(i,j) = (A_z_old(i,j+1)-A_z_old(i,j-1))/(2.0*grid_size)
          B_y(i,j) = -(A_z_old(i+1,j)-A_z_old(i-1,j))/(2.0*grid_size)
        ENDIF
     ENDDO
ENDDO
! end of calculating B_x and B_y

OPEN(10,FILE = 'B_x.dat')
DO j = 1,Ny+1
   DO i = 1,Nx+1
      WRITE(10,'(3E12.4)') REAL(i-1)*grid_size,REAL(j-1)*grid_size,B_x(i,j)
   ENDDO
   WRITE(10,'(A)')
ENDDO
CLOSE(10)

OPEN(10,FILE = 'B_y.dat')
DO j = 1,Ny+1
   DO i = 1,Nx+1
      WRITE(10,'(3E12.4)') REAL(i-1)*grid_size,REAL(j-1)*grid_size,B_y(i,j)
   ENDDO
   WRITE(10,'(A)')
ENDDO
CLOSE(10)

END PROGRAM FCT


      FUNCTION BESSY0(X)
      REAL*8 Y,P1,P2,P3,P4,P5,Q1,Q2,Q3,Q4,Q5,R1,R2,R3,R4,R5,R6,
     *    S1,S2,S3,S4,S5,S6
      DATA P1,P2,P3,P4,P5/1.D0,-.1098628627D-2,.2734510407D-4,
     *    -.2073370639D-5,.2093887211D-6/, Q1,Q2,Q3,Q4,Q5/-.1562499995D-
     *1,
     *    .1430488765D-3,-.6911147651D-5,.7621095161D-6,-.934945152D-7/
      DATA R1,R2,R3,R4,R5,R6/-2957821389.D0,7062834065.D0,-512359803.6D0
     *,
     *    10879881.29D0,-86327.92757D0,228.4622733D0/,
     *    S1,S2,S3,S4,S5,S6/40076544269.D0,745249964.8D0,
     *    7189466.438D0,47447.26470D0,226.1030244D0,1.D0/
      IF(X.LT.8.)THEN
        Y=X**2
        BESSY0=(R1+Y*(R2+Y*(R3+Y*(R4+Y*(R5+Y*R6)))))/(S1+Y*(S2+Y
     *      *(S3+Y*(S4+Y*(S5+Y*S6)))))+.636619772*BESSJ0(X)*LOG(X)
      ELSE
        Z=8./X
        Y=Z**2
        XX=X-.785398164
        BESSY0=SQRT(.636619772/X)*(SIN(XX)*(P1+Y*(P2+Y*(P3+Y*(P4+Y*
     *      P5))))+Z*COS(XX)*(Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*Q5)))))
      ENDIF
      RETURN
      END


program hmipt_2dsquare
  !########################################################
  !     Program  : HMIPT
  !     TYPE     : Main program
  !     PURPOSE  : Solve the Hubbard model using DMFT-IPT
  !     AUTHORS  : Adriano Amaricci
  !########################################################
  !LOCAL:
  USE DMFT_IPT
  USE VECTORS
  USE SQUARE_LATTICE
  USE IOTOOLS
  USE INTEGRATE
  USE TIMER

  implicit none

  logical                :: converged
  real(8)                :: n,wband,kint,eint,x
  integer                :: i,Lk,iloop
  complex(8)             :: zeta
  complex(8),allocatable :: sigma(:),fg(:),fg0(:)
  real(8),allocatable    :: wr(:),wt(:),epsik(:),nk(:),dos(:)

  call read_input("inputIPT.in")
  !allocate functions:
  allocate(fg(L))
  allocate(sigma(L))
  allocate(fg0(L))
  allocate(wr(L))

  !build freq. array
  wr = linspace(-wmax,wmax,L,mesh=fmesh)

  !build square lattice structure:
  dos=0.d0
  wband=4.d0*ts
  allocate(dos(L))
  do i=1,L
     x=1.d0/wmax*(wr(i)/wband)**2-1.d0
     call comelp(x,kint,eint)
     dos(i)=2.d0/wband/pi**2*kint*heaviside(wband-abs(wr(i)))
  enddo
  dos=dos/sum(dos)/fmesh
  call splot("rho0_realw.ipt",wr,dos)
  dos=dos*fmesh

  Lk   = square_lattice_dimension(Nx)
  allocate(wt(Lk),epsik(Lk),nk(Lk))
  wt   = square_lattice_structure(Lk,Nx)
  epsik= square_lattice_dispersion_array(Lk,ts)

  call get_initial_sigma

  ! call get_optical_conductivity
  ! stop

  !dmft loop:
  iloop=0 ; converged=.false.
  do while (.not.converged)
     iloop=iloop+1
     write(*,"(A,i5)",advance="no")"DMFT-loop",iloop
     fg=zero
     do i=1,L
        zeta = cmplx(wr(i),eps) - sigma(i)
        !fg(i) = trapz(fmesh,wt/(zeta-epsik))
        fg(i) = sum_overk_zeta(zeta,epsik,wt)
     enddo
     n   = trapz(fmesh,dimag(fg)*fermi(wr,beta))/trapz(fmesh,dimag(fg))
     fg0 = one/(one/fg + sigma)
     sigma= solve_ipt_sopt(fg0,wr)
     converged=check_convergence(sigma,eps_error,nsuccess,nloop)
     call splot("nVSiloop.ipt",iloop,n,append=TT)
  enddo
  call close_file("nVSiloop.ipt")
  call splot("DOS.ipt",wr,-aimag(fg)/pi,append=printf)
  call splot("G_realw.ipt",wr,fg,append=printf)
  call splot("G0_realw.ipt",wr,fg0,append=printf)
  call splot("Sigma_realw.ipt",wr,sigma,append=printf)
  ! nk = square_lattice_momentum_distribution(Lk)
  ! call splot("nkVSepsk.ipt",epsik,nk,append=printf)

  call get_optical_conductivity()

contains

  subroutine get_initial_sigma()
    logical :: check
    inquire(file="Sigma_realw.last",exist=check)
    if(check)then
       write(*,*)"Reading Sigma in input:"
       call sread("Sigma_realw.last",wr,sigma)
    else
       print*,"Using Hartree-Fock self-energy"
       print*,"===================================="
       n=0.5d0
       sigma=zero
    endif
  end subroutine get_initial_sigma

  function square_lattice_momentum_distribution(Lk) result(nk)
    integer            :: Lk
    integer,parameter  :: M=1024
    integer            :: ik,i
    type(matsubara_gf) :: gm,sm
    real(8)            :: nk(Lk),wm(M),w
    call allocate_gf(gm,M)
    call allocate_gf(sm,M)
    wm   = pi/beta*real(2*arange(1,M)-1,8)
    call get_matsubara_gf_from_DOS(wr,sigma,sm%iw,beta)
    do ik=1,Lk
       gm%iw=one/(xi*wm - epsik(ik) - sm%iw)
       call fftgf_iw2tau(gm%iw,gm%tau,beta)
       nk(ik)=-gm%tau(M)
    enddo
  end function square_lattice_momentum_distribution

  subroutine get_optical_conductivity()
    integer                               :: ix,iy,iz,ik,i,iw,it,iv
    integer                               :: Nw
    real(8)                               :: Fiw,Fiviw
    type(vect2D)                          :: vk
    real(8),dimension(:),allocatable      :: omega(:)
    real(8),dimension(:),allocatable      :: reoc(:),imoc(:),ock(:)
    complex(8),dimension(:),allocatable   :: oc(:)
    real(8),dimension(:,:),allocatable    :: Ak
    !
    real(8)                               :: t_(0:L/2)
    real(8)                               :: oct(0:L/2)

    Nw=L/2
    allocate(omega(-Nw+1:Nw))
    forall(i=1:L)omega(-Nw+i)=wr(i)

    allocate(Ak(Lk,-Nw+1:Nw))
    forall(ik=1:Lk,i=1:L)Ak(ik,-Nw+i)=-dimag(one/(cmplx(wr(i),eps)-epsik(ik)-sigma(i)))/pi

    allocate(reoc(-Nw+1:Nw),imoc(-Nw+1:Nw),ock(-Nw+1:Nw),oc(-Nw+1:Nw))
    oc   = zero
    reoc = zero
    imoc = zero
    call start_timer
    do ik=1,Lk
       ock = zero
       vk  = square_lattice_velocity(kgrid(ik2ix(ik),ik2iy(ik)))
       do iv=1,Nw
          do iw=-Nw+1,Nw-iv
             Fiw     = fermi(omega(iw),beta)
             Fiviw   = fermi(omega(iv+iw),beta)
             ock(iv) = ock(iv) + ((Fiw-Fiviw)/omega(iv))*Ak(ik,iw)*Ak(ik,iv+iw)*vk%x*vk%y
          enddo                 !end w-loop
       enddo                    !end v-loop
       reoc(:) = reoc(:)+ock(:)*wt(ik)*ts*fmesh
       call eta(ik,Lk)
    enddo
    call stop_timer
    ! forall(i=1:Nw)reoc(-i+1)=-reoc(i)
    ! imoc(1:Nw) = kronig(reoc(1:Nw),omega(1:Nw),Nw)
    ! oc   = cmplx(reoc,imoc,8)
    call splot("OC_realw.ipt",omega,reoc)!,imoc)

    t_=linspace(0.d0,pi/wmax*Nw,Nw+1)
    oct=zero
    do it=0,Nw
       do iw=1,Nw
          oct(it)=oct(it) + reoc(iw)*exp(xi*omega(iw)*t_(it))*fmesh
       enddo
    enddo
    call splot("OC_t.ipt",t_,oct)

  end subroutine get_optical_conductivity

  subroutine comelp ( hk, ck, ce )
    !*****************************************************************************80
    !
    !! COMELP computes complete elliptic integrals K(k) and E(k).
    !
    !  Licensing:
    !
    !    This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However,
    !    they give permission to incorporate this routine into a user program
    !    provided that the copyright is acknowledged.
    !
    !  Modified:
    !
    !    07 July 2012
    !
    !  Author:
    !
    !    Shanjie Zhang, Jianming Jin
    !
    !  Reference:
    !
    !    Shanjie Zhang, Jianming Jin,
    !    Computation of Special Functions,
    !    Wiley, 1996,
    !    ISBN: 0-471-11963-6,
    !    LC: QA351.C45.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) HK, the modulus.  0 <= HK <= 1.
    !
    !    Output, real ( kind = 8 ) CK, CE, the values of K(HK) and E(HK).
    !
    implicit none
    real ( kind = 8 ) ae
    real ( kind = 8 ) ak
    real ( kind = 8 ) be
    real ( kind = 8 ) bk
    real ( kind = 8 ) ce
    real ( kind = 8 ) ck
    real ( kind = 8 ) hk
    real ( kind = 8 ) pk
    pk = 1.0D+00 - hk * hk
    if ( hk == 1.0D+00 ) then
       ck = 1.0D+300
       ce = 1.0D+00
    else
       ak = ((( &
            0.01451196212D+00   * pk &
            + 0.03742563713D+00 ) * pk &
            + 0.03590092383D+00 ) * pk &
            + 0.09666344259D+00 ) * pk &
            + 1.38629436112D+00
       bk = ((( &
            0.00441787012D+00   * pk &
            + 0.03328355346D+00 ) * pk &
            + 0.06880248576D+00 ) * pk &
            + 0.12498593597D+00 ) * pk &
            + 0.5D+00
       ck = ak - bk * log ( pk )
       ae = ((( &
            0.01736506451D+00   * pk &
            + 0.04757383546D+00 ) * pk &
            + 0.0626060122D+00  ) * pk &
            + 0.44325141463D+00 ) * pk &
            + 1.0D+00
       be = ((( &
            0.00526449639D+00   * pk &
            + 0.04069697526D+00 ) * pk &
            + 0.09200180037D+00 ) * pk &
            + 0.2499836831D+00  ) * pk
       ce = ae - be * log ( pk )
    end if
    return
  end subroutine comelp

end program hmipt_2dsquare


!     calculation of fp
subroutine r_scalfp(fp,ocpp,i)
  use r_common, only: bpre,cpre,hp
  implicit none

  real(8) :: fp,ocpp
  integer :: i

  fp=-ocpp*(bpre-cpre)*hp(i)
  return
end subroutine r_scalfp

!     calculation of fu
subroutine r_scalfu(fu,isd,ni)
  use r_common
  use solid_variables, only : nsd_solid
  implicit none

  real(8) :: fu
  integer :: isd,ni
  integer :: ksd

  fu=0.0d0
  do ksd = 1,nsd_solid
    fu = fu + bd(ksd,ni)*PK1str_tens(ksd,isd)
  enddo
  return
end subroutine r_scalfu

!     calculation of fu in current configuration
subroutine r_scalfu_curr(fu,i,ni,cstr_element)
  use r_common
  use solid_variables, only : nsd_solid
  implicit none

  real(8) :: fu
  integer :: i,ni
  real(8),intent(in) :: cstr_element(2*nsd_solid)  !...Cauchy stress

  fu=0.0d0
  if (i == 1) then
     fu=fu+cstr_element(1)*bd_curr(1,ni)
     fu=fu+cstr_element(6)*bd_curr(2,ni)
     fu=fu+cstr_element(5)*bd_curr(3,ni)
  elseif (i == 2) then
     fu=fu+cstr_element(6)*bd_curr(1,ni)
     fu=fu+cstr_element(2)*bd_curr(2,ni)
     fu=fu+cstr_element(4)*bd_curr(3,ni)
  elseif (i == 3) then
     fu=fu+cstr_element(5)*bd_curr(1,ni)
     fu=fu+cstr_element(4)*bd_curr(2,ni)
     fu=fu+cstr_element(3)*bd_curr(3,ni)
  endif

  return
end subroutine r_scalfu_curr

!     calculation of kpp
subroutine r_scalkpp(fkpp,ocpp,k,m)
  use r_common
  use solid_variables, only : nsd_solid
  implicit none

  real(8) :: fkpp,ocpp
  integer :: k,m

  fkpp = ocpp*hp(k)*hp(m)
  return
end subroutine r_scalkpp

!     calculation of kup
subroutine r_scalkup(fkup,ocup,i,k,ni)
  use r_common
  use solid_variables, only : nsd_solid
  implicit none

  real(8) :: fkup,ocup(2*nsd_solid)
  integer :: i,k,ni
  integer :: m

  fkup=0.0d0
  do m=1,2*nsd_solid
     fkup=fkup+ocup(m)*dge(m,i,ni)*hp(k)
  enddo
  return
end subroutine r_scalkup


      FUNCTION RANGE(GXP,GGX,GNEED)
!    RANGE CALCULATES THE RANGE (SHOT TO RECEIVER DISTANCE) FROM A SET OF
!  GROUP-DISTANCE PAIRS AND/OR THE GROUP-GROUP DISTANCE.  THIS ROUTINE ASSUMES
!  THAT THE SEISMIC LINE IS STRAIGHT!!!  RANGES ARE INTERPOLATED BETWEEN
!  GROUPS SPECIFIED AND ARE EXTRAPOLATED USING GGX FOR GROUPS LESS THAN THE
!  FIRST GIVEN OR GREATER THAN THE LAST GIVEN.  EXTRAPOLATION USES GGX*
!  (GROUP GIVEN - GROUP WANTED)+(RANGE OF THE GROUP GIVEN).
!
!  ARGUMENTS:
!    GXP   - AN ARRAY OF GROUP-DISTANCE PAIRS.  AT LEAST ONE PAIR MUST BE GIVEN.
!            EACH PAIR MUST HAVE THE GROUP NUMBER FIRST AND THE RANGE (DISTANCE)
!            SECOND.  THE GXP SET MUST BE TERMINATED BY A NEGATIVE GROUP NUMBER.
!            THUS, ODD ELEMENTS IN THE GXP ARRAY ARE GROUP NUMBERS AND THE EVEN
!            ELEMENTS ARE THE CORRESPONDING RANGES.  GROUP NUMBERS MUST INCREASE
!            IN THE GXP ARRAY.
!    GGX   - THE CONSTANT GROUP TO GROUP DISTANCE.
!    GNEED - THE GROUP NUMBER OF THE RANGE WANTED.
!
!  EXAMPLE 1:
!  GIVEN GXP(1)=24., GXP(2)=450., GXP(3)=-1.,  GGX=300. AND GNEED=20.
!  THEN RANGE=(24-20)*300.+450.=1650.
!
!  COPYRIGHTED BY:
!  PAUL HENKART, SCRIPPS INSTITUTION OF OCEANOGRAPHY, DECEMBER 1979
!
      DIMENSION GXP(1)
!
      INDEX=1                                                            ! THE FIRST GXP PAIR
   10 TEMP=GXP(INDEX)-GNEED
!      IF(TEMP)300,200,100
      IF( temp .LT. 0 ) GOTO 300
      IF( temp .EQ. 0 ) GOTO 200
  100 IF(INDEX.NE.1) GO TO 150
!****  THE GROUP WANTED IS LESS THAN THE FIRST GIVEN OR IS GREATER THAN THE LAST
!****  GIVEN, THEREFORE, EXTRAPOLATE USING GGX.
  110 CONTINUE
      RANGE=TEMP*GGX+GXP(INDEX+1)
      RETURN
  150 CONTINUE                                                           !  INTERPOLATE TO GET THE RANGE
      RANGE=(TEMP/(GXP(INDEX)-GXP(INDEX-2)))*(GXP(INDEX-1)-
     *     GXP(INDEX+1))+GXP(INDEX+1)
      RETURN
  200 CONTINUE                                                           !  GNEED IS GXP(INDEX) EXACTLY!!
      RANGE=GXP(INDEX+1)
      RETURN
  300 CONTINUE                                                          !  GROUP WANTED (GNEED) IS BIGGER THAN GXP(INDEX)
      IF(GXP(INDEX+2).LT.0.) GO TO 110
      INDEX=INDEX+2
      GO TO 10
      END


SUBROUTINE setaux(mbc,mx,xlower,dx,maux,aux)

  IMPLICIT NONE
  INTEGER, INTENT(in) :: mbc,mx,maux
  REAL(KIND=8), INTENT(in) :: xlower,dx
  REAL(KIND=8), INTENT(out) ::  aux(maux,1-mbc:mx+mbc)

  INTEGER i, ibc
  DOUBLE PRECISION xc, bathy, b, slope, d2xzb

  if (maux .lt. 3) then
      write(6,*) 'setaux.f : maux must be at least 3'
      stop
  endif

  DO i = 1-mbc,mx+mbc
     xc = xlower + (i-0.5)*dx
     call bathy_complete(xc,b,slope,d2xzb)
     aux(1,i) = b
     !! aux(2,i) = slope
     !! aux(3,i) = d2xzb
  end do

  do i = 2-mbc,mx+1
     aux(2,i) = (aux(1,i+1) - aux(1,i-1))/(2.d0*dx)
     aux(3,i) = (aux(1,i+1) - 2.d0*aux(1,i) + aux(1,i-1))/(dx*dx)
  END DO

END SUBROUTINE SETAUX


!---------------------------------------------------------------*

!
!     This subroutine analyses the structure of the expanding
!     filament.
!
!     Andrew Spakowitz
!     Written 9-1-04

!     Check the calculator of eigenvalue/eigenvector

      subroutine find_struc(R,NT,N,RCOM,DELR)

      real(dp) R(3,NT)  ! Bead positions
      real(dp) U(3,N-1) ! Tangent
      real(dp) B(N-1)   ! Bond length
      integer N,NT              ! Number of beads
      integer I

!     Structure analysis

      real(dp) RCOM(3)  ! Center of mass
      real(dp) DELR(3)  ! Mag of gyration tensor
      real(dp) TEMP(3)
      real(dp) DELRR(3) ! Real part
      real(dp) DELRI(3) ! Imaginary part
      real(dp) EVEC(3,3)
      real(dp) T(3,3)   ! Radius of gyration tensor
      real(dp) fv1(3)
      integer iv1(3)
      integer ERR

!     Find the center of mass

      RCOM(1) = 0.
      RCOM(2) = 0.
      RCOM(3) = 0.
      do 10 I = 1,N
         RCOM(1) = RCOM(1) + R(1,I)
         RCOM(2) = RCOM(2) + R(2,I)
         RCOM(3) = RCOM(3) + R(3,I)
 10   continue
      RCOM(1) = RCOM(1)/N
      RCOM(2) = RCOM(2)/N
      RCOM(3) = RCOM(3)/N

!     Find the principle radii of gyration

      T(1,1) = 0.
      T(1,2) = 0.
      T(1,3) = 0.
      T(2,1) = 0.
      T(2,2) = 0.
      T(2,3) = 0.
      T(3,1) = 0.
      T(3,2) = 0.
      T(3,3) = 0.
      do 20 I = 1,N
         T(1,1) = T(1,1) + (R(1,I)-RCOM(1))*(R(1,I)-RCOM(1))
         T(1,2) = T(1,2) + (R(1,I)-RCOM(1))*(R(2,I)-RCOM(2))
         T(1,3) = T(1,3) + (R(1,I)-RCOM(1))*(R(3,I)-RCOM(3))
         T(2,1) = T(2,1) + (R(2,I)-RCOM(2))*(R(1,I)-RCOM(1))
         T(2,2) = T(2,2) + (R(2,I)-RCOM(2))*(R(2,I)-RCOM(2))
         T(2,3) = T(2,3) + (R(2,I)-RCOM(2))*(R(3,I)-RCOM(3))
         T(3,1) = T(3,1) + (R(3,I)-RCOM(3))*(R(1,I)-RCOM(1))
         T(3,2) = T(3,2) + (R(3,I)-RCOM(3))*(R(2,I)-RCOM(2))
         T(3,3) = T(3,3) + (R(3,I)-RCOM(3))*(R(3,I)-RCOM(3))
 20   continue
      T(1,1) = T(1,1)/N
      T(1,2) = T(1,2)/N
      T(1,3) = T(1,3)/N
      T(2,1) = T(2,1)/N
      T(2,2) = T(2,2)/N
      T(2,3) = T(2,3)/N
      T(3,1) = T(3,1)/N
      T(3,2) = T(3,2)/N
      T(3,3) = T(3,3)/N

!      call rg(3,3,T,DELRR,DELRI,1,EVEC,iv1,fv1,ERR)

      DELR(1) = sqrt(DELRR(1))
      DELR(2) = sqrt(DELRR(2))
      DELR(3) = sqrt(DELRR(3))

      if (DELR(1) > DELR(2).AND.DELR(2) > DELR(3)) then
         TEMP(1) = DELR(1)
         TEMP(2) = DELR(2)
         TEMP(3) = DELR(3)
      elseif (DELR(2) > DELR(1).AND.DELR(1) > DELR(3)) then
         TEMP(1) = DELR(2)
         TEMP(2) = DELR(1)
         TEMP(3) = DELR(3)
      elseif (DELR(1) > DELR(3).AND.DELR(3) > DELR(2)) then
         TEMP(1) = DELR(1)
         TEMP(2) = DELR(3)
         TEMP(3) = DELR(2)
      elseif (DELR(2) > DELR(3).AND.DELR(3) > DELR(1)) then
         TEMP(1) = DELR(2)
         TEMP(2) = DELR(3)
         TEMP(3) = DELR(1)
      elseif (DELR(3) > DELR(1).AND.DELR(1) > DELR(2)) then
         TEMP(1) = DELR(3)
         TEMP(2) = DELR(1)
         TEMP(3) = DELR(2)
      elseif (DELR(3) > DELR(2).AND.DELR(2) > DELR(1)) then
         TEMP(1) = DELR(3)
         TEMP(2) = DELR(2)
         TEMP(3) = DELR(1)
      endif

      DELR(1) = TEMP(1)
      DELR(2) = TEMP(2)
      DELR(3) = TEMP(3)

      RETURN
      END

!---------------------------------------------------------------*


*DECK DPOLCF
      SUBROUTINE DPOLCF (XX, N, X, C, D, WORK)
C***BEGIN PROLOGUE  DPOLCF
C***PURPOSE  Compute the coefficients of the polynomial fit (including
C            Hermite polynomial fits) produced by a previous call to
C            POLINT.
C***LIBRARY   SLATEC
C***CATEGORY  E1B
C***TYPE      DOUBLE PRECISION (POLCOF-S, DPOLCF-D)
C***KEYWORDS  COEFFICIENTS, POLYNOMIAL
C***AUTHOR  Huddleston, R. E., (SNLL)
C***DESCRIPTION
C
C     Abstract
C        Subroutine DPOLCF computes the coefficients of the polynomial
C     fit (including Hermite polynomial fits ) produced by a previous
C     call to DPLINT.  The coefficients of the polynomial, expanded
C     about XX, are stored in the array D. The expansion is of the form
C     P(Z) = D(1) + D(2)*(Z-XX) +D(3)*((Z-XX)**2) + ... +
C                                                  D(N)*((Z-XX)**(N-1)).
C     Between the call to DPLINT and the call to DPOLCF the variable N
C     and the arrays X and C must not be altered.
C
C     *****  INPUT PARAMETERS
C      *** All TYPE REAL variables are DOUBLE PRECISION ***
C
C     XX   - The point about which the Taylor expansion is to be made.
C
C     N    - ****
C            *     N, X, and C must remain unchanged between the
C     X    - *     call to DPLINT and the call to DPOLCF.
C     C    - ****
C
C     *****  OUTPUT PARAMETER
C      *** All TYPE REAL variables are DOUBLE PRECISION ***
C
C     D    - The array of coefficients for the Taylor expansion as
C            explained in the abstract
C
C     *****  STORAGE PARAMETER
C
C     WORK - This is an array to provide internal working storage. It
C            must be dimensioned by at least 2*N in the calling program.
C
C
C     **** Note - There are two methods for evaluating the fit produced
C     by DPLINT. You may call DPOLVL to perform the task, or you may
C     call DPOLCF to obtain the coefficients of the Taylor expansion and
C     then write your own evaluation scheme. Due to the inherent errors
C     in the computations of the Taylor expansion from the Newton
C     coefficients produced by DPLINT, much more accuracy may be
C     expected by calling DPOLVL as opposed to writing your own scheme.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   890213  DATE WRITTEN
C   891006  Cosmetic changes to prologue.  (WRB)
C   891024  Corrected KEYWORD section.  (WRB)
C   891024  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  DPOLCF
C
      INTEGER I,IM1,K,KM1,KM1PI,KM2N,KM2NPI,N,NM1,NMKP1,NPKM1
      DOUBLE PRECISION C(*),D(*),PONE,PTWO,X(*),XX,WORK(*)
C***FIRST EXECUTABLE STATEMENT  DPOLCF
      DO 10010 K=1,N
      D(K)=C(K)
10010 CONTINUE
      IF (N.EQ.1) RETURN
      WORK(1)=1.0D0
      PONE=C(1)
      NM1=N-1
      DO 10020 K=2,N
      KM1=K-1
      NPKM1=N+K-1
      WORK(NPKM1)=XX-X(KM1)
      WORK(K)=WORK(NPKM1)*WORK(KM1)
      PTWO=PONE+WORK(K)*C(K)
      PONE=PTWO
10020 CONTINUE
      D(1)=PTWO
      IF (N.EQ.2) RETURN
      DO 10030 K=2,NM1
      KM1=K-1
      KM2N=K-2+N
      NMKP1=N-K+1
      DO 10030 I=2,NMKP1
      KM2NPI=KM2N+I
      IM1=I-1
      KM1PI=KM1+I
      WORK(I)=WORK(KM2NPI)*WORK(IM1)+WORK(I)
      D(K)=D(K)+WORK(I)*D(KM1PI)
10030 CONTINUE
      RETURN
      END


*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
* Program REPONS
* Creation d'un fichier image de type BDF contenant une reponse impulsionnelle
*
* La valeur de SIGMA doit etre donnee en qualifieur
* du programme a l'interieur d'une procedure de commande
*
* Pas d'ecriture dans le fichier recapitulation
*
*****---------------------------------------------------------------------------
*	S. ROQUES - J. VIGNEAU				30 NOVEMBRE 1989
* JLP (Modif Midas)
* Version 10-01-90
*-------------------------------------------------------------------------------
	program d_repons
*
	implicit none
*
	integer*4 N,nx,ny,pntr
	real*4	sigma,rayon
	character name*40,comments*80
	integer*4 madrid(1)
	common /vmr/madrid
*
* Initialisation
*
	call jlp_begin
	call jlp_inquifmt
        write(6,102)
102	format('******* Program d_repons  Version 02-05-91')
*
* saisie de nx
*
	write(6,11)
11	format(' Size of the output image (square): nx only')
	read(5,*) nx
	ny=nx
*
* saisie de sigma
*
	write(6,12)
12	format(' Sigma of the PSF :')
	read(5,*) sigma
*
* construction de la reponse
*
	N=nx*ny*4
	call jlp_getvm(pntr,N)
	call PSF(madrid(pntr),nx,ny,sigma,rayon)
*
* Ouverture du fichier Image
*
	write (comments,1002) sigma
1002	format(' Reponse Impulsionnelle, sigma = ',f4.1)
	write(6,13)
13	format(' Output image : (should be *.PSF)')
	name=' '
	call jlp_writeimag(madrid(pntr),nx,ny,nx,
     1	name,comments)
*
* ecriture du descripteur "rayon" de la PSF
*
	write(6,1001) rayon
1001	format (' Rayon de la Reponse impulsionnelle : ', F5.2)
*
	call jlp_end
	stop
	end
*
*
 	SUBROUTINE PSF (OBJ,NX,NY,SIGMA,RAYON)
*
* Simulation de la reponse impulsionnelle gaussienne
* constante sur des cercles concentriques
*
* Output:
* RAYON
*
	implicit none
*
	integer*4 nx,ny
	real*4		obj(nx,ny), sigma, rayon,sigma2
*
 	integer*4	ix, iy, k, l, ik, il
	real*4	      	arg, min, pi
	pi=3.14159265358979323846
*
	min = .0001
	rayon = 0.
	ix = nx/2 + 1
	iy = ny/2 + 1
	sigma2 = 2 * sigma * sigma
*
	do l = 1, ny
	 il = (l - iy)*(l - iy)
	 do k = 1, nx
	  ik = (k - ix)*(k - ix)
	  arg = - float(ik +il)/sigma2
	  obj (k,l) = exp(arg)
	  if (obj(k,l) .lt. min) then
	   obj(k,l) = 0.
	  else
	   rayon = rayon + 1.
	  end if
	 end do
	end do
*
	rayon = SQRT (rayon/pi)
	return
	end


      subroutine r8mkspl3zb(fun,x,nx,th,nth,ph,nph,fspl,nf2,nf3,
     >   ibcxmin,bcxmin,ibcxmax,bcxmax,nb1,
     >   wk,inwk,ilinx,ilinth,ilinph,ier)
C
C  create a tricubic biperiodic spline with knots at grid points and
C  function values from the callable function `fun' passed.
C
C  use tpsplinb to setup the spline coefficients
C
C  periodic boundary condition for theta & phi grids.
C  boundary condition data may be specified at x(1) and x(nx) for each
C  theta & phi:
C     ibcxmin=0 ==> "not a knot" boundary condition, cf cubspl.for
C     ibcxmin=1 ==> match slope, bcxmin(ith,iph) gives df/dx at
C         x(1),th(ith),ph(iph)
C     ibcxmin=2 ==> match 2nd derivative, given at x(1),th(ith),ph(iph)
C          by bcxmin(ith,iph)
C
C     ibcxmax,bcxmax have analogous interpretation -- at x(nx).
C
!============
! idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER nth,nph,nf2,nf3,nb1,inwk,nx,iph,ith,ix
!============
! idecl:  explicitize implicit REAL declarations:
      REAL*8 fun,zdummy
!============
      external fun                      ! passed real function(x,th)
      REAL*8 x(nx)                        ! x coordinate array
      REAL*8 th(nth)                      ! th coordinate array
      REAL*8 ph(nph)                      ! ph coordinate array
C
      REAL*8 fspl(8,nf2,nf3,nph)          ! function data / spline coeff array
      REAL*8 wk(inwk)                     ! workspace for bpsplinb
C
      integer ibcxmin                   ! boundary condition indicator
      REAL*8 bcxmin(nb1,nph)              ! boundary condition data
      integer ibcxmax                   ! boundary condition indicator
      REAL*8 bcxmax(nb1,nph)              ! boundary condition data
C
      integer ilinx                     ! output =1 if x(...) evenly spaced
      integer ilinth                    ! output =1 if th(...) evenly spaced
      integer ilinph                    ! output =1 if ph(...) evenly spaced
C
      integer ier                       ! completion code from bpspline
C
C----------------------------
C
      ier=0
      if(nf2.lt.nx) then
         write(6,'('' ?mkspl3pb -- array dim error, nf2 .lt. nx'')')
         ier=1
      endif
      if(nf3.lt.nth) then
         write(6,'('' ?mkspl3pb -- array dim error, nf3 .lt. nth'')')
         ier=2
      endif
      if(nb1.lt.nth) then
         write(6,'('' ?mkspl3pb -- array dim error, nb1 .lt. nth'')')
         ier=3
      endif

      if(ier.ne.0) return
C
      do iph=1,nph
         do ith=1,nth
            do ix=1,nx
               fspl(1,ix,ith,iph)=fun(x(ix),th(ith),ph(iph))
            enddo
         enddo
      enddo
C
      call r8mktricubw(x,nx,th,nth,ph,nph,fspl,nf2,nf3,
     >   ibcxmin,bcxmin,ibcxmax,bcxmax,nb1,
     >   -1,zdummy,-1,zdummy,max(nx,nth,nph),
     >   -1,zdummy,-1,zdummy,max(nx,nth,nph),
     >   wk,inwk,ilinx,ilinth,ilinph,ier)
C
      return
      end


! Implementation module for automatic differentiation

module autoDiff
  type ad
     real*8 :: x
     real*8 :: dx
  end type ad

  interface assignment(=)
     module procedure assign_ad_ad
     module procedure assign_ad_r
  end interface

  interface operator(**)
     module procedure exp_ad_int
  end interface

  interface operator(+)
     module procedure add_ad_ad
     module procedure add_r_ad
     module procedure add_i_ad
     module procedure add_ad_r
  end interface

  interface operator(-)
     module procedure sub_ad_ad
     module procedure sub_r_ad
     module procedure sub_ad_r
  end interface

  interface operator(*)
     module procedure mul_ad_ad
     module procedure mul_r_ad
     module procedure mul_i_ad
     module procedure mul_ad_r
  end interface

  interface operator(/)
     module procedure div_r_ad
     module procedure div_ad_ad
  end interface

contains
  subroutine assign_ad_ad(to, from)
    type(ad), intent(out) :: to
    type(ad), intent(in)  :: from
    to%x = from%x
    to%dx = from%dx
  end subroutine assign_ad_ad

  subroutine assign_ad_r(to, from)
    type(ad), intent(out) :: to
    real*8, intent(in)  :: from
    to%x = from
    to%dx = 0.0d0
  end subroutine assign_ad_r

  type(ad) function add_ad_ad(a, b)
    ! ad's add like vectors
    type(ad), intent(in) :: a, b
    add_ad_ad = ad(a%x+b%x,a%dx+b%dx)
  end function add_ad_ad

  type(ad) function add_r_ad(a, b)
    ! ad's add like vectors
    real*8, intent(in)   :: a
    type(ad), intent(in) :: b
    add_r_ad = ad(a+b%x,b%dx)
  end function add_r_ad

  type(ad) function add_i_ad(a, b)
    ! ad's add like vectors
    integer, intent(in)  :: a
    type(ad), intent(in) :: b
    add_i_ad = ad(a+b%x,b%dx)
  end function add_i_ad

  type(ad) function add_ad_r(a, b)
    ! ad's add like vectors
    type(ad), intent(in) :: a
    real*8, intent(in)   :: b
    add_ad_r = ad(a%x+b,a%dx)
  end function add_ad_r

  type(ad) function sub_ad_ad(a, b)
    ! ad's subtract like vectors
    type(ad), intent(in) :: a, b
    sub_ad_ad = ad(a%x-b%x,a%dx-b%dx)
  end function sub_ad_ad

  type(ad) function sub_r_ad(a, b)
    ! ad's subtract like vectors
    real*8, intent(in)   :: a
    type(ad), intent(in) :: b
    sub_r_ad = ad(a-b%x,-b%dx)
  end function sub_r_ad

  type(ad) function sub_ad_r(a, b)
    ! ad's subtract like vectors
    type(ad), intent(in) :: a
    real*8, intent(in)   :: b
    sub_ad_r = ad(a%x-b,a%dx)
  end function sub_ad_r

  type(ad) function mul_r_ad(a, b)
    !The product of ad's
    real*8, intent(in)   :: a
    type(ad), intent(in) :: b
    mul_r_ad = ad(a*b%x,a*b%dx)
  end function mul_r_ad

  type(ad) function mul_i_ad(a, b)
    !The product of ad's
    integer, intent(in)  :: a
    type(ad), intent(in) :: b
    mul_i_ad = ad(a*b%x,a*b%dx)
  end function mul_i_ad

  type(ad) function mul_ad_r(a, b)
    !The product of ad's
    type(ad), intent(in) :: a
    real*8, intent(in)   :: b
    mul_ad_r = ad(a%x*b,a%dx*b)
  end function mul_ad_r

  type(ad) function mul_ad_ad(a, b)
    !The product of ad's is given by the "product rule" of differentation:
    !   (x,dx)*(y,dy)=(xy,xdy+ydx).
    type(ad), intent(in) :: a, b
    mul_ad_ad = ad(a%x*b%x,(a%dx*b%x + a%x*b%dx))
  end function mul_ad_ad

  type(ad) function div_ad_ad(a, b)
    ! The quotient rule of differentiation gives
    !  (x,dx)/(y,dy)=(x/y,(ydx-xdy)/(y*y)).
    type(ad), intent(in) :: a, b
    div_ad_ad = ad(a%x/b%x,(a%dx*b%x - a%x*b%dx)/(b%x * b%x))
  end function div_ad_ad

  type(ad) function div_r_ad(a, b)
    !The product of ad's
    real*8, intent(in)   :: a
    type(ad), intent(in) :: b
    div_r_ad = ad(a/b%x,-a*b%dx/(b%x * b%x))
  end function div_r_ad

  type(ad) function exp_ad_int(a, n)
    type(ad), intent(in) :: a
    integer, intent(in)  :: n
    exp_ad_int = ad((a%x)**n,n*(a%x)**(n-1))
  end function exp_ad_int

  subroutine pr(str, a)
    character(len=*), intent(in) :: str
    type(ad), intent(in) :: a
    write(*,'(2(a,f14.7))') str,a%x,' ',a%dx
  end subroutine pr

end module autoDiff


! Name = ARPIT KUMAR JAIN ROLLNO = 180122009
PROGRAM question4
    IMPLICIT NONE

    INTEGER :: n, factorial = 1, i
    PRINT *, "Enter number: "

    ! reading integer from screen
    READ *, n

    ! finding factorial by looping 1 to n and storing multiplication on factorial variable
    DO i = 1, n
        factorial = factorial * i
    ENDDO

    ! printing factorial value on screen
    print *, factorial

    STOP
END PROGRAM


*DECK DGAMIT
      DOUBLE PRECISION FUNCTION DGAMIT (A, X)
C***BEGIN PROLOGUE  DGAMIT
C***PURPOSE  Calculate Tricomi's form of the incomplete Gamma function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7E
C***TYPE      DOUBLE PRECISION (GAMIT-S, DGAMIT-D)
C***KEYWORDS  COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB,
C             SPECIAL FUNCTIONS, TRICOMI
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C   Evaluate Tricomi's incomplete Gamma function defined by
C
C   DGAMIT = X**(-A)/GAMMA(A) * integral from 0 to X of EXP(-T) *
C              T**(A-1.)
C
C   for A .GT. 0.0 and by analytic continuation for A .LE. 0.0.
C   GAMMA(X) is the complete gamma function of X.
C
C   DGAMIT is evaluated for arbitrary real values of A and for non-
C   negative values of X (even though DGAMIT is defined for X .LT.
C   0.0), except that for X = 0 and A .LE. 0.0, DGAMIT is infinite,
C   which is a fatal error.
C
C   The function and both arguments are DOUBLE PRECISION.
C
C   A slight deterioration of 2 or 3 digits accuracy will occur when
C   DGAMIT is very large or very small in absolute value, because log-
C   arithmic variables are used.  Also, if the parameter  A  is very
C   close to a negative integer (but not a negative integer), there is
C   a loss of accuracy, which is reported if the result is less than
C   half machine precision.
C
C***REFERENCES  W. Gautschi, A computational procedure for incomplete
C                 gamma functions, ACM Transactions on Mathematical
C                 Software 5, 4 (December 1979), pp. 466-481.
C               W. Gautschi, Incomplete gamma functions, Algorithm 542,
C                 ACM Transactions on Mathematical Software 5, 4
C                 (December 1979), pp. 482-489.
C***ROUTINES CALLED  D1MACH, D9GMIT, D9LGIC, D9LGIT, DGAMR, DLGAMS,
C                    DLNGAM, XERCLR, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920528  DESCRIPTION and REFERENCES sections revised.  (WRB)
C***END PROLOGUE  DGAMIT
      DOUBLE PRECISION A, X, AEPS, AINTA, ALGAP1, ALNEPS, ALNG, ALX,
     1  BOT, H, SGA, SGNGAM, SQEPS, T, D1MACH, DGAMR, D9GMIT, D9LGIT,
     2  DLNGAM, D9LGIC
      LOGICAL FIRST
      SAVE ALNEPS, SQEPS, BOT, FIRST
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DGAMIT
      IF (FIRST) THEN
         ALNEPS = -LOG (D1MACH(3))
         SQEPS = SQRT(D1MACH(4))
         BOT = LOG (D1MACH(1))
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LT. 0.D0) CALL XERMSG ('SLATEC', 'DGAMIT', 'X IS NEGATIVE'
     +   , 2, 2)
C
      IF (X.NE.0.D0) ALX = LOG (X)
      SGA = 1.0D0
      IF (A.NE.0.D0) SGA = SIGN (1.0D0, A)
      AINTA = AINT (A + 0.5D0*SGA)
      AEPS = A - AINTA
C
      IF (X.GT.0.D0) GO TO 20
      DGAMIT = 0.0D0
      IF (AINTA.GT.0.D0 .OR. AEPS.NE.0.D0) DGAMIT = DGAMR(A+1.0D0)
      RETURN
C
 20   IF (X.GT.1.D0) GO TO 30
      IF (A.GE.(-0.5D0) .OR. AEPS.NE.0.D0) CALL DLGAMS (A+1.0D0, ALGAP1,
     1  SGNGAM)
      DGAMIT = D9GMIT (A, X, ALGAP1, SGNGAM, ALX)
      RETURN
C
 30   IF (A.LT.X) GO TO 40
      T = D9LGIT (A, X, DLNGAM(A+1.0D0))
      IF (T.LT.BOT) CALL XERCLR
      DGAMIT = EXP (T)
      RETURN
C
 40   ALNG = D9LGIC (A, X, ALX)
C
C EVALUATE DGAMIT IN TERMS OF LOG (DGAMIC (A, X))
C
      H = 1.0D0
      IF (AEPS.EQ.0.D0 .AND. AINTA.LE.0.D0) GO TO 50
C
      CALL DLGAMS (A+1.0D0, ALGAP1, SGNGAM)
      T = LOG (ABS(A)) + ALNG - ALGAP1
      IF (T.GT.ALNEPS) GO TO 60
C
      IF (T.GT.(-ALNEPS)) H = 1.0D0 - SGA * SGNGAM * EXP(T)
      IF (ABS(H).GT.SQEPS) GO TO 50
C
      CALL XERCLR
      CALL XERMSG ('SLATEC', 'DGAMIT', 'RESULT LT HALF PRECISION', 1,
     +   1)
C
 50   T = -A*ALX + LOG(ABS(H))
      IF (T.LT.BOT) CALL XERCLR
      DGAMIT = SIGN (EXP(T), H)
      RETURN
C
 60   T = T - A*ALX
      IF (T.LT.BOT) CALL XERCLR
      DGAMIT = -SGA * SGNGAM * EXP(T)
      RETURN
C
      END


PROGRAM set_max_value
IMPLICIT NONE
INTEGER, DIMENSION(1000,10,30) :: values
INTEGER :: i, j, k

DO i = 1, 1000
  DO j = 1, 10
    DO k = 1, 30
      values(i, j, k) = CEILING(RAND() * 1002.)
    END DO
  END DO
END DO

DO i = 1, 1000
  DO j = 1, 10
    DO k = 1, 30
      IF (values(i, j, k) .gt. 1000) THEN
        values(i, j, k) = 1000
        !WRITE(*, 100) i, j, k, values(i, j, k)
        !100 FORMAT ("POS:",I6,I4,I4,2X,"VAL:",I6)
      END IF
    END DO
  END DO
END DO

DO i = 1, 1000
  DO j = 1, 10
    DO k = 1, 30
      values(i, j, k) = CEILING(RAND() * 1002.)
    END DO
  END DO
END DO

WHERE (values > 1000)
  values = 1000
END WHERE

END PROGRAM set_max_value


! THIS VERSION: GALAHAD 2.1 - 22/03/2007 AT 09:00 GMT.
   PROGRAM GALAHAD_L2RT_test_deck
   USE GALAHAD_L2RT_DOUBLE                            ! double precision version
   USE GALAHAD_SYMBOLS
   IMPLICIT NONE
   INTEGER, PARAMETER :: working = KIND( 1.0D+0 )     ! set precision
   REAL ( KIND = working ), PARAMETER :: one = 1.0_working, zero = 0.0_working
   INTEGER, PARAMETER :: n = 50, m = 2 * n            ! problem dimensions
   INTEGER, PARAMETER :: m2 = 50, n2 = 2 * m2         ! 2nd problem dimensions
   INTEGER :: i, pass, status, problem, nn
   REAL ( KIND = working ), DIMENSION( n ) :: X, V
   REAL ( KIND = working ), DIMENSION( m ) :: U
   REAL ( KIND = working ), DIMENSION( n2 ) :: X2, V2
   REAL ( KIND = working ), DIMENSION( m2 ) :: U2
   REAL ( KIND = working ), DIMENSION( 0 ) :: X0, V0, U0
   REAL ( KIND = working ) :: p, sigma, mu

   TYPE ( L2RT_data_type ) :: data
   TYPE ( L2RT_control_type ) :: control
   TYPE ( L2RT_inform_type ) :: inform

!  ==============
!  Normal entries
!  ==============

   WRITE( 6, "( /, ' ==== normal exits ====== ', / )" )

! Initialize control parameters

   OPEN( UNIT = 23, STATUS = 'SCRATCH' )
   DO problem = 1, 2
     DO pass = 1, 10
       IF ( pass /= 4 .AND. pass /= 7 .AND. pass /= 8 )                         &
         CALL L2RT_initialize( data, control )
!      control%print_level = 1
!      control%itmax = 50
!      control%extra_vectors = 100
       control%error = 23 ; control%out = 23 ; control%print_level = 10
       inform%status = 1
       sigma = one
       p = 3.0_working
       mu = 0.0_working
       IF ( pass == 2 ) sigma = 10.0_working
       IF ( pass == 3 ) sigma = 0.0001_working
       IF ( pass == 4 ) THEN
         control%fraction_opt = 0.99_working
       END IF
       IF ( pass == 5 ) THEN
         control%fraction_opt = 0.99_working
         control%extra_vectors = 1
       END IF
       IF ( pass == 6 ) THEN
         control%fraction_opt = 0.99_working
         control%extra_vectors = 100
       END IF
       IF ( pass == 7 ) THEN
         control%fraction_opt = 0.99_working
         control%extra_vectors = 100
       END IF
       IF ( pass == 8 ) THEN
         control%fraction_opt = 0.99_working
         p = 2.0_working
       END IF
       IF ( pass == 9 ) THEN
         control%prefix = '"L2RT: "     '
!        control%error = 6 ; control%out = 6 ; control%print_level = 1
!        sigma = 10.0_working
       END IF
       IF ( pass == 10 ) THEN
         control%prefix = '"L2RT: "     '
!        control%error = 6 ; control%out = 6 ; control%print_level = 1
         p = 2.0_working
         mu = 1.0_working
       END IF

       IF ( problem == 1 ) THEN
         U = one
!        control%error = 6 ; control%out = 6 ; control%print_level = 1
         DO
           CALL L2RT_solve( m, n, p, sigma, mu, X, U, V, data, control, inform )

           SELECT CASE( inform%status )  ! Branch as a result of inform%status
           CASE( 2 )                     !  Form u <- u + A * v
             U( : n ) = U( : n ) + V
             DO i = 1, n
               U( n + i ) = U( n + i ) + i * V( i )
             END DO
           CASE( 3 )                     !  Form v <- v + A^T * u
             V = V + U( : n )            !  A^T = ( I : diag(1:n) )
             DO i = 1, n
               V( i ) = V( i ) + i * U( n + i )
             END DO
           CASE ( 4 )                    ! Restart
              U = one
           CASE DEFAULT
              EXIT
           END SELECT
         END DO
       ELSE
         U2 = one
 !       control%error = 6 ; control%out = 6 ; control%print_level = 1
         DO
           CALL L2RT_solve( m2, n2, p, sigma, mu, X2, U2, V2, data, control,   &
                            inform )

           SELECT CASE( inform%status )  ! Branch as a result of inform%status
           CASE( 2 )                     !  Form u <- u + A * v
             U2 = U2 + V2( : n )         !  A = ( I : diag(1:n) )
             DO i = 1, n
               U2( i ) = U2( i ) + i * V2( n + i )
             END DO
           CASE( 3 )                     !  Form v <- v + A^T * u
             V2( : n ) = V2( : n ) + U2
             DO i = 1, n
               V2( n + i ) = V2( n + i ) + i * U2( i )
             END DO
           CASE ( 4 )                    ! Restart
              U2 = one
           CASE DEFAULT
              EXIT
           END SELECT
         END DO
       END IF
       WRITE( 6, "( ' problem ', I1, ' pass ', I3,                              &
      &     ' L2RT_solve exit status = ', I6 )" ) problem, pass, inform%status
!      WRITE( 6, "( ' its, solution and Lagrange multiplier = ', I6, 2ES12.4 )")&
!                inform%iter + inform%iter_pass2, f, inform%multiplier
       CALL L2RT_terminate( data, control, inform ) ! delete internal workspace
     END DO
   END DO

!  =============
!  Error entries
!  =============

   WRITE( 6, "( /, ' ==== error exits ====== ', / )" )

! Initialize control parameters

   status = 3
   DO pass = 1, 4
      sigma = one
      p = 3.0_working
      mu = zero
      CALL L2RT_initialize( data, control )
      control%error = 23 ; control%out = 23 ; control%print_level = 10
      inform%status = 1
      U = one
      IF ( pass == 1 ) nn = 0
      IF ( pass == 2 ) sigma = - one
      IF ( pass == 3 ) p = one
      IF ( pass == 4 ) mu = - one

!  Iteration to find the minimizer

      DO
        IF ( pass == 1 ) THEN
          CALL L2RT_solve( 0, nn, p, sigma, mu, X0, U0, V0, data, control,     &
                           inform )
        ELSE
          CALL L2RT_solve( m, n, p, sigma, mu, X, U, V, data, control, inform )
        END IF

        SELECT CASE( inform%status )  ! Branch as a result of inform%status
        CASE( 2 )                     !  Form u <- u + A * v
          U( : n ) = U( : n ) + V
          DO i = 1, n
            U( n + i ) = U( n + i ) + i * V( i )
          END DO
        CASE( 3 )                     !  Form v <- v + A^T * u
          V = V + U( : n )            !  A^T = ( I : diag(1:n) )
          DO i = 1, n
            V( i ) = V( i ) + i * U( n + i )
          END DO
        CASE ( 4 )                    ! Restart
           U = one
        CASE DEFAULT
           EXIT
        END SELECT
      END DO
      WRITE( 6, "(  I3, ' L2RT_solve exit status = ', I6 )" )         &
             status, inform%status
      CALL L2RT_terminate( data, control, inform ) !  delete internal workspace
   END DO

   DO status = 1, 25
     IF ( status == - GALAHAD_error_allocate ) CYCLE
     IF ( status == - GALAHAD_error_deallocate ) CYCLE
     IF ( status == - GALAHAD_error_restrictions ) CYCLE
     IF ( status == - GALAHAD_error_bad_bounds ) CYCLE
     IF ( status == - GALAHAD_error_primal_infeasible ) CYCLE
     IF ( status == - GALAHAD_error_dual_infeasible ) CYCLE
     IF ( status == - GALAHAD_error_unbounded ) CYCLE
     IF ( status == - GALAHAD_error_no_center ) CYCLE
     IF ( status == - GALAHAD_error_analysis ) CYCLE
     IF ( status == - GALAHAD_error_factorization ) CYCLE
     IF ( status == - GALAHAD_error_solve ) CYCLE
     IF ( status == - GALAHAD_error_uls_analysis ) CYCLE
     IF ( status == - GALAHAD_error_uls_factorization ) CYCLE
     IF ( status == - GALAHAD_error_uls_solve ) CYCLE
     IF ( status == - GALAHAD_error_preconditioner ) CYCLE
     IF ( status == - GALAHAD_error_ill_conditioned ) CYCLE
     IF ( status == - GALAHAD_error_tiny_step ) CYCLE
!    IF ( status == - GALAHAD_error_max_iterations ) CYCLE
     IF ( status == - GALAHAD_error_cpu_limit ) CYCLE
     IF ( status == - GALAHAD_error_inertia ) CYCLE
     IF ( status == - GALAHAD_error_file ) CYCLE
     IF ( status == - GALAHAD_error_io ) CYCLE
     IF ( status == - GALAHAD_error_upper_entry ) CYCLE
     IF ( status == - GALAHAD_error_sort ) CYCLE
     IF ( status == - GALAHAD_error_sort ) CYCLE
!    IF ( status == - GALAHAD_error_input_status ) CYCLE

      sigma = one
      p = 3.0_working
      mu = zero
      CALL L2RT_initialize( data, control )
      control%error = 23 ; control%out = 23 ; control%print_level = 10
      inform%status = 1
      U = one
      IF ( status == - GALAHAD_error_max_iterations ) THEN
        control%itmax = 0
      ELSE IF ( status == - GALAHAD_error_input_status ) THEN
        inform%status = 0
      ELSE
write(6,*) status
        EXIT
      END IF

!  Iteration to find the minimizer

      DO
        CALL L2RT_solve( m, n, p, sigma, mu, X, U, V, data, control, inform )

        SELECT CASE( inform%status )  ! Branch as a result of inform%status
        CASE( 2 )                     !  Form u <- u + A * v
          U( : n ) = U( : n ) + V
          DO i = 1, n
            U( n + i ) = U( n + i ) + i * V( i )
          END DO
        CASE( 3 )                     !  Form v <- v + A^T * u
          V = V + U( : n )            !  A^T = ( I : diag(1:n) )
          DO i = 1, n
            V( i ) = V( i ) + i * U( n + i )
          END DO
        CASE ( 4 )                    ! Restart
           U = one
        CASE DEFAULT
           EXIT
        END SELECT
      END DO
      WRITE( 6, "(  I3, ' L2RT_solve exit status = ', I6 )" )         &
             status, inform%status
      CALL L2RT_terminate( data, control, inform ) !  delete internal workspace
   END DO
   CLOSE( unit = 23 )

   END PROGRAM GALAHAD_L2RT_test_deck


      SUBROUTINE bextrema(modb, bmin, bmax, nzeta, ntheta)
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER :: nzeta, ntheta
      REAL(rprec), INTENT(in)  :: modb(nzeta,ntheta)
      REAL(rprec), INTENT(out) :: bmin(ntheta), bmax(ntheta)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: ku
C-----------------------------------------------
!
!     Computes MAX, MIN of |B| along v (zeta) between two angle lines (theta = 0,pi)
!
      DO ku = 1,ntheta
         bmin(ku)  = MINVAL(modb(:,ku))
         bmax(ku)  = MAXVAL(modb(:,ku))
      ENDDO

      END SUBROUTINE bextrema


SUBROUTINE p71(input_file,output_file)
!-------------------------------------------------------------------------
! SUBROUTINE 7.1 One dimensional analysis of steady seepage using
!             2-node "rod" elements.
!-------------------------------------------------------------------------
 USE main
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::fixed_freedoms,i,iel,k,loaded_nodes,nels,neq,nlen,nod=2,nn,     &
   nprops=1,np_types
 REAL(iwp)::penalty=1.0e20_iwp,zero=0.0_iwp
 CHARACTER(LEN=15)::argv
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),kdiag(:),g_num(:,:),node(:),num(:)
 REAL(iwp),ALLOCATABLE::disps(:),ell(:),kp(:,:),kv(:),kvh(:),loads(:),    &
   prop(:,:),value(:)
!-----------------------input and initialisation--------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nels,nn,np_types
 neq=nn
 ALLOCATE(ell(nels),num(nod),prop(nprops,np_types),etype(nels),           &
   kp(nod,nod),g_num(nod,nels),kdiag(neq),loads(0:neq),disps(0:neq))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)ell
 READ(10,*)g_num
 kdiag=0
!-----------------------loop the elements to find global arrays sizes-----
 elements_1: DO iel=1,nels
   num=g_num(:,iel)
   CALL fkdiag(kdiag,num)
 END DO elements_1
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 WRITE(11,'(2(A,I5))')                                                    &
   " There are",neq," equations and the skyline storage is",kdiag(neq)
 ALLOCATE(kv(kdiag(neq)),kvh(kdiag(neq)))
 kv=zero
!-----------------------global conductivity matrix assembly---------------
 elements_2: DO iel=1,nels
   CALL rod_km(kp,prop(1,etype(iel)),ell(iel))
   num=g_num(:,iel)
   CALL fsparv(kv,kp,num,kdiag)
 END DO elements_2
 kvh=kv
!-----------------------specify boundary values---------------------------
 loads=zero
 READ(10,*)loaded_nodes,(k,loads(k),i=1,loaded_nodes)
 READ(10,*)fixed_freedoms
 IF(fixed_freedoms/=0)THEN
   ALLOCATE(node(fixed_freedoms),value(fixed_freedoms))
   READ(10,*)(node(i),value(i),i=1,fixed_freedoms)
   kv(kdiag(node))=kv(kdiag(node))+penalty
   loads(node)=kv(kdiag(node))*value
 END IF
!-----------------------equation solution---------------------------------
 CALL sparin(kv,kdiag)
 CALL spabac(kv,loads,kdiag)
!-----------------------retrieve nodal net flow rates---------------------
 CALL linmul_sky(kvh,loads,disps,kdiag)
 WRITE(11,'(/A)')"  Node Total Head  Flow rate"
 disps(0)=zero
 DO k=1,nn
   WRITE(11,'(I5,2E12.4)')k,loads(k),disps(k)
 END DO
 WRITE(11,'(/A)')"       Inflow      Outflow"
 WRITE(11,'(5X,2E12.4)')                                                  &
   SUM(disps,MASK=disps>zero),SUM(disps,MASK=disps<zero)

END SUBROUTINE p71


!***** INITIALCON.F90 ********************************************************************
module initialcon

use params
use helpers
use basis_funcs

use boundary_custom
use boundary

real :: rh_fluid  ! set far-field fluid density

contains

    !===========================================================================
    ! set_ic
    !    Select and set the initial conditions
    !------------------------------------------------------------
    subroutine set_ic(Q_r, id)
        implicit none
        real, dimension(nx,ny,nz,nQ,nbasis), intent(inout) :: Q_r
        ! character(*), intent(in) :: name
        integer i,j,k,id

        ! te_fluid = T_floor
        ! rh_fluid = 1.0
        ! coll = rh_fluid*te_fluid/vis
        ! colvis = coll*vis  ! or, dn*te
        if (ivis == 0) then
            coll = 0
            colvis = 0
        end if

        Q_r(:,:,:,:,:)  = 0.0
        Q_r(:,:,:,rh,1) = rh_floor
        Q_r(:,:,:,en,1) = T_floor*rh_floor/aindm1
        ! QMask(:,:,:) = .false.
        ! MMask(:,:,:) = .false.

        select case(id)
            ! case(0)
            !     call mpi_print(iam, 'Setting up 2D hydrodynamic jet (old version)...')
            !     call fill_fluid2(Q_r)
            case(0)
                call mpi_print(iam, 'Setting up 2D hydrodynamic jet...')
                call hydro_jet(Q_r)
            case(1)
                call mpi_print(iam, 'Setting up 2D isentropic vortex v0...')
                call isentropic_vortex(Q_r, 0)
            case(2)
                call mpi_print(iam, 'Setting up 2D isentropic vortex v1...')
                call isentropic_vortex(Q_r, 1)
            case(3)
                call mpi_print(iam, 'Setting up 1D Sod Shock Tube v1...')
                call sod_shock_tube_1d(Q_r, 0)
            case(4)
                call mpi_print(iam, 'Setting up 1D Sod Shock Tube v2...')
                call sod_shock_tube_1d(Q_r, 1)
            case(5)
                call mpi_print(iam, 'Setting up Poiseuille flow problem...')
                call poiseuille_flow(Q_r)
            case(6)
                call mpi_print(iam, 'Setting up 2D cylinder-in-pipe (laminar)...')
                call pipe_cylinder_2d(Q_r, 0)
            case(7)
                call mpi_print(iam, 'Setting up 2D cylinder-in-pipe (periodic)...')
                call pipe_cylinder_2d(Q_r, 1)
        end select

        ! coll = epsi  ! temporary hack: set coll to epsi to get old behavior
    end subroutine set_ic
    !---------------------------------------------------------------------------

    !===========================================================================
    ! 2D unstable hydrodynamic jet
    !------------------------------------------------------------
    subroutine hydro_jet(Q_r)
        implicit none
        real, dimension(nx,ny,nz,nQ,nbasis), intent(inout) :: Q_r
        integer i,j,k
        real te,dn,pr,beta,beta2,smx,smy,smz,rand_num,rnum

        dn = 1.0
        te = T_floor
        pr = te*dn

        coll   = dn*te/vis  ! global
        colvis = coll*vis   ! or, dn*te  (also global)

        beta  = 1.0   ! jet strength
        beta2 = 0.005 ! perturbation strength

        do k = 1,nz
        do j = 1,ny
        do i = 1,nx
            call random_number(rand_num)
            rnum = (rand_num - 0.5)

            smx = beta*dn/cosh(20*yc(j)/lyu)
            smy = beta2*rnum/cosh(20*yc(j)/lyu)**2
            smz = 0

            Q_r(i,j,k,rh,1) = dn
            Q_r(i,j,k,mx,1) = smx
            Q_r(i,j,k,my,1) = smy
            Q_r(i,j,k,mz,1) = smz
            Q_r(i,j,k,en,1) = pr/aindm1 + 0.5*(smx**2 + smy**2 + smz**2)/dn
        end do
        end do
        end do

    end subroutine hydro_jet
    !---------------------------------------------------------------------------

    !===========================================================================
    ! 2D isentropic vortex
    !------------------------------------------------------------
    ! For a survey of 2D isentropic vortex problems:
    !    Spiegel, et al. "A Survey of the Isentropic..." (2015)
    ! Version 0 -- horizontal propagation, see
    !    Hesthaven & Warburton, "Nodal Discontinuous Galerkin..." (2008)
    ! Version 1 -- diagonal propagation, see
    !    Shu, "Essentially Non-oscillatory and... Weighted" (1998)
    !---------------------------------------------------------------------------
    subroutine isentropic_vortex(Q_r, ver)
        implicit none
        real, dimension(nx,ny,nz,nQ,nbasis), intent(inout) :: Q_r
        integer i,j,k, ver
        real rh_amb,vx_amb,vy_amb,vz_amb,pr_amb,te_amb,Rgsqi,beta
        real xctr,yctr,zctr,xp,yp,r2,delta_vx,delta_vy,delta_T
        real dn,vx,vy,vz,te,pr

        beta   = 5.0            ! vortex strength
        rh_amb = 1.0            ! ambient density
        vx_amb = 1.0            ! ambient x-velocity  1.0/aindex**0.5
        select case(ver)
          case(0)
            vy_amb = 0.0        ! ambient y-velocity  1.0/aindex**0.5
            Rgsqi = 1.0         ! inverse grid length scale squared
          case(1)
            vy_amb = 1.0        ! ambient y-velocity  1.0/aindex**0.5
            Rgsqi = 0.5         ! inverse grid length scale squared
        end select
        vz_amb = 0.0            ! ambient z-velocity
        pr_amb = 1.0            ! ambient pressure (atmospheric pressure)
        te_amb = pr_amb/rh_amb  ! ambient temperature

        xctr = 0.0              ! vortex center in x-directionrh_fluid*te/vis
        yctr = 0.0              ! vortex center in y-direction
        zctr = 0.0              ! vortex center in z-direction

        do k = 1,nz
        do j = 1,ny
        do i = 1,nx
            xp = xc(i) - xctr   ! x-value from vortex center
            yp = yc(j) - yctr   ! y-value from vortex center
            r2 = xp**2 + yp**2  ! radial distance from vortex center

            delta_vx = -yp*beta/(2*pi) * exp( Rgsqi*(1 - r2) )
            delta_vy =  xp*beta/(2*pi) * exp( Rgsqi*(1 - r2) )
            delta_T  = -(aindm1*beta**2)/(16*Rgsqi*aindex*pi**2) * exp( 2*Rgsqi*(1 - r2) )

            vx = vx_amb + delta_vx
            vy = vy_amb + delta_vy
            vz = vz_amb
            te = te_amb + delta_T
            dn = te**(1./aindm1)  ! OR (1 - delta_T)**(1/(gamma-1)), rh_amb * te**(1./aindm1)
            pr = dn**aindex  ! use te*dn OR dn**aindex (for ideal gas)

            Q_r(i,j,k,rh,1) = dn
            Q_r(i,j,k,mx,1) = dn*vx
            Q_r(i,j,k,my,1) = dn*vy
            Q_r(i,j,k,mz,1) = dn*vz
            Q_r(i,j,k,en,1) = pr/aindm1 + 0.5*dn*(vx**2 + vy**2 + vz**2)
        end do
        end do
        end do
        ! print *,'iam=',iam,'xl=',xc(1),'xh=',xc(nx),'yl=',yc(1),'yh=',yc(ny)

    end subroutine isentropic_vortex
    !---------------------------------------------------------------------------

    !===========================================================================
    ! SOD Shock Tube
    !------------------------------------------------------------
    subroutine sod_shock_tube_1d(Q_r, ver)
        implicit none
        real, dimension(nx,ny,nz,nQ,nbasis), intent(inout) :: Q_r
        integer i,j,k, ver
        real rh_hi,rh_lo,pr_hi,pr_lo,xctr,yctr,xp,yp,dn,vx,vy,vz,pr

        rh_hi = 1.0 !e-4  ! NOTE: density floor needs to be 5.0e-6 (e-4 for original)
        pr_hi = 1.0*P_base  ! atmospheric pressure
        rh_lo = 0.125 !e-4
        pr_lo = 0.1*P_base
        vx = 0.0
        vy = 0.0
        vz = 0.0

        xctr = 0
        yctr = 0  ! only needed if shock normal not aligned w/ x-direction

        do k = 1,nz
        do j = 1,ny
        do i = 1,nx
            xp = xc(i) - xctr
            if ( ver == 1 ) then
                yp = yc(j) - yctr
            else
                yp = 0
            endif

            if ( xp+yp <= 0 ) then
                dn = rh_hi
                pr = pr_hi
            endif
            if ( xp+yp > 0 ) then
                dn = rh_lo
                pr = pr_lo
            endif

            Q_r(i,j,k,rh,1) = dn
            Q_r(i,j,k,mx,1) = dn*vx
            Q_r(i,j,k,my,1) = dn*vy
            Q_r(i,j,k,mz,1) = dn*vz
            Q_r(i,j,k,en,1) = pr/aindm1 + 0.5*dn*(vx**2 + vy**2 + vz**2)
        end do
        end do
        end do

    end subroutine sod_shock_tube_1d
    !---------------------------------------------------------------------------

    !===========================================================================
    ! 2D pipe (Poiseuille) flow
    !   * Need outflow BCs on right wall: nu d u/d eta - p*eta = 0
    ! NOTE: This subroutine sets BCs for the problem using custom_boundary
    !------------------------------------------------------------
    subroutine poiseuille_flow(Q_r)
        use boundary_custom

        implicit none
        real, dimension(nx,ny,nz,nQ,nbasis), intent(inout) :: Q_r
        integer i,j,k,ieq
        real dn,pr,te,vx,vy,vz,ux_amb,yp,yp0

        !-------------------------------------------------------
        ! Definitions
        dn = 1.0
        te = T_floor
        pr = dn*te  ! 1.0*P_base  ! can be adjusted to get stable results

        coll   = dn*te/vis  ! global (CES' nu = rh_fluid*T_floor)
        colvis = coll*vis   ! or, dn*te  (also global)

        vx = 0.0
        vy = 0.0
        vz = 0.0

        yp0 = lyd  ! set zero-value of y-coordinate to domain bottom
        ux_amb = 3.0e-1

        !-------------------------------------------------------
        ! Set initial conditions
        do k = 1,nz
        do j = 1,ny
        do i = 1,nx
            Q_r(i,j,k,rh,1) = dn
            Q_r(i,j,k,mx,1) = dn*vx
            Q_r(i,j,k,my,1) = dn*vy
            Q_r(i,j,k,mz,1) = dn*vz
            Q_r(i,j,k,en,1) = pr/aindm1 + 0.5*dn*(vx**2 + vy**2 + vz**2)
        end do
        end do
        end do

        Qxlo_ext_def(:,:,:,:) = 0.0
        call set_xlobc_inflow(ux_amb, dn, pr, Qxlo_ext_def)
    end subroutine poiseuille_flow
    !---------------------------------------------------------------------------

    !===========================================================================
    ! 2D pipe flow around a cylinder
    !   * Re ~ 20 for laminar case (ver 0)
    !   * Re ~ 100 for periodic case (version 1)
    !   * Need outflow BCs on right wall: nu d u/d eta - p*eta = 0
    !   * No-slip BCs everywhere else
    ! NOTE: This subroutine sets BCs for the problem using custom_boundary
    !------------------------------------------------------------
    subroutine pipe_cylinder_2d(Q_r, version)
        use boundary_custom

        implicit none
        real, dimension(nx,ny,nz,nQ,nbasis), intent(inout) :: Q_r
        ! logical, dimension(nx,ny,nz) :: Qmask
        integer i,j,k,ieq,version
        real dn,pr,te,vx,vy,vz,ux_amb,xp0,yp0,cyl_x0,cyl_y0,cyl_rad

        !-------------------------------------------------------
        ! Definitions
        dn = 1.0
        te = T_floor
        pr = dn*te  ! 1.0*P_base  ! can be adjusted to get stable results

        coll   = dn*te/vis  ! global
        colvis = coll*vis   ! or, dn*te  (also global)

        vx = 0.0
        vy = 0.0
        vz = 0.0

        xp0 = lxd              ! set zero-value of x-coordinate to left of domain
        yp0 = lyd              ! set zero-value of y-coordinate to bottom of domain
        cyl_x0  = xp0 + ly/2.  ! center of cylinder relative to origin
        cyl_y0  = yp0 + ly/2.
        cyl_rad = ly/8.

        select case(version)
            case(0)
                ux_amb = 0.3
            case(1)
                ux_amb = 1.5
        end select

        !-------------------------------------------------------
        ! Set initial conditions
        do k = 1,nz
        do j = 1,ny
        do i = 1,nx
            Q_r(i,j,k,rh,1) = dn
            Q_r(i,j,k,mx,1) = dn*vx
            Q_r(i,j,k,my,1) = dn*vy
            Q_r(i,j,k,mz,1) = dn*vz
            Q_r(i,j,k,en,1) = pr/aindm1 + 0.5*dn*(vx**2 + vy**2 + vz**2)
        end do
        end do
        end do

        !-------------------------------------------------------
        ! Generate cylinder mask --> zero out grid quantities in mask
        !   NOTE: might be an offset b/c mask is constructed at faces, not cells
        ! Qmask(:,:,:) = cyl_in_2d_pipe_mask(cyl_x0, cyl_y0, cyl_rad)

        ! where (Qmask(:,:,:))
        !     Q_r(:,:,:,rh,1) = 1.25
        !     Q_r(:,:,:,mx,1) = 0.0
        !     Q_r(:,:,:,my,1) = 0.0
        !     Q_r(:,:,:,mz,1) = 0.0
        ! end where

        ! NOTE: Qxlow_ext_custom, Qcyl_ext, and QMask should already be initialized!
        ! call add_custom_boundaries(icname)
        call set_cyl_in_2d_pipe_boundaries(Qmask, ux_amb, dn, pr, Qxlo_ext_def, Qcyl_ext_c)

    end subroutine pipe_cylinder_2d
    !---------------------------------------------------------------------------

end module initialcon


    Program zheevd_example

!     ZHEEVD Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use blas_interfaces, Only: zscal
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen
      Use lapack_interfaces, Only: zheevd
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, ifail, info, k, lda, liwork, lrwork, lwork, n
      Character (1) :: job, uplo
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), work(:)
      Real (Kind=dp), Allocatable :: rwork(:), w(:)
      Integer, Allocatable :: iwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, cmplx, conjg, maxloc
!     .. Executable Statements ..
      Write (nout, *) 'ZHEEVD Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      liwork = 5*n + 3
      lrwork = 2*n*n + 5*n + 1
      lwork = n*(n+2)
      Allocate (a(lda,n), work(lwork), rwork(lrwork), w(n), iwork(liwork))
      Read (nin, *) uplo

!     Read A from data file

      If (uplo=='U') Then
        Read (nin, *)(a(i,i:n), i=1, n)
      Else If (uplo=='L') Then
        Read (nin, *)(a(i,1:i), i=1, n)
      End If

      Read (nin, *) job

!     Calculate all the eigenvalues and eigenvectors of A
      Call zheevd(job, uplo, n, a, lda, w, work, lwork, rwork, lrwork, iwork, &
        liwork, info)

      Write (nout, *)
      If (info>0) Then
        Write (nout, *) 'Failure to converge.'
      Else

!       Print eigenvalues and eigenvectors

        Write (nout, *) 'Eigenvalues'
        Do i = 1, n
          Write (nout, 100) i, w(i)
        End Do
        Write (nout, *)
        Flush (nout)

!       Normalize the eigenvectors so that the element of largest absolute
!       value is real.
        Do i = 1, n
          rwork(1:n) = abs(a(1:n,i))
          k = maxloc(rwork(1:n), 1)
          Call zscal(n, conjg(a(k,i))/cmplx(abs(a(k,i)),kind=dp), a(1,i), 1)
        End Do

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_complex_gen('General', ' ', n, n, a, lda, &
          'Eigenvectors', ifail)

      End If

100   Format (3X, I5, 5X, 2F8.4)
    End Program


      real*8 function grad_array(coord, array, i)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
!***********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 Calculate derivative functions needed for POD basis functions.
!D1
!***********************************************************************
!D2
!D2 REVISION HISTORY
!D2
!D2 FEHM Version 2.30
!D2
!D2 Initial implementation: 08-SEP-04, Programmer: B. Robinson
!D2
!D2 $Log:   /pvcs.config/fehm90/src/grad_array.f_a  $
!D2
!***********************************************************************
!D3
!D3 REQUIREMENTS TRACEABILITY
!D3
!D3 2.3.6 Streamline particle-tracking module
!D3
!***********************************************************************
!D4
!D4 SPECIAL COMMENTS AND REFERENCES
!D4
!D4 Requirements from SDN: 10086-RD-2.20-00
!D4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
!D4   FEHM Application Version 2.20
!D4
!***********************************************************************

      use comai, only : neq
      use combi, only : cord
      use comsptr, only : irray
      implicit none
      real*8 dumcoord(-1:1)
      real*8 deriv, deriv1, deriv2
      integer i,j,ix1,ixm1
      real*8 array(neq)
      integer coord

c recall neighbouring node numbers
      ix1=irray(i,coord)
      ixm1=irray(i,-coord)

c account for boundary nodes by taking the other connection if
c     there is no connection at that location
c     Then, we average the two derivtaives to do either a centered
c     difference or just get the one that exists

      dumcoord(0) = cord(i, coord)

      if(ix1.le.0) then
         dumcoord(-1) = cord(ixm1, coord)
         deriv1 = (array(i)-array(ixm1))/(dumcoord(0)-dumcoord(-1))
      else
         dumcoord(1) = cord(ix1, coord)
         deriv1 = (array(ix1)-array(i))/(dumcoord(1)-dumcoord(0))
      end if
      if(ixm1.le.0) then
         dumcoord(1) = cord(ix1, coord)
         deriv2 = (array(ix1)-array(i))/(dumcoord(1)-dumcoord(0))
      else
         dumcoord(-1) = cord(ixm1, coord)
         deriv2 = (array(i)-array(ixm1))/(dumcoord(0)-dumcoord(-1))
      end if

      grad_array = (deriv1 + deriv2)/2.

      return

      end