*     MB02FD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          ITMAX, KMAX, NMAX
      PARAMETER        ( ITMAX = 10, KMAX = 20, NMAX = 20 )
      INTEGER          LDR, LDT, LDWORK
      PARAMETER        ( LDR = NMAX*KMAX, LDT = KMAX,
     $                   LDWORK = ( NMAX + 1 )*KMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, IT, J, K, LEN, M, N, P, PIT, POS, POSR,
     $                 S1, SCIT
      CHARACTER        TYPET
      DOUBLE PRECISION NNRM
*     .. Local Arrays .. (Dimensioned for TYPET = 'R'.)
      INTEGER          S(ITMAX)
      DOUBLE PRECISION DWORK(LDWORK), R(LDR, NMAX*KMAX),
     $                 T(LDT, NMAX*KMAX), V(NMAX*KMAX), W(NMAX*KMAX),
     $                 Z(NMAX*KMAX)
*     .. External Functions ..
      LOGICAL          LSAME
      DOUBLE PRECISION DNRM2
      EXTERNAL         DNRM2, LSAME
*     .. External Subroutines ..
      EXTERNAL         DAXPY, DCOPY, DGEMV, DLASET, DSCAL, DTRMV, MB02FD
*
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, K, IT
      TYPET = 'R'
      M = N*K
      IF( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE IF( K.LE.0 .OR. K.GT.KMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) K
      ELSE IF( IT.LE.0 .OR. IT.GT.ITMAX ) THEN
         WRITE ( NOUT, FMT = 99991 ) IT
      ELSE
         READ ( NIN, FMT = * ) ( S(I), I = 1, IT )
         READ ( NIN, FMT = * ) ( ( T(I,J), J = 1,M ), I = 1,K )
         P   = 0
         POS = 1
         WRITE ( NOUT, FMT = 99997 )
         DO 90  SCIT = 1, IT
            CALL MB02FD( TYPET, K, N, P, S(SCIT), T(1,POS), LDT,
     $                   R(POS,POS), LDR, DWORK, LDWORK, INFO )
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
               STOP
            END IF
            S1 = S(SCIT) + P
            IF ( S1.EQ.0 ) THEN
*              Estimate the 2-norm of the Toeplitz matrix with 5 power
*              iterations.
               LEN = N*K
               CALL DLASET( 'All', LEN, 1, ONE, ONE, V, 1 )
               DO 30  PIT = 1, 5
                  DO 10  I = 1, N
                     CALL DGEMV( 'NoTranspose', K, LEN-(I-1)*K, ONE, T,
     $                           LDT, V((I-1)*K+1), 1, ZERO,
     $                           W((I-1)*K+1), 1 )
   10             CONTINUE
                  DO 20 I = 1, N-1
                     CALL DGEMV( 'Transpose', K, (N-I)*K, ONE,
     $                           T(1,K+1), LDT, V((I-1)*K+1), 1,
     $                           ONE, W(I*K+1), 1 )
   20             CONTINUE
                  CALL DCOPY( LEN, W, 1, V, 1 )
                  NNRM = DNRM2( LEN, V, 1 )
                  CALL DSCAL( LEN, ONE/NNRM, V, 1 )
   30          CONTINUE
            ELSE
*              Estimate the 2-norm of the Schur complement with 5 power
*              iterations.
               LEN = ( N - S1 )*K
               CALL DLASET( 'All', LEN, 1, ONE, ONE, V, 1 )
               DO 80  PIT = 1, 5
                  POSR = ( S1 - 1 )*K + 1
                  DO 40  I = 1, N - S1
                     CALL DGEMV( 'NoTranspose', K, LEN-(I-1)*K, ONE,
     $                           T(1,POSR+K), LDT, V((I-1)*K+1), 1,
     $                           ZERO, W((I-1)*K+1), 1 )
   40             CONTINUE
                  DO 50  I = 1, N - S1
                     CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', K,
     $                           R(POSR,POSR), LDR, V((I-1)*K+1), 1 )
                     CALL DGEMV( 'NoTranspose', K, LEN-I*K, ONE,
     $                           R(POSR,POSR+K), LDR, V(I*K+1), 1, ONE,
     $                           V((I-1)*K+1), 1 )
   50             CONTINUE
                  CALL DLASET( 'All', LEN, 1, ZERO, ZERO, Z, 1 )
                  DO 60  I = 1, N - S1
                     CALL DGEMV( 'Transpose', K, LEN-I*K, ONE,
     $                           R(POSR,POSR+K), LDR, V((I-1)*K+1), 1,
     $                           ONE, Z(I*K+1), 1 )
                     CALL DTRMV( 'Upper', 'Transpose', 'NonUnit', K,
     $                           R(POSR,POSR), LDR, V((I-1)*K+1), 1 )
                     CALL DAXPY( K, ONE, V((I-1)*K+1), 1, Z((I-1)*K+1),
     $                           1 )
   60             CONTINUE
                  CALL DLASET( 'All', LEN, 1, ZERO, ZERO, V, 1 )
                  DO 70  I = 1, N - S1
                     CALL DGEMV( 'Transpose', K, LEN-(I-1)*K, ONE,
     $                           T(1,POSR+K), LDT, W((I-1)*K+1), 1,
     $                           ONE, V((I-1)*K+1), 1 )
   70             CONTINUE
                  CALL DAXPY( LEN, -ONE, Z, 1, V, 1 )
                  NNRM = DNRM2( LEN, V, 1 )
                  CALL DSCAL( LEN, -ONE/NNRM, V, 1 )
   80          CONTINUE
               POS = ( S1 - 1 )*K + 1
               P   = S1
            END IF
            WRITE ( NOUT, FMT = 99995 ) P*K, NNRM
   90    CONTINUE
         WRITE ( NOUT, FMT = 99996 )
         DO 100  I = 1, P*K
            WRITE ( NOUT, FMT = 99994 ) ( R(I,J), J = 1, M )
  100    CONTINUE
      END IF
      STOP
*
99999 FORMAT (' MB02FD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB02FD = ',I2)
99997 FORMAT ('   Incomplete Cholesky factorization ',
     $         //'   rows    norm(Schur complement)',/)
99996 FORMAT (/' The upper ICC factor of the block Toeplitz matrix is '
     $       )
99995 FORMAT (I4,5X,F8.4)
99994 FORMAT (20(1X,F8.4))
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' K is out of range.',/' K = ',I5)
99991 FORMAT (/' IT is out of range.',/' IT = ',I5)
      END


 ! This code is part of the OpenCSR package developed at:
! https://github.com/ChristopherMayes/OpenCSR

module csr3d_mod

use, intrinsic :: iso_fortran_env
use elliptic_integral_mod, only : ellipinc
use fft_mod, only : ccfft3d
!$ use omp_lib, only: omp_get_max_threads

implicit none

! Fortran 2008
!integer, parameter, private :: sp = REAL32
integer, parameter, private :: dp = REAL64
!integer, parameter, private :: qp = REAL128

!------------------------------------------------------------------------
!------------------------------------------------------------------------
contains

!------------------------------------------------------------------------
!+
! Subroutine csr3d_steady_state_solver(density, gamma, rho, delta, wake, offset, normalize)
!
! Deposits particle arrays onto mesh
!
! Input:
!   density      -- REAL64(:,:,:): charge density array in x, y, z
!                                  This should be normalized so that:
!                                  sum(density)*product(delta) = 1
!
!   delta        -- REAL64(3): vector of grid spacings dx, dy, dz
!
!   gamma        -- REAL64: relativistic gamma
!
!   rho          -- REAL64: bending radius. Can be positive or negative.
!
!   icomp        -- integer: Field component requested:
!                        0: phi (scalar potential)
!
!   wake        -- REAL64(:,:,:,3): allocated wakefield array to populate.
!
!                                     The final index corresponds to components
!                                     1: Wx
!                                     2: Wy
!                                     3: Ws
!                                     If present, all components will be computed.
!
!   phi           -- REAL64(:,:,:), optional: allocated potential array to populate
!
!   normalize     -- REAL64, optional: Return normalized units (1/m^2)
!                                      Otherwise further multiply by 1/(4*pi*epsilon_0 * rho)
!                                      to return V/m
!                    Default: True
!
!   offset        -- real(3), optional: Offset coordinates x0, y0, z0 to evaluate the field,
!                    relative to rho.
!                    Default: (0,0,0)
!                        For example, an offset of (0,0,10) can be used to compute
!                        the field at z=+10 m relative to rho.
!
! Output:
!   wake        -- REAL64(:,:,:,3) :  3D CSR wake
!
!
! Notes:
!
!   This algorithm is ultimately memory limited. For each component, two complex,
!   double-sized arrays are needed, requiring the following:
!   Bytes per component calc = nx*ny*nz * 2 (arrays of complex numbers) *
!            2^3 (double-sized 3D arrays) * 128 (bits/complex number) / 8 (bits/Bytes)
!         = 256 Bytes * nx*ny*nz
!   Some examples:
!      32x32x32    =>   8 MB
!      64x64x64    =>  67 MB
!      128x128x128 => 538 MB
!      256x256x256 => 4.3 GB
!      512x512x512 =>  34 GB
!   For smaller grid sizes, the algorithm could be improved by calculating all three
!   Green function arrays at the same time.
!
!-
subroutine csr3d_steady_state_solver(density, gamma, rho, delta, wake, offset, normalize)

real(dp), intent(in), dimension(:,:,:) :: density
real(dp), intent(in) :: gamma, rho, delta(3)
real(dp), optional, intent(out), dimension(:,:,:,:) :: wake
real(dp), intent(in), optional :: offset(3)
logical, optional :: normalize
logical :: normalize0
! internal arrays
real(dp), allocatable, dimension(:,:,:) :: density_prime
complex(dp), allocatable, dimension(:,:,:) :: complex_density_prime, cgrn
real(dp) :: dx, dy, dz
real(dp) :: factor, offset0=0
real(dp), parameter :: clight=299792458.0
real(dp), parameter :: fpei=299792458.0**2*1.00000000055d-7  ! this is 1/(4 pi eps0) after the 2019 SI changes

integer :: nx, ny, nz, nx2, ny2, nz2
integer :: i, icomp, ishift, jshift, kshift

! optional normalization
normalize0 = .true.
if (present(normalize)) normalize0 = normalize

! Sizes
nx = size(density, 1); ny = size(density, 2); nz = size(density, 3)
nx2 = 2*nx; ny2 = 2*ny; nz2 = 2*nz;

! Grid spacings (conveniences)
dx = delta(1); dy = delta(2); dz = delta(3)

! Allocate complex scratch arrays
!allocate(density_prime(nx, ny, nz))
allocate(cgrn(nx2, ny2, nz2))
allocate(complex_density_prime(nx2, ny2, nz2))

! density -> d/dz density -> FFT
! This will calculate d/dz density and place in the complex array
call calc_density_derivative_complex(density, complex_density_prime, dz)
!call calc_density_derivative(density, density_prime, delta(3))
!complex_density_prime = 0
!complex_density_prime(1:nx, 1:ny, 1:nz) = density_prime

! Debug:
!call write_2d('density', density(:, ny/2, :))
!call write_2d('density_prime', density_prime(:, ny/2, :))
!call write_2d('complex_density_prime', real(complex_density_prime(1:nx, ny/2, 1:nz)))

! FFT complex density
call ccfft3d(complex_density_prime, complex_density_prime, [1,1,1], nx2, ny2, nz2, 0)

! Loop over Gx, Gy, Gs
do icomp=1, 3

  ! Get the green array
  call get_cgrn_csr3d(cgrn, delta, gamma, rho, icomp, offset=offset)

  ! This step fails because of NaN
  !  cgrn -> FFT(cgrn)
  call ccfft3d(cgrn, cgrn, [1,1,1], nx2, ny2, nz2, 0)

  print *,  "Multiply FFT'd arrays, re-use cgrn"
  ! Multiply FFT'd arrays, re-use cgrn
  cgrn=complex_density_prime*cgrn

  ! Inverse FFT
  call ccfft3d(cgrn, cgrn, [-1,-1,-1], nx2, ny2, nz2, 0)

  ! Factor for normalized 1/m^2 units, or V/m
  if (normalize0) then
    factor = dx*dy*dz/(nx2*ny2*nz2)
  else
    ! Green function handles negative rho
    factor = fpei/abs(rho) * dx*dy*dz/(nx2*ny2*nz2)
  endif

  ! This is where the output is shifted to
  ishift = nx-1
  jshift = ny-1
  kshift = nz-1

 ! Extract field
  wake(:,:,:,icomp) = factor*real(cgrn(1+ishift:nx+ishift, 1+jshift:ny+jshift, 1+kshift:nz+kshift), dp)

enddo

end subroutine csr3d_steady_state_solver

subroutine calc_density_derivative_complex(density, density_prime, dz)
real(dp), intent(in), dimension(:,:,:) :: density
real(dp), intent(in) :: dz
complex(dp), dimension(:,:,:), intent(inout) :: density_prime
integer :: nx, ny, nz

print *, 'calc_density_derivative...'

! Sizes
nx = size(density, 1)
ny = size(density, 2)
nz = size(density, 3)

! Allocate double-sized arrays. This array will be placed in the first octant
!allocate( density_prime( 2*size(density, 1), 2*size(density, 2), 2*size(density, 3) ))
density_prime = 0 ! Zero out everything

! Endpoints: second order Forward and backwards stencils
density_prime(1:nx,1:ny,1)  = (-(3/2)*density(:,:,1)    + 2*density(:,:,2)    -(1/2)*density(:,:,3) )/dz
density_prime(1:nx,1:ny,nz) = ( (1/2)*density(:,:,nz-2) - 2*density(:,:,nz-1) +(3/2)*density(:,:,nz) )/dz

! Second order central differences
density_prime(1:nx,1:ny,2:nz-1) =  (density(:,:,3:nz) - density(:,:,1:nz-2))/(2*dz)

print *, 'calc_density_derivative...Done'

end subroutine

!------------------------------------------------------------------------
!+
! Subroutine get_cgrn_csr3d(cgrn, delta, gamma, rho, icomp, offset)
!
! Computes the free space Green function on a mesh with given spacings in the lab frame.
! The computation is performed in the rest fram by boosting the coordinates by gamma.
!
!
! Input:
!   cgrn         -- COMPLEX128(:,:,:): pre-allocated array
!   delta        -- REAL64(3): vector of grid spacings dx, dy, dz
!   gamma        -- REAL64: relativistic gamma
!   rho          -- REAL64: bending radius. Can be positive or negative.
!   icomp        -- integer: Wake component requested:
!
!                        1: Wx
!                        2: Wy
!                        3: Ws
!   offset        -- real(3), optional: Offset coordinates for the center of the grid in [m].
!                    Default: (0,0,0)
!                        For example, an offset of (0,0,10) can be used to compute
!                        the field at z=+10 m relative to the rho_mesh center.
!
! Output:
!   cgrn         -- COMPLEX128(:,:,:): Green function array
!
!
! Notes:
!   Internal formulas are for rho > 0
!
!   Internally, mesh spacings in scaled units
!   x - > x/rho
!   y ->  y/rho
!   z ->  z/(2*rho)
!
!
!-
subroutine get_cgrn_csr3d(cgrn, delta, gamma, rho, icomp, offset)

complex(dp), intent(out), dimension(0:,0:,0:) :: cgrn ! Convenient indexing
real(dp), intent(in), dimension(3) :: delta
integer, intent(in) :: icomp
real(dp), intent(in) :: gamma, rho
real(dp), intent(in), optional :: offset(3)
! Local
real(dp) :: dx,dy,dz
real(dp) :: x, y, z, xmin, ymin, zmin
real(dp) :: gval
integer :: imin, imax, jmin, jmax, kmin, kmax
integer :: i,j,k, isize, jsize, ksize
integer :: n_threads

! Mesh spacings in scaled units
! x - > x/rho
! y ->  y/rho
! z ->  z/(2*rho)

dx=delta(1)/rho; dy=delta(2)/abs(rho); dz=delta(3)/abs(2*rho) ! This will handle negative rho

! Grid min
isize = size(cgrn,1); jsize=size(cgrn,2); ksize=size(cgrn,3)

xmin = ( -isize/2 +1 ) *dx
ymin = ( -jsize/2 +1 ) *dy
zmin = ( -ksize/2 +1 ) *dz

! Add optional offset
if (present(offset)) then
  xmin = xmin + offset(1)/abs(rho)  ! Do not flip the sign of the offset.
  ymin = ymin + offset(2)/abs(rho)
  zmin = zmin + offset(3)/abs(2*rho)
endif

!$ n_threads = omp_get_max_threads()
!$ if (n_threads > 1) write(*,'(a, i0)') 'OpenMP Green function calc get_cgrn_csr3d, n_threads = ', n_threads
!$OMP PARALLEL DO &
!$OMP DEFAULT(FIRSTPRIVATE), &
!$OMP SHARED(cgrn)
do k = 0, ksize-1
  z = k*dz + zmin

  do j=0, jsize-1
    y=j*dy + ymin

   do i=0, isize-1
     x = i*dx + xmin

     cgrn(i,j,k) =  psi0(x, y, z, gamma, icomp, abs(dx), dy, dz)

    enddo
  enddo
enddo
!$OMP END PARALLEL DO

! Flip psi_x sign for negative rho
if (icomp == 1 .and. rho < 0) cgrn = -cgrn

!call write_2d('psi', real(cgrn(:, jsize/2-1 +1, :)))

end subroutine get_cgrn_csr3d

!------------------------------------------------------------------------
!+
! elemental real(dp) function psi_s(x, y, z, gamma)
!
!
! Eq. 24 from Ref[X] without the prefactor e beta^2 / (2 rho^2)
!-
elemental real(dp) function psi_s(x, y, z, gamma)
real(dp), intent(in) :: x, y, z, gamma
real(dp) :: beta, beta2, kap, alp

! Check for the origin
if ((x == 0) .and. (y == 0) .and. (z == 0)) then
    psi_s = 0
else
    beta2 = 1-1/gamma**2
    beta = sqrt(beta2)

    alp = alpha(x, y, z, gamma)

    kap = 2*(alp - z)/beta ! Simpler form of kappa
    !kap = sqrt(x**2 + y**2 + 4*(1+x) * sin(alp)**2)

    psi_s =  &
        ! Acceleration term
        (cos(2*alp) - 1/(1+x)) / (kap - beta*(1+x)*sin(2*alp) ) &
        ! Space Charge term
        -1 / (  (gamma**2-1)*(1+x)*(kap - beta*(1+x)*sin(2*alp))  )

endif
end function psi_s

!------------------------------------------------------------------------
!+
! function psi0(x, y, z, gamma, icomp, dx, dy, dz)
!
! Same as psi, but handles singularities along the coordinate axes.
! This should be used when creating a grid of points.
!

elemental real(dp) function psi0(x, y, z, gamma, icomp, dx, dy, dz)
real(dp), intent(in) :: x, y, z, gamma, dx, dy, dz
integer, intent(in) :: icomp
select case (icomp)

    case(1, 2)
    ! x, y
    ! There are singularities along these axes. Do simple average
    ! TODO: tanh-sinh quadrature
    if ((x == 0) .and. (y == 0)) then
        ! Along z axis
        psi0 = (psi(-dx/2, y, z, gamma, icomp) + psi( dx/2, y, z, gamma, icomp))/2

    elseif ((y == 0) .and. (z == 0)) then
        ! Along x axis
        psi0 = (psi(x, -dy/2, z, gamma, icomp) + psi(x, dy/2, z, gamma, icomp))/2
    else
        psi0 = psi(x, y, z, gamma, icomp)
    endif

    case(3)
    ! s
    if ((x == 0) .and. (y == 0) .and. (z == 0)) then
        ! Origin = 0
        psi0 = 0
    else
        psi0 = psi(x, y, z, gamma, icomp)
    endif

end select
end function

! Conveniences

real(dp) function psi_x0(x, y, z, gamma, dx, dy, dz)
real(dp), intent(in) :: x, y, z, gamma, dx, dy, dz
psi_x0 = psi0(x, y, z, gamma, 1, dx, dy, dz)
end function

real(dp) function psi_y0(x, y, z, gamma, dx, dy, dz)
real(dp), intent(in) :: x, y, z, gamma, dx, dy, dz
psi_y0 = psi0(x, y, z, gamma, 2, dx, dy, dz)
end function

real(dp) function psi_s0(x, y, z, gamma)
real(dp), intent(in) :: x, y, z, gamma
real(dp) :: dx=0, dy=0, dz=0
    psi_s0 = psi0(x, y, z, gamma, 3, dx, dy, dz)
end function

!------------------------------------------------------------------------
!+
! elemental real(dp) function psi(x, y, z, gamma, icomp)
!
! Returns a component of the 3D CSR potential psi from Ref. [X]
!
! Eq. 24 from Ref[X] without the prefactor e beta^2 / (2 rho^2)
! This is actually psi_x_hat
!
!
! Inputs
! ------
! Same as alpha plus:
!
! icomp : integer
!          1: Wx
!          2: Wy
!          3: Ws
!
! Returns:
! psi : real
!      psi_x if icomp == 1
!      psi_y if icomp == 2
!      psi_s if icomp == 3
!
!-
elemental real(dp) function psi(x, y, z, gamma, icomp)
real(dp), intent(in) :: x, y, z, gamma
integer, intent(in) :: icomp
real(dp) :: beta, beta2, kap, alp
real(dp) :: sin2a, cos2a, kap2, sin2a2, x2, y2, y4, xp, xp2, xy, xy2, f1, f2, arg2, f, e

beta2 = 1-1/gamma**2
beta = sqrt(beta2)

alp = alpha(x, y, z, gamma)
kap = 2*(alp - z)/beta ! Simpler form of kappa
!kap = sqrt(x**2 + y**2 + 4*(1+x) * sin(alp)**2)

if (icomp == 3) then
    if ((x == 0) .and. (y == 0) .and. (z == 0)) then
      psi = 0
    else
      ! Acceleration term
      psi = (cos(2*alp) - 1/(1+x)) / (kap - beta*(1+x)*sin(2*alp) )  ! acceleration term
      ! Add Space Charge term
      psi = psi -1 / (  (gamma**2-1)*(1+x)*(kap - beta*(1+x)*sin(2*alp))  )
    endif
    return
endif

! Common patterns
sin2a = sin(2*alp)
cos2a = cos(2*alp)

kap2 = kap**2
sin2a2 = sin2a**2

x2 = x**2
y2 = y**2
y4 = y2**2
xp = x + 1
xp2 = xp**2
xy2 = x2 + y2
xy = sqrt(xy2)

! More complicated pattens
f1 = 2 + 2*x +x2
f2 = (2+x)**2
arg2 = -4 * xp / xy2

! Elliptic integrals of the first and second kind F(phi|m), E(phi|m)
call ellipinc(alp, arg2, F, E)

if (icomp == 1) then
! psi_x
! psi_x is actually psi_x_hat that includes the psi_phi term
! There is an extra ] in the numerator of the second term. All terms should multiply E.
    ! Acceleration term
    psi = f1*F / (xp*xy) - (x2*f2 + y2*f1)*E / (xp*(y2+f2)*xy)  &
        + ( kap2 - 2*beta2*xp2 + beta2*xp*f1*cos2a  ) / (beta *xp*(kap2 - beta2*xp2*sin2a2)) &
        + kap*( y4 - x2*f2 - 2*beta2*y2*xp2 )*sin2a / ( xy2*(y2 + f2)*(kap2-beta2*xp2*sin2a2)  ) &
        + kap*beta2*xp*( x2*f2 + y2*f1 )*sin2a*cos2a / ( xy2*(y2+f2)*(kap2-beta2*xp2*sin2a2)  )

    ! Add Space Charge term
    ! prefactor 1/(gamma*beta)^2 = 1/(gamma^2-1)to agree with the prefactor of psi_x
    psi = psi + 1/(gamma**2-1) * (F/(xp*xy) \
            + (x*(2+x)-y2)*E/(xp*(y2+f2)*xy) \
            + beta*(cos2a-xp)/(kap2 - beta2*xp2*sin2a2) \
            - kap*sin2a * ( (x*(2+x)*(beta2*xp2-2) + y2*(2+beta2*xp2) ) + beta2*xp*(x*(2+x)-y2)*cos2a ) \
                / ( (y4 + x2*f2 + 2*y2*f1) * (kap2 - beta2*xp2*sin2a2 ) ) )

        ! This is the psi_phi term. TODO: make another component with this
        ! - (2/beta2)* F/xy ! Include the phi term

