!============================================================================!
        subroutine cfilter( ny, nx, ndof, v )
!
!  Filter a complex 2-D field
!
!============================================================================!
        implicit none

        integer :: nx, ny, ndof
        complex :: v(ny,nx,ndof), f(ny,nx), rhs(ny,nx)
        real    :: lhs(ny,nx,3)

        real, parameter :: alpha = 0.1
        real, parameter :: beta  = 0.0
        real, parameter :: d     = (6.0*beta-1.0)/16.0
        real, parameter :: a     = (2.0+3.0*alpha)/4.0
        real, parameter :: b     = (9.0 + 16.0*alpha + 10.0*beta)/16.0
        real, parameter :: c     = (alpha + 4.0*beta)/4.0

        integer :: iter, idof
!============================================================================!
        call error('cfilter$','Need to switch indices$')

        do idof = 1, ndof

        f = v(:,:,idof)

!.... setup RHS of filter in y

        rhs(1,:) = (15.0 * f(1,:) + 4.0 * f(2,:) - 6.0 * f(3,:) + &
                   4.0 * f(4,:) - f(5,:))/16.0
        rhs(2,:) = 3.0/4.0 * f(2,:) + (f(1,:) + 6.0 * f(3,:) - &
                   4.0 * f(4,:) + f(5,:))/16.0

        rhs(3,:) = 5.0/8.0 * f(3,:) + (-f(1,:) + 4.0 * f(2,:) + &
                   4.0 * f(4,:) - f(5,:))/16.0
        rhs(4:ny-3,:) = a * f(4:ny-3,:) + &
                        b/2.0 * ( f(5:ny-2,:) + f(3:ny-4,:) ) + &
                        c/2.0 * ( f(6:ny-1,:) + f(2:ny-5,:) ) + &
                        d/2.0 * ( f(7:ny,:)   + f(1:ny-6,:) )
        rhs(ny-2,:) = 5.0/8.0 * f(ny-2,:) + (-f(ny-4,:) + 4.0 * f(ny-3,:) + &
                      4.0 * f(ny-1,:) - f(ny,:))/16.0

        rhs(ny-1,:) = 3.0/4.0 * f(ny-1,:) + (f(ny,:) + 6.0 * f(ny-2,:) - &
                      4.0 * f(ny-3,:) + f(ny-4,:))/16.0
        rhs(ny,:) = (15.0 * f(ny,:) + 4.0 * f(ny-1,:) - 6.0 * f(ny-2,:) + &
                    4.0 * f(ny-3,:) - f(ny-4,:))/16.0

!.... setup LHS of filter in y

        if (beta.eq.0.0) then           !.... tridiagonal LHS

          lhs(:,:,1) = alpha
          lhs(:,:,2) = 1.0
          lhs(:,:,3) = alpha

!.... correct for the boundaries

          lhs(1,:,:) = 0.0
          lhs(1,:,2) = 1.0
          lhs(2,:,:) = 0.0
          lhs(2,:,2) = 1.0
          lhs(3,:,:) = 0.0
          lhs(3,:,2) = 1.0

          lhs(ny-2,:,:) = 0.0
          lhs(ny-2,:,2) = 1.0
          lhs(ny-1,:,:) = 0.0
          lhs(ny-1,:,2) = 1.0
          lhs(ny,:,:)   = 0.0
          lhs(ny,:,2)   = 1.0

          call csolve2( ny, nx, 1, lhs, rhs )

        else
          write(*,*) 'Error:  only tridiagonal LHS is currently supported'
          call exit(1)
        end if

        v(:,:,idof) = rhs(:,:)

        end do          ! idof

        return
        end

!=============================================================================!
        subroutine csolve2( n, nsys, nblk, mat, rhs )
!=============================================================================!
!
!  Solves a block tridiagonal system of equations without pivoting.
!  Vectorized over the second index.
!
!  WARNING: Since pivoting is not done, this algorithm could fail
!
!  input:
!    nsys       : number of systems to vectorize over
!    n          : number of rows in the systems
!    nblk       : dimension of the blocks in each row
!
!  inout:
!    mat        : the block tridiagonal matrix to be solved
!    rhs        : the right hand side (complex)
!=============================================================================!
        implicit none

        integer, intent(in)    :: n, nblk, nsys
        real, intent(inout)    :: mat(n,nsys,nblk,nblk*3)
        complex, intent(inout) :: rhs(n,nsys,nblk)

!.... useful constants

        real, parameter :: zero = 0.0, one = 1.0

!.... local variables

        integer :: nc, nr, i, j, l, m, p, q
        real    :: mult(nsys), fact(nsys)

!=============================================================================!
!                     F O R W A R D   E L I M I N A T I O N
!=============================================================================!
        do i = 1, n - 1

!.... do the first four columns

          do nc = 1, nblk - 1

            j = nblk + nc

            do m = nc, nblk - 1
              l = m + 1
              mult(:) = -mat(i,:,l,j) / mat(i,:,nc,j)
              do q = nc + nblk + 1, nblk * 3
                mat(i,:,l,q) = mat(i,:,l,q) + mult(:) * mat(i,:,nc,q)
              end do
              rhs(i,:,l) = rhs(i,:,l) + mult(:) * rhs(i,:,nc)
            end do

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p  = i + 1

            j = nc + nblk
            fact(:) = one / mat(i,:,nc,j)

            do m = 1, nblk
              mult(:) = -mat(p,:,m,nc) * fact(:)
              do q = nc + 1, nblk * 2
                l = q + nblk
                mat(p,:,m,q) = mat(p,:,m,q) + mult(:) * mat(i,:,nc,l)
              end do
              rhs(p,:,m) = rhs(p,:,m) + mult(:) * rhs(i,:,nc)
            end do

          end do        ! end of loop on nc

        end do          ! end of loop on i

!.... do the last row

        i = n

        do nc = 1, nblk - 1

          j = nblk + nc

          do m = nc, nblk - 1
            l = m + 1
            mult(:) = -mat(i,:,l,j) / mat(i,:,nc,j)
            do q = nc + nblk + 1, nblk * 2
              mat(i,:,l,q) = mat(i,:,l,q) + mult(:) * mat(i,:,nc,q)
            end do
            rhs(i,:,l) = rhs(i,:,l) + mult(:) * rhs(i,:,nc)
          end do

        end do  ! end of loop on nc

!=============================================================================!
!                   B A C K W A R D   S U B S T I T U T I O N
!=============================================================================!

!.... do the last row first

        i = n

        do m = nblk, 1, -1
          j = m + nblk
          do q = m+1, nblk
            l = q + nblk
            rhs(i,:,m) = rhs(i,:,m) - rhs(i,:,q) * mat(i,:,m,l)
          end do
          rhs(i,:,m) = rhs(i,:,m) / mat(i,:,m,j)
        end do

!.... now do the rest of the rows in reverse order

        do i = n - 1, 1, -1

          p = i + 1

          do m = nblk, 1, -1
            j = m + nblk
            do q = m+1, nblk
              l = q + nblk
              rhs(i,:,m) = rhs(i,:,m) - rhs(i,:,q) * mat(i,:,m,l)
            end do
            do q = 1, nblk
              l = q + nblk * 2
              rhs(i,:,m) = rhs(i,:,m) - rhs(p,:,q) * mat(i,:,m,l)
            end do
            rhs(i,:,m) = rhs(i,:,m) / mat(i,:,m,j)
          end do

        end do

        return
        end

!============================================================================!
        subroutine filter( ny, nx, f )
!
!  Filter a REAL 2-D field
!
!============================================================================!
        implicit none

        integer:: nx, ny
        real :: f(ny,nx), rhs(ny,nx)
        real, allocatable :: lhs(:,:,:)

        real, parameter :: alpha = 0.1
        real, parameter :: beta  = 0.0
        real, parameter :: d     = (6.0*beta-1.0)/16.0
        real, parameter :: a     = (2.0+3.0*alpha)/4.0
        real, parameter :: b     = (9.0 + 16.0*alpha + 10.0*beta)/16.0
        real, parameter :: c     = (alpha + 4.0*beta)/4.0

        integer :: iter
!============================================================================!

!.... setup RHS of filter in y

        rhs(1,:) = (15.0 * f(1,:) + 4.0 * f(2,:) - 6.0 * f(3,:) + &
                   4.0 * f(4,:) - f(5,:))/16.0
        rhs(2,:) = 3.0/4.0 * f(2,:) + (f(1,:) + 6.0 * f(3,:) - &
                   4.0 * f(4,:) + f(5,:))/16.0

        rhs(3,:) = 5.0/8.0 * f(3,:) + (-f(1,:) + 4.0 * f(2,:) + &
                   4.0 * f(4,:) - f(5,:))/16.0
        rhs(4:ny-3,:) = a * f(4:ny-3,:) + &
                        b/2.0 * ( f(5:ny-2,:) + f(3:ny-4,:) ) + &
                        c/2.0 * ( f(6:ny-1,:) + f(2:ny-5,:) ) + &
                        d/2.0 * ( f(7:ny,:)   + f(1:ny-6,:) )
        rhs(ny-2,:) = 5.0/8.0 * f(ny-2,:) + (-f(ny-4,:) + 4.0 * f(ny-3,:) + &
                      4.0 * f(ny-1,:) - f(ny,:))/16.0

        rhs(ny-1,:) = 3.0/4.0 * f(ny-1,:) + (f(ny,:) + 6.0 * f(ny-2,:) - &
                      4.0 * f(ny-3,:) + f(ny-4,:))/16.0
        rhs(ny,:) = (15.0 * f(ny,:) + 4.0 * f(ny-1,:) - 6.0 * f(ny-2,:) + &
                    4.0 * f(ny-3,:) - f(ny-4,:))/16.0

!.... setup LHS of filter in y

        if (beta.eq.0.0) then           !.... tridiagonal LHS

          allocate ( lhs(ny,nx,3) )

          lhs(:,:,1) = alpha
          lhs(:,:,2) = 1.0
          lhs(:,:,3) = alpha

!.... correct for the boundaries

          lhs(1,:,:) = 0.0
          lhs(1,:,2) = 1.0
          lhs(2,:,:) = 0.0
          lhs(2,:,2) = 1.0
          lhs(3,:,:) = 0.0
          lhs(3,:,2) = 1.0

          lhs(ny-2,:,:) = 0.0
          lhs(ny-2,:,2) = 1.0
          lhs(ny-1,:,:) = 0.0
          lhs(ny-1,:,2) = 1.0
          lhs(ny,:,:)   = 0.0
          lhs(ny,:,2)   = 1.0

          call solve2( ny, nx, 1, lhs, rhs )

          deallocate ( lhs )

        else
          write(*,*) 'Error:  only tridiagonal LHS is currently supported'
          call exit(1)
        end if

        f(:,:) = rhs(:,:)

        return
        end

!=============================================================================!
        subroutine solve2( n, nsys, nblk, mat, rhs )
!=============================================================================!
!
!  Solves a block tridiagonal system of equations without pivoting.
!  Vectorized over the second index.
!
!  WARNING: Since pivoting is not done, this algorithm could fail
!
!  input:
!    nsys       : number of systems to vectorize over
!    n          : number of rows in the systems
!    nblk       : dimension of the blocks in each row
!
!  inout:
!    mat        : the block tridiagonal matrix to be solved
!    rhs        : the right hand side
!=============================================================================!
        implicit none

        integer, intent(in) :: n, nblk, nsys
        real, intent(inout) :: mat(n,nsys,nblk,nblk*3), rhs(n,nsys,nblk)

!.... useful constants

        real, parameter :: zero = 0.0, one = 1.0

!.... local variables

        integer :: nc, nr, i, j, l, m, p, q
        real    :: mult(nsys), fact(nsys)

!=============================================================================!
!                     F O R W A R D   E L I M I N A T I O N
!=============================================================================!
        do i = 1, n - 1

!.... do the first four columns

          do nc = 1, nblk - 1

            j = nblk + nc

            do m = nc, nblk - 1
              l = m + 1
              mult(:) = -mat(i,:,l,j) / mat(i,:,nc,j)
              do q = nc + nblk + 1, nblk * 3
                mat(i,:,l,q) = mat(i,:,l,q) + mult(:) * mat(i,:,nc,q)
              end do
              rhs(i,:,l) = rhs(i,:,l) + mult(:) * rhs(i,:,nc)
            end do

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p  = i + 1

            j = nc + nblk
            fact(:) = one / mat(i,:,nc,j)

            do m = 1, nblk
              mult(:) = -mat(p,:,m,nc) * fact(:)
              do q = nc + 1, nblk * 2
                l = q + nblk
                mat(p,:,m,q) = mat(p,:,m,q) + mult(:) * mat(i,:,nc,l)
              end do
              rhs(p,:,m) = rhs(p,:,m) + mult(:) * rhs(i,:,nc)
            end do

          end do        ! end of loop on nc

        end do          ! end of loop on i

!.... do the last row

        i = n

        do nc = 1, nblk - 1

          j = nblk + nc

          do m = nc, nblk - 1
            l = m + 1
            mult(:) = -mat(i,:,l,j) / mat(i,:,nc,j)
            do q = nc + nblk + 1, nblk * 2
              mat(i,:,l,q) = mat(i,:,l,q) + mult(:) * mat(i,:,nc,q)
            end do
            rhs(i,:,l) = rhs(i,:,l) + mult(:) * rhs(i,:,nc)
          end do

        end do  ! end of loop on nc

!=============================================================================!
!                   B A C K W A R D   S U B S T I T U T I O N
!=============================================================================!

!.... do the last row first

        i = n

        do m = nblk, 1, -1
          j = m + nblk
          do q = m+1, nblk
            l = q + nblk
            rhs(i,:,m) = rhs(i,:,m) - rhs(i,:,q) * mat(i,:,m,l)
          end do
          rhs(i,:,m) = rhs(i,:,m) / mat(i,:,m,j)
        end do

!.... now do the rest of the rows in reverse order

        do i = n - 1, 1, -1

          p = i + 1

          do m = nblk, 1, -1
            j = m + nblk
            do q = m+1, nblk
              l = q + nblk
              rhs(i,:,m) = rhs(i,:,m) - rhs(i,:,q) * mat(i,:,m,l)
            end do
            do q = 1, nblk
              l = q + nblk * 2
              rhs(i,:,m) = rhs(i,:,m) - rhs(p,:,q) * mat(i,:,m,l)
            end do
            rhs(i,:,m) = rhs(i,:,m) / mat(i,:,m,j)
          end do

        end do
!=============================================================================!
        return
        end


module BIVARModule

use NumberKindsModule

