!===============================================================================
!
! poly.F90  -  routines for polynomials
!
! Distributed? under GNU General Public License version > 3.
!
!-------------------------------------------------------------------------------
! Author: Taylor Haar
! Last modified: 26/09/2016
!-------------------------------------------------------------------------------
# include "defs.h"

!-------------------------------------------------------------------------------
subroutine chebyshev(porder, mu, nu, c, z_k)
  ! Construct a Chebyshev polynomial of order 'porder'

  use module_input
  implicit none

  integer, intent(in)                       :: porder
  REAL, intent(in)                          :: mu, nu
  REAL, intent(out)                         :: c
  COMPLEX, dimension(porder), intent(inout) :: z_k

  REAL     :: theta_k
  COMPLEX  :: comp_c
  integer  :: k

  ! Error checking
  if (porder <= 0) then
     call die("chebyshev(): order must be a positive integer")
  endif

  if (nu > mu) then
     call die("chebyshev(): nu > mu")
  elseif (mu <= 0) then
     call die("chebyshev(): mu <= 0")
  elseif (nu < 0) then
     call die("chebyshev(): nu < 0")
  endif

  ! Construct (real) c in parts, using the complex variable comp_c
  comp_c = ONE/mu

  do k = 1, porder
     theta_k = 2*PI*k/(porder + 1)
     z_k(k) = cmplx(mu * (ONE - cos(theta_k)), &
          - sqrt(mu**2 - nu**2) * sin(theta_k))
     ! Add corresponding factor to c
     comp_c = comp_c / (mu - z_k(k))
  enddo

  ! comp_c should now be real by construction, and hence can be cast
  c = real(comp_c)

end subroutine chebyshev

!-------------------------------------------------------------------------------
subroutine chebyshev_k(porder, mu, nu, c, z_k)
  ! Construct a polynomial of order 'porder + 1',
  ! consisting of a Chebyshev polynomial plus an extra root at 0.
  !
  ! The zero root is placed in the centre such that
  !         z_i = z_(n-i+1)* for all i, where n = porder + 1

  use module_input
  implicit none

  integer, intent(in)                       :: porder
  REAL, intent(in)                          :: mu, nu
  REAL, intent(out)                         :: c
  COMPLEX, dimension(porder+1), intent(inout) :: z_k

  REAL     :: theta_k
  COMPLEX  :: comp_c
  integer  :: k

  ! Error checking
  if (porder <= 0) then
     call die("chebyshev(): order must be a positive integer")
  endif

  if (nu > mu) then
     call die("chebyshev(): nu > mu")
  elseif (mu <= 0) then
     call die("chebyshev(): mu <= 0")
  elseif (nu < 0) then
     call die("chebyshev(): nu < 0")
  endif

  ! Construct (real) c = 1/[mu*P(mu)] in parts, using the complex comp_c
  comp_c = ONE/mu

  ! Do first half of Chebyshev
  do k = 1, porder/2
     theta_k = 2*PI*k/(porder + 1)
     z_k(k) = cmplx(mu * (1 - cos(theta_k)), &
          - sqrt(mu**2 - nu**2) * sin(theta_k))
     ! Add corresponding factor to c
     comp_c = comp_c / (mu - z_k(k))
  enddo

  ! Insert zero root
  z_k(porder/2 + 1) = 0

  ! Do second half of Chebyshev
  do k = porder/2 + 1, porder
     theta_k = 2*PI*k/(porder + 1)
     z_k(k+1) = cmplx(mu * (1 - cos(theta_k)), &
          - sqrt(mu**2 - nu**2) * sin(theta_k))
     ! Add corresponding factor to c
     comp_c = comp_c / (mu - z_k(k+1))
  enddo

  ! comp_c should now be real by construction, and hence can be cast
  c = real(comp_c)

end subroutine chebyshev_k

!-------------------------------------------------------------------------------
subroutine chebyshev_rat(porder1, porder2, mu, nu, c, z_k)
  ! Construct the polynomial P1/P2,
  ! where P1 and P2 are Chebyshev polynomials

  use module_input
  implicit none

  integer, intent(in)                       :: porder1, porder2
  REAL, intent(in)                          :: mu, nu
  REAL, intent(out)                         :: c
  COMPLEX, dimension(porder1 - porder2), intent(inout) :: z_k

  REAL     :: theta_k
  COMPLEX  :: comp_c
  integer  :: j, k

  ! Error checking
  if (porder1 < porder2) then
     call die("chebyshev_rat(): order of P2 > P1")
  else if (mod(porder1 + 1, porder2 + 1) /= 0) then
     call die("chebyshev_rat(): P1 and P2 do not factorize [require mod(n1+1, n2+1) == 0]")
  else if (porder1 == 0 .or. porder2 == 0) then
     call die("chebyshev_rat(): zero polynomial order")
  endif

  if (nu > mu) then
     call die("chebyshev(): nu > mu")
  elseif (mu <= 0) then
     call die("chebyshev(): mu <= 0")
  elseif (nu < 0) then
     call die("chebyshev(): nu < 0")
  endif

  ! Construct (real) c incrementally via the complex variable comp_c
  ! -- poly = P1/P2, so the correction factor is
  ! -- c = mu * P2(mu)/[mu * P1(mu)] = 1/poly(mu)
  comp_c = ONE

  j = 1
  do k = 1, porder1
     ! Only count roots which are in P_1, but not P_2
     if (mod(k, (porder1 + 1)/(porder2 + 1)) /= 0) then
        theta_k = k * 2*PI/(porder1 + 1)
        z_k(j) = cmplx(mu * (1 - cos(theta_k)), &
             - sqrt(mu**2 - nu**2) * sin(theta_k))
        ! Add corresponding factor to c
        comp_c = comp_c / (mu - z_k(j))
        ! Increment root counter
        j = j + 1
     endif
  enddo

  ! comp_c should now be real by construction, and hence can be cast
  c = real(comp_c)

end subroutine chebyshev_rat

!-------------------------------------------------------------------------------
subroutine poly_mult(out, in, pf) ! out = P_pid(K) in
  use module_poly, only: poly
  use module_action_type, only: type_pfermi
  use module_p_interface
  use module_vol
  implicit none

  SPINCOL_FIELD, intent(out) :: out
  SPINCOL_FIELD, intent(in)  :: in
  type(type_pfermi)        :: pf

  P_SPINCOL_FIELD, save :: tmp
  integer :: i
  integer :: mid, pid

  ALLOCATE_SC_FIELD(tmp)

  pid = pf%polyid
  mid = pf%mid1

  call sc_copy(out, in)
  do i = 1, poly(pid)%n
     ! out -> (K - z_i) out
     call wdagw_r8(tmp, out, mid)
     call sc_cxpby(out, tmp(1,1,1), -poly(pid)%z_k(i))
  enddo
  ! Scale by c at the end
  call sc_scale(out, poly(pid)%c)

end subroutine poly_mult

!-------------------------------------------------------------------------------
subroutine poly_hmult(out, in, pf) ! out = Q_pid(K) in
  ! For even polynomials, Q is such that P = Q*Q
  ! For odd polynomials, Q is such that P = (MQ)*(MQ)
  !
  ! Assumes ordering such that z_i = z_j* when i = n - j + 1

  use module_poly, only: poly
  use module_action_type, only: type_pfermi
  use module_p_interface
  use module_vol
  implicit none

  SPINCOL_FIELD, intent(out) :: out
  SPINCOL_FIELD, intent(in)  :: in
  type(type_pfermi)          :: pf

  P_SPINCOL_FIELD, save :: tmp
  integer :: i
  integer :: mid, pid

  ALLOCATE_SC_FIELD(tmp)

  pid = pf%polyid
  mid = pf%mid1

  call sc_copy(out, in)
  do i = 1, poly(pid)%n/2
     ! out -> (K - z_i) out
     call wdagw_r8(tmp, out, mid)
     call sc_cxpby(out, tmp(1,1,1), -poly(pid)%z_k(i))
  enddo
  ! Scale by sqrt(c) at the end
  call sc_scale(out, sqrt(poly(pid)%c))

end subroutine poly_hmult

!-------------------------------------------------------------------------------
subroutine poly_hmult_full(out, in, pf) ! out = Q_pid(K) in
  ! Used for the correction term case, where z_(n/2+1) = 0
  ! Returns MQ, where P = (MQ)*(MQ)
  !
  ! Assumes ordering such that z_i = z_j* when i = n - j + 1

  use module_poly, only: poly
  use module_action_type, only: type_pfermi
  use module_p_interface
  use module_vol
  implicit none

  SPINCOL_FIELD, intent(out) :: out
  SPINCOL_FIELD, intent(in)  :: in
  type(type_pfermi)          :: pf

  P_SPINCOL_FIELD, save :: tmp
  integer :: i
  integer :: mid, pid

  ALLOCATE_SC_FIELD(tmp)

  pid = pf%polyid
  mid = pf%mid1

  call sc_copy(out, in)
  do i = 1, poly(pid)%n/2
     ! out -> (K - z_i) out
     call wdagw_r8(tmp, out, mid)
     call sc_cxpby(out, tmp(1,1,1), -poly(pid)%z_k(i))
  enddo
  ! Add final W multiplication
  call wmul_r8(tmp, out, mid)
  call sc_copy(out, tmp)
  ! Scale by sqrt(c) at the end
  call sc_scale(out, sqrt(poly(pid)%c))

end subroutine poly_hmult_full


!-------------------------------------------------------------------------------
subroutine inv_poly(x, b, pf, calc_sf)
  ! Find x such that P_pid(K) x = b
  !
  ! Uses a partial fraction decomposition of P such
  ! that one can use multi-shift solvers:
  !   1/prod[z - a_i] B = sum[i] {{prod[j/=i] 1/[a_i - a_j]} 1/[z - a_i]} B

  use module_poly, only: poly
  use module_action_type, only: type_pfermi
  use module_field, only: sco
  use module_vol
  ! Imports for solution checking
  use module_cg, only: cg_para
  use module_counter
  use module_function_decl
  implicit none

  COMPLEX, dimension(NDIRAC, NCOL, volh_tot), intent(in) :: b
  COMPLEX, dimension(NDIRAC, NCOL, volh_tot), intent(out) :: x
  integer, intent(in) :: calc_sf
  type(type_pfermi) :: pf

  COMPLEX, dimension(poly(pf%polyid)%n) :: p_i
  integer :: mid, pid, fermi_id
  integer :: iters(poly(pf%polyid)%n), frdo(poly(pf%polyid)%n)
  integer :: i, j

  ! For checking the solution
  COMPLEX, dimension(:,:,:), allocatable :: px
  integer :: ierr
  DOUBLE, dimension(3) :: norm
  logical, save :: headline_check_written = .false.
  character(*), parameter :: key_chk = "%invChk"
  character(*), parameter :: fmt_chk_h = "(1x, 2a, a6, a5, 3a20)"
  character(*), parameter :: fmt_chk_b = "(1x, a8, i6, i5, 2e20.10, i20)"

  ! If checking the solution, allocate extra spincol-field storage
  if (cg_para%check /= 0) then
     allocate(px(NDIRAC, NCOL, volh_tot), STAT = ierr)
     if (ierr /= 0) then
        call stderr2_int("allocation failed", 1, ierr)
        call die("inv_poly: allocation failed px")
     endif
  endif

  ! frdo = 0 -> solve for each possible shift
  frdo = 0
  mid = pf%mid1
  pid = pf%polyid
  fermi_id = pf%pid

  ! First, calculate chi_i such that (K - z_i) chi_i = b
  ! Results are stored at chi_i = sco(1,i)%sco
  call mcg_outer_z(b, mid, poly(pid)%n, frdo, -poly(pid)%z_k, &
       iters, fermi_id, calc_sf)

  ! Next, construct x from (K - z_i)^-1 b via a partial fraction expansion
  ! -- p_i = required coefficients
  do i = 1, poly(pid)%n
     p_i(i) = ONE / poly(pid)%c
     do j = 1, poly(pid)%n
        if (j /= i) then
           p_i(i) = p_i(i) / (poly(pid)%z_k(i) - poly(pid)%z_k(j))
        endif
     enddo
  enddo

  call sc_zero(x)
  do i = 1, poly(pid)%n
     ! x += p_i chi_i
     call sc_caxpy(x, sco(1,i)%sco(1), p_i(i))
  enddo

  if (cg_para%check /= 0) then ! check solution
     call poly_mult(px, x, pf)
     norm(1) = sc_norm2(px - b);
     norm(2) = sc_norm2(b);
     norm(3) = sc_norm2(x);
     call global_sum_vec(3, norm)

     ! Write headers only once
     if (.not. headline_check_written) then
        if (my_pe() == 0) then
           write(UREC, fmt_chk_h) &
               "T", key_chk, "traj", "pid", "Rb", "Rx", "iterations"
        endif
        headline_check_written = .true.
     endif

     ! Write to standard output in BQCD style
     if (my_pe() == 0) then
        write(UREC, fmt_chk_b) &
           key_chk, counter%traj, pid, &
           norm(1)/norm(2), norm(1)/norm(3), maxval(iters)
     endif

     ! Deallocate the extra storage
     deallocate(px, STAT = ierr)
     if (ierr /= 0) then
        call stderr2_int("deallocation failed", 1, ierr)
        call die("inv_poly: deallocation failed px")
     endif

  endif

end subroutine inv_poly

!-------------------------------------------------------------------------------
subroutine inv_hpoly(x, b, pf, calc_sf)
  ! Find x such that Q_pid(K) x = b
  ! where P = Q*Q (even order) or Q*Q(K-z_k(n/2)) (odd order)
  !
  ! The array section (1:n/2) takes advantage of integer
  ! division such that for odd n, i = 1, ..., (n-1)/2,
  ! leaving out the root in the middle.
  !
  ! Uses a partial fraction decomposition of Q such
  ! that one can use multi-shift solvers

  use module_poly, only: poly
  use module_action_type, only: type_pfermi
  use module_field, only: sco
  use module_vol
  ! Imports for solution checking
  use module_cg, only: cg_para
  use module_counter
  use module_function_decl
  implicit none

  COMPLEX, dimension(NDIRAC, NCOL, volh_tot), intent(in) :: b
  COMPLEX, dimension(NDIRAC, NCOL, volh_tot), intent(out) :: x
  integer, intent(in) :: calc_sf
  type(type_pfermi) :: pf

  COMPLEX, dimension(poly(pf%polyid)%n / 2) :: p_i
  integer :: mid, pid, fermi_id
  integer :: iters(poly(pf%polyid)%n/2), frdo(poly(pf%polyid)%n/2)
  integer :: i, j

  ! For checking the solution
  COMPLEX, dimension(:,:,:), allocatable :: px
  integer :: ierr
  DOUBLE, dimension(3) :: norm

  logical, save :: headline_check_written = .false.
  character(*), parameter :: key_chk = "%invhChk"
  character(*), parameter :: fmt_chk_h = "(1x, 2a, a6, a5, 3a20)"
  character(*), parameter :: fmt_chk_b = "(1x, a9, i6, i5, 2e20.10, i20)"

  ! If testing, allocate extra spincol-field storage
  if (cg_para%check /= 0) then
     allocate(px(NDIRAC, NCOL, volh_tot), STAT = ierr)
     if (ierr /= 0) then
        call stderr2_int("allocation failed", 1, ierr)
        call die("inv_poly: allocation failed px")
     endif
  endif

  ! frdo = 0 -> solve for each possible shift
  frdo = 0
  mid = pf%mid1
  pid = pf%polyid
  fermi_id = pf%pid

  ! First, calculate chi_i such that (K - z_i) chi_i = b
  ! Results are stored at chi_i = sco(1,i)%sco(i)
  call mcg_outer_z(b, mid, poly(pid)%n/2, frdo, &
       -poly(pid)%z_k(1:poly(pid)%n/2), iters, fermi_id, calc_sf)

  ! Next, construct x from (K - z_i)^-1 b via a partial fraction expansion
  ! -- p_i = required coefficients
  do i = 1, poly(pid)%n/2
     p_i(i) = ONE / sqrt(poly(pid)%c)
     do j = 1, poly(pid)%n/2
        if (j /= i) then
           p_i(i) = p_i(i) / (poly(pid)%z_k(i) - poly(pid)%z_k(j))
        endif
     enddo
  enddo

  call sc_zero(x)
  do i = 1, poly(pid)%n/2
     ! x += p_i chi_i
     call sc_caxpy(x, sco(1,i)%sco(1), p_i(i))
  enddo

  if (cg_para%check /= 0) then ! check solution
     ! Determine Ax
     call poly_hmult(px, x, pf)

     norm(1) = sc_norm2(px - b);
     norm(2) = sc_norm2(b);
     norm(3) = sc_norm2(x);
     call global_sum_vec(3, norm)

     ! Write headers only once
     if (.not. headline_check_written) then
        if (my_pe() == 0) then
           write(UREC, fmt_chk_h) &
               "T", key_chk, "traj", "pid", "Rb", "Rx", "iterations"
        endif
        headline_check_written = .true.
     endif

     ! Write to standard output in BQCD style
     if (my_pe() == 0) then
        write(UREC, fmt_chk_b) &
           key_chk, counter%traj, pid, &
           norm(1)/norm(2), norm(1)/norm(3), maxval(iters)
     endif

     ! Deallocate the extra storage
     deallocate(px, STAT = ierr)
     if (ierr /= 0) then
        call stderr2_int("deallocation failed", 1, ierr)
        call die("inv_hpoly: deallocation failed px")
     endif

  endif

end subroutine inv_hpoly

!-------------------------------------------------------------------------------
subroutine gen_shifts(b, pf, calc_sf, zero_sh)
  ! Wrapper for 'mcg_outer_z', which calculates the shifted inverses:
  !     sco(1,i)%sco(1) = (K - z_i)^-1 phi

  use module_poly
  use module_action_type, only: type_pfermi
  use module_field, only: sco
  use module_vol
  implicit none

  COMPLEX, dimension(NDIRAC, NCOL, volh_tot), intent(in) :: b
  type(type_pfermi)   :: pf
  integer, intent(in) :: calc_sf
  logical, intent(in) :: zero_sh

  integer :: iters(poly(pf%polyid)%n), frdo(poly(pf%polyid)%n)
  integer :: mid, pid, fermi_id

  pid = pf%polyid
  mid = pf%mid1
  fermi_id = pf%pid

  ! frdo = 0 -> solve for each possible shift
  frdo = 0

  if (poly(pid)%type == P_CORRECTION) then
     ! Skip middle term (= 1/K) in multi-shift solver
     ! In the correction term case, we either use CG_MRE for this term
     ! (zero_sh = .true.) or invert K on P(K)^-1 phi (zero_sh = .false.)
     frdo(poly(pid)%n/2 + 1) = 1
  end if

  ! Calculate chi_i such that (K - z_i) chi_i = b
  ! Results are stored at chi_i = sco(1,i)%sco
  call mcg_outer_z(b, mid, poly(pid)%n, frdo, -poly(pid)%z_k, &
       iters, fermi_id, calc_sf)

  if (zero_sh) then
     ! Perform a better inversion method for zero-shift term
     ! For now, use MRE pre-conditioning
     ! [Do here, as mcg_outer_z sets sco(1,i)%sco to zero]
     TIMING_START(timing_bin_cg_mre_mtmp)
     call cg_mre_mtmp(sco(1, poly(pid)%n/2+1)%sco(1), b, mid, fermi_id, calc_sf)
     TIMING_STOP(timing_bin_cg_mre_mtmp)
  end if

end subroutine gen_shifts

!-------------------------------------------------------------------------------
subroutine inv_poly_shifts(out, n, inv_shift, b, pf)
  ! Use the given inv_shift(i) = (K - z_i)^-1 phi to calculate the inverse
  !
  ! b is the right-hand vector: P(K) out = b

  use module_poly, only: poly
  use module_action_type, only: type_pfermi
  use module_vol
  use module_input
  use typedef, only: sco_field
  ! Imports for solution checking
  use module_cg, only: cg_para
  use module_counter
  use module_function_decl
  implicit none

  type(type_pfermi), intent(in)   :: pf
  COMPLEX, dimension(NDIRAC, NCOL, volh_tot), intent(out) :: out
  COMPLEX, dimension(NDIRAC, NCOL, volh_tot), intent(in) :: b
  integer, intent(in) :: n
  type(sco_field), intent(in) :: inv_shift(n)

  COMPLEX, dimension(poly(pf%polyid)%n) :: p_i
  integer, dimension(poly(pf%polyid)%n) :: conj_id
  integer :: i, j, pid, mid

  ! For checking the solution
  COMPLEX, dimension(:,:,:), allocatable :: r
  integer :: ierr
  DOUBLE, dimension(3) :: norm

  integer, save :: headline_check_written = 0
  character(*), parameter :: key_chk = "%invChk"
  character(*), parameter :: fmt_chk_h = "(1x, 2a, a6, a5, 2a20)"
  character(*), parameter :: fmt_chk_b = "(1x, a8, i6, i5, 2e20.10)"

  ! If testing, allocate extra spincol-field storage
  if (cg_para%check /= 0) then
     allocate(r(NDIRAC, NCOL, volh_tot), STAT = ierr)
     if (ierr /= 0) then
        call stderr2_int("allocation failed", 1, ierr)
        call die("inv_poly_shifts: allocation failed r")
     endif
  endif

  pid = pf%polyid
  mid = pf%mid1

  ! First, construct p(i) = 1/c_n prod(j=1, n, j!=i) [1/(z_i - z_j)]
  do i = 1, n
     if (input%solver_cg_poly == 2 .and. i == n/2 + 1) then
        ! Skip zero shift for two-step method
        cycle
     endif
     p_i(i) = ONE / poly(pid)%c
     do j = 1, n
        if (input%solver_cg_poly == 2 .and. j == n/2 + 1) then
           ! Skip zero shift for two-step method
           cycle
        endif
        if (j /= i) then
           p_i(i) = p_i(i) / (poly(pid)%z_k(i) - poly(pid)%z_k(j))
        endif
     enddo
  enddo

  ! Then P^-1 phi = sum[p(i) * inv_shift(i)]
  call sc_zero(out)
  do i = 1, n
     if (input%solver_cg_poly == 2 .and. i == n/2 + 1) then
        ! Skip zero shift for two-step method
        cycle
     endif

     call sc_caxpy(out, inv_shift(i)%sco(1), p_i(i))
  enddo

  if (cg_para%check /= 0) then ! check solution
     ! Determine Ax
     call poly_mult(r, out, pf)

     norm(1) = sc_norm2(r - b);
     norm(2) = sc_norm2(b);
     norm(3) = sc_norm2(out);
     call global_sum_vec(3, norm)

     ! Write headers only once
     if (headline_check_written == 0) then
        if (my_pe() == 0) then
           write(UREC, fmt_chk_h) &
               "T", key_chk, "traj", "pid", "Rb", "Rx"
        endif
        headline_check_written = 1
     endif

     ! Write to standard output in BQCD style
     if (my_pe() == 0) then
        write(UREC, fmt_chk_b) &
           key_chk, counter%traj, pid, &
           norm(1)/norm(2), norm(1)/norm(3)
     endif

     ! Deallocate the extra storage
     deallocate(r, STAT = ierr)
     if (ierr /= 0) then
        call stderr2_int("deallocation failed", 1, ierr)
        call die("inv_poly_shifts: deallocation failed r")
     endif

  endif

end subroutine inv_poly_shifts

!-------------------------------------------------------------------------------

subroutine read_poly(polyid, file, ioerr)
  ! Read in a polynomial from `file' to module_poly's poly(polyid)
  !
  ! The resultant action term will be phi^\dag P(K) \phi, whereas
  ! required correction terms are constructed via construct_combined_poly()
  !
  ! This is useful for PF-RHMC, where the polynomial filter must
  ! approximate 1/sqrt(Z) and hence doesn't have an easy implementation

  use module_poly, only: poly
  use module_function_decl
  implicit none

  integer :: polyid ! Polynomial ID to read in to
  character(len = 80) :: file ! File to read from
  integer :: ioerr ! IO Error integer
  integer :: i

  ! IMPORTANT: input file format must match up with write_poly()
  DEBUG2S('Start: read_poly()')

  if (my_pe() == 0) then
     write(0, '(a, i2, a, a)') "Reading poly (", polyid, ") from ", trim(file)
  endif

  ! Also, if poly(polyid) already has a polynomial, panic!
  if (poly(polyid)%n > 0) then
     call die("ERROR: Polynomial not empty!!")
  endif

  open(ULIST, file = trim(file), action = "read", status = "old")

  read(ULIST, *, end = 10) poly(polyid)%n
  read(ULIST, *, end = 10) poly(polyid)%c

  ! Allocate storage for roots, then read them
  nullify(poly(polyid)%z_k)
  allocate(poly(polyid)%z_k(poly(polyid)%n))
  do i = 1, poly(polyid)%n
     read(ULIST, *, end = 10) poly(polyid)%z_k(i)
  enddo

  close(ULIST)
  ioerr = 0
  DEBUG2S('End: read_poly()')
  return

10 ioerr = 1 ! Encountered IO error on read
  DEBUG2S('End: read_poly()')
  close(ULIST)


end subroutine read_poly

!===============================================================================