elseif (icomp == 2) then
! psi_y
    ! Acceleration term
    psi = y * ( &
            F/xy - (x*(2+x)+y2)*E / ((y2+f2)*xy) &
            - beta*(1-xp*cos2a) / (kap2-beta2*xp2*sin2a2) &
            + kap*xp*( -(2+beta2)*y2 + (-2+beta2)*x*(2+x) ) * sin2a / ( (y4 + x2*f2 + 2*y2*f1)*( kap2-beta2*xp2*sin2a2 ) ) &
            + kap*beta2*xp2*(y2 + x*(2+x))*sin2a*cos2a / ( ( y4 + x2*f2 + 2*y2*f1)*(kap2 -beta2*xp2*sin2a2)  ) &
            )
    ! Add SC term
    psi = psi + (y/(gamma**2-1)) * ( 2*E / ( (y2 + f2)*xy) - beta / (kap2 - beta2*xp2*sin2a2) \
            + kap*xp*( beta2*(f1 + y2) -4 + 2*beta2*xp*cos2a )*sin2a \
            / ( (y4 + x2*f2 + 2*y2*f1) * (kap2 - beta2*xp2*sin2a2 ) ) )

endif

end function psi

!------------------------------------------------------------------------
!+
! elemental real(dp) function alpha(x, y, z, gamma)
!
! alpha angle from Eq. 6 in Ref. [X]
!
! When z = 0, this uses the the quadratic solution.
! Otherwise, it uses the quartic solution in Appendix A.
!
!

! Inputs
! ------
!   x  : real
!        horizontal position divided by rho
!        This is chi in Ref. [X]
!   y  : real
!        vertical position divided by rho
!        This is zeta in Ref. [X]
!   z  : real
!        longitudinal position divided by 2*rho
!        This is xi in Ref. [X]
!
!   gamma : real
!           realativistic gamma
!
! Returns
! -------
!  alpha : real
!
!-
elemental real(dp) function alpha(x, y, z, gamma)
real(dp), intent(in) :: x, y, z, gamma
real(dp) :: beta2, b, c, eta, nu, zeta,  omega, omega3, m
real(dp) :: arg1, arg2, arg3, temp

beta2 = 1-1/gamma**2

if (z == 0.0) then
    ! Quadratic solution

    b = 3 * (1 - beta2 - beta2*x) / beta2 / (1+x)
    c = -3*(x**2 + y**2)/(4*(1+x))

    alpha = sqrt( (-b + sqrt(b**2 - 4*c))/2 )