implicit none

private
public idbvip, idtang, idpdrv, idptip, idlctn

contains

subroutine idbvip ( md, ndp, xd, yd, zd, nip, xi, yi, zi, iwk, wk )
!
!*******************************************************************************
!
!! IDBVIP performs bivariate interpolation of irregular X, Y data.
!
!
!  Discussion:
!
!    The data points must be distinct and their projections in the
!    X-Y plane must not be collinear, otherwise an error return
!    occurs.
!
!    Inadequate work space IWK and WK may cause incorrect results.
!
!  Latest revision:
!
!    January, 1985
!
!  Purpose:
!
!    To provide bivariate interpolation and smooth surface fitting for
!    values given at irregularly distributed points.
!
!    The resulting interpolating function and its first-order partial
!    derivatives are continuous.
!
!    The method employed is local, i.e. a change in the data in one area
!    of the plane does not affect the interpolating function except in
!    that local area.  This is advantageous over global interpolation
!    methods.
!
!    Also, the method gives exact results when all points lie in a plane.
!    This is advantageous over other methods such as two-dimensional
!    Fourier series interpolation.
!
!  Usage:
!
!    This package contains two user entries, IDBVIP and IDSFFT, both
!    requiring input data to be given at points
!      ( X(I), Y(I) ), I = 1,...,N.
!
!    If the user desires the interpolated data to be output at grid
!    points, i.e. at points
!      ( XI(I), YI(J) ), I = 1,...,NXI, J=1,...,NYI,
!    then IDSFFT should be used.  This is useful for generating an
!    interpolating surface.
!
!    The other user entry point, IDBVIP, will produce interpolated
!    values at scattered points
!      ( XI(I), YI(I) ), i = 1,...,NIP.
!    This is useful for filling in missing data points on a grid.
!
!  History:
!
!    The original version of BIVAR was written by Hiroshi Akima in
!    August 1975 and rewritten by him in late 1976.  It was incorporated
!    into NCAR's public software libraries in January 1977.  In August
!    1984 a new version of BIVAR, incorporating changes described in the
!    Rocky Mountain Journal of Mathematics article cited below, was
!    obtained from Dr Akima by Michael Pernice of NCAR's Scientific
!    Computing Division, who evaluated it and made it available in February,
!    1985.
!
!  Accuracy:
!
!    Accurate to machine precision on the input data points.  Accuracy at
!    other points greatly depends on the input data.
!
!  References:
!
!    Hiroshi Akima,
!    A Method of Bivariate Interpolation and Smooth Surface Fitting
!      for Values Given at Irregularly Distributed Points,
!    ACM Transactions on Mathematical Software,
!    Volume 4, Number 2, June 1978.
!
!    Hiroshi Akima,
!    On Estimating Partial Derivatives for Bivariate Interpolation
!      of Scattered Data,
!    Rocky Mountain Journal of Mathematics,
!    Volume 14, Number 1, Winter 1984.
!
!  Method:
!
!    The XY plane is divided into triangular cells, each cell having
!    projections of three data points in the plane as its vertices, and
!    a bivariate quintic polynomial in X and Y is fitted to each
!    triangular cell.
!
!    The coefficients in the fitted quintic polynomials are determined
!    by continuity requirements and by estimates of partial derivatives
!    at the vertices and along the edges of the triangles.  The method
!    described in the rocky mountain journal reference guarantees that
!    the generated surface depends continuously on the triangulation.
!
!    The resulting interpolating function is invariant under the following
!    types of linear coordinate transformations:
!      1) a rotation of the XY coordinate system
!      2) linear scale transformation of the Z axis
!      3) tilting of the XY plane, i.e. new coordinates (u,v,w) given by
!           u = x
!           v = y
!           w = z + a*x + b*y
!         where a, b are arbitrary constants.
!
!    complete details of the method are given in the reference publications.
!
!  Parameters:
!
!    Input, integer MD, mode of computation.   MD must be 1,
!    2, or 3, else an error return occurs.
!
!    1: if this is the first call to this subroutine, or if the
!    value of NDP has been changed from the previous call, or
!    if the contents of the XD or YD arrays have been changed
!    from the previous call.
!
!    2: if the values of NDP and the XD and YD arrays are unchanged
!    from the previous call, but new values for XI, YI are being
!    used.  If MD = 2 and NDP has been changed since the previous
!    call to IDBVIP, an error return occurs.
!
!    3: if the values of NDP, NIP, XD, YD, XI, YI are unchanged from
!    the previous call, i.e. if the only change on input to idbvip is
!    in the ZD array.  If MD = 3 and NDP or NIP has been changed since
!    the previous call to IDBVIP, an error return occurs.
!
!    Between the call with MD = 2 or MD = 3 and the preceding call, the
!    IWK and WK work arrays should not be disturbed.
!
!    Input, integer NDP, the number of data points (must be 4 or
!    greater, else an error return occurs).
!
!    Input, real XD(NDP), Y(NDP), the X and Y coordinates of the data points.
!
!    Input, real ZD(NDP), the data values at the data points.
!
!    Input, integer NIP, the number of output points at which
!    interpolation is to be performed (must be 1 or greater, else an
!    error return occurs).
!
!    Input, real XI(NIP), YI(NIP), the coordinates of the points at which
!    interpolation is to be performed.
!
!    Output, real ZI(NIP), the interpolated data values.
!
!    Workspace, integer IWK(31*NDP+NIP).
!
!    Workspace, real WK(8*NDP).
!

!
  integer(kint) ndp
  integer(kint) nip
!
  real(kreal) ap
  real(kreal) bp
  real(kreal) cp
  real(kreal) dp
  integer(kint) iip
  integer(kint) itipv
  integer(kint) itpv
  integer(kint) iwk(31*ndp + nip)
  integer(kint) jwipl
  integer(kint) jwipt
  integer(kint) jwit
  integer(kint) jwit0
  integer(kint) jwiwk
  integer(kint) jwiwl
  integer(kint) jwiwp
  integer(kint) jwwpd
  integer(kint) md
  integer(kint) nl
  integer(kint) nt
  integer(kint) ntsc
  real(kreal) p00
  real(kreal) p01
  real(kreal) p02
  real(kreal) p03
  real(kreal) p04
  real(kreal) p05
  real(kreal) p10
  real(kreal) p11
  real(kreal) p12
  real(kreal) p13
  real(kreal) p14
  real(kreal) p20
  real(kreal) p21
  real(kreal) p22
  real(kreal) p23
  real(kreal) p30
  real(kreal) p31
  real(kreal) p32
  real(kreal) p40
  real(kreal) p41
  real(kreal) p50
  real(kreal) wk(8*ndp)
  real(kreal) x0
  real(kreal) xd(ndp)
  real(kreal) xi(nip)
  real(kreal) xs1
  real(kreal) xs2
  real(kreal) y0
  real(kreal) yd(ndp)
  real(kreal) yi(nip)
  real(kreal) ys1
  real(kreal) ys2
  real(kreal) zd(ndp)
  real(kreal) zi(nip)
!
  save /idlc/
  save /idpt/
!
  common /idlc/ itipv,xs1,xs2,ys1,ys2,ntsc(9)
  common /idpt/ itpv,x0,y0,ap,bp,cp,dp, &
                p00,p10,p20,p30,p40,p50,p01,p11,p21,p31,p41, &
                p02,p12,p22,p32,p03,p13,p23,p04,p14,p05
