module mod_cond_triangular
  use mod_triangular
  use mod_prec
  use mod_error_id
  use mod_utility
  implicit none

  private

  public :: lower_left_nullvec, z_lower_left_nullvec, d_lower_left_nullvec, &
       lower_right_nullvec, z_lower_right_nullvec, d_lower_right_nullvec, &
       lower_min_sv, d_lower_min_sv, z_lower_min_sv, &
       lower_max_sv, d_lower_max_sv, z_lower_max_sv, &
       upper_min_sv, d_upper_min_sv, z_upper_min_sv, &
       upper_max_sv, d_upper_max_sv, z_upper_max_sv

  interface lower_left_nullvec
     module procedure z_lower_left_nullvec, d_lower_left_nullvec
  end interface lower_left_nullvec

  interface lower_right_nullvec
     module procedure z_lower_right_nullvec, d_lower_right_nullvec
  end interface lower_right_nullvec

  interface lower_min_sv
     module procedure  d_lower_min_sv, z_lower_min_sv
  end interface lower_min_sv

  interface lower_max_sv
     module procedure  d_lower_max_sv, z_lower_max_sv
  end interface lower_max_sv

  interface upper_min_sv
     module procedure  d_upper_min_sv, z_upper_min_sv
  end interface upper_min_sv

  interface upper_max_sv
     module procedure  d_upper_max_sv, z_upper_max_sv
  end interface upper_max_sv

  integer(kind=int32), parameter :: default_maxit=20
  real(kind=dp), parameter :: default_tol=4*eps, default_tolres=4*eps