else
    !Quartic solution

    ! Terms of the depressed quartic equation
    eta = -6 * z / (beta2 * (1+x))
    nu = 3 * (1/beta2 - 1 - x) / (1+x)
    zeta = (3.0_dp/4.0_dp) * (4* z**2 /beta2 - x**2 - y**2) / (1+x)

    ! Omega calc and cube root
    temp = (eta**2/16 - zeta * nu/6 + nu**3/216)
    omega = temp + sqrt(temp**2 - (zeta/3 + nu**2/36)**3)
    omega3 = omega**(1.0_dp/3.0_dp)   ! Do not forget the 1, 3 literals must be defined to double precision!!

    ! Eq. (A2) from Ref[1]
    m = -nu/3 + (zeta/3 + nu**2/36) /omega3 + omega3

    arg1 = sqrt(2 * abs(m))
    arg2 = -2 * (m + nu)
    arg3 = 2 * eta / arg1

    if (z >= 0) then
        alpha =  (arg1 + sqrt(abs(arg2 - arg3)))/2
    else
        alpha = (-arg1 + sqrt(abs(arg2 + arg3)))/2
    endif

endif
end function alpha

!------------------------------------------------------------------------
! Debugging utils

! -----------------
! -----------------
! Write grid utility for debugging
!
subroutine write_2d(fname, grid)
real(dp) :: grid(:,:)
integer :: i, j, outfile
character(*) :: fname

open(newunit=outfile, file = trim(fname))

write(outfile, *)  size(grid, 1)
write(outfile, *)  size(grid, 2)
do i = 1, size(grid, 1)
  do j = 1, size(grid, 2)
    write(outfile, *) grid(i, j)
  enddo
enddo
close(outfile)
write(*,*) 'Grid written to ', trim(fname)
end subroutine
! -----------------
! -----------------

subroutine ellipinc_test()
real(dp) :: phi, m, mc, elb, eld
real(dp) :: ellipkinc, ellipeinc
phi = 0.1
m = 0.5

call ellipinc(phi, m, ellipkinc, ellipeinc)
print *, 'ellipinc(phi, m, ellipkinc, ellipeinc)', phi, m, ellipkinc, ellipeinc

print *, ' ------ negative m test ---------'
phi = 0.1761732772710074
m = -2001999.9999999998

call ellipinc(phi, m, ellipkinc, ellipeinc)
print *, 'ellipinc(phi, m, ellipkinc, ellipeinc)', phi, m, ellipkinc, ellipeinc

!     Inputs: phi = amplitude, mc = complementary parameter, 0 <= m < 1
!
!     Outputs: elb = B(phi|m), eld = D(phi|m)

end subroutine

end module


!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED is distributed in the hope that it will be useful, but
!    WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Makes mass matrix
!! @author Ilario Mazzieri
!> @date September, 2013
!> @version 1.0
!> @param[in] nn number of 1-D GLL nodes
!> @param[in] xq GLL nodes
!> @param[in] wq GLL weights
!> @param[in] dd spectral derivatives matrix
!> @param[in] rho mass density
!> @param[in] A11 costant values for the bilinear map
!> @param[in] A12 costant values for the bilinear map
!> @param[in] A13 costant values for the bilinear map
!> @param[in] A21 costant values for the bilinear map
!> @param[in] A22 costant values for the bilinear map
!> @param[in] A23 costant values for the bilinear map
!> @param[in] A31 costant values for the bilinear map
!> @param[in] A32 costant values for the bilinear map
!> @param[in] A33 costant values for the bilinear map
!> @param[in] B11 costant values for the bilinear map
!> @param[in] B12 costant values for the bilinear map
!> @param[in] B13 costant values for the bilinear map
!> @param[in] B21 costant values for the bilinear map
!> @param[in] B22 costant values for the bilinear map
!> @param[in] B23 costant values for the bilinear map
!> @param[in] B31 costant values for the bilinear map
!> @param[in] B32 costant values for the bilinear map
!> @param[in] B33 costant values for the bilinear map
!> @param[in] GG1 costant values for the bilinear map
!> @param[in] GG2 costant values for the bilinear map
!> @param[in] GG3 costant values for the bilinear map
!> @param[in] DD1 costant values for the bilinear map
!> @param[in] DD2 costant values for the bilinear map
!> @param[in] DD3 costant values for the bilinear map
!> @param[out] mass  diagonal mass matrix

      subroutine MAKE_MASS_MATRIX(nn,xq,wq,dd,rho,&
                           AA11,AA12,AA13,AA21,AA22,AA23,&
                           AA31,AA32,AA33,BB11,BB12,BB13,&
                           BB21,BB22,BB23,BB31,BB32,BB33,&
                           GG1,GG2,GG3,DD1,DD2,DD3,&
                           mass)

      implicit none

      integer*4 :: nn
      integer*4 :: i,j,k

      real*8 :: AA11,AA12,AA13,AA21,AA22,AA23,AA31,AA32,AA33
      real*8 :: BB11,BB12,BB13,BB21,BB22,BB23,BB31,BB32,BB33
      real*8 :: GG1,GG2,GG3,DD1,DD2,DD3
      real*8 :: dxdx,dxdy,dxdz,dydx,dydy,dydz,dzdx,dzdy,dzdz,det_j

      real*8, dimension(nn) :: xq, wq

      real*8, dimension(nn,nn) :: dd

      real*8, dimension(nn,nn,nn) :: rho
      real*8, dimension(nn,nn,nn) :: mass

!     ELEMENT NODAL MASS CALCULATION

      do k = 1,nn
         do j = 1,nn
            do i = 1,nn
               dxdx = AA11 + BB12*xq(k) + BB13*xq(j) + GG1*xq(j)*xq(k)
               dydx = AA21 + BB22*xq(k) + BB23*xq(j) + GG2*xq(j)*xq(k)
               dzdx = AA31 + BB32*xq(k) + BB33*xq(j) + GG3*xq(j)*xq(k)

               dxdy = AA12 + BB11*xq(k) + BB13*xq(i) + GG1*xq(k)*xq(i)
               dydy = AA22 + BB21*xq(k) + BB23*xq(i) + GG2*xq(k)*xq(i)
               dzdy = AA32 + BB31*xq(k) + BB33*xq(i) + GG3*xq(k)*xq(i)

               dxdz = AA13 + BB11*xq(j) + BB12*xq(i) + GG1*xq(i)*xq(j)
               dydz = AA23 + BB21*xq(j) + BB22*xq(i) + GG2*xq(i)*xq(j)
               dzdz = AA33 + BB31*xq(j) + BB32*xq(i) + GG3*xq(i)*xq(j)

               det_j = dxdz * (dydx*dzdy - dzdx*dydy) &
                     - dydz * (dxdx*dzdy - dzdx*dxdy) &
                     + dzdz * (dxdx*dydy - dydx*dxdy)

               mass(i,j,k) = rho(i,j,k) * det_j * wq(i)*wq(j)*wq(k)
            enddo
         enddo
      enddo

      return

      end subroutine MAKE_MASS_MATRIX


************************************************************************
*
*   This library consists of various Fortran routines which are useful
*   in generating the triangular meshes for the 2D MFE codes.  The
*   following is a very brief description of the routines.  See the
*   documentation for full details.
*
*   Routines for generating the triangle vertex list for triangulations
*   obtained from logically retangular grids by adding diagonals:
*
*       TRIRG -- selects one of the following meshes.
*       TSYM  -- Symmetric mesh.
*       TSYMV -- Variant of TSYM.
*       TRHX  -- Right-handed hexagonal mesh.
*       TLHX  -- Left-handed hexagonal mesh.
*       THHR  -- Horizontal-herringbone hexagonal mesh.
*       THHRV -- Variant of THHR.
*       TVHR  -- Vertical-herringbone hexagonal mesh.
*       TVHRV -- Variant of TVHR.
*
*   The corresponding routines for generating the edge-two-triangle/
*   edge-one-triangle vertex list.
*
*       EDGRG -- selects one of the following meshes.
*       ESYM  -- Symmetric mesh.
*       ESYMV -- Variant of ESYM.
*       ERHX  -- Right-handed hexagonal mesh.
*       ELHX  -- Left-handed hexagonal mesh.
*       EHHR  -- Horizontal-herringbone hexagonal mesh.
*       EHHRV -- Variant of EHHR.
*       EVHR  -- Vertical-herringbone hexagonal mesh.
*       EVHRV -- Variant of EVHR.
*
*   The following routines generate the adjacency structure of the
*   nodes in an arbitrary triangulation.
*
*       FNADJT -- Find adjacency structure from triangle vertex list.
*       FNADJE -- Find adjacency structure from edge vertex list.
*
*
*   The following routines are associated with triangulations obtained
*   by globally subdividing unstructured triangular meshes.  The data
*   structure is based on that described by R. Bank.  (These are
*   undocumented and possibly buggy.)
*
*       REFINE -- Globally refines unstructured triangulations.
*       FNTVTX -- Generates the triangle vertex list.
*       FNEVTX -- Generates the edge vertex list.
*
*   Miscellaneous routines:
*
*       FILSEG  -- Generates a refined discretization of an interval.
*
*   These low level routines are also available: T0, T1, D0, D1, HE00,
*   HE10, HE01, HE11, VE00, VE10, VE01, VE11, BB0, BB1, RB0, RB1, TB0,
*   TB1, LB0 and LB1.  See the documentation for their use.
*
************************************************************************
************************************************************************
*
*   The following routines generate the triangle vertex list and the
*   edge-two-triangle/edge-one-triangle vertex list for triangulations
*   obtained by adding diagonals to a logically rectangular grid.  The
*   routines described here are
*
*       trirg, tsym, tsymv, trhx, tlhx, thhr, thhrv, tvhr, and tvhrv,
*       which generate the triangle vertex list;
*
*       edgrg, esym, esymv, erhx, elhx, ehhr, ehhrv, evhr, and evhrv,
*       which generate the edge-two-triangle/edge-one-triangle vertex
*       list.
*
*   See the diagrams below for the specific type of triangulation each
*   routine generates.  The routines "trirg" and "edgrg" are special
*   driver routines which call one of the other routines specified by
*   the value of the flag TYPE.  Thus one may either directly call the
*   specific routines which generate the type of mesh desired or call
*   "trirg" and "edgrg" with the appropriate choice of TYPE.  The call
*   sequences for "trirg" and "edgrg" are
*
*       call trirg(ncol,nrow,type,  ntr,l),
*       call edgrg(ncol,nrow,type,  nedg,niedg,nbedg,l).
*
*   The call sequence for the routines which generate the triangle
*   vertex list (routines prefixed with a 't') is
*
*       call t???(ncol,nrow,  ntr,l),
*
*   and that for the routines which generate the edge vertex list
*   (routines prefixed with a 'e') is
*
*       call e???(ncol,nrow,  nedg,niedg,nbedg,l)
*
*   The arguments are described below.
*
*     NCOL, NROW -- the number of grid columns and rows respectively.
*     The columns are numbered consecutively from left to right and the
*     rows are numbered consecutively from bottom to top.  The (i,j)th
*     node of the mesh lies on the intersection of the ith column and
*     the jth row.  The nodes are numbered by row from left to right
*     beginning with the bottom-most row.
*
*     TYPE -- an integer which specifies type of triangulation.  The
*     allowed values are
*
*         TYPE = 11, 12 <==> 'symmetric' meshes;
*         TYPE = 21, 22 <==> 'biased' hexagonal meshes;
*         TYPE = 31, 32, 33, 34 <==> 'herringbone' hexagonal meshes.
*
*     See the diagrams below for specific details.  If TYPE is not
*     assigned one of these values nothing is done.
*
*   The following arguments are returned values:
*
*     NTR -- the number of triangles in the mesh.
*     NEDG -- the number of edges in the mesh; NEDG=NIEDG+NBEDG.
*     NIEDG -- the number of interior edges in the mesh.
*     NBEDG -- the number of boundary edges in the mesh.
*
*     L -- the array of node numbers of the vertices of the triangles
*     or edges.  For the triangle routines, the array L must have
*     length at least 3*NTR.  When dimensioned (0:2,NTR), the second
*     index corresponds to the triangle (1 through NTR) and the first
*     index corresponds to the vertex (0, 1 or 2).  Thus L(k,j) is the
*     node number of the kth vertex of triangle j.  For each triangle,
*     the vertices 0, 1, and 2 are oriented counter-clockwise about
*     the triangle.  For the edge routines, the array L must have
*     length at least 4*NEDG.  When dimensioned (0:3,NEDG), the second
*     index corresponds to the edge (1 through NEDG) and the first
*     index corresponds to the vertex (0, 1, 2, or 3).  Vertices 0
*     and 1 are the endpoints of the edge itself and vertices 2 and 3
*     are the remaining vertices of the two triangles which share this
*     common edge.  Vertices 0, 1 and 2 are oriented counter-clockwise
*     about one of the triangles.  Vertices 0, 3 and 1 have the same
*     orientation about the other.  This describes the case for
*     interior edges (edge-two-triangles).  For boundary edges
*     (edge-one-triangles), there is only a single triangle which has
*     the edge 01 as an edge.  In this case L(3,.) is assigned the
*     value zero.  The vertices for all edge-two-triangles come first
*     in L (second index ranging from 1 through NIEDG) and the edge-
*     one-triangles come last (second index ranging from NIEDG+1
*     through NEDG).  The details on how the vertices are labeled are
*     documented elsewhere in this library.
*
*
*   MESH TYPES
*   ----------
*
*     Symmetric Meshes
*     ----------------
*       The diagonals alternate between    |\|/|\|/      TYPE=11
*       the 45 and -45 degree diagonals    +-+-+-+-
*       in both the horizontal and         |/|\|/|\   Routines "tsym"
*       vertical directions, beginning     +-+-+-+-   and "esym".
*       with the 45 degree diagonal in     |\|/|\|/
*       the lower left corner of the       +-+-+-+-
*       grid.                              |/|\|/|\
*                                          +-+-+-+-
*
*       This is a variant of the above     |/|\|/|\      TYPE=12
*       mesh which begins with the -45     +-+-+-+-
*       degree diagonal in the lower       |\|/|\|/   Routines "tsymv"
*       left corner of the grid.           +-+-+-+-   and "esymv".
*                                          |/|\|/|\
*                                          +-+-+-+-
*                                          |\|/|\|/
*                                          +-+-+-+-
*
*     Biased Hexagonal Meshes
*     -----------------------
*       Right-handed hexagonal mesh.       |/|/|/|/      TYPE=21
*       All diagonals are 45 degree        +-+-+-+-
*       diagonals.                         |/|/|/|/   Routines "trhx"
*                                          +-+-+-+-   and "erhx".
*                                          |/|/|/|/
*                                          +-+-+-+-
*                                          |/|/|/|/
*                                          +-+-+-+-
*
*       Left-handed hexagonal mesh.        |\|\|\|\      TYPE=22
*       All diagonals are -45 degree       +-+-+-+-
*       diagonals.                         |\|\|\|\   Routines "tlhx"
*                                          +-+-+-+-   and "elhx".
*                                          |\|\|\|\
*                                          +-+-+-+-
*                                          |\|\|\|\
*                                          +-+-+-+-
*
*     Herringbone Hexagonal Meshes
*     ----------------------------
*       Horizontal herringbone mesh.  The  |\|\|\|\      TYPE=31
*       diagonals alternate between the    +-+-+-+-
*       45 and -45 degree diagonals in     |/|/|/|/   Routines "thhr"
*       the vertical direction, beginning  +-+-+-+-   and "ehhr".
*       with 45 degree diagonals along     |\|\|\|\
*       the bottom of the grid.            +-+-+-+-
*                                          |/|/|/|/
*                                          +-+-+-+-
*
*       This is a variant of the above     |/|/|/|/      TYPE=32
*       mesh which begins with -45 degree  +-+-+-+-
*       diagonals along the bottom of the  |\|\|\|\   Routines "thhrv"
*       grid.                              +-+-+-+-   and "ehhrv".
*                                          |/|/|/|/
*                                          +-+-+-+-
*                                          |\|\|\|\
*                                          +-+-+-+-
*
*       Vertical herringbone mesh.  The    |/|\|/|\      TYPE=33
*       diagonals alternate between the    +-+-+-+-
*       45 and -45 degree diagonals in     |/|\|/|\   Routines "tvhr"
*       the horizontal direction, begin-   +-+-+-+-   and "evhr".
*       ning with 45 degree diagonals      |/|\|/|\
*       along the left side of the grid.   +-+-+-+-
*                                          |/|\|/|\
*                                          +-+-+-+-
*
*       This is a variant of the above     |\|/|\|/      TYPE=34
*       mesh which begins with -45 degree  +-+-+-+-
*       diagonals along the left side of   |\|/|\|/   Routines "tvhrv"
*       the grid.                          +-+-+-+-   and "evhrv".
*                                          |\|/|\|/
*                                          +-+-+-+-
*                                          |\|/|\|/
*                                          +-+-+-+-
*
************************************************************************
      subroutine trirg(ncol,nrow,type,  ntr,l)
