module diffoperpack
  !========================================================================
  !
  !  DIFFOPERPACK
  !
  !
  !	Pack with discrete differential operators routines
  !      for the geodesic sphere
  !
  !	Pedro da Silva Peixoto (pedrosp@ime.usp.br)
  !	Nov 2011
  !
  !========================================================================

  !Global kinds and constants
  use constants, only: &
       i4, &
       r8

  !Mesh and fields structures/types
  use datastruct, only: &
       grid_structure, &
       scalar_field, &
       rbf_matrix_structure, &
       vector_field_cart, &
       vector_variable_edge, &
       vectorinterpol_methods

  !Spherical mesh pack
  use smeshpack, only: &
       arclen, &
       cross_product, &
       insidetrmesh, &
       modint, &
       proj_vec_sphere

  !Interpolation pack
  use interpack, only: &
       rbfvec_matrix_build, &
       vec_remap_trc2ed, &
       vec_remap_trv2ed, &
       vec_remap_trv2trc, &
       vector_reconstruct

  implicit none

contains

  !========================================================================
  !    Discrete integral operators
  !========================================================================

  function int_simpson(s, f)
    !-----------------------------------------------
    !  Simpsons integral rule for 3 points on an arc
    !   not necessarily equally spaced
    !   s -> relative position between the points
    !   f -> values on points
    !-----------------------------------------------

    !Points positions on arc
    real (r8), intent(in) :: s(1:3)
    !Values of the function
    real (r8), intent(in) :: f(1:3)
    !Points positions
    real (r8):: int_simpson
    real (r8):: l
    real (r8):: l2
    real (r8):: l3

    !Aux
    real (r8):: g(1:3)
    real (r8):: a
    real (r8):: b
    real (r8):: c

    l=s(3)-s(1)
    l2=(s(3)*s(3)-s(1)*s(1))/2
    l3=( s(3)*s(3)*s(3)-s(1)*s(1)*s(1) )/3

    g(1)=f(1)/((s(1)-s(2))*(s(1)-s(3)))
    g(2)=f(2)/((s(2)-s(1))*(s(2)-s(3)))
    g(3)=f(3)/((s(3)-s(1))*(s(3)-s(2)))

    !int_{x=s1..s3} (a x^2 + b x + c)
    a=sum(g)
    b=-(g(1)*(s(2)+s(3))+ g(2)*(s(1)+s(3)) + g(3)*(s(1)+s(2)))
    c= g(1)*s(2)*s(3) + g(2)*s(1)*s(3) + g(3)*s(1)*s(2)
    !print*, "s", s
    !print*, "f", f
    !print*, "a,b,c",a, b, c
    !print*, "ls", l, l2, l3
    int_simpson=a*l3+b*l2+c*l

    return
  end function int_simpson

  function int_trp(s, f)
    !-----------------------------------------------
    !  Trapezoidal integral rule for 2 points on an arc
    !   s -> relative position between the points
    !   f -> values on points
    !-----------------------------------------------

    !Points positions on arc
    real (r8), intent(in) :: s(1:2)
    !Values of the function
    real (r8), intent(in) :: f(1:2)
    !Points positions
    real (r8):: int_trp

    int_trp=(s(2)-s(1))*(f(1)+f(2))/2

    return
  end function int_trp

  !========================================================================
  !    Discrete DIVERGENCE operators
  !========================================================================

  function div_cell_Cgrid(i, u, mesh)
    !-----------------------------------------------------------
    ! Given a the normal components of a vector field defined on  edges
    !  calculates the numerical divergence based on Gauss Theorem
    ! Valid for C grids only
    !-----------------------------------------------------------
    !   i -> node if u%pos=3, tr if u%pos=2
    !   u -> scalarfield defined on Triangle or hexagon edges (normal comp only)
    !   mesh -> mesh structure
    !
    !-----------------------------------------------------------
    !Node for divergence calculation
    integer (i4), intent(in) :: i

    !Input variable with vectors
    type(scalar_field), intent(in) :: u

    real (r8):: div_cell_Cgrid

    !Mesh in which the variable belongs
    type(grid_structure), intent(in) :: mesh

    !Logical var for considering or not divergente average
    !That is, division or not by the cell area
    !logical, intent(in) :: average

    !Temp. vars
    real (r8):: divtmp
    real (r8):: signcor
    real (r8):: nrv
    !real (r8), allocatable :: vec(:)

    !Counters
    integer (i4):: j
    integer (i4):: k

    !Check if vectors on hexag/pent edges

    select case(u%pos)
    case(2)
       !For all edges forming the triangle
       divtmp=0_r8
       do j=1, 3
          !Get edge index
          k=mesh%tr(i)%ed(j)
          !print*, "Edge:", j
          !Get edge outer normal related to the hexagon
          signcor=real(mesh%tr(i)%nr(j), r8)
          !Calculate normal component
          nrv=signcor*u%f(k)
          !Calculate numerical integration
          divtmp=divtmp+nrv*mesh%ed(k)%leng
       end do
       !if(average)then
       !Averaged divergence (division by cell area)
       divtmp=divtmp/mesh%tr(i)%areag
       !end if
    case(3)
       !For all edges forming the hexagon
       divtmp=0._r8
       do j=1, mesh%v(i)%nnb
          !Get edge index
          k=mesh%v(i)%ed(j)
          !print*, "Edge:", j
          !Get edge outer normal related to the hexagon
          signcor=real(mesh%hx(i)%nr(j), r8)
          !Calculate normal component
          nrv=signcor*u%f(k) !dot_product(v%p(k)%v, mesh%edhx(k)%nr)
          !Calculate numerical integration
          divtmp=divtmp+nrv*mesh%edhx(k)%leng
       end do
       !if(average)then
       !Averaged divergence (division by cell area)
       divtmp=divtmp/mesh%hx(i)%areag
       !end if
    case(6)
       !For all edges forming the hexagon
       divtmp=0._r8
       do j=1, mesh%v(i)%nnb
          !Get edge index
          k=mesh%v(i)%ed(j)
          !print*, "Edge:", j
          !Get edge outer normal related to the hexagon
          signcor=real(mesh%hx(i)%ttgout(j), r8)
          !Calculate normal component
          nrv=signcor*u%f(k) !dot_product(v%p(k)%v, mesh%edhx(k)%nr)
          !Calculate numerical integration
          divtmp=divtmp+nrv*mesh%edhx(k)%leng
       end do
       !if(average)then
       !Averaged divergence (division by cell area)
       divtmp=divtmp/mesh%hx(i)%areag
       !end if
    case default
       print*, "div_cell ERROR: Vectors not on hx or tr edges (pos=2,3, 6).", u%pos
       stop
    end select

    !Assign returnable variable the result
    div_cell_Cgrid=divtmp

    return
  end function div_cell_Cgrid

  function grad_edge_Cgrid(ed, h, pos, mtd, mesh)
    !-----------------------------------------------------------
    ! Given a scalar field h calculates the gradient at edge "ed"
    ! with orietation depending on the position "pos" wanted
    !
    ! If pos=3 - normal to edhx edge is used as reference
    !   (velocities at midpoint of Voronoi cell edge)
    ! If pos=6 - tangent to ed is used as reference
    !   (velocities at intersection of triangle and Voronoi edges)
    !
    ! MTD - method to be used
    ! If mtd="trsk" - use simple differences of values on cells that
    !     share the edge (2nd order only if pos=6)
    ! If mtd="bary" - use gradient of barycentric coordinate
    !     (2nd order with pos = 3 and 6)
    !     *may affect mimetic properties
    !
    ! Valid for C grids only
    !-----------------------------------------------------------
    !Node for divergence calculation
    integer (i4), intent(in) :: ed

    !Position to put gradient
    integer (i4), intent(in) :: pos

    !Method to be used
    character (len=4), intent(in) :: mtd

    !Input variable with vectors
    type(scalar_field), intent(in) :: h

    real (r8):: grad_edge_Cgrid

    !Mesh in which the variable belongs
    type(grid_structure), intent(in) :: mesh

    !Logical var for considering or not divergente average
    !That is, division or not by the cell area
    !logical, intent(in) :: average

    !Temp. vars
    real (r8), dimension(1:3):: gradtmp
    real (r8), dimension(1:3):: vectmp
    real (r8):: signcor
    !real (r8):: nrv
    !real (r8), allocatable :: vec(:)
    integer(i4):: i, k

    !Check if vectors on hexag/pent edges

    select case(pos)
    case(3)
       if(trim(mtd)=="trsk")then
          signcor=dsign( 1._r8, dot_product(mesh%edhx(ed)%nr, &
               mesh%v(mesh%edhx(ed)%sh(2))%p-mesh%v(mesh%edhx(ed)%sh(1))%p ))
          grad_edge_Cgrid=signcor*(h%f(mesh%edhx(ed)%sh(2))-h%f(mesh%edhx(ed)%sh(1)))
          grad_edge_Cgrid=grad_edge_Cgrid/mesh%ed(ed)%leng

       elseif(trim(mtd)=="bary")then
          !Find triangle that cointains the midpoint of the edge
          if(insidetrmesh(mesh%edhx(ed)%c%p, mesh%edhx(ed)%v(1) , mesh))then
             k=mesh%edhx(ed)%v(1)
          elseif(insidetrmesh(mesh%edhx(ed)%c%p, mesh%edhx(ed)%v(2) , mesh))then
             k=mesh%edhx(ed)%v(2)
          else
             print*, "grad_edge_Cgrid error:"
             print*, "Could not fit edge center into triangles"
             stop
          end if
          !print*, ed, k

          !Calculate vector gradient of field using barycentric coords
          gradtmp=0.
          do i=1, 3
             !get vertices
             !j=mesh%tr(k)%v(i)
             !get edge indexes
             !m=modint(i+1, 3)
             !l=mesh%tr(k)%ed(m)
             !vectmp=-mesh%ed(l)%nr*mesh%tr(k)%nr(m)*mesh%ed(l)%leng*h%f(j)
             vectmp=mesh%v(mesh%tr(k)%v(modint(i+2, 3)))%p-mesh%v(mesh%tr(k)%v(modint(i+1, 3)))%p
             gradtmp=gradtmp+h%f(mesh%tr(k)%v(i))*&
                  cross_product(mesh%edhx(ed)%c%p, vectmp)/mesh%tr(k)%areap/2._r8
             !print*, mesh%tr(k)%v(modint(i+2, 3)), mesh%tr(k)%v(modint(i+1, 3))
          end do
          gradtmp=proj_vec_sphere(gradtmp, mesh%edhx(ed)%c%p)
          grad_edge_Cgrid=dot_product(gradtmp, mesh%edhx(ed)%nr)
       end if

    case(6)
       ! Obs: the tangent of a triangle edge (which is used as normal
       !   of the voronoi cell edges) is always defined such
       !   that it point from its vertex 1 to its vertex 2
       !   Therefore, the gradient needs no correction term (n_ei)
       !   NOT normalized to earth radius
       grad_edge_Cgrid=(h%f(mesh%ed(ed)%v(2))-h%f(mesh%ed(ed)%v(1)))
       grad_edge_Cgrid=grad_edge_Cgrid/mesh%ed(ed)%leng
    case default
       print*, "grad_edge_Cgrid ERROR: position not set for HX C gridon hx or tr edges (pos=3, 6)."
       stop
    end select

    return
  end function grad_edge_Cgrid

  subroutine div_mesh_hx_trp(v, div, mesh)
    !-----------------------------------------------------------
    ! Given a vector variable defined on hexagonal edges
    !  calculates the numerical divergence based on Gauss Theorem
    !-----------------------------------------------------------
    !Variable with vectors on hexagonal corners (triang. cc)
    type(vector_field_cart), intent(in) :: v

    !Output variable for divergence in scalar variable defined on
    ! hexagon centers
    type(scalar_field), intent(inout) :: div

    !Mesh in which the variable belongs
    type(grid_structure), intent(in) :: mesh

    !Temp. vars
    real (r8):: divtmp
    real (r8):: sign
    real (r8), dimension(1:3) :: nr(1:3)
    real (r8), dimension(1:3) :: f(1:2)
    real (r8), dimension(1:3) :: s(1:2)

    !Counters
    integer (i4):: i
    integer (i4):: j
    integer (i4):: ed
    integer (i4):: tr(1:2)

    div%pos=0
    div%n=mesh%nv
    if(.not.allocated(div%f))then
       allocate(div%f(1:div%n))
    end if

    !call vec_edhx2trc_interpol(ved, v, mesh)

    !For all hexagons
    do i=1, mesh%nv
       !do i=8,8
       divtmp=0
       do j=1, mesh%v(i)%nnb

          !Get edge index
          ed=mesh%v(i)%ed(j)
          !print*,"ed: ", ed

          !Get corners (triang circumcenters)
          tr=mesh%edhx(ed)%v
          !print*,"tr: ", tr(1:2)

          !Sign correction for this hx edge
          sign=real(mesh%hx(i)%nr(j), r8)
          !print*,"sign: ", sign

          !Get normal to edge with correction
          nr=sign*mesh%edhx(ed)%nr
          !print*,"Normal: ", nr

          !Get first corner vector dot prod normal
          s(1)=0
          f(1)=dot_product(v%p(tr(1))%v,  nr)
          !print*, "V1:", v%p(tr(1))%v
          !print*, "s1, f1:", s(1), f(1)

          !Get other corner vector dot prod normal
          s(2)=mesh%edhx(ed)%leng
          f(2)=dot_product(v%p(tr(2))%v,  nr)

          divtmp=divtmp+int_trp(s, f)
          !divtmp=divtmp+(s(3)/6)*(f(1)+4*f(2)+f(3))
          !print*,"simp:", int_simpson(s, f)
       end do
       div%f(i)=divtmp/mesh%hx(i)%areag
       !print*, "Hx:", i, "Div:", divtmp
    end do

  end subroutine div_mesh_hx_trp

  subroutine div_mesh_hx_simp(ved, v, div, mesh)
    !-----------------------------------------------------------
    ! Given a vector variable defined on hexagonal edges
    !  calculates the numerical divergence based on Gauss Theorem
    !-----------------------------------------------------------
    !Input variable with vectors on hexagonal edges midpoints
    type(vector_variable_edge), intent(in) :: ved

    !Output variable for divergence in scalar variable defined on
    ! hexagon centers
    type(scalar_field), intent(inout) :: div

    !Mesh in which the variable belongs
    type(grid_structure), intent(in) :: mesh

    !Variable with vectors on hexagonal corners (triang. cc)
    type(vector_field_cart):: v

    !Temp. vars
    real (r8):: divtmp
    real (r8):: signc
    real (r8), dimension(1:3) :: nr(1:3)
    real (r8), dimension(1:3) :: f(1:3)
    real (r8), dimension(1:3) :: s(1:3)

    !Counters
    integer (i4):: i
    integer (i4):: j
    integer (i4):: ed
    integer (i4):: tr(1:2)

    div%pos=0
    div%n=mesh%nv
    if(.not.allocated(div%f))then
       allocate(div%f(1:div%n))
    end if

    !call vec_edhx2trc_interpol(ved, v, mesh)

    !For all hexagons
    do i=1, mesh%nv
       !do i=8,8
       divtmp=0
       do j=1, mesh%v(i)%nnb

          !Get edge index
          ed=mesh%v(i)%ed(j)
          !print*,"ed: ", ed

          !Get corners (triang circumcenters)
          tr=mesh%edhx(ed)%v
          !print*,"tr: ", tr(1:2)

          !Sign correction for this hx edge
          signc=real(mesh%hx(i)%nr(j), r8)
          !print*,"sign: ", sign

          !Get normal to edge with correction
          nr=signc*mesh%edhx(ed)%nr
          !print*,"Normal: ", nr

          !Get first corner vector dot prod normal
          s(1)=0
          f(1)=dot_product(v%p(tr(1))%v,  nr)
          !print*, "V1:", v%p(tr(1))%v
          !print*, "s1, f1:", s(1), f(1)

          !Get edge's midpoint vector
          s(2)=arclen(mesh%tr(tr(1))%c%p, mesh%edhx(ed)%c%p)
          f(2)=signc*ved%nr(ed)
          !print*, "s2, f2:", s(2), f(2)

          !Get other corner vector dot prod normal
          s(3)=s(2)+arclen(mesh%edhx(ed)%c%p, mesh%tr(tr(2))%c%p)
          !print*, s(3)-s(2)-s(2)
          f(3)=dot_product(v%p(tr(2))%v,  nr)
          !print*, "V3:", v%p(tr(2))%v
          !print*, "s3, f:", s(3), f(3)

          divtmp=divtmp+int_simpson(s, f)
          !divtmp=divtmp+(s(3)/6)*(f(1)+4*f(2)+f(3))
          !print*,"simp:", int_simpson(s, f)
       end do
       div%f(i)=divtmp/mesh%hx(i)%areag
       !print*, "Hx:", i, "Div:", divtmp
    end do

  end subroutine div_mesh_hx_simp

  !  subroutine divergence(v, div, mesh, average)
  !    !-----------------------------------------------------------
  !    ! Given a vector variable defined on either triangles' edges
  !    ! or hexagonals/pentagonals' edges calculates the numerical
  !    ! divergence average or integral based on Divergence Theorem
  !    !
  !    ! Input
  !    !   v -> vector variable defined on edges
  !    !   v%pos=0 -> triangle edges
  !    !   v%pos=1 -> hexag edges
  !    !   mesh -> mesh structure
  !    !
  !    !
  !    ! average = .true. -> Divides divergence cell integral by cell area
  !    ! average = .false. -> Don't divide by cell area
  !    !
  !    ! Output
  !    !   div  -> divergence on triangle or hexagon centers
  !    !  div%pos=1 -> triangle centers
  !    !  div%pos=0 -> hexagon centers
  !    !-----------------------------------------------------------
  !    !Input variable with vectors on triangles edge's midpoints
  !    type(vector_variable_edge), intent(in) :: v
  !
  !    !Output variable for divergence in scalar variable defined on
  !    ! triangle centers
  !    type(interpolable_variable), intent(inout) :: div
  !
  !    !Mesh in which the variable belongs
  !    type(grid_structure), intent(in) :: mesh
  !
  !    !Logical var for considering or not divergente average
  !    !That is, division or not by the cell area
  !    logical, intent(in):: average
  !
  !    !Temp. vars
  !    real (r8):: divtmp
  !    real (r8):: signc
  !    real (r8):: a
  !    real (r8):: nrm
  !    !real (r8), allocatable :: vec(:)
  !
  !    !Counters
  !    integer (i4):: i
  !    integer (i4):: j
  !    integer (i4):: k
  !
  !
  !    if(v%pos==0)then
  !       !Vectors on triangles' edges
  !
  !       !Divergence positioned on triangle centres
  !       div%pos=1
  !       div%n=mesh%nt
  !
  !       !Allocate memory for divergence
  !       if(.not.allocated(div%f))then
  !          allocate(div%f(1:div%n))
  !       end if
  !
  !       !For all triangles
  !       do i=1, mesh%nt
  !          !For all edges forming the triangle
  !          divtmp=0_r8
  !          do j=1, 3
  !             !Get edge index
  !             k=mesh%tr(i)%ed(j)
  !             !Get edge outer normal related to the triangle
  !             signc=real(mesh%tr(i)%nr(j), r8)
  !             !Get the norm of the edge vector
  !             nrm=dsqrt((v%nr(k))**2+(v%tg(k))**2)
  !             !Calculate sin(alpha), angle between v%nr and edge tangent
  !             a=signc*v%nr(k)/nrm
  !             !Calculate numerical integral term
  !             divtmp=divtmp+signc*v%nr(k)*mesh%ed(k)%leng
  !          end do
  !          if(average)then
  !             !Averaged divergence (division by cell area)
  !             divtmp=divtmp/mesh%tr(i)%areag
  !          end if
  !          !Assign returnable variable the result
  !          div%f(i)=divtmp
  !
  !       end do
  !    else
  !       !Vectors on hexag/pent edges
  !
  !       !Divergence on triangle nodes/hexagon centers
  !       div%pos=0
  !       div%n=mesh%nv
  !
  !       !Allocate memory for divergence
  !       if(.not.allocated(div%f))then
  !          allocate(div%f(1:div%n))
  !       end if
  !       !For all hexagons
  !       do i=1, mesh%nv
  !          !For all edges forming the hexagon
  !          !print*, "---- Hexagon:", hx , " ----"
  !          divtmp=0_r8
  !          do j=1, mesh%v(i)%nnb
  !             !Get edge index
  !             k=mesh%v(i)%ed(j)
  !             !print*, "Edge:", j
  !             !Get the norm of the edge vector
  !             nrm=dsqrt((v%nr(k))**2+(v%tg(k))**2)
  !             !Get edge outer normal related to the hexagon
  !             signc=real(mesh%hx(i)%nr(j), r8)
  !             !Calculate sin(alpha), angle between v%nr and edge tangent
  !             a=signc*v%nr(k)/nrm
  !             !Calculate numerical integration
  !             divtmp=divtmp+signc*v%nr(k)*mesh%edhx(k)%leng
  !          end do
  !          if(average)then
  !             !Averaged divergence (division by cell area)
  !             divtmp=divtmp/mesh%hx(i)%areag
  !          end if
  !          !Assign returnable variable the result
  !          div%f(i)=divtmp
  !       end do
  !    end if
  !
  !    return
  !  end subroutine divergence

  function div_mesh_fullvec(v, mesh, cellopt, average)
    !-----------------------------------------------------------
    ! Given a vector variable (cartesian) calculates the numerical
    ! divergence average or integral based on Divergence Theorem
    !
    ! Input
    !   v -> vector variable defined
    !   mesh -> mesh structure
    !   cellopt -> Cell to use: "TR" or "HX"
    !
    ! Output
    !   div  -> divergence estimates
    !-----------------------------------------------------------
    !Input variable with vectors
    type(vector_field_cart), intent(in) :: v

    !Output variable for divergence in scalar variable defined on
    type(scalar_field):: div_mesh_fullvec

    !Mesh in which the variable belongs
    type(grid_structure), intent(in) :: mesh

    !Cell to be used
    character (len=2), optional :: cellopt
    character (len=2):: cell

    !Logical var for considering or not divergente average
    !That is, division or not by the cell area
    ! Default is .true.
    logical, optional :: average
    logical:: av

    !Velocity field - aux
    type(vector_field_cart):: vtrc
    type(vector_field_cart):: ved

    !Set default values for optionals
    if(.not.present(cellopt))then
       cell="hx"
    else
       cell=cellopt
    end if

    if(.not.present(average))then
       av=.true.
    else
       av=average
    end if

    if(cell=="HX" .or. cell=="hx")then

       !Calculate divergence based on the position of the given vectors

       select case (v%pos)
       case(0)  !Vectors on tr vertices
          ! HA - Estimate Divergence NICAM method
          !Interpolate vector field on triangle circumcenters
          call vec_remap_trv2trc(v, vtrc, mesh)
          !Interpolate vector field to edges midpoints
          ved%pos=3 !Inform that vectors must be interpoalated to hx edge
          call vec_remap_trc2ed(vtrc, ved, mesh)
          !Estimate numerical divergence HA - NICAM Method
          call div_mesh_ed_fullvec(ved, div_mesh_fullvec, mesh, av)

       case (1) !HB !Vector on Tr circumcenters, or hx vertices
          !Interpolate vector field to edges midpoints
          ved%pos=3 !Inform that vectors must be interpoalated to hx edge
          call vec_remap_trc2ed(v, ved, mesh)
          !Estimate numerical divergence
          call div_mesh_ed_fullvec(ved, div_mesh_fullvec, mesh, av)

       case (3, 6) !HC !Vectors on hx edges
          !Directly estimate numerical divergence
          call div_mesh_ed_fullvec(v, div_mesh_fullvec, mesh, av)

       case default
          print*, "div_mesh error - Don't know how to calculate with this vector position:", v%pos, cell
          stop
       end select
    elseif(cell=="TR" .or. cell=="tr")then
       !Calculate divergence based on the position of the given vectors

       select case (v%pos)
       case(0)  ! TB !Vectors on tr vertices
          !Interpolate vector field to edges midpoints
          call vec_remap_trv2ed(v, ved, mesh)

          !Estimate numerical divergence
          call div_mesh_ed_fullvec(ved, div_mesh_fullvec, mesh, av)

       case (1) ! TA !Vector on Tr circumcenters, or hx vertices
          !Interpolate vector field to tr vertices (nodes)
          ved%pos=2
          call vec_remap_trc2ed(v, ved, mesh)
          !Estimate numerical divergence
          call div_mesh_ed_fullvec(ved, div_mesh_fullvec, mesh, av)

       case (2) !TC !Vectors on TR edges
          !Directly estimate numerical divergence
          call div_mesh_ed_fullvec(v, div_mesh_fullvec, mesh, av)

       case default
          print*, "div_mesh error - Don't know how to calculate with this vector position:", v%pos, cell
          stop
       end select

    else
       print*, "div_mesh error - Cell has not been properly given",  cell
       stop
    end if

    return
  end function div_mesh_fullvec

  function divho_mesh_fullvec(ved, mesh, discinterp_mtd, cellopt, average)
    !-----------------------------------------------------------
    ! Given a vector variable (cartesian) calculates the numerical
    ! divergence average or integral based on Divergence Theorem
    !
    ! Input
    !   ved -> vector field
    !   mesh -> mesh structure
    !   cellopt -> Cell to use: "HX"
    !
    ! Output
    !   divho_mesh  -> divergence estimates
    !-----------------------------------------------------------
    !Input variable with scalars on Voronoi cell edge's midpoints
    type(vector_field_cart), intent(in) :: ved

    !Output variable for divergence in scalar variable defined on
    type(scalar_field):: divho_mesh_fullvec

    !Mesh in which the variable belongs
    type(grid_structure), intent(in) :: mesh

    !Inteprolation/Reconsgtruction method used for
    !     divergence/laplacian discretizations
    type(vectorinterpol_methods) :: discinterp_mtd

    !Normal components
    type(scalar_field):: vecncomp

    !Cell to be used
    character (len=2), optional :: cellopt
    character (len=2):: cell

    !Logical var for considering or not divergente average
    !That is, division or not by the cell area
    ! Default is .true.
    logical, optional :: average
    logical:: av

    !Velocity field - aux
    type(vector_field_cart):: vtrc

    !Aux point
    real(r8), dimension(1:3)::p

    !Index
    integer (i4):: i
    integer (i4):: j
    integer (i4):: k
    integer (i4):: l
    integer (i4):: n

    !Condition numbers
    real (r8):: condnummin
    real (r8):: condnummax

    !RBF matrix vector
    type(rbf_matrix_structure), allocatable :: rbf_mat(:)

    !RBF stencil and kind of interpolation
    character(len=4):: stencil

    !Set default values for optionals
    if(.not.present(cellopt))then
       cell="hx"
    else
       cell=cellopt
    end if

    if(.not.present(average))then
       av=.true.
    else
       av=average
    end if

    if(discinterp_mtd%recon(1:3)=="rbf")then
       !If RBF, calculate the matrix structure (precalculation, depends only on mesh)
       condnummin=100000000.
       condnummax=0.
       stencil=trim(discinterp_mtd%recon(4:6))
       !Build rbf matrices
       call rbfvec_matrix_build( stencil, discinterp_mtd%rbf_par, rbf_mat, mesh)
       !Calculate condition number estimates
       n=size(rbf_mat)
       print*
       print*, "Length of RBF matrices vector:", n
       do i=1,n
          condnummin=min(condnummin,rbf_mat(i)%condnum)
          condnummax=max(condnummax,rbf_mat(i)%condnum)
       end do
       print*, "Condition Number Estimates (min, max):"
       print "(2e12.3)", condnummin, condnummax
       print*, "Shape parameter:"
       print*, discinterp_mtd%rbf_par
       print*
    end if

    if(cell=="HX" .or. cell=="hx")then

       !Calculate divergence based on the position of the given vectors
       select case (ved%pos)
       case (3) !HC !Vectors on hx edges

          !Reconstruct vector field to triangle circuncenters/
          !  Voronoi corners - based on alignement index
          vtrc%pos=1
          vtrc%n=mesh%nt
          allocate(vtrc%p(1:vtrc%n))

          !Divergence on triangle nodes/hexagon centers
          divho_mesh_fullvec%pos=0
          divho_mesh_fullvec%n=mesh%nv
          if(.not.allocated(divho_mesh_fullvec%f))then
             allocate(divho_mesh_fullvec%f(1:divho_mesh_fullvec%n))
          end if

          !Vectors normal comp on HX edges
          vecncomp%pos=3
          vecncomp%n=mesh%ne
          allocate(vecncomp%f(1:vecncomp%n))
          do i=1, mesh%ne
             vecncomp%f(i)=dot_product(ved%p(i)%v, mesh%edhx(i)%nr)
          end do
          l=0
          do i=1, mesh%nv
             !Check if cell is aligned
             if(mesh%hx(i)%align<discinterp_mtd%alignlimit)then
                !Directly estimate numerical divergence
                divho_mesh_fullvec%f(i)=div_cell_fullvec(i, ved, mesh, average)
             else
                l=l+1
                !Reconstruct to surrounding trcs
                do j=1, mesh%v(i)%nnb
                   k=mesh%v(i)%tr(j)
                   p=mesh%tr(k)%c%p
                   vtrc%p(k)%v=vector_reconstruct (p, &
                        vecncomp, mesh, discinterp_mtd%recon, rbf_mat, pindex=k)
                   !vtrc%p(k)%v=(/-p(2), p(1), 0/)
                end do
                !Calculate higher order div
                divho_mesh_fullvec%f(i)=divho_cell_fullvec(i, ved, vtrc, mesh, average)

             end if
          end do
       case default
          print*, "divho_mesh error - Don't know how to calculate with"//&
               " this vector position:", ved%pos, cell
          stop
       end select
    else
       print*, "divho_mesh error - Cell has not been properly given",  cell
       stop
    end if
    print*, "Used higher order method in ", l, " cells"
    return
  end function divho_mesh_fullvec

  subroutine div_mesh_ed_fullvec(v, div, mesh, average)
    !-----------------------------------------------------------
    ! Given a vector variable defined on either triangles' edges
    ! or hexagonals/pentagonals' edges calculates the numerical
    ! divergence average or integral based on Divergence Theorem
    !
    ! Input
    !   v -> cartesian vector variable defined on tr or hx edges
    !   v%pos=2 -> triangle edges
    !   v%pos=3 -> hexag edges
    !   mesh -> mesh structure
    !
    ! average = .true. -> Divides divergence cell integral by cell area
    ! average = .false. -> Don't divide by cell area
    !
    ! Output
    !   div  -> divergence on triangle or hexagon centers
    !  div%pos=1 -> triangle centers
    !  div%pos=0 -> hexagon centers
    !-----------------------------------------------------------
    !Input variable with vectors on triangles edge's midpoints
    type(vector_field_cart), intent(in) :: v

    !Output variable for divergence in scalar variable defined on
    ! triangle centers
    type(scalar_field), intent(inout) :: div

    !Mesh in which the variable belongs
    type(grid_structure), intent(in) :: mesh

    !Logical var for considering or not divergente average
    !That is, division or not by the cell area
    logical, intent(in):: average

    !Counters
    integer (i4):: i

    if(v%pos==2)then
       !Vectors on triangles' edges

       !Divergence positioned on triangle centres
       div%pos=1
       div%n=mesh%nt

       !Allocate memory for divergence
       if(.not.allocated(div%f))then
          allocate(div%f(1:div%n))
       end if

       !For all triangles
       do i=1, mesh%nt
          !Assign returnable variable the result
          div%f(i)=div_cell_fullvec(i, v, mesh, average)
       end do
    else
       !Vectors on hexag/pent edges

       !Divergence on triangle nodes/hexagon centers
       div%pos=0
       div%n=mesh%nv

       !Allocate memory for divergence
       if(.not.allocated(div%f))then
          allocate(div%f(1:div%n))
       end if
       !For all hexagons
       do i=1, mesh%nv
          !Assign returnable variable the result
          div%f(i)=div_cell_fullvec(i, v, mesh, average)
       end do
    end if

    return
  end subroutine div_mesh_ed_fullvec

  function div_cell_fullvec(i, v, mesh, average)
    !-----------------------------------------------------------
    ! Given a cartesian vector variable the numerical
    ! divergence average or integral based on Divergence Theorem
    !
    !   i -> node if v%pos=3, tr if v%pos=2
    !   v -> vector variable defined on Triangle or hexagon edges !!!
    !   mesh -> mesh structure
    !
    !-----------------------------------------------------------
    !Node for divergence calculation
    integer (i4), intent(in) :: i

    !Input variable with vectors
    type(vector_field_cart), intent(in) :: v

    real (r8):: div_cell_fullvec

    !Mesh in which the variable belongs
    type(grid_structure), intent(in) :: mesh

    !Logical var for considering or not divergente average
    !That is, division or not by the cell area
    logical, intent(in) :: average

    !Temp. vars
    real (r8):: divtmp
    real (r8):: signcor
    real (r8):: nrv
    !real (r8), allocatable :: vec(:)

    !Counters
    integer (i4):: j
    integer (i4):: k

    !Check if vectors on hexag/pent edges

    select case(v%pos)
    case(2)
       !For all edges forming the triangle
       divtmp=0_r8
       do j=1, 3
          !Get edge index
          k=mesh%tr(i)%ed(j)
          !print*, "Edge:", j
          !Get edge outer normal related to the hexagon
          signcor=real(mesh%tr(i)%nr(j), r8)
          !Calculate normal component
          nrv=signcor*dot_product(v%p(k)%v, mesh%ed(k)%nr)
          !Calculate numerical integration
          divtmp=divtmp+nrv*mesh%ed(k)%leng
       end do
       if(average)then
          !Averaged divergence (division by cell area)
          divtmp=divtmp/mesh%tr(i)%areag
       end if
    case(3)
       !For all edges forming the hexagon
       divtmp=0._r8
       do j=1, mesh%v(i)%nnb
          !Get edge index
          k=mesh%v(i)%ed(j)
          !print*, "Edge:", j
          !Get edge outer normal related to the hexagon
          signcor=real(mesh%hx(i)%nr(j), r8)
          !Calculate normal component
          nrv=signcor*dot_product(v%p(k)%v, mesh%edhx(k)%nr)
          !Calculate numerical integration
          divtmp=divtmp+nrv*mesh%edhx(k)%leng
       end do
       if(average)then
          !Averaged divergence (division by cell area)
          divtmp=divtmp/mesh%hx(i)%areag
       end if
    case(6)
       !For all edges forming the hexagon
       divtmp=0._r8
       do j=1, mesh%v(i)%nnb
          !Get edge index
          k=mesh%v(i)%ed(j)
          !print*, "Edge:", j
          !Get edge outer normal related to the hexagon
          signcor=real(mesh%hx(i)%ttgout(j), r8)
          !Calculate normal component
          nrv=signcor*dot_product(v%p(k)%v, mesh%ed(k)%tg)
          !Calculate numerical integration
          divtmp=divtmp+nrv*mesh%edhx(k)%leng
       end do

       if(average)then
          !Averaged divergence (division by cell area)
          divtmp=divtmp/mesh%hx(i)%areag
       end if
    case default
       print*, "div_cell ERROR: Vectors not on hx or tr edges (pos=2,3, 6).", v%pos
       stop
    end select

    !Assign returnable variable the result
    div_cell_fullvec=divtmp

    return
  end function div_cell_fullvec

  function divho_cell_fullvec(i, ved, vtrc, mesh, average)
    !-----------------------------------------------------------
    ! Given a cartesian vector variable the numerical
    ! divergence average or integral based on Divergence Theorem
    !
    !   i -> node (v%pos=3)
    !   ved -> vector variable defined on hexagon edges !!!
    !   vtrc -> vector variable defined on triangle circuncenters !!!
    !   mesh -> mesh structure
    !
    !-----------------------------------------------------------
    !Node for divergence calculation
    integer (i4), intent(in) :: i

    !Input variable with vectors
    type(vector_field_cart), intent(in) :: ved
    type(vector_field_cart), intent(in) :: vtrc

    real (r8):: divho_cell_fullvec

    !Mesh in which the variable belongs
    type(grid_structure), intent(in) :: mesh

    !Logical var for considering or not divergente average
    !That is, division or not by the cell area
    logical, intent(in) :: average

    !Counters
    integer (i4):: j
    !integer (i4):: k
    integer (i4):: ed
    integer (i4):: tr(1:2)

    !Temp. vars
    real (r8):: divtmp
    real (r8):: signc
    !real (r8):: nrv
    real (r8), dimension(1:3) :: nr(1:3)
    real (r8), dimension(1:3) :: f(1:3)
    real (r8), dimension(1:3) :: s(1:3)

    !Check if vectors on hexag/pent edges
    if(ved%pos==3)then
       !For all edges forming the hexagon
       divtmp=0._r8
       do j=1, mesh%v(i)%nnb

          !Get edge index
          ed=mesh%v(i)%ed(j)
          !print*,"ed: ", ed

          !Get corners (triang circumcenters)
          tr=mesh%edhx(ed)%v
          !print*,"tr: ", tr(1:2)

          !Sign correction for this hx edge
          signc=real(mesh%hx(i)%nr(j), r8)
          !print*,"sign: ", sign

          !Get normal to edge with correction
          nr=signc*mesh%edhx(ed)%nr
          !print*,"Normal: ", nr

          !Get first corner vector dot prod normal
          s(1)=0
          f(1)=dot_product(vtrc%p(tr(1))%v,  nr)
          !print*, "V1:", v%p(tr(1))%v
          !print*, "s1, f1:", s(1), f(1)

          !Get edge's midpoint vector
          s(2)=arclen(mesh%tr(tr(1))%c%p, mesh%edhx(ed)%c%p)
          f(2)=dot_product(ved%p(ed)%v, nr)
          !print*, "s2, f2:", s(2), f(2)

          !Get other corner vector dot prod normal
          s(3)=s(2)+arclen(mesh%edhx(ed)%c%p, mesh%tr(tr(2))%c%p)
          !print*, s(3)-s(2)-s(2)
          f(3)=dot_product(vtrc%p(tr(2))%v,  nr)
          !print*, "V3:", v%p(tr(2))%v
          !print*, "s3, f:", s(3), f(3)

          divtmp=divtmp+int_simpson(s, f)
          !divtmp=divtmp+(s(3)/6)*(f(1)+4*f(2)+f(3))
          !print*,"simp:", int_simpson(s, f)
       end do
       if(average)then
          !Averaged divergence (division by cell area)
          divtmp=divtmp/mesh%hx(i)%areag
       end if
    else
       print*, "div_cell ERROR: Vectors not on hx edges (pos=3).", ved%pos
       stop
    end if

    !Assign returnable variable the result
    divho_cell_fullvec=divtmp

    return
  end function divho_cell_fullvec