contains

  real(kind=dp) function d_upper_max_sv(r,u1,v1,res,tolres0, &
       maxit0,error) result(sigmau)
    real(kind=dp), dimension(:,:), intent(in) :: r
    real(kind=dp), dimension(:), intent(out) :: u1,v1,res
    real(kind=dp), intent(in), optional :: tolres0
    type(error_info), intent(inout), optional :: error
    integer(kind=int32), intent(in), optional :: maxit0

    integer(kind=int32) :: n, k, maxit
    real(kind=dp) :: tolres, sigmav, sigmau0, maxr
    type(routine_info), parameter :: info=info_d_upper_max_sv
    !
    sigmau=0.0_dp
    if (failure(error)) return
    call push_id(info, error)

    n=size(r,1)
    if (n<1) then
       call set_error(1, info, error); return
    else if (n /= size(r,2)) then
       call set_error(2, info, error); return
    else if (n /= size(u1) .or. n /= size(v1) .or. n /= size(res)) then
       call set_error(3, info, error); return
    end if

    maxr=maxabs(r)
    maxit=equals_option(default_maxit,maxit0)
    tolres=equals_option(maxr*default_tolres,tolres0)

    u1=0.0_dp
    v1=0.0_dp
    if (maxr==0.0_dp) then
       u1(1)=1.0_dp; v1(1)=1.0_dp
       sigmau=0.0_dp
       res=0.0_dp
       call pop_id(error)
       return
    else
       ! Get initial vectors.
       call upper_tr_left_multiply_linpack(r,u1,v1)
       sigmau=norm2(v1)
       v1=v1/sigmau
       sigmav=norm2(u1) ! not really sigmav.
       sigmau=sigmau/sigmav
       u1=u1/sigmav
       k=1
       do while (k < maxit)
          ! Update u1
          res=u1; sigmau0=sigmau
          call upper_left_multiply(r,v1,u1)
          sigmav=norm2(u1)
          u1=u1/sigmav
          ! Update v1
          call upper_tr_left_multiply(r,u1,v1)
          sigmau=norm2(v1)
          v1=v1/sigmau
          res = u1*sigmav-res*sigmau0
          if (norm2(res) < tolres) then
             call pop_id(error)
             return
          end if
          k=k+1
       end do
       if (tolres==0.0_dp) then
          ! maxits is OK if tolerance is zero.
          call pop_id(error)
       else
          call set_error(4, info, error); return
       end if
    end if
  end function d_upper_max_sv

  real(kind=dp) function z_upper_max_sv(r,u1,v1,res,tolres0, &
       maxit0,error) result(sigmau)
    complex(kind=dp), dimension(:,:), intent(in) :: r
    complex(kind=dp), dimension(:), intent(out) :: u1,v1,res
    real(kind=dp), intent(in), optional :: tolres0
    type(error_info), intent(inout), optional :: error
    integer(kind=int32), intent(in), optional :: maxit0

    integer(kind=int32) :: n, k, maxit
    real(kind=dp) :: tolres, sigmav, sigmau0, maxr
    type(routine_info), parameter :: info=info_z_upper_max_sv
    !
    sigmau=0.0_dp
    if (failure(error)) return
    call push_id(info, error)

    n=size(r,1)
    if (n<1) then
       call set_error(1, info, error); return
    else if (n /= size(r,2)) then
       call set_error(2, info, error); return
    else if (n /= size(u1) .or. n /= size(v1) .or. n /= size(res)) then
       call set_error(3, info, error); return
    end if

    maxr=maxabs(r)
    maxit=equals_option(default_maxit,maxit0)
    tolres=equals_option(maxr*default_tolres,tolres0)

    u1=(0.0_dp,0.0_dp)
    v1=(0.0_dp,0.0_dp)
    if (maxr==0.0_dp) then
       u1(1)=(1.0_dp,0.0_dp); v1(1)=(1.0_dp,0.0_dp)
       sigmau=0.0_dp
       res=(0.0_dp,0.0_dp)
       call pop_id(error)
       return
    else
       ! Get initial vectors.
       call upper_tr_left_multiply_linpack(r,u1,v1)
       sigmau=norm2(v1)
       v1=v1/sigmau
       sigmav=norm2(u1) ! not really sigmav.
       sigmau=sigmau/sigmav
       u1=u1/sigmav
       k=1
       do while (k < maxit)
          ! Update u1
          res=u1; sigmau0=sigmau
          call upper_left_multiply(r,v1,u1)
          sigmav=norm2(u1)
          u1=u1/sigmav
          ! Update v1
          call upper_tr_left_multiply(r,u1,v1)
          sigmau=norm2(v1)
          v1=v1/sigmau
          res = u1*sigmav-res*sigmau0
          if (norm2(res) < tolres) then
             call pop_id(error)
             return
          end if
          k=k+1
       end do
       if (tolres==0.0_dp) then
          ! maxits is OK if tolerance is zero.
          call pop_id(error)
       else
          call set_error(4, info, error); return
       end if
    end if
  end function z_upper_max_sv

  real(kind=dp) function d_upper_min_sv(r,un,vn,res,tolres0, &
       maxit0,error) result(sigmau)
    real(kind=dp), dimension(:,:), intent(in) :: r
    real(kind=dp), dimension(:), intent(out) :: un,vn,res
    real(kind=dp), intent(in), optional :: tolres0
    type(error_info), intent(inout), optional :: error
    integer(kind=int32), intent(in), optional :: maxit0

    integer(kind=int32) :: n, k, maxit, p, q
    real(kind=dp) :: tolres, sigmav, maxr
    type(routine_info), parameter :: info=info_d_upper_min_sv
    !
    sigmau=0.0_dp
    if (failure(error)) return
    call push_id(info, error)

    n=size(r,1)
    if (n<1) then
       call set_error(1, info, error); return
    else if (n /= size(r,2)) then
       call set_error(2, info, error); return
    else if (n /= size(un) .or. n /= size(vn) .or. n /= size(res)) then
       call set_error(3, info, error); return
    end if

    maxr=maxabs(r)
    maxit=equals_option(default_maxit,maxit0)
    tolres=equals_option(maxr*default_tolres,tolres0)

    un=0.0_dp
    vn=0.0_dp
    if (maxr==0.0_dp) then
       un(1)=1.0_dp; vn(1)=1.0_dp
       sigmau=0.0_dp
       res=0.0_dp
       call pop_id(error)
       return
    else
       ! treat very small diagonal elements as hard zeros.
       p=first_zero_diagonal(r, maxr*eps*eps)
       q=reverse_first_zero_diagonal(r, maxr*eps*eps)
       if (p<=n .or. q >= 1) then
          vn(p)=1.0_dp
          un(q)=1.0_dp
          if (p > 1) call upper_left_invert(r(1:p-1,1:p-1),vn(1:p-1),-r(1:p-1,p))
          if (q < n) call upper_right_invert(un(q+1:n),r(q+1:n,q+1:n),-r(q,q+1:n))
          ! un=conjg(un)
          un=un/norm2(un); vn=vn/norm2(vn)
          sigmau=0.0_dp
          ! Residual is R*vn-sigma*un or just R*vn
          res=0.0_dp
          call upper_left_multiply(r(1:p,1:p),vn(1:p),res(1:p))
          call pop_id(error); return
       else
          ! Get initial vectors.
          call upper_tr_left_invert_linpack(r,un,vn)
          sigmau=1/norm2(un)
          un=sigmau*un
          sigmau=sigmau*norm2(vn)
          k=1
          do while (k < maxit)
             ! Update v
             call upper_left_invert(r,vn,un)
             sigmav=1/norm2(vn)
             vn=sigmav*vn
             ! Update un
             res=un
             call upper_tr_left_invert(r,un,vn)
             sigmau=1/norm2(un)
             un=sigmau*un
             res=res*sigmav - un*sigmau
             if (norm2(res) < tolres) then
                call pop_id(error)
                return
             end if
             k=k+1
          end do
          if (tolres==0.0_dp) then
             ! maxits is OK if tolerance is zero.
             call pop_id(error)
          else
             call set_error(4, info, error); return
          end if
       end if
    end if
  end function d_upper_min_sv

  real(kind=dp) function z_upper_min_sv(r,un,vn,res,tolres0, &
       maxit0,error) result(sigmau)
    complex(kind=dp), dimension(:,:), intent(in) :: r
    complex(kind=dp), dimension(:), intent(out) :: un,vn,res
    real(kind=dp), intent(in), optional :: tolres0
    type(error_info), intent(inout), optional :: error
    integer(kind=int32), intent(in), optional :: maxit0

    integer(kind=int32) :: n, k, maxit, p, q
    real(kind=dp) :: tolres, sigmav, maxr
    type(routine_info), parameter :: info=info_z_upper_min_sv
    !
    sigmau=0.0_dp
    if (failure(error)) return
    call push_id(info, error)

    n=size(r,1)
    if (n<1) then
       call set_error(1, info, error); return
    else if (n /= size(r,2)) then
       call set_error(2, info, error); return
    else if (n /= size(un) .or. n /= size(vn) .or. n /= size(res)) then
       call set_error(3, info, error); return
    end if

    maxr=maxabs(r)
    maxit=equals_option(default_maxit,maxit0)
    tolres=equals_option(maxr*default_tolres,tolres0)

    un=(0.0_dp,0.0_dp)
    vn=(0.0_dp,0.0_dp)
    if (maxr==0.0_dp) then
       un(1)=(1.0_dp,0.0_dp); vn(1)=(1.0_dp,0.0_dp)
       sigmau=0.0_dp
       res=(0.0_dp,0.0_dp)
       call pop_id(error)
       return
    else
       ! treat very small diagonal elements as hard zeros.
       p=first_zero_diagonal(r, maxr*eps*eps)
       q=reverse_first_zero_diagonal(r, maxr*eps*eps)
       if (p<=n .or. q >= 1) then
          vn(p)=(1.0_dp,0.0_dp)
          un(q)=(1.0_dp,0.0_dp)
          if (p > 1) call upper_left_invert(r(1:p-1,1:p-1),vn(1:p-1),-r(1:p-1,p))
          if (q < n) call upper_right_invert(un(q+1:n),r(q+1:n,q+1:n),-r(q,q+1:n))
          un=conjg(un)
          un=un/norm2(un); vn=vn/norm2(vn)
          sigmau=0.0_dp
          ! Residual is R*vn-sigma*un or just R*vn
          res=(0.0_dp,0.0_dp)
          call upper_left_multiply(r(1:p,1:p),vn(1:p),res(1:p))
          call pop_id(error); return
       else
          ! Get initial vectors.
          call upper_tr_left_invert_linpack(r,un,vn)
          sigmau=1/norm2(un)
          un=sigmau*un
          sigmau=sigmau*norm2(vn)
          k=1
          do while (k < maxit)
             ! Update v
             call upper_left_invert(r,vn,un)
             sigmav=1/norm2(vn)
             vn=sigmav*vn
             ! Update un
             res=un
             call upper_tr_left_invert(r,un,vn)
             sigmau=1/norm2(un)
             un=sigmau*un
             res=res*sigmav - un*sigmau
             if (norm2(res) < tolres) then
                call pop_id(error)
                return
             end if
             k=k+1
          end do
          if (tolres==0.0_dp) then
             ! maxits is OK if tolerance is zero.
             call pop_id(error)
          else
             call set_error(4, info, error); return
          end if
       end if
    end if
  end function z_upper_min_sv

  real(kind=dp) function d_lower_max_sv(l,u1,v1,res,tolres0, &
       maxit0,error) result(sigmau)
    real(kind=dp), dimension(:,:), intent(in) :: l
    real(kind=dp), dimension(:), intent(out) :: u1,v1,res
    real(kind=dp), intent(in), optional :: tolres0
    type(error_info), intent(inout), optional :: error
    integer(kind=int32), intent(in), optional :: maxit0

    integer(kind=int32) :: n, k, maxit
    real(kind=dp) :: tolres, sigmav, sigmau0, maxl
    type(routine_info), parameter :: info=info_d_lower_max_sv
    !
    sigmau=0.0_dp
    if (failure(error)) return
    call push_id(info, error)

    n=size(l,1)
    if (n<1) then
       call set_error(1, info, error); return
    else if (n /= size(l,2)) then
       call set_error(2, info, error); return
    else if (n /= size(u1) .or. n /= size(v1) .or. n /= size(res)) then
       call set_error(3, info, error); return
    end if

    maxl=maxabs(l)
    maxit=equals_option(default_maxit,maxit0)
    tolres=equals_option(maxl*default_tolres,tolres0)

    u1=0.0_dp
    v1=0.0_dp
    if (maxl==0.0_dp) then
       u1(1)=1.0_dp; v1(1)=1.0_dp
       sigmau=0.0_dp
       res=0.0_dp
       call pop_id(error)
       return
    else
       ! Get initial vectors.
       call lower_tr_left_multiply_linpack(l,u1,v1)
       sigmau=norm2(v1)
       v1=v1/sigmau
       sigmav=norm2(u1) ! not really sigmav.
       sigmau=sigmau/sigmav
       u1=u1/sigmav
       k=1
       do while (k < maxit)
          ! Update u1
          res=u1; sigmau0=sigmau
          call lower_left_multiply(l,v1,u1)
          sigmav=norm2(u1)
          u1=u1/sigmav
          ! Update v1
          call lower_tr_left_multiply(l,u1,v1)
          sigmau=norm2(v1)
          v1=v1/sigmau
          res = u1*sigmav-res*sigmau0
          if (norm2(res) < tolres) then
             call pop_id(error)
             return
          end if
          k=k+1
       end do
       if (tolres==0.0_dp) then
          ! maxits is OK if tolerance is zero.
          call pop_id(error)
       else
          call set_error(4, info, error); return
       end if
    end if
  end function d_lower_max_sv

  real(kind=dp) function z_lower_max_sv(l,u1,v1,res,tolres0, &
       maxit0,error) result(sigmau)
    complex(kind=dp), dimension(:,:), intent(in) :: l
    complex(kind=dp), dimension(:), intent(out) :: u1,v1,res
    real(kind=dp), intent(in), optional :: tolres0
    type(error_info), intent(inout), optional :: error
    integer(kind=int32), intent(in), optional :: maxit0

    integer(kind=int32) :: n, k, maxit
    real(kind=dp) :: tolres, sigmav, sigmau0, maxl
    type(routine_info), parameter :: info=info_z_lower_max_sv
    !
    sigmau=0.0_dp
    if (failure(error)) return
    call push_id(info, error)

    n=size(l,1)
    if (n<1) then
       call set_error(1, info, error); return
    else if (n /= size(l,2)) then
       call set_error(2, info, error); return
    else if (n /= size(u1) .or. n /= size(v1) .or. n /= size(res)) then
       call set_error(3, info, error); return
    end if

    maxl=maxabs(l)
    maxit=equals_option(default_maxit,maxit0)
    tolres=equals_option(maxl*default_tolres,tolres0)

    u1=(0.0_dp,0.0_dp)
    v1=(0.0_dp,0.0_dp)
    if (maxl==0.0_dp) then
       u1(1)=(1.0_dp,0.0_dp); v1(1)=(1.0_dp,0.0_dp)
       sigmau=0.0_dp
       res=(0.0_dp,0.0_dp)
       call pop_id(error)
       return
    else
       ! Get initial vectors.
       call lower_tr_left_multiply_linpack(l,u1,v1)
       sigmau=norm2(v1)
       v1=v1/sigmau
       sigmav=norm2(u1) ! not really sigmav.
       sigmau=sigmau/sigmav
       u1=u1/sigmav
       k=1
       do while (k < maxit)
          ! Update u1
          res=u1; sigmau0=sigmau
          call lower_left_multiply(l,v1,u1)
          sigmav=norm2(u1)
          u1=u1/sigmav
          ! Update v1
          call lower_tr_left_multiply(l,u1,v1)
          sigmau=norm2(v1)
          v1=v1/sigmau
          res = u1*sigmav-res*sigmau0
          if (norm2(res) < tolres) then
             call pop_id(error)
             return
          end if
          k=k+1
       end do
       if (tolres==0.0_dp) then
          ! maxits is OK if tolerance is zero.
          call pop_id(error)
       else
          call set_error(4, info, error); return
       end if
    end if
  end function z_lower_max_sv

  real(kind=dp) function d_lower_min_sv(l,un,vn,res,tolres0, &
       maxit0,error) result(sigmau)
    real(kind=dp), dimension(:,:), intent(in) :: l
    real(kind=dp), dimension(:), intent(out) :: un,vn,res
    real(kind=dp), intent(in), optional :: tolres0
    type(error_info), intent(inout), optional :: error
    integer(kind=int32), intent(in), optional :: maxit0

    integer(kind=int32) :: n, k, maxit, p, q
    real(kind=dp) :: tolres, sigmav, maxl
    type(routine_info), parameter :: info=info_d_lower_min_sv
    !
    sigmau=0.0_dp
    if (failure(error)) return
    call push_id(info, error)

    n=size(l,1)
    if (n<1) then
       call set_error(1, info, error); return
    else if (n /= size(l,2)) then
       call set_error(2, info, error); return
    else if (n /= size(un) .or. n /= size(vn) .or. n /= size(res)) then
       call set_error(3, info, error); return
    end if

    maxl=maxabs(l)
    maxit=equals_option(default_maxit,maxit0)
    tolres=equals_option(maxl*default_tolres,tolres0)

    un=0.0_dp
    vn=0.0_dp
    if (maxl==0.0_dp) then
       un(1)=1.0_dp; vn(1)=1.0_dp
       sigmau=0.0_dp
       res=0.0_dp
       call pop_id(error)
       return
    else
       ! treat very small diagonal elements as hard zeros.
       p=first_zero_diagonal(l, maxl*eps*eps)
       q=reverse_first_zero_diagonal(l, maxl*eps*eps)
       if (p<=n .or. q >= 1) then
          un(p)=1.0_dp
          vn(q)=1.0_dp
          if (p > 1) call lower_right_invert(un(1:p-1),l(1:p-1,1:p-1),-l(p,1:p-1))
          if (q < n) call lower_left_invert(l(q+1:n, q+1:n), vn(q+1:n), -l(q+1:n,q))
          un=un/norm2(un); vn=vn/norm2(vn)
          sigmau=0.0_dp
          ! Residual is L*vn-sigma*un or just L*vn
          res=0.0_dp
          call lower_left_multiply(l(q:n,q:n),vn(q:n),res(q:n))
          call pop_id(error); return
       else
          ! Get initial vectors.
          call lower_tr_left_invert_linpack(l,un,vn)
          sigmau=1/norm2(un)
          un=sigmau*un
          sigmau=sigmau*norm2(vn)
          k=1
          do while (k < maxit)
             ! Update v
             call lower_left_invert(l,vn,un)
             sigmav=1/norm2(vn)
             vn=sigmav*vn
             ! Update un
             res=un
             call lower_tr_left_invert(l,un,vn)
             sigmau=1/norm2(un)
             un=sigmau*un
             res=res*sigmav - un*sigmau
             if (norm2(res) < tolres) then
                call pop_id(error)
                return
             end if
             k=k+1
          end do
          if (tolres==0.0_dp) then
             ! maxits is OK if tolerance is zero.
             call pop_id(error)
          else
             call set_error(4, info, error); return
          end if
       end if
    end if
  end function d_lower_min_sv

  real(kind=dp) function z_lower_min_sv(l,un,vn,res,tolres0, &
       maxit0,error) result(sigmau)
    complex(kind=dp), dimension(:,:), intent(in) :: l
    complex(kind=dp), dimension(:), intent(out) :: un,vn,res
    real(kind=dp), intent(in), optional :: tolres0
    type(error_info), intent(inout), optional :: error
    integer(kind=int32), intent(in), optional :: maxit0

    integer(kind=int32) :: n, k, maxit, p, q
    real(kind=dp) :: tolres, sigmav, maxl
    type(routine_info), parameter :: info=info_z_lower_min_sv
    !
    sigmau=0.0_dp
    if (failure(error)) return
    call push_id(info, error)

    n=size(l,1)
    if (n<1) then
       call set_error(1, info, error); return
    else if (n /= size(l,2)) then
       call set_error(2, info, error); return
    else if (n /= size(un) .or. n /= size(vn) .or. n /= size(res)) then
       call set_error(3, info, error); return
    end if

    maxl=maxabs(l)
    maxit=equals_option(default_maxit,maxit0)
    tolres=equals_option(maxl*default_tolres,tolres0)

    un=(0.0_dp,0.0_dp)
    vn=(0.0_dp,0.0_dp)
    if (maxl==0.0_dp) then
       un(1)=(1.0_dp,0.0_dp); vn(1)=(1.0_dp,0.0_dp)
       sigmau=0.0_dp
       res=(0.0_dp,0.0_dp)
       call pop_id(error)
       return
    else
       ! treat very small diagonal elements as hard zeros.
       p=first_zero_diagonal(l, maxl*eps*eps)
       q=reverse_first_zero_diagonal(l, maxl*eps*eps)
       if (p<=n .or. q >= 1) then
          un(p)=(1.0_dp,0.0_dp)
          vn(q)=(1.0_dp,0.0_dp)
          if (p > 1) call lower_right_invert(un(1:p-1),l(1:p-1,1:p-1),-l(p,1:p-1))
          if (q < n) call lower_left_invert(l(q+1:n, q+1:n), vn(q+1:n), -l(q+1:n,q))
          un=conjg(un)
          un=un/norm2(un); vn=vn/norm2(vn)
          sigmau=0.0_dp
          ! Residual is L*v-sigma*u or just L*v
          res=(0.0_dp,0.0_dp)
          call lower_left_multiply(l(q:n,q:n),vn(q:n),res(q:n))
          call pop_id(error); return
       else
          ! Get initial vectors.
          call lower_tr_left_invert_linpack(l,un,vn)
          sigmau=1/norm2(un)
          un=sigmau*un
          sigmau=sigmau*norm2(vn)
          k=1
          do while (k < maxit)
             ! Update vn
             call lower_left_invert(l,vn,un)
             sigmav=1/norm2(vn)
             vn=sigmav*vn
             ! Update un
             res=un
             call lower_tr_left_invert(l,un,vn)
             sigmau=1/norm2(un)
             un=sigmau*un
             res=res*sigmav - un*sigmau
             if (norm2(res) < tolres) then
                call pop_id(error)
                return
             end if
             k=k+1
          end do
          if (tolres==0.0_dp) then
             ! maxits shouldn't raise an error if the tolerance is zero.
             call pop_id(error)
          else
             call set_error(4, info, error); return
          end if
       end if
    end if
  end function z_lower_min_sv

  ! null vector of a lower triangular matrix.
  ! error: 1 no null vector within tolerance
  ! p returns a value such that x(p+1:n)=0
  ! If tol=0.0_dp, just do maxits iterations.
  subroutine d_lower_left_nullvec(x,l,tol,maxit, p, error)
    real(kind=dp), dimension(:,:), intent(in) :: l
    real(kind=dp), dimension(:), intent(out) :: x
    real(kind=dp), intent(in) :: tol
    type(error_info), intent(inout), optional :: error
    integer(kind=int32), intent(in) :: maxit
    integer(kind=int32), intent(out) :: p

    integer(kind=int32) :: n, k
    real(kind=dp) :: nrmx
    real(kind=dp), dimension(size(x)) :: y
    type(routine_info), parameter :: info=info_d_lower_left_nullvec
    !
    if (failure(error)) return
    call push_id(info, error)

    n=size(l,1)
    x=0.0_dp
    y=0.0_dp
    p=first_zero_diagonal(l, tol)
    If (p==1) then
       x(1)=1.0_dp
       call pop_id(error); return
    else if (p <= n) then
       ! if a small enough diagonal element is found, solve
       ! for a null vector directly.
       x(p)=1.0_dp
       call lower_right_invert(x(1:p-1),l(1:p-1, 1:p-1), -l(p,1:p-1))
       call pop_id(error); return
    else
       ! Otherwise use the Linpack condition estimator approach.
       p=n
       call lower_right_invert_linpack(x,l,y)
       nrmx=norm2(x)
       x=x/nrmx
       nrmx=nrmx/norm2(y)
       k=1
       do while (k < maxit)
          if (1/nrmx < tol) then
             call pop_id(error)
             return
          end if
          call lower_tr_right_invert(y,l,x)
          y=y/norm2(y)
          call lower_right_invert(x,l,y)
          nrmx=norm2(x)
          x=x/nrmx
          k=k+1
       end do
       if (tol==0.0_dp) then
          call pop_id(error)
       else
          call set_error(1, info, error); return
       end if
    end if
  end subroutine d_lower_left_nullvec

  ! null vector of a lower triangular matrix.
  subroutine z_lower_left_nullvec(x,l,tol,maxit,p, error)
    complex(kind=dp), dimension(:,:), intent(in) :: l
    complex(kind=dp), dimension(:), intent(out) :: x
    real(kind=dp), intent(in) :: tol
    type(error_info), intent(inout), optional :: error
    integer(kind=int32), intent(in) :: maxit
    integer(kind=int32), intent(out) :: p
    !
    integer(kind=int32) :: n, k
    real(kind=dp) :: nrmx
    complex(kind=dp), dimension(size(x)) :: y
    type(routine_info), parameter :: info=info_z_lower_left_nullvec
    !
    n=size(l,1)
    if (failure(error)) return
    call push_id(info, error)

    x=(0.0_dp, 0.0_dp)
    y=(0.0_dp, 0.0_dp)
    p=first_zero_diagonal(l, tol)
    if (p==1) then
       x(p)=(1.0_dp, 0.0_dp)
       call pop_id(error); return
    else if (p <= n) then
       ! if a small enough diagonal element is found, solve
       ! for a null vector directly.
       x(p)=(1.0_dp, 0.0_dp)
       call lower_right_invert(x(1:p-1),l(1:p-1, 1:p-1), -l(p,1:p-1))
       call pop_id(error); return
    else
       ! Otherwise use the Linpack condition estimator.
       p=n
       call lower_right_invert_linpack(x,l,y)
       nrmx=norm2(x)
       x=x/nrmx
       nrmx=nrmx/norm2(y)
       k=1
       do while (k < maxit)
          if (1/nrmx < tol) then
             call pop_id(error)
             return
          end if
          call lower_tr_right_invert(y,l,x)
          y=y/norm2(y)
          call lower_right_invert(x,l,y)
          nrmx=norm2(x)
          x=x/nrmx
          k=k+1
       end do
       if (tol==0.0_dp) then
          call pop_id(error)
       else
          call set_error(1, info, error); return
       end if
    end if
  end subroutine z_lower_left_nullvec

  ! right null vector of a lower triangular matrix.
  ! Returns p such that x(1:p-1)=0
  subroutine d_lower_right_nullvec(x,l,tol,maxit, p, error)
    real(kind=dp), dimension(:,:), intent(in) :: l
    real(kind=dp), dimension(:), intent(out) :: x
    real(kind=dp), intent(in) :: tol
    type(error_info), intent(inout), optional :: error
    integer(kind=int32), intent(in) :: maxit
    integer(kind=int32), intent(out) :: p
    !
    integer(kind=int32) :: n, k
    real(kind=dp) :: nrmx
    real(kind=dp), dimension(size(x)) :: y
    type(routine_info), parameter :: info=info_d_lower_right_nullvec
    !
    n=size(l,1)
    if (failure(error)) return
    call push_id(info, error)
    x=0.0_dp
    y=0.0_dp
    p=reverse_first_zero_diagonal(l, tol)
    if (p==n) then
       x(n)=1.0_dp
       call pop_id(error); return
    else if (p >= 1) then
       ! if a small enough diagonal element is found, solve
       ! for a null vector directly.
       x(p)=1.0_dp
       call lower_left_invert(l(p+1:n,p+1:n),x(p+1:n),-l(p+1:n,p))
       call pop_id(error); return
    else
       ! Otherwise use the Linpack condition estimator approach.
       p=1
       call lower_left_invert_linpack(l,x,y)
       nrmx=norm2(x)
       x=x/nrmx
       nrmx=nrmx/norm2(y)
       k=1
       do while (k < maxit)
          if (1/nrmx < tol) then
             call pop_id(error); return
          end if
          call lower_tr_left_invert(l,y,x)
          y=y/norm2(y)
          call lower_left_invert(l,x,y)
          nrmx=norm2(x)
          x=x/nrmx
          k=k+1
       end do
       if (tol==0.0_dp) then
          call pop_id(error)
       else
          call set_error(1, info, error); return
       end if
    end if
  end subroutine d_lower_right_nullvec

  ! right null vector of a lower triangular matrix.
  subroutine z_lower_right_nullvec(x, l, tol, maxit, p, error)
    complex(kind=dp), dimension(:,:), intent(in) :: l
    complex(kind=dp), dimension(:), intent(out) :: x
    real(kind=dp), intent(in) :: tol
    type(error_info), intent(inout), optional :: error
    integer(kind=int32), intent(in) :: maxit
    integer(kind=int32), intent(out) :: p
    !
    integer(kind=int32) :: n, k
    real(kind=dp) :: nrmx
    complex(kind=dp), dimension(size(x)) :: y
    type(routine_info), parameter :: info=info_z_lower_right_nullvec
    !
    n=size(l,1)
    if (failure(error)) return
    call push_id(info, error)
    x=(0.0_dp, 0.0_dp)
    y=(0.0_dp, 0.0_dp)
    p=reverse_first_zero_diagonal(l, tol)
    if (p==n) then
       x(n)=(1.0_dp, 0.0_dp)
       call pop_id(error); return
    else if (p >= 1) then
       ! if a small enough diagonal element is found, solve
       ! for a null vector directly.
       x(p)=(1.0_dp, 0.0_dp)
       call lower_left_invert(l(p+1:n,p+1:n),x(p+1:n),-l(p+1:n,p))
       call pop_id(error); return
    else
       ! Otherwise use the Linpack condition estimator approach.
       p=1
       call lower_left_invert_linpack(l,x,y)
       nrmx=norm2(x)
       x=x/nrmx
       nrmx=nrmx/norm2(y)
       k=1
       do while (k < maxit)
          if (1/nrmx < tol) then
             call pop_id(error)
             return
          end if
          call lower_tr_left_invert(l,y,x)
          y=y/norm2(y)
          call lower_left_invert(l,x,y)
          nrmx=norm2(x)
          x=x/nrmx
          k=k+1
       end do
       if (tol==0.0_dp) then
          call pop_id(error)
       else
          call set_error(1, info, error); return
       end if
    end if
  end subroutine z_lower_right_nullvec