************************************************************************
*
*   Generates the triangle vertex list by calling the appropriate
*   routine for the mesh specified by TYPE.
*
************************************************************************
      integer ncol, nrow, type, ntr, l(1)

      if(type .eq. 11) then
       call tsym(ncol,nrow,  ntr,l)

      elseif(type .eq. 12) then
       call tsymv(ncol,nrow,  ntr,l)

      elseif(type .eq. 21) then
       call trhx(ncol,nrow,  ntr,l)

      elseif(type .eq. 22) then
       call tlhx(ncol,nrow,  ntr,l)

      elseif(type .eq. 31) then
       call thhr(ncol,nrow,  ntr,l)

      elseif(type .eq. 32) then
       call thhrv(ncol,nrow,  ntr,l)

      elseif(type .eq. 33) then
       call tvhr(ncol,nrow,  ntr,l)

      elseif(type .eq. 34) then
       call tvhrv(ncol,nrow,  ntr,l)
       endif

      return
      end
      subroutine tsym(ncol,nrow,  ntr,l)
************************************************************************
*
*   Generate the triangle vertex list for the symmetric mesh.
*
************************************************************************
      integer ncol, nrow, ntr, l(0:2,1), nodij, i, j

      ntr = 0

      do 11 j=1,nrow-1,2
      do 11 i=1,ncol-1,2
       nodij = i + ncol*(j-1)
       call t0(nodij,ncol,1,  l(0,ntr+1))
       ntr = ntr + 2
   11 continue

      do 12 j=1,nrow-1,2
      do 12 i=2,ncol-1,2
       nodij = i + ncol*(j-1)
       call t1(nodij,ncol,1,  l(0,ntr+1))
       ntr = ntr + 2
   12 continue

      do 13 j=2,nrow-1,2
      do 13 i=1,ncol-1,2
       nodij = i + ncol*(j-1)
       call t1(nodij,ncol,1,  l(0,ntr+1))
       ntr = ntr + 2
   13 continue

      do 14 j=2,nrow-1,2
      do 14 i=2,ncol-1,2
       nodij = i + ncol*(j-1)
       call t0(nodij,ncol,1,  l(0,ntr+1))
       ntr = ntr + 2
   14 continue

      return
      end
      subroutine tsymv(ncol,nrow,  ntr,l)
************************************************************************
*
*   Generate the triangle vertex list for the variant of the
*   symmetric mesh.
*
************************************************************************
      integer ncol, nrow, ntr, l(0:2,1), nodij, i, j

      ntr = 0

      do 11 j=1,nrow-1,2
      do 11 i=1,ncol-1,2
       nodij = i + ncol*(j-1)
       call t1(nodij,ncol,1,  l(0,ntr+1))
       ntr = ntr + 2
   11 continue

      do 12 j=1,nrow-1,2
      do 12 i=2,ncol-1,2
       nodij = i + ncol*(j-1)
       call t0(nodij,ncol,1,  l(0,ntr+1))
       ntr = ntr + 2
   12 continue

      do 13 j=2,nrow-1,2
      do 13 i=1,ncol-1,2
       nodij = i + ncol*(j-1)
       call t0(nodij,ncol,1,  l(0,ntr+1))
       ntr = ntr + 2
   13 continue

      do 14 j=2,nrow-1,2
      do 14 i=2,ncol-1,2
       nodij = i + ncol*(j-1)
       call t1(nodij,ncol,1,  l(0,ntr+1))
       ntr = ntr + 2
   14 continue

      return
      end
      subroutine trhx(ncol,nrow,  ntr,l)
************************************************************************
*
*   Generate the triangle vertex list for the right-handed hexagonal
*   mesh.
*
************************************************************************
      integer ncol, nrow, ntr, l(0:2,1), nodij, i, j

      ntr = 0

      do 11 j=1,nrow-1,2
      do 11 i=1,ncol-1
       nodij = i + ncol*(j-1)
       call t0(nodij,ncol,1,  l(0,ntr+1))
       ntr = ntr + 2
   11 continue

      do 13 j=2,nrow-1,2
      do 13 i=1,ncol-1
       nodij = i + ncol*(j-1)
       call t0(nodij,ncol,1,  l(0,ntr+1))
       ntr = ntr + 2
   13 continue

      return
      end
      subroutine tlhx(ncol,nrow,  ntr,l)
************************************************************************
*
*   Generate the triangle vertex list for the left-handed hexagonal
*   mesh.
*
************************************************************************
      integer ncol, nrow, ntr, l(0:2,1), nodij, i, j

      ntr = 0

      do 11 j=1,nrow-1,2
      do 11 i=1,ncol-1
       nodij = i + ncol*(j-1)
       call t1(nodij,ncol,1,  l(0,ntr+1))
       ntr = ntr + 2
   11 continue

      do 13 j=2,nrow-1,2
      do 13 i=1,ncol-1
       nodij = i + ncol*(j-1)
       call t1(nodij,ncol,1,  l(0,ntr+1))
       ntr = ntr + 2
   13 continue

      return
      end
      subroutine thhr(ncol,nrow,  ntr,l)
************************************************************************
*
*   Generate the triangle vertex list for the "horizontal-herringbone"
*   hexagonal mesh.
*
************************************************************************
      integer ncol, nrow, ntr, l(0:2,1), nodij, i, j

      ntr = 0

      do 11 j=1,nrow-1,2
      do 11 i=1,ncol-1
       nodij = i + ncol*(j-1)
       call t0(nodij,ncol,1,  l(0,ntr+1))
       ntr = ntr + 2
   11 continue

      do 13 j=2,nrow-1,2
      do 13 i=1,ncol-1
       nodij = i + ncol*(j-1)
       call t1(nodij,ncol,1,  l(0,ntr+1))
       ntr = ntr + 2
   13 continue

      return
      end
      subroutine thhrv(ncol,nrow,  ntr,l)
************************************************************************
*
*   Generate the triangle vertex list for the variant of the
*   "horizontal-herringbone" hexagonal mesh.
*
************************************************************************
      integer ncol, nrow, ntr, l(0:2,1), nodij, i, j

      ntr = 0

      do 11 j=1,nrow-1,2
      do 11 i=1,ncol-1
       nodij = i + ncol*(j-1)
       call t1(nodij,ncol,1,  l(0,ntr+1))
       ntr = ntr + 2
   11 continue

      do 13 j=2,nrow-1,2
      do 13 i=1,ncol-1
       nodij = i + ncol*(j-1)
       call t0(nodij,ncol,1,  l(0,ntr+1))
       ntr = ntr + 2
   13 continue

      return
      end
      subroutine tvhr(ncol,nrow,  ntr,l)
************************************************************************
*
*   Generate the triangle vertex list for the "vertical-herringbone"
*   hexagonal mesh.
*
************************************************************************
      integer ncol, nrow, ntr, l(0:2,1), nodij, i, j

      ntr = 0

      do 11 j=1,nrow-1
      do 11 i=1,ncol-1,2
       nodij = i + ncol*(j-1)
       call t0(nodij,ncol,1,  l(0,ntr+1))
       ntr = ntr + 2
   11 continue

      do 13 j=1,nrow-1
      do 13 i=2,ncol-1,2
       nodij = i + ncol*(j-1)
       call t1(nodij,ncol,1,  l(0,ntr+1))
       ntr = ntr + 2
   13 continue

      return
      end
      subroutine tvhrv(ncol,nrow,  ntr,l)
************************************************************************
*
*   Generate the triangle vertex list for the variant of the
*   "vertical-herringbone" hexagonal mesh.
*
************************************************************************
      integer ncol, nrow, ntr, l(0:2,1), nodij, i, j

      ntr = 0

      do 11 j=1,nrow-1
      do 11 i=1,ncol-1,2
       nodij = i + ncol*(j-1)
       call t1(nodij,ncol,1,  l(0,ntr+1))
       ntr = ntr + 2
   11 continue

      do 13 j=1,nrow-1
      do 13 i=2,ncol-1,2
       nodij = i + ncol*(j-1)
       call t0(nodij,ncol,1,  l(0,ntr+1))
       ntr = ntr + 2
   13 continue

      return
      end
      subroutine edgrg(ncol,nrow,type,  nedg,niedg,nbedg,l)
************************************************************************
*
*   Generates the edge-two-triangle/edge-one-triangle vertex list by
*   calling the appropriate routine for the mesh specified by TYPE.
*
************************************************************************
      integer ncol, nrow, type, nedg, niedg, nbedg, l(1)

      if(type .eq. 11) then
       call esym(ncol,nrow,  nedg,niedg,nbedg,l)

      elseif(type .eq. 12) then
       call esymv(ncol,nrow,  nedg,niedg,nbedg,l)

      elseif(type .eq. 21) then
       call erhx(ncol,nrow,  nedg,niedg,nbedg,l)

      elseif(type .eq. 22) then
       call elhx(ncol,nrow,  nedg,niedg,nbedg,l)

      elseif(type .eq. 31) then
       call ehhr(ncol,nrow,  nedg,niedg,nbedg,l)

      elseif(type .eq. 32) then
       call ehhrv(ncol,nrow,  nedg,niedg,nbedg,l)

      elseif(type .eq. 33) then
       call evhr(ncol,nrow,  nedg,niedg,nbedg,l)

      elseif(type .eq. 34) then
       call evhrv(ncol,nrow,  nedg,niedg,nbedg,l)
       endif

      return
      end
      subroutine esym(ncol,nrow,  nedg,niedg,nbedg,l)
************************************************************************
*
*   Generate the edge-two-triangle/edge-one-triangle vertex list for
*   the symmetric mesh.
*
************************************************************************
      logical even
      integer ncol,nrow, nedg,niedg,nbedg,l(0:3,1), nodij,i,j,k

      even(k) = (mod(k,2) .eq. 0)

      nedg = 0

*     ----------------
*      Diagonal edges
*     ----------------
      do 11 j=1,nrow-1,2
      do 11 i=1,ncol-1
       nodij = i + ncol*(j-1)
       nedg = nedg + 1
       if(even(i)) then
        call de1(nodij,ncol,1,  l(0,nedg))
       else
        call de0(nodij,ncol,1,  l(0,nedg))
        endif
   11 continue

      do 13 j=2,nrow-1,2
      do 13 i=1,ncol-1
       nodij = i + ncol*(j-1)
       nedg = nedg + 1
       if(even(i)) then
        call de0(nodij,ncol,1,  l(0,nedg))
       else
        call de1(nodij,ncol,1,  l(0,nedg))
        endif
   13 continue