end module diffoperpack


SUBROUTINE fmacat(vmfl,acat)
!
! This subroutine sets up an intermediate matrix acat.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::vmfl(:)
 REAL(iwp),INTENT(OUT)::acat(:,:)
 REAL(iwp)::temp(4,4),zero=0.0_iwp,pt5=0.5_iwp,one=1.0_iwp,three=3.0_iwp
 INTEGER::i,j
 temp=zero
 temp(1,1)=one
 temp(1,2)=-pt5
 temp(1,4)=-pt5
 temp(2,1)=-pt5
 temp(2,2)=one
 temp(2,4)=-pt5
 temp(3,3)=three
 temp(4,1)=-pt5
 temp(4,2)=-pt5
 temp(4,4)=one
 DO i=1,4
   DO j=1,4
     acat(i,j)=vmfl(i)*vmfl(j)
   END DO
 END DO
 acat=temp-acat
RETURN
END SUBROUTINE fmacat


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C     -*- Mode: fortran -*-
C=======================================================================
      SUBROUTINE SPOFF (XN, YN, ZN, NSPL, ZS, XS, XS2, YS, YS2,
     &     SLTOP, SLBOT, NUMNP, NDIM )
C=======================================================================

C     --*** SPLXYZ *** (GEN3D) Calculate 3D coordinates for Spline projection
C     --   Written by Amy Gilkey - revised 05/09/88
C     --   Modified by Greg Sjaardema - 02/06/89
C     --
C     --WRPXYZ calculates the coordinate array for the 3D warp translations.
C     --
C     --Parameters:
C     --   XN, YN, ZN - IN/OUT - the coordinates, modified
C     --   NSPL - Number of points on spline curve
C     --   ZS, XS, YS - IN - spline point coordinates
C     --   XS2, YS2 - spline slopes
C     --   SLTOP, SLBOT - slopes at top and bottom of spline
C     --   NUMNP - number of nodal points
C     --   NDIM - spatial dimension (2 or 3)
C     --

      REAL XN(*), YN(*), ZN(*)
      REAL ZS(NSPL), XS(NSPL), XS2(NSPL), YS(NSPL), YS2(NSPL)
      REAL SLTOP(2), SLBOT(2)

C$$$      CALL RDSPLN (.TRUE., NDB, SLTOP, SLBOT, NSPL, ZS, XS, YS)

      CALL SPLINE (ZS, XS, NSPL, SLTOP(1), SLBOT(1), XS2)
      CALL SPLINE (ZS, YS, NSPL, SLTOP(2), SLBOT(2), YS2)

      KLO = 1

      DO 80 INP = 1, NUMNP
         Z = ZN(INP)
         CALL HUNT (ZS, NSPL, Z, KLO)
         IF (KLO .EQ. NSPL) KLO = KLO - 1
         IF (KLO .EQ.    0) KLO = KLO + 1

         H  = ZS(KLO+1) - ZS(KLO)
         A  = (ZS(KLO+1)-Z)/H
         B  = (Z-ZS(KLO))/H

         XOFF = A * XS(KLO) + B * XS(KLO+1) +
     *        ((A**3-A) * XS2(KLO)+(B**3-B)*XS2(KLO+1)) * (H**2) / 6.

         YOFF = A * YS(KLO) + B * YS(KLO+1) +
     *        ((A**3-A) * YS2(KLO)+(B**3-B)*YS2(KLO+1)) * (H**2) / 6.

         XN(INP) = XN(INP) + XOFF
         YN(INP) = YN(INP) + YOFF
   80 CONTINUE

      RETURN
      END


! ---------------------------------------------------- !
!      Set up LU diagonalizzazione filtro              !
!             F. Califano, Marzo 2001                  !
! ---------------------------------------------------- !
! A (f_i-1 + f_i+1) + f_i = a_filt f_i +               !
!      b_filt (f_i-1 + f_i+1) + c_filt (f_i-2 + f_i+2) !
! ---------------------------------------------------- !

           subroutine init_filtro_open_x

use box_mod
use parameter_mod
use filtro_open_mod

IMPLICIT NONE

! --------------------------------- !
! *** Set up filtro Compatto        !
! *** Parametri solver tridiagonale !
! --------------------------------- !

    TARNS = 'N'
    info = 0
    lrhs  = 1
    ldb   = nx

!    Parametro filtraggio

!    FILTRO IV ordine: R.H.S. coefficients of the tridiag. filter
!    Lele 1992, pag. 40, C.2.4

        !a_filt =   (5.0d0 + 6.0d0 * omega_x) / 8.0d0
        !b_filt =   (1.0d0 + 2.0d0 * omega_x) / 4.0d0
        !c_filt = - (1.0d0 - 2.0d0 * omega_x) / 16.0d0
        !d_filt = 0.0d0

!    FILTRO VI ordine: R.H.S. coefficients of the tridiag. filter
!    Lele 1992, pag. 40, C.2.5

        a_filt = (11.0d0 + 10.0d0 * omega_x) / 16.0d0
        b_filt = (15.0d0 + 34.0d0 * omega_x) / 64.0d0
        c_filt = (- 3.0d0 + 6.0d0 * omega_x) / 32.0d0
        d_filt = (  1.0d0 - 2.0d0 * omega_x) / 64.0d0

!    R.H.S boundary conditions coefficients

        a11_filt =  15.0d0 / 16.0d0
        a12_filt =   1.0d0 / 4.0d0
        a13_filt = - 3.0d0 / 8.0d0
        a14_filt =   1.0d0 / 4.0d0
        a15_filt = - 1.0d0 / 16.0d0

        a21_filt =   1.0d0/ 16.0d0
        a22_filt =   3.0d0 / 4.0d0
        a23_filt =   3.0d0 / 8.0d0
        a24_filt = - 1.0d0 / 4.0d0
        a25_filt =   1.0d0/ 16.0d0

        a31_filt = - 1.0d0/ 16.0d0
        a32_filt =   1.0d0 / 4.0d0
        a33_filt =   5.0d0 / 8.0d0
        a34_filt =   1.0d0 / 4.0d0
        a35_filt = - 1.0d0/ 16.0d0

!    Diagonale filt_d, sotto diagonale filt_m e super diagonale filt_p
!    (filt_2 e' un working array)

        filt_d = 1.0

        filt_p = omega_x
        filt_m = omega_x

        filt_p(1)   = 0.0
        filt_m(nx1) = 0.0

!    Filtro R.H.S boundary conditions coefficients:
!    f(x) unchanged at i = 1, 2 and the same on the right  OR
!    f(x) Lele boundary conditions at i = 1, 2 and the same on the right

        filt_m(1)   = 0.0
        filt_p(2)   = 0.0
        filt_m(nx2) = 0.0
        filt_p(nx1) = 0.0

!    f(x) unchanged also at i = 3 and the same on the right OR
!    f(x) Lele boundary conditions also at i = 3 and the same on the right

        filt_m(2)   = 0.0
        filt_p(3)   = 0.0
        filt_m(nx3) = 0.0
        filt_p(nx2) = 0.0

!    Working array

        filt_2 = 0.0

!     Fattorizzazione LU

    CALL DGTTRF(nx, filt_m, filt_d, filt_p, filt_2, ipv_f, info)

      if (info > 0 .or. info < 0) then
      write(*,*) 'Problemi fattorizzazione LU, Filtro: info:', info
      stop
      endif

 end subroutine


      SUBROUTINE VECM50GAL(KEY,VECIN,VECOUT)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C THIS ROUTINE ROTATES CARTERSIAN VECTORS BETWEEN THE MEAN OF 1950.0
C COORDINATE SYSTEM AND THE GALACTIC COORDINATE SYSTEM. BOTH ARE
C GEOCENTRIC.
C
C THE GALACTIC POLE AND GALACTIC CENTER DIRECTIONS ARE TAKEN FROM THE
C TEXT 'ASTRONOMY' BY  L W FREDRICK, 9TH EDITION, 1971. VALUES VERIFIED
C FROM OTHER SOURCES. THE DIRECTIONS ARE THOSE DECIDED UPON BY THE
C INTERNATIONAL ASTRONOMICAL UNION IN 1958.
C
C VARIABLE DIM TYPE I/O DESCRIPTION
C -------- --- ---- --- -----------
C
C KEY       1  I*4   I  FLAG INDICATING THE 'FROM' AND 'TO' COORDINATE
C                       SYSTEMS.
C
C                       = NEGATIVE, FROM GALACTIC TO 1950.0
C                       = OTHERWISE, FROM 1950.0 TO GALACTIC
C
C VECIN     3  R*8   I  THE VECTOR IN THE 'FROM' SYSTEM. ANY UNITS.
C
C VECOUT    3  R*8   O  THE VECTOR IN THE 'TO' SYSTEM. SAME UNITS AS
C                       VECIN. IN THE CALLING PROGRAM, VECIN AND VECOUT
C                       MAY BE THE SAME ARRAY.
C
C***********************************************************************
C
C BY C PETRUZZO, GSFC/742, 12/84.
C   MODIFIED.....
C
C***********************************************************************
C
      REAL*8 HALFPI / 1.570796326794897D0 /
      REAL*8 PI     / 3.141592653589793D0 /
      REAL*8 TWOPI  / 6.283185307179586D0 /
      REAL*8 DEGRAD / 57.29577951308232D0 /
      REAL*8 DEGHR/15.D0/
      INTEGER INIT/1/
      REAL*8 GCENTER(3),XGALACT(3),YGALACT(3),ZGALACT(3)
      REAL*8 GALM50(3,3),M50GAL(3,3),VECIN(3),VECOUT(3)
C
C *******************************
C * ONCE-PER-RUN INITIALIZATION *
C *******************************
C
      IF(INIT.EQ.1) THEN
        INIT = 0
C
C      ZRA,ZDEC GIVES THE DIRECTION OF THE GALACTIC NORTH POLE.
        ZRA =  (12.D0 + 49.D0/60.D0)*DEGHR/DEGRAD    ! = 12H, 49M
        ZDEC = 27.4D0/DEGRAD                         ! = 27.4 DEG
C
C      CRA,CDEC GIVES THE DIRECTION TO GALACTIC CENTER WHICH IS ON
C      THE ON THE X-AXIS.
        CRA =  (17.D0 + 42.4D0/60.D0)*DEGHR/DEGRAD   ! = 17H, 42.4M
        CDEC =  -(28.D0 + 55.D0/60.D0)/DEGRAD        ! = -28 DEG, 55 MIN
C
C      GET GALACTIC SYSTEM AXES RELATIVE TO THE 1950.0 COORDINATE SYSTEM
        CALL XYZSPH(1,CRA,CDEC,1.D0,GCENTER,1.D0)  ! 89.9919 DEG FROM Z.
        CALL XYZSPH(1,ZRA,ZDEC,1.D0,ZGALACT,1.D0)
        CALL UCROSS(ZGALACT,GCENTER,YGALACT)
        CALL UCROSS(YGALACT,ZGALACT,XGALACT)
C
C      SET THE MATRIX TAKING VECTOR COORDS FROM 1950.0 TO GALACTIC
        DO 10 I=1,3
        M50GAL(I,1) = XGALACT(I)
        M50GAL(I,2) = YGALACT(I)
   10   M50GAL(I,3) = ZGALACT(I)
C
C      SET THE MATRIX TAKING VECTORS FROM GALACTIC COORDS TO 1950.0
        CALL MTXFLIP33(M50GAL,GALM50)
C
        END IF
C
C
C ***********************
C * ROTATATE THE VECTOR *
C ***********************
C
      IF(KEY.LT.0) THEN
C      FROM GALACTIC TO 1950.0
        CALL VECROT(M50GAL,VECIN,VECOUT)
C
      ELSE
C      FROM 1950.0 TO GALACTIC
        CALL VECROT(GALM50,VECIN,VECOUT)
        END IF
C
C
      RETURN
      END


C==============================================================================
c transforms from (line,sample) to (latitude,longitude) for a
c perspective projection camera system.  an oblate spheroid model of the
c planet (re,rp) is used.  all angles are in radians.  planetocentric
c latitudes and east-longitudes are used.
c
c inputs:
c     rline,rsamp   :  input image coordinates
c     om	    :  camera to planet transformation matrix
c     psc3          :  spacecraft vector in (x3,y3,z3) coordinates, where
c		    :     psc3(1) = rsc*dcos(sclat)
c		    :     psc3(2) = 0.0d0
c		    :     psc3(3) = rsc*dsin(sclat)
c     sclon         :  spacecraft longitude
c     re            :  planet's equatorial radius (km)
c     epsln	    :  planet eccentricity = (re/rp)**2
c     epsln2        :  constant = psc3(1)**2 + epsln*psc3(3)**2 - re**2
c     oal,oas       :  image coordinates of optical axis intercept point
c     zscale        :  camera constant = fl*pscale
c
c outputs:
c     ind           :	ind=1 if resulting (rlat,rlon) are valid
c		    :	ind=0 if point is off the planet
c     rlat,rlon     :  computed planet coordinates.
C==============================================================================
      subroutine planet(ind,rline,rsamp,rlat,rlon,
     &       om,psc3,sclon,re,epsln,epsln2,oal,oas,zscale)
      IMPLICIT NONE
      integer ind
      real*8 rline,rsamp,rlat,rlon,om(3,3),psc3(3),re,epsln,epsln2,
     +       oal,oas,zscale

      real*8 sclon,ux0,uy0,uz0,ux3,uy3,uz3,a,b,d,r,x,y,z
      real*8 pi/3.141592653589793d0/

c         vector from spacecraft to point on planet in camera coordinate system
      ux0 = rsamp - oas
      uy0 = rline - oal
      uz0 = zscale
c         convert vector to planet coordinate system (x3,y3,z3)
      ux3 = om(1,1)*ux0 + om(1,2)*uy0 + om(1,3)*uz0
      uy3 = om(2,1)*ux0 + om(2,2)*uy0 + om(2,3)*uz0
      uz3 = om(3,1)*ux0 + om(3,2)*uy0 + om(3,3)*uz0
c          find where vector intersects planet
      a = ux3**2      + uy3**2 + epsln*uz3**2
      b = ux3*psc3(1)          + epsln*uz3*psc3(3)
      d = b*b - a*epsln2
      if(d.lt.0.) then
          ind = 0		!point off the planet
          return
      endif
      r = (-b-dsqrt(d))/a	!choose smaller root for point in front
c
      x = r*ux3 + psc3(1)
      y = r*uy3
      z = r*uz3 + psc3(3)
      d = dsqrt(x**2+y**2)
      rlat = datan2(z,d)
      rlon = dmod(datan2(y,x)+sclon+2.d0*pi,2.d0*pi)
      ind = 1
      return
      end

C==============================================================================
c transforms from (latitude,longitude) to (line,sample) in a
c perspective projection camera system.  an oblate spheroid model of the
c planet (re,rp) is used.  all angles are in radians.  planetocentric
c latitudes and east-longitudes are used.
c
c inputs:
c     rlat,rlon     :  input planet coordinates.
c     om	    :  camera to planet transformation matrix
c     psc3          :  spacecraft vector in (x3,y3,z3) coordinates, where
c		    :     psc3(1) = rsc*dcos(sclat)
c		    :     psc3(2) = 0.0d0
c		    :     psc3(3) = rsc*dsin(sclat)
c     sclon         :  spacecraft longitude
c     re            :  planet's equatorial radius (km)
c     epsln	    :  planet eccentricity = (re/rp)**2
c     epsln2        :  constant = psc3(1)**2 + epsln*psc3(3)**2 - re**2
c     oal,oas       :  image coordinates of optical axis intercept point
c     zscale        :  camera constant = fl*pscale
c
c outputs:
c     ind           :  ind=1 if resulting (rline,rsamp) are valid
c                   :  ind=0 if point is behind the planet
c     rline,rsamp   :  computed image coordinates
C==============================================================================
      subroutine plainv(ind,rlat,rlon,rline,rsamp,
     &       om,psc3,sclon,re,epsln,epsln2,oal,oas,zscale)
      IMPLICIT NONE
      integer ind
      real*8 rlat,rlon,rline,rsamp,om(3,3),psc3(3),sclon,re,
     +       epsln,epsln2,oal,oas,zscale

      real*8 clat,r,ux3,uy3,uz3,a,b,d,ux0,uy0,uz0,s

      clat = dcos(rlat)
      r = re/dsqrt((1-epsln)*clat**2+epsln)	!geocentric radius
c          compute vector from camera to point on planet
      ux3 =  r*clat*dcos(rlon-sclon) - psc3(1)
      uy3 =  r*clat*dsin(rlon-sclon)
      uz3 =  r*dsin(rlat)            - psc3(3)
c          back-of-planet test
      a = ux3**2      + uy3**2 + epsln*uz3**2
      b = ux3*psc3(1)          + epsln*uz3*psc3(3)
      d = b*b - a*epsln2
      if(d.gt.0.) then
          r = (-b-dsqrt(d))/a
          if (r.lt.0.99999d0) then
               ind = 0			!point behind the planet
               return
          endif
      endif
c          rotate vector into camera coordinates
      ux0 = om(1,1)*ux3 + om(2,1)*uy3 + om(3,1)*uz3
      uy0 = om(1,2)*ux3 + om(2,2)*uy3 + om(3,2)*uz3
      uz0 = om(1,3)*ux3 + om(2,3)*uy3 + om(3,3)*uz3
c          scale vector into pixels
      s = zscale/uz0
      rline = s*uy0 + oal
      rsamp = s*ux0 + oas
      ind = 1
      return
      end

C==============================================================================
c convert from (line,sample) to (lat,lon) and vice versa.
C==============================================================================
      subroutine latlon1(ipic,rline,rsamp,rlat,rlon,ind)
      IMPLICIT NONE
      integer ipic,ind
      real*8 rline,rsamp,rlat,rlon

      include 'cmap.fin'

      common/cnav_sedr/fl1,oal1,oas1,pscale1,zscale1
      common/cnav_sedr/om1(3,3),psc31(3),sclat1,sclon1,epsln21
      common/cnav_sedr/fl2,oal2,oas2,pscale2,zscale2
      common/cnav_sedr/om2(3,3),psc32(3),sclat2,sclon2,epsln22
      real*8 fl1,oal1,oas1,pscale1,zscale1,om1,psc31,sclat1,sclon1,
     +       epsln21,fl2,oal2,oas2,pscale2,zscale2,om2,psc32,sclat2,
     +       sclon2,epsln22

c           convert from (line,samp) to (lat,lon)
      if (ipic.eq.1) then
           call planet(ind,rline,rsamp,rlat,rlon,
     &        om1,psc31,sclon1,re,epsln,epsln21,oal1,oas1,zscale1)
      else
           call planet(ind,rline,rsamp,rlat,rlon,
     &        om2,psc32,sclon2,re,epsln,epsln22,oal2,oas2,zscale2)
      endif
      return

      entry linsam1(ipic,rlat,rlon,rline,rsamp,ind)
c           convert from (lat,lon) to (line,samp)
      if (ipic.eq.1) then
           call plainv(ind,rlat,rlon,rline,rsamp,
     &            om1,psc31,sclon1,re,epsln,epsln21,oal1,oas1,zscale1)
      else
           call plainv(ind,rlat,rlon,rline,rsamp,
     &            om2,psc32,sclon2,re,epsln,epsln22,oal2,oas2,zscale2)
      endif

      return
      end

C==============================================================================
c convert from (line,sample) to (lat,lon) and vice versa.  this version
c also converts from image-space to object-space and vice versa, as
c required.
C==============================================================================
      subroutine latlon2(ipic,rline,rsamp,rlat,rlon,ind)
      IMPLICIT NONE
      integer ipic,ind
      real*8 rline,rsamp,rlat,rlon

      include 'cmap.fin'
      include 'cpic.fin'

      common/cnav_sedr/fl1,oal1,oas1,pscale1,zscale1
      common/cnav_sedr/om1(3,3),psc31(3),sclat1,sclon1,epsln21
      common/cnav_sedr/fl2,oal2,oas2,pscale2,zscale2
      common/cnav_sedr/om2(3,3),psc32(3),sclat2,sclon2,epsln22
      real*8 fl1,oal1,oas1,pscale1,zscale1,om1,psc31,sclat1,sclon1,
     +       epsln21,fl2,oal2,oas2,pscale2,zscale2,om2,psc32,sclat2,
     +       sclon2,epsln22

      common/distor/itype(2),conv(2216,2),nph(2),npv(2),project(2)
      real*4 conv
      integer nph, npv, itype
      character*5 project

      real*4 rl,rs
      real*8 r8rl,r8rs

      rl = rline
      rs = rsamp
      if (itype(ipic).eq.7) call convisos(project(ipic),camera_id,
     &     rl,rs,rl,rs,1,conv(1,ipic),nph(ipic),npv(ipic),ind)
c           convert from (line,samp) to (lat,lon)
      if (ipic.eq.1) then
           r8rl = rl
           r8rs = rs
           call planet(ind,r8rl,r8rs,rlat,rlon,
     &        om1,psc31,sclon1,re,epsln,epsln21,oal1,oas1,zscale1)
      else
           r8rl = rl
           r8rs = rs
           call planet(ind,r8rl,r8rs,rlat,rlon,
     &        om2,psc32,sclon2,re,epsln,epsln22,oal2,oas2,zscale2)
      endif
      return

      entry linsam2(ipic,rlat,rlon,rline,rsamp,ind)
c           convert from (lat,lon) to (line,samp)
      if (ipic.eq.1) then
           call plainv(ind,rlat,rlon,rline,rsamp,
     &            om1,psc31,sclon1,re,epsln,epsln21,oal1,oas1,zscale1)
      else
           call plainv(ind,rlat,rlon,rline,rsamp,
     &            om2,psc32,sclon2,re,epsln,epsln22,oal2,oas2,zscale2)
      endif

      if (itype(ipic).eq.7) then
        rl=rline
        rs=rsamp
        call convisos(project(ipic),camera_id,rl,rs,rl,rs,0,
     &          conv(1,ipic),nph(ipic),npv(ipic),ind)
        rline = rl
        rsamp = rs
      end if

      ind = 1
      return
      end

C==============================================================================
c routine to convert input latitude (rlat) to planetocentric if igeo=1
C==============================================================================
      real*8 function geocen(rlat)
      IMPLICIT NONE
      real*8 rlat

      include 'cmap.fin'
      include 'const.fin'

      if (dabs(rlat).ge.pi/2.d0) then
           geocen = dsign(pi/2.d0,rlat)
           return
      endif

      if (igeo.ne.1) then
         geocen = rlat
      else
         geocen = datan(dtan(rlat)/epsln)
      endif
      return
      end

C==============================================================================
c routine to convert input latitude (rlat) to planetodetic if igeo=1
C==============================================================================
      real*8 function geodet(rlat)
      IMPLICIT NONE
      real*8 rlat

      include 'cmap.fin'
      include 'const.fin'

      if (dabs(rlat).ge.pi/2.d0) then
           geodet = dsign(pi/2.d0,rlat)
           return
      endif

      if (igeo.ne.1) then
         geodet = rlat
      else
         geodet = datan(dtan(rlat)*epsln)
      endif
      return
      end

C==============================================================================
c get camera distortion parameters.
c mode=1 if res file directory has already been read.
C==============================================================================
      subroutine getgeopar(project_id,camera_id,frame_id,planet_id,
     &		conv,nph,npv,mode,*)
      IMPLICIT NONE
      integer*4 project_id,camera_id,frame_id,planet_id,nph,npv,mode
      real*4 conv(2216)			!camera distortion parameters

      save
      character *6 format(409) /5*'FULL',404*'REAL'/
      integer status,nrows,ibis

      integer iunitr,jdata(2)
      real*4 rloc(2,202)

      logical parmtst
      integer icnt,idef,ind,icount,iret,mpv
      character*24 rfnames(4)/
     &		'/project/vgr/resj.fil',	!jupiter
     &		'/project/vgr/ress.fil',	!saturn
     &		'/project/vgr/resu.fil',	!uranus
     &		'/project/vgr/resn.fil'/	!neptune
      character*256 rfname

      integer ibis_file_get

  101 format(' ***Reseau locations for frame',i8,' not found')
      character*80 msg
c
      if (project_id.ne.4) return	!only implemented for vgr
c     ...find and open reseau location file
      if (mode.eq.0) then
         call xvparm('RES',rfname,icnt,idef,1)	!get file name
         if (idef.eq.1) rfname=rfnames(planet_id-4)
         call xvunit(iunitr,'X',1,ind,'U_NAME',rfname,' ')
         call xvsignal(iunitr,ind,.true.)
         call ibis_file_open(iunitr,ibis,'read',409,99999,
     +                        format,0,status)
         if ( status .ne. 1 ) call ibis_signal_u(iunitr,status,1)
         icount = ibis_file_get(ibis,'nr',nrows,1,1) ! get nrows
         if ( nrows .lt. 0 ) call ibis_signal(ibis,icount,1)
         mode = 1
      endif
c     ....get reseau locations
      jdata(1) = frame_id
      jdata(2) = camera_id
      call getlocv2(ibis,nrows,jdata,rloc,iret)
      if (iret.eq.0) goto 30	!skip if successful

      write(msg,101) frame_id
      call xvmessage(msg,' ')
      call xvmessage('Do you wish to use nominal reseau locations?',' ')
   20 call xvintract('QUERY',' Enter Y or N')
      if (parmtst('EXIT', mpv, 1)) goto 990
      if (parmtst('N', mpv, 1)) goto 990
      call xvmessage('Nominal reseau locations used',' ')
      call getres(rloc,camera_id)

c     ....get geom parameters
   30 call geomav(conv,camera_id,rloc)
      nph = 24
      npv = 23
      call mve(7,2208,conv(9),conv,1,1)  !move so buffer begins with tiepoints
      return
c     ...error conditions
  990 call xvmessage(' ***Use program RESLOC to locate the reseau',' ')
      return1
      end

C==============================================================================
c read old tiepoints from third input file...
C==============================================================================
      subroutine getpts(*)
      IMPLICIT NONE

      include 'cpts.fin'

      common/c1_iobuf/buf(500,10)		!scratch space for i/o
      real*4 buf

      integer iunit,status,ncol,count,ibis_in,nrow,icol,i
      character*80 msg

      integer ibis_file_get

      call xvunit(iunit, 'inp', 3, status, ' ')
      call ibis_file_open(iunit, ibis_in, 'read', 0, 0,' ',' ', status)
      if (status .ne. 1) call ibis_signal_u(iunit, status, 1)
      count = ibis_file_get(ibis_in, 'nc', ncol, 1, 1)
      if (count .lt. 0) call ibis_signal(ibis_in, count, 1)
      count = ibis_file_get(ibis_in, 'nr', nrow, 1, 1)
      if (count .lt. 0) call ibis_signal(ibis_in, count, 1)

      if (ncol.ne.10) then
          call xvmessage(' ***Invalid input tiepoint file format',' ')
          return1
      endif

      do icol=1,ncol
         call ibis_column_read(ibis_in, buf(1, icol), icol, 1, nrow,
     +                         status)
         if (status .ne. 1) call ibis_signal(ibis_in, status, 1)

      enddo

      npts = nrow
c
c     ....move data to tiepoints area
      do i=1,nrow
         lpt(1,i) = buf(i,1)
         lpt(2,i) = buf(i,2)
         rpt(1,i) = buf(i,3)
         rpt(2,i) = buf(i,4)
         lpt0(1,i) = buf(i,5)
         lpt0(2,i) = buf(i,6)
         zl(i) = buf(i,7)
         zr(i) = buf(i,8)
         cmax(i) = buf(i,9)
      enddo

      call ibis_file_close(ibis_in, ' ', status)
      if (status .ne. 1) call ibis_signal(ibis_in, status, 1)
      write(msg,110) npts
  110 format(i6,' tiepoints read from input tiepoint file')
      call xvmessage(msg,' ')
      return
      end

C==============================================================================
c write tiepoints to output ibis interface file.
C==============================================================================
      subroutine putpts(*)
      IMPLICIT NONE

      include 'cpts.fin'

      common/c1_iobuf/obuf(500,10)		!scratch space for i/o
      real*4 obuf

      integer ounit,status,ncol,ibis_out,nrow,i,n,icol

      if (npts.eq.0) return
      nrow = 0		!column length=number of tiepoints output
      do i=1,npts
         if (lpt(1,i).ge.0.0) nrow=nrow+1
      enddo

      ncol = 10
      call xvunit(ounit, 'out', 1, status, ' ')
      call ibis_file_open(ounit, ibis_out, 'write', ncol, nrow, ' ',
     +' ', status)
      if (status .ne. 1) call ibis_signal_u(ounit, status, 1)
c
c     ....rearrange data for column sequential output
      n = 0
      DO i=1,npts
        IF (lpt(1,i).ge.0.0) THEN	!reject all flagged tiepoints
          n = n + 1
          obuf(n,1) = lpt(1,i)
          obuf(n,2) = lpt(2,i)
          obuf(n,3) = rpt(1,i)
          obuf(n,4) = rpt(2,i)
          obuf(n,5) = lpt0(1,i)
          obuf(n,6) = lpt0(2,i)
          obuf(n,7) = zl(i)
          obuf(n,8) = zr(i)
          obuf(n,9) = cmax(i)
          obuf(n,10) = i
        END IF
      END DO

      do icol=1,10
         call ibis_column_write(ibis_out, obuf(1, icol), icol, 1, nrow,
     +status)
         if (status .ne. 1) call ibis_signal(ibis_out, status, 1)
      enddo

      call ibis_file_close(ibis_out, ' ', status)
      return
      end


      real function shear(a,b,c,x)
c
c     + + + PURPOSE + + +
c     Calculates nondimensional shear stress.
c
c     Called from subroutine XCRIT.
c     Author(s): G. Foster
c     Reference in User Guide:
c
c     Changes:
c
c     Version: This module recoded from WEPP version 90.92.
c     Date recoded: 01/08/91.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      real a, b, c, x
c
c     + + + ARGUMENT DEFINITIONS + + +
c     a      - shear stress coefficient for current slope
c              section
c     b      - shear stress coefficient for current slope
c              section
c     c      - shear stress coefficient for current slope
c              section
c     x      - nondimensional distance at which shear stress
c              is to be calculated
c
c     + + + LOCAL VARIABLES + + +
c     value  -
      real value
c
c     + + + END SPECIFICATIONS + + +
c
      value = a * x ** 2 + b * x + c
      if (value.lt.0.0) value = 0.0
      shear = value ** 0.66666667
      if (shear.le.0.0) shear = 0.0001
c
      return
      end


      subroutine gbox(emax, alat, qb, n1, n2, n3)
c============================================================
c     Find the max. dimensions of the reciprocal-space
c     box which contains all plane waves with Ekin < Emax.
c
c  DATE: Wed Oct 16 14:54:34 MDT 1996
c============================================================
      implicit none

      real*8, intent(IN)                       :: emax, alat
      real*8, dimension(3,3), intent(IN)       :: qb
      integer, intent(OUT)                     :: n1,n2,n3

      real*8 Gmax, twopi, tpiba
      real*8 q11,q12,q13,q22,q23,q33,rvol,range1,range2,range3
      real*8, external                         :: tripl

      twopi = 8d0*datan(1d0)
      tpiba = twopi / alat
      Gmax = sqrt( 2d0 * emax ) / tpiba

      q11 = DOT_PRODUCT( qb(:,1), qb(:,1) )
      q12 = DOT_PRODUCT( qb(:,1), qb(:,2) )
      q13 = DOT_PRODUCT( qb(:,1), qb(:,3) )
      q22 = DOT_PRODUCT( qb(:,2), qb(:,2) )
      q23 = DOT_PRODUCT( qb(:,2), qb(:,3) )
      q33 = DOT_PRODUCT( qb(:,3), qb(:,3) )

      rvol = abs( tripl( qb(:,1), qb(:,2), qb(:,3) ) )

      range1 = rvol / sqrt(q22*q33 - q23**2)
      range2 = rvol / sqrt(q11*q33 - q13**2)
      range3 = rvol / sqrt(q11*q22 - q12**2)

      n1 = int ( Gmax / range1 + 1d0 )
      n2 = int ( Gmax / range2 + 1d0 )
      n3 = int ( Gmax / range3 + 1d0 )

      return
      end


subroutine sistupf(a, b, l, u)

implicit none

real, dimension(:,:), intent(in) :: a
real, dimension(:), intent(in) :: b
real, dimension(:), intent(out) :: u

integer, dimension(:), intent(in) :: l

integer :: ln, li

integer :: n, i, j, p

n = size(b)

ln = l(n)

u(n) = b(ln)/a(ln,n)

do i = n-1, 1, -1

  li = l(i)
  u(i) = b(li)
  do j = i+1, n
    u(i) = u(i) - a(li,j)*u(j)
  enddo

  u(i) = u(i)/a(li,i)
enddo

end subroutine


C NCLFORTSTART
      SUBROUTINE DPRCWATDP(Q,DP,KLVL,QMSG,DPMSG,PRCWAT)
      IMPLICIT NONE
c Input
      INTEGER KLVL
      DOUBLE PRECISION Q(KLVL),DP(KLVL),QMSG,DPMSG
c Output
      DOUBLE PRECISION PRCWAT
C NCLEND

C NCL: prcwat = prcwater_dp (q,dp)

c nomenclature:
c     q      - specific humidity [kg/kg; ie: dimensionless]
c     dp     - layer thickness [Pa]
c     prcwat - precipitable water [kg/m2]

c Local
      INTEGER KL,KNT
      DOUBLE PRECISION G

      G = 9.81D0

      KNT = 0
      PRCWAT = 0.0D0
      DO KL = 1,KLVL
          IF (Q(KL).NE.QMSG .AND. DP(KL).NE.DPMSG) THEN
              KNT = KNT + 1
              PRCWAT = PRCWAT + Q(KL)*ABS(DP(KL))
          END IF
      END DO

      IF (KNT.GT.0) THEN
          PRCWAT = PRCWAT/G
      ELSE
          PRCWAT = QMSG
      END IF

      RETURN
      END


      program ex2_omp

!***  Stencil update
!***  This is the serial version
!***    Employs a temporary array (tmp) inside loop
!***    Employs a reduction operation on variable sum
!***    In this code there are read-after-write and write-after-read dependencies

!***  The algorithm that presets the input arrays and also the format for the sum
!***    are carefully selected to hide round-off discrepancies in the output

!***  All variables and unnamed constants are in double precision

!***  Compile with: ifort -xhost -qopenmp ex2_omp.f90

!***  Execution time is of the order of seconds
!***  Memory requirement is about 20.1 GB

!***  The kernel has a write-after-read (WAR) dependency

        use omp_lib

        integer                              :: n = 30000
        real(8), dimension(:,:), allocatable :: x, y, tmp
        real(8)                              :: sum

        write (0,*) 'Allocate arrays'
        allocate (x(n,n), y(n,n), tmp(n,n))

!***  The input arrays are carefull filled to minimize round-off errors
        write (0,*) 'Preset input arrays (x and y)'
        do j=1, n
          do i=1, n
            x(i,j) = real(modulo((i+j), 3)) - 0.9999_8
            y(i,j) = x(i,j) + 0.0001
          enddo
        enddo

!$      write (0,'(a,i4)') ' Number of threads :: ', omp_get_max_threads()

        write (0,*) 'Start timer and calculation'
        call system_clock(ic1, ir)

        sum = 0.

!$omp parallel do default(none) shared(n, x, y, tmp) private(i, j)
        do j=2, n-1
          do i=2, n-1
            tmp(i,j) = 0.167_8 * (x(i,j) + x(i-1,j) + x(i+1,j) + x(i,j-1) + x(i,j+1) + &
                                  y(i+1,j))
          enddo
        enddo

!$omp parallel do default(none) shared(n, y, tmp) private(i, j) reduction (+: sum)
        do j=2, n-1
          do i=2, n-1
            y(i,j)   = tmp(i,j)
            sum      = sum + tmp(i,j)
          enddo
        enddo

        call system_clock(ic2, ir)
        write (0,*) 'Stop timer after calculation'
        write (0,*)
        write (0,'(a,f12.5,a)') 'Time to completion :: ', (real(ic2) - real(ic1)) / real(ir), ' seconds'

!***  The output format with 2 digits after the decimal point is carefully selected to hide round-off errors
        write (0,'(a,f12.2)')   'The total sum is   :: ', sum

      end program ex2_omp


program euler
  integer max, x, y, p, l, i

  character(6) s, r

  character t

  max = 0

  do x = 100, 999
    do y = 100, 999
      p = x * y

      write(s, '(i0)') p

      write(r, '(i0)') p

      l = len_trim(r)

      do i = 1, l / 2
        t = r(i:i)

        r(i:i) = r(l + 1 - i:l + 1 - i)

        r(l + 1 - i:l + 1 - i) = t
      enddo

      if ((s == r) .and. (p > max)) then
        max = p
      endif
    enddo
  enddo

  write(*, '(i0)') max
end program euler


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   ppp :    A continuous dynamical system with period doubling
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

      F(1)= U(1)*(1-U(1)) - PAR(4)*U(1)*U(2)
      F(2)=-PAR(2)*U(2)   + PAR(4)*U(1)*U(2) - PAR(5)*U(2)*U(3) &
                          - PAR(1)*(1-EXP(-PAR(6)*U(2)))
      F(3)=-PAR(3)*U(3)   + PAR(5)*U(2)*U(3)

      END SUBROUTINE FUNC

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ---------- -----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T

      U(1)=1.0
      U(2)=0.0
      U(3)=0.0

      PAR(1)=0.0
      PAR(2)=0.25
      PAR(3)=0.5
      PAR(4)=3.0
      PAR(5)=3.0
      PAR(6)=5.0

      END SUBROUTINE STPNT

      SUBROUTINE BCND
      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS


c  bpspline -- dmc 30 May 1996
c
c  set up coefficients for bicubic spline with following BC's:
c  * LHS and RHS BCs -- d3f/dx3 from 3rd divided difference, 1st coordinate
c  * derivatives periodic in second coordinate
c
c  see similar routine, bpsplinb, for more control over x boundary
c  conditions...
c
      subroutine r8bpspline(x,inx,th,inth,fspl,inf3,
     >                    wk,nwk,ilinx,ilinth,ier)
c
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      integer inx,inth,inf3,nwk
      REAL*8 x(inx),th(inth),fspl(4,4,inf3,inth),wk(nwk)
      integer ilinx,ilinth
      integer ier
c
c  input:
c    x(1...inx) -- abscissae, first dimension of data
c   th(1...inth) -- abscissae, second (periodic) dimension of data
c   fspl(1,1,1..inx,1..inth) -- function values
c   inf3 -- fspl dimensioning, inf3.ge.inx required.
c
c  output:
c   fspl(*,*,1..inx,1..inth) -- bicubic spline coeffs (4x4)
c   ...fspl(1,1,*,*) is not replaced.
c
c   ilinx -- =1 on output if x(inx) pts are nearly evenly spaced (tol=1e-3)
c   ilinth-- =1 on output if th(inth) evenly spaced (tol=1e-3)
c
c   ier -- completion code, 0 for normal
c
c  workspace:
c   wk -- must be at least 5*max(inx,inth) large
c  nwk -- size of workspace
c
c---------------------------------
c  compute bicubic spline of 2d function, given values at the grid
c  grid crossing points, f(1,1,i,j)=f(x(i),th(j)).
c
c  on evaluation:  for point x btw x(i) and x(i+1), dx=x-x(i)
c                       and th btw th(j) and th(j+1), dt=th-th(j),
c
c      spline =
c        f(1,1,i,j) + dx*f(2,1,i,j) + dx**2*f(3,1,i,j) + dx**3*f(4,1,i,j)
c   +dt*(f(1,2,i,j) + dx*f(2,2,i,j) + dx**2*f(3,2,i,j) + dx**3*f(4,2,i,j))
c   +d2*(f(1,3,i,j) + dx*f(2,3,i,j) + dx**2*f(3,3,i,j) + dx**3*f(4,3,i,j))
c   +d3*(f(1,4,i,j) + dx*f(2,4,i,j) + dx**2*f(3,4,i,j) + dx**3*f(4,4,i,j))
c
c      where d2=dt**2 and d3=dt**3.
c
c---------------------------------
      integer ierx,ierth
      REAL*8 zdum(1)
c---------------------------------
c
      ier=0
      if(nwk.lt.5*max(inx,inth)) then
         write(6,'('' ?bpspline:  workspace too small.'')')
         ier=1
      endif
      if(inx.lt.2) then
         write(6,'('' ?bpspline:  at least 2 x points required.'')')
         ier=1
      endif
      if(inth.lt.2) then
         write(6,'('' ?bpspline:  need at least 2 theta points.'')')
         ier=1
      endif
c
c  check ilinx & x vector
c
      call r8splinck(x,inx,ilinx,1.0E-3_r8,ierx)
      if(ierx.ne.0) ier=2
c
      if(ier.eq.2) then
         write(6,'('' ?bpspline:  x axis not strict ascending'')')
      endif
c
c  check ilinth & th vector
c
      call r8splinck(th,inth,ilinth,1.0E-3_r8,ierth)
      if(ierth.ne.0) ier=3
c
      if(ier.eq.3) then
         write(6,'('' ?bpspline:  th axis not strict ascending'')')
      endif
c
      if(ier.ne.0) return
c
c------------------------------------
c
      zdum=0.0_r8
c
c  not-a-knot BCs for x, periodic for theta
c
      call r8bcspline(x,inx,th,inth,fspl,inf3,
     >   7,zdum,7,zdum,
     >   -1,zdum,-1,zdum,
     >   wk,nwk,ilinx,ilinth,ier)
c
      return
      end


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

      subroutine exact_solution(xi,eta,zeta,dtemp)

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

c---------------------------------------------------------------------
c     this function returns the exact solution at point xi, eta, zeta
c---------------------------------------------------------------------

      include 'header.h'

      double precision  xi, eta, zeta, dtemp(5)
      integer m

      do m = 1, 5
         dtemp(m) =  ce(m,1) +
     >     xi*(ce(m,2) + xi*(ce(m,5) + xi*(ce(m,8) + xi*ce(m,11)))) +
     >     eta*(ce(m,3) + eta*(ce(m,6) + eta*(ce(m,9) + eta*ce(m,12))))+
     >     zeta*(ce(m,4) + zeta*(ce(m,7) + zeta*(ce(m,10) +
     >     zeta*ce(m,13))))
      enddo

      return
      end


      program DRDCFT
c>> 1996-06-05 DRDCFT Krogh Fixes for conversion to C.
c>> 1994-10-19 DRDCFT Krogh  Changes to use M77CON
c>> 1989-05-07 DRDCFT FTK, CLL
c     Driver to demonstrate DCFT -- Complex Fast Fourier Transform
c     ------------------------------------------------------------------
c--D replaces "?": DR?CFT, ?CFT
c     ------------------------------------------------------------------
      double precision    F(256)
      double precision S(31), T, DELTAT, TTIME, PI, TWOPI, RTWO
      double precision  ZERO, FOUR, P1, P3
      integer    I, K, KF, M, MS, N, ND, MA(1)
      parameter (PI = 3.1415926535897932384D0)
      parameter (TWOPI = 2.D0 * PI)
      parameter (RTWO = 1.4142135623730950488D0)
      parameter (M = 7)
c      parameter (N = 2**M)
      parameter (N = 128)
      parameter (ND = 1)
      parameter (ZERO = 0.D0)
      parameter (FOUR = 4.D0)
      parameter (P1 = .1D0)
      parameter (P3 = .3D0)
      data  TTIME /25.D0/
      data MA / M /
c     ------------------------------------------------------------------
      print*,'Program DRDCFT..  Demonstrates DCFT'
      DELTAT = TTIME / N
      T = ZERO
      do 100 K = 1, 2*N, 2
         F(K)=SIN(TWOPI*(T+P1))+FOUR*COS(TWOPI*(RTWO*T+P3))
         F(K+1) = ZERO
         T = T + DELTAT
  100 continue
      MS = 0
      call DCFT (F, 'A', MA, ND, MS, S)
      print'(1X/A/1X)',' TRANSFORM FOR K=21 TO 41 (NO SIGMA FACTORS)'
      do 120 K = 21, 41, 3
         KF = 2*K-1
         print'(A,I3,A,I3,3(F11.5,F9.5))',
     *        ' K=',K,' TO',K+2,(F(I), I=KF, KF+5)
  120 continue
      stop
      end


      SUBROUTINE INTERP(XIN,YIN,DELTIN,LENIN,NTRP,XCAL,YCAL,
     &YINTERP,DELTOT,LENOT)
C***********************************************************************
C  TO LINEARLY INTERPOLATE INPUT ARRAY OF (X,Y) POINTS, FOR MODE       *
C  IWAVE = 13. X IS TIME, Y IS CURRENT. XIN AND YIN HAVE THE INPUT     *
C  VALUES, XCAL AND YCAL HAVE THE CALCULATED INTERPOLATED VALUES ONLY. *
C  ARRAY YINTERP HAS Y OUTPUT ONLY. IN THIS IMPLEMENTATION, SENN       *
C  MEASURES X SPACING ONCE, AND CALCULATES RELATIVE X VALUES IN        *
C  SUBROUTINE RKGS. (FOR REFERENCE, OUTPUT FILE XYINTERP HAS THE FULL  *
C  TWO-DIMENSIONAL INTERPOLATED ARRAY, WITH RELATIVE X VALUES, AS      *
C  FORMED BY THIS SUBROUTINE.)                                         *
C***********************************************************************
C      include "common.f"
      REAL*4 XIN(LENIN),YIN(LENIN),XCAL(LENOT),YCAL(LENOT),
     &YINTERP(LENOT),B,M,DELTX
      INTEGER*4 I,J,NTRP,LENIN,LENOT
      REAl*8 DELTIN,DELTOT,VALUE
      IF (LENIN .LT. 2)THEN
        WRITE (*,*) ' INPUT FILE HAS LESS THAN TWO POINTS'
        WRITE (66,*) ' INPUT FILE HAS LESS THAN TWO POINTS'
C        RETURN  ! 6/19/10
        STOP      ! 6/19/10
      END IF
      LENOT = (LENIN -1)*(NTRP + 1) + 1
      DELTOT =  DELTIN/(NTRP +1)
      XCAL(1) = XIN(1)
      YCAL(1) = YIN(1)
C      YINTERP(1) = YIN(1)   ! Don't need?
      VALUE = XIN(1)
      I = 1
      J = 0
	  K = 1   ! Index for interpolated Y array YINTERP
C      WRITE (*,*) XCAL(1),YCAL(1)   !! Diagnostic
      WRITE(2,*) XCAL(1),YCAL(1)
      YINTERP(K) = YCAL(1)   ! or YIN(1)?
      DO WHILE( I .LT. LENIN)
        J = J + 1
        K = K + 1
        VALUE =VALUE + DELTOT
        XCAL(J) = VALUE
        IF (MOD(J,(NTRP +1)).EQ.0) THEN
C          WRITE (*,*) XIN(I+1 ),YIN(I+1 )   !! Diagnostic
          WRITE(2,*) XIN(I+1 ),YIN(I+1 )
          YINTERP(K) = YIN(I+1)
          I =I +1
        ELSE
          DELTX =XIN(I+1)-XIN(I)
          IF (DELTX .LE. 0)THEN
            WRITE (*,*) 'WARNING: INPUT TIME STREAM NOT',
     &' MONOTONIC INCREASING'
            WRITE (66,*) 'WARNING: INPUT TIME STREAM NOT',
     &' MONOTONIC INCREASING'
C            RETURN  !6/19/10
          END IF
          M = (YIN(I+1) - YIN(I))/DELTIN   !! Orig. DELTX
          B = YIN(I) -M*XIN(I)
          YCAL(J) = M*XCAL(J) + B
C          WRITE(*,*) XCAL(J),YCAL(J)   !! Diagnostic
          WRITE(2,*) XCAL(J),YCAL(J)
          YINTERP(K) = YCAL(J)
        END IF
      END DO
      WRITE (*,*) 'End of new data.    ',
     &LENOT,' (x,y) pairs created'
      WRITE (*,*) 'Output file named XYINTERP'
C      WRITE (*,*) (YCAL(K),K=1,LENOT)   !! Diagnostic
      RETURN
      END


program improvedeulermethod
    implicit none
      real*8:: x, y, y1, xwant, h, fxy, fxy1, fe
      integer:: niter, i

      x= 0.0; y=0.0; h=0.001; xwant=1.57
      niter = int((xwant -x)/h)
      open(unit=21, file="improved_euler_method.dat")

      do i=1,niter
      fxy = 1 + y**2
      y1 = y + h*fxy
      fe = 1 + y1**2
      fxy1 = (fxy+fe)/2
      y = y + h*fxy1

      write(21,*) dfloat(i)*h, y
      end do

end program improvedeulermethod


use SoilClass
implicit none

! create ground
type(Soil_) :: soil
type(Random_) :: random
type(FEMDomain_)::domain
type(DigitalElevationModel_) ::dem
real(real64),allocatable :: strain(:,:),stress(:,:),trSigma(:),allstress(:,:,:)
integer(int32),parameter :: num_node=10
real(real64) :: E, v
integer(int32) :: i,j

! create mesh from Digital Elevetion Model (DEM)

! create dummy DEM data
dem%x = zeros(num_node)
dem%y = zeros(num_node)
dem%z = zeros(num_node)
do i=1, num_node
    dem%x(i) = random%gauss(mu=0.0d0,sigma=10.0d0)
    dem%y(i) = random%gauss(mu=0.0d0,sigma=10.0d0)
    dem%z(i) = random%gauss(mu=0.0d0,sigma=1.0d0) + 10.0d0
enddo
!domain%mesh%nodcoord = zeros(size(dem%x),3 )
!domain%mesh%nodcoord(:,1) = dem%x
!domain%mesh%nodcoord(:,2) = dem%y
!domain%mesh%nodcoord(:,3) = dem%z

!call domain%mesh%meshing()
!call domain%mesh%convertTriangleToRectangular()
!call print(domain%mesh%elemnod)
!
!call domain%vtk("tri")
!call domain%msh("tri")

call soil%import(dem=dem,x_num=20,y_num=20,z_num=6)

call soil%msh("DEM")
call soil%vtk("DEM")

soil%YoungModulus = 10000.0d0
soil%PoissonRatio = 0.30d0
soil%Density      = 1.60d0
soil%VoidRatio    = 0.50d0

call soil%PreFlightCheck()

! only gravity
call soil%deform(z_max=2.0d0,disp=[0.0d0,0.0d0,0.0d0])

!do i=1,soil%femdomain%ne()
!    strain=soil%femdomain%StrainMatrix(ElementID=i,GaussPoint=2,disp=soil%disp)
!enddo
allstress=zeros(soil%femdomain%ne(),3,3 )

trSigma = zeros(soil%femdomain%ne() )
do i=1,soil%femdomain%ne()
    E = soil%YoungModulus(i)
    v = soil%PoissonRatio(i)
    stress=soil%femdomain%stressMatrix(ElementID=i,E=E,v=v,disp=soil%disp)
    trSigma(i) = trace(stress)
    allstress(i,:,:) = stress(:,:)
enddo

! result
call soil%vtk("DEM_deformed")
call soil%vtk("DEM_deformed_s11",scalar=trSigma,ElementType=VTK_HEXAHEDRON)
call soil%vtk("DEM_deformed_disp",vector=soil%disp,ElementType=VTK_HEXAHEDRON)
call soil%vtk("DEM_deformed_str",tensor=allstress,ElementType=VTK_HEXAHEDRON)

end


 SUBROUTINE isoha14(isohd,yield,aprim,eps,c0,c1,c2,c3)
 IMPLICIT NONE

 INTEGER(kind=4),INTENT(IN) :: isohd
 REAL(kind=8),INTENT(IN):: c0, c1, c2, c3, eps
 REAL(kind=8),INTENT(OUT):: yield,aprim
 !Local variables
! INTEGER (kind=4) :: i
 REAL(kind=8),PARAMETER:: tol=1d-10

 SELECT CASE (isohd)
 ! c0    = props(1)     !C0 constant or Initial Yield
 ! c1    = props(2)     !Efref or Hardening constant
 ! c2    = props(3)     !exponent
 ! c3    = props(4)     !residual flow stress
 CASE(1)   !No hardening
     yield = c0
     aprim = 0d0

 CASE(2,5)   !Linear Law (include defined by points)
     yield = c0 + c1*eps
     aprim = c1

 CASE(3)   !Ludwik-Nadai Law
     yield = c0*(c1 + eps)**c2
     aprim = c0*c2*(c1 + eps)**(c2-1d0)

 CASE(4)   !Exponential + saturation
     yield = c0 + c1*eps+(c3-c0)*(1d0-1d0/EXP(c2*eps))
     aprim = c1 + (c3-c0)*c2/EXP(c2*eps)               !derivative

 CASE(6)   !Hollomon Law
     yield = c0*(eps + tol)**c2
     aprim = c0*c2*(eps + tol)**(c2-1d0)

 CASE(7)   !Voce Law
     yield = c0 + c1*(1d0 - EXP(-c2*eps))
     aprim = c1*c2*EXP(-c2*eps)

 END SELECT

 RETURN
 END SUBROUTINE isoha14


      subroutine ire_dgtheta(ctfm,ctfmp,n_Athth,n_B,n_alpha,n_beta,n_div
     &beta,nm1_B,np1_B,Nx,ht,hx,vee,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 hx
      real*8 vee
      real*8 ctfm(Nx)
      real*8 ctfmp(Nx)
      real*8 n_Athth(Nx)
      real*8 n_B(Nx)
      real*8 n_alpha(Nx)
      real*8 n_beta(Nx)
      real*8 n_divbeta(Nx)
      real*8 nm1_B(Nx)
      real*8 np1_B(Nx)
      real*8 res
      real*8 qb
      res = 0.0D0
      do i=2, Nx-1, 1
      qb = 0.5000000000000000D0 * (-0.1D1 * nm1_B(i) + np1_B(i)) / ht +
     #0.6666666666666667D0 * vee * n_divbeta(i) * n_B(i) + 0.50000000000
     #00000D0 / ctfmp(i) * (n_B(i - 1) - 0.1D1 * n_B(i + 1)) / hx * n_be
     #ta(i) + 0.2D1 * n_Athth(i) * n_alpha(i) - 0.2D1 / ctfm(i) * n_B(i)
     # * n_beta(i)
      res = res + qb**2
      end do
      res = sqrt(res/(1*Nx))
      END


program mainPecScattering
    use pec_scattering
    use data_tools
    implicit none

    integer :: n_points = 20 ! points per dimension in mesh
    integer :: n_terms = 50  ! number of terms in Mie series
    real(8) :: k = 3.5d0     ! wavenumber [1/m]
    real(8) :: a = 2.4d0     ! sphere radius [m]
    real(8) :: alpha = PI / 30     ! incident angle in (0, pi)
    complex(8) :: Eo = 3.3d0      ! incident electric field amplitud [V/m]

    real(8), allocatable :: xyz_list(:, :)
    complex(8), allocatable :: Ei_TE(:, :)
    complex(8), allocatable :: Es_TE(:, :)
    complex(8), allocatable :: Ei_TM(:, :)
    complex(8), allocatable :: Es_TM(:, :)

    ! spherical mesh
    call spherical_mesh(a, n_points, xyz_list)

    ! rectangular mesh, without sphere
    !call rectangular_mesh(a, -5d0, 5d0, -5d0, 5d0, 0d0, 0d0, n_points, xyz_list)

    ! TE scattering
    call sphere_plane_scattering_TE(xyz_list, k, a, alpha, Eo, n_terms, Es_TE)
    call incident_plane_wave_TE(xyz_list, k, alpha, Eo, Ei_TE)

    ! TM scattering
    call sphere_plane_scattering_TM(xyz_list, k, a, alpha, Eo, n_terms, Es_TM)
    call incident_plane_wave_TM(xyz_list, k, alpha, Eo, Ei_TM)

    ! save real part of total field
    call save_data(xyz_list, dreal(Ei_TE + Es_TE), "data_TE.txt")
    call save_data(xyz_list, dreal(Ei_TM + Es_TM), "data_TM.txt")

end program


!  *******************************************************************
!  *                                                                 *
!  *                     Function dlafr2                             *
!  *                                                                 *
!  *******************************************************************
!  Double Precision Version 1.41
!  Written by Gordon A. Fenton, TUNS, Apr. 27, 1994
!  Latest Update: May 9, 2001
!
!  PURPOSE  returns the covariance between two points in an isotropic 2-D
!           fractional noise field.
!
!  This function computes and returns the covariance between two points,
!  separated by the distance T, in a 2-D fractional Gaussian noise
!  (fGn) process. The radial covariance function of the fractional
!  noise process is given by
!
!               var              2H       2H           2H
!      B(s) = -------- [ |s + pb|  -  2|s|  +  |s - pb|  ]		(1)
!                  2H
!              2*pb
!
!  where `pb' is the length over which the fractional Brownian motion
!  is averaged in order to make this, the derivative process, exist,
!  and s is the Euclidean length of the lag vector {X,Y}, s = sqrt(X*X+Y*Y).
!  Normally `pb' is selected to be quite small (of the order of the
!  size of the discretization interval).
!
!  If var < 0, then this function returns the variance of a local average
!  of the process, |var|*V(D), averaged over the domain `D' (see below).
!  The variance function which yields a close approximation to the above
!  radial covariance function is given by
!
!                      r          r        r              r
!              |D + pb|  -  2( |D|  +  |pb|  )  + |D - pb|
!      V(D) = --------------------------------------------------	(2)
!                          2                  2H
!                         D * (2H+1)*(2H+2)*pb
!
!  where r = (2H+2) and D = |X| + |Y| (the 1-norm of {X,Y}, where now X and
!  Y are the dimensions of the rectangular averaging region). The actual
!  covariance function corresponding to (2) is equal to (1) along the
!  coordinate axes, and remains close to (1) for H > 0.8. For H < 0.7,
!  the covariance in the diagonal direction is too high, but since the
!  covariance in such fields dies off very rapidly, the error is
!  believed negligible.
!
!  Parameters to this process are brought in through the common block
!  /dparam/ and are described as follows;
!
!     var	the point variance of the fGn process.
!
!     pb	the averaging length discussed above.
!
!     H		the Hurst exponent. In this implementation, 0.5 < H < 1;
!		values of H near 1 yield a correlation structure which
!		remains very high (and thus a covariance matrix which may
!		be nearly singular). Values of H near 0.5 yield a band-
!		limited white noise process.
!
!     da, db	dummy placeholders provided so that the common block /dparam/
!		has the same form for a variety of variance functions.
!
!  Arguments to this function are just the components, X and Y, of the lag
!  vector separating the two points (or the dimensions of the
!  physical averaging region, if var < 0).
!
!  REVISION HISTORY:
!  1.1	added lvarfn flag to end of /dparam/ common block. Set it to
!	true if the variance function is to be returned. Otherwise this
!	function returns the covariance. (Apr 29/00)
!  1.2	eliminated lvarfn -- now return covariances only if var < 0 (Mar 27/01)
!  1.3	properly handled sign on var for covariances (Apr 5/01)
!  1.4	reversed default - now return covariances if var > 0 (Apr 11/01)
!  1.41	revised above documentation to reflect revision 1.4 (May 9/01)
!----------------------------------------------------------------------
      real*8 function dlafr2( X, Y )
      implicit real*8 (a-h,o-z)
      common/dparam/ var, pb, H, da, db
      data zero/0.d0/, one/1.d0/, two/2.d0/
      abs(q)  = dabs(q)
      sqrt(q) = dsqrt(q)
!
      e0 = two*H
      if( var .lt. zero ) then			! return variance function
         if( (X.eq. zero) .and. (Y .eq. zero) ) then
            dlafr2 = -var
         else
            D  = abs(X) + abs(Y)
            e1 = e0 + one
            e2 = e0 + two
            t1 = (D+pb)**e2 - two*(D**e2 + pb**e2) + abs(D-pb)**e2
            dlafr2 = -var*t1/(D*D*e1*e2*pb**e0)
         endif
      else					! var < 0, return covariance
         D = sqrt(X*X + Y*Y)
         t1 = (D+pb)**e0 - two*(D**e0) + abs(D-pb)**e0
         dlafr2 = var*t1/(two*(pb**e0))
      endif

      return
      end