end module mod_cond_triangular


	program fft_test
c	test the execution speed of FFT
c	Note: dtime is a bsd call used to get the timings

	parameter (nsize=256*256)
	complex a(nsize),s(512*3)
	dimension is(512),m(3)
	integer wm(4*256+20),wn(4*256+20)
	real*4 timer(2),aa(2*nsize)
	ntimes=10
c	256x256 sizes for harm
	m(1)=8
	m(2)=8
	m(3)=0
c	setup tables
	ifset=0
	do j=1,nsize
		a(j)=0.1d0*cos(j*0.01)*sin(j*0.1)*sin(j*0.0333)
	enddo
	call harm(a,m,is,s,ifset,iferr)
c	initialize timer
	err=dtime(timer)
	do j=1,ntimes
	ifset=-2
	call harm(a,m,is,s,ifset,iferr)
	ifset=2
	call harm(a,m,is,s,ifset,iferr)
	enddo
	err=dtime(timer)
	call tprint(timer,'harm, 256x256',ntimes)

c	Now do the same for C2FFT
	do j=1,nsize
		a(j)=0.1d0*cos(j*0.01)*sin(j*0.1)*sin(j*0.0333)
	enddo
	id=256
	nm=256
	nn=256
	ISIG=0
	iord=1
	call C2FFT(A,ID,NM,NN,WM,WN,ISIG,IORD,IS,IERR)
	if(ierr.ne.0)then
		write(6,*)'Error Code ',ierr,' in C2FFT'
		stop
		endif