*     ---------------------------
*      Interior horizontal edges
*     ---------------------------
      do 21 j=2,nrow-1
      do 21 i=1,ncol-1
       nodij = i + ncol*(j-1)
       nedg = nedg + 1
       if(even(i+j)) then
        call he11(nodij,ncol,1,  l(0,nedg))
       else
        call he00(nodij,ncol,1,  l(0,nedg))
        endif
   21 continue
*     -------------------------
*      Interior vertical edges
*     -------------------------
      do 31 j=1,nrow-1
      do 31 i=2,ncol-1
       nodij = i + ncol*(j-1)
       nedg = nedg + 1
       if(even(i+j)) then
        call ve11(nodij,ncol,1,  l(0,nedg))
       else
        call ve00(nodij,ncol,1,  l(0,nedg))
        endif
   31 continue

      niedg = nedg

*     ----------------
*      Boundary edges
*     ----------------
*     Bottom boundary edges, left to right
      do 110 i=1,ncol-1
       nodij = i
       nedg = nedg + 1
       if(even(i)) then
        call bb0(nodij,ncol,1,  l(0,nedg))
       else
        call bb1(nodij,ncol,1,  l(0,nedg))
        endif
  110 continue

*     Right boundary edges, bottom to top
      do 120 j=1,nrow-1
       nodij = ncol*j
       nedg = nedg + 1
       if(even(j+ncol)) then
        call rb1(nodij,ncol,1,  l(0,nedg))
       else
        call rb0(nodij,ncol,1,  l(0,nedg))
        endif
  120 continue

*     Top boundary edges, right to left
      do 130 i=ncol,2,-1
       nodij = i + ncol*(nrow-1)
       nedg = nedg + 1
       if(even(i+nrow)) then
        call tb1(nodij,ncol,1,  l(0,nedg))
       else
        call tb0(nodij,ncol,1,  l(0,nedg))
        endif
  130 continue

*     Left boundary edges, top to bottom
      do 140 j=nrow,2,-1
       nodij = 1 + ncol*(j-1)
       nedg = nedg + 1
       if(even(j)) then
        call lb0(nodij,ncol,1,  l(0,nedg))
       else
        call lb1(nodij,ncol,1,  l(0,nedg))
        endif
  140 continue

      nbedg = nedg - niedg

      return
      end
      subroutine esymv(ncol,nrow,  nedg,niedg,nbedg,l)
************************************************************************
*
*   Generate the edge-two-triangle/edge-one-triangle vertex list for
*   the symmetric mesh variant.
*
************************************************************************
      logical even
      integer ncol,nrow, nedg,niedg,nbedg,l(0:3,1), nodij,i,j,k

      even(k) = (mod(k,2) .eq. 0)

      nedg = 0

*     ----------------
*      Diagonal edges
*     ----------------
      do 11 j=1,nrow-1,2
      do 11 i=1,ncol-1
       nodij = i + ncol*(j-1)
       nedg = nedg + 1
       if(even(i)) then
        call de0(nodij,ncol,1,  l(0,nedg))
       else
        call de1(nodij,ncol,1,  l(0,nedg))
        endif
   11 continue

      do 13 j=2,nrow-1,2
      do 13 i=1,ncol-1
       nodij = i + ncol*(j-1)
       nedg = nedg + 1
       if(even(i)) then
        call de1(nodij,ncol,1,  l(0,nedg))
       else
        call de0(nodij,ncol,1,  l(0,nedg))
        endif
   13 continue
*     ---------------------------
*      Interior horizontal edges
*     ---------------------------
      do 21 j=2,nrow-1
      do 21 i=1,ncol-1
       nodij = i + ncol*(j-1)
       nedg = nedg + 1
       if(even(i+j)) then
        call he00(nodij,ncol,1,  l(0,nedg))
       else
        call he11(nodij,ncol,1,  l(0,nedg))
        endif
   21 continue
*     -------------------------
*      Interior vertical edges
*     -------------------------
      do 31 j=1,nrow-1
      do 31 i=2,ncol-1
       nodij = i + ncol*(j-1)
       nedg = nedg + 1
       if(even(i+j)) then
        call ve00(nodij,ncol,1,  l(0,nedg))
       else
        call ve11(nodij,ncol,1,  l(0,nedg))
        endif
   31 continue

      niedg = nedg

*     ----------------
*      Boundary edges
*     ----------------
*     Bottom boundary edges, left to right
      do 110 i=1,ncol-1
       nodij = i
       nedg = nedg + 1
       if(even(i)) then
        call bb1(nodij,ncol,1,  l(0,nedg))
       else
        call bb0(nodij,ncol,1,  l(0,nedg))
        endif
  110 continue

*     Right boundary edges, bottom to top
      do 120 j=1,nrow-1
       nodij = ncol*j
       nedg = nedg + 1
       if(even(j+ncol)) then
        call rb0(nodij,ncol,1,  l(0,nedg))
       else
        call rb1(nodij,ncol,1,  l(0,nedg))
        endif
  120 continue

*     Top boundary edges, right to left
      do 130 i=ncol,2,-1
       nodij = i + ncol*(nrow-1)
       nedg = nedg + 1
       if(even(i+nrow)) then
        call tb0(nodij,ncol,1,  l(0,nedg))
       else
        call tb1(nodij,ncol,1,  l(0,nedg))
        endif
  130 continue

*     Left boundary edges, top to bottom
      do 140 j=nrow,2,-1
       nodij = 1 + ncol*(j-1)
       nedg = nedg + 1
       if(even(j)) then
        call lb1(nodij,ncol,1,  l(0,nedg))
       else
        call lb0(nodij,ncol,1,  l(0,nedg))
        endif
  140 continue

      nbedg = nedg - niedg

      return
      end
      subroutine erhx(ncol,nrow,  nedg,niedg,nbedg,l)
************************************************************************
*
*   Generate the edge-two-triangle/edge-one-triangle vertex list for
*   the right-handed hexagonal mesh.
*
************************************************************************
      integer ncol,nrow, nedg,niedg,nbedg,l(0:3,1), nodij,i,j

      nedg = 0

*     ----------------
*      Diagonal edges
*     ----------------
      do 11 j=1,nrow-1
      do 11 i=1,ncol-1
      nodij = i + ncol*(j-1)
      nedg = nedg + 1
   11 call de0(nodij,ncol,1,  l(0,nedg))
*     ---------------------------
*      Interior horizontal edges
*     ---------------------------
      do 21 j=2,nrow-1
      do 21 i=1,ncol-1
      nodij = i + ncol*(j-1)
      nedg = nedg + 1
   21 call he10(nodij,ncol,1,  l(0,nedg))
*     -------------------------
*      Interior vertical edges
*     -------------------------
      do 31 j=1,nrow-1
      do 31 i=2,ncol-1
      nodij = i + ncol*(j-1)
      nedg = nedg + 1
   31 call ve01(nodij,ncol,1,  l(0,nedg))

      niedg = nedg

*     ----------------
*      Boundary edges
*     ----------------
*     Bottom boundary edges, left to right
      do 110 i=1,ncol-1
      nodij = i
      nedg = nedg + 1
  110 call bb1(nodij,ncol,1,  l(0,nedg))

*     Right boundary edges, bottom to top
      do 120 j=1,nrow-1
      nodij = ncol*j
      nedg = nedg + 1
  120 call rb0(nodij,ncol,1,  l(0,nedg))

*     Top boundary edges, right to left
      do 130 i=ncol,2,-1
      nodij = i + ncol*(nrow-1)
      nedg = nedg + 1
  130 call tb1(nodij,ncol,1,  l(0,nedg))

*     Left boundary edges, top to bottom
      do 140 j=nrow,2,-1
      nodij = 1 + ncol*(j-1)
      nedg = nedg + 1
  140 call lb0(nodij,ncol,1,  l(0,nedg))

      nbedg = nedg - niedg

      return
      end
      subroutine elhx(ncol,nrow,  nedg,niedg,nbedg,l)
************************************************************************
*
*   Generate the edge-two-triangle/edge-one-triangle vertex list for
*   the left-handed hexagonal mesh.
*
************************************************************************
      integer ncol,nrow, nedg,niedg,nbedg,l(0:3,1), nodij,i,j

      nedg = 0

*     ----------------
*      Diagonal edges
*     ----------------
      do 11 j=1,nrow-1
      do 11 i=1,ncol-1
      nodij = i + ncol*(j-1)
      nedg = nedg + 1
   11 call de1(nodij,ncol,1,  l(0,nedg))
*     ---------------------------
*      Interior horizontal edges
*     ---------------------------
      do 21 j=2,nrow-1
      do 21 i=1,ncol-1
      nodij = i + ncol*(j-1)
      nedg = nedg + 1
   21 call he01(nodij,ncol,1,  l(0,nedg))
*     -------------------------
*      Interior vertical edges
*     -------------------------
      do 31 j=1,nrow-1
      do 31 i=2,ncol-1
      nodij = i + ncol*(j-1)
      nedg = nedg + 1
   31 call ve10(nodij,ncol,1,  l(0,nedg))

      niedg = nedg

*     ----------------
*      Boundary edges
*     ----------------
*     Bottom boundary edges, left to right
      do 110 i=1,ncol-1
      nodij = i
      nedg = nedg + 1
  110 call bb0(nodij,ncol,1,  l(0,nedg))

*     Right boundary edges, bottom to top
      do 120 j=1,nrow-1
      nodij = ncol*j
      nedg = nedg + 1
  120 call rb1(nodij,ncol,1,  l(0,nedg))

*     Top boundary edges, right to left
      do 130 i=ncol,2,-1
      nodij = i + ncol*(nrow-1)
      nedg = nedg + 1
  130 call tb0(nodij,ncol,1,  l(0,nedg))

*     Left boundary edges, top to bottom
      do 140 j=nrow,2,-1
      nodij = 1 + ncol*(j-1)
      nedg = nedg + 1
  140 call lb1(nodij,ncol,1,  l(0,nedg))

      nbedg = nedg - niedg

      return
      end
      subroutine ehhr(ncol,nrow,  nedg,niedg,nbedg,l)
************************************************************************
*
*   Generate the edge-two-triangle/edge-one-triangle vertex list for
*   the "horizontal-herringbone" hexagonal mesh.
*
************************************************************************
      logical even
      integer ncol,nrow, nedg,niedg,nbedg,l(0:3,1), nodij,i,j,k

      even(k) = (mod(k,2) .eq. 0)

      nedg = 0

*     ----------------
*      Diagonal edges
*     ----------------
      do 11 j=1,nrow-1
      do 11 i=1,ncol-1
       nodij = i + ncol*(j-1)
       nedg = nedg + 1
       if(even(j)) then
        call de1(nodij,ncol,1,  l(0,nedg))
       else
        call de0(nodij,ncol,1,  l(0,nedg))
        endif
   11 continue
*     ---------------------------
*      Interior horizontal edges
*     ---------------------------
      do 21 j=2,nrow-1
      do 21 i=1,ncol-1
       nodij = i + ncol*(j-1)
       nedg = nedg + 1
       if(even(j)) then
        call he00(nodij,ncol,1,  l(0,nedg))
       else
        call he11(nodij,ncol,1,  l(0,nedg))
        endif
   21 continue
*     -------------------------
*      Interior vertical edges
*     -------------------------
      do 31 j=1,nrow-1
      do 31 i=2,ncol-1
       nodij = i + ncol*(j-1)
       nedg = nedg + 1
       if(even(j)) then
        call ve10(nodij,ncol,1,  l(0,nedg))
       else
        call ve01(nodij,ncol,1,  l(0,nedg))
        endif
   31 continue

      niedg = nedg

*     ----------------
*      Boundary edges
*     ----------------
*     Bottom boundary edges, left to right
      do 110 i=1,ncol-1
      nodij = i
      nedg = nedg + 1
  110 call bb1(nodij,ncol,1,  l(0,nedg))

*     Right boundary edges, bottom to top
      do 120 j=1,nrow-1
       nodij = ncol*j
       nedg = nedg + 1
       if(even(j)) then
        call rb1(nodij,ncol,1,  l(0,nedg))
       else
        call rb0(nodij,ncol,1,  l(0,nedg))
        endif
  120 continue

*     Top boundary edges, right to left
      do 130 i=ncol,2,-1
       nodij = i + ncol*(nrow-1)
       nedg = nedg + 1
       if(even(nrow)) then
        call tb1(nodij,ncol,1,  l(0,nedg))
       else
        call tb0(nodij,ncol,1,  l(0,nedg))
        endif
  130 continue

*     Left boundary edges, top to bottom
      do 140 j=nrow,2,-1
       nodij = 1 + ncol*(j-1)
       nedg = nedg + 1
       if(even(j)) then
        call lb0(nodij,ncol,1,  l(0,nedg))
       else
        call lb1(nodij,ncol,1,  l(0,nedg))
        endif
  140 continue

      nbedg = nedg - niedg

      return
      end
      subroutine ehhrv(ncol,nrow,  nedg,niedg,nbedg,l)
************************************************************************
*
*   Generate the edge-two-triangle/edge-one-triangle vertex list for
*   the variant of the "horizontal-herringbone" hexagonal mesh.
*
************************************************************************
      logical even
      integer ncol,nrow, nedg,niedg,nbedg,l(0:3,1), nodij,i,j,k

      even(k) = (mod(k,2) .eq. 0)

      nedg = 0

*     ----------------
*      Diagonal edges
*     ----------------
      do 11 j=1,nrow-1
      do 11 i=1,ncol-1
       nodij = i + ncol*(j-1)
       nedg = nedg + 1
       if(even(j)) then
        call de0(nodij,ncol,1,  l(0,nedg))
       else
        call de1(nodij,ncol,1,  l(0,nedg))
        endif
   11 continue