!
!  Error check.
!
  if ( md < 1 .or. md > 3 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'IDBVIP - Fatal error!'
    write ( *, '(a)' ) '  Input parameter MD out of range.'
    stop
  end if

  if ( ndp < 4 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'IDBVIP - Fatal error!'
    write ( *, '(a)' ) '  Input parameter NDP out of range.'
    stop
  end if

  if ( nip < 1 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'IDBVIP - Fatal error!'
    write ( *, '(a)' ) '  Input parameter NIP out of range.'
    stop
  end if

  if ( md == 1 ) then
    iwk(1) = ndp
  else
    if ( ndp /= iwk(1) ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'IDBVIP - Fatal error!'
      write ( *, '(a)' ) '  MD = 2 or 3 but NDP was changed since last call.'
      stop
    end if
  end if

  if ( md <= 2 ) then
    iwk(3) = nip
  else
    if ( nip < iwk(3) ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'IDBVIP - Fatal error!'
      write ( *, '(a)' ) '  MD = 3 but NIP was changed since last call.'
      stop
    end if
  end if
!
!  Allocation of storage areas in the IWK array.
!
  jwipt = 16
  jwiwl = 6*ndp+1
  jwiwk = jwiwl
  jwipl = 24*ndp+1
  jwiwp = 30*ndp+1
  jwit0 = 31*ndp
  jwwpd = 5*ndp+1
!
!  Triangulate the XY plane.
!
  if ( md == 1 ) then

    call idtang ( ndp, xd, yd, nt, iwk(jwipt), nl, iwk(jwipl), &
      iwk(jwiwl), iwk(jwiwp), wk )

    iwk(5) = nt
    iwk(6) = nl

    if ( nt == 0 ) then
      return
    end if

  else

    nt = iwk(5)
    nl = iwk(6)

  end if
!
!  Locate all points at which interpolation is to be performed.
!
  if ( md <= 2 ) then

    itipv = 0
    jwit = jwit0

    do iip = 1, nip

      jwit = jwit+1

      call idlctn ( ndp, xd, yd, nt, iwk(jwipt), nl, iwk(jwipl), &
        xi(iip), yi(iip), iwk(jwit), iwk(jwiwk), wk )

    end do

  end if
!
!  Estimate the partial derivatives at all data points.
!
  call idpdrv ( ndp, xd, yd, zd, nt, iwk(jwipt), wk, wk(jwwpd) )
!
!  Interpolate the ZI values.
!
  itpv = 0
  jwit = jwit0

  do iip = 1, nip

    jwit = jwit + 1

    call idptip ( ndp, xd, yd, zd, nt, iwk(jwipt), nl, iwk(jwipl), wk, &
      iwk(jwit), xi(iip), yi(iip), zi(iip) )

  end do

  return
end subroutine

subroutine idgrid ( xd, yd, nt, ipt, nl, ipl, nxi, nyi, xi, yi, ngp, igp )
!
!*******************************************************************************
!
!! IDGRID organizes grid points for surface fitting.
!
!
!  Discussion:
!
!    IDGRID sorts the points in ascending order of triangle numbers and
!    of the border line segment number.
!
!  Parameters:
!
!    Input, real XD(NDP), YD(NDP), the X and Y coordinates of the data
!    points.
!
!    Input, integer NT, the number of triangles.
!
!    Input, integer IPT(3*NT), the indices of the triangle vertexes.
!
!    Input, integer NL, the number of border line segments.
!
!    Input, integer IPL(3*NL), containing the point numbers of the end points
!    of the border line segments and their respective triangle numbers,
!
!    Input, integer NXI, NYI, the number of grid points in the X and Y
!    coordinates.
!
!    Input, real XI(NXI), YI(NYI), the coordinates of the grid points.
!
!    Output, integer NGP(2*(NT+2*NL)) where the
!    number of grid points that belong to each of the
!    triangles or of the border line segments are to be stored.
!
!    Output, integer IGP(NXI*NYI), where the grid point numbers are to be
!    stored in ascending order of the triangle number and the border line
!    segment number.
!

!
  integer(kint) nl
  integer(kint) nt
  integer(kint) nxi
  integer(kint) nyi
!
  integer(kint) igp(nxi*nyi)
  integer(kint) il0
  integer(kint) il0t3
  integer(kint) ilp1
  integer(kint) ilp1t3
  integer(kint) insd
  integer(kint) ip1
  integer(kint) ip2
  integer(kint) ip3
  integer(kint) ipl(3*nl)
  integer(kint) ipt(3*nt)
  integer(kint) it0
  integer(kint) it0t3
  integer(kint) ixi
  integer(kint) iximn
  integer(kint) iximx
  integer(kint) iyi
  integer(kint) izi
  integer(kint) jigp0
  integer(kint) jigp1
  integer(kint) jigp1i
  integer(kint) jngp0
  integer(kint) jngp1
  integer(kint) l
  integer(kint) ngp(2*(nt+2*nl))
  integer(kint) ngp0
  integer(kint) ngp1
  integer(kint) nl0
  integer(kint) nt0
  integer(kint) nxinyi
  real(kreal) spdt
  real(kreal) u1
  real(kreal) u2
  real(kreal) u3
  real(kreal) v1
  real(kreal) v2
  real(kreal) v3
  real(kreal) vpdt
  real(kreal) x1
  real(kreal) x2
  real(kreal) x3
  real(kreal) xd(*)
  real(kreal) xi(nxi)
  real(kreal) xii
  real(kreal) ximn
  real(kreal) ximx
  real(kreal) xmn
  real(kreal) xmx
  real(kreal) y1
  real(kreal) y2
  real(kreal) y3
  real(kreal) yd(*)
  real(kreal) yi(nyi)
  real(kreal) yii
  real(kreal) yimn
  real(kreal) yimx
  real(kreal) ymn
  real(kreal) ymx
!
!  Statement functions
!
  spdt(u1,v1,u2,v2,u3,v3) = (u1-u2)*(u3-u2)+(v1-v2)*(v3-v2)

  vpdt(u1,v1,u2,v2,u3,v3) = (u1-u3)*(v2-v3)-(v1-v3)*(u2-u3)
!
!  Preliminary processing
!
  nt0 = nt
  nl0 = nl
  nxinyi = nxi * nyi
  ximn = min ( xi(1), xi(nxi) )
  ximx = max ( xi(1), xi(nxi) )
  yimn = min ( yi(1), yi(nyi) )
  yimx = max ( yi(1), yi(nyi) )
!
!  Determine grid points inside the data area.
!
  jngp0 = 0
  jngp1 = 2*(nt0+2*nl0)+1
  jigp0 = 0
  jigp1 = nxinyi + 1

  do it0 = 1, nt0

    ngp0 = 0
    ngp1 = 0
    it0t3 = it0*3
    ip1 = ipt(it0t3-2)
    ip2 = ipt(it0t3-1)
    ip3 = ipt(it0t3)
    x1 = xd(ip1)
    y1 = yd(ip1)
    x2 = xd(ip2)
    y2 = yd(ip2)
    x3 = xd(ip3)
    y3 = yd(ip3)
    xmn = min ( x1, x2, x3 )
    xmx = max ( x1, x2, x3 )
    ymn = min ( y1, y2, y3 )
    ymx = max ( y1, y2, y3 )
    insd = 0

    do ixi = 1, nxi

      if ( xi(ixi) < xmn .or. xi(ixi) > xmx ) then
        if ( insd == 0 ) then
          cycle
        end if
        iximx = ixi-1
        go to 23
      end if

      if ( insd /= 1 ) then
        insd = 1
        iximn = ixi
      end if

    end do

    if ( insd == 0 ) then
      go to 38
    end if

    iximx = nxi

23  continue

    do iyi = 1, nyi

      yii = yi(iyi)

      if ( yii < ymn .or. yii > ymx ) then
        go to 37
      end if

      do ixi = iximn, iximx

        xii = xi(ixi)
        l = 0
        if ( vpdt(x1,y1,x2,y2,xii,yii) ) 36,25,26

25      continue

        l = 1
26      continue
        if(vpdt(x2,y2,x3,y3,xii,yii))     36,27,28
27      continue
        l = 1
28      continue
        if(vpdt(x3,y3,x1,y1,xii,yii))     36,29,30
29      continue
        l = 1
30      continue
        izi = nxi*(iyi-1)+ixi

        if ( l == 1 ) go to 31

        ngp0 = ngp0+1
        jigp0 = jigp0+1
        igp(jigp0) = izi
        go to 36

31      continue

        do jigp1i = jigp1,nxinyi
          if ( izi == igp(jigp1i) ) then
            go to 36
          end if
        end do

        ngp1 = ngp1+1
        jigp1 = jigp1-1
        igp(jigp1) = izi

36      continue

      end do

37    continue

    end do

38  continue

    jngp0 = jngp0+1
    ngp(jngp0) = ngp0
    jngp1 = jngp1-1
    ngp(jngp1) = ngp1

  end do
!
!  Determine grid points outside the data area.
!  in semi-infinite rectangular area.
!
  do il0 = 1, nl0

    ngp0 = 0
    ngp1 = 0
    il0t3 = il0*3
    ip1 = ipl(il0t3-2)
    ip2 = ipl(il0t3-1)
    x1 = xd(ip1)
    y1 = yd(ip1)
    x2 = xd(ip2)
    y2 = yd(ip2)

    xmn = ximn
    xmx = ximx
    ymn = yimn
    ymx = yimx

    if ( y2 >= y1 ) then
      xmn = min ( x1, x2 )
    end if

    if ( y2 <= y1 ) then
      xmx = max ( x1, x2 )
    end if

    if ( x2 <= x1 ) then
      ymn = min ( y1, y2 )
    end if

    if ( x2 >= x1 ) then
      ymx = max ( y1, y2 )
    end if

    insd = 0

    do ixi = 1, nxi

      if ( xi(ixi) < xmn .or. xi(ixi) > xmx ) then
        if ( insd == 0 ) then
          go to 42
        end if
        iximx = ixi-1
        go to 43
      end if

      if ( insd /= 1 ) then
        insd = 1
        iximn = ixi
      end if

42    continue

    end do

    if ( insd == 0 ) go to 58

    iximx = nxi

43  continue

    do iyi = 1, nyi

      yii = yi(iyi)
      if(yii<ymn.or.yii>ymx)        go to 57

      do ixi = iximn,iximx

        xii = xi(ixi)
        l = 0
        if(vpdt(x1,y1,x2,y2,xii,yii))     46,45,56
   45       l = 1
   46       if(spdt(x2,y2,x1,y1,xii,yii))     56,47,48
   47       l = 1
   48       if(spdt(x1,y1,x2,y2,xii,yii))     56,49,50
   49       l = 1
   50       izi = nxi*(iyi-1)+ixi
        if(l==1)    go to 51
        ngp0 = ngp0+1
        jigp0 = jigp0+1
        igp(jigp0) = izi
        go to 56

51      continue

        do jigp1i = jigp1,nxinyi
          if(izi==igp(jigp1i))     go to 56
        end do

53      continue

        ngp1 = ngp1+1
        jigp1 = jigp1-1
        igp(jigp1) = izi

56      continue

      end do

57    continue

    end do

58  continue

    jngp0 = jngp0+1
    ngp(jngp0) = ngp0
    jngp1 = jngp1-1
    ngp(jngp1) = ngp1
!
!  In semi-infinite triangular area.
!
60  continue

    ngp0 = 0
    ngp1 = 0
    ilp1 = mod(il0,nl0)+1
    ilp1t3 = ilp1*3
    ip3 = ipl(ilp1t3-1)
    x3 = xd(ip3)
    y3 = yd(ip3)
    xmn = ximn
    xmx = ximx
    ymn = yimn
    ymx = yimx
    if(y3>=y2.and.y2>=y1)   xmn = x2
    if(y3<=y2.and.y2<=y1)   xmx = x2
    if(x3<=x2.and.x2<=x1)   ymn = y2
    if(x3>=x2.and.x2>=x1)   ymx = y2
    insd = 0

    do ixi = 1, nxi

      if ( xi(ixi) < xmn .or. xi(ixi) > xmx ) then
        if(insd==0)   go to 62
        iximx = ixi-1
        go to 63
      end if

      if ( insd /= 1 ) then
        insd = 1
        iximn = ixi
      end if

62    continue

    end do

    if(insd==0)     go to 78

    iximx = nxi

63  continue

    do iyi = 1, nyi

      yii = yi(iyi)
      if(yii<ymn.or.yii>ymx)        go to 77

      do ixi = iximn, iximx

        xii = xi(ixi)
        l = 0
        if ( spdt(x1,y1,x2,y2,xii,yii) )     66,65,76
   65       l = 1
   66       if(spdt(x3,y3,x2,y2,xii,yii))     70,67,76
   67       l = 1
   70       izi = nxi*(iyi-1)+ixi

        if ( l /= 1 ) then
          ngp0 = ngp0+1
          jigp0 = jigp0+1
          igp(jigp0) = izi
          go to 76
        end if

        do jigp1i = jigp1, nxinyi
          if(izi==igp(jigp1i)) go to 76
        end do

        ngp1 = ngp1+1
        jigp1 = jigp1-1
        igp(jigp1) = izi

76      continue

      end do

77    continue

    end do

78  continue

    jngp0 = jngp0+1
    ngp(jngp0) = ngp0
    jngp1 = jngp1-1
    ngp(jngp1) = ngp1

  end do

  return
end subroutine

subroutine idlctn ( ndp, xd, yd, nt, ipt, nl, ipl, xii, yii, iti, iwk, wk )
!
!*******************************************************************************
!
!! IDLCTN finds the triangle that contains a point.
!
!
!  Discusstion:
!
!    IDLCTN determines what triangle a given point (XII, YII) belongs to.
!    When the given point does not lie inside the data area, IDLCTN
!    determines the border line segment when the point lies in an outside
!    rectangular area, and two border line segments when the point
!    lies in an outside triangular area.
!
!  Parameters:
!
!    Input, integer NDP, the number of data points.
!
!    Input, real XD(NDP), YD(NDP), the X and Y coordinates of the data.
!
!    Input, integer NT, the number of triangles.
!
!    Input, integer IPT(3*NT), the point numbers of the vertexes of
!    the triangles,
!
!    Input, integer NL, the number of border line segments.
!
!    Input, integer IPL(3*NL), the point numbers of the end points of
!    the border line segments and their respective triangle numbers.
!
!    Input, real XII, YII, the coordinates of the point to be located.
!
!    Output, integer ITI, the triangle number, when the point is inside the
!    data area, or two border line segment numbers, il1 and il2,
!    coded to il1*(nt+nl)+il2, when the point is outside the data area.
!
!    Workspace, integer IWK(18*NDP).
!
!    Workspace, real WK(8*NDP).
!

!
  integer(kint) ndp
  integer(kint) nl
  integer(kint) nt
!
  integer(kint) i1
  integer(kint) i2
  integer(kint) i3
  integer(kint) idp
  integer(kint) idsc(9)
  integer(kint) il1
  integer(kint) il1t3
  integer(kint) il2
  integer(kint) ip1
  integer(kint) ip2
  integer(kint) ip3
  integer(kint) ipl(3*nl)
  integer(kint) ipt(3*nt)
  integer(kint) isc
  integer(kint) it0
  integer(kint) it0t3
  integer(kint) iti
  integer(kint) itipv
  integer(kint) itsc
  integer(kint) iwk(18*ndp)
  integer(kint) jiwk
  integer(kint) jwk
  integer(kint) nl0
  integer(kint) nt0
  integer(kint) ntl
  integer(kint) ntsc
  integer(kint) ntsci
  real(kreal) spdt
  real(kreal) u1
  real(kreal) u2
  real(kreal) u3
  real(kreal) v1
  real(kreal) v2
  real(kreal) v3
  real(kreal) vpdt
  real(kreal) wk(8*ndp)
  real(kreal) x0
  real(kreal) x1
  real(kreal) x2
  real(kreal) x3
  real(kreal) xd(ndp)
  real(kreal) xii
  real(kreal) xmn
  real(kreal) xmx
  real(kreal) xs1
  real(kreal) xs2
  real(kreal) y0
  real(kreal) y1
  real(kreal) y2
  real(kreal) y3
  real(kreal) yd(ndp)
  real(kreal) yii
  real(kreal) ymn
  real(kreal) ymx
  real(kreal) ys1
  real(kreal) ys2
!
  save /idlc/
!
  common /idlc/ itipv,xs1,xs2,ys1,ys2,ntsc(9)
!
!  Statement functions
!
  spdt(u1,v1,u2,v2,u3,v3) = (u1-u2)*(u3-u2)+(v1-v2)*(v3-v2)

  vpdt(u1,v1,u2,v2,u3,v3) = (u1-u3)*(v2-v3)-(v1-v3)*(u2-u3)
!
!  Preliminary processing
!
  nt0 = nt
  nl0 = nl
  ntl = nt0+nl0
  x0 = xii
  y0 = yii
!
!  Processing for a new set of data points
!
  if ( itipv/=0)      go to 30
!
!  Divide the x-y plane into nine rectangular sections.
!
  xmn = xd(1)
  xmx = xd(1)
  ymn = yd(1)
  ymx = yd(1)
  do idp = 2, ndp
    xmn = min ( xd(idp), xmn )
    xmx = max ( xd(idp), xmx )
    ymn = min ( yd(idp), ymn )
    ymx = max ( yd(idp), ymx )
  end do

  xs1 = ( xmn + xmn + xmx ) / 3.0E+00
  xs2 = ( xmn + xmx + xmx ) / 3.0E+00
  ys1 = ( ymn + ymn + ymx ) / 3.0E+00
  ys2 = ( ymn + ymx + ymx ) / 3.0E+00
!
!  Determine and store in the iwk array, triangle numbers of
!  the triangles associated with each of the nine sections.
!
  ntsc(1:9) = 0
  idsc(1:9) = 0

  it0t3 = 0
  jwk = 0

  do it0 = 1, nt0

    it0t3 = it0t3+3
    i1 = ipt(it0t3-2)
    i2 = ipt(it0t3-1)
    i3 = ipt(it0t3)
    xmn = min ( xd(i1), xd(i2), xd(i3) )
    xmx = max ( xd(i1), xd(i2), xd(i3) )
    ymn = min ( yd(i1), yd(i2), yd(i3) )
    ymx = max ( yd(i1), yd(i2), yd(i3) )

    if ( ymn <= ys1 ) then
      if(xmn<=xs1)                   idsc(1) = 1
      if(xmx>=xs1.and.xmn<=xs2)    idsc(2) = 1
      if(xmx>=xs2)                   idsc(3) = 1
    end if

    if ( ymx >= ys1 .and. ymn <= ys2 ) then
      if(xmn<=xs1)                   idsc(4) = 1
      if(xmx>=xs1.and.xmn<=xs2)    idsc(5) = 1
      if(xmx>=xs2)                   idsc(6) = 1
    end if

    if(ymx<ys2)                   go to 25
    if(xmn<=xs1)                   idsc(7) = 1
    if(xmx>=xs1.and.xmn<=xs2)    idsc(8) = 1
    if(xmx>=xs2)                   idsc(9) = 1

25  continue

    do isc = 1, 9
      if ( idsc(isc) /= 0 ) then
        jiwk = 9*ntsc(isc)+isc
        iwk(jiwk) = it0
        ntsc(isc) = ntsc(isc)+1
        idsc(isc) = 0
      end if
    end do
!
!  Store in the wk array the minimum and maximum of the X and
!  Y coordinate values for each of the triangle.
!
    jwk = jwk+4
    wk(jwk-3) = xmn
    wk(jwk-2) = xmx
    wk(jwk-1) = ymn
    wk(jwk)   = ymx

  end do

  go to 60
!
!  Check if in the same triangle as previous.
!
30 continue

  it0 = itipv

  if(it0>nt0)      go to 40

  it0t3 = it0*3
  ip1 = ipt(it0t3-2)
  x1 = xd(ip1)
  y1 = yd(ip1)
  ip2 = ipt(it0t3-1)
  x2 = xd(ip2)
  y2 = yd(ip2)
  if(vpdt(x1,y1,x2,y2,x0,y0) < 0.0E+00 )      go to 60
  ip3 = ipt(it0t3)
  x3 = xd(ip3)
  y3 = yd(ip3)
  if(vpdt(x2,y2,x3,y3,x0,y0) < 0.0E+00 )      go to 60
  if(vpdt(x3,y3,x1,y1,x0,y0) < 0.0E+00 )      go to 60

  iti = it0
  itipv = it0

  return
!
!  Check if on the same border line segment.
!
40 continue

  il1 = it0 / ntl
  il2 = it0-il1*ntl
  il1t3 = il1*3
  ip1 = ipl(il1t3-2)
  x1 = xd(ip1)
  y1 = yd(ip1)
  ip2 = ipl(il1t3-1)
  x2 = xd(ip2)
  y2 = yd(ip2)
  if(il2/=il1)      go to 50
  if(spdt(x1,y1,x2,y2,x0,y0) < 0.0E+00 )      go to 60
  if(spdt(x2,y2,x1,y1,x0,y0) < 0.0E+00 )      go to 60
  if(vpdt(x1,y1,x2,y2,x0,y0) > 0.0E+00 )      go to 60

  iti = it0
  itipv = it0

  return
!
!  Check if between the same two border line segments.
!
50 continue

  if(spdt(x1,y1,x2,y2,x0,y0) > 0.0E+00 )      go to 60

  ip3 = ipl(3*il2-1)
  x3 = xd(ip3)
  y3 = yd(ip3)

  if ( spdt(x3,y3,x2,y2,x0,y0) <= 0.0E+00 )  then
    iti = it0
    itipv = it0
    return
  end if
!
!  Locate inside the data area.
!  Determine the section in which the point in question lies.
!
60 continue

  isc = 1

  if ( x0 >= xs1 ) then
    isc = isc+1
  end if

  if ( x0 >= xs2 ) then
    isc = isc+1
  end if

  if ( y0 >= ys1 ) then
    isc = isc+3
  end if

  if ( y0 >= ys2 ) then
    isc = isc+3
  end if
!
!  Search through the triangles associated with the section.
!
  ntsci = ntsc(isc)
  if(ntsci<=0)      go to 70
  jiwk = -9+isc

  do itsc = 1, ntsci

    jiwk = jiwk+9
    it0 = iwk(jiwk)
    jwk = it0*4
    if(x0<wk(jwk-3))    go to 61
    if(x0>wk(jwk-2))    go to 61
    if(y0<wk(jwk-1))    go to 61
    if(y0>wk(jwk))      go to 61
    it0t3 = it0*3
    ip1 = ipt(it0t3-2)
    x1 = xd(ip1)
    y1 = yd(ip1)
    ip2 = ipt(it0t3-1)
    x2 = xd(ip2)
    y2 = yd(ip2)
    if(vpdt(x1,y1,x2,y2,x0,y0)<0.0E+00 )    go to 61
    ip3 = ipt(it0t3)
    x3 = xd(ip3)
    y3 = yd(ip3)

    if ( vpdt(x2,y2,x3,y3,x0,y0) >= 0.0E+00 ) then

      if ( vpdt(x3,y3,x1,y1,x0,y0) >= 0.0E+00 ) then
        iti = it0
        itipv = it0
        return
      end if

    end if

61  continue

  end do
!
!  Locate outside the data area.
!
70 continue

  do il1 = 1, nl0

    il1t3 = il1*3
    ip1 = ipl(il1t3-2)
    x1 = xd(ip1)
    y1 = yd(ip1)
    ip2 = ipl(il1t3-1)
    x2 = xd(ip2)
    y2 = yd(ip2)
    if(spdt(x2,y2,x1,y1,x0,y0)<0.0E+00 )    go to 72
    if(spdt(x1,y1,x2,y2,x0,y0)<0.0E+00 )    go to 71
    if(vpdt(x1,y1,x2,y2,x0,y0)>0.0E+00 )    go to 72
    il2 = il1
    go to 75

   71   continue

    il2 = mod(il1,nl0)+1
    ip3 = ipl(3*il2-1)
    x3 = xd(ip3)
    y3 = yd(ip3)
    if(spdt(x3,y3,x2,y2,x0,y0)<=0.0E+00 )    go to 75

   72   continue

  end do

  it0 = 1
  iti = it0
  itipv = it0

  return

   75 continue

  it0 = il1*ntl+il2
  iti = it0
  itipv = it0

  return
end subroutine

subroutine idpdrv ( ndp, xd, yd, zd, nt, ipt, pd, wk )
!
!*******************************************************************************
!
!! IDPDRV estimates first and second partial derivatives at data points.
!
!
!  Parameters:
!
!    Input, integer NDP, the number of data points.
!
!    Input, real XD(NDP), YD(NDP), the X and Y coordinates of the data.
!
!    Input, real ZD(NDP), the data values.
!
!    Input, integer NT, the number of triangles.
!
!    Input, integer IPT(3*NT), the point numbers of the vertexes of the
!    triangles.
!
!    Output, real PD(5*NDP), the estimated zx, zy, zxx, zxy, and zyy values
!    at the ith data point are to be stored as  the (5*i-4)th, (5*i-3)rd,
!    (5*i-2)nd, (5*i-1)st and (5*i)th elements, respectively, where i =
!    1, 2, ..., ndp.
!
!    Workspace, real WK(NDP).
!

!
  integer(kint) ndp
  integer(kint) nt
!
  real(kreal) d12
  real(kreal) d23
  real(kreal) d31
  real(kreal) dx1
  real(kreal) dx2
  real(kreal) dy1
  real(kreal) dy2
  real(kreal) dz1
  real(kreal) dz2
  real(kreal) dzx1
  real(kreal) dzx2
  real(kreal) dzy1
  real(kreal) dzy2
  real(kreal), parameter :: epsln = 1.0E-06
  integer(kint) idp
  integer(kint) ipt(3*nt)
  integer(kint) ipti(3)
  integer(kint) it
  integer(kint) iv
  integer(kint) jpd
  integer(kint) jpd0
  integer(kint) jpdmx
  integer(kint) jpt
  integer(kint) jpt0
  integer(kint) nt0
  real(kreal) pd(5*ndp)
  real(kreal) vpx
  real(kreal) vpxx
  real(kreal) vpxy
  real(kreal) vpy
  real(kreal) vpyx
  real(kreal) vpyy
  real(kreal) vpz
  real(kreal) vpzmn
  real(kreal) w1(3)
  real(kreal) w2(3)
  real(kreal) wi
  real(kreal) wk(ndp)
  real(kreal) xd(ndp)
  real(kreal) xv(3)
  real(kreal) yd(ndp)
  real(kreal) yv(3)
  real(kreal) zd(ndp)
  real(kreal) zv(3)
  real(kreal) zxv(3)
  real(kreal) zyv(3)
!
!  Preliminary processing.
!
  nt0 = nt
!
!  Clear the PD array.
!
  jpdmx = 5*ndp

  pd(1:jpdmx) = 0.0E+00

  wk(1:ndp) = 0.0E+00
!
!  Estimate ZX and ZY.
!
  do it = 1, nt0

    jpt0 = 3*(it-1)

    do iv = 1, 3
      jpt = jpt0+iv
      idp = ipt(jpt)
      ipti(iv) = idp
      xv(iv) = xd(idp)
      yv(iv) = yd(idp)
      zv(iv) = zd(idp)
    end do

    dx1 = xv(2)-xv(1)
    dy1 = yv(2)-yv(1)
    dz1 = zv(2)-zv(1)
    dx2 = xv(3)-xv(1)
    dy2 = yv(3)-yv(1)
    dz2 = zv(3)-zv(1)
    vpx = dy1*dz2-dz1*dy2
    vpy = dz1*dx2-dx1*dz2
    vpz = dx1*dy2-dy1*dx2
    vpzmn = abs(dx1*dx2+dy1*dy2)*epsln

    if ( abs(vpz) > vpzmn ) then

      d12 = sqrt((xv(2)-xv(1))**2+(yv(2)-yv(1))**2)
      d23 = sqrt((xv(3)-xv(2))**2+(yv(3)-yv(2))**2)
      d31 = sqrt((xv(1)-xv(3))**2+(yv(1)-yv(3))**2)
      w1(1) = 1.0E+00 / (d31*d12)
      w1(2) = 1.0E+00 / (d12*d23)
      w1(3) = 1.0E+00 / (d23*d31)
      w2(1) = vpz*w1(1)
      w2(2) = vpz*w1(2)
      w2(3) = vpz*w1(3)

      do iv = 1, 3
        idp = ipti(iv)
        jpd0 = 5*(idp-1)
        !wi = (w1(iv)**2)*w2(iv)
        wi = 1.0_kreal
        pd(jpd0+1) = pd(jpd0+1)+vpx*wi
        pd(jpd0+2) = pd(jpd0+2)+vpy*wi
        wk(idp) = wk(idp)+vpz*wi
      end do

    end if

  end do

  do idp = 1, ndp
    jpd0 = 5*(idp-1)
    pd(jpd0+1) = -pd(jpd0+1)/wk(idp)
    pd(jpd0+2) = -pd(jpd0+2)/wk(idp)
  end do
!
!  Estimate ZXX, ZXY, and ZYY.
!
  do it = 1, nt0

    jpt0 = 3*(it-1)

    do iv = 1, 3
      jpt = jpt0+iv
      idp = ipt(jpt)
      ipti(iv) = idp
      xv(iv) = xd(idp)
      yv(iv) = yd(idp)
      jpd0 = 5*(idp-1)
      zxv(iv) = pd(jpd0+1)
      zyv(iv) = pd(jpd0+2)
    end do

    dx1 = xv(2)-xv(1)
    dy1 = yv(2)-yv(1)
    dzx1 = zxv(2)-zxv(1)
    dzy1 = zyv(2)-zyv(1)
    dx2 = xv(3)-xv(1)
    dy2 = yv(3)-yv(1)
    dzx2 = zxv(3)-zxv(1)
    dzy2 = zyv(3)-zyv(1)
    vpxx = dy1*dzx2-dzx1*dy2
    vpxy = dzx1*dx2-dx1*dzx2
    vpyx = dy1*dzy2-dzy1*dy2
    vpyy = dzy1*dx2-dx1*dzy2
    vpz = dx1*dy2-dy1*dx2
    vpzmn = abs(dx1*dx2+dy1*dy2)*epsln

    if ( abs(vpz) > vpzmn ) then

      d12 = sqrt((xv(2)-xv(1))**2+(yv(2)-yv(1))**2)
      d23 = sqrt((xv(3)-xv(2))**2+(yv(3)-yv(2))**2)
      d31 = sqrt((xv(1)-xv(3))**2+(yv(1)-yv(3))**2)
      w1(1) = 1.0E+00 /(d31*d12)
      w1(2) = 1.0E+00 /(d12*d23)
      w1(3) = 1.0E+00 /(d23*d31)
      w2(1) = vpz*w1(1)
      w2(2) = vpz*w1(2)
      w2(3) = vpz*w1(3)

      do iv = 1, 3
        idp = ipti(iv)
        jpd0 = 5*(idp-1)
        !wi = (w1(iv)**2)*w2(iv)
        wi = 1.0_kreal
        pd(jpd0+3) = pd(jpd0+3)+vpxx*wi
        pd(jpd0+4) = pd(jpd0+4)+(vpxy+vpyx)*wi
        pd(jpd0+5) = pd(jpd0+5)+vpyy*wi
      end do

    end if

  end do

  do idp = 1, ndp
    jpd0 = 5*(idp-1)
    pd(jpd0+3) = -pd(jpd0+3)/wk(idp)
    pd(jpd0+4) = -pd(jpd0+4)/(2.0*wk(idp))
    pd(jpd0+5) = -pd(jpd0+5)/wk(idp)
  end do

  return
end subroutine

subroutine idptip ( ndp,xd, yd, zd, nt, ipt, nl, ipl, pdd, iti, xii, yii, zii )
!
!*******************************************************************************
!
!! IDPTIP performs interpolation, determining a value of Z given X and Y.
!
!
!  Modified:
!
!    19 February 2001
!
!  Parameters:
!
!    Input, integer NDP, the number of data values.
!
!    Input, real XD(NDP), YD(NDP), the X and Y coordinates of the data.
!
!    Input, real ZD(NDP), the data values.
!
!    Input, integer NT, the number of triangles.
!
!    Input, ipt = integer array of dimension 3*nt containing the
!    point numbers of the vertexes of the triangles,
!
!    Input, integer NL, the number of border line segments.
!
!    Input, integer IPL(3*NL), the point numbers of the end points of the
!    border line segments and their respective triangle numbers,
!
!    Input, real PDD(5*NDP). the partial derivatives at the data points,
!
!    Input, integer ITI, triangle number of the triangle in which lies
!    the point for which interpolation is to be performed,
!
!    Input, real XII, YII, the X and Y coordinates of the point for which
!    interpolation is to be performed.
!
!    Output, real ZII, the interpolated Z value.
!

!
  integer(kint) ndp
  integer(kint) nl
  integer(kint) nt
!
  real(kreal) a
  real(kreal) aa
  real(kreal) ab
  real(kreal) ac
  real(kreal) act2
  real(kreal) ad
  real(kreal) adbc
  real(kreal) ap
  real(kreal) b
  real(kreal) bb
  real(kreal) bc
  real(kreal) bdt2
  real(kreal) bp
  real(kreal) c
  real(kreal) cc
  real(kreal) cd
  real(kreal) cp
  real(kreal) csuv
  real(kreal) d
  real(kreal) dd
  real(kreal) dlt
  real(kreal) dp
  real(kreal) dx
  real(kreal) dy
  real(kreal) g1
  real(kreal) g2
  real(kreal) h1
  real(kreal) h2
  real(kreal) h3
  integer(kint) i
  integer(kint) idp
  integer(kint) il1
  integer(kint) il2
  integer(kint) ipl(3*nl)
  integer(kint) ipt(3*nt)
  integer(kint) it0
  integer(kint) iti
  integer(kint) itpv
  integer(kint) jipl
  integer(kint) jipt
  integer(kint) jpd
  integer(kint) jpdd
  integer(kint) kpd
  integer(kint) ntl
  real(kreal) lu
  real(kreal) lv
  real(kreal) p0
  real(kreal) p00
  real(kreal) p01
  real(kreal) p02
  real(kreal) p03
  real(kreal) p04
  real(kreal) p05
  real(kreal) p1
  real(kreal) p10
  real(kreal) p11
  real(kreal) p12
  real(kreal) p13
  real(kreal) p14
  real(kreal) p2
  real(kreal) p20
  real(kreal) p21
  real(kreal) p22
  real(kreal) p23
  real(kreal) p3
  real(kreal) p30
  real(kreal) p31
  real(kreal) p32
  real(kreal) p4
  real(kreal) p40
  real(kreal) p41
  real(kreal) p5
  real(kreal) p50
  real(kreal) pd(15)
  real(kreal) pdd(5*ndp)
  real(kreal) thsv
  real(kreal) thus
  real(kreal) thuv
  real(kreal) thxu
  real(kreal) u
  real(kreal) v
  real(kreal) x(3)
  real(kreal) x0
  real(kreal) xd(*)
  real(kreal) xii
  real(kreal) y(3)
  real(kreal) y0
  real(kreal) yd(*)
  real(kreal) yii
  real(kreal) z(3)
  real(kreal) z0
  real(kreal) zd(*)
  real(kreal) zii
  real(kreal) zu(3)
  real(kreal) zuu(3)
  real(kreal) zuv(3)
  real(kreal) zv(3)
  real(kreal) zvv(3)
!
  save /idpt/
!
  common /idpt/ itpv,x0,y0,ap,bp,cp,dp, &
                p00,p10,p20,p30,p40,p50,p01,p11,p21,p31,p41, &
                p02,p12,p22,p32,p03,p13,p23,p04,p14,p05
!
!  Preliminary processing
!
  it0 = iti
  ntl = nt+nl

  if ( it0 > ntl ) then
    il1 = it0/ntl
    il2 = it0-il1*ntl
    if(il1==il2)      go to 40
    go to 60
  end if
!
!  Calculation of ZII by interpolation.
!  Check if the necessary coefficients have been calculated.
!
  if ( it0 == itpv )     go to 30
!
!  Load coordinate and partial derivative values at the vertexes.
!
  jipt = 3*(it0-1)
  jpd = 0

  do i = 1, 3

    jipt = jipt+1
    idp = ipt(jipt)
    x(i) = xd(idp)
    y(i) = yd(idp)
    z(i) = zd(idp)
    jpdd = 5*(idp-1)

    do kpd = 1, 5
      jpd = jpd+1
      jpdd = jpdd+1
      pd(jpd) = pdd(jpdd)
    end do

  end do
!
!  Determine the coefficients for the coordinate system
!  transformation from the XY system to the UV system and vice versa.
!
  x0 = x(1)
  y0 = y(1)
  a = x(2)-x0
  b = x(3)-x0
  c = y(2)-y0
  d = y(3)-y0
  ad = a*d
  bc = b*c
  dlt = ad-bc
  ap =  d/dlt
  bp = -b/dlt
  cp = -c/dlt
  dp =  a/dlt
!
!  Convert the partial derivatives at the vertexes of the
!  triangle for the UV coordinate system.
!
  aa = a*a
  act2 = 2.0E+00 *a*c
  cc = c*c
  ab = a*b
  adbc = ad+bc
  cd = c*d
  bb = b*b
  bdt2 = 2.0E+00 *b*d
  dd = d*d

  do i = 1, 3
    jpd = 5*i
    zu(i) = a*pd(jpd-4)+c*pd(jpd-3)
    zv(i) = b*pd(jpd-4)+d*pd(jpd-3)
    zuu(i) = aa*pd(jpd-2)+act2*pd(jpd-1)+cc*pd(jpd)
    zuv(i) = ab*pd(jpd-2)+adbc*pd(jpd-1)+cd*pd(jpd)
    zvv(i) = bb*pd(jpd-2)+bdt2*pd(jpd-1)+dd*pd(jpd)
  end do
!
!  Calculate the coefficients of the polynomial.
!
  p00 = z(1)
  p10 = zu(1)
  p01 = zv(1)
  p20 = 0.5E+00 * zuu(1)
  p11 = zuv(1)
  p02 = 0.5E+00 * zvv(1)
  h1 = z(2)-p00-p10-p20
  h2 = zu(2)-p10-zuu(1)
  h3 = zuu(2)-zuu(1)
  p30 =  10.0E+00 * h1 - 4.0E+00 * h2 + 0.5E+00 * h3
  p40 = -15.0E+00 * h1 + 7.0E+00 * h2           - h3
  p50 =   6.0E+00 * h1 - 3.0E+00 * h2 + 0.5E+00 * h3
  h1 = z(3)-p00-p01-p02
  h2 = zv(3)-p01-zvv(1)
  h3 = zvv(3)-zvv(1)
  p03 =  10.0E+00 * h1 - 4.0E+00 * h2 + 0.5E+00 * h3
  p04 = -15.0E+00 * h1 + 7.0E+00 * h2    -h3
  p05 =   6.0E+00 * h1 - 3.0E+00 * h2 + 0.5E+00 * h3
  lu = sqrt(aa+cc)
  lv = sqrt(bb+dd)
  thxu = atan2(c,a)
  thuv = atan2(d,b)-thxu
  csuv = cos(thuv)
  p41 = 5.0E+00*lv*csuv/lu*p50
  p14 = 5.0E+00*lu*csuv/lv*p05
  h1 = zv(2)-p01-p11-p41
  h2 = zuv(2)-p11-4.0E+00 * p41
  p21 =  3.0E+00 * h1-h2
  p31 = -2.0E+00 * h1+h2
  h1 = zu(3)-p10-p11-p14
  h2 = zuv(3)-p11- 4.0E+00 * p14
  p12 =  3.0E+00 * h1-h2
  p13 = -2.0E+00 * h1+h2
  thus = atan2(d-c,b-a)-thxu
  thsv = thuv-thus
  aa =  sin(thsv)/lu
  bb = -cos(thsv)/lu
  cc =  sin(thus)/lv
  dd =  cos(thus)/lv
  ac = aa*cc
  ad = aa*dd
  bc = bb*cc
  g1 = aa * ac*(3.0E+00*bc+2.0E+00*ad)
  g2 = cc * ac*(3.0E+00*ad+2.0E+00*bc)
  h1 = -aa*aa*aa*(5.0E+00*aa*bb*p50+(4.0E+00*bc+ad)*p41) &
       -cc*cc*cc*(5.0E+00*cc*dd*p05+(4.0E+00*ad+bc)*p14)
  h2 = 0.5E+00 * zvv(2)-p02-p12
  h3 = 0.5E+00 * zuu(3)-p20-p21
  p22 = (g1*h2+g2*h3-h1)/(g1+g2)
  p32 = h2-p22
  p23 = h3-p22
  itpv = it0
!
!  Convert XII and YII to UV system.
!
30 continue

  dx = xii-x0
  dy = yii-y0
  u = ap*dx+bp*dy
  v = cp*dx+dp*dy
!
!  Evaluate the polynomial.
!
  p0 = p00+v*(p01+v*(p02+v*(p03+v*(p04+v*p05))))
  p1 = p10+v*(p11+v*(p12+v*(p13+v*p14)))
  p2 = p20+v*(p21+v*(p22+v*p23))
  p3 = p30+v*(p31+v*p32)
  p4 = p40+v*p41
  p5 = p50
  zii = p0+u*(p1+u*(p2+u*(p3+u*(p4+u*p5))))
  return
!
!  Calculation of ZII by extrapolation in the rectangle.
!  Check if the necessary coefficients have been calculated.
!
40 continue

  if(it0==itpv)     go to 50
!
!  Load coordinate and partial derivative values at the end
!  points of the border line segment.
!
  jipl = 3*(il1-1)
  jpd = 0

  do i = 1, 2

    jipl = jipl+1
    idp = ipl(jipl)
    x(i) = xd(idp)
    y(i) = yd(idp)
    z(i) = zd(idp)
    jpdd = 5*(idp-1)

    do kpd = 1, 5
      jpd = jpd+1
      jpdd = jpdd+1
      pd(jpd) = pdd(jpdd)
    end do

  end do
!
!  Determine the coefficients for the coordinate system
!  transformation from the XY system to the UV system
!  and vice versa.
!
  x0 = x(1)
  y0 = y(1)
  a = y(2)-y(1)
  b = x(2)-x(1)
  c = -b
  d = a
  ad = a*d
  bc = b*c
  dlt = ad-bc
  ap =  d/dlt
  bp = -b/dlt
  cp = -bp
  dp =  ap
!
!  Convert the partial derivatives at the end points of the
!  border line segment for the UV coordinate system.
!
  aa = a*a
  act2 = 2.0E+00 * a * c
  cc = c*c
  ab = a*b
  adbc = ad+bc
  cd = c*d
  bb = b*b
  bdt2 = 2.0E+00 * b * d
  dd = d*d

  do i = 1, 2
    jpd = 5*i
    zu(i) = a*pd(jpd-4)+c*pd(jpd-3)
    zv(i) = b*pd(jpd-4)+d*pd(jpd-3)
    zuu(i) = aa*pd(jpd-2)+act2*pd(jpd-1)+cc*pd(jpd)
    zuv(i) = ab*pd(jpd-2)+adbc*pd(jpd-1)+cd*pd(jpd)
    zvv(i) = bb*pd(jpd-2)+bdt2*pd(jpd-1)+dd*pd(jpd)
  end do
!
!  Calculate the coefficients of the polynomial.
!
  p00 = z(1)
  p10 = zu(1)
  p01 = zv(1)
  p20 = 0.5E+00 * zuu(1)
  p11 = zuv(1)
  p02 = 0.5E+00 * zvv(1)

  h1 = z(2)-p00-p01-p02
  h2 = zv(2)-p01-zvv(1)
  h3 = zvv(2)-zvv(1)

  p03 =  10.0E+00 * h1 - 4.0E+00*h2+0.5E+00*h3
  p04 = -15.0E+00 * h1 + 7.0E+00*h2    -h3
  p05 =   6.0E+00 * h1 - 3.0E+00*h2+0.5E+00*h3

  h1 = zu(2)-p10-p11
  h2 = zuv(2)-p11

  p12 =  3.0E+00*h1-h2
  p13 = -2.0E+00*h1+h2
  p21 = 0.0E+00
  p23 = -zuu(2)+zuu(1)
  p22 = -1.5E+00*p23

  itpv = it0
!
!  Convert XII and YII to UV system.
!
50 continue

  dx = xii-x0
  dy = yii-y0
  u = ap*dx+bp*dy
  v = cp*dx+dp*dy
!
!  Evaluate the polynomial.
!
  p0 = p00+v*(p01+v*(p02+v*(p03+v*(p04+v*p05))))
  p1 = p10+v*(p11+v*(p12+v*p13))
  p2 = p20+v*(p21+v*(p22+v*p23))
  zii = p0+u*(p1+u*p2)

  return
!
!  Calculation of ZII by extrapolation in the triangle.
!  Check if the necessary coefficients have been calculated.
!
60 continue

  if ( it0 /= itpv ) then
!
!  Load coordinate and partial derivative values at the vertex of the triangle.
!
    jipl = 3*il2-2
    idp = ipl(jipl)
    x0 = xd(idp)
    y0 = yd(idp)
    z0 = zd(idp)
    jpdd = 5*(idp-1)

    do kpd = 1, 5
      jpdd = jpdd+1
      pd(kpd) = pdd(jpdd)
    end do
!
!  Calculate the coefficients of the polynomial.
!
    p00 = z0
    p10 = pd(1)
    p01 = pd(2)
    p20 = 0.5E+00*pd(3)
    p11 = pd(4)
    p02 = 0.5E+00*pd(5)
    itpv = it0

  end if
!
!  Convert XII and YII to UV system.
!
  u = xii-x0
  v = yii-y0
!
!  Evaluate the polynomial.
!
  p0 = p00+v*(p01+v*p02)
  p1 = p10+v*p11
  zii = p0+u*(p1+u*p20)

  return
end subroutine

subroutine idsfft ( md, ndp, xd, yd, zd, nxi, nyi, nzi, xi, yi, zi, iwk, wk )
!
!*******************************************************************************
!
!! IDSFFT fits a smooth surface Z(X,Y) given irregular (X,Y,Z) data.
!
!
!  Discussion:
!
!    IDSFFT performs smooth surface fitting when the projections of the
!    data points in the (X,Y) plane are irregularly distributed.
!
!  Special conditions:
!
!    Inadequate work space IWK and WK may may cause incorrect results.
!
!    The data points must be distinct and their projections in the XY
!    plane must not be collinear, otherwise an error return occurs.
!
!  Parameters:
!
!    Input, integer MD, mode of computation (must be 1, 2, or 3,
!    else an error return will occur).
!
!    1, if this is the first call to this routine, or if the value of
!    NDP has been changed from the previous call, or if the contents of
!    the XD or YD arrays have been changed from the previous call.
!
!    2, if the values of NDP and the XD, YD arrays are unchanged from
!    the previous call, but new values for XI, YI are being used.  If
!    MD = 2 and NDP has been changed since the previous call to IDSFFT,
!    an error return occurs.
!
!    3, if the values of NDP, NXI, NYI, XD, YD, XI, YI are unchanged
!    from the previous call, i.e. if the only change on input to idsfft
!    is in the ZD array.  If MD = 3 and NDP, nxi or nyi has been changed
!    since the previous call to idsfft, an error return occurs.
!
!    Between the call with MD = 2 or MD = 3 and the preceding call, the
!    iwk and wk work arrays should not be disturbed.
!
!    Input, integer NDP, the number of data points.  NDP must be at least 4.
!
!    Input, real XD(NDP), YD(NDP), the X and Y coordinates of the data.
!
!    Input, real ZD(NDP), the data values.
!
!    Input, integer NXI, NYI, the number of output grid points in the
!    X and Y directions.  NXI and NYI must each be at least 1.
!
!    Input, integer NZI, the first dimension of ZI.  NZI must be at
!    least NXI.
!
!    Input, real XI(NXI), YI(NYI), the X and Y coordinates of the grid
!    points.
!
!    Workspace, integer IWK(31*NDP+NXI*NYI).
!
!    Workspace, real WK(6*NDP).
!
!    Output, real ZI(NZI,NYI), contains the interpolated Z values at the
!    grid points.
!

!
  integer(kint) ndp
  integer(kint) nxi
  integer(kint) nyi
  integer(kint) nzi
!
  real(kreal) ap
  real(kreal) bp
  real(kreal) cp
  real(kreal) dp
  integer(kint) il1
  integer(kint) il2
  integer(kint) iti
  integer(kint) itpv
  integer(kint) iwk(31*ndp + nxi*nyi)
  integer(kint) ixi
  integer(kint) iyi
  integer(kint) izi
  integer(kint) jig0mn
  integer(kint) jig0mx
  integer(kint) jig1mn
  integer(kint) jig1mx
  integer(kint) jigp
  integer(kint) jngp
  integer(kint) jwigp
  integer(kint) jwigp0
  integer(kint) jwipl
  integer(kint) jwipt
  integer(kint) jwiwl
  integer(kint) jwiwp
  integer(kint) jwngp
  integer(kint) jwngp0
  integer(kint) jwwpd
  integer(kint) md
  integer(kint) ngp0
  integer(kint) ngp1
  integer(kint) nl
  integer(kint) nngp
  integer(kint) nt
  real(kreal) p00
  real(kreal) p01
  real(kreal) p02
  real(kreal) p03
  real(kreal) p04
  real(kreal) p05
  real(kreal) p10
  real(kreal) p11
  real(kreal) p12
  real(kreal) p13
  real(kreal) p14
  real(kreal) p20
  real(kreal) p21
  real(kreal) p22
  real(kreal) p23
  real(kreal) p30
  real(kreal) p31
  real(kreal) p32
  real(kreal) p40
  real(kreal) p41
  real(kreal) p50
  real(kreal) wk(6*ndp)
  real(kreal) x0
  real(kreal) xd(ndp)
  real(kreal) xi(nxi)
  real(kreal) y0
  real(kreal) yd(ndp)
  real(kreal) yi(nyi)
  real(kreal) zd(ndp)
  real(kreal) zi(nzi,nyi)
!
  save /idpt/
!
  common /idpt/ itpv,x0,y0,ap,bp,cp,dp, &
                p00,p10,p20,p30,p40,p50,p01,p11,p21,p31,p41, &
                p02,p12,p22,p32,p03,p13,p23,p04,p14,p05
!
!  Error check.
!
  if ( md < 1 .or. md > 3 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'IDSFFT - Fatal error!'
    write(*,*)'  Input parameter MD out of range.'
    stop
  end if

  if ( ndp < 4 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'IDSFFT - Fatal error!'
    write ( *, '(a)' ) '  Input parameter NDP out of range.'
    stop
  end if

  if ( nxi < 1 .or. nyi < 1 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'IDSFFT - Fatal error!'
    write ( *, '(a)' ) '  Input parameter NXI or NYI out of range.'
    stop
  end if

  if ( nxi > nzi ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'IDSFFT - Fatal error!'
    write ( *, '(a)' ) '  Input parameter NZI is less than NXI.'
    stop
  end if

  if ( md <= 1 ) then

    iwk(1) = ndp

  else

    if ( ndp /= iwk(1) ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'IDSFFT - Fatal error!'
      write ( *, '(a)' ) '  MD = 2 or 3 but ndp was changed since last call.'
      stop
    end if

  end if

  if ( md <= 2 ) then

    iwk(3) = nxi
    iwk(4) = nyi

  else

    if ( nxi /= iwk(3) ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'IDSFFT - Fatal error!'
      write ( *, '(a)' ) 'MD = 3 but nxi was changed since last call.'
      stop
    end if

    if ( nyi /= iwk(4) ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'IDSFFT - Fatal error!'
      write ( *, '(a)' ) '  MD = 3 but nyi was changed since last call.'
      stop
    end if

  end if
!
!  Allocation of storage areas in the IWK array.
!
  jwipt = 16
  jwiwl = 6*ndp+1
  jwngp0 = jwiwl-1
  jwipl = 24*ndp+1
  jwiwp = 30*ndp+1
  jwigp0 = 31*ndp
  jwwpd = 5*ndp+1
!
!  Triangulate the XY plane.
!
  if ( md == 1 ) then

    call idtang ( ndp, xd, yd, nt, iwk(jwipt), nl, iwk(jwipl), &
      iwk(jwiwl), iwk(jwiwp), wk )

    iwk(5) = nt
    iwk(6) = nl

    if ( nt == 0 ) then
      return
    end if

  else

    nt = iwk(5)
    nl = iwk(6)

  end if
!
!  Sort output grid points in ascending order of the triangle
!  number and the border line segment number.
!
  if ( md <= 2 ) then

    call idgrid ( xd, yd, nt, iwk(jwipt), nl, iwk(jwipl), nxi, &
      nyi, xi, yi, iwk(jwngp0+1), iwk(jwigp0+1) )

  end if
!
!  Estimate partial derivatives at all data points.
!
  call idpdrv ( ndp, xd, yd, zd, nt, iwk(jwipt), wk, wk(jwwpd) )
!
!  Interpolate the ZI values.
!
  itpv = 0
  jig0mx = 0
  jig1mn = nxi*nyi+1
  nngp = nt+2*nl

  do jngp = 1, nngp

    iti = jngp

    if ( jngp > nt ) then
      il1 = (jngp-nt+1)/2
      il2 = (jngp-nt+2)/2
      if(il2>nl) then
        il2 = 1
      end if
      iti = il1*(nt+nl)+il2
    end if

    jwngp = jwngp0+jngp
    ngp0 = iwk(jwngp)

    if ( ngp0 /= 0 ) then

      jig0mn = jig0mx+1
      jig0mx = jig0mx+ngp0

      do jigp = jig0mn, jig0mx

        jwigp = jwigp0+jigp
        izi = iwk(jwigp)
        iyi = (izi-1)/nxi+1
        ixi = izi-nxi*(iyi-1)

        call idptip ( ndp, xd, yd, zd, nt, iwk(jwipt), nl, iwk(jwipl), &
          wk, iti, xi(ixi), yi(iyi), zi(ixi,iyi) )

      end do

    end if

    jwngp = jwngp0+2*nngp+1-jngp
    ngp1 = iwk(jwngp)

    if ( ngp1 /= 0 ) then

      jig1mx = jig1mn-1
      jig1mn = jig1mn-ngp1

      do jigp = jig1mn, jig1mx

        jwigp = jwigp0+jigp
        izi = iwk(jwigp)
        iyi = (izi-1)/nxi+1
        ixi = izi-nxi*(iyi-1)

        call idptip ( ndp, xd, yd, zd, nt, iwk(jwipt), nl, iwk(jwipl), &
          wk, iti, xi(ixi), yi(iyi), zi(ixi,iyi) )

      end do

    end if

  end do

  return
end subroutine

subroutine idtang ( ndp, xd, yd, nt, ipt, nl, ipl, iwl, iwp, wk )
!
!*******************************************************************************
!
!! IDTANG performs triangulation.
!
!
!  Discussion:
!
!    The routine divides the XY plane into a number of triangles according to
!    given data points in the plane, determines line segments that form
!    the border of data area, and determines the triangle numbers
!    corresponding to the border line segments.
!
!    At completion, point numbers of the vertexes of each triangle
!    are listed counter-clockwise.  Point numbers of the end points
!    of each border line segment are listed counter-clockwise,
!    listing order of the line segments being counter-clockwise.
!
!  Parameters:
!
!    Input, integer NDP, the number of data points.
!
!    Input, real XD(NDP), YD(NDP), the X and Y coordinates of the data.
!
!    Output, integer NT, the number of triangles,
!
!    Output, integer IPT(6*NDP-15), where the point numbers of the
!    vertexes of the IT-th triangle are to be stored as entries
!    3*IT-2, 3*IT-1, and 3*IT, for IT = 1 to NT.
!
!    Output, integer NL, the number of border line segments.
!
!    Output, integer IPL(6*NDP), where the point numbers of the end
!    points of the (il)th border line segment and its respective triangle
!    number are to be stored as the (3*il-2)nd, (3*il-1)st, and (3*il)th
!    elements, il = 1,2,..., nl.
!
!    Workspace, integer IWL(18*NDP),
!
!    Workspace, integer IWP(NDP),
!
!    Workspace, real WK(NDP).
!

!
  integer(kint) ndp
!
  real(kreal) dsqf
  real(kreal) dsqi
  real(kreal) dsqmn
  real(kreal), parameter :: epsln = 1.0E-06
!  integer(kint) idxchg
  integer(kint) il
  integer(kint) ilf
  integer(kint) iliv
  integer(kint) ilt3
  integer(kint) ilvs
  integer(kint) ip
  integer(kint) ip1
  integer(kint) ip1p1
  integer(kint) ip2
  integer(kint) ip3
  integer(kint) ipl(6*ndp)
  integer(kint) ipl1
  integer(kint) ipl2
  integer(kint) iplj1
  integer(kint) iplj2
  integer(kint) ipmn1
  integer(kint) ipmn2
  integer(kint) ipt(6*ndp-15)
  integer(kint) ipt1
  integer(kint) ipt2
  integer(kint) ipt3
  integer(kint) ipti
  integer(kint) ipti1
  integer(kint) ipti2
  integer(kint) irep
  integer(kint) it
  integer(kint) it1t3
  integer(kint) it2t3
  integer(kint) itf(2)
  integer(kint) its
  integer(kint) itt3
  integer(kint) itt3r
  integer(kint) iwl(18*ndp)
  integer(kint) iwp(ndp)
  integer(kint) ixvs
  integer(kint) ixvspv
  integer(kint) jl1
  integer(kint) jl2
  integer(kint) jlt3
  integer(kint) jp
  integer(kint) jp1
  integer(kint) jp2
  integer(kint) jpc
  integer(kint) jpmn
  integer(kint) jpmx
  integer(kint) jwl
  integer(kint) jwl1
  integer(kint) jwl1mn
  integer(kint) nl
  integer(kint) nl0
  integer(kint) nlf
  integer(kint) nlfc
  integer(kint) nlft2
  integer(kint) nln
  integer(kint) nlnt3
  integer(kint) nlsh
  integer(kint) nlsht3
  integer(kint) nlt3
  integer(kint), parameter :: nrep = 100
  integer(kint) nt
  integer(kint) nt0
  integer(kint) ntf
  integer(kint) ntt3
  integer(kint) ntt3p3
  real(kreal) sp
  real(kreal) spdt
  real(kreal) u1
  real(kreal) u2
  real(kreal) u3
  real(kreal) v1
  real(kreal) v2
  real(kreal) v3
  real(kreal) vp
  real(kreal) vpdt
  real(kreal) wk(ndp)
  real(kreal) x1
  real(kreal) x2
  real(kreal) x3
  real(kreal) xd(ndp)
  real(kreal) xdmp
  real(kreal) y1
  real(kreal) y2
  real(kreal) y3
  real(kreal) yd(ndp)
  real(kreal) ydmp
!
!  Statement functions
!
  dsqf(u1,v1,u2,v2) = (u2-u1)**2+(v2-v1)**2
  spdt(u1,v1,u2,v2,u3,v3) = (u2-u1)*(u3-u1)+(v2-v1)*(v3-v1)
  vpdt(u1,v1,u2,v2,u3,v3) = (v3-v1)*(u2-u1)-(u3-u1)*(v2-v1)
!
!  Preliminary processing
!
  if ( ndp < 4 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'IDTANG - Fatal error!'
    write ( *, '(a)' ) '  Input parameter NDP out of range.'
    stop
  end if
!
!  Determine IPMN1 and IPMN2, the closest pair of data points.
!
  dsqmn = dsqf(xd(1),yd(1),xd(2),yd(2))
  ipmn1 = 1
  ipmn2 = 2

  do ip1 = 1, ndp-1

    x1 = xd(ip1)
    y1 = yd(ip1)
    ip1p1 = ip1+1

    do ip2 = ip1p1, ndp

      dsqi = dsqf(x1,y1,xd(ip2),yd(ip2))

      if ( dsqi == 0.0 ) then
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'IDTANG - Fatal error!'
        write ( *, '(a)' ) '  Two of the input data points are identical.'
        stop
      end if

      if(dsqi<dsqmn) then
        dsqmn = dsqi
        ipmn1 = ip1
        ipmn2 = ip2
      end if

    end do

  end do
!
!  Compute the midpoint of the closest two data points.
!
  xdmp = (xd(ipmn1)+xd(ipmn2)) / 2.0E+00
  ydmp = (yd(ipmn1)+yd(ipmn2)) / 2.0E+00
!
!  Sort the other (NDP-2) data points in ascending order of
!  distance from the midpoint and store the sorted data point
!  numbers in the IWP array.
!
  jp1 = 2

  do ip1 = 1, ndp
    if ( ip1 /= ipmn1 .and. ip1 /= ipmn2 ) then
      jp1 = jp1+1
      iwp(jp1) = ip1
      wk(jp1) = dsqf(xdmp,ydmp,xd(ip1),yd(ip1))
    end if
  end do

  do jp1 = 3, ndp-1

    dsqmn = wk(jp1)
    jpmn = jp1

    do jp2 = jp1, ndp
      if(wk(jp2)<dsqmn) then
        dsqmn = wk(jp2)
        jpmn = jp2
      end if
    end do

    its = iwp(jp1)
    iwp(jp1) = iwp(jpmn)
    iwp(jpmn) = its
    wk(jpmn) = wk(jp1)

  end do
!
!  If necessary, modify the ordering in such a way that the
!  first three data points are not collinear.
!
  x1 = xd(ipmn1)
  y1 = yd(ipmn1)
  x2 = xd(ipmn2)
  y2 = yd(ipmn2)

  do jp = 3, ndp
    ip = iwp(jp)
    sp = spdt(xd(ip),yd(ip),x1,y1,x2,y2)
    vp = vpdt(xd(ip),yd(ip),x1,y1,x2,y2)
    if ( abs(vp) > ( abs(sp) * epsln ) )   go to 37
  end do

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'IDTANG - Fatal error!'
  write ( *, '(a)' ) '  All collinear data points.'
  stop

   37 continue

  if ( jp /= 3 ) then

    jpmx = jp

    do jpc = 4, jpmx
      jp = jpmx+4-jpc
      iwp(jp) = iwp(jp-1)
    end do

    iwp(3) = ip

  end if
!
!  Form the first triangle.
!
!  Store point numbers of the vertexes of the triangle in the IPT array,
!  store point numbers of the border line segments and the triangle number in
!  the IPL array.
!
  ip1 = ipmn1
  ip2 = ipmn2
  ip3 = iwp(3)

  if ( vpdt(xd(ip1),yd(ip1),xd(ip2),yd(ip2),xd(ip3),yd(ip3)) < 0.0E+00 ) then
    ip1 = ipmn2
    ip2 = ipmn1
  end if

  nt0 = 1
  ntt3 = 3
  ipt(1) = ip1
  ipt(2) = ip2
  ipt(3) = ip3
  nl0 = 3
  nlt3 = 9
  ipl(1) = ip1
  ipl(2) = ip2
  ipl(3) = 1
  ipl(4) = ip2
  ipl(5) = ip3
  ipl(6) = 1
  ipl(7) = ip3
  ipl(8) = ip1
  ipl(9) = 1
!
!  Add the remaining data points, one by one.
!
  do jp1 = 4, ndp

    ip1 = iwp(jp1)
    x1 = xd(ip1)
    y1 = yd(ip1)
!
!  Determine the first invisible and visible border line segments, iliv and
!  ilvs.
!
    do il = 1, nl0

      ip2 = ipl(3*il-2)
      ip3 = ipl(3*il-1)
      x2 = xd(ip2)
      y2 = yd(ip2)
      x3 = xd(ip3)
      y3 = yd(ip3)
      sp = spdt(x1,y1,x2,y2,x3,y3)
      vp = vpdt(x1,y1,x2,y2,x3,y3)

      if ( il == 1 ) then
        ixvs = 0
        if(vp<=(abs(sp)*(-epsln)))   ixvs = 1
        iliv = 1
        ilvs = 1
        go to 53
      end if

      ixvspv = ixvs

      if ( vp <= (abs(sp)*(-epsln)) ) then
        ixvs = 1
        if(ixvspv==1)      go to 53
        ilvs = il
        if(iliv/=1)        go to 54
        go to 53
      end if

      ixvs = 0

      if ( ixvspv /= 0 ) then
        iliv = il
        if(ilvs/=1)        go to 54
      end if

53     continue

    end do

    if(iliv==1.and.ilvs==1)  ilvs = nl0

54   continue

    if(ilvs<iliv)  ilvs = ilvs+nl0
!
!  Shift (rotate) the IPL array to have the invisible border
!  line segments contained in the first part of the array.
!
55   continue

    if ( iliv /= 1 ) then

      nlsh = iliv-1
      nlsht3 = nlsh*3

      do jl1 = 1,nlsht3
        jl2 = jl1+nlt3
        ipl(jl2) = ipl(jl1)
      end do

      do jl1 = 1,nlt3
        jl2 = jl1+nlsht3
        ipl(jl1) = ipl(jl2)
      end do

      ilvs = ilvs-nlsh

    end if
!
!  Add triangles to the IPT array,
!  update border line segments in the IPL array,
!  set flags for the border line segments to be reexamined in the IWL array.
!
    jwl = 0

    do il = ilvs, nl0

      ilt3 = il*3
      ipl1 = ipl(ilt3-2)
      ipl2 = ipl(ilt3-1)
      it   = ipl(ilt3)
!
!  Add a triangle to the IPT array.
!
      nt0 = nt0+1
      ntt3 = ntt3+3
      ipt(ntt3-2) = ipl2
      ipt(ntt3-1) = ipl1
      ipt(ntt3)   = ip1
!
!  Update border line segments in the IPL array.
!
      if ( il == ilvs ) then
        ipl(ilt3-1) = ip1
        ipl(ilt3)   = nt0
      end if

      if ( il == nl0 ) then
        nln = ilvs+1
        nlnt3 = nln*3
        ipl(nlnt3-2) = ip1
        ipl(nlnt3-1) = ipl(1)
        ipl(nlnt3)   = nt0
      end if
!
!  Determine the vertex that does not lie on the border
!  line segments.
!
      itt3 = it*3
      ipti = ipt(itt3-2)

      if ( ipti == ipl1 .or. ipti == ipl2 ) then
        ipti = ipt(itt3-1)
        if ( ipti == ipl1 .or. ipti == ipl2 ) then
          ipti = ipt(itt3)
        end if
      end if
!
!  Check if the exchange is necessary.
!
      if ( idxchg(xd,yd,ip1,ipti,ipl1,ipl2) /= 0 ) then
!
!  Modify the IPT array.
!
        ipt(itt3-2) = ipti
        ipt(itt3-1) = ipl1
        ipt(itt3)   = ip1
        ipt(ntt3-1) = ipti
        if(il==ilvs)  ipl(ilt3) = it
        if(il==nl0.and.ipl(3)==it)      ipl(3) = nt0
!
!  Set flags in the IWL array.
!
        jwl = jwl+4
        iwl(jwl-3) = ipl1
        iwl(jwl-2) = ipti
        iwl(jwl-1) = ipti
        iwl(jwl)   = ipl2

      end if

    end do

    nl0 = nln
    nlt3 = nlnt3
    nlf = jwl/2

    if ( nlf == 0 ) then
      go to 79
    end if
!
!  Improve triangulation.
!
    ntt3p3 = ntt3+3

    do irep = 1, nrep

      do ilf = 1,nlf

        ipl1 = iwl(2*ilf-1)
        ipl2 = iwl(2*ilf)
!
!  Locate in the ipt array two triangles on both sides of
!  the flagged line segment.
!
        ntf = 0

        do itt3r = 3,ntt3,3
          itt3 = ntt3p3-itt3r
          ipt1 = ipt(itt3-2)
          ipt2 = ipt(itt3-1)
          ipt3 = ipt(itt3)
          if(ipl1/=ipt1.and.ipl1/=ipt2.and. ipl1/=ipt3)      go to 71
          if(ipl2/=ipt1.and.ipl2/=ipt2.and. ipl2/=ipt3)      go to 71
          ntf = ntf+1
          itf(ntf) = itt3/3
          if(ntf==2)     go to 72
71         continue
        end do

        if ( ntf < 2 )       go to 76
!
!  Determine the vertexes of the triangles that do not lie
!  on the line segment.
!
72       continue

        it1t3 = itf(1)*3
        ipti1 = ipt(it1t3-2)
        if(ipti1/=ipl1.and.ipti1/=ipl2)    go to 73
        ipti1 = ipt(it1t3-1)

        if ( ipti1 == ipl1 .or. ipti1 == ipl2 ) then
          ipti1 = ipt(it1t3)
        end if

73       continue

        it2t3 = itf(2)*3
        ipti2 = ipt(it2t3-2)
        if(ipti2/=ipl1.and.ipti2/=ipl2)    go to 74
        ipti2 = ipt(it2t3-1)
        if(ipti2/=ipl1.and.ipti2/=ipl2)    go to 74
        ipti2 = ipt(it2t3)
!
!  Check if the exchange is necessary.
!
74       continue

        if( idxchg(xd,yd,ipti1,ipti2,ipl1,ipl2) == 0) then
          go to 76
        end if
!
!  Modify the IPT array.
!
        ipt(it1t3-2) = ipti1
        ipt(it1t3-1) = ipti2
        ipt(it1t3)   = ipl1
        ipt(it2t3-2) = ipti2
        ipt(it2t3-1) = ipti1
        ipt(it2t3)   = ipl2
!
!  Set new flags.
!
        jwl = jwl+8
        iwl(jwl-7) = ipl1
        iwl(jwl-6) = ipti1
        iwl(jwl-5) = ipti1
        iwl(jwl-4) = ipl2
        iwl(jwl-3) = ipl2
        iwl(jwl-2) = ipti2
        iwl(jwl-1) = ipti2
        iwl(jwl)   = ipl1
        do jlt3 = 3,nlt3,3
          iplj1 = ipl(jlt3-2)
          iplj2 = ipl(jlt3-1)

          if((iplj1==ipl1.and.iplj2==ipti2).or. &
             (iplj2==ipl1.and.iplj1==ipti2)) then
                               ipl(jlt3) = itf(1)
          end if

          if((iplj1==ipl2.and.iplj2==ipti1).or. &
             (iplj2==ipl2.and.iplj1==ipti1)) then
                              ipl(jlt3) = itf(2)
          end if

        end do

76       continue

      end do

      nlfc = nlf
      nlf = jwl/2
!
!  Reset the IWL array for the next round.
!
      if ( nlf == nlfc ) go to 79

      jwl1mn = 2*nlfc+1
      nlft2 = nlf*2

      do jwl1 = jwl1mn,nlft2
        jwl = jwl1+1-jwl1mn
        iwl(jwl) = iwl(jwl1)
      end do

      nlf = jwl/2

    end do

79  continue

  end do
!
!  Rearrange the IPT array so that the vertexes of each triangle
!  are listed counter-clockwise.
!
  do itt3 = 3, ntt3, 3

    ip1 = ipt(itt3-2)
    ip2 = ipt(itt3-1)
    ip3 = ipt(itt3)

    if(vpdt(xd(ip1),yd(ip1),xd(ip2),yd(ip2),xd(ip3),yd(ip3)) < 0.0E+00 ) then
      ipt(itt3-2) = ip2
      ipt(itt3-1) = ip1
    end if

  end do

  nt = nt0
  nl = nl0

  return
end subroutine

function idxchg( x, y, i1, i2, i3, i4 )
!
!*******************************************************************************
!
!! IDXCHG determines whether two triangles should be exchanged.
!
!
!  Discussion:
!
!    The max-min-angle criterion of C L Lawson is used.
!
!  Parameters:
!
!    Input, real X(*), Y(*), the coordinates of the data points.
!
!    Input, integer I1, I2, I3, I4, are the point numbers of
!    four points P1, P2, P3, and P4 that form a quadrilateral,
!    with P3 and P4 connected diagonally.
!
!    Output, integer IDXCHG, reports whether the triangles should be
!    exchanged:
!    0, no exchange is necessary.
!    1, an exchange is necessary.
!

!
  real(kreal) a1sq
  real(kreal) a2sq
  real(kreal) a3sq
  real(kreal) a4sq
  real(kreal) c1sq
  real(kreal) c3sq
  real(kreal), parameter :: epsln = 1.0E-12
  integer(kint) i1
  integer(kint) i2
  integer(kint) i3
  integer(kint) i4
  integer(kint) idx
  integer(kint) idxchg
  real(kreal) s1sq
  real(kreal) s2sq
  real(kreal) s3sq
  real(kreal) s4sq
  real(kreal) u1
  real(kreal) u2
  real(kreal) u3
  real(kreal) u4
  real(kreal) x(*)
  real(kreal) x1
  real(kreal) x2
  real(kreal) x3
  real(kreal) x4
  real(kreal) y(*)
  real(kreal) y1
  real(kreal) y2
  real(kreal) y3
  real(kreal) y4
!
!  Preliminary processing
!
  x1 = x(i1)
  y1 = y(i1)
  x2 = x(i2)
  y2 = y(i2)
  x3 = x(i3)
  y3 = y(i3)
  x4 = x(i4)
  y4 = y(i4)

  idx = 0

  u3 = (y2-y3)*(x1-x3)-(x2-x3)*(y1-y3)
  u4 = (y1-y4)*(x2-x4)-(x1-x4)*(y2-y4)

  if ( u3 * u4 > 0.0_kreal ) then

    u1 = (y3-y1)*(x4-x1)-(x3-x1)*(y4-y1)
    u2 = (y4-y2)*(x3-x2)-(x4-x2)*(y3-y2)

    a1sq = (x1-x3)**2+(y1-y3)**2
    a4sq = (x4-x1)**2+(y4-y1)**2
    c1sq = (x3-x4)**2+(y3-y4)**2
    a2sq = (x2-x4)**2+(y2-y4)**2
    a3sq = (x3-x2)**2+(y3-y2)**2
    c3sq = (x2-x1)**2+(y2-y1)**2

    s1sq = u1*u1 / (c1sq*max(a1sq,a4sq))
    s2sq = u2*u2 / (c1sq*max(a2sq,a3sq))
    s3sq = u3*u3 / (c3sq*max(a3sq,a1sq))
    s4sq = u4*u4 / (c3sq*max(a4sq,a2sq))

    if ( min ( s3sq, s4sq ) - min ( s1sq, s2sq ) > epsln ) then
      idx = 1
    end if

  end if

  idxchg = idx

   return
end function

subroutine timestamp ( )
!
!*******************************************************************************
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!
!  Example:
!
!    May 31 2001   9:45:54.872 AM
!
!  Modified:
!
!    31 May 2001
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!

!
  character ( len = 8 ) ampm
  integer(kint) d
  character ( len = 8 ) date
  integer(kint) h
  integer(kint) m
  integer(kint) mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer(kint) n
  integer(kint) s
  character ( len = 10 )  time
  integer(kint) values(8)
  integer(kint) y
  character ( len = 5 ) zone
!
  call date_and_time ( date, time, zone, values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 0 ) then
        ampm = 'Midnight'
      else
        ampm = 'AM'
      end if
    end if
  end if

  write ( *, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
    trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm )

  return
end subroutine

end module


! RUN: %S/test_folding.sh %s %flang %t
! Test transformational intrinsic function folding

module m

  type A
    real(4) x
    integer(8) i
  end type

  integer(8), parameter :: new_shape(*) = [2, 4]
  integer(4), parameter :: order(2) = [2, 1]

  ! Testing integers (similar to real and complex)
  integer(4), parameter :: int_source(*) = [1, 2, 3, 4, 5, 6]
  integer(4), parameter :: int_pad(2) = [7, 8]
  integer(4), parameter :: int_expected_result(*, *) = reshape([1, 5, 2, 6, 3, 7, 4, 8], new_shape)
  integer(4), parameter :: int_result(*, *) = reshape(int_source, new_shape, int_pad, order)
  integer(4), parameter :: int_result_long_source(*, *) = reshape([1, 5, 2, 6, 3, 7, 4, 8, 9], new_shape)
  logical, parameter :: test_reshape_integer_1 = all(int_expected_result == int_result)
  logical, parameter :: test_reshape_integer_2 = all(shape(int_result, 8).EQ.new_shape)
  logical, parameter :: test_reshape_integer_3 = all(int_expected_result == int_result_long_source)

  ! Testing characters
  character(kind=1, len=3), parameter ::char_source(*) = ["abc", "def", "ghi", "jkl", "mno", "pqr"]
  character(kind=1,len=3), parameter :: char_pad(2) = ["stu", "vxy"]

  character(kind=1, len=3), parameter :: char_expected_result(*, *) = &
    reshape(["abc", "mno", "def", "pqr", "ghi", "stu", "jkl", "vxy"], new_shape)

  character(kind=1, len=3), parameter :: char_result(*, *) = &
    reshape(char_source, new_shape, char_pad, order)

  logical, parameter :: test_reshape_char_1 = all(char_result == char_expected_result)
  logical, parameter :: test_reshape_char_2 = all(shape(char_result, 8).EQ.new_shape)

  ! Testing derived types
  type(A), parameter :: derived_source(*) = &
    [A(x=1.5, i=1), A(x=2.5, i=2), A(x=3.5, i=3), A(x=4.5, i=4), A(x=5.5, i=5), A(x=6.5, i=6)]

  type(A), parameter :: derived_pad(2) = [A(x=7.5, i=7), A(x=8.5, i=8)]

  type(A), parameter :: derived_expected_result(*, *) = &
    reshape([a::a(x=1.5_4,i=1_8),a(x=5.5_4,i=5_8),a(x=2.5_4,i=2_8), a(x=6.5_4,i=6_8), &
      a(x=3.5_4,i=3_8),a(x=7.5_4,i=7_8),a(x=4.5_4,i=4_8),a(x=8.5_4,i=8_8)], new_shape)

  type(A), parameter :: derived_result(*, *) = reshape(derived_source, new_shape, derived_pad, order)

  logical, parameter :: test_reshape_derived_1 = all((derived_result%x.EQ.derived_expected_result%x) &
      .AND.(derived_result%i.EQ.derived_expected_result%i))

  logical, parameter :: test_reshape_derived_2 = all(shape(derived_result).EQ.new_shape)
end module


*> \brief \b DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric matrix in standard form.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLANV2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN )
*
*       .. Scalar Arguments ..
*       DOUBLE PRECISION   A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric
*> matrix in standard form:
*>
*>      [ A  B ] = [ CS -SN ] [ AA  BB ] [ CS  SN ]
*>      [ C  D ]   [ SN  CS ] [ CC  DD ] [-SN  CS ]
*>
*> where either
*> 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or
*> 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex
*> conjugate eigenvalues.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in,out] A
*> \verbatim
*>          A is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*>          C is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*>          D is DOUBLE PRECISION
*>          On entry, the elements of the input matrix.
*>          On exit, they are overwritten by the elements of the
*>          standardised Schur form.
*> \endverbatim
*>
*> \param[out] RT1R
*> \verbatim
*>          RT1R is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[out] RT1I
*> \verbatim
*>          RT1I is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[out] RT2R
*> \verbatim
*>          RT2R is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[out] RT2I
*> \verbatim
*>          RT2I is DOUBLE PRECISION
*>          The real and imaginary parts of the eigenvalues. If the
*>          eigenvalues are a complex conjugate pair, RT1I > 0.
*> \endverbatim
*>
*> \param[out] CS
*> \verbatim
*>          CS is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[out] SN
*> \verbatim
*>          SN is DOUBLE PRECISION
*>          Parameters of the rotation matrix.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup doubleOTHERauxiliary
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  Modified by V. Sima, Research Institute for Informatics, Bucharest,
*>  Romania, to reduce the risk of cancellation errors,
*>  when computing real eigenvalues, and to ensure, if possible, that
*>  abs(RT1R) >= abs(RT2R).
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN )
*
*  -- LAPACK auxiliary routine (version 3.4.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     September 2012
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, HALF, ONE
      PARAMETER          ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
      DOUBLE PRECISION   MULTPL
      PARAMETER          ( MULTPL = 4.0D+0 )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION   AA, BB, BCMAX, BCMIS, CC, CS1, DD, EPS, P, SAB,
     $                   SAC, SCALE, SIGMA, SN1, TAU, TEMP, Z
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLAPY2
      EXTERNAL           DLAMCH, DLAPY2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SIGN, SQRT
*     ..
*     .. Executable Statements ..
*
      EPS = DLAMCH( 'P' )
      IF( C.EQ.ZERO ) THEN
         CS = ONE
         SN = ZERO
         GO TO 10
*
      ELSE IF( B.EQ.ZERO ) THEN
*
*        Swap rows and columns
*
         CS = ZERO
         SN = ONE
         TEMP = D
         D = A
         A = TEMP
         B = -C
         C = ZERO
         GO TO 10
      ELSE IF( ( A-D ).EQ.ZERO .AND. SIGN( ONE, B ).NE.SIGN( ONE, C ) )
     $          THEN
         CS = ONE
         SN = ZERO
         GO TO 10
      ELSE
*
         TEMP = A - D
         P = HALF*TEMP
         BCMAX = MAX( ABS( B ), ABS( C ) )
         BCMIS = MIN( ABS( B ), ABS( C ) )*SIGN( ONE, B )*SIGN( ONE, C )
         SCALE = MAX( ABS( P ), BCMAX )
         Z = ( P / SCALE )*P + ( BCMAX / SCALE )*BCMIS
*
*        If Z is of the order of the machine accuracy, postpone the
*        decision on the nature of eigenvalues
*
         IF( Z.GE.MULTPL*EPS ) THEN
*
*           Real eigenvalues. Compute A and D.
*
            Z = P + SIGN( SQRT( SCALE )*SQRT( Z ), P )
            A = D + Z
            D = D - ( BCMAX / Z )*BCMIS
*
*           Compute B and the rotation matrix
*
            TAU = DLAPY2( C, Z )
            CS = Z / TAU
            SN = C / TAU
            B = B - C
            C = ZERO
         ELSE
*
*           Complex eigenvalues, or real (almost) equal eigenvalues.
*           Make diagonal elements equal.
*
            SIGMA = B + C
            TAU = DLAPY2( SIGMA, TEMP )
            CS = SQRT( HALF*( ONE+ABS( SIGMA ) / TAU ) )
            SN = -( P / ( TAU*CS ) )*SIGN( ONE, SIGMA )
*
*           Compute [ AA  BB ] = [ A  B ] [ CS -SN ]
*                   [ CC  DD ]   [ C  D ] [ SN  CS ]
*
            AA = A*CS + B*SN
            BB = -A*SN + B*CS
            CC = C*CS + D*SN
            DD = -C*SN + D*CS
*
*           Compute [ A  B ] = [ CS  SN ] [ AA  BB ]
*                   [ C  D ]   [-SN  CS ] [ CC  DD ]
*
            A = AA*CS + CC*SN
            B = BB*CS + DD*SN
            C = -AA*SN + CC*CS
            D = -BB*SN + DD*CS
*
            TEMP = HALF*( A+D )
            A = TEMP
            D = TEMP
*
            IF( C.NE.ZERO ) THEN
               IF( B.NE.ZERO ) THEN
                  IF( SIGN( ONE, B ).EQ.SIGN( ONE, C ) ) THEN
*
*                    Real eigenvalues: reduce to upper triangular form
*
                     SAB = SQRT( ABS( B ) )
                     SAC = SQRT( ABS( C ) )
                     P = SIGN( SAB*SAC, C )
                     TAU = ONE / SQRT( ABS( B+C ) )
                     A = TEMP + P
                     D = TEMP - P
                     B = B - C
                     C = ZERO
                     CS1 = SAB*TAU
                     SN1 = SAC*TAU
                     TEMP = CS*CS1 - SN*SN1
                     SN = CS*SN1 + SN*CS1
                     CS = TEMP
                  END IF
               ELSE
                  B = -C
                  C = ZERO
                  TEMP = CS
                  CS = -SN
                  SN = TEMP
               END IF
            END IF
         END IF
*
      END IF
*
   10 CONTINUE
*
*     Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I).
*
      RT1R = A
      RT2R = D
      IF( C.EQ.ZERO ) THEN
         RT1I = ZERO
         RT2I = ZERO
      ELSE
         RT1I = SQRT( ABS( B ) )*SQRT( ABS( C ) )
         RT2I = -RT1I
      END IF
      RETURN
*
*     End of DLANV2
*
      END


      subroutine ceigenft(npts,nfft,kspec,mxdata,data,dpss,
     $                    wsave,mxfreq,yk)
c
c  computes eigen-ft's by windowing data with dpss and taking ffts
c  note that fft is unnormalized and window must be normalized such that
c  its sum of squares is one, so that psd=yk**2
c
c  inputs:
c    npts  - number of data points in array data
c    nfft  - length of the fft
c    kspec - number of spectra to compute
c    mxdata- leading dimension of data and dpss
c    data  - real array containing data series
c    dpss  - double precision array containing kspec tapers
c            of length npts
c    wsave - real work vector of length at least 4*nfft+15
c    mxfreq- leading dimension of yk
c
c  outputs:
c    yk    - complex array containing kspec ffts of tapered data
c            of length nfft
c
c  calls cffti,cfftf
c
c****************************************************************
c
      double precision dpss
      complex yk
      dimension data(mxdata,2),wsave(4*nfft+15),dpss(mxdata,kspec),
     $          yk(mxfreq,kspec)
c
      nfft2=nfft/2
      call cffti(nfft,wsave)
      do 20 j=1,kspec
        do 10 i=1,npts
   10     yk(i,j)=dpss(i,j)*cmplx(data(i,1),data(i,2))
        do 11 i=npts+1,nfft
   11     yk(i,j)=0.
   20   call cfftf(nfft,yk(1,j),wsave)
      return
      end

c $Id$


*DECK ZABS
      DOUBLE PRECISION FUNCTION ZABS (ZR, ZI)
C***BEGIN PROLOGUE  ZABS
C***SUBSIDIARY
C***PURPOSE  Subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and
C            ZBIRY
C***LIBRARY   SLATEC
C***TYPE      ALL (ZABS-A)
C***AUTHOR  Amos, D. E., (SNL)
C***DESCRIPTION
C
C     ZABS COMPUTES THE ABSOLUTE VALUE OR MAGNITUDE OF A DOUBLE
C     PRECISION COMPLEX VARIABLE CMPLX(ZR,ZI)
C
C***SEE ALSO  ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   830501  DATE WRITTEN
C   910415  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  ZABS
      DOUBLE PRECISION ZR, ZI, U, V, Q, S
C***FIRST EXECUTABLE STATEMENT  ZABS
      U = ABS(ZR)
      V = ABS(ZI)
      S = U + V
C-----------------------------------------------------------------------
C     S*1.0D0 MAKES AN UNNORMALIZED UNDERFLOW ON CDC MACHINES INTO A
C     TRUE FLOATING ZERO
C-----------------------------------------------------------------------
      S = S*1.0D+0
      IF (S.EQ.0.0D+0) GO TO 20
      IF (U.GT.V) GO TO 10
      Q = U/V
      ZABS = V*SQRT(1.D+0+Q*Q)
      RETURN
   10 Q = V/U
      ZABS = U*SQRT(1.D+0+Q*Q)
      RETURN
   20 ZABS = 0.0D+0
      RETURN
      END


c
c program auxiliary
c
      include 'VICMAIN_FOR'
      subroutine main44

      parameter (maxsamp=20000, maxpix=50, maxint=10000)
      real*4 obuf(maxsamp),inbuf(maxsamp)
      real*4 slop(maxpix),ofst(maxpix)
      integer*4 unit(maxpix),nl(maxpix),ns(maxpix),status
      integer ounit,hist(0:maxint)
      character*100 msg
      logical xvptst,no_stretch

c parameters
      call xvpcnt('INP',nids)
      no_stretch=xvptst('NOSTR')
      call xvparm('NS',nso,count,def,1)
      call xvparm('PERCENT',percent,count,def,1)
      if(nids.gt.maxpix)then
        call xvmessage('Too many inputs',' ')
        call abend
      endif

c open inputs
      do i=1,nids
        call xvunit(unit(i),'INP',i,status,' ')
        call xvsignal(unit(i),status,1)
        call xvopen(unit(i),status,'U_FORMAT','REAL',' ')
        call xvsignal(unit(i),status,1)
        call xvget(unit(i),status,'NL',nl(i),'NS',ns(i),' ')
        call xvsignal(unit(i),status,1)
        if(ns(i).gt.maxsamp)then
          call xvmessage('Input picture line too long',' ')
          call abend
        endif
        if(ns(i).gt.ns(1))then
          call xvmessage('Input picture lines differ',' ')
          call abend
        endif
        if(nl(i).gt.nl(1))then
          call xvmessage('Input pictures columns differ',' ')
          call abend
        endif
      enddo

c get limits of intensity on inputs
c get percent stretch parameters.
      if(no_stretch)goto 101
      do 100 image=1,nids
        do i=0,maxint
          hist(i)=0
        enddo
        rmin=1.0e+30
        rmax=-1.0e+30
        do line=1,nl(image)
          call xvread(unit(image),inbuf,status,'LINE',line,' ')
          call xvsignal(unit(image),status,1)
          do i=1,ns(image)
            if(inbuf(i).lt.rmin)rmin=inbuf(i)
            if(inbuf(i).gt.rmax)rmax=inbuf(i)
          enddo
        enddo
        write(msg,*)'image= ',image,' min dn= ',rmin,' max dn= ',rmax
        call xvmessage(msg,' ')
        if(rmax.eq.rmin)then
          slop(image)=0.0
          ofst(image)=128.0
          goto 100
        endif
        if(rmax .le. rmin) then
          slope=maxint/1.0
          offset = 0.0
        else
          slope=maxint/(rmax-rmin)
          offset=maxint-slope*rmax
        endif
        do line=1,nl(image)
          call xvread(unit(image),inbuf,status,'LINE',line,' ')
          call xvsignal(unit(image),status,1)
          do i=1,ns(image)
            j=nint(inbuf(i)*slope+offset)
            hist(j)=hist(j)+1
          enddo
        enddo
        ncounts=nl(image)*ns(image)*percent/100.
        n=0
        do i=0,maxint
          n=n+hist(i)
          ii=i
          if(n.ge.ncounts)goto 10
        enddo
10      rmin=(ii-offset)/slope
        n=0
        do i=maxint,0,-1
          n=n+hist(i)
          ii=i
          if(n.ge.ncounts)goto 11
        enddo
11      rmax=(ii-offset)/slope
        if(rmax .le. rmin) then
          slop(image)=255.0
          ofst(image)=0.0
        else
          slop(image)=255./(rmax-rmin)
          ofst(image)=255.-slop(image)*rmax
        endif
100   continue
101   continue

c determine size of output
      if((nso/ns(1))*ns(1).ne.nso)then
        call xvmessage('NS not a multiple of input line length',' ')
        call abend
      endif
      npic_per_row=nso/ns(1)
      npic_per_col=nids/npic_per_row
      if(npic_per_col*npic_per_row.lt.nids)
     +   npic_per_col=npic_per_col+1
      nlo=npic_per_col*nl(1)

c open output
      call xvunit(ounit,'OUT',1,status,' ')
      call xvsignal(ounit,status,1)
      call xvopen(ounit,status,'U_FORMAT','REAL','O_FORMAT','BYTE',
     +              'U_NL',nlo,'U_NS',nso,'OP','WRITE',' ')
      call xvsignal(ounit,status,1)

c write data
      left_image=1-npic_per_row
      do irow=1,npic_per_col
        left_image=left_image+npic_per_row

        do line=1,nl(1)
          k=0
          image=left_image-1

          do icol=1,npic_per_row
            image=image+1

            if(image.le.nids)then
              call xvread(unit(image),inbuf,status,'LINE',line,' ')
              call xvsignal(unit(image),status,1)
              do i=1,ns(image)
                k=k+1
                if(no_stretch)then
                  dn=inbuf(i)
                else
                  dn=inbuf(i)*slop(image)+ofst(image)+0.5
                endif
                if(dn.lt.0.0)dn=0.0
                if(dn.gt.255.0)dn=255.0
                obuf(k)=dn
              enddo
            else
              do i=1,ns(1)
                k=k+1
                obuf(k)=0.0
              enddo
            endif

          enddo
          call xvwrit(ounit,obuf,status,' ')
          call xvsignal(ounit,status,1)
        enddo
      enddo

      return
      end


      program AOC

      integer :: ios, u = 42, i, j, k = 0, l, x, y, x1, y1, x2, y2, xi, yi
      integer, dimension(1000,1000) :: b

      open(unit=u, file='day_5_2.txt', iostat=ios)
      if ( ios /= 0 ) stop "ERR"

      do i = 1, 500
         read(u, *, iostat=ios) x1, y1, x2, y2

         if (x1 == x2) then
            xi = 0
         else if (x1 < x2) then
            xi = 1
            l = x2 - x1
         else
            xi = -1
            l = x1 - x2
         end if

         if (y1 == y2) then
            yi = 0
         else if (y1 < y2) then
            yi = 1
            l = y2 - y1
         else
            yi = -1
            l = y1 - y2
         end if

         do j = 0, l
            x = x1 + (j * xi)
            y = y1 + (j * yi)
            b(x, y) = b(x, y) + 1
            if (b(x,y) == 2) k = k + 1
         end do
      end do

      close(u)
      print*, k
      end program AOC