c	initialize timer
	err=dtime(timer)
	do j=1,ntimes
	ISIG=-1
	call C2FFT(A,ID,NM,NN,WM,WN,ISIG,IORD,IS,IERR)
	if(ierr.ne.0)then
		write(6,*)'Error Code ',ierr,' in C2FFT'
		stop
		endif
	isig=1
c	normalize
	do k=1,nm*nn
		a(k)=a(k)/(nm*nn)
		enddo
	enddo
	call C2FFT(A,ID,NM,NN,WM,WN,ISIG,IORD,IS,IERR)
	if(ierr.ne.0)then
		write(6,*)'Error Code ',ierr,' in C2FFT'
		stop
		endif
	err=dtime(timer)
	call tprint(timer,'C2FFT 256x256',ntimes)

c	setup tables
	ifset=0
	do j=1,nsize,2
		aa(j)=0.1d0*cos(j*0.01)*sin(j*0.1)*sin(j*0.0333)
		aa(j+1)=0.0d0
	enddo
	id=256
	nm=256
	nn=256
c	initialize timer
	err=dtime(timer)
	do j=1,ntimes
c	back
        call fft(aa(1),aa(2),nn*nm,nn,nn,-2)
        call fft(aa(1),aa(2),nn*nm,nn,nn*nm,-2)
c	forward
	do k=1,nm*nn*2
		aa(k)=aa(k)/(nm*nn)
		enddo
	enddo
        call fft(aa(1),aa(2),nn*nm,nn,nn,2)
        call fft(aa(1),aa(2),nn*nm,nn,nn*nm,2)
	err=dtime(timer)
	call tprint(timer,'fft 256x256',ntimes)

c	Now repeat with a size of 250x250
	do j=1,nsize
		a(j)=0.1d0*cos(j*0.01)*sin(j*0.1)*sin(j*0.0333)
	enddo
	id=250
	nm=250
	nn=250
	ISIG=0
	iord=1
	call C2FFT(A,ID,NM,NN,WM,WN,ISIG,IORD,IS,IERR)
	if(ierr.ne.0)then
		write(6,*)'Error Code ',ierr,' in C2FFT'
		stop
		endif
c	initialize timer
	err=dtime(timer)
	do j=1,ntimes
	ISIG=-1
	call C2FFT(A,ID,NM,NN,WM,WN,ISIG,IORD,IS,IERR)
	if(ierr.ne.0)then
		write(6,*)'Error Code ',ierr,' in C2FFT'
		stop
		endif
	isig=1
c	normalize
	do k=1,nm*nn
		a(k)=a(k)/(nm*nn)
		enddo
	enddo
	call C2FFT(A,ID,NM,NN,WM,WN,ISIG,IORD,IS,IERR)
	if(ierr.ne.0)then
		write(6,*)'Error Code ',ierr,' in C2FFT'
		stop
		endif
	err=dtime(timer)
	call tprint(timer,'C2FFT 250x250',ntimes)

c	setup tables
	ifset=0
	do j=1,nsize,2
		aa(j)=0.1d0*cos(j*0.01)*sin(j*0.1)*sin(j*0.0333)
		aa(j+1)=0.0d0
	enddo
	nm=250
	nn=250
c	initialize timer
	err=dtime(timer)
	do j=1,ntimes
c	back
        call fft(aa(1),aa(2),nn*nm,nn,nn,-2)
        call fft(aa(1),aa(2),nn*nm,nn,nn*nm,-2)
c	normalize
	do k=1,nm*nn*2
		aa(k)=aa(k)/(nm*nn)
		enddo
c	forward
        call fft(aa(1),aa(2),nn*nm,nn,nn,2)
        call fft(aa(1),aa(2),nn*nm,nn,nn*nm,2)
	enddo
	err=dtime(timer)
	call tprint(timer,'fft 250x250',ntimes)
	end

	subroutine tprint(timer,label,ntimes)
	character*(*) label
	real*4 timer(2)
	write(6,*)
	write(6,*)'Timing for routine ',label
	write(6,*)'Total User time:',timer(1)
	write(6,*)'Total System time:',timer(2)
	timer(1)=timer(1)/dble(ntimes*2)
	timer(2)=timer(2)/dble(ntimes*2)
	write(6,*)'User time per FFT:',timer(1)
	write(6,*)'System time per FFT:',timer(2)
	return
	end


      module material_behavior

      use linearsolvers

!     =========================element center point
      real*8 :: el_center_coord(dimen)
      real*8 :: qtransform(dimen,dimen) ! this is the transformtion matrix
!     ================================================================
!                      history variables
!     ================================================================
!      real*8,allocatable::gauss_coords(:,:) !gauss_coords(igauss,dimen)
      real*8,allocatable::ele_pol_vector(:,:)  !gauss_coords(ele,dimen)
!      real*8,allocatable::shape_function_weight(:,:) ! shape_function_weight(nem,igauss_element)
!     ================================================================
!                      history variables
!     ================================================================
      real*8,allocatable::q_t(:),q_t_p(:),q_t_b(:)
      real*8,allocatable::                      &
        q_sigma_c_t(:,:,:),q_sigma_e_t(:,:,:),  &
        q_sigma_c_p(:,:,:),q_sigma_e_p(:,:,:),   &
        q_sigma_c_b(:,:,:),q_sigma_e_b(:,:,:),    &
        q_d_e_t(:,:),q_d_k_t(:,:),                 &
        q_d_e_p(:,:),q_d_k_p(:,:),                  &
        q_d_e_b(:,:),q_d_k_b(:,:)
!     ================================================================
!                      polarization history variables
!     ================================================================
      real*8,allocatable::      &
        q_rempol_t(:,:),         &
        q_rempol_p(:,:),          &
        q_rempol_b(:,:)

!     =======================mechanical properties variables
      real*8::cmate_voight(9,9)
      real*8::ctens(3,3,3,3)
      real*8::ctenst(3,3,3,3)
      real*8::cmat_voight(6,6)
      real*8::stense(3,3,3,3)
      real*8::e1,e2,e3,nu12,nu13,nu23,g12,g13,g23
      real*8::lambda,nu,mu,kbulk
!     =======================electric variables
      real*8,parameter::eps_vac_permit=8.58e-12
      real*8::epz(3,3,3)
      real*8,dimension(3,3)::ktense,ktense_trans
      real*8::ktense_inv(3,3) !the material matrix
      real*8::xeta(3,3,3)! the non linear electric permibility tensor

!     ===========================materials tensors
      real*8,dimension(3,3,3):: epz_t,epz_trans,epz_nl !the electro coupling tensor
      real*8,dimension(3,3,3,3)      :: b_tilt,b_tilt_trans ! the nonlinear electro coupling tensor

!     ===================================remanent polarization
      real*8,dimension(dimen):: rem_pol_t,drem_pol_t
      real*8,dimension(dimen):: rem_pol_p,drem_pol_p
      real*8,dimension(dimen):: rem_pol_b
!     ================================================================
!                      polarization history variables local
!     ================================================================
      real*8,dimension(dimen)::  &
        q_rempol_t_local,        &
        q_rempol_p_local,        &
        q_rempol_b_local
!     =======================polarization switching variables
      real*8::e_coercive ! coercive field
      integer::ipol
      real*8::p_per_sat
      real*8::pol_rate
      real*8::der_total(3)
!     ================================================================
!                      time variables
!     ================================================================
      real*8::time(2),dtime
      integer::ntime,itime  ! time
!     ================================================================
      integer::noelem
!     ================================================================
!     ================================================================
!     ================================================================
!     ================================================================
!     ================================================================
      contains

      subroutine material_properties()
      implicit none
!     ================================================================
!                      material variables
!     ================================================================

!     ================================================================
      integer::eye(dimen,dimen)
      integer::i,j,k,l,m,n

!     =======================polarization switching variables
      real*8 ::ecoup_norma
      real*8 ::ecoup_perpe
      real*8 ::ecoup_shear
!     =======================electric polarization (displacement in refrence confiquaration)
      real*8 :: polarization_vec(dimen)
      real*8 :: der_total(dimen),pol(3)
      real*8 :: der_unit(3)
      real*8,dimension(dimen)::  elr_t,elr_p,elr_b
      real*8 :: alpha_de(3,3)
      real*8 :: pol_intesity ,sat_pol
      real*8 :: kappa_0
!     ================================================================
      real*8::ey
      real*8::k00,k01,labda01
      real*8::labda_e_01,k_e_00,k_e_01
      real*8::labda_k_01,k_k_00,k_k_01
      common/visco_elastic/k00,k01,labda01,            &
                          k_e_00,k_e_01,labda_e_01,     &
                          k_k_00,k_k_01,labda_k_01
!     ================================================================
      eye = 0.0; do i = 1,dimen; eye(i,i) = 1;enddo

!      e_coercive=0.67e6  ![v/m] coercive field
!      pol_rate=5.4   !remnant polarization rate
!      p_per_sat= 0.26 ! [c/m^2]
!      kappa_0=0.04e-6
!!
!      e1= 6.06e10; ; ![pa]
!      nu23=0.3;
!     ==============================general polarization
      pol_intesity=norm_vect(polarization_vec);

      e1= 1 ![n/m^2] pzt 5a;
!      e1= 62e9 ![n/m^2] pzt 5a;
      nu23=0.3;

      ktense=0.0d0
      ktense(1,1)=(4.0d0)*1e-9;
      ktense(2,2)=ktense(1,1)
      ktense(3,3)=ktense(1,1)/2.0;

      ecoup_norma =-44.69;   ![n/(v.m)]
      ecoup_perpe =18.93;    ![n/(v.m)]
      ecoup_shear =-23.27;   ![n/(v.m)]

!      k00=1.0 ; k01=0.0; labda01=0.0
!      k_e_00=1.0 ; k_e_01=1.0; labda_e_01=1.0 ;
!      k_k_00=1.0 ; k_k_01=0.0; labda_k_01=0.0 ;

      e2=e1;e3=e2
      nu13=nu23;nu12=nu13;
      g23 = e1/(1+nu12)/2.0;
      g13 = g23;g12=g23;
      ey=e1
      nu=nu12

      mu=ey/(1+nu)/2.0
      lambda=ey*nu/(1+nu)/(1-2.0*nu)
      kbulk=lambda+2.0*mu/3.0

      der_unit=unit_vect(polarization_vec)
!     ==============================test
       der_unit=0.0d0
       der_unit(1)=1.0d0
!     ==============================
      do i=1,dimen
      do j=1,dimen
      alpha_de(i,j)=eye(i,j)-der_unit(i)*der_unit(j)
      enddo;enddo

      epz=0.0d0
      do i=1,dimen
      do j=1,dimen
      do k=1,dimen
      epz(k,i,j)=ecoup_norma*der_unit(k)*der_unit(i)*der_unit(j)  &
               +ecoup_perpe*der_unit(k)*alpha_de(i,j)             &
               +ecoup_shear*der_unit(i)*alpha_de(j,k)*0.5         &
               +ecoup_shear*der_unit(j)*alpha_de(i,k)*0.5
      enddo;enddo;enddo

     ktense_inv=0.0d0
     forall(k=1:3) ktense_inv(k,k)=1/ktense(k,k)

      xeta=0.0d0;
      b_tilt=0.0d0

      do i=1,dimen;do j=1,dimen;do k=1,dimen;do l=1,dimen
      ctens(i,j,k,l)=lambda*eye(i,j)*eye(k,l)+mu*(eye(i,k)*eye(j,l)+eye(i,l)*eye(j,k))
      enddo;enddo;enddo;enddo

      do i=1,dimen;do j=1,dimen;do k=1,dimen;do l=1,dimen
      stense(i,j,k,l)=(1.0/kbulk/9.0)*eye(i,j)*eye(k,l)+(1/mu/4.0)*(eye(i,k)*eye(j,l)+eye(i,l)*eye(j,k)-(2.0/3.0)*eye(i,j)*eye(k,l))
      enddo;enddo;enddo;enddo
!     ==============================x3 polarized
!     epz=0.0d0
!     epz(3,3,3)=45.744;
!     epz(3,1,1)=-19.375;
!     epz(1,1,3)=23.81
!
!     epz(3,2,2)=epz(3,1,1)
!
!     epz(2,2,3)=epz(1,1,3)
!     epz(1,3,1)=epz(1,1,3)
!     epz(2,3,2)=epz(1,1,3)
!     b_tilt(3,3,3,3)=-3.35e-2;
!     b_tilt(3,3,1,1)=3.35e-2;
!     b_tilt(3,3,2,2)=3.35e-2;
!     ==============================x3 polarized
      ktense=0.0d0
      ktense(1,1)=(4.0d0)*1e-9;
      ktense(2,2)=ktense(1,1)
      ktense(3,3)=ktense(1,1)/2.0;

!      call material_transofrmation_tensor_x2()
!      call tensor_transform_rank_3(qtransform,epz,epz_trans)
!      call tensor_transform_rank_4(qtransform,b_tilt,b_tilt_trans)
!      call tensor_transform_rank_2(qtransform,ktense,ktense_trans)
!
!      epz=epz_trans
!      b_tilt=b_tilt_trans
!      ktense=ktense_trans

      epz_t=0.0;
      epz_nl=0.0;

      do 50 i=1,dimen; do 50 j=1,dimen;do 50 k=1,dimen;do 50 l=1,dimen
      epz_nl(k,i,j)=epz(k,i,j)+0.5*b_tilt(k,l,i,j)*abs(elr_t(l))
50    epz_t(k,i,j)=epz(k,i,j)+b_tilt(k,l,i,j)*abs(elr_t(l))

!    1D formulation
ctens=0; ctens(1,1,1,1)=1;
epz=0; epz(1,1,1)=-1;
ctenst=ctens;
epz_t=epz;
ktense=0.0d0  ;ktense(1,1)=1;

      endsubroutine material_properties

      subroutine  update_history(ngauss,dimen)
      integer::ngauss,dimen

      q_sigma_c_b=q_sigma_c_p;
      q_sigma_c_p=q_sigma_c_t;

      q_sigma_e_b=q_sigma_e_p;
      q_sigma_e_p=q_sigma_e_t;

      q_d_e_b=q_d_e_p
      q_d_e_p=q_d_e_t

      q_d_k_b=q_d_k_p
      q_d_k_p=q_d_k_t

      q_rempol_b=q_rempol_p
      q_rempol_p=q_rempol_t

      endsubroutine  update_history

!     ===============================================================
!           forming history variables
!     ===============================================================
      subroutine  form_history(ngauss,dimen,ipdf,nem)
      integer::ngauss,dimen,ipdf,nem
!     ===================allocate history variables
      allocate(                                                                  &
      q_sigma_c_t(dimen,dimen,ngauss),q_sigma_e_t(dimen,dimen,ngauss),            &
      q_sigma_c_p(dimen,dimen,ngauss),q_sigma_e_p(dimen,dimen,ngauss),            &
      q_sigma_c_b(dimen,dimen,ngauss),q_sigma_e_b(dimen,dimen,ngauss),             &
        q_d_e_t(dimen,ngauss),q_d_k_t(dimen,ngauss),                                &
        q_d_e_p(dimen,ngauss),q_d_k_p(dimen,ngauss),                                 &
        q_d_e_b(dimen,ngauss),q_d_k_b(dimen,ngauss),                                  &
      q_t(ngauss),q_t_p(ngauss),q_t_b(ngauss),                                         &
      q_rempol_t(dimen,ngauss),                                                         &
      q_rempol_p(dimen,ngauss),                                                          &
      q_rempol_b(dimen,ngauss),          &
      ele_pol_vector(nem,dimen))

      q_sigma_c_t=0.0d0;q_sigma_e_t=0.0d0;
      q_sigma_c_p=0.0d0;q_sigma_e_p=0.0d0;
      q_sigma_c_b=0.0d0;q_sigma_e_b=0.0d0;

       q_d_e_t=0.0d0;q_d_k_t=0.0d0;
       q_d_e_p=0.0d0;q_d_k_p=0.0d0;
       q_d_e_b=0.0d0;q_d_k_b=0.0d0;

     q_rempol_t=0.0d0;
     q_rempol_p=0.0d0;
     q_rempol_b=0.0d0;
     ele_pol_vector=0.0d0

      q_t=0.0d0 ; q_t_p=0.0d0; q_t_b=0.0d0

      end subroutine  form_history

subroutine stress_elect_displacement(ur,der,sigma)
!     ================================================================
!                          input variables
!     ================================================================
real*8,intent(in) :: ur(:,:)! global coefficient
!     ================================================================
!                         output variables
!     ================================================================
integer :: i !integer counters
real*8  :: der(:),sigma(:,:)
!     ================================================================
real*8::strain(3,3);
real*8::electric_feild(3);
!     ================================================================
strain=0.0d0;electric_feild=0.0d0;
strain(1:dimen,1:dimen)=0.5d0*(   ur(1:dimen,:)+transpose(ur(1:dimen,:))+      &
                              matmul(  transpose(   ur(1:dimen,:)  ),ur(1:dimen,:))    );

electric_feild(1:dimen)=-ur(dimen+1,:)

!write(1,*)'strain=',strain(1,1)
!write(1,*)'electric_feild=',electric_feild(1)

sigma =  0.0d0 ;
der   =  0.0d0 ;

sigma(1,1)=ctens(1,1,1,1)*strain(1,1)-epz(1,1,1)*electric_feild(1)
der(1)=epz(1,1,1)*strain(1,1)+ktense(1,1)*electric_feild(1)

!write(1,*)'ktense(1,1)=',ktense(1,1)
!write(1,*)'sigma=',sigma(1,1)
!write(1,*)'der=',der(1)

endsubroutine stress_elect_displacement

      end module material_behavior


elemental function pbc(x) result(res)
  !! returns coordinate difference of first minimum image
  real(8)  :: res
  real(8), intent(in) :: x
  res = x - int(2._8*x)
end function pbc

real(8) function dist2_mi_generic(pos,posout, MetricG)
  !! Returns square of the separation between the minimum image of two particles
  !! for a generic (triclinic) box.
  !! `posout` is set to the vector between the images.
  use iso_fortran_env
  implicit none
  real(8),intent(in) :: pos(3)
  real(8),intent(out) :: posout(3)
  real(8),intent(in) :: MetricG(3,3)

  integer :: j

  do j=1,3
     posout(j) = pbc(pos(j))
  end do

  dist2_mi_generic = posout(1)*(posout(1)*MetricG(1,1) + 2*posout(2)*MetricG(2,1)+2*posout(3)*MetricG(3,1))+&
       posout(2)*(posout(2)*MetricG(2,2) + 2*posout(3)*MetricG(3,2))+&
       posout(3)*(posout(3)*MetricG(3,3))

end function dist2_mi_generic

real(8) function dist2_mi_cubic(pos,posout,MetricG)
  !! Returns square of the separation between the minimum image of two particles
  !! for a cubic box.
  !! `posout` is set to the vector between the images.
  implicit none
  real(8),intent(in) :: pos(3)
  real(8),intent(out) :: posout(3)
  real(8),intent(in) :: MetricG(3,3)

  integer :: j

  do j=1,3
     posout(j) = pbc(pos(j))
  end do
  dist2_mi_cubic=posout(1)*posout(1)+posout(2)*posout(2)+posout(3)*posout(3)
  dist2_mi_cubic = dist2_mi_cubic*MetricG(1,1)

end function dist2_mi_cubic

real(8) function dist2_mi_cubicXY(pos,posout,MetricG)
  !! Returns square of the separation between the minimum image of two particles
  !! for a cubic box with periodic boundary conditions only in the XY directions.
  !! `posout` is set to the vector between the images.
  implicit none
  real(8),intent(in) :: pos(3)
  real(8),intent(out) :: posout(3)
  real(8),intent(in) :: MetricG(3,3)
  integer :: j

  do j=1,2
     posout(j) = pbc(pos(j))
  end do

  posout(3)=pos(3)

  dist2_mi_cubicXY=posout(1)*posout(1)+posout(2)*posout(2)+posout(3)*posout(3)
  dist2_mi_cubicXY = dist2_mi_cubicXY*MetricG(1,1)

end function dist2_mi_cubicXY

real(8) function dist2_mi_hexagonal(pos,posout, MetricG)
  !! Returns square of the separation between the minimum image of two particles
  !! for an hexagonal box.
  !! `posout` is set to the vector between the images.
  use iso_fortran_env
  implicit none
  real(8),intent(in) :: pos(3)
  real(8),intent(out) :: posout(3)
  real(8),intent(in) :: MetricG(3,3)

  integer :: j

  do j=1,3
     posout(j) = pbc(pos(j))
  end do
  dist2_mi_hexagonal = MetricG(1,1)*(posout(1)*posout(1) + posout(2)*(posout(2) + posout(1)))+&
       posout(3)*posout(3)*MetricG(3,3)

end function dist2_mi_hexagonal


program t
  integer ::a = 10, b = 20
  print *,(-a + (-b * a))
end program t


      subroutine fclaw2d_clawpatch5_fort_tag4refinement(mx,my,mbc,
     &      meqn, xlower,ylower,dx,dy,blockno,
     &      q, tag_threshold, init_flag,tag_patch)
      implicit none

      integer mx,my, mbc, meqn, tag_patch, init_flag
      integer blockno
      double precision xlower, ylower, dx, dy
      double precision tag_threshold
      double precision q(meqn,1-mbc:mx+mbc,1-mbc:my+mbc)

      integer i,j, mq, ii, jj
      double precision qmin, qmax, xc,yc,quad(-1:1,-1:1)
      integer :: fclaw2d_clawpatch_exceeds_threshold, exceeds_th

      logical(kind=4) :: is_ghost, fclaw2d_clawpatch5_is_ghost

      tag_patch = 0

c     # Refine based only on first variable in system.
      mq = 1
      qmin = q(mq,1,1)
      qmax = q(mq,1,1)
      do j = 1-mbc,my+mbc
         do i = 1-mbc,mx+mbc
            xc = xlower + (i-0.5)*dx
            yc = ylower + (j-0.5)*dy
            qmin = min(q(mq,i,j),qmin)
            qmax = max(q(mq,i,j),qmax)
            is_ghost = fclaw2d_clawpatch5_is_ghost(i,j,mx,my)
            if (.not. is_ghost) then
               do ii = -1,1
                  do jj = -1,1
                     quad(ii,jj) = q(mq,i+ii,j+jj)
                  end do
               end do
            endif
            exceeds_th = fclaw2d_clawpatch_exceeds_threshold(
     &             blockno, q(mq,i,j),qmin,qmax,quad, dx,dy,xc,yc,
     &             tag_threshold,init_flag,is_ghost)

c           # -1 : Not conclusive (possibly ghost cell); don't tag for refinement
c           # 0  : Does not pass threshold (don't tag for refinement)
c           # 1  : Passes threshold (tag for refinement)
            if (exceeds_th .gt. 0) then
c              # Refine this patch
               tag_patch = 1
               return
            endif
         enddo
      enddo

      end

c     # We may want to check ghost cells for tagging.
      logical(kind=4) function fclaw2d_clawpatch5_is_ghost(i,j,mx,my)
         implicit none

         integer i, j, mx, my
         logical(kind=4) is_ghost

         is_ghost = .false.
         if (i .lt. 1 .or. j .lt. 1) then
            is_ghost = .true.
         elseif (i .gt. mx .or. j .gt. my) then
            is_ghost = .true.
         end if

         fclaw2d_clawpatch5_is_ghost = is_ghost

         return

      end


!> Module containing the matrix transformations
  module transformations

  contains

!> Matrix-vector multiplication using level 2 BLAS routines.
!! See http://www.netlib.org/lapack/explore-html/d7/d15/group__double__blas__level2_gadd421a107a488d524859b4a64c1901a9.html
!! and http://www.netlib.org/lapack/explore-html/dc/dc1/group__complex16__blas__level2_gafaeb2abd9fffa7442b938dc384aeaf47.html
  subroutine matrix_vector()
  use globalvars
  implicit none

! variables required for the BLAS calls
  character                            :: trans
  integer                              :: i, j
  real(dp)                             :: alpha, beta
  complex(dp)                          :: calpha, cbeta
  real(dp),dimension(:),allocatable    :: work
  complex(dp),dimension(:),allocatable :: cwork

  alpha = 1.0_dp
  beta = 0.0_dp
  calpha = cr
  cbeta = c0

  allocate(work(matdim))
  allocate(cwork(matdim))

  real_vector(:)= 1.0_dp
  complex_vector(:)= cr

! set real_matrix and complex_matrix as the identity matrix
  forall(i=1:matdim, j=1:matdim) real_matrix(i,j) = (i/j)*(j/i)
  forall(i=1:matdim, j=1:matdim) complex_matrix(i,j) = (i/j)*(j/i)
! set diagonal entries to matval/i*matval instead of 1
  real_matrix(:,:)=real_matrix(:,:)*matval
  complex_matrix(:,:)=complex_matrix(:,:)*ci*matval

  trans = 'N'
  call dgemv(trans,matdim,matdim,alpha,real_matrix,matdim,real_vector,1,beta,work,1)
! the result of the multiplication is in work. Copy over to real_vector.
  real_vector = work

  call zgemv(trans,matdim,matdim,calpha,complex_matrix,matdim,complex_vector,1,cbeta,cwork,1)
! the result of the multiplication is in cwork. Copy over to complex_vector.
  complex_vector = cwork

  deallocate(work)
  deallocate(cwork)

  end subroutine matrix_vector

!> Matrix diagonalization using lapack routines.
!! See http://www.netlib.org/lapack/explore-html/d2/d8a/group__double_s_yeigen_ga442c43fca5493590f8f26cf42fed4044.html#ga442c43fca5493590f8f26cf42fed4044
!! and http://www.netlib.org/lapack/explore-html/df/d9a/group__complex16_h_eeigen_gaf23fb5b3ae38072ef4890ba43d5cfea2.html#gaf23fb5b3ae38072ef4890ba43d5cfea2
  subroutine diag_matrix()
  use globalvars
  implicit none

! variables required for the BLAS calls
  character                            :: jobz, uplo
  integer                              :: lwork, info
  real(dp),dimension(:),allocatable    :: work, rwork
  complex(dp),dimension(:),allocatable :: cwork

  real_matrix(:,:) = matval
  complex_matrix(:,:) = matval*cr

  lwork = 3*matdim-1
  allocate(work(lwork))

  jobz = 'V'
  uplo = 'U'

  call dsyev(jobz,uplo,matdim,real_matrix,matdim,real_vector,work,lwork,info)
  if(info.eq.0) then
    write(*,*) "Diagonalization of real matrix successful!"
  endif
  deallocate(work)

  lwork = 2*matdim-1
  allocate(work(matdim))
  allocate(cwork(lwork))
  allocate(rwork(3*matdim-2))
  call zheev(jobz,uplo,matdim,complex_matrix,matdim,work,cwork,lwork,rwork,info)
  if(info.eq.0) then
    write(*,*) "Diagonalization of complex matrix successful!"
  endif
! The eigenvalues of hermitian matrices are real. We have to copy over the values from work with is a real vector into
! complex_vector for the printout.
  complex_vector(:) = work
  deallocate(work,cwork,rwork)

  end subroutine diag_matrix
!> @file

end module transformations


!
! The Laboratory of Algorithms
!
! The MIT License
!
! Copyright 2011-2015 Andrey Pudov.
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the 'Software'), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
!

module MLinearCongruential

    use MRandom

    implicit none
    private

    integer, parameter :: m  = 100000000
    integer, parameter :: m1 = 10000
    integer, parameter :: b  = 31415821

    type, extends(TRandom), public :: TLinearCongruential
    contains
        procedure :: random
    end type
contains
    function random(instance, from, to)
        class(TLinearCongruential), intent(in out) :: instance
        integer, optional, intent(in) :: from
        integer, optional, intent(in) :: to
        integer :: random

        integer, save :: value = 1234567
        value = mod(multiply(value, b) + 1, m)

        random = value
    end function

    !
    ! Computes (value1 * value2 mod m) with no overflow.
    !
    function multiply(value1, value2)
        integer, intent(in) :: value1
        integer, intent(in) :: value2
        integer :: multiply

        integer p1
        integer p0
        integer q1
        integer q0

        p1 = value1 / m1
        p0 = mod(value1, m1)

        q1 = value2 / m1
        q0 = mod(value2, m1)

        multiply = mod((mod(p0 * q1 + p1 * q0, m1) * m1 + p0 * q0), m)
    end function
end module


!--------------------------------------------------------------------------------------------------
! MODULE: Global_defs
!> @author Marin Sapunar, Ruđer Bošković Institute
!> @date January, 2017
!
!> @brief Important parameters and commonly used simple types.
!--------------------------------------------------------------------------------------------------
module global_defs
    use, intrinsic :: iso_fortran_env, only : &
        stderr => error_unit, &
        stdout => output_unit, &
        stdin => input_unit, &
        sp => real32, &
        dp => real64, &
        qp => real128

    integer, parameter :: j15 = selected_int_kind(15)
    integer :: print_level !< Global print level option for programs.

    ! Number constants.
    real(dp), parameter :: num0 = 0.0_dp
    real(dp), parameter :: num1 = 1.0_dp
    real(dp), parameter :: num2 = 2.0_dp
    real(dp), parameter :: num3 = 3.0_dp
    real(dp), parameter :: num4 = 4.0_dp
    real(dp), parameter :: f1o2 = num1 / num2
    real(dp), parameter :: f1o4 = num1 / num4
    real(dp), parameter :: f3o4 = num3 / num4
    real(dp), parameter :: sqr2 = sqrt(num2)
    real(dp), parameter :: rsq2 = num1 / sqr2
    real(dp), parameter :: sqr3 = sqrt(num3)
    real(dp), parameter :: rsq3 = num1 / sqr3
    real(dp), parameter :: pi = acos(-num1)
    real(dp), parameter :: pio2 = pi / num2

! intel v15.0 doesn't print backtrace with call abort()
#if __INTEL_COMPILER
    interface
        subroutine abort() bind(C, name="abort")
        end subroutine
    end interface
#endif

 !  !----------------------------------------------------------------------------------------------
 !  ! TYPE: IVec
 !  !> @brief Array of integer vectors of varying dimensions.
 !  !----------------------------------------------------------------------------------------------
 !  type ivec
 !     integer, allocatable :: c(:) !< Coefficents of the vectors.
 !  end type ivec

    !----------------------------------------------------------------------------------------------
    ! TYPE: IMat
    !> @brief Array of integer matrices of varying dimensions.
    !----------------------------------------------------------------------------------------------
    type imat
        integer, allocatable :: c(:, :) !< Coefficients of the matrices.
    end type imat

    !----------------------------------------------------------------------------------------------
    ! TYPE: RVec
    !> @brief Array of real vectors of varying dimensions.
    !----------------------------------------------------------------------------------------------
    type rvec
       real(dp), allocatable :: c(:) !< Coefficents of the vectors.
    end type rvec

    !----------------------------------------------------------------------------------------------
    ! TYPE: RMat
    !> @brief Array of real matrices of varying dimensions.
    !----------------------------------------------------------------------------------------------
    type rmat
        real(dp), allocatable :: c(:, :) !< Coefficients of the matrices.
    end type rmat

    !----------------------------------------------------------------------------------------------
    ! TYPE: LVec
    !> @brief Array of logical vectors of varying dimensions.
    !----------------------------------------------------------------------------------------------
    type lvec
       logical, allocatable :: l(:)
    end type lvec

    !----------------------------------------------------------------------------------------------
    ! TYPE: LMat
    !> @brief Array of logical matrices of varying dimensions.
    !----------------------------------------------------------------------------------------------
    type lmat
       logical, allocatable :: l(:, :)
    end type lmat

contains

    subroutine errstop(errsub, errmsg, errnum)
        character(len=*), intent(in) :: errsub !< Subroutine where the error occured.
        character(len=*), intent(in), optional :: errmsg !< Error message.
        integer, intent(in), optional :: errnum !< Error number.

        write(stderr, '(1x,a)') 'Error in '//errsub//'.'
        if (present(errmsg)) write(stderr, '(3x, a, a)')  'Error: ', errmsg
        if (present(errnum)) write(stderr, '(3x, a, i0)')  'Status: ', errnum
        call abort()
    end subroutine errstop

end module global_defs


      SUBROUTINE zbrac(func,x1,x2,succes)
      INTEGER NTRY
      REAL x1,x2,func,FACTOR
      EXTERNAL func
      PARAMETER (FACTOR=1.6,NTRY=50)
      INTEGER j
      REAL f1,f2
      LOGICAL succes
      if(x1.eq.x2)pause 'you have to guess an initial range in zbrac'
      f1=func(x1)
      f2=func(x2)
      succes=.true.
      do 11 j=1,NTRY
        if(f1*f2.lt.0.)return
        if(abs(f1).lt.abs(f2))then
          x1=x1+FACTOR*(x1-x2)
          f1=func(x1)
        else
          x2=x2+FACTOR*(x2-x1)
          f2=func(x2)
        endif
11    continue
      succes=.false.
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/zbrac.for


function inside_circle(cen_x, cen_y, radius, x, y) result(is_inside)
    implicit none
    integer, intent(in) :: cen_x, cen_y, radius, x, y
    integer :: distance
    logical :: is_inside
    distance = (cen_x - x) * (cen_x - x) + (cen_y - y) * (cen_y - y)
    is_inside = distance < radius * radius
end function inside_circle

program P1004
    implicit none
    integer :: cases, i
    integer :: src_x, src_y, dst_x, dst_y
    integer :: systems, j
    integer :: cen_x, cen_y, radius
    integer :: io
    logical :: src_inside, dst_inside
    logical :: inside_circle
    read *, cases
    do i = 1, cases
        read *, src_x, src_y, dst_x, dst_y
        read *, systems
        io = 0
        do j = 1, systems
            read *, cen_x, cen_y, radius
            src_inside = inside_circle(cen_x, cen_y, radius, src_x, src_y)
            dst_inside = inside_circle(cen_x, cen_y, radius, dst_x, dst_y)
            if (src_inside .neqv. dst_inside) then
                io = io + 1
            end if
        end do
        write (*, '(I0)') io
    end do
end program P1004


MODULE Interpolation

  ! -----------------
  ! Module use
  ! -----------------
  USE Type_Kinds,  ONLY: Double => fp_kind

  ! Disable all implicit typing
  IMPLICIT NONE

  ! -----------------
  ! Module parameters
  ! -----------------
  ! RCS Id for the module
  CHARACTER(*), PRIVATE, PARAMETER :: MODULE_RCS_ID = &

  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE

  PUBLIC :: find_index_linear
  PUBLIC :: interp_linear
  PUBLIC :: find_index
  PUBLIC :: lpoly
  PUBLIC :: interp

  REAL(Double), PARAMETER :: ZERO = 0.0_Double, ONE = 1.0_Double

CONTAINS

  SUBROUTINE find_index_linear(x, x_int, index_int)
    REAL(Double), INTENT(IN)      :: x(:)
    REAL(Double), INTENT(IN)      :: x_int(:)
    INTEGER,      INTENT(OUT)     :: index_int(:)

    CALL find_index(x, x_int, index_int)

  END SUBROUTINE find_index_linear

  SUBROUTINE interp_linear(y, x, x_int, y_int, index_int)

    REAL(Double), INTENT(IN)       :: y(:)
    REAL(Double), INTENT(IN)       :: x(:)
    REAL(Double), INTENT(IN)       :: x_int(:)
    REAL(Double), INTENT(OUT)      :: y_int(:)
    INTEGER, OPTIONAL, INTENT(IN)  :: index_int(:)

    ! Local
    INTEGER      :: index_int_local(SIZE(x_int))
    REAL(Double) :: xlp(SIZE(x_int),2)

    IF(PRESENT(index_int))THEN
      CALL lpoly(x, x_int, index_int, xlp)
      CALL interp(y, xlp, index_int, y_int)
    ELSE
      CALL find_index(x, x_int, index_int_local)
      CALL lpoly(x, x_int, index_int_local, xlp)
      CALL interp(y, xlp, index_int_local, y_int)
    END IF

  END SUBROUTINE interp_linear

!------------------------------------------------------------------------
!  Lagrange interpolation:
!            (x -x2)(x -x3)...(x -xn)      (x -x1)(x -x3)...(x -xn)
!     P(x) = ------------------------*y1 + ------------------------*y2
!            (x1-x2)(x1-x3)...(x1-xn)      (x2-x1)(x2-x3)...(x2-xn)
!
!                                          (x -x1)(x -x2)...(x -xn-1)
!            + ...                       + ------------------------*yn
!                                          (xn-x1)(xn-x3)...(xn-xn-1)
!     where n is the number of data points for interpolation
!     n = 2 is a linear interpolation
!------------------------------------------------------------------------

!----------------------------------------------------------------
! The subroutine finds the indexes for interpolation routines
!
! Input arguments:
!   x     :     Rank-1 array containg the original points
!               Type: Double
!               Dimension: nx
!   x_int :     Rank-1 array containg the interpolation points
!               Type: Double
!               Dimension: nx_int
! Optional input arguments
!   n_points  : The number of data point for interpolation. If not
!               provided a value of 2 is assumed (linear interpolation).
!               Dimension: Scalar
! Output arguments
!   index_int : Rank-1 array containing the indexes of the first
!               data point of the n_points data series
!               Dimension: nx_int
!
!       e.g. if n_points = 3 (three points interpolation),
!       x(index_int(i)), x(index_int(i)+1) and x(index_int(i)+2)
!       will be used as the locations of three points for the
!       interpolation on x_int(i)
!----------------------------------------------------------------
  SUBROUTINE find_index(x, x_int, index_int, n_points)
    REAL(Double), INTENT(IN)      :: x(:)
    REAL(Double), INTENT(IN)      :: x_int(:)
    INTEGER,      INTENT(OUT)     :: index_int(:)
    INTEGER, OPTIONAL, INTENT(IN) :: n_points

    ! Local variable
    INTEGER :: j, j1, k, k1, k2, js, djs, nx, nx_int, npts, half
    INTEGER, PARAMETER :: NPTS_default = 2
    REAL(Double)       :: d1, d2

    nx     = SIZE(x)
    nx_int = SIZE(x_int)

    npts = NPTS_default
    IF(PRESENT(n_points))npts = n_points

    k1 = 1
    DO k = 1, nx_int
      IF(x_int(k) < x(1))THEN
        index_int(k) = 1
      ELSE
        k1 = k
        EXIT
      ENDIF
    ENDDO

    k2 = nx_int
    DO k = nx_int, 1, -1
      IF(x_int(k) > x(nx))THEN
        index_int(k) = nx-npts+1
      ELSE
        k2 = k
        EXIT
      ENDIF
    ENDDO

    half = npts/2
    j1 = 1
    DO k=k1, k2
      DO j = j1, nx-1
        d1 = x_int(k) - x(j)
        d2 = x(j+1) - x_int(k)
        IF(d1 >= ZERO .AND. d2 >= ZERO)THEN
          ! pickup j or j+1 depending on which near to the point x_int(k).
          ! j (or j+1) will be the center point. js in the following calculation
          ! is the leftest point.
          IF(d1 < d2)THEN
            js = j - half + MOD(npts+1, 2)
          ELSE
            js = (j+1) - half
          END IF
          IF(js < 1)js = 1
          djs = nx - (js+npts-1)
          IF(djs < 0)js = js + djs
          index_int(k) = js
          j1 = j
          EXIT
        ENDIF
      ENDDO
    ENDDO

  END SUBROUTINE find_index

!--------------------------------------------------------------------
!  The subroutine computes Lagrange Polynomial for interploation
!
! Input arguments
!
!   x     :     Rank-1 array containg the original points
!               Type: Double
!               Dimension: nx
!   x_int :     Rank-1 array containg the interpolation points
!               Type: Double
!               Dimension: nx_int
!
!  index_int :  Rank-1 array containing the indexes of the first
!               data point of the n_points data series
!               Dimension: nx_int
!
! Optional input arguments
!   n_points  : The number of data point for interpolation. If not
!               provided a value of 2 is assumed (linear interpolation).
!               Dimension: Scalar
!
! Output arguments:
!   lp :        Rank-2 array containing Polynomial data
!               Type: Double
!               Dimension: nx_int x n_points
!----------------------------------------------------------------------

  SUBROUTINE lpoly(x, x_int, index_int, lp, n_points)
    REAL(Double),     INTENT(IN)  :: x(:)
    REAL(Double),     INTENT(IN)  :: x_int(:)
    INTEGER,          INTENT(IN)  :: index_int(:)
    REAL(Double),     INTENT(OUT) :: lp(:,:)
    INTEGER,OPTIONAL, INTENT(IN)  :: n_points

    ! Local
    INTEGER, PARAMETER :: NPTS_default = 2
    INTEGER :: nx, nx_int, i, i1, i2, j, jj, k, kk, m, npts
    REAL(Double) :: pn, pd

    nx     = SIZE(x)
    nx_int = SIZE(x_int)

    npts = NPTS_default
    IF(PRESENT(n_points))npts = n_points

    DO m = 1, nx_int
      i1 = index_int(m)
      i2 = i1 + npts - 1
      DO j = 1, npts
        pn = ONE
        pd = ONE
        jj = i1+j-1
        DO k = 1, npts
          IF(k == j)CYCLE
          kk = i1+k-1
          pn = pn*(x_int(m)-x(kk))
          pd = pd*(x(jj)-x(kk))
        ENDDO
        lp(m, j) = pn / pd

      END DO
    END DO

  END SUBROUTINE lpoly

!------------------------------------------------------------------
! Subroutine does the interpolation given the Lagrange Polynomials.
!
! Input arguments
!   y  :   Rang-1 array containing the original data
!          Type: Double
!          Dimension: nx
!  xlp :   Lagrange Polynomials
!          Type: Double
!          Dimension: nx_int x n_points
!  index_int :  Rank-1 array containing the indexes of the first
!               data point of the n_points data series
!               Dimension: nx_int
! Output arguments
!  y_int : Rank-1 array containing the results
!          Type: Double
!          Dimension: nx_int
!-------------------------------------------------------------------

  SUBROUTINE interp(y, xlp, index_int, y_int)
    REAL(Double), INTENT(IN)      :: y(:)
    REAL(Double), INTENT(IN)      :: xlp(:,:)
    INTEGER,      INTENT(IN)      :: index_int(:)
    REAL(Double), INTENT(OUT)     :: y_int(:)

    ! Local
    INTEGER :: npts, ny_int, i, k

    npts   = SIZE(xlp, DIM=2)
    ny_int = SIZE(y_int)

    y_int = ZERO
    DO k = 1,ny_int
    DO i = 1,npts
      y_int(k) = y_int(k) + xlp(k,i)*y(index_int(k)+i-1)
    END DO
    END DO

  END SUBROUTINE interp

END MODULE Interpolation


      program t
      implicit none
      REAL C,F,TEMP
      C(F) = 5.0*(F - 32.0)/9.0
      print '(f5.1)',c(32.0)
      print '(f5.1)',c(212.0)
      end program t


program debug
    implicit none
    integer, parameter :: a = 10, b = -20, c = 30
    integer, parameter :: d = -40, e = 0, f = 50
    print *, min(a, b, c, d, e, f)
    print *, max(a, b, c, d, e, f)
    print *, max(a, b)
    print *, min(a, b)
end program