*     ---------------------------
*      Interior horizontal edges
*     ---------------------------
      do 21 j=2,nrow-1
      do 21 i=1,ncol-1
       nodij = i + ncol*(j-1)
       nedg = nedg + 1
       if(even(j)) then
        call he11(nodij,ncol,1,  l(0,nedg))
       else
        call he00(nodij,ncol,1,  l(0,nedg))
        endif
   21 continue
*     -------------------------
*      Interior vertical edges
*     -------------------------
      do 31 j=1,nrow-1
      do 31 i=2,ncol-1
       nodij = i + ncol*(j-1)
       nedg = nedg + 1
       if(even(j)) then
        call ve01(nodij,ncol,1,  l(0,nedg))
       else
        call ve10(nodij,ncol,1,  l(0,nedg))
        endif
   31 continue

      niedg = nedg

*     ----------------
*      Boundary edges
*     ----------------
*     Bottom boundary edges, left to right
      do 110 i=1,ncol-1
      nodij = i
      nedg = nedg + 1
  110 call bb0(nodij,ncol,1,  l(0,nedg))

*     Right boundary edges, bottom to top
      do 120 j=1,nrow-1
       nodij = ncol*j
       nedg = nedg + 1
       if(even(j)) then
        call rb0(nodij,ncol,1,  l(0,nedg))
       else
        call rb1(nodij,ncol,1,  l(0,nedg))
        endif
  120 continue

*     Top boundary edges, right to left
      do 130 i=ncol,2,-1
       nodij = i + ncol*(nrow-1)
       nedg = nedg + 1
       if(even(nrow)) then
        call tb0(nodij,ncol,1,  l(0,nedg))
       else
        call tb1(nodij,ncol,1,  l(0,nedg))
        endif
  130 continue

*     Left boundary edges, top to bottom
      do 140 j=nrow,2,-1
       nodij = 1 + ncol*(j-1)
       nedg = nedg + 1
       if(even(j)) then
        call lb1(nodij,ncol,1,  l(0,nedg))
       else
        call lb0(nodij,ncol,1,  l(0,nedg))
        endif
  140 continue

      nbedg = nedg - niedg

      return
      end
      subroutine evhr(ncol,nrow,  nedg,niedg,nbedg,l)
************************************************************************
*
*   Generate the edge-two-triangle/edge-one-triangle vertex list for
*   the "vertical-herringbone" hexagonal mesh.
*
************************************************************************
      logical even
      integer ncol,nrow, nedg,niedg,nbedg,l(0:3,1), nodij,i,j,k

      even(k) = (mod(k,2) .eq. 0)

      nedg = 0

*     ----------------
*      Diagonal edges
*     ----------------
      do 11 j=1,nrow-1
      do 11 i=1,ncol-1
       nodij = i + ncol*(j-1)
       nedg = nedg + 1
       if(even(i)) then
        call de1(nodij,ncol,1,  l(0,nedg))
       else
        call de0(nodij,ncol,1,  l(0,nedg))
        endif
   11 continue
*     ---------------------------
*      Interior horizontal edges
*     ---------------------------
      do 21 j=2,nrow-1
      do 21 i=1,ncol-1
       nodij = i + ncol*(j-1)
       nedg = nedg + 1
       if(even(i)) then
        call he01(nodij,ncol,1,  l(0,nedg))
       else
        call he10(nodij,ncol,1,  l(0,nedg))
        endif
   21 continue
*     -------------------------
*      Interior vertical edges
*     -------------------------
      do 31 j=1,nrow-1
      do 31 i=2,ncol-1
       nodij = i + ncol*(j-1)
       nedg = nedg + 1
       if(even(i)) then
        call ve00(nodij,ncol,1,  l(0,nedg))
       else
        call ve11(nodij,ncol,1,  l(0,nedg))
        endif
   31 continue

      niedg = nedg

*     ----------------
*      Boundary edges
*     ----------------
*     Bottom boundary edges, left to right
      do 110 i=1,ncol-1
       nodij = i
       nedg = nedg + 1
       if(even(i)) then
        call bb0(nodij,ncol,1,  l(0,nedg))
       else
        call bb1(nodij,ncol,1,  l(0,nedg))
        endif
  110 continue

*     Right boundary edges, bottom to top
      do 120 j=1,nrow-1
       nodij = ncol*j
       nedg = nedg + 1
       if(even(ncol)) then
        call rb0(nodij,ncol,1,  l(0,nedg))
       else
        call rb1(nodij,ncol,1,  l(0,nedg))
        endif
  120 continue

*     Top boundary edges, right to left
      do 130 i=ncol,2,-1
       nodij = i + ncol*(nrow-1)
       nedg = nedg + 1
       if(even(i)) then
        call tb1(nodij,ncol,1,  l(0,nedg))
       else
        call tb0(nodij,ncol,1,  l(0,nedg))
        endif
  130 continue

*     Left boundary edges, top to bottom
      do 140 j=nrow,2,-1
      nodij = 1 + ncol*(j-1)
      nedg = nedg + 1
  140 call lb0(nodij,ncol,1,  l(0,nedg))

      nbedg = nedg - niedg

      return
      end
      subroutine evhrv(ncol,nrow,  nedg,niedg,nbedg,l)
************************************************************************
*
*   Generate the edge-two-triangle/edge-one-triangle vertex list for
*   the variant of the "vertical-herringbone" hexagonal mesh.
*
************************************************************************
      logical even
      integer ncol,nrow, nedg,niedg,nbedg,l(0:3,1), nodij,i,j,k

      even(k) = (mod(k,2) .eq. 0)

      nedg = 0

*     ----------------
*      Diagonal edges
*     ----------------
      do 11 j=1,nrow-1
      do 11 i=1,ncol-1
       nodij = i + ncol*(j-1)
       nedg = nedg + 1
       if(even(i)) then
        call de0(nodij,ncol,1,  l(0,nedg))
       else
        call de1(nodij,ncol,1,  l(0,nedg))
        endif
   11 continue
*     ---------------------------
*      Interior horizontal edges
*     ---------------------------
      do 21 j=2,nrow-1
      do 21 i=1,ncol-1
       nodij = i + ncol*(j-1)
       nedg = nedg + 1
       if(even(i)) then
        call he10(nodij,ncol,1,  l(0,nedg))
       else
        call he01(nodij,ncol,1,  l(0,nedg))
        endif
   21 continue
*     -------------------------
*      Interior vertical edges
*     -------------------------
      do 31 j=1,nrow-1
      do 31 i=2,ncol-1
       nodij = i + ncol*(j-1)
       nedg = nedg + 1
       if(even(i)) then
        call ve11(nodij,ncol,1,  l(0,nedg))
       else
        call ve00(nodij,ncol,1,  l(0,nedg))
        endif
   31 continue

      niedg = nedg

*     ----------------
*      Boundary edges
*     ----------------
*     Bottom boundary edges, left to right
      do 110 i=1,ncol-1
       nodij = i
       nedg = nedg + 1
       if(even(i)) then
        call bb1(nodij,ncol,1,  l(0,nedg))
       else
        call bb0(nodij,ncol,1,  l(0,nedg))
        endif
  110 continue

*     Right boundary edges, bottom to top
      do 120 j=1,nrow-1
       nodij = ncol*j
       nedg = nedg + 1
       if(even(ncol)) then
        call rb1(nodij,ncol,1,  l(0,nedg))
       else
        call rb0(nodij,ncol,1,  l(0,nedg))
        endif
  120 continue

*     Top boundary edges, right to left
      do 130 i=ncol,2,-1
       nodij = i + ncol*(nrow-1)
       nedg = nedg + 1
       if(even(i)) then
        call tb0(nodij,ncol,1,  l(0,nedg))
       else
        call tb1(nodij,ncol,1,  l(0,nedg))
        endif
  130 continue

*     Left boundary edges, top to bottom
      do 140 j=nrow,2,-1
      nodij = 1 + ncol*(j-1)
      nedg = nedg + 1
  140 call lb1(nodij,ncol,1,  l(0,nedg))

      nbedg = nedg - niedg

      return
      end
************************************************************************
*
*   The following routines label the vertices of individual triangles,
*   edge-two-triangles, and edge-one-triangles for the various possible
*   orientations (see diagrams below).  The routines are t0 and t1
*   (triangles), de0, de1, he00, he10, he01, he11, ve00, ve10, ve01,
*   and ve11 (edge-two-triangles), and bb0, bb1, rb0, rb1, tb0, tb1,
*   lb0, and lb1 (edge-one-triangles).  The arguments to all these
*   routines are similar and are described here.
*
*     N -- the node number of the local reference node for the
*     triangle pair or edge.  The reference node for each orientation
*     is indicated in the diagrams by an "*".
*
*     JC, JR -- the increments in node number between consecutive nodes
*     in a column (bottom to top) and between consecutive nodes in a
*     row (left to right).  Thus if we are at node number N, the node
*     immediately above in the same column is node N+JC, the node to
*     the right in the same row is node N+JR, the node to the left is
*     node N-JR, and so on.  Such a relationship between node numbers
*     will hold if the nodes are numbered by column or by row.  Note
*     that JC and JR may be given negative values.
*
*     L -- the array of node numbers of the vertices of a triangle or
*     edge.  Triangles are done by pairs which are formed when a grid
*     cell in divided by a diagonal (see diagrams below).  For these
*     two routines, "t0" and "t1", L has length 6, dimensioned (0:2,2).
*     The second index corresponds to the triangle, 1 or 2, and the
*     first index corresponds to the vertex number.  Thus L(j,1) is
*     the node number of the jth vertex of the first triangle, and so
*     on.  Notice that the vertices are oriented counter-clockwise
*     about the boundary of each triangle.  For the remaining routines
*     which label the vertices of edges, L is a vector of length 4,
*     dimensioned (0:3).  L(j) is the node number of the jth vertex.
*     Vertices 0 and 1 are the endpoints of the edge and vertices 2
*     and 3 are the remaining vertices of the two triangles which share
*     this common edge.  Notice that vertices 0, 1, and 2 are oriented
*     counter-clockwise about one of the triangles.  Vertices 0, 3, and
*     1 have the same orientation about the other triangle.  This
*     describes the case for all interior edges (edge-two-triangles).
*     For edges lying on the boundary, there is only a single triangle
*     which has the edge 01 as an edge (edge-one-triangles).  In this
*     case L(3) is assigned the value zero.  Note also that the edge 01
*     is oriented counter-clockwise about the boundary of the domain.
*
*   Triangles.
*                         "t0"                             "t1"
*
*        +-----+        2-----1           +-----+         1-----0
*        |    /|        |    / 0          |\    |        2 \    |
*        |   / |        | 1 / /|          | \   |        |\ \ 2 |
*        |  /  |  ===>  |  / / |          |  \  |  ===>  | \ \  |
*        | /   |        | / /  |          |   \ |        |  \ \ |
*        |/    |        |/ / 2 |          |    \|        | 1 \ \|
*        +-----+        0 /    |          +-----+        |    \ 2
*       *                1-----2         *               0-----1
*
*   Interior edges (edge-two-triangles).
*
*     diagonal edges:
*
*                      "de0"            "de1"
*
*                      2----1           0----2
*                      |   /|           |\   |
*                      |  / |           | \  |
*                      | /  |           |  \ |
*                      |/   |           |   \|
*                     *0----3          *3----1
*
*     horizontal edges:
*
*         "he00"        "he10"        "he01"        "he11"
*
*          2                 2         2                 2
*          |\               /|         |\               /|
*          | \             / |         | \             / |
*          |  \           /  |         |  \           /  |
*         *0---1        *0---1        *0---1        *0---1
*          |  /          |  /           \  |          \  |
*          | /           | /             \ |           \ |
*          |/            |/               \|            \|
*          3             3                 3             3
*
*     vertical edges:
*
*         "ve00"        "ve10"        "ve01"        "ve11"
*
*            1         2---1             1---3     2---1---3
*           /|\         \  |\           /|  /       \  |  /
*          / | \         \ | \         / | /         \ | /
*         /  |  \         \|  \       /  |/           \|/
*        2---0---3         0---3     2---0             0
*            *             *             *             *
*
*   Boundary edges (edge-one-triangles).
*
*     bottom boundary:            right boundary:
*
*         "bb0"     "bb1"             "rb0"     "rb1"
*
*         2             2                 1     2---1
*         |\           /|                /|      \  |
*         | \         / |               / |       \ |
*         |  \       /  |              /  |        \|
*        *0---1    *0---1             2---0*        0*
*
*     top boundary:               left boundary:
*
*         "tb0"     "tb1"             "lb0"     "lb1"
*
*         1---0*    1---0*           *0---2    *0
*          \  |     |  /              |  /      |\
*           \ |     | /               | /       | \
*            \|     |/                |/        |  \
*             2     2                 1         1---2
*
************************************************************************
      subroutine t0(n,jc,jr,  l)

      integer n, jc, jr, l(0:2,2)

      l(0,1) = n
      l(1,1) = n + jr + jc
      l(2,1) = n + jc

      l(0,2) = n + jr + jc
      l(1,2) = n
      l(2,2) = n + jr

      return
      end
      subroutine t1(n,jc,jr,  l)

      integer n, jc, jr, l(0:2,2)

      l(0,1) = n
      l(1,1) = n + jr
      l(2,1) = n + jc

      l(0,2) = n + jr + jc
      l(1,2) = n + jc
      l(2,2) = n + jr

      return
      end
      subroutine de0(n,jc,jr,  l)

      integer n, jc, jr, l(0:3)

      l(0) = n
      l(1) = n + jr + jc
      l(2) = n + jc
      l(3) = n + jr

      return
      end
      subroutine de1(n,jc,jr,  l)

      integer n, jc, jr, l(0:3)

      l(0) = n + jc
      l(1) = n + jr
      l(2) = n + jr + jc
      l(3) = n

      return
      end
      subroutine he00(n,jc,jr,  l)

      integer n, jc, jr, l(0:3)

      l(0) = n
      l(1) = n + jr
      l(2) = n + jc
      l(3) = n - jc

      return
      end
      subroutine he10(n,jc,jr,  l)

      integer n, jc, jr, l(0:3)

      l(0) = n
      l(1) = n + jr
      l(2) = n + jr + jc
      l(3) = n - jc

      return
      end
      subroutine he01(n,jc,jr,  l)

      integer n, jc, jr, l(0:3)

      l(0) = n
      l(1) = n + jr
      l(2) = n + jc
      l(3) = n + jr - jc

      return
      end
      subroutine he11(n,jc,jr,  l)

      integer n, jc, jr, l(0:3)

      l(0) = n
      l(1) = n + jr
      l(2) = n + jr + jc
      l(3) = n + jr - jc

      return
      end
      subroutine ve00(n,jc,jr,  l)

      integer n, jc, jr, l(0:3)

      l(0) = n
      l(1) = n + jc
      l(2) = n - jr
      l(3) = n + jr

      return
      end
      subroutine ve10(n,jc,jr,  l)

      integer n, jc, jr, l(0:3)

      l(0) = n
      l(1) = n + jc
      l(2) = n - jr + jc
      l(3) = n + jr

      return
      end
      subroutine ve01(n,jc,jr,  l)

      integer n, jc, jr, l(0:3)

      l(0) = n
      l(1) = n + jc
      l(2) = n - jr
      l(3) = n + jr + jc

      return
      end
      subroutine ve11(n,jc,jr,  l)

      integer n, jc, jr, l(0:3)

      l(0) = n
      l(1) = n + jc
      l(2) = n - jr + jc
      l(3) = n + jr + jc

      return
      end
      subroutine bb0(n,jc,jr,  l)

      integer n, jc, jr, l(0:3)

      l(0) = n
      l(1) = n + jr
      l(2) = n + jc
      l(3) = 0

      return
      end
      subroutine bb1(n,jc,jr,  l)

      integer n, jc, jr, l(0:3)

      l(0) = n
      l(1) = n + jr
      l(2) = n + jr + jc
      l(3) = 0

      return
      end
      subroutine rb0(n,jc,jr,  l)

      integer n, jc, jr, l(0:3)

      l(0) = n
      l(1) = n + jc
      l(2) = n - jr
      l(3) = 0

      return
      end
      subroutine rb1(n,jc,jr,  l)

      integer n, jc, jr, l(0:3)

      l(0) = n
      l(1) = n + jc
      l(2) = n - jr + jc
      l(3) = 0

      return
      end
      subroutine tb0(n,jc,jr,  l)

      integer n, jc, jr, l(0:3)

      l(0) = n
      l(1) = n - jr
      l(2) = n - jc
      l(3) = 0

      return
      end
      subroutine tb1(n,jc,jr,  l)

      integer n, jc, jr, l(0:3)

      l(0) = n
      l(1) = n - jr
      l(2) = n - jr - jc
      l(3) = 0

      return
      end
      subroutine lb0(n,jc,jr,  l)

      integer n, jc, jr, l(0:3)

      l(0) = n
      l(1) = n - jc
      l(2) = n + jr
      l(3) = 0

      return
      end
      subroutine lb1(n,jc,jr,  l)

      integer n, jc, jr, l(0:3)

      l(0) = n
      l(1) = n - jc
      l(2) = n + jr - jc
      l(3) = 0

      return
      end
      subroutine fnadjt(ntri,tvtx,  nnod,xadj,adjncy,madj,  xladj,errc)
************************************************************************
*
*   FNADJT -- FIND ADJACENCY STRUCTURE FROM TRIANGLE VERTEX LIST.
*
*   THIS ROUTINE FINDS THE ADJACENCY STRUCTURE OF THE NODES IN A
*   TRIANGULAR MESH GIVEN A LIST OF THE TRIANGLE VERTICES.  THE
*   RESULTING ADJACENCY LIST FOR EACH NODE IS ORDERED.
*
*   ARGUMENT  I/O/M/T  DESCRIPTION
*   --------  -------  -----------
*    NTRI        I     NUMBER OF TRIANGLES IN THE MESH.
*
*    TVTX        I     TRIANGLE VERTEX LIST.  TVTX(I,J), I=0,1,2,
*                      ARE THE THREE VERTICES OF THE JTH TRIANGLE.
*
*    NNOD        I     NUMBER OF NODES IN THE MESH.
*
*    XADJ        O     INDEX ARRAY OF LENGTH NNOD+1 CONTAINING POINTERS
*                      TO THE BEGINNING OF EACH ADJACENCY LIST IN
*                      ADJNCY.
*
*    ADJNCY      O     ARRAY CONTAINING THE NODE ADJACENCY LISTS.
*
*    MADJ        I     DECLARED LENGTH OF ADJNCY.
*
*    XLADJ       T     TEMPORARY ARRAY OF LENGTH NNOD+1.
*
*    ERRC        O     SET TO 1 IF THERE WAS INSUFFICIENT STORAGE TO
*                      STORE THE ADJACENCY LISTS.  SET TO 0 OTHERWISE.
*
************************************************************************
      integer ntri,tvtx(0:2,*),nnod,xadj(*),adjncy(*),xladj(*),madj,errc
      integer i,j,k,l,nedg,itri,ivtx,jvtx,inod,iedg,jdeg,shift

*     =======================================
*      i. generate the sorted list of edges.
*     =======================================

      nedg = 0

      do 100 itri=1,ntri
      do 100 ivtx=0,2

*      next edge to be inserted is (i,j).
       jvtx = mod(ivtx+1,3)
       i = min( tvtx(ivtx,itri), tvtx(jvtx,itri) )
       j = max( tvtx(ivtx,itri), tvtx(jvtx,itri) )

*      sort on first component.
       iedg = nedg
  110  if(iedg .lt. 1) go to 130
       if(adjncy(2*iedg-1) .le. i) go to 115
       iedg = iedg - 1
       go to 110

  115  if(adjncy(2*iedg-1) .lt. i) go to 130

*      first components are equal.  sort on second.
  120  if(adjncy(2*iedg) .le. j) go to 125
       iedg = iedg - 1
       if(iedg .ge. 1 .and. adjncy(2*iedg-1) .eq. i) go to 120
       go to 130

*      if second components are equal, its a duplicate edge.
  125  if(adjncy(2*iedg) .eq. j) go to 100

*      insert edge (i,j) into list at location iedg+1.
  130  if(2*(nedg+1) .gt. madj) go to 910
       nedg = nedg + 1

       do 135 k=2*nedg,2*iedg+3,-1
  135  adjncy(k) = adjncy(k-2)

       adjncy(2*iedg+1) = i
       adjncy(2*iedg+2) = j

  100 continue

*     =========================================
*      ii. find the lower adjacency structure.
*     =========================================

*     generate the index array xladj.
      xladj(1) = 1
      inod = 2
      iedg = 0
  212 iedg = iedg + 1
      if(iedg .gt. nedg) go to 210
  211 if(adjncy(2*iedg-1) .lt. inod) go to 212
      xladj(inod) = iedg
      inod = inod + 1
      go to 211

  210 continue

      do 220 j=inod,nnod+1
  220 xladj(j) = nedg + 1

*     generate the lower adjacency lists by compression.
      do 230 i=1,nedg
  230 adjncy(i) = adjncy(2*i)

*     =========================================
*      iii. find the full adjacency structure.
*     =========================================

*     generate the index array xadj.
      xadj(1) = xladj(1)
      xadj(2) = xladj(2)
      do 310 j=2,nnod
*      compute the degree of node j.
       jdeg = xladj(j+1) - xladj(j)
       do 311 k=1,xladj(j)-1
  311  if(adjncy(k) .eq. j) jdeg = jdeg + 1
       xadj(j+1) = xadj(j) + jdeg
  310 continue

*     generate the full adjacency lists.
      do 320 j=nnod,2,-1

*      move lower adjacency list for node j to new location.
       shift = xadj(j+1) - xladj(j+1)
       if(shift .ne. 0) then
        do 323 i=xladj(j+1)-1,xladj(j),-1
  323   adjncy(i+shift) = adjncy(i)
        endif

*      complete the adjacency list for node j.
       l = xadj(j)
       do 321 i=1,j-1
*       search lower adjacency list of node i for node j.
        k = xladj(i) - 1
  322   k = k + 1
        if(k .ge. xladj(i+1)) go to 321
        if(adjncy(k) .ne. j) go to 322

*       node j is adjacent to node i.
        adjncy(l) = i
        l = l + 1
  321  continue

  320 continue

      errc = 0
      return

*     =======================================
*      error return -- insufficient storage.
*     =======================================

  910 errc = 1
      return
      end
      subroutine fnadje(nedg,evtx,  nnod,xadj,adjncy,  xladj)
************************************************************************
*
*   fnadje -- find adjacency structure from edge vertex list.
*
*   this routine finds the adjacency structure of the nodes in a
*   triangular mesh given a list of the edge vertices.  the resulting
*   adjacency list for each node is ordered.
*
*   argument  i/o/m/t  description
*   --------  -------  -----------
*    nedg        i     number of edges in the mesh.
*
*    evtx        i     edge vertex list.  evtx(i,j), i=0,1, are the
*                      two vertices of the jth edge.  evtx(i,j), i=2,3,
*                      are the remaining vertices of the two triangles
*                      sharing the jth edge.  they are ignored here.
*
*    nnod        i     number of nodes in the mesh.
*
*    xadj        o     index array of length nnod+1 containing pointers
*                      to the beginning of each adjacency list in
*                      adjncy.
*
*    adjncy      o     array of length 2*nedg containing the node
*                      adjacency lists.
*
*    xladj       t     temporary array of length nnod+1.
*
************************************************************************
      integer nedg,evtx(0:3,*),nnod,xadj(*),adjncy(*),xladj(*)
      integer i,j,k,l,iedg,jedg,inod,jdeg,shift

*     =======================================
*      i. generate the sorted list of edges.
*     =======================================

      do 100 jedg=1,nedg

*      next edge to be inserted is (i,j).
       i = min( evtx(0,jedg), evtx(1,jedg) )
       j = max( evtx(0,jedg), evtx(1,jedg) )

*      sort on first component.
       iedg = jedg - 1
  110  if(iedg .lt. 1) go to 130
       if(adjncy(2*iedg-1) .le. i) go to 115
       iedg = iedg - 1
       go to 110

  115  if(adjncy(2*iedg-1) .lt. i) go to 130

*      first components are equal.  sort on second.
  120  if(adjncy(2*iedg) .le. j) go to 125
       iedg = iedg - 1
       if(iedg .ge. 1 .and. adjncy(2*iedg-1) .eq. i) go to 120
       go to 130

*      if second components are equal, its a duplicate edge.
  125  if(adjncy(2*iedg) .eq. j) go to 100

*      insert edge (i,j) into list at location iedg+1.
  130  continue

       do 135 k=2*jedg,2*iedg+3,-1
  135  adjncy(k) = adjncy(k-2)

       adjncy(2*iedg+1) = i
       adjncy(2*iedg+2) = j

  100 continue

*     =========================================
*      ii. find the lower adjacency structure.
*     =========================================

*     generate the index array xladj.
      xladj(1) = 1
      inod = 2
      iedg = 0
  212 iedg = iedg + 1
      if(iedg .gt. nedg) go to 210
  211 if(adjncy(2*iedg-1) .lt. inod) go to 212
      xladj(inod) = iedg
      inod = inod + 1
      go to 211

  210 continue

      do 220 j=inod,nnod+1
  220 xladj(j) = nedg + 1

*     generate the lower adjacency lists by compression.
      do 230 i=1,nedg
  230 adjncy(i) = adjncy(2*i)

*     =========================================
*      iii. find the full adjacency structure.
*     =========================================

*     generate the index array xadj.
      xadj(1) = xladj(1)
      xadj(2) = xladj(2)
      do 310 j=2,nnod
*      compute the degree of node j.
       jdeg = xladj(j+1) - xladj(j)
       do 311 k=1,xladj(j)-1
  311  if(adjncy(k) .eq. j) jdeg = jdeg + 1
       xadj(j+1) = xadj(j) + jdeg
  310 continue

*     generate the full adjacency lists.
      do 320 j=nnod,2,-1

*      move lower adjacency list for node j to new location.
       shift = xadj(j+1) - xladj(j+1)
       if(shift .ne. 0) then
        do 323 i=xladj(j+1)-1,xladj(j),-1
  323   adjncy(i+shift) = adjncy(i)
        endif

*      complete the adjacency list for node j.
       l = xadj(j)
       do 321 i=1,j-1
*       search lower adjacency list of node i for node j.
        k = xladj(i) - 1
  322   k = k + 1
        if(k .ge. xladj(i+1)) go to 321
        if(adjncy(k) .ne. j) go to 322

*       node j is adjacent to node i.
        adjncy(l) = i
        l = l + 1
  321  continue

  320 continue

      return
      end
      subroutine filseg(nseg,niseg,x)
************************************************************************
*
*   Generates a refined discretization of an interval by equally
*   spacing points within each segment of a coarse discretization.
*
*     NSEG -- the number of segments.
*
*     NISEG -- an integer vector of length NSEG.  NISEG(i) is the
*     number of points to be equally spaced within the ith segment.
*     It is overwritten with an indexing vector where NISEG(i) points
*     to the location in X where the first point of the ith segment
*     will be stored.
*
*     X -- on input the vector contains the coordinates of the endpoints
*     of the segments.  X(i) and X(i+1) are the left and right endpoints
*     of the ith segment.  It is overwritten with the coordinates of the
*     points of the resulting refined discretization.  The length of X
*     must be large enough to store the coordinates of the interpolated
*     points specified by NISEG as well as the coordinates of the coarse
*     discretization given initially by X.
*
************************************************************************
      double precision x(1), dx
      integer nseg, niseg(1), k, j, n

      do 10 k=2,nseg
   10 niseg(k) = niseg(k) + niseg(k-1)

      do 11 k=nseg+1,2,-1
   11 niseg(k) = niseg(k-1) + k
      niseg(1) = 1

      do 12 k=nseg,1,-1
      n = niseg(k+1) - niseg(k)
      dx = (x(k+1) - x(k))/float(n)
      do 12 j=1,n
   12 x(niseg(k)+j) = x(k) + float(j)*dx

      return
      end
      subroutine refine(nlvl,nt0,nv0,usrt,xrfnt,rfnt,xvert,vert)

      integer nlvl, nt0, nv0, usrt(6,*)
      integer xrfnt(*), rfnt(3,*), xvert(*), vert(2,*)

      integer i, k, n, shft, nt, nv

*     we require that nt0 = 3 mod 4 for the refinement process.  if
*     necessary, we renumber the macro triangles begining with 2, 3,
*     or 4 to achieve this.
      shft = 3 - mod(nt0,4)
      if (shft .gt. 0) then
        do 10 i=nt0,1,-1
          do 11 k=1,3
   11     usrt(k,i+shft) = usrt(k,i)

          do 12 k=4,6
            if (usrt(k,i) .gt. 0) then
              usrt(k,i+shft) = usrt(k,i) + shft

            else
              usrt(k,i+shft) = usrt(k,i)
              endif
   12     continue
   10   continue
        endif

      nt = nt0 + shft
      nv = nv0
      xrfnt(1) = 1 + shft
      xvert(1) = 1
      do 20 n=1,nlvl-1
        xrfnt(n+1) = nt + 1
        xvert(n+1) = nv + 1
        do 20 i=xrfnt(n),xrfnt(n+1)-1
        call divide(i,xrfnt(2)-1,usrt,nt,rfnt,nv,vert)
   20 continue
      xrfnt(nlvl+1) = nt + 1
      xvert(nlvl+1) = nv + 1

      return
      end
      subroutine divide(i,nt0,usrt,nt,rfnt,nv,vert)

      integer i,nt0,usrt(6,1),nt,rfnt(3,1),nv,vert(2,1)
      integer j,k,l,ison,vtx,km1,kp1,vf,kbar,jbar,nbr

      if (i .le. nt0) then
*       ---------------------------------------------
*        triangle to be divided is a macro triangle.
*       ---------------------------------------------
*       set the son field for triangle i and set the
*       father, level, and son fields for its descendent quartet.
        ison = nt + 1
        rfnt(3,i) = ison
        rfnt(1,ison) = i
        rfnt(2,ison) = 2
        do 10 l=0,3
   10   rfnt(3,ison+l) = 0

*       set the fields refering to the vertices of the father of ison.
        do 20 l=1,3
   20   rfnt(2,ison+l) = usrt(l,i)

*       set the fields refering to the vertices of ison.
        do 30 l=1,3
          nbr = usrt(3+l,i)
          if (nbr .lt. 0) then
*           edge l of triangle i is a boundary edge.
*           create a boundary vertex.
            nv = nv + 1
            rfnt(1,ison+l) = nv
            vert(1,nv) = ison+l
            vert(2,nv) = nbr

          else if (rfnt(3,nbr) .eq. 0) then
*           neighboring triangle across edge l is unrefined.
*           create an irregular vertex.
            nv = nv + 1
            rfnt(1,ison+l) = nv
            vert(1,nv) = -(ison+l)
            vert(2,nv) = nbr

          else
*           neighboring triangle is refined.
*           vertex exists; change it to a regular vertex.
            k = 1
            if (usrt(5,nbr) .eq. i) k = 2
            if (usrt(6,nbr) .eq. i) k = 3
            vtx = rfnt(1,rfnt(3,nbr)+k)
            rfnt(1,ison+l) = vtx
            vert(1,vtx) = abs(vert(1,vtx))
            vert(2,vtx) = ison+l
          endif
   30   continue

      else
*       -------------------------------------------------
*        triangle to be divided is not a macro triangle.
*       -------------------------------------------------
*       decompose i.
        k = mod(i,4)
        j = i - k

*       set the son field for triangle i and set the
*       father, level, and son fields for its descendent quartet.
        ison = nt + 1
        rfnt(3,i) = ison
        rfnt(1,ison) = i
        rfnt(2,ison) = rfnt(2,j) + 1
        do 40 l=0,3
   40   rfnt(3,ison+l) = 0

        if (k .eq. 0) then
*         --------------------------------------------------------------
*          triangle to be divided is the central member of the quartet.
*         --------------------------------------------------------------
*         set the fields refering to the vertices of the father of ison.
          do 50 l=1,3
   50     rfnt(2,ison+l) = rfnt(1,j+l)

*         set the fields refering to the vertices of ison.
          do 60 l=1,3
            if (rfnt(3,j+l) .eq. 0) then
*             neighboring triangle across edge l is unrefined.
*             create an irregular vertex.
              nv = nv + 1
              rfnt(1,ison+l) = nv
              vert(1,nv) = -(ison+l)
              vert(2,nv) = j+l

            else
*             neighboring triangle is refined.
*             vertex exists; change it to a regular vertex.
              vtx = rfnt(1,rfnt(3,j+l)+l)
              rfnt(1,ison+l) = vtx
              vert(1,vtx) = abs(vert(1,vtx))
              vert(2,vtx) = ison+l
            endif
   60     continue

        else
          km1 = 1 + mod(k+1,3)
          kp1 = 1 + mod(k,3)

*         set the fields refering to the vertices
*         of the father of ison.
          rfnt(2,ison+k) = rfnt(2,j+k)
          rfnt(2,ison+km1) = rfnt(1,j+kp1)
          rfnt(2,ison+kp1) = rfnt(1,j+km1)

*         set the field refering to vertex k of ison.
          if(rfnt(3,j) .eq. 0) then
*           neighboring triangle across edge k is unrefined.
*           create an irregular vertex.
            nv = nv + 1
            rfnt(1,ison+k) = nv
            vert(1,nv) = -(ison+k)
            vert(2,nv) = j

          else
*           neighboring triangle is refined.
*           vertex exists; change it to a regular vertex.
            vtx = rfnt(1,rfnt(3,j)+k)
            rfnt(1,ison+k) = vtx
            vert(1,vtx) = abs(vert(1,vtx))
            vert(2,vtx) = ison+k
            endif

*         set the field refering to vertex kp1 of ison.
          vf = vert(2,rfnt(1,j+kp1))
          if (vf .lt. 0) then
*           edge kp1 of triangle i is a boundary edge.
*           create a boundary vertex.
            nv = nv + 1
            rfnt(1,ison+kp1) = nv
            vert(1,nv) = ison+kp1
            vert(2,nv) = vf

          else
*           find neighboring triangle across edge kp1 of triangle i.
            kbar = mod(vf,4)
            jbar = vf - kbar
            if (jbar .eq. j) then
              vf = vert(1,rfnt(1,j+kp1))
              kbar = mod(vf,4)
              jbar = vf - kbar
              endif
            nbr = jbar + (1 + mod(kbar,3))

            if (rfnt(3,nbr) .eq. 0) then
*             neighbor is unrefined.  create an irregular vertex.
              nv = nv + 1
              rfnt(1,ison+kp1) = nv
              vert(1,nv) = -(ison+kp1)
              vert(2,nv) = nbr

            else
*             neighbor is refined.
*             vertex exists; change it to a regular vertex.
              vtx = rfnt(1,rfnt(3,nbr)+kbar)
              rfnt(1,ison+kp1) = vtx
              vert(1,vtx) = abs(vert(1,vtx))
              vert(2,vtx) = ison+kp1
            endif
          endif

*         set the field refering to vertex km1 of ison.
          vf = vert(2,rfnt(1,j+km1))
          if (vf .lt. 0) then
*           edge km1 of triangle i is a boundary edge.
*           create a boundary vertex.
            nv = nv + 1
            rfnt(1,ison+km1) = nv
            vert(1,nv) = ison+km1
            vert(2,nv) = vf

          else
*           find neighboring triangle across edge km1 of triangle i.
            kbar = mod(vf,4)
            jbar = vf - kbar
            if (jbar .eq. j) then
              vf = vert(1,rfnt(1,j+km1))
              kbar = mod(vf,4)
              jbar = vf - kbar
              endif
            nbr = jbar + (1 + mod(kbar+1,3))

            if (rfnt(3,nbr) .eq. 0) then
*             neighbor is unrefined.  create an irregular vertex.
              nv = nv + 1
              rfnt(1,ison+km1) = nv
              vert(1,nv) = -(ison+km1)
              vert(2,nv) = nbr

            else
*             neighbor is refined.
*             vertex exists; change it to a regular vertex.
              vtx = rfnt(1,rfnt(3,nbr)+kbar)
              rfnt(1,ison+km1) = vtx
              vert(1,vtx) = abs(vert(1,vtx))
              vert(2,vtx) = ison+km1
            endif
          endif
        endif
      endif

      nt = nt + 4

      return
      end
      subroutine fntvtx(nlvl,xrfnt,rfnt,  ntri,tvtx)

      integer nlvl,xrfnt(*),rfnt(3,*),  ntri,tvtx(0:2,*), j

      ntri = 0

      do 10 j=xrfnt(nlvl),xrfnt(nlvl+1)-1,4
       ntri = ntri + 1
       tvtx(0,ntri) = rfnt(1,j+1)
       tvtx(1,ntri) = rfnt(1,j+2)
       tvtx(2,ntri) = rfnt(1,j+3)

       ntri = ntri + 1
       tvtx(0,ntri) = rfnt(2,j+1)
       tvtx(1,ntri) = rfnt(1,j+3)
       tvtx(2,ntri) = rfnt(1,j+2)

       ntri = ntri + 1
       tvtx(0,ntri) = rfnt(1,j+3)
       tvtx(1,ntri) = rfnt(2,j+2)
       tvtx(2,ntri) = rfnt(1,j+1)

       ntri = ntri + 1
       tvtx(0,ntri) = rfnt(1,j+2)
       tvtx(1,ntri) = rfnt(1,j+1)
       tvtx(2,ntri) = rfnt(2,j+3)
   10 continue

      return
      end
      subroutine fnevtx(nlvl,xrfnt,rfnt,xvert,vert,  nedg,evtx)

      integer nlvl,xrfnt(1),rfnt(3,1),xvert(1),vert(2,1)
      integer nedg,evtx(0:3,1)
      integer i,j,k,km1,kp1

      nedg = 0

      do 10 i=xvert(nlvl),xvert(nlvl+1)-1
       k = mod(vert(1,i),4)
       j = vert(1,i) - k
       km1 = 1 + mod(k+1,3)
       kp1 = 1 + mod(k,3)

       nedg = nedg + 1
       evtx(0,nedg) = rfnt(2,j+kp1)
       evtx(1,nedg) = rfnt(1,j+k)
       evtx(2,nedg) = rfnt(1,j+km1)

       nedg = nedg + 1
       evtx(0,nedg) = rfnt(1,j+k)
       evtx(1,nedg) = rfnt(2,j+km1)
       evtx(2,nedg) = rfnt(1,j+kp1)

       if(vert(2,i).le.0) then
        evtx(3,nedg-1) = vert(2,i)
        evtx(3,nedg)   = vert(2,i)

       else
        k = mod(vert(2,i),4)
        j = vert(2,i) - k
        km1 = 1 + mod(k+1,3)
        kp1 = 1 + mod(k,3)
        evtx(3,nedg-1) = rfnt(1,j+kp1)
        evtx(3,nedg)   = rfnt(1,j+km1)
        endif
   10 continue

      do 20 j=xrfnt(nlvl),xrfnt(nlvl+1)-1,4
      do 20 k=1,3
       km1 = 1 + mod(k+1,3)
       kp1 = 1 + mod(k,3)

       nedg = nedg + 1
       evtx(0,nedg) = rfnt(1,j+kp1)
       evtx(1,nedg) = rfnt(1,j+km1)
       evtx(2,nedg) = rfnt(1,j+k)
       evtx(3,nedg) = rfnt(2,j+k)
   20 continue

      return
      end


      function SYMPS(Z,N)
      PARAMETER (ML=30)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION Z(ML)
      IF(N.EQ.0) THEN
         SYMPS=Z(1)
         RETURN
      END IF
      S2=0.
      S3=0.
      DO 10 I=1,N-1
        S2=S2+Z(I*2+1)
10    CONTINUE
      DO 20 I=1,N
        S3=S3+Z(I*2)
20    CONTINUE
      SYMPS=(Z(1)+Z(2*N+1)+2.*S2+4.*S3)/3.
      END


!**
!* This program, like the demo_ modules, is not an integral component of this software package.
!* It only serves as a demonstration of how this package can be used.
!* This program simply runs the binary labour choice demo.
!**
program ncegm_demo
    use demo_fella11, only:start_demo_fella2011
    use demo_binary_labour_choice, only: start_demo_blc
    implicit none

    ! Uncomment the following line to solve Fella (2011)'s model
    !call start_demo_fella2011

    call start_demo_blc

end program