c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine pintgr(u, phi1, phi2, frc, nx, nxmax, ny, nz)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      implicit none

      include 'header.h'
      integer          nx, nxmax, ny, nz
      double precision u(5,nxmax,ny,nz), frc,
     $                 phi1(problem_size,problem_size),
     $                 phi2(problem_size,problem_size)

c---------------------------------------------------------------------
c  local variables
c---------------------------------------------------------------------
      integer i, j, k
      double precision  frc1, frc2, frc3

c---------------------------------------------------------------------
c   initialize
c---------------------------------------------------------------------
      do j = 1,ny
        do i = 1,nx
          phi1(i,j) = 0.d0
          phi2(i,j) = 0.d0
        end do
      end do

      do j = 2,ny-2
         do i = 2,nx-1

            k = 3

            phi1(i,j) = c2*(u(5,i,j,k) -
     >             0.5d0 * (u(2,i,j,k)**2 + u(3,i,j,k)**2 +
     >                      u(4,i,j,k)**2) / u(1,i,j,k) )

            k = nz-1

            phi2(i,j) = c2*(u(5,i,j,k) -
     >             0.5d0 * (u(2,i,j,k)**2 + u(3,i,j,k)**2 +
     >                      u(4,i,j,k)**2) / u(1,i,j,k) )
         end do
      end do

      frc1 = 0.0d0

      do j = 2,ny-3
         do i = 2, nx-2
            frc1 = frc1 + (phi1(i,j)   + phi1(i+1,j)   +
     >                     phi1(i,j+1) + phi1(i+1,j+1) +
     >                     phi2(i,j)   + phi2(i+1,j)   +
     >                     phi2(i,j+1) + phi2(i+1,j+1))
         end do
      end do

      frc1 = dxi * deta * frc1

c---------------------------------------------------------------------
c   initialize
c---------------------------------------------------------------------
      do k = 1,nz
        do i = 1,nx
          phi1(i,k) = 0.
          phi2(i,k) = 0.
        end do
      end do

      do k = 3, nz-1
         do i = 2, nx-1
            phi1(i,k) = c2*(u(5,i,2,k) -
     >             0.5d0 * (u(2,i,2,k)**2 + u(3,i,2,k)**2 +
     >                      u(4,i,2,k)**2 ) / u(1,i,2,k) )
         end do
      end do

      do k = 3, nz-1
         do i = 2, nx-1
            phi2(i,k) = c2*(u(5,i,ny-2,k) -
     >             0.5d0 * (u(2,i,ny-2,k)**2 + u(3,i,ny-2,k)**2 +
     >                      u(4,i,ny-2,k)**2 ) / u(1,i,ny-2,k) )
         end do
      end do

      frc2 = 0.0d0
      do k = 3, nz-2
         do i = 2, nx-2
            frc2 = frc2 + (phi1(i,k)   + phi1(i+1,k)   +
     >                     phi1(i,k+1) + phi1(i+1,k+1) +
     >                     phi2(i,k)   + phi2(i+1,k)   +
     >                     phi2(i,k+1) + phi2(i+1,k+1))
         end do
      end do

      frc2 = dxi * dzeta * frc2

c---------------------------------------------------------------------
c   initialize
c---------------------------------------------------------------------
      do k = 1,nz
        do j = 1,ny
          phi1(j,k) = 0.d0
          phi2(j,k) = 0.d0
        end do
      end do

      do k = 3, nz-1
         do j = 2, ny-2
            phi1(j,k) = c2*(u(5,2,j,k) -
     >             0.5d0 * (u(2,2,j,k)**2 + u(3,2,j,k)**2 +
     >                      u(4,2,j,k)**2)   / u(1,2,j,k) )
         end do
      end do

      do k = 3, nz-1
         do j = 2, ny-2
            phi2(j,k) = c2*(u(5,nx-1,j,k) -
     >             0.5d0 * (u(2,nx-1,j,k)**2 + u(3,nx-1,j,k)**2 +
     >                      u(4,nx-1,j,k)**2)  / u(1,nx-1,j,k) )
         end do
      end do

      frc3 = 0.0d0

      do k = 3, nz-2
         do j = 2, ny-3
            frc3 = frc3 + (phi1(j,k)   + phi1(j+1,k)   +
     >                     phi1(j,k+1) + phi1(j+1,k+1) +
     >                     phi2(j,k)   + phi2(j+1,k)   +
     >                     phi2(j,k+1) + phi2(j+1,k+1))
         end do
      end do

      frc3 = deta * dzeta * frc3
      frc = 0.25d0 * ( frc1 + frc2 + frc3 )

      return
      end


! This subroutine is used to caculate Hamiltonian for
! bulk system .

! History
!        May/29/2011 by Quansheng Wu
  subroutine ham_bulk(k,Hamk_bulk)

     use para
     implicit none

! loop index
     integer :: i1,i2,ia,ib,ic,iR

     integer :: ia1, ia2

     integer :: nwann

     real(dp) :: kdotr

! wave vector in 2d
     real(Dp) :: k(3)

     ! coordinates of R vector
     real(Dp) :: R(3)

     !> row start; row end; column start; column end
     real(dp) :: rs, re
     real(dp) :: cs, ce

     real(dp) :: pos(3)
     real(dp) :: pos1(3)
     real(dp) :: pos2(3)

     !> distance between two atoms
     real(dp) :: dis

     ! Hamiltonian of bulk system
     complex(Dp),intent(out) ::Hamk_bulk(Num_wann, Num_wann)

     real(dp), external :: norm

     nwann= Num_wann/2
     Hamk_bulk=0d0
     if (soc==2) then
        !> the first atom in home unit cell
        do ia1=1, Num_atoms
           pos1= Atom_position(:, ia1)
           rs= index_start(ia1)
           re= index_end(ia1)
           !> the second atom in unit cell R
           do ia2=1, Num_atoms
              pos2= Atom_position(:, ia2)
              cs= index_start(ia2)
              ce= index_end(ia2)
              do iR=1,Nrpts
                 ia=irvec(1,iR)
                 ib=irvec(2,iR)
                 ic=irvec(3,iR)

                 pos= ia*Rua+ ib*Rub+ ic* Ruc
                 pos= pos+ pos2- pos1
                 dis= norm(pos)

                 if (dis> Rcut) cycle

                 kdotr=k(1)*ia + k(2)*ib + k(3)*ic

                 Hamk_bulk(rs:re, cs:ce)=Hamk_bulk(rs:re, cs:ce)&
                 +HmnR(rs:re, cs:ce,iR)*Exp(2d0*pi*zi*kdotr)/ndegen(iR)

                 Hamk_bulk(rs:re, cs+nwann:ce+nwann)= &
                 Hamk_bulk(rs:re, cs+nwann:ce+nwann)+ &
                 HmnR(rs:re, cs+nwann:ce+nwann,iR)* &
                 Exp(2d0*pi*zi*kdotr)/ndegen(iR)

                 Hamk_bulk(rs+nwann:re+nwann, cs:ce)= &
                 Hamk_bulk(rs+nwann:re+nwann, cs:ce)+ &
                 HmnR(rs+nwann:re+nwann, cs:ce,iR)* &
                 Exp(2d0*pi*zi*kdotr)/ndegen(iR)

                 Hamk_bulk(rs+nwann:re+nwann, cs+nwann:ce+nwann)= &
                 Hamk_bulk(rs+nwann:re+nwann, cs+nwann:ce+nwann)+ &
                 HmnR(rs+nwann:re+nwann, cs+nwann:ce+nwann,iR)* &
                 Exp(2d0*pi*zi*kdotr)/ndegen(iR)

              enddo ! iR
           enddo ! ia2
        enddo ! ia1
     else
        !> the first atom in home unit cell
        do ia1=1, Num_atoms
           pos1= Atom_position(:, ia1)
           rs= index_start(ia1)
           re= index_end(ia1)
           !> the second atom in unit cell R
           do ia2=1, Num_atoms
              pos2= Atom_position(:, ia2)
              cs= index_start(ia2)
              ce= index_end(ia2)
              do iR=1,Nrpts
                 ia=irvec(1,iR)
                 ib=irvec(2,iR)
                 ic=irvec(3,iR)

                 pos= ia*Rua+ ib*Rub+ ic* Ruc
                 pos= pos+ pos2- pos1
                 dis= norm(pos)

                 if (dis> Rcut) cycle

                 kdotr=k(1)*ia + k(2)*ib + k(3)*ic

                 Hamk_bulk(rs:re, cs:ce)=Hamk_bulk(rs:re, cs:ce)&
                 +HmnR(rs:re, cs:ce,iR)*Exp(2d0*pi*zi*kdotr)/ndegen(iR)

              enddo ! iR
           enddo ! ia2
        enddo ! ia1

     endif ! soc

! check hermitcity

     do i1=1, Num_wann
     do i2=1, Num_wann
        if(abs(Hamk_bulk(i1,i2)-conjg(Hamk_bulk(i2,i1))).ge.1e-6)then
          write(stdout,*)'there are something wrong with Hamk_bulk'
          stop
        endif
     enddo
     enddo

  return
  end subroutine ham_bulk


!> \brief Simplex-Simulated Annealing in the spirit of NR
!> \author Alin M Elena
!> \date 12/11/07, 13:38:02
!
module m_SimplexSA
  use m_Constants
  use m_Types
  use m_Useful
  implicit none
!
  private
!
  public :: amebsa
contains
!
!> \brief Simplex-Simulated Annealing method
!> \author Alin M Elena
!> \date 12/11/07, 13:39:28
!> \param p matrix n+1 by n contains the initial simplex
!> \param y array, n+1, contains the cost function for each point in simplex
!> @param func function the cost function
!> \param bounds array array, n, the parameters to be optimized
!> \param iter integer number of iterations done
!> \param ftol real the desired tolerance
!> \param temptr the temperature
!> \param pb the best point
!> \param yb the cost of the best point
!> \param io type(ioType) contains all the info about I/O files
!> \param gen type(generalType) contains the info needed by the program to run
!> \param atomic type(atomicxType) contains all info about the atoms and basis set and some parameters
!> \param tb type(modelType) contains information about the tight binding model parameters
!> \param sol type(solutionType) contains information about the solution space
!> \remarks all the job is done by AmebsaPrivate
!> \internal add citation to the original paper
  subroutine amebsa (p, y, pb, yb, ftol, func, iter, temptr, bounds, gen, atomic, tb, sol, io)
    integer, intent (inout) :: iter
    real (k_pr), intent (inout) :: yb
    real (k_pr), intent (inout) :: ftol, temptr
    real (k_pr), dimension (:), intent (inout) :: y, pb
    real (k_pr), dimension (:, :), intent (inout) :: p
    real (k_pr), dimension (:, :), intent (in) :: bounds
    type (generalType), intent (inout) :: gen
    type (atomicxType), intent (inout) :: atomic
    type (modelType), intent (inout) :: tb
    type (solutionType), intent (inout) :: sol
    type (ioType), intent (inout) :: io
!
    interface
      function func (x, gen, atomic, tb, sol, io)
        use m_Constants
        use m_Types
        implicit none
        real (k_pr), dimension (:), intent (in) :: x
        type (generalType), intent (inout) :: gen
        type (atomicxType), intent (inout) :: atomic
        type (modelType), intent (inout) :: tb
        type (solutionType), intent (inout) :: sol
        type (ioType), intent (inout) :: io
        real (k_pr) :: func
      end function func
    end interface
!
    integer :: ihi, ndim
    real (k_pr) :: yhi
    real (k_pr), dimension (size(p, 2)) :: psum
!
    call AmebsaPrivate
  contains
!
    subroutine AmebsaPrivate
      integer :: i, iii, j, ilo, inhi
      real (k_pr) :: rtol, ylo, ynhi, ysave, ytry
      real (k_pr), dimension (size(y)) :: yt, harvest
      ndim = AssertEq (size(p, 2), size(p, 1)-1, size(y)-1, size(pb), io)
      psum (:) = sum (p(:, :), dim=1)
      do
        do j = 1, ndim + 1
          harvest (j) = ranmar (sol%seed)
        end do
        yt (:) = y (:) - temptr * Log (harvest)
        ilo = iminloc (yt(:))
        ylo = yt (ilo)
        ihi = imaxloc (yt(:))
        yhi = yt (ihi)
        yt (ihi) = ylo
        inhi = imaxloc (yt(:))
        ynhi = yt (inhi)
        rtol = 2.0_k_pr * Abs (yhi-ylo) / (Abs(yhi)+Abs(ylo))
        if (rtol < ftol .or. iter < 0) then
          call swap (y(1), y(ilo))
          call swap (p(1, :), p(ilo, :))
          return
        end if
        ytry = amotsa (-1.0_k_pr)
        iter = iter - 1
        if (ytry <= ylo) then
          ytry = amotsa (2.0_k_pr)
          iter = iter - 1
        else if (ytry >= ynhi) then
          ysave = yhi
          ytry = amotsa (0.5_k_pr)
          iter = iter - 1
          if (ytry >= ysave) then
            p (:, :) = 0.5_k_pr * (p(:, :)+spread(p(ilo, :), 1, size(p, 1)))
            do i = 1, ndim + 1
              if (i /= ilo) then
                y (i) = func (p(i, :), gen, atomic, tb, sol, io)
!check the bounds
                do iii = 1, ndim
                  if ((p(i, iii) < bounds(iii, 1)) .or. (p(i, iii) > bounds(iii, 2))) then
                    y (i) = k_infinity
                  end if
                end do
              end if
            end do
            iter = iter - ndim
            psum (:) = sum (p(:, :), dim=1)
          end if
        end if
      end do
    end subroutine AmebsaPrivate
!> \brief extrapolates a point an checks it
!> \author Alin M Elena
!> \date 12/11/07, 13:35:59
!> \param fac real the factor used for extrapolation
    function amotsa (fac)
      real (k_pr), intent (in) :: fac
      real (k_pr) :: amotsa
      real (k_pr) :: fac1, fac2, yflu, ytry, harv
      real (k_pr), dimension (size(p, 2)) :: ptry
      integer :: i
      fac1 = (1.0_k_pr-fac) / ndim
      fac2 = fac1 - fac
      ptry (:) = psum (:) * fac1 - p (ihi, :) * fac2
      ytry = func (ptry, gen, atomic, tb, sol, io)
      do i = 1, ndim
        if ((ptry(i) < bounds(i, 1)) .or. (ptry(i) > bounds(i, 2))) then
          ytry = k_infinity
        end if
      end do
      if (ytry <= yb) then
        pb (:) = ptry (:)
        yb = ytry
      end if
      harv = ranmar (sol%seed)
      yflu = ytry + temptr * Log (harv)
      if (yflu < yhi) then
        y (ihi) = ytry
        yhi = yflu
        psum (:) = psum (:) - p (ihi, :) + ptry (:)
        p (ihi, :) = ptry (:)
      end if
      amotsa = yflu
    end function amotsa
  end subroutine amebsa
end module m_SimplexSA


!   ==================
    subroutine setprob
!   ==================

    implicit none

    character*12 fname
    integer iunit

    REAL (kind=8) :: center(2), theta, xcb(2), mindepth
    common /fault/  center, theta, xcb, mindepth

    real (kind=8) :: scaling
    common /water/  scaling

    real (kind=8) :: width
!
!
      iunit = 7
      fname = 'setprob.data'
!     # open the unit with new routine from Clawpack 4.4 to skip over
!     # comment lines starting with #:
      call opendatafile(iunit, fname)

!
      read(7,*) width ! domain_depth
      read(7,*) width ! domain width
      read(7,*) center(1)
      read(7,*) width
      read(7,*) theta
      read(7,*) center(2)
      read(7,*) scaling ! water depth
      read(7,*) scaling

      center(2) = -center(2)
      xcb(1) = center(1) - 0.5*width
      xcb(2) = center(1) + 0.5*width

      mindepth = dmin1(dabs(center(2) - 0.5*width*dsin(theta)), &
                      dabs(center(2) + 0.5*width*dsin(theta)))

    return
    end


      subroutine ksdfp (x,side,act,dfun,ndv,s,slope,y,p,h,hess,
     1                  isdflg)
      implicit double precision (a-h,o-z)
      dimension x(*),side(*),act(*),dfun(*),s(*),y(*),p(*),h(*)
      dimension hess(*)
c
c          routine to compute search direction using the
c          davidon-fletcher-powell method
c
c          author   - Gregory A. Wrenn
c          location - Lockheed Engineering and Sciences Co.
c                     144 Research Drive
c                     Hampton, Va. 23666
c
c          last modification - 19 July 1996
c
      if (isdflg .gt. 0) go to 40
c
c          reset approximate hessian matrix to initial condition
c
   10 continue
c
c          set h matrix to hess matrix
c
      isdflg = 0
      nh = ndv * (ndv + 1) / 2
      do 20 i = 1,nh
        h(i) = hess(i)
   20 continue
      do 30 i = 1,ndv
        act(i) = side(i)
   30 continue
      go to 80
c
c          dfp algorithm
c
   40 continue
c
c          check for validity of hessian matrix
c          in the case of side constraints
c
      do 50 i = 1,ndv
        if (side(i) .ne. act(i)) go to 10
   50 continue
c
c          compute vectors p and y
c
      do 60 i = 1,ndv
        y(i) = dfun(i) - y(i)
        p(i) = x(i) - p(i)
   60 continue
c
c          compute update to hessian matrix
c
      call kshmul (h,y,s,ndv)
      call ksvprd (p,y,sigma,ndv)
      call ksvprd (y,s,tau,ndv)
      if (abs(sigma) .lt. 1.0e-08) sigma = 1.0e-08
      if (abs(tau) .lt. 1.0e-08) tau = 1.0e-08
      sigma = 1.0 / sigma
      tau = 1.0 / tau
c
      k = 0
      do 70 i = 1,ndv
      do 70 j = 1,i
        k = k + 1
        h(k) = h(k) + sigma * p(i) * p(j) - tau * s(i) * s(j)
   70 continue
c
   80 continue
      call kshmul (h,dfun,s,ndv)
c
c          negate s-vector
c
      smax = 1.0e-08
      do 90 i = 1,ndv
        s(i) = -s(i)
        si = abs(s(i))
        if (si .gt. smax) smax = si
   90 continue
c
c          normalize search direction to unit maximum
c          and save previous gradients in y-vector
c          and previous design variables in p-vector
c
      do 100 i = 1,ndv
        s(i) = s(i) / smax
        y(i) = dfun(i)
        p(i) = x(i)
  100 continue
c
c          compute slope
c
      call ksvprd (s,dfun,slope,ndv)
      if (slope .gt. 0.0 .and. isdflg .gt. 0) go to 10
      if (slope .gt. 0.0) slope = 0.0
c
      return
      end


module mesh_functions

!!! Subroutines and functions for general calculations. Not specific to any
!!! particular application, although it is expected these will generally be used
!!! for calculations to do with a mesh (not fields or solutions).
!!! Any function that is used by more than one module should appear in here.
!!! ALL subroutines and functions in this module are public.

  use other_consts   !! pi

  implicit none

  private

  public  area_between_three_points,area_between_two_vectors,calc_branch_direction,&
       angle_btwn_vectors,calc_scale_factors_2d,check_colinear_points,cross_product,&
       distance_between_points,make_plane_from_3points,mesh_a_x_eq_b,ph3,pl1,&
       point_internal_to_surface,scalar_product_3,scalar_triple_product,scale_mesh,&
       unit_norm_to_plane_two_vectors,unit_norm_to_three_points,unit_vector,&
       vector_length,volume_internal_to_surface

contains

!!! list of subroutines

  ! calc_branch_direction
  ! ..... calculates direction of branch and stores in elem_direction

  ! calc_scale_factors_2d
  ! ..... calculate the scale factors for a 2d mesh

  ! make_plane_from_3points
  ! ..... finds the equation of a plane in 3D and a vector normal to the plane from three
  ! ..... non-colinear points.

  ! scale_mesh
  ! ..... multiply mesh (coordinates and derivatives) by a constant

!!! list of functions

  ! angle_btwn_vectors
  ! .... returns the angle between two vectors

  ! check_colinear_points
  ! .... returns true or false for whether 3 points are colinear

  ! cross_product ***
  ! .... returns the vector cross product of A*B

  ! distance_between_points ***
  ! .... calculates the distance between two arbitrary points

  ! mesh_a_x_eq_b ***
  ! .... solves a small matrix system

  ! scalar_product_3 ***
  ! .... dot product of two 3x1 vectors

  ! unit_vector ***
  ! .... Calculates the unit vector for an arbitrary 3x1 vector

  ! vector_length ***
  ! .... Calculates the length of a 3x1 vector

!!!#####################################################################

  subroutine calc_branch_direction(ne)

!!! calculates the direction of element ne and stores in elem_direction

    use arrays!,only: elem_direction,elem_nodes,node_xyz

    integer,intent(in) :: ne

    integer :: np_end,np_start
    real(dp) :: length

    np_start = elem_nodes(1,ne)
    np_end = elem_nodes(2,ne)

    length = distance_between_points(node_xyz(1,np_end),node_xyz(1,np_start))
    elem_direction(1:3,ne)=(node_xyz(1:3,np_end)-node_xyz(1:3,np_start))/length

  end subroutine calc_branch_direction

!!! ##########################################################################

  subroutine calc_scale_factors_2d(sf_option)

!!! calculates the arclengths and scale factors for 2d surface elements,
!!! stores in scale_factors_2d

    use arrays !only: arclength,elem_lines_2d,elem_nodes_2d,lines_2d,lines_in_elem,&
!line_versn_2d,nodes_in_line,node_xyz_2d,num_elems_2d,num_lines_2d,scale_factors_2d,dp

    character(len=4),intent(in) :: sf_option
!!! local variables
    integer,parameter :: num_deriv = 4
    integer :: ido(num_deriv,2),IG(4),it,IT_count,ITMAX=20,k,N,NAE,ne,&
         ng,NGA=4,NI1(3),ni,ni2,nj,nk,nk2,nl,nn,nn2,NNK,no_nl,&
         np,ns,nv,NNL(2,4)
    real(dp) :: DA,SUM1,SUM2,SUM3,SUM4,W,WG_LOCAL(10),XA_LOCAL(4,3),XI,&
         XIGG(10),XN_LOCAL(2,3,4)
    logical :: FOUND

    XIGG = [0.6_dp,0.2113248654051_dp,0.7886751345948_dp,0.1127016653792_dp,&
         0.6_dp,0.8872983346207_dp,0.0694318442029_dp,0.3300094782075_dp,&
         0.6699905217924_dp,0.9305681557970_dp]
    WG_LOCAL = [1.0_dp,0.6_dp,0.6_dp,0.2777777777778_dp,0.4444444444444_dp,&
         0.2777777777778_dp,0.1739274225687_dp,0.3260725774313_dp,&
         0.3260725774313_dp,0.1739274225687_dp]
    IG = [0,1,3,6]
    ido = reshape ([1,2,1,2,1,1,2,2],shape(ido))
    NI1 = [1,2,1]
    NNL = reshape([1,2,3,4,1,3,2,4],shape(NNL))

    if(.not.allocated(scale_factors_2d)) allocate(scale_factors_2d(16,num_elems_2d))

    select case (sf_option)
    case ('unit')
       scale_factors_2d = 1.0_dp
    case('arcl')
       do no_nl=1,num_lines_2d !loop over global lines
          nl=lines_2d(no_nl)
          ni = nodes_in_line(1,0,nl)
          do n = 1,2                  !for each node on the line
             np = nodes_in_line(n+1,1,nl)       !np1,np2
             do nj = 1,3
                nv = line_versn_2d(N,nj,nl)
                XN_LOCAL(1,nj,n) = node_xyz_2d(1,nv,nj,np)
                ne = lines_in_elem(1,nl)
                ni2 = 1+MOD(ni,2)
                nn = 1
                FOUND =.FALSE.
                do WHILE((nn.LE.4).AND.(.NOT.FOUND))
                   if(np.EQ.elem_nodes_2d(nn,ne))then
                      FOUND=.TRUE.
                   else
                      nn=nn+1
                   endif
                enddo
                do nk=2,4           !dxi1, dxi2, d2xi1xi2
                   if(IDO(nk,ni).EQ.2.AND.IDO(nk,ni2).EQ.1) then
                      XN_LOCAL(2,nj,n) = node_xyz_2d(nk,nv,nj,np)
                   endif
                enddo !nk
             enddo !nj
          enddo !n

          SUM2=0.0_dp
          do ng=1,NGA
             XI=XIGG(IG(NGA)+ng)
             W=WG_LOCAL(IG(NGA)+ng)
             do nj=1,3
                do k=1,2
                   XA_LOCAL(k,nj)=PL1(1,k,XI)*XN_LOCAL(1,nj,1) &
                        +PL1(2,k,XI)*XN_LOCAL(1,nj,2)
                enddo
             enddo

             SUM1=XA_LOCAL(2,1)**2+XA_LOCAL(2,2)**2+XA_LOCAL(2,3)**2
             SUM2=SUM2+W*DSQRT(SUM1)
          enddo !ng

          arclength(1:3,nl)=SUM2

          it=0
          iterative_loop : do
             it=it+1
             IT_count=it
             SUM3=0.0_dp
             SUM4=0.0_dp
             do ng=1,NGA
                XI=XIGG(IG(NGA)+ng)
                W=WG_LOCAL(IG(NGA)+ng)
                do nj=1,3
                   do k=1,2
                      XA_LOCAL(k,nj)=0.0_dp
                      do n=1,2
                         XA_LOCAL(k,nj)=XA_LOCAL(k,nj)+ &
                              PH3(n,1,k,XI)*XN_LOCAL(1,nj,n) &
                              +PH3(n,2,k,XI)*XN_LOCAL(2,nj,n)*arclength(n,nl)
                      enddo
                   enddo
                   XA_LOCAL(3,nj)=0.0_dp
                   do n=1,2
                      XA_LOCAL(3,nj)=XA_LOCAL(3,nj)+ &
                           PH3(n,2,2,XI)*XN_LOCAL(2,nj,n)
                   enddo
                   XA_LOCAL(4,nj)=0.0_dp
                   do n=1,2
                      XA_LOCAL(4,nj)=XA_LOCAL(4,nj)+ &
                           PH3(n,2,1,XI)*XN_LOCAL(2,nj,n)
                   enddo
                enddo
                SUM1=XA_LOCAL(2,1)**2+XA_LOCAL(2,2)**2+XA_LOCAL(2,3)**2
                SUM2=0.0_dp
                do nj=1,3
                   SUM2=SUM2+XA_LOCAL(2,nj)*XA_LOCAL(3,nj)
                enddo                  !nj
                SUM3=SUM3+W*DSQRT(SUM1)
                if(SUM1.GT.1.0e-6_dp) SUM4=SUM4+W*SUM2/DSQRT(SUM1)
             enddo                     !ng
             DA=-(arclength(3,nl)-SUM3)/(1.0_dp-SUM4)
             if(DABS(DA).GT.1.0e+6_dp) then
                arclength(3,nl)=1.0_dp
                exit iterative_loop
             endif

             arclength(3,nl) = arclength(3,nl)+DA      !is new arclength
             arclength(1:2,nl) = arclength(3,nl)

             if(it.eq.ITMAX) exit iterative_loop

          enddo iterative_loop      !iteration
       enddo !loop over lines

       scale_factors_2d = 1.0_dp !initialise

       do ne=1,num_elems_2d
          do NAE=1,4
             nl = elem_lines_2d(NAE,ne)
             if(nl /= 0)then
                ni = nodes_in_line(1,0,nl)
                ni2 = NI1(ni+1)
                do N=1,2
                   nn=NNL(N,NAE)
                   ns=0
                   do nn2=1,nn-1
                      do nk2=1,num_deriv
                         ns=ns+1
                      enddo
                   enddo
                   do nk=2,num_deriv
                      if(IDO(nk,ni2).EQ.1) then
                         scale_factors_2d(nk+ns,ne) = arclength(N,nl)
                         if(DABS(scale_factors_2d(nk+ns,ne)).LT.1.0e-6_dp) scale_factors_2d(nk+ns,ne) = 1.0_dp
                      endif
                   enddo !nk
                enddo !N=1,2
             endif
          enddo !NAE (nl)

          NNK=0
          do ns=1,4
             scale_factors_2d(NNK+4,ne)=scale_factors_2d(NNK+2,ne)*scale_factors_2d(NNK+3,ne)
             NNK=NNK+4
          enddo !nn

       enddo !noelem (ne)
    end select

  end subroutine calc_scale_factors_2d

!!!###############################################################

  subroutine make_plane_from_3points(NORML,NORMALTYPE,POINT1,POINT2,POINT3)

    !###    make_plane_from_3points finds the equation of a plane in three
    !###    dimensions and a vector normal to the plane from three
    !###    non-colinear points.
    !###    NORMALTYPE=1 for raw normal and plane equation
    !###    NORMALTYPE=2 for unit normal and plane equation
    !###    The coefficients represent aX + bY + cZ + d = 0
    !###    NORML(1)=a,NORML(2)=b,NORML(3)=c,NORML(4)=d
    use arrays

    !     Parameter list
    integer :: NORMALTYPE
    real(dp) :: POINT1(3),POINT2(3),POINT3(3),NORML(4)
    !     Local variables
    real(dp) :: DifF1(3),DifF2(3),NORMSIZE
    logical :: COLINEAR

    ! Check for colinearity
    COLINEAR=.FALSE.
    colinear = check_colinear_points(POINT1,POINT2,POINT3)
    if(.NOT.COLINEAR) then
       DifF1(1:3)=POINT2(1:3)-POINT1(1:3)
       DifF2(1:3)=POINT2(1:3)-POINT3(1:3)

       NORML(1)=(DifF1(2)*DifF2(3))-(DifF1(3)*DifF2(2))
       NORML(2)=(DifF1(3)*DifF2(1))-(DifF1(1)*DifF2(3))
       NORML(3)=(DifF1(1)*DifF2(2))-(DifF1(2)*DifF2(1))

       if(NORMALTYPE.EQ.2) then
          NORMSIZE = vector_length(NORML)
          NORML(1:3)=NORML(1:3)/NORMSIZE
       endif

       NORML(4) = -scalar_product_3(NORML,POINT1)

    else !Colinear

       WRITE(*,*) ' COLINEAR points in make_plane_from_3points '
       NORML = 0.0_dp
    endif
  end subroutine make_plane_from_3points

!!!##################################################

  subroutine scale_mesh(scaling,type)

    use arrays!,only: node_xyz,node_xyz_2d,scale_factors_2d

    real(dp),intent(in) :: scaling
    character(len=2),intent(in) :: type

    select case(type)
    case('1d')
       node_xyz = node_xyz * scaling
    case('2d')
       node_xyz_2d = node_xyz_2d * scaling
       node_xyz_2d(4,:,:,:) = 0.0_dp
    end select

    scale_factors_2d = 1.0_dp

  end subroutine scale_mesh

!!!##################################################

  function area_between_two_vectors(vect_a,vect_b)

    !###
    use arrays
    real(dp),intent(in) :: vect_a(3),vect_b(3)
    real(dp) :: cross(3)
    real(dp) :: area_between_two_vectors

    ! area = 1/2 x magnitude of the cross-product of vectors a and b

    cross = cross_product(vect_a,vect_b)
    area_between_two_vectors = 0.5_dp * sqrt(dot_product(cross,cross))

  end function area_between_two_vectors

!!!##################################################

  function area_between_three_points(point_a,point_b,point_c)

    !###
    use arrays
    real(dp),intent(in) :: point_a(3),point_b(3),point_c(3)
    real(dp) :: norm(3),vect_a(3),vect_b(3)
    real(dp) :: area_between_three_points

    ! area = 1/2 x magnitude of the cross-product of vectors a and b

    vect_a(1:3) = point_a(1:3) - point_b(1:3)
    vect_b(1:3) = point_a(1:3) - point_c(1:3)
    norm = cross_product(vect_a,vect_b)
    area_between_three_points = 0.5_dp * sqrt(dot_product(norm,norm))

  end function area_between_three_points

!!! ##########################################################################

  function ph3(I,J,K,XI)
    use arrays
!!! dummy arguments
    integer :: I,I_J_K,J,K
    real(dp) :: XI
!!! local variables
    real(dp) :: ph3

    ! K is 1,2, or 3; J is 1 or 2; I is 1 or 2

    I_J_K = 100*I + 10*J + K

    select case(I_J_K)
    case(111) !i=1,j=1,k=1
       PH3=(2.0_dp*XI-3.0_dp)*XI*XI+1.0_dp  ! 2xi^3-3xi^2+1
    case(121) !i=1,j=2,k=1
       PH3=((XI-2.0_dp)*XI+1.0_dp)*XI      ! xi^3-2xi^2+xi
    case(211) !i=2,j=1,k=1
       PH3=XI*XI*(3.0_dp-2.0_dp*XI)        ! -2xi^3+3xi^2
    case(221) !i=2,j=2,k=1
       PH3=XI*XI*(XI-1.0_dp)              ! xi^3-xi^2
    case(112) !i=1,j=1,k=2
       PH3=6.0_dp*XI*(XI-1.0_dp)           ! 6xi^2-6xi
    case(122) !i=1,j=2,k=2
       PH3=(3.0_dp*XI-4.0_dp)*XI+1.0_dp     ! 3xi^2-4xi+1
    case(212) !i=2,j=1,k=2
       PH3=6.0_dp*XI*(1.0_dp-XI)           ! -6xi^2+6xi
    case(222) !i=2,j=2,k=2
       PH3=XI*(3.0_dp*XI-2.0_dp)           ! 3xi^2-2xi
    case(113) !i=1,j=1,k=3
       PH3=12.0_dp*XI-6.0_dp               ! 12xi-6
    case(123) !i=1,j=2,k=3
       PH3=6.0_dp*XI-4.0_dp                ! 6xi-4
    case(213) !i=2,j=1,k=3
       PH3=6.0_dp-12.0_dp*XI               ! -12xi+6
    case(223) !i=2,j=2,k=3
       PH3=6.0_dp*XI-2.0_dp                ! 6xi-2
    end select

  end function ph3

!!! ##########################################################################

  function pl1(I,K,XI)
    use arrays
!!! dummy arguments
    integer :: I,I_K,K
    real(dp) :: XI
!!! local variables
    real(dp) :: pl1

    I_K = 10*I + K

    select case(I_K)
    case(11) !i=1,k=1
       PL1=1.0_dp-XI
    case(21) !i=2,k=1
       PL1=XI
    case(12) !i=1,k=2
       PL1=-1.0_dp
    case(22) !i=2,k=2
       PL1=1.0_dp
    case(30 :) !k=3
       PL1=0.0_dp
    end select

    return
  end function pl1

!!!##################################################

  function unit_norm_to_plane_two_vectors(vect_a,vect_b)
    use arrays
    real(dp),intent(in) :: vect_a(3),vect_b(3)
    real(dp) :: magnitude,norm(3)
    real(dp) :: unit_norm_to_plane_two_vectors(3)

    norm = cross_product(vect_a,vect_b)
    magnitude = sqrt(dot_product(norm,norm))
    unit_norm_to_plane_two_vectors = norm/magnitude

  end function unit_norm_to_plane_two_vectors

!!!##################################################

  function unit_norm_to_three_points(point_a,point_b,point_c)
    use arrays
    real(dp),intent(in) :: point_a(3),point_b(3),point_c(3)
    real(dp) :: magnitude,norm(3),vect_a(3),vect_b(3)
    real(dp) :: unit_norm_to_three_points(3)

    vect_a(1:3) = point_a(1:3) - point_b(1:3)
    vect_b(1:3) = point_a(1:3) - point_c(1:3)
    norm = cross_product(vect_a,vect_b)
    magnitude = sqrt(dot_product(norm,norm))
    unit_norm_to_three_points = norm/magnitude

  end function unit_norm_to_three_points

!!!##################################################

  function angle_btwn_vectors(U,V)
     use arrays
    !###    ANGLE calculates the angle between two vectors

    real(dp),intent(in) :: U(3),V(3)

    real(dp) :: ANGLE,angle_btwn_vectors,N_U(3),N_V(3)

    N_U = unit_vector(U)
    N_V = unit_vector(V)
    ANGLE = scalar_product_3(N_U,N_V)
    ANGLE = max(-1.0_dp,ANGLE)
    ANGLE = min(1.0_dp,ANGLE)
    ANGLE = cos(ANGLE)

    angle_btwn_vectors=ANGLE

  end function angle_btwn_vectors

!!!###############################################################

  function check_colinear_points(POINT1,POINT2,POINT3)
    use arrays ,only : dp
    !###    check_colinear_points checks whether two vectors are colinear.

    !     Parameter list
    real(dp) :: POINT1(3),POINT2(3),POINT3(3)
    !     Local variables
    real(dp) :: ERR1(3),ERR2(3),LU,LV,U(3),V(3)
    real(dp),parameter :: zero_tol = 1.0e-14_dp
    logical :: check_colinear_points

    check_colinear_points =.FALSE.
    U(1:3)=POINT2(1:3)-POINT1(1:3)
    V(1:3)=POINT3(1:3)-POINT1(1:3)
    LU = vector_length(U)
    LV = vector_length(V)
    ! If 2 of the points are the same then LU and LV
    ! can be zero causing div by zero below and resulting in
    ! the wrong answer (on Linux)
    if((dabs(LU)>zero_tol).AND.(dabs(LV)>zero_tol)) then
       ERR1(1:3)=DABS(U(1:3)/LU-V(1:3)/LV)
       ERR2(1:3)=DABS(U(1:3)/LU+V(1:3)/LV)
       if((ERR1(1).LE.ZERO_TOL.AND.ERR1(2).LE.ZERO_TOL.AND.ERR1(3).LE. &
            ZERO_TOL).OR.(ERR2(1).LE.ZERO_TOL.AND.ERR2(2).LE.ZERO_TOL.AND. &
            ERR2(3).LE.ZERO_TOL)) check_colinear_points=.TRUE.
    else
       check_colinear_points=.TRUE.
    endif
  end function check_colinear_points

!!!###############################################################

  function cross_product(A,B)
     use arrays
    !###  cross_product returns the vector cross product of A*B in C.

    !     Parameter List
    real(dp),intent(in) :: A(3),B(3)

    real(dp) :: cross_product(3)

    cross_product(1) = A(2)*B(3)-A(3)*B(2)
    cross_product(2) = A(3)*B(1)-A(1)*B(3)
    cross_product(3) = A(1)*B(2)-A(2)*B(1)

  end function cross_product

!!!###############################################################

  function scalar_triple_product(A,B,C)
     use arrays
    !###  scalar_triple_product returns A.(BxC)

    !     Parameter List
    real(dp),intent(in) :: A(3),B(3),C(3)

    real(dp) :: scalar_triple_product

    scalar_triple_product = A(1)*(B(2)*C(3)-B(3)*C(2)) + &
         A(2)*(B(3)*C(1)-B(1)*C(3)) + A(3)*(B(1)*C(2)-B(2)*C(1))

  end function scalar_triple_product

!!!###############################################################

  function distance_between_points(point1, point2)
     use arrays
    !###    calculates the distance between two arbitrary points

    real(dp),intent(in) :: point1(3),point2(3)
    integer :: i
    real(dp) :: distance_between_points

    distance_between_points = 0.0_dp
    do i=1,3
       distance_between_points = distance_between_points + (point1(i)-point2(i))**2
    enddo
    distance_between_points = dsqrt(distance_between_points)

  end function distance_between_points

!!!###############################################################

  function mesh_a_x_eq_b(MATRIX,VECTOR)
     use arrays
    real(dp) :: MATRIX(3,3),VECTOR(3)
    !Local variables
    integer :: i,j,k,pivot_row
    real(dp) :: A(3,4),max,pivot_value,SOLUTION(3),TEMP(4)
    real(dp) :: mesh_a_x_eq_b(3)

    A(1:3,1:3) = MATRIX(1:3,1:3)
    A(1:3,4) = VECTOR(1:3)
    do k=1,2
       max=0.0_dp
       do i=k,3
          if(DABS(A(i,k)).GT.max)then
             max=DABS(A(i,k))
             pivot_row=i
          endif
       enddo !i
       if(pivot_row.ne.k)then
          do j=1,4
             TEMP(j)=A(k,j)
             A(k,j)=A(pivot_row,j)
             A(pivot_row,j)=TEMP(j)
          enddo !j
       endif
       pivot_value = A(k,k)
       A(k,1:4) = A(k,1:4)/pivot_value
       do i=k+1,3
          do j=k+1,4
             A(i,j) = A(i,j)-A(i,k)*A(k,j)
          enddo
          A(i,k) = 0.0_dp
       enddo
    enddo !N
    A(3,4) = A(3,4)/A(3,3)
    A(2,4) = A(2,4)-A(3,4)*A(2,3)
    A(1,4) = A(1,4)-A(3,4)*A(1,3)-A(2,4)*A(1,2)

    SOLUTION(1:3) = A(1:3,4)

    mesh_a_x_eq_b = solution

  end function mesh_a_x_eq_b

!!!##################################################

  function scalar_product_3(A,B)
     use arrays
    !### calculates scalar product of two vectors A,B of length 3.

    real(dp),intent(in) :: A(*),B(*)

    integer :: i
    real(dp) :: scalar_product_3

    scalar_product_3 = 0.0_dp
    do i=1,3
       scalar_product_3 = scalar_product_3 + A(i)*B(i)
    enddo

  end function scalar_product_3

!!!###############################################################

  function unit_vector(A)
     use arrays
    !###  Calculates the unit vector for an arbitrary 3x1 vector

    real(dp),intent(in) :: A(*)
    real(dp) :: length_a,unit_vector(3)

    length_a = vector_length(A)
    if(length_a.gt.1.0e-6_dp)then
       unit_vector(1:3) = A(1:3)/length_a
    else
       WRITE(*,*) ' >>WARNING: Cannot normalise a zero length vector'
       WRITE(*,*) ' We recommend debugging, but hit enter to continue'
       read(*,*)
    endif

  end function unit_vector

!!!##################################################

  function vector_length(A)
     use arrays
    !###  Calculates the length of a 3x1 vector

    real(dp),intent(in) :: A(*)
    real(dp) :: vector_length
    integer :: i

    vector_length = 0.0_dp
    do i=1,3
       vector_length = vector_length + A(i)*A(i)
    enddo
    vector_length = dsqrt(vector_length)

  end function vector_length

!!!###############################################################

  function volume_internal_to_surface(triangles,vertex_xyz)
     use arrays
    ! calculates the volume enclosed by a list of surface elements

    integer,intent(in) :: triangles(:,:)
    real(dp),intent(in) :: vertex_xyz(:,:)
    real(dp) :: volume_internal_to_surface

!!! Local Variables
    integer :: ntri,num_triangles
    real(dp) :: volume,V1(3),V2(3),V3(3),P4(3)

    num_triangles = count(triangles(:,:).ne.0)/3

    P4 = sum(vertex_xyz,dim=2)/size(vertex_xyz,dim=2)

    volume = 0.0_dp

    do ntri = 1,num_triangles
       V1(1:3) = P4(1:3) - vertex_xyz(1:3,triangles(1,ntri))
       V2(1:3) = P4(1:3) - vertex_xyz(1:3,triangles(2,ntri))
       V3(1:3) = P4(1:3) - vertex_xyz(1:3,triangles(3,ntri))
       volume = volume + abs(scalar_triple_product(V1,V2,V3))
    enddo

    volume_internal_to_surface = volume/6.0_dp

  end function volume_internal_to_surface

!!!###############################################################

  function point_internal_to_surface(triangles,point_xyz,vertex_xyz)
!!! Cast a line in positive x-direction from each data point and
!!! then work out how many triangular elements it crosses. If even it is in the
!!! shape and if odd it is outside the shape
     use arrays
    integer,intent(in) :: triangles(:,:)
    real(dp),intent(in) :: point_xyz(3),vertex_xyz(:,:)
    logical :: point_internal_to_surface

!!! Local Variables
    integer :: ntri,num_triangles
    real(dp) :: area,area_triangle,cofm_surfaces(3),denominator,&
         norm_v(3),point(3),P1(3),P2(3),P3(3),u
    real(dp),parameter :: dist_tol = 1.0e-4_dp, user_tol = 1.0e-14_dp
    logical :: cross_any

    num_triangles = count(triangles(:,:).ne.0)/3

    cofm_surfaces = sum(vertex_xyz,dim=2)/size(vertex_xyz,dim=2)

! check whether the line that joins the centre of mass of the surface mesh and the point
! in question crosses ANY face. If it does, then point not inside.

    cross_any = .false.

    do ntri=1,num_triangles
       P1(1:3) = vertex_xyz(1:3,triangles(1,ntri))
       P2(1:3) = vertex_xyz(1:3,triangles(2,ntri))
       P3(1:3) = vertex_xyz(1:3,triangles(3,ntri))
       norm_v = unit_norm_to_three_points(P1,P2,P3) ! unit normal to triangle plane
       ! u = (a*x1+b*y1+c*z1+d)/(a*(x1-x2)+b*(y1-y2)+c*(z1-z2))
       denominator = norm_v(1)*(point_xyz(1)-cofm_surfaces(1)) + &
            norm_v(2)*(point_xyz(2)-cofm_surfaces(2)) + &
            norm_v(3)*(point_xyz(3)-cofm_surfaces(3))
       ! denominator is zero for line parallel to plane
       if(abs(denominator).gt.user_tol)then
          ! calculate the distance of the surface point from point_xyz
          u = (dot_product(norm_v,point_xyz)-dot_product(norm_v,P1))/denominator
          if(u.ge.0.0_dp.and.u.le.1.0_dp)then ! POTENTIALLY crosses. Test further (angle)
             point = point_xyz + u*(cofm_surfaces-point_xyz) ! projection to surface
             area = area_between_two_vectors(P1-point,P2-point)+ &
                  area_between_two_vectors(P1-point,P3-point)+area_between_two_vectors(P2-point,P3-point)
             area_triangle = area_between_two_vectors(P1-P2,P1-P3)
             if(abs(area_triangle-area).lt.dist_tol) cross_any = .true.
          endif
       endif
    enddo

    if(.not.cross_any)then
       point_internal_to_surface = .true.
    else
       point_internal_to_surface = .false.
    endif

  end function point_internal_to_surface

end module mesh_functions


      module SUB_bistbl
	USE LIB_LAPACK_BLAS
	USE LIB_LAPACK_Rdp
	contains
c
      subroutine bistbl (l, n, x, b, mv, solve, tol,
     $     mxmv, work, ldw, rwork, ldrw, iwork, info)
c
c subroutine bistbl v1.0 1995
c
c Copyright (c) 1995 by D.R. Fokkema.
c Permission to copy all or part of this work is granted,
c provided that the copies are not made or distributed
c for resale, and that the copyright notice and this
c notice are retained.
c
c THIS WORK IS PROVIDED ON AN "AS IS" BASIS.  THE AUTHOR
c PROVIDES NO WARRANTY WHATSOEVER, EITHER EXPRESSED OR IMPLIED,
c REGARDING THE WORK, INCLUDING WARRANTIES WITH RESPECT TO ITS
c MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE.
c
C Parameter list (by M.Botchev, October, 1997):
C
C l      == (input) INTEGER BiCGstab's dimension
C n      == (input) INTEGER size of the system to solve
C x      == (input/output) DOUBLE PRECISION array dimension n
C           initial guess on input, solution on output
C b      == (input) DOUBLE PRECISION array dimension n
C           right-hand side (rhs) vector
C mv     == (input) EXTERNAL name of matrix vector subroutine
C           to deliver y:=A*x by CALL mv(n,x,y)
C solve  == (input) EXTERNAL name of subroutine to perform
C           a preconditioner solve by CALL solve(n,x). This call
C           delivers solution to M*x=x, M is the left preconditioning
C           matrix, x is rhs on input and solution on output.
C tol    == (input) DOUBLE PRECISION tolerance for the relative
C           residual norm stopping criterion: ||r_k|| <= tol*||r_0||
C mxmv   == (input/output) INTEGER.  On input: maximum number of matrix
C           vector multiplications allowed to be done.  On input:
C           actual number of matrix vector multiplications done
C work   == (workspace) DOUBLE PRECISION array dimension (n,3+2*(l+1))
C ldw    == (input) INTEGER leading dimension of work (??)
C rwork  == (workspace) DOUBLE PRECISION array dimension (l+1,3+2*(l+1))
C ldrw   == (input) INTEGER leading dimension of rwork (??)
C iwork  == (workspace) INTEGER array dimension (l+1)
C info   == (output) INTEGER.  Info = 0 in case of normal computations
C           and
C           info = m < 0 - means paramater number m has an illegal value
C           info = 1 - means no convergence achieved (stopping criterion
C           is not fulfilled)
C           info = 2 - means breakdown of the algorithm (try to enlarge
C           parameter l to get rid of this)
C Three parameters were added to link the code to VAC:
C oktest == (input) LOGICAL.  Set to .true. if intermediate residuals should
C           be printed
C nonzer == (input) LOGICAL, indicates whether the initial guess is zero
C           vector.  If (nonzer.eq..false.) one matrix-vector
C           multiplication will be saved
C stc    == (input) CHARACTER*3, stopping criterion parameter:
C           stc='abs' -- use absolute stopping criterion ||r_k|| <= tol,
C           otherwise use relative stopping criterion, as indicated above

      implicit none
c
c     .. Parameters ..
c
      integer l, n, mxmv, ldw, ldrw, iwork(l+1), info
      double precision x(n), b(n), tol
      double precision work(n,3+2*(l+1)), rwork(l+1,3+2*(l+1))
c
c     .. Matrix ..
c
      external mv
      external solve
c
c     .. Local ..
c
      logical rcmp, xpdt
      integer i, j, k, nmv
      double precision alpha, beta, omega, rho0, rho1, sigma
      double precision varrho, hatgamma
      double precision rnrm0, rnrm
      double precision mxnrmx, mxnrmr, kappa0, kappal
c
c     .. Work Aliases ..
c
      integer z, zz, y0, yl, y
      integer rr, r, u, xp, bp
c
c     .. Constants ..
c
      double precision  zero, one, delta
      parameter (zero = 0d0, one = 1d0, delta = 1d-2)
c
c     .. BLAS and LAPACK ..
c
c     subroutine daxpy
c     subroutine dcopy
c     subroutine dgemv
c     subroutine dgetrf
c     subroutine dgetrs
c     subroutine dlacpy
c     subroutine dlaset
c     subroutine dsymv
c     function ddot
c     function dnrm2
c
      ![waw]double precision dnrm2, ddot
c
c     .. Intrinsic ..
c
      intrinsic abs, max, sign, sqrt
c
c     ===========================
c     .. Executable Statements ..
c     ===========================
c
      info = 0

      if (l.lt.1) info = -1
      if (n.lt.1) info = -2
      if (tol.le.zero) info = -7
      if (mxmv.lt.0) info = -8

      rr = 1
      r = rr+1
      u = r+(l+1)
      xp = u+(l+1)
      bp = xp+1
      if (bp*n.gt.ldw) info = -10

      z = 1
      zz = z+(l+1)
      y0 = zz+(l+1)
      yl = y0+1
      y = yl+1
      if (y*(l+1).gt.ldrw) info = -12

      if (info.ne.0) return
c
c     --- Initialize first residual
c
      call mv (n, x, work(1,r))
      do i=1,n
	 work(i,r) = b(i) - work(i,r)
      enddo
      call solve (n, work(1,r))
c
c     --- Initialize iteration loop
c
      nmv = 0

      call dcopy (n, work(1,r), 1, work(1,rr), 1)
      call dcopy (n, work(1,r), 1, work(1,bp), 1)
      call dcopy (n, x, 1, work(1,xp), 1)
      call dlaset ('n', n, 1, zero, zero, x, 1)
      rnrm0 = dnrm2 (n, work(1,r), 1)
      rnrm = rnrm0

      mxnrmx = rnrm0
      mxnrmr = rnrm0
      rcmp = .false.
      xpdt = .false.

      alpha = zero
      omega = one
      sigma = one
      rho0 = one
c
c     --- Iterate
c
      do while (rnrm.gt.tol*rnrm0 .and. nmv.lt.mxmv)

c
c     =====================
c     --- The BiCG part ---
c     =====================
c
	 rho0 = -omega*rho0
	 do k=1,l
	    rho1 = ddot (n, work(1,rr), 1, work(1,r+k-1), 1)
	    if (rho0.eq.zero) then
	       info = 2
	       return
	    endif
	    beta = alpha*(rho1/rho0)
	    rho0 = rho1
	    do j=0,k-1
	       do i=1,n
		  work(i,u+j) = work(i,r+j) - beta*work(i,u+j)
	       enddo
	    enddo
	    call mv (n, work(1,u+k-1), work(1,u+k))
	    call solve (n, work(1,u+k))
	    nmv = nmv+1
	    sigma = ddot (n, work(1,rr), 1, work(1,u+k), 1)
	    if (sigma.eq.zero) then
	       info = 2
	       return
	    endif
	    alpha = rho1/sigma
	    call daxpy (n, alpha, work(1,u), 1, x, 1)
	    do j=0,k-1
	       call daxpy (n, (-alpha), work(1,u+j+1), 1,
     $              work(1,r+j), 1)
	    enddo
	    call mv (n, work(1,r+k-1), work(1,r+k))
	    call solve (n, work(1,r+k))
	    nmv = nmv+1
	    rnrm = dnrm2 (n, work(1,r), 1)
	    mxnrmx = max (mxnrmx, rnrm)
	    mxnrmr = max (mxnrmr, rnrm)
	 enddo

*         print *,'2: work(1,r) = ',work(1,r),' ',work(2,r),' ',work(3,r)
*         print *,'3:         x = ',x(1),' ',x(2),' ',x(3)
*         pause

c
c     ==================================
c     --- The convex polynomial part ---
c     ==================================
c
c        --- Z = R'R
c
	 do i=1,l+1
	    call dgemv ('t', n, l+1-(i-1), one, work(1,r+i-1),
     $           n, work(1,r+i-1), 1, zero, rwork(i,z+i-1), 1)
	    call dcopy (l-(i-1), rwork(i+1,z+i-1), 1,
     $           rwork(i,z+i), l+1)
	 enddo
*         do i=1,l+1
*            write(*,'(20f9.2)') (rwork(i,j),j=1,3+2*(l+1))
*         enddo

	 call dlacpy ('a', l+1, l+1, rwork(1,z), l+1,
     $        rwork(1,zz), l+1)
	 call dgetrf (l-1, l-1, rwork(2,zz+1), l+1,
     $        iwork, info)
c
c        --- tilde r0 and tilde rl (small vectors)
c
	 rwork(1,y0) = -one
	 call dcopy (l-1, rwork(2,z), 1, rwork(2,y0), 1)
	 call dgetrs ('n', l-1, 1, rwork(2,zz+1), l+1, iwork,
     $        rwork(2,y0), l+1, info)
	 rwork(l+1,y0) = zero

	 rwork(1,yl) = zero
	 call dcopy (l-1, rwork(2,z+l), 1, rwork(2,yl), 1)
	 call dgetrs ('n', l-1, 1, rwork(2,zz+1), l+1, iwork,
     $        rwork(2,yl), l+1, info)
	 rwork(l+1,yl) = -one
c
c        --- Convex combination
c
	 call dsymv ('u', l+1, one, rwork(1,z), l+1,
     $        rwork(1,y0), 1, zero, rwork(1,y), 1)
	 kappa0 = sqrt(ddot (l+1, rwork(1,y0), 1,
     $        rwork(1,y), 1))

	 call dsymv ('u', l+1, one, rwork(1,z), l+1,
     $        rwork(1,yl), 1, zero, rwork(1,y), 1)
	 kappal = sqrt(ddot (l+1, rwork(1,yl), 1,
     $        rwork(1,y), 1))

	 call dsymv ('u', l+1, one, rwork(1,z), l+1,
     $        rwork(1,y0), 1, zero, rwork(1,y), 1)
	 varrho =
     $        ddot (l+1, rwork(1,yl), 1, rwork(1,y), 1)
     $        / (kappa0*kappal)

	 hatgamma =
     $        sign(1d0,varrho)*max(abs(varrho),7d-1)
     $        * (kappa0/kappal)

	 call daxpy (l+1, (-hatgamma), rwork(1,yl), 1,
     $        rwork(1,y0), 1)
c
c        --- Update
c
	 omega = rwork(l+1,y0)

	 call dgemv ('n', n, l, (-one), work(1,u+1), n,
     $        rwork(2,y0), 1, one, work(1,u), 1)
	 call dgemv ('n', n, l, one, work(1,r), n,
     $        rwork(2,y0), 1, one, x, 1)
	 call dgemv ('n', n, l, (-one), work(1,r+1), n,
     $        rwork(2,y0), 1, one, work(1,r), 1)

	 call dsymv ('u', l+1, one, rwork(1,z), l+1,
     $        rwork(1,y0), 1, zero, rwork(1,y), 1)
	 rnrm = sqrt (ddot (l+1, rwork(1,y0), 1,
     $        rwork(1,y), 1))
c
c     ================================
c     --- The reliable update part ---
c     ================================
c
	 mxnrmx = max (mxnrmx, rnrm)
	 mxnrmr = max (mxnrmr, rnrm)
	 xpdt = (rnrm.lt.delta*rnrm0.and.rnrm0.lt.mxnrmx)
	 rcmp = ((rnrm.lt.delta*mxnrmr.and.rnrm0.lt.mxnrmr)
     $        .or.xpdt)
	 if (rcmp) then
	    call mv (n, x, work(1,r))
	    call solve (n, work(1,r))
            nmv = nmv + 1
	    do i=1,n
	       work(i,r) =  work(i,bp) - work(i,r)
	    enddo
	    mxnrmr = rnrm
	    if (xpdt) then
	       call daxpy (n, one, x, 1, work(1,xp), 1)
	       call dlaset ('n', n, 1, zero, zero, x, 1)
	       call dcopy (n, work(1,r), 1, work(1,bp), 1)
	       mxnrmx = rnrm
	    endif
	 endif
c         print *,'rnrm =',rnrm
      enddo
c
c     =========================
c     --- End of iterations ---
c     =========================
c
      call daxpy (n, one, work(1,xp), 1, x, 1)
c
c     --- Check stopping criterion
c
      call mv (n, x, work(1,r))
      do i=1,n
	 work(i,r) = b(i) - work(i,r)
      enddo
      call solve (n, work(1,r))
      rnrm = dnrm2 (n, work(1,r), 1)
      if (rnrm.gt.tol*rnrm0) info = 1
c
c     --- Return
c
      tol = rnrm/rnrm0
      mxmv = nmv

      return
      end subroutine

      end module


program analyze_LEC
implicit none

!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
!
!  this script calculates the integrals of the LEC output file created with
!  LEC.f90
!
!  for curvilinear grid:
!  longitude (i) 0=250E, 1100=0E, 1500=40E, 1700=60E
!  latitude  (j) 0=78.5S, 518=55S, 677=45S, 866=30S, 1181=0S
!  depth     (k) 1=5m, 9=96.9m, 10=112m, 14=198m, 17=318m, 35=4125, 42=5875m
!
!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||

!===============================================================================
!  variables
!===============================================================================

! user input
integer ::                                                                     &
  imt, jmt, km, ntavg, k,                                                      &
  nrec_rPm, nrec_rPe, nrec_rKm, nrec_rKe,                                      &
  nrec_gPm, nrec_gPe, nrec_gKm, nrec_gKe,                                      &
  nrec_gPmh, nrec_gPms, nrec_gPeh, nrec_gPes,                                  &
  nrec_cPem, nrec_cKem, nrec_cPKm, nrec_cPKe,                                  &
  nrec_TEMP, nrec_PU_x, nrec_PV_y

character*120 :: LEC_folder,geometry1_file,geometry2_file,LEC_file,            &
  output_file, output_folder

character*3   :: year

real,    dimension(:),     allocatable :: dz,area,tdepth

real,    dimension(:,:),   allocatable ::                                      &
  DXT, DYT, TAREA, DXU, DYU, UAREA, geometry2,                                 &
  gPm, gPe, gKm, gKe, gPmh, gPeh, gPms, gPes

real,    dimension(:,:,:), allocatable ::                                      &
  rPm, rPe, rKm, rKe, cPem, cKem, cPKm, cPKe, TEMP, DZT, DZU, PU_x, PV_y, FBC

imt = 3600
jmt = 2400
km  =   42

nrec_rPm  =    1
nrec_rPe  =   43
nrec_rKm  =   85
nrec_rKe  =  127
nrec_gPm  =  169
nrec_gPe  =  170
nrec_gKm  =  171
nrec_gKe  =  172
nrec_gPmh =  173
nrec_gPms =  174
nrec_gPeh =  175
nrec_gPes =  176
nrec_cPem =  177
nrec_cKem =  219
nrec_cPKm =  261
nrec_cPKe =  303
nrec_TEMP =  345
nrec_PU_x =  387
nrec_PV_y =  429

write (*,*) ''
write (*,*) '--- ANALYZING ENERGY BUDGET ---'
write (*,*) ''

!===============================================================================
!  INPUT
!===============================================================================

read  (*,'(a120)') LEC_file
read  (*,'(a3)')   year
read  (*,*)        ntavg

output_folder = '/home/dijkbio/andre/LEC/results/analyze_LEC/'
if      ( ntavg==1  ) then
  output_file = trim(output_folder)//'analysis_LEC_1_'//year
else if ( ntavg==5  ) then
  output_file = trim(output_folder)//'analysis_LEC_5_'//year
else if ( ntavg==11 ) then
  output_file = trim(output_folder)//'analysis_LEC_11_'//year
endif
write(*,*) ntavg, year
write(*,*) output_file
write(*,*) output_folder
!===============================================================================
!  GEOMETRY
!===============================================================================

LEC_folder      = '/home/dijkbio/andre/LEC/'
geometry1_file  = trim(LEC_folder)//'input/geometry1'
geometry2_file  = trim(LEC_folder)//'input/geometry2'

! read 2D geometry fields
allocate( DXT(imt,jmt), DYT(imt,jmt), TAREA(imt,jmt), DZT(imt,jmt,km),         &
          DXU(imt,jmt), DYU(imt,jmt), UAREA(imt,jmt), DZU(imt,jmt,km) )
open(2,file=geometry1_file,access='direct',form='unformatted',recl=imt*jmt,    &
       status='old')
read(2,rec=1) DXT ! [m]
read(2,rec=2) DXU ! [m]
read(2,rec=3) DYT ! [m]
read(2,rec=4) DYU ! [m]
read(2,rec=5) TAREA ! [m^2]
read(2,rec=6) UAREA ! [m^2]
do k=1,km
  read(2,rec=6+   k) DZT(:,:,k) ! [m]
  read(2,rec=6+km+k) DZU(:,:,k) ! [m]
enddo
close(2)

! read 1D geometry fields
! all real: k,dz[m],tdepth[m],area[m^2],p[bar]
allocate( geometry2(6,km),dz(km),tdepth(km),area(km) )
open(2,file=geometry2_file,access='direct',form='unformatted',recl=6,     &
       status='old')
do k=1,km
  read(2,rec=k) geometry2(:,k)
enddo
dz(:)     = geometry2(2,:)
tdepth(:) = geometry2(3,:)
area(:)   = geometry2(4,:)
close(2)

!===============================================================================
!  LOAD LEC FIELDS
!===============================================================================

allocate(                                                                      &
rPm(imt,jmt,km),  rPe(imt,jmt,km),  rKm(imt,jmt,km),  rKe(imt,jmt,km),         &
gPm(imt,jmt),     gPe(imt,jmt),     gKm(imt,jmt),     gKe(imt,jmt),            &
gPmh(imt,jmt),    gPms(imt,jmt),    gPeh(imt,jmt),    gPes(imt,jmt),           &
cPem(imt,jmt,km), cKem(imt,jmt,km), cPKm(imt,jmt,km), cPKe(imt,jmt,km),        &
TEMP(imt,jmt,km), PU_x(imt,jmt,km), PV_y(imt,jmt,km) )

!open file
open (1,file=LEC_file,access='direct',form='unformatted',recl=imt*jmt,  &
        status='unknown')
write (*,*) 'file: ', LEC_file

call load_3D_field(1,nrec_rPm ,rPm )
call load_3D_field(1,nrec_rPe ,rPe )
call load_3D_field(1,nrec_rKm ,rKm )
call load_3D_field(1,nrec_rKe ,rKe )

call load_2D_field(1,nrec_gPm ,gPm )
call load_2D_field(1,nrec_gPe ,gPe )
call load_2D_field(1,nrec_gKm ,gKm )
call load_2D_field(1,nrec_gKe ,gKe )
call load_2D_field(1,nrec_gPmh,gPmh)
call load_2D_field(1,nrec_gPms,gPms)
call load_2D_field(1,nrec_gPeh,gPeh)
call load_2D_field(1,nrec_gPes,gPes)

call load_3D_field(1,nrec_cPem,cPem)
call load_3D_field(1,nrec_cKem,cKem)
call load_3D_field(1,nrec_cPKm,cPKm)
call load_3D_field(1,nrec_cPKe,cPKe)
call load_3D_field(1,nrec_TEMP,TEMP)
call load_3D_field(1,nrec_PU_x,PU_x)
call load_3D_field(1,nrec_PV_y,PV_y)

close(1)

!===============================================================================
!  CALCULATIONS
!===============================================================================
write (*,*) ''
write (*,*) 'CALCULATIONS'

! Southern Ocean integrals [90S,30S]
call regional_integrals(1,1,imt,866,'SO30')
! Southern Ocean integrals [90S,30S]x[60W,30E]
call regional_integrals(500,1,1400,866,'SA30')
! Southern Ocean/Weddell Gyre integrals [90S,30S]x[50W,60E]
call regional_integrals(600,1,1700,866,'WG30')
! Southern Ocean integrals [90S,45S]
call regional_integrals(1,1,imt,677,'SO45')
! Southern Ocean integrals [90S,55S]
call regional_integrals(1,1,imt,518,'SO55')
! Weddell Gyre to Kerguelen Plateau  integrals [90S,55S]x[35W,80E]
call regional_integrals(750,1,1900,600,'WGKP')
! North of Southern Ocean [30S,90N]
call regional_integrals(1,867,imt,jmt,'NO30P')
! North of Southern Ocean [30S,90N]
call regional_integrals(800,1,1300,518,'SOMSR')
write (*,*) '>>> done writing output'

!===============================================================================
!===============================================================================
contains

!===============================================================================
subroutine regional_integrals(imin,jmin,imax,jmax,area_name)

character*4         :: area_name
integer, intent(in) :: imin,jmin,imax,jmax
integer, parameter  :: imt=3600,jmt=2400,km=42
real                ::                                                         &
  gPm_int ,gPe_int ,gKm_int ,gKe_int ,                                         &
  gPmh_int,gPeh_int,gPms_int,gPes_int,                                         &
  rPm_int ,rPe_int ,rKm_int ,rKe_int ,                                         &
  cPem_int,cKem_int,cPKm_int,cPKe_int,                                         &
  rPm_int_top ,rPe_int_top ,rKm_int_top ,rKe_int_top ,                         &
  cPem_int_top,cKem_int_top,cPKm_int_top,cPKe_int_top,                         &
  rPm_int_bot ,rPe_int_bot ,rKm_int_bot ,rKe_int_bot ,                         &
  cPem_int_bot,cKem_int_bot,cPKm_int_bot,cPKe_int_bot,                         &
  ohc_int,ohc_int_top,ohc_int_bot,                                             &
  PU_x_int,PU_x_int_top,PU_x_int_bot,                                          &
  PV_y_int,PV_y_int_top,PV_y_int_bot

! generation
call surf_int_2D(imin,jmin,imax,jmax,gPm,TAREA,DZT(:,:,1),gPm_int)
call surf_int_2D(imin,jmin,imax,jmax,gPe,TAREA,DZT(:,:,1),gPe_int)
call surf_int_2D(imin,jmin,imax,jmax,gKm,TAREA,DZT(:,:,1),gKm_int)
call surf_int_2D(imin,jmin,imax,jmax,gKe,TAREA,DZT(:,:,1),gKe_int)

call surf_int_2D(imin,jmin,imax,jmax,gPmh,TAREA,DZT(:,:,1),gPmh_int)
call surf_int_2D(imin,jmin,imax,jmax,gPms,TAREA,DZT(:,:,1),gPms_int)
call surf_int_2D(imin,jmin,imax,jmax,gPeh,TAREA,DZT(:,:,1),gPeh_int)
call surf_int_2D(imin,jmin,imax,jmax,gPes,TAREA,DZT(:,:,1),gPes_int)

! full depth
call r_c_integrals(imin,jmin,1,imax,jmax,km,                                   &
                   rPm_int,rPe_int,rKm_int,rKe_int,                            &
                   cPem_int,cKem_int,cPKm_int,cPKe_int,                        &
                   ohc_int, PU_x_int, PV_y_int)

! top
call r_c_integrals(imin,jmin,1,imt,jmt,17,                                     &
                   rPm_int_top,rPe_int_top,rKm_int_top,rKe_int_top,            &
                   cPem_int_top,cKem_int_top,cPKm_int_top,cPKe_int_top,        &
                   ohc_int_top, PU_x_int_top, PV_y_int_top)

! bottom
call r_c_integrals(imin,jmin,35,imt,jmt,km,                                    &
                   rPm_int_bot,rPe_int_bot,rKm_int_bot,rKe_int_bot,            &
                   cPem_int_bot,cKem_int_bot,cPKm_int_bot,cPKe_int_bot,        &
                   ohc_int_bot, PU_x_int_bot, PV_y_int_bot)

! output
open(3,file=trim(output_file)//'_'//area_name//'.out',form='formatted')

200 FORMAT (40(A,","),A)
201 FORMAT (40(E15.7,","),E15.7)
write (3,200)                                                                  &
  'gPm' ,'gPe' ,'gKm' ,'gKe' ,                                                 &
  'gPmh','gPeh','gPms','gPes',                                                 &
  'rPm' ,'rPe' ,'rKm' ,'rKe' ,                                                 &
  'cPem','cKem','cPKm','cPKe',                                                 &
  'rPm_top' ,'rPe_top' ,'rKm_top' ,'rKe_top' ,                                 &
  'cPem_top','cKem_top','cPKm_top','cPKe_top',                                 &
  'rPm_bot' ,'rPe_bot' ,'rKm_bot' ,'rKe_bot' ,                                 &
  'cPem_bot','cKem_bot','cPKm_bot','cPKe_bot',                                 &
  'temp_int','temp_int_top','temp_int_bot',                                    &
  'PU_x_int','PU_x_int_top','PU_x_int_bot',                                    &
  'PV_y_int','PV_y_int_top','PV_y_int_bot'
write (3,201)                                                                  &
  gPm_int ,gPe_int ,gKm_int ,gKe_int ,                                         &
  gPmh_int,gPeh_int,gPms_int,gPes_int,                                         &
  rPm_int ,rPe_int ,rKm_int ,rKe_int ,                                         &
  cPem_int,cKem_int,cPKm_int,cPKe_int,                                         &
  rPm_int_top ,rPe_int_top ,rKm_int_top ,rKe_int_top ,                         &
  cPem_int_top,cKem_int_top,cPKm_int_top,cPKe_int_top,                         &
  rPm_int_bot ,rPe_int_bot ,rKm_int_bot ,rKe_int_bot ,                         &
  cPem_int_bot,cKem_int_bot,cPKm_int_bot,cPKe_int_bot,                         &
  ohc_int,ohc_int_top,ohc_int_bot,                                             &
  PU_x_int,PU_x_int_top,PU_x_int_bot,                                          &
  PV_y_int,PV_y_int_top,PV_y_int_bot
close(3)
end subroutine regional_integrals
!===============================================================================

!===============================================================================
subroutine r_c_integrals(imin,jmin,kmin,imax,jmax,kmax,                        &
                         rPm_int,rPe_int,rKm_int,rKe_int,                      &
                         cPem_int,cKem_int,cPKm_int,cPKe_int,                  &
                         ohc_int, PU_x_int, PV_y_int )

integer, intent(in) :: imin,jmin,kmin,imax,jmax,kmax
real, intent(out)   :: rPm_int,rPe_int,rKm_int,rKe_int,                        &
                       cPem_int,cKem_int,cPKm_int,cPKe_int,                    &
                       ohc_int, PU_x_int, PV_y_int

! reservoirs
call vol_int_full(imin,jmin,kmin,imax,jmax,kmax,rPm,TAREA,dz,DZT,rPm_int)
call vol_int_full(imin,jmin,kmin,imax,jmax,kmax,rPe,TAREA,dz,DZT,rPe_int)
call vol_int_part(imin,jmin,kmin,imax,jmax,kmax,rKm,TAREA,dz,DZT,rKm_int)
call vol_int_part(imin,jmin,kmin,imax,jmax,kmax,rKe,TAREA,dz,DZT,rKe_int)

! exchange terms
call vol_int_full(imin,jmin,kmin,imax,jmax,kmax,cPem,TAREA,dz,DZT,cPem_int)
call vol_int_part(imin,jmin,kmin,imax,jmax,kmax,cKem,TAREA,dz,DZT,cKem_int)
call vol_int_full(imin,jmin,kmin,imax,jmax,kmax,cPKm,TAREA,dz,DZT,cPKm_int)
call vol_int_full(imin,jmin,kmin,imax,jmax,kmax,cPKe,TAREA,dz,DZT,cPKe_int)

! OHC
call vol_int_part(imin,jmin,kmin,imax,jmax,kmax,TEMP,TAREA,dz,DZT,ohc_int)

! pressure work terms
call vol_int_full(imin,jmin,kmin,imax,jmax,kmax,PU_x,TAREA,dz,DZT,PU_x_int)
call vol_int_full(imin,jmin,kmin,imax,jmax,kmax,PV_y,TAREA,dz,DZT,PV_y_int)

end subroutine r_c_integrals
!===============================================================================

!===============================================================================
!===============================================================================
end program


      subroutine chkbnd(x0,y0,z0,r02,i0,
     >                  xp,dp2,nbnd,isigma)
c     ================================================================
c
      implicit   none
c
      integer    i0
      integer    nbnd
      integer    isigma
      integer    j
      integer    jp
      integer    k
      integer    kp
      integer    njoint
      integer    ierr
      integer    nbm1
      integer    nbm2
      integer    incr
c
      real*8     x0
      real*8     y0
      real*8     z0
      real*8     r02
      real*8     xp(3,nbnd)
      real*8     dp2(nbnd)
      real*8     xm(9)
      real*8     xminv(9)
      real*8     xc(4)
      real*8     yc(4)
      real*8     zc(4)
c
c     ****************************************************************
c     check if the plane defined by (x0,y0,z0) is an actual boundary
c     plane...........................................................
c     ****************************************************************
c
c     ================================================================
c     The idea is to find the number of joint points with any other
c     two planes not being outside the polyhedron. If it is more than
c     three, the plane is a boundary plane............................
c     ================================================================
      xm(1)=x0/r02
      xm(2)=y0/r02
      xm(3)=z0/r02
      njoint=0
      nbm2=nbnd-2
      nbm1=nbnd-1
      kp=0
      do while(njoint.le.2 .and. kp.le.nbm2)
         kp=kp+1
         k=mod(kp+i0-1,nbnd)+1
         xm(4)=xp(1,k)/dp2(k)
         xm(5)=xp(2,k)/dp2(k)
         xm(6)=xp(3,k)/dp2(k)
         do jp=kp+1,nbm1
            j=mod(jp+i0-1,nbnd)+1
c           write(6,'(''i0,k,j ='',3i5)')i0,k,j
            xm(7)=xp(1,j)/dp2(j)
            xm(8)=xp(2,j)/dp2(j)
            xm(9)=xp(3,j)/dp2(j)
c           ----------------------------------------------------------
            call invm3(xm,xminv,ierr)
c           ----------------------------------------------------------
            if(ierr.eq.0) then
c              -------------------------------------------------------
               call celbnd(xminv(1)+xminv(2)+xminv(3),
     >                     xminv(4)+xminv(5)+xminv(6),
     >                     xminv(7)+xminv(8)+xminv(9),
     >                     xp,nbnd,
     >                     xc,yc,zc,njoint,incr)
c              -------------------------------------------------------
            endif
         enddo
      enddo
c
      if(njoint.ge.3) then
         isigma=1
      else
         isigma=0
      endif
c
      return
      end