cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c   Miscellaneous subroutines
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

c
c----------------------------------------------------------------------------
c   This subroutine performs a polynomial interpolation of the data table
c       defined by xa and ya of length(N) at the point x.  Output is y with
c       estimated error dy.  Based on modified Neville's algorithm from
c       Numerical Recipies W. Press et.al.
c     JL 7/22/09
c----------------------------------------------------------------------------
c
      subroutine pol_int(xa,ya,N,x,y,dy)
      use penta_kind_mod
      implicit none
      integer(iknd) :: N
      real(rknd), dimension(N) :: xa, ya
      real(rknd) :: x,y,dy
      !local variables
      real(rknd), dimension(N) :: C,D, diff_vec
      integer(iknd) :: i,ns, m
      real(rknd) :: diff, difftmp, h0, hm, dh, W

      !find the nearest entry
      ns=1
      diff=dabs(x-xa(1))
      do i=1,N
        difftmp=dabs(x-xa(i))
        if ( difftmp .lt. diff ) then
          ns=i
          diff=difftmp
        endif
      enddo

      !initialize C,D tableau
      C=ya
      D=ya

      !initial approximation to y
      y=ya(ns)

      !move through column of tableau and calculate Cmi,Dmi
      ns=ns-1
      do m=1,N-1        !column
        do i=1,N-m      !row
          !components of C,D
          h0=xa(i)-x
          hm=xa(i+m)-x
          dh=h0-hm
          !check for equal xa values, which would give DIV0
          if (dh .eq. 0) then
            write(*,*) 'error in interp, 2 xa are equal'
            stop
          endif
          !define C,D for this column
          W=C(i+1)-D(i)
          C(i)=h0*W/dh
          D(i)=hm*W/dh
        enddo

        !choose which branch to take
        if (2_iknd*ns .lt. N-m) then
          dy=C(ns+1)
        else
          dy=D(ns)
          ns=ns-1
        endif
        y=y+dy
      enddo

      end subroutine pol_int
c
c----------------------------------------------------------------------------
c   This subroutine defines the classical friction coefficients and
c    returns them as the matrix L(species1,species2) where
c    species1,2=[electrons, ion1, ion2, ...] and each L(s1,s2) is a 4x4
c    matrix of friction coefficients: [ls1s2_11, -ls1s2_12; -ls1s2_21, -ls1s2_22].
c     The total matrix lmat is thus num_species*2 square.
c   JL 7/2009
c----------------------------------------------------------------------------
c
      subroutine define_friction_coeffs(masses,charges,v_ths,Temps,dens,
     1 loglambda,num_species,lmat)
      use penta_kind_mod
      use phys_const
      implicit none
      !dummy variables
      integer(iknd) :: num_species
      real(rknd), dimension(num_species) :: masses, charges, v_ths,
     1  Temps, dens
      real(rknd) :: loglambda
      real(rknd), dimension(num_species*2,num_species*2) :: lmat
      !local variables
      integer(iknd) :: ind1, ind2, ispec1, ispec2
      real(rknd), dimension(num_species) :: Mak_p1,
     1  Mak_p2, tau_ak,  Kak, Mak00, Mak10, Mak11, Mak01,
     2  Nak11
      real(rknd) :: tau_coeff, ma, na, charge_a, Ta, vth_a, lab11,
     1  lab12, lab21, lab22, Kba, Mba10, Nab01, Nab00, Nab10, Nab11,
     2  tau_ab, nama
      real(rknd), parameter :: one=1._rknd

      !coefficient on collision times
      tau_coeff=3._rknd*dsqrt(pi)*pi*eps0**2_iknd

      !This nested loop defines the upper half (including the diagonal) of
      ! the large lmat matrix

      !loop over species a (row)
      do ispec1 = 1,num_species
        !assign parameters for species a
        ma=masses(ispec1)
        Ta=Temps(ispec1)
        charge_a=charges(ispec1)
        na=dens(ispec1)
        vth_a=v_ths(ispec1)
        Kak=(v_ths/vth_a)**2_iknd !Normalized thermal velocities

        !calculate moments of collision operator Mij,Nij
        Mak_p1=-one*(one + ma/masses)
        Mak_p2=one + Kak
        Mak00=Mak_p1*Mak_p2**(-1.5_rknd)
        Mak10=1.5_rknd*Mak_p1*Mak_p2**(-2.5_rknd)
        Mak11=-1._rknd*(13._rknd/4._rknd+4._rknd*Kak+
     1    7.5_rknd*Kak**2_iknd)*Mak_p2**(-2.5_rknd)
        Mak01=Mak10
        Nak11=6.75_rknd*(Ta/Temps)*Kak*Mak_p2**(-2.5_rknd)

        !calculate collision times
        tau_ak=tau_coeff*ma**2_iknd*vth_a**3_iknd/(dens*charge_a
     1          **2_iknd*charges**2_iknd*loglambda)

        !loop over second species (columns)
        do ispec2 = ispec1,ispec1+(num_species-ispec1)

          !assign values for this species calculated above
          Nab00=-Mak00(ispec2)
           Nab10=-Mak10(ispec2)
          Nab11= Nak11(ispec2)
          tau_ab=tau_ak(ispec2)

          !calculate remaining values
          Kba=(vth_a/v_ths(ispec2))**2_iknd
          Mba10=-1.5_rknd*(one+masses(ispec2)/ma)*(one+Kba)**(-2.5_rknd)
          Nab01=-Mba10*(Ta*vth_a)/(Temps(ispec2)*v_ths(ispec2))

          nama=na*ma

          !define friction matrix components (4x4 matrices)
          if (ispec1 == ispec2) then  !diagonal
            lab11=nama*( sum(Mak00/tau_ak) + Nab00/tau_ab )
            lab21=nama*( sum(Mak10/tau_ak) + Nab10/tau_ab )
            lab22=nama*( sum(Mak11/tau_ak) + Nab11/tau_ab )
            lab12=nama*( sum(Mak01/tau_ak) + Nab01/tau_ab )
          else                      !off-diagonal
            lab11=nama*( Nab00/tau_ab )
            lab21=nama*( Nab10/tau_ab )
            lab22=nama*( Nab11/tau_ab )
            lab12=nama*( Nab01/tau_ab )
          endif

        !define indices for full matrix and assign components
        ind1=(ispec1 - 1)*2+1
        ind2=(ispec2 - 1)*2+1

        lmat(ind1,ind2)=lab11
        lmat(ind1,ind2+1)=-lab12
        lmat(ind1+1,ind2)=-lab21
        lmat(ind1+1,ind2+1)=lab22

        enddo !species b loop
      enddo  !species a loop

      !define other half of lmat (lower half)
      do ispec1=2,num_species
        do ispec2=1,(ispec1 - 1)

          !define indices for full matrix and assign components from transpose
          ! of upper half
          ind1=(ispec1 - 1)*2+1
          ind2=(ispec2 - 1)*2+1

          lmat(ind1:ind1+1,ind2:ind2+1)
     1        =transpose(lmat(ind2:ind2+1,ind1:ind1+1))
        enddo
      enddo
      end subroutine define_friction_coeffs
c
c----------------------------------------------------------------------------
c   This subroutine calculates the parallel, poloidal and toroidal (in
c     Boozer coordinates) flows.  These are returned in vectors arranged
c     as [electron, I1, I2, ....]
c   JL 7/2009
c----------------------------------------------------------------------------
c
      subroutine calculate_flows(num_species,L1,L2,L3,N1,N2,N3,Xvec,
     1  gamma_e,gamma_i,q_e,q_i,charges,B_uprl,B_qprl,u_theta,u_zeta)
      use penta_kind_mod
      use phys_const
      use pprof_pass
      use vmec_var_pass
      implicit none
      !dummy variables
      integer(iknd) :: num_species
      real(rknd), dimension(2*num_species+1) :: Xvec
      real(rknd), dimension(num_species) :: L1,L2,L3,N1,N2,N3,
     1  B_uprl,B_qprl, u_theta, u_zeta, charges
      real(rknd) :: gamma_e, q_e
      real(rknd), dimension(num_species-1) :: gamma_i, q_i
      !local variables
      real(rknd), dimension(2,2) :: Ntmp, Ntmp_inv, Ltmp
      real(rknd), dimension(2) :: tmp1, tmp2, UandQ
      integer(iknd) :: ispec, tmp_ind
      real(rknd) :: ucoeff

      !calculate species' flows
      do ispec=1,num_species
        !define 4x4 thermal coefficient matrices and inverse of Na
        Ntmp(1,1:2)=[N1(ispec), N2(ispec)]
        Ntmp(2,1:2)=[N2(ispec), N3(ispec)]
        call mat_2by2_inverse(Ntmp,Ntmp_inv)
        Ltmp(1,1:2)=[L1(ispec), L2(ispec)]
        Ltmp(2,1:2)=[L2(ispec), L3(ispec)]

        !define parallel flows for ions and electrons
        tmp_ind=1+2*(ispec-1)
        tmp1=matmul(-Ltmp,Xvec(tmp_ind:tmp_ind+1))
        if (ispec .eq. 1) then    !electrons
          tmp2(1)=tmp1(1)+gamma_e
          tmp2(2)=tmp1(2)+q_e/elem_charge/Te
          UandQ=Bsq*matmul(Ntmp_inv,tmp2)
          B_uprl(ispec)=UandQ(1)
          B_qprl(ispec)=UandQ(2)*5._rknd/2._rknd*elem_charge*Te*ne
        else                      !ions
          tmp2(1)=tmp1(1)+gamma_i(ispec-1)
          tmp2(2)=tmp1(2)+q_i(ispec-1)/elem_charge/Ti(ispec-1)
          UandQ=Bsq*matmul(Ntmp_inv,tmp2)
          B_uprl(ispec)=UandQ(1)
          B_qprl(ispec)=UandQ(2)*5._rknd/2._rknd*elem_charge*
     1      Ti(ispec-1)*ni(ispec-1)
        endif

        !define poloidal and toroidal flows
        ucoeff=4._rknd*pi**2_iknd/vol_p
        u_theta(ispec)=chip*ucoeff*(B_uprl(ispec)/Bsq -
     1    Xvec(tmp_ind)*bzeta/(charges(ispec)*chip*Bsq))
        u_zeta(ispec)=psip*ucoeff*(B_uprl(ispec)/Bsq +
     1    Xvec(tmp_ind)*btheta/(charges(ispec)*psip*Bsq))
      enddo
      end subroutine calculate_flows
c
c----------------------------------------------------------------------------
c   This subroutine calculates the Pfirsh-Schlueter particle and heat
c       fluxes.  These are returned in vectors arranged as [electron, I1, I2, ....]
c   JL 7/2009
c----------------------------------------------------------------------------
c
      subroutine calculate_PS_flux(charges,num_species,lmat,Xvec,U2,
     1  gamma_PS,q_PS)
      use penta_kind_mod
      use phys_const
      implicit none
      !dummy variables
      integer(iknd) :: num_species
      real(rknd) :: U2
      real(rknd),dimension(num_species*2,num_species*2) :: lmat
      real(rknd) :: Xvec(2*num_species+1)
      real(rknd),dimension(num_species) :: gamma_PS, q_PS, charges
      !local variables
      real(rknd) :: lX_sum1,lX_sum2
      integer(iknd) :: ispec1, ispec2, spec1_ind, spec2_ind

      !loop over species and calculate product of friction coefficients
      !  and thermodynamic forces, then PS fluxes
      do ispec1=1,num_species
        spec1_ind=(ispec1-1)*2+1
        !sum product over species
        lX_sum1=0._rknd
        lX_sum2=0._rknd
        do ispec2=1,num_species
          spec2_ind=(ispec2-1)*2+1
          lX_sum1=lX_sum1+sum(lmat(spec1_ind,spec2_ind:spec2_ind+1)*
     1      Xvec(spec2_ind:spec2_ind+1))/charges(ispec2)
          lX_sum2=lX_sum2+sum(lmat(spec1_ind+1,spec2_ind:spec2_ind+1)*
     1      Xvec(spec2_ind:spec2_ind+1)/charges(ispec2))
        enddo
        !calculate fluxes
        gamma_PS(ispec1)=-U2*lX_sum1/charges(ispec1)
        q_PS(ispec1)=-U2*lX_sum2/charges(ispec1)
      enddo
      end subroutine calculate_PS_flux
c
c----------------------------------------------------------------------------
c   This subroutine determines the ambipolar roots as gamma_e=sum(Z*gammai)
c     where the sum is over ion species.  The zeros are found from linear
c     interpolation and using the functions zeroin and rad_flux.
c   The roots (er_roots(:)) and number of roots (num_roots) are passed
c       using the module Er_roots_pass.
c   If an even number of roots is found, the first root only is chosen.
c   JL 7/2009
c----------------------------------------------------------------------------
c
      subroutine find_Er_roots(gamma_e,gamma_i,Er_test_vals,Z_ion,
     1  num_Er_test,nis,qg_all_i)
      use penta_kind_mod
      use Er_fit_pass
      use Er_roots_pass
	use penta_functions_mod
      implicit none
      !dummy variables
      integer(iknd) :: num_Er_test, nis
      real(rknd), dimension(num_Er_test) :: gamma_e, Er_test_vals
      real(rknd),dimension(nis) :: Z_ion(nis)
      !local variables
      integer(iknd) :: ispec, ie, iroot, ind, root_diff
      integer(iknd), allocatable :: I_vr(:)
      real(rknd), dimension(num_Er_test) :: I_vr_tmp, qg_all_i
      real(rknd), dimension(nis,num_Er_test) :: gamma_i
      real(rknd) :: a_test, b_test, tol_Er
      !external functions
!      real(rknd),external :: zeroin,rad_flux

      !sum ion fluxes times charge numbers
      qg_all_i=0._rknd
      do ispec=1,nis
        qg_all_i=qg_all_i+Z_ion(ispec)*gamma_i(ispec,:)
      enddo

      !find where the sign switches
      num_roots=0_iknd
      do ie=1_iknd,num_Er_test-1_iknd
        a_test=dsign(1._rknd,gamma_e(ie)-qg_all_i(ie))
        b_test=dsign(1._rknd,gamma_e(ie+1)-qg_all_i(ie+1))
        if (a_test .ne. b_test) then
          num_roots=num_roots+1_iknd
          I_vr_tmp(num_roots)=ie
        endif
      enddo

      !allocate variables by number of roots
      allocate(I_vr(num_roots))
      allocate(er_roots(num_roots))

      !indices of the roots
      I_vr=I_vr_tmp(1:num_roots)

      !check for zero or even number of roots
      if (num_roots .eq. 0) then
        write(*,*) 'No roots found in search range'
        stop
      elseif ( mod(num_roots,2) .eq. 0) then
        write(*,*) 'Even number of roots found, choosing first only.'
        I_vr=I_vr(1)
      endif

      !find zeros using linear interpolation
      tol_er = 1.e-10_rknd    !tolerance on zeroin function
c     num_pts=2               !number of points used in fit (around root), order of polynomial fit+1

      !allocate fit variables
      allocate(diff_qg(num_pts))
      allocate(Er_fit(num_pts))

      !loop over roots and interpolate to find fine root
      do iroot=1,num_roots
        !this index
        ind=I_vr(iroot)

c          !make sure there are not multiple roots in num_pts range
c       if ((num_roots .gt. 1) .and. (iroot .ne. num_roots)) then
c         root_diff=I_vr(iroot+1)-ind
c         if (root_diff .le. num_pts-1) then
c           write(*,*) 'Distance between roots too small for ',
c     1       'interpolation.  Increase num_Er_pts.'
c           write(*,*) I_vr
c           stop
c         endif
c       endif

        !define difference in flux and Er over fit range
        diff_qg=gamma_e(ind:ind+1)-qg_all_i(ind:ind+1)
        Er_fit=Er_test_vals(ind:ind+1)

        !fit the values over range and use zeroin and rad_flux to find zero
        er_roots(iroot) = zeroin(Er_fit(1),Er_fit(num_pts)
     1    ,rad_flux,tol_er)

      enddo
      !deallocate variables
      deallocate(I_vr,diff_qg,Er_fit)
      end subroutine find_Er_roots
c
c----------------------------------------------------------------------
c   This subroutine calculates the flux and force matrices.  These
c     matrices are those which multiply the vectors of fluxes and
c     forces in the equation A*fluxes=B*forces.  Note that these
c     fluxes are the total fluxes minus the PS fluxes and do not
c     include the bootstrap currents.  The matrix arrangements are
c       the same as lmat above.
c   JL 7/2009
c----------------------------------------------------------------------
c
      subroutine define_flux_force_mat(num_s,lmat,L1,L2,L3,M1,M2,M3,
     1 N1,N2,N3,charges,dens,flux_mat,force_mat)
      use penta_kind_mod
      use phys_const
      use vmec_var_pass
      implicit none
      !dummy variables
      integer(iknd), intent(in) :: num_s
      real(rknd), intent(in), dimension(num_s*2,num_s*2) :: lmat
      real(rknd), intent(in), dimension(num_s) :: L1,L2,L3,M1,M2,M3,N1,
     1 N2,N3,charges, dens
      real(rknd),intent(out),dimension(num_s*2,num_s*2) :: flux_mat
      real(rknd),intent(out),dimension(num_s*2,num_s*2+1) :: force_mat
      !local variables
      integer(iknd) :: ispec1, ispec2, ii1, ii2, ind1, ind2
      real(rknd), dimension(2,2) :: Ntmp, Ntmp_inv, Mtmp, Ltmp, ll_tmp,
     1  tmp1,tmp2,tmp3,tmp4,tmp5

      !define flux and force matrices
      do ispec1=1,num_s   !row (species a)
        do ispec2=1,num_s !column (species b)
          !whole matrix indices
          ind1=(ispec1 - 1)*2+1
          ind2=(ispec2 - 1)*2+1

          !define thermal coefficient matrices
          Ntmp(1,1:2)=[N1(ispec2), N2(ispec2)]
          Ntmp(2,1:2)=[N2(ispec2), N3(ispec2)]
          call mat_2by2_inverse(Ntmp,Ntmp_inv)  !inv(N)
          Mtmp(1,1:2)=[M1(ispec2), M2(ispec2)]
          Mtmp(2,1:2)=[M2(ispec2), M3(ispec2)]
          Ltmp(1,1:2)=[L1(ispec2), L2(ispec2)]
          Ltmp(2,1:2)=[L2(ispec2), L3(ispec2)]
          !define friction coefficient matrices
          ll_tmp(1,1:2)=[lmat(ind1,ind2),lmat(ind1,ind2+1)]
          ll_tmp(2,1:2)=[lmat(ind1+1,ind2),lmat(ind1+1,ind2+1)]

          !perform matrix algebra
          tmp1=matmul(Mtmp,Ntmp_inv)
          tmp2=-matmul(ll_tmp,Ntmp_inv)*Bsq
          tmp3=matmul(Ntmp_inv,Ltmp)
          tmp4=matmul(Mtmp,tmp3)
          tmp5=-matmul(ll_tmp,tmp3)*Bsq

          !matrix assignment (loop over 2x2 matrices)
          if (ispec1==ispec2) then    !diagonal terms
            do ii1=1,2
              do ii2=1,2
                flux_mat(ind1+ii1-1,ind2+ii2-1)=tmp1(ii1,ii2)
     1            +tmp2(ii1,ii2)
                force_mat(ind1+ii1-1,ind2+ii2-1)=tmp4(ii1,ii2)
     1            +tmp5(ii1,ii2)-Ntmp(ii1,ii2)
              enddo
            enddo
            else                      !off diagonal terms
            do ii1=1,2
              do ii2=1,2
                flux_mat(ind1+ii1-1,ind2+ii2-1)=tmp2(ii1,ii2)
                force_mat(ind1+ii1-1,ind2+ii2-1)=tmp5(ii1,ii2)
              enddo
            enddo
          endif !diagonal check

        enddo !column
      enddo  !row

      !add last column of force_mat (XE)
      do ispec1=1,num_s
        ii1=1+(ispec1-1)*2
        ii2=2+(ispec1-1)*2

        force_mat(ii1,num_s*2+1)=dens(ispec1)
     1    *charges(ispec1)*dsqrt(Bsq)
        force_mat(ii2,num_s*2+1)=0._rknd
      enddo
      end subroutine define_flux_force_mat
c
c-----------------------------------------------------------------------
c   This subroutine inverts a 2x2 matrix
c   -mod by JL for speed
c-----------------------------------------------------------------------
c
      subroutine mat_2by2_inverse(a,a_inverse)
      use penta_kind_mod
      implicit none
      real(rknd), dimension(2,2):: a, a_inverse
      real(rknd) :: denom
      denom = a(1,1)*a(2,2) - a(1,2)*a(2,1)
      if(denom .eq. 0.) then
       write(*,'("error: singular matrix")')
       write(*,*) a(1,1),a(1,2)
       write(*,*) a(2,1),a(2,2)
       stop 25
      endif
      a_inverse(1,1) = a(2,2)
      a_inverse(2,2) = a(1,1)
      a_inverse(1,2) = -a(1,2)
      a_inverse(2,1) = -a(2,1)

      a_inverse=a_inverse/denom
      return
      end subroutine mat_2by2_inverse

c
c-----------------------------------------------------------------------
c   -This subroutine calculates the spline fit coefficients to the
c    L,M,N* files and passes them through coeff_var_pass
c-----------------------------------------------------------------------
c
      subroutine fit_coeffs
      use penta_kind_mod
      use coeff_var_pass
      use parameter_pass
      use bspline
      implicit none
      real(rknd), dimension(:) , allocatable :: cmul, efield,
     1 log_efield

      !allocate spline arrays
      allocate(xt_cl(num_cl+kcord),xt_el(num_el+keord))
      allocate(c_spll(num_cl,num_el))
      allocate(xt_cm(num_cm+kcord),xt_em(num_em+keord))
      allocate(c_splm(num_cm,num_em))
      allocate(xt_cn(num_cn+kcord),xt_en(num_en+keord))
      allocate(c_spln(num_cn,num_en))

      !L star

      !if logarithmic interpolation is to be used, use a normalized efield
      if ( log_interp ) then
        allocate(log_efield(num_el),efield(num_el),cmul(num_cl))
        cmul=dlog(cmul_ls)
        log_efield=dlog(efield_ls)
        efield=(log_efield-minval(log_efield))
     1    /(maxval(log_efield)-minval(log_efield))
        eminl=minval(log_efield); emaxl=maxval(log_efield)
        deallocate(log_efield)
      else
        cmul=cmul_ls
        efield=efield_ls
        eminl=minval(efield); emaxl=maxval(efield)
      endif
      cminl=minval(cmul); cmaxl=maxval(cmul)

      call dbsnak(num_el,efield,keord,xt_el)    !compute 'not-a-knot' sequence
      call dbsnak(num_cl,cmul,kcord,xt_cl)      !compute 'not-a-knot' sequence
      call dbs2in(num_cl,cmul,num_el,efield,coef2d_ls, ! fit
     1            num_cl,kcord,keord,xt_cl,xt_el,c_spll)
      deallocate(efield,cmul)

      !M star

      !if logarithmic interpolation is to be used, use a normalized efield
      if ( log_interp ) then
        allocate(log_efield(num_em),efield(num_em),cmul(num_cm))
        cmul=dlog(cmul_ms)
        log_efield=dlog(efield_ms)
        efield=(log_efield-minval(log_efield))
     1         /(maxval(log_efield)-minval(log_efield))
        eminm=minval(log_efield); emaxm=maxval(log_efield)
        deallocate(log_efield)
      else
        cmul=cmul_ms
        efield=efield_ms
        eminm=minval(efield); emaxm=maxval(efield)
      endif
      cminm=minval(cmul); cmaxm=maxval(cmul)

      call dbsnak(num_em,efield,keord,xt_em)    !compute 'not-a-knot' sequence
      call dbsnak(num_cm,cmul,kcord,xt_cm)      !compute 'not-a-knot' sequence
      call dbs2in(num_cm,cmul,num_em,efield,coef2d_ms, ! fit
     1          num_cm,kcord,keord,xt_cm,xt_em,c_splm)
      deallocate(efield,cmul)

      !N star

      !if logarithmic interpolation is to be used
      if ( log_interp ) then
        allocate(log_efield(num_en),efield(num_en),cmul(num_cn))
        cmul=dlog(cmul_ns)
        log_efield=dlog(efield_ns)
        efield=(log_efield-minval(log_efield))
     1         /(maxval(log_efield)-minval(log_efield))
        eminn=minval(log_efield); emaxn=maxval(log_efield)
        deallocate(log_efield)
      else
        cmul=cmul_ns
        efield=efield_ns
        eminn=minval(efield); emaxn=maxval(efield)
      endif
      cminn=minval(cmul); cmaxn=maxval(cmul)

      call dbsnak(num_en,efield,keord,xt_en)    !compute 'not-a-knot' sequence
      call dbsnak(num_cn,cmul,kcord,xt_cn)      !compute 'not-a-knot' sequence
      call dbs2in(num_cn,cmul,num_en,efield,coef2d_ns, ! fit
     1            num_cn,kcord,keord,xt_cn,xt_en,c_spln)
      deallocate(efield,cmul)
      end subroutine fit_coeffs
c
c-----------------------------------------------------------------------
c   This subroutine defines the thermal transport coefficients
c     by convolving the monoenergetic transport coefficients over
c     the local maxwellian using the subroutine energy_conv.  The
c     calculated thermal arrays are arranged as [electron, I1,I2...]
c   JL 7/2009
c-----------------------------------------------------------------------
c
      subroutine define_thermal_mats(Er,nis,v_ths,ns,masses,qs,
     1  loglambda,L1,L2,L3,M1,M2,M3,N1,N2,N3)
      use penta_kind_mod
      use phys_const
      use coeff_var_pass
      use thermal_pass
      use parameter_pass
      implicit none
      !dummy variables
      integer(iknd) :: nis
      real(rknd) :: Er, loglambda
      real(rknd), dimension(nis+1) :: v_ths,ns,qs,L1,L2,L3,
     1  M1,M2,M3,N1,N2,N3,masses, charges
      !local variables
      integer(iknd) :: ispec, mat_ind, I
      real(rknd), dimension(3) :: Lth, Mth,Nth
      integer(iknd),dimension(nis) ::  ikeep
      logical :: logopt

      !define |Er| and loglambda
      abs_Er=dabs(Er)
      loglam=loglambda

      !allocate vectors
      allocate(nb(nis),vtb(nis),qb(nis))

      !loop over species and integrate coefficients
      do ispec = 1,nis+1
        !test species parameters
        ma=masses(ispec)
        qa=qs(ispec)
        na=ns(ispec)
        vta=v_ths(ispec)

        !field species parameters
        !ikeep=(/1:ispec-1, ispec+1:nis+1/)  !all indices not equal to ispec
        ikeep=(/(I,I=1,ispec-1), (I,I=ispec+1,nis+1)/)  !all indices not equal to ispec
        qb=qs(ikeep)
        nb=ns(ikeep)
        vtb=v_ths(ikeep)

        !integrate La
        logopt=.false.      !don't use the log of the coefficient
        call energy_conv(num_cl,num_el,xt_cl,xt_el,c_spll,logopt,Lth,
     1    eminl, emaxl, cminl, cmaxl)
        L1(ispec) = Lth(1);L2(ispec) = Lth(2);L3(ispec) = Lth(3)

        !integrate Ma
        logopt=.true.      !use the log of the coefficient
        call energy_conv(num_cm,num_em,xt_cm,xt_em,c_splm,logopt,Mth,
     1    eminm, emaxm, cminm, cmaxm)
        M1(ispec) = Mth(1);M2(ispec) = Mth(2);M3(ispec) = Mth(3)

        !integrate Na
        logopt=.false.      !don't use the log of the coefficient
        call energy_conv(num_cn,num_en,xt_cn,xt_en,c_spln,logopt,Nth,
     1    eminn, emaxn, cminn, cmaxn)
        N1(ispec) = Nth(1);N2(ispec) = Nth(2);N3(ispec) = Nth(3)

      enddo !species loop

      deallocate(nb,vtb,qb)
      end subroutine define_thermal_mats
c
c-----------------------------------------------------------------------
c   This subroutine convolves the monoenergetic transport coefficients over
c     the local maxwellian.
c   JL 7/2009 modified from Don's DKES_coef
c-----------------------------------------------------------------------
c
      subroutine energy_conv(num_c,num_e,xt_c,xt_e,c_spl,logopt,coeff,
     1 emin,emax,cmin,cmax)
      use penta_kind_mod
      use phys_const
      use intfun_pass
      use thermal_pass
      use parameter_pass
	use penta_functions_mod
      implicit none
      !dummy variables
      integer(iknd), intent(in) :: num_c, num_e
      logical, intent(in) :: logopt
      real(rknd), intent(in) :: xt_c(num_c+kcord), xt_e(num_e+keord)
      real(rknd), intent(in) :: c_spl(num_c+kcord,num_e+keord)
      real(rknd), intent(in) :: emin,emax,cmin,cmax
      real(rknd), intent(out), dimension(3) :: coeff
      !local variables
      integer(iknd) :: err, jind, iK
      integer(iknd), dimension(3) :: jvals
      real(rknd) :: int_flag, nofun, coeff_tmp, dK, Ktest
      !external functions
      !real(rknd), external :: intfun

      allocate(xt_c_pass(num_c+kcord))
      allocate(xt_e_pass(num_e+keord))
      allocate(c_spl_pass(num_c+kcord,num_e+keord))

      !assign variables for passing
      num_c_pass=num_c
      num_e_pass=num_e
      log_coeff=logopt
      xt_c_pass=xt_c
      xt_e_pass=xt_e
      c_spl_pass=c_spl
      emin_pass=emin
      emax_pass=emax
      cmin_pass=cmin
      cmax_pass=cmax

      !loop over j=1,3 and integrate
      jvals=[1_iknd,2_iknd,3_iknd]

      do jind=1,3

        !test j
        jval=jvals(jind)

        !either use quanc8 or rectangular approximation
        if (use_quanc8) then         !quanc8
          call quanc8(intfun, Kmin, Kmax,epsabs, epsrel,
     1               coeff_tmp, err, nofun, int_flag)
          !check for integrator error
          if(abs(int_flag) .gt. 1.e-16_rknd) then
            write(*,*) 'warning: quanc8 error, flag = ',int_flag
            write(*,*) 'May be ok, proceeding'
          endif
        else                       !rectangular
          coeff_tmp=0._rknd
          dK=(Kmax-Kmin)/(num_K_steps-1._rknd)
          do iK=1,num_K_steps
            Ktest=Kmin+(real(iK,rknd)-1._rknd)*dK   !test K
            coeff_tmp=intfun(Ktest)+coeff_tmp       !sum(coeff(K))
          enddo
        coeff_tmp=coeff_tmp*dK                    !sum(coeff(K))*dK
        endif !integrator choice

        coeff(jind)=coeff_tmp*na*2._rknd*vta*ma/dsqrt(pi)
      enddo !jvals

      deallocate(xt_c_pass,xt_e_pass,c_spl_pass)

      end subroutine energy_conv
c
c-----------------------------------------------------------------------
c   This subroutine calculates the perpendicular collision frequency
c       of species a on species b.  The external function derf is
c     used to get the double precision error function, but if this
c     is included in a library the function can be omitted.
c   JL 7/2009
c-----------------------------------------------------------------------
c
      subroutine calc_perp_coll_freq(va,xb,qa,qb,ma,nb,Kb,loglambda
     1  ,vta,Ka,nu_perp_a)
      use penta_kind_mod
      use phys_const
	use penta_functions_mod
      implicit none
      !dummy variables
      real(rknd),intent(in) :: va,xb,qa,qb,ma,nb,Kb,loglambda,vta,Ka
      real(rknd),intent(out) :: nu_perp_a
      !local variables
      real(rknd) :: va3, nu_ab, qa2, qb2, H_ab, one
      !external functions
      !real(rknd), external :: derf

      !constant
      one=1._rknd

      !define powers for speed
      va3=Ka*va*vta**2_iknd
      qa2=qa**2_iknd
      qb2=qb**2_iknd

      !calculate reference collision freq of a on b
      nu_ab=nb*qa2*qb2*loglambda/
     1       (ma**2_iknd*va3*4._rknd*pi*eps0**2_iknd)
      !calculate potential
      H_ab=(one-one/(2._rknd*Kb))*derf(xb) + dexp(-Kb)/(xb*dsqrt(pi))
      !collision frequency
      nu_perp_a=H_ab*nu_ab
      end subroutine calc_perp_coll_freq
c
c-----------------------------------------------------------------------
c   This subroutine forms the thermodynamic force vector.
c   JL 7/2009
c-----------------------------------------------------------------------
c
      subroutine form_Xvec(Er_test,Z_ion,B_Eprl,ns,Xvec)
      use penta_kind_mod
      use phys_const
      use pprof_pass
      use vmec_var_pass
      implicit none
      !dummy variables
      integer(iknd),intent(in) :: ns
      real(rknd),intent(in) :: Er_test, B_Eprl
      real(rknd),intent(in), dimension(ns) :: Z_ion
      real(rknd),intent(out),dimension(ns*2+3) :: Xvec

      !   Species charge sign has been included, elem_charge has been
      !   factored out of Er term because Ta is in eV.

      !electrons
      Xvec(1) = -Te*elem_charge*(dnedr/ne + dTedr/Te + Er_test/Te)
      Xvec(2) = -elem_charge*dTedr
      !ions
      Xvec(3:(ns-1)*2+3:2) = -elem_charge*Ti*
     1  (dnidr/ni + dTidr/Ti - Z_ion*Er_test/Ti)
      Xvec(4:(ns-1)*2+4:2) = -elem_charge*dTidr
      !E_||
      Xvec(ns*2+3)=B_Eprl/dsqrt(Bsq);

      return
      end subroutine form_Xvec
c
c-----------------------------------------------------------------------
c   !Subroutine to find the inverse of a square matrix
c   !Author : Louisda16th a.k.a Ashwith J. Rego
c   !Reference : Algorithm has been well explained in:
c   !http://math.uww.edu/~mcfarlat/inverse.htm
c   !http://www.tutor.ms.unimelb.edu.au/matrix/matrix_inverse.html
c   modified by JL 7/2009 for kind precision
c-----------------------------------------------------------------------
c
      SUBROUTINE FINDInv(matrix, inverse, n, errorflag)
      use penta_kind_mod
      IMPLICIT NONE
      !Declarations
      INTEGER(iknd), INTENT(IN) :: n
      INTEGER(iknd), INTENT(OUT) :: errorflag  !Return error status. -1 for error, 0 for normal
      REAL(rknd), INTENT(IN), DIMENSION(n,n) :: matrix  !Input matrix
      REAL(rknd), INTENT(OUT), DIMENSION(n,n) :: inverse !Inverted matrix

      LOGICAL :: FLAG = .TRUE.
      INTEGER(iknd) :: i, j, k, l
      REAL(rknd) :: m
      REAL(rknd), DIMENSION(n,2*n) :: augmatrix !augmented matrix

    !Augment input matrix with an identity matrix
      DO i = 1, n
        DO j = 1, 2*n
            IF (j <= n ) THEN
                augmatrix(i,j) = matrix(i,j)
            ELSE IF ((i+n) == j) THEN
                augmatrix(i,j) = 1._rknd
            Else
                augmatrix(i,j) = 0._rknd
            ENDIF
        END DO
      END DO

      !Reduce augmented matrix to upper traingular form
      DO k =1, n-1
        IF (augmatrix(k,k) == 0._rknd) THEN
            FLAG = .FALSE.
            DO i = k+1, n
                IF (augmatrix(i,k) /= 0._rknd) THEN
                    DO j = 1,2*n
                        augmatrix(k,j) = augmatrix(k,j)+augmatrix(i,j)
                    END DO
                    FLAG = .TRUE.
                    EXIT
                ENDIF
                IF (FLAG .EQV. .FALSE.) THEN
                    PRINT*, "Matrix is non - invertible"
                    inverse = 0._rknd
                    errorflag = -1_iknd
                    return
                ENDIF
            END DO
        ENDIF
        DO j = k+1, n
            m = augmatrix(j,k)/augmatrix(k,k)
            DO i = k, 2*n
                augmatrix(j,i) = augmatrix(j,i) - m*augmatrix(k,i)
            END DO
        END DO
      END DO

      !Test for invertibility
      DO i = 1, n
        IF (augmatrix(i,i) == 0) THEN
            PRINT*, "Matrix is non - invertible"
            inverse = 0._rknd
            errorflag = -1_iknd
            return
        ENDIF
      END DO

      !Make diagonal elements as 1
      DO i = 1 , n
        m = augmatrix(i,i)
        DO j = i , (2 * n)
               augmatrix(i,j) = (augmatrix(i,j) / m)
        END DO
      END DO

      !Reduced right side half of augmented matrix to identity matrix
      DO k = n-1, 1, -1
        DO i =1, k
        m = augmatrix(i,k+1)
            DO j = k, (2*n)
                augmatrix(i,j) = augmatrix(i,j) -augmatrix(k+1,j) * m
            END DO
        END DO
      END DO

      !store answer
      DO i =1, n
        DO j = 1, n
            inverse(i,j) = augmatrix(i,j+n)
        END DO
      END DO
      errorflag = 0_iknd
      END SUBROUTINE FINDinv


*> \brief \b STZRQF
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download STZRQF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE STZRQF( M, N, A, LDA, TAU, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, LDA, M, N
*       ..
*       .. Array Arguments ..
*       REAL               A( LDA, * ), TAU( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> This routine is deprecated and has been replaced by routine STZRZF.
*>
*> STZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A
*> to upper triangular form by means of orthogonal transformations.
*>
*> The upper trapezoidal matrix A is factored as
*>
*>    A = ( R  0 ) * Z,
*>
*> where Z is an N-by-N orthogonal matrix and R is an M-by-M upper
*> triangular matrix.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.  M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A.  N >= M.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is REAL array, dimension (LDA,N)
*>          On entry, the leading M-by-N upper trapezoidal part of the
*>          array A must contain the matrix to be factorized.
*>          On exit, the leading M-by-M upper triangular part of A
*>          contains the upper triangular matrix R, and elements M+1 to
*>          N of the first M rows of A, with the array TAU, represent the
*>          orthogonal matrix Z as a product of M elementary reflectors.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*>          TAU is REAL array, dimension (M)
*>          The scalar factors of the elementary reflectors.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup realOTHERcomputational
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  The factorization is obtained by Householder's method.  The kth
*>  transformation matrix, Z( k ), which is used to introduce zeros into
*>  the ( m - k + 1 )th row of A, is given in the form
*>
*>     Z( k ) = ( I     0   ),
*>              ( 0  T( k ) )
*>
*>  where
*>
*>     T( k ) = I - tau*u( k )*u( k )**T,   u( k ) = (   1    ),
*>                                                   (   0    )
*>                                                   ( z( k ) )
*>
*>  tau is a scalar and z( k ) is an ( n - m ) element vector.
*>  tau and z( k ) are chosen to annihilate the elements of the kth row
*>  of X.
*>
*>  The scalar tau is returned in the kth element of TAU and the vector
*>  u( k ) in the kth row of A, such that the elements of z( k ) are
*>  in  a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in
*>  the upper triangular part of A.
*>
*>  Z is given by
*>
*>     Z =  Z( 1 ) * Z( 2 ) * ... * Z( m ).
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE STZRQF( M, N, A, LDA, TAU, INFO )
*
*  -- LAPACK computational routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), TAU( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, K, M1
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. External Subroutines ..
      EXTERNAL           SAXPY, SCOPY, SGEMV, SGER, SLARFG, XERBLA
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.M ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'STZRQF', -INFO )
         RETURN
      END IF
*
*     Perform the factorization.
*
      IF( M.EQ.0 )
     $   RETURN
      IF( M.EQ.N ) THEN
         DO 10 I = 1, N
            TAU( I ) = ZERO
   10    CONTINUE
      ELSE
         M1 = MIN( M+1, N )
         DO 20 K = M, 1, -1
*
*           Use a Householder reflection to zero the kth row of A.
*           First set up the reflection.
*
            CALL SLARFG( N-M+1, A( K, K ), A( K, M1 ), LDA, TAU( K ) )
*
            IF( ( TAU( K ).NE.ZERO ) .AND. ( K.GT.1 ) ) THEN
*
*              We now perform the operation  A := A*P( k ).
*
*              Use the first ( k - 1 ) elements of TAU to store  a( k ),
*              where  a( k ) consists of the first ( k - 1 ) elements of
*              the  kth column  of  A.  Also  let  B  denote  the  first
*              ( k - 1 ) rows of the last ( n - m ) columns of A.
*
               CALL SCOPY( K-1, A( 1, K ), 1, TAU, 1 )
*
*              Form   w = a( k ) + B*z( k )  in TAU.
*
               CALL SGEMV( 'No transpose', K-1, N-M, ONE, A( 1, M1 ),
     $                     LDA, A( K, M1 ), LDA, ONE, TAU, 1 )
*
*              Now form  a( k ) := a( k ) - tau*w
*              and       B      := B      - tau*w*z( k )**T.
*
               CALL SAXPY( K-1, -TAU( K ), TAU, 1, A( 1, K ), 1 )
               CALL SGER( K-1, N-M, -TAU( K ), TAU, 1, A( K, M1 ), LDA,
     $                    A( 1, M1 ), LDA )
            END IF
   20    CONTINUE
      END IF
*
      RETURN
*
*     End of STZRQF
*
      END


      FUNCTION   MC_P_INTEG
     &          (delht,nrht,prod,err)

      IMPLICIT REAL*8 (a-h,o-z)

      character*200 error_msg
      complex  * 16 MC_P_INTEG,
     &              prod(nrht),t(6),ta,tb

      ix=nrht-1
      iy=ix/2
      if (ix .ne. 2*iy) then
           write(error_msg,
     &         '(''[MC_P_INTEG]: '',
     &           ''NRHT is not 1 + a power of 2'')')
           call LWPC_ERROR ('Error',error_msg)
      end if

      index=1
      ht=delht*DFLOAT(ix)
      t(1)=0.5d0*(prod(1)+prod(ix+1))*ht

      m=1
      do i=1,7
         if (ix .gt. 1) then
            ht=ht*0.5d0
            iy=ix/2
            ix=iy
            ta=(0.d0,0.d0)
            do j=1,index
               jj=(2*j-1)*ix
               ta=ta+prod(jj+1)
            end do
            ta=ta*ht+t(1)*0.5d0
            index=index*2

            m=i
            if (m .gt. 5) m=5
            power=1.d0
            do j=1,m
               power=power*4.d0
               tb=ta-t(j)
               t(j)=ta
               ta=ta+tb/DCMPLX(power-1.d0,0.d0)
            end do
            t(m+1)=ta
         end if
      end do
      err=CDABS(t(m+1)-t(m))
      MC_P_INTEG=t(m+1)

      RETURN
      END      ! MC_P_INTEG


!******************************************************************************
!*
!*                     Physical and Geometrical Constants
!*
!******************************************************************************

  !==========================================================================
  ! 1) AUTHOR: F. Galliano
  !
  ! 2) HISTORY:
  !    - Created 07/2007
  !    - Add the CGS constants (02/2014)
  !
  ! 3) DESCRIPTION: Defines the main constants
  !==========================================================================

MODULE constants

  USE utilities, ONLY: DP
  IMPLICIT NONE
  PRIVATE

  ! Geometrical constants
  !----------------------
  REAL(DP), PARAMETER, PUBLIC :: pi = 3.141592653589793238_DP
  REAL(DP), PARAMETER, PUBLIC :: twopi = 6.283185307179586476925286766559005_DP
  REAL(DP), PARAMETER, PUBLIC :: oneoversqrt2pi = 0.39894227485064260_DP

  ! MKS constants
  !--------------
  TYPE const_MKS
    ! Fundamental constants
    REAL(DP) :: hplanck = 6.6255E-34_DP ! Planck constant [J.s]
    REAL(DP) :: clight = 2.997E8_DP     ! Speed of light in vacuum [m.s-1]
    REAL(DP) :: grav = 6.67E-11_DP      ! Gravitation const [N.m-2.kg-1]
    REAL(DP) :: kboltz = 1.381E-23_DP   ! Boltzman constant [J.K-1]
    REAL(DP) :: stefan = 5.67E-8_DP     ! Stefan-Boltzman [W.m-2.K-4]
    ! Atomic constants
    REAL(DP) :: u = 1.6605E-27_DP       ! Atomic mass unit [kg]
    REAL(DP) :: mp = 1.6726E-27_DP      ! Proton mass [kg]
    REAL(DP) :: mn = 1.6749E-27_DP      ! Neutron mass [kg]
    REAL(DP) :: me = 9.1096E-31_DP      ! Electron mass [kg]
    REAL(DP) :: mH = 1.6738E-27_DP      ! Hydrogen atom mass [kg]
    REAL(DP) :: a0 = 5.292E-11_DP       ! Bohr radius [m]
    REAL(DP) :: Ryd = 1.097373E7_DP     ! Rydberg constant [m-1]
    REAL(DP) :: cRyd = 3.289842E15_DP   ! c x Rydberg constant [Hz]
    REAL(DP) :: txsec = 6.65E-29_DP     ! Thomson cross section [m2]
    REAL(DP) :: eV = 1.602E-19_DP       ! Electron volt [J.eV-1]
    REAL(DP) :: eV2wave = 1.239E-6_DP   ! Wavelength <=> 1 eV [m]
    REAL(DP) :: eV2nu = 2.418E14_DP     ! Frequency <=> 1 eV [Hz]
    REAL(DP) :: eV2temp = 11604.8_DP    ! Temperature <=> 1 eV [K]
    ! Astronomical constants
    REAL(DP) :: Lsun = 3.845E26_DP      ! Solar luminosity [J.s-1]
    REAL(DP) :: Msun = 1.989E30_DP      ! Solar mass [kg]
    REAL(DP) :: Rsun = 6.596E8_DP       ! Solar radius [m]
    REAL(DP) :: pc = 3.086E16_DP        ! Parsec [m]
    REAL(DP) :: kpc = 3.086E19_DP       ! Kiloparsec [m]
    REAL(DP) :: Mpc = 3.086E22_DP       ! Megaparsec [m]
    REAL(DP) :: year = 3.1536E7_DP      ! Year [s]
    REAL(DP) :: AU = 1.496E11_DP        ! Sun-earth distance [m]
    REAL(DP) :: TCMB = 2.728_DP         ! CMB temperature [K]
    ! Conversion between units
    REAL(DP) :: micron = 1.E-6_DP       ! Micron [m]
    REAL(DP) :: angstrom = 1.E-10_DP    ! Angstrom [m]
    REAL(DP) :: erg = 1.E-7_DP          ! Erg [J]
    REAL(DP) :: mJy = 1.E-29_DP         ! mJy [W.m-2.Hz-1]
    REAL(DP) :: Jy = 1.E-26_DP          ! Jy [W.m-2.Hz-1]
  END TYPE const_MKS
  PUBLIC :: const_MKS
  TYPE(const_MKS), SAVE, PUBLIC :: MKS

  ! CGS constants
  !--------------
  TYPE const_CGS
    ! Fundamental constants
    REAL(DP) :: hplanck = 6.6255E-27_DP ! Planck constant [erg.s]
    REAL(DP) :: clight = 2.997E10_DP    ! Speed of light in vacuum [cm.s-1]
    REAL(DP) :: grav = 6.67E-8_DP       ! Gravitation const [dynes.cm-2.g-1]
    REAL(DP) :: kboltz = 1.381E-16_DP   ! Boltzman constant [erg.K-1]
    REAL(DP) :: stefan = 5.67E-5_DP     ! Stefan-Boltzman [erg.s-1.cm-2.K-4]
    ! Atomic constants
    REAL(DP) :: u = 1.6605E-24_DP       ! Atomic mass unit [g]
    REAL(DP) :: mp = 1.6726E-24_DP      ! Proton mass [g]
    REAL(DP) :: mn = 1.6749E-24_DP      ! Neutron mass [g]
    REAL(DP) :: me = 9.1096E-28_DP      ! Electron mass [g]
    REAL(DP) :: mH = 1.6738E-24_DP      ! Hydrogen atom mass [g]
    REAL(DP) :: a0 = 5.292E-9_DP        ! Bohr radius [cm]
    REAL(DP) :: Ryd = 1.097373E5_DP     ! Rydberg constant [cm-1]
    REAL(DP) :: cRyd = 3.289842E15_DP   ! c x Rydberg constant [Hz]
    REAL(DP) :: txsec = 6.65E-25_DP     ! Thomson cross section [cm2]
    REAL(DP) :: eV = 1.602E-12_DP       ! Electron volt [erg.eV-1]
    REAL(DP) :: eV2wave = 1.239E-4_DP   ! Wavelength <=> 1 eV [cm]
    REAL(DP) :: eV2nu = 2.418E14_DP     ! Frequency <=> 1 eV [Hz]
    REAL(DP) :: eV2temp = 11604.8_DP    ! Temperature <=> 1 eV [K]
    ! Astronomical constants
    REAL(DP) :: Lsun = 3.845E33_DP      ! Solar luminosity [erg.s-1]
    REAL(DP) :: Msun = 1.989E33_DP      ! Solar mass [g]
    REAL(DP) :: Rsun = 6.596E10_DP      ! Solar radius [cm]
    REAL(DP) :: pc = 3.086E18_DP        ! Parsec [cm]
    REAL(DP) :: kpc = 3.086E21_DP       ! Kiloparsec [cm]
    REAL(DP) :: Mpc = 3.086E24_DP       ! Megaparsec [cm]
    REAL(DP) :: year = 3.1536E7_DP      ! Year [s]
    REAL(DP) :: AU = 1.496E13_DP        ! Sun-earth distance [cm]
    REAL(DP) :: TCMB = 2.728_DP         ! CMB temperature [K]
    ! Conversion between units
    REAL(DP) :: micron = 1.E-4_DP       ! Micron [cm]
    REAL(DP) :: angstrom = 1.E-8_DP     ! Angstrom [cm]
    REAL(DP) :: joule = 1.E7_DP         ! J [erg]
    REAL(DP) :: mJy = 1.E-26_DP         ! mJy [erg.s-1.cm-2.Hz-1]
    REAL(DP) :: Jy = 1.E-23_DP          ! Jy [erg.s-1.cm-2.Hz-1]
  END TYPE const_CGS
  PUBLIC :: const_CGS
  TYPE(const_CGS), SAVE, PUBLIC :: CGS

  ! Atomic Quantities
  !------------------
  TYPE const_atom
    ! H
    CHARACTER(15) :: H_name = "Hydrogen"
    INTEGER :: H_number = 1
    REAL(DP) :: H_weight = 1.0079_DP
    ! He
    CHARACTER(15) :: He_name = "Helium"
    INTEGER :: He_number = 2
    REAL(DP) :: He_weight = 4.002602_DP
    ! Li
    CHARACTER(15) :: Li_name = "Lithium"
    INTEGER :: Li_number = 3
    REAL(DP) :: Li_weight = 6.941_DP
    ! Be
    CHARACTER(15) :: Be_name = "Beryllium"
    INTEGER :: Be_number = 4
    REAL(DP) :: Be_weight = 9.012182_DP
    ! B
    CHARACTER(15) :: B_name = "Boron"
    INTEGER :: B_number = 5
    REAL(DP) :: B_weight = 10.811_DP
    ! C
    CHARACTER(15) :: C_name = "Carbon"
    INTEGER :: C_number = 6
    REAL(DP) :: C_weight = 12.0107_DP
    ! N
    CHARACTER(15) :: N_name = "Nitrogen"
    INTEGER :: N_number = 7
    REAL(DP) :: N_weight = 14.0067_DP
    ! O
    CHARACTER(15) :: O_name = "Oxygen"
    INTEGER :: O_number = 8
    REAL(DP) :: O_weight = 15.9994_DP
    ! F
    CHARACTER(15) :: F_name = "Fluorine"
    INTEGER :: F_number = 9
    REAL(DP) :: F_weight = 18.998403_DP
    ! Ne
    CHARACTER(15) :: Ne_name = "Neon"
    INTEGER :: Ne_number = 10
    REAL(DP) :: Ne_weight = 20.179_DP
    ! Na
    CHARACTER(15) :: Na_name = "Sodium"
    INTEGER :: Na_number = 11
    REAL(DP) :: Na_weight = 22.98977_DP
    ! Mg
    CHARACTER(15) :: Mg_name = "Magnesium"
    INTEGER :: Mg_number = 12
    REAL(DP) :: Mg_weight = 24.305_DP
    ! Al
    CHARACTER(15) :: Al_name = "Aluminium"
    INTEGER :: Al_number = 13
    REAL(DP) :: Al_weight = 26.98154_DP
    ! Si
    CHARACTER(15) :: Si_name = "Silicon"
    INTEGER :: Si_number = 14
    REAL(DP) :: Si_weight = 28.086_DP
    ! P
    CHARACTER(15) :: P_name = "Phosphorous"
    INTEGER :: P_number = 15
    REAL(DP) :: P_weight = 30.97376_DP
    ! S
    CHARACTER(15) :: S_name = "Hydrogen"
    INTEGER :: S_number = 16
    REAL(DP) :: S_weight = 32.06_DP
    ! Cl
    CHARACTER(15) :: Cl_name = "Chlorine"
    INTEGER :: Cl_number = 17
    REAL(DP) :: Cl_weight = 35.453_DP
    ! Ar
    CHARACTER(15) :: Ar_name = "Argon"
    INTEGER :: Ar_number = 18
    REAL(DP) :: Ar_weight = 39.948_DP
    ! K
    CHARACTER(15) :: K_name = "Potassium"
    INTEGER :: K_number = 19
    REAL(DP) :: K_weight = 39.098_DP
    ! Ca
    CHARACTER(15) :: Ca_name = "Calcium"
    INTEGER :: Ca_number = 20
    REAL(DP) :: Ca_weight = 40.08_DP
    ! Sc
    CHARACTER(15) :: Sc_name = "Scandium"
    INTEGER :: Sc_number = 21
    REAL(DP) :: Sc_weight = 44.9559_DP
    ! Ti
    CHARACTER(15) :: Ti_name = "Titanium"
    INTEGER :: Ti_number = 22
    REAL(DP) :: Ti_weight = 47.90_DP
    ! V
    CHARACTER(15) :: V_name = "Vanadium"
    INTEGER :: V_number = 23
    REAL(DP) :: V_weight = 50.9414_DP
    ! Cr
    CHARACTER(15) :: Cr_name = "Chromium"
    INTEGER :: Cr_number = 24
    REAL(DP) :: Cr_weight = 51.996_DP
    ! Mn
    CHARACTER(15) :: Mn_name = "Manganese"
    INTEGER :: Mn_number = 25
    REAL(DP) :: Mn_weight = 54.9380_DP
    ! Fe
    CHARACTER(15) :: Fe_name = "Iron"
    INTEGER :: Fe_number = 26
    REAL(DP) :: Fe_weight = 55.847_DP
    ! Co
    CHARACTER(15) :: Co_name = "Cobalt"
    INTEGER :: Co_number = 27
    REAL(DP) :: Co_weight = 58.9332_DP
    ! Ni
    CHARACTER(15) :: Ni_name = "Nickel"
    INTEGER :: Ni_number = 28
    REAL(DP) :: Ni_weight = 58.70_DP
    ! Cu
    CHARACTER(15) :: Cu_name = "Copper"
    INTEGER :: Cu_number = 29
    REAL(DP) :: Cu_weight = 63.546_DP
    ! Zn
    CHARACTER(15) :: Zn_name = "Zinc"
    INTEGER :: Zn_number = 30
    REAL(DP) :: Zn_weight = 65.38_DP
    ! Ga
    CHARACTER(15) :: Ga_name = "Gallium"
    INTEGER :: Ga_number = 31
    REAL(DP) :: Ga_weight = 69.72_DP
    ! Ge
    CHARACTER(15) :: Ge_name = "Germanium"
    INTEGER :: Ge_number = 32
    REAL(DP) :: Ge_weight = 72.59_DP
    ! As
    CHARACTER(15) :: As_name = "Arsenic"
    INTEGER :: As_number = 33
    REAL(DP) :: As_weight = 74.9216_DP
    ! Se
    CHARACTER(15) :: Se_name = "Selenium"
    INTEGER :: Se_number = 34
    REAL(DP) :: Se_weight = 78.96_DP
    ! Br
    CHARACTER(15) :: Br_name = "Bromine"
    INTEGER :: Br_number = 35
    REAL(DP) :: Br_weight = 79.904_DP
    ! Kr
    CHARACTER(15) :: Kr_name = "Krypton"
    INTEGER :: Kr_number = 36
    REAL(DP) :: Kr_weight = 83.80_DP
  END TYPE const_atom
  PUBLIC :: const_atom
  TYPE(const_atom), SAVE, PUBLIC :: atom

  ! Elemental abundances
  !---------------------
  ! From Asplund et al. (2009)
  TYPE const_abund
    REAL(DP) :: Xsun = 0.7381_DP ! M(H)/M(all)
    REAL(DP) :: Ysun = 0.2485_DP ! M(H)/M(all)
    REAL(DP) :: Zsun = 0.0134_DP ! M(H)/M(all)
  END TYPE const_abund
  PUBLIC :: const_abund
  TYPE(const_abund), SAVE, PUBLIC :: abund

END MODULE constants


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!

submodule(centered_helmholtz_solvers) centered_axisymmetric_spherical_solver

! Parameters confined to the submodule
integer(ip), parameter :: SIZE_OF_WORKSPACE_INDICES = 10

contains

    ! SUBROUTINE hwscsp(intl, ts, tf, m, mbdcnd, bdts, bdtf, rs, rf, n, nbdcnd, &
    !                       bdrs, bdrf, elmbda, f, idimf, pertrb, ierror, w)
    !
    !
    ! DIMENSION OF           bdts(n+1),  bdtf(n+1), bdrs(m+1), bdrf(m+1),
    ! ARGUMENTS              f(idimf, n+1)
    !
    !
    ! PURPOSE                Solves a finite difference approximation
    !                        to the modified helmholtz equation in
    !                        spherical coordinates assuming axisymmetry
    !                        (no dependence on longitude).  the equation
    !                        is
    !
    !                          (1/r**2)(d/dr)((r**2)(d/dr)u) +
    !
    !                          (1/(r**2)sin(theta))(d/dtheta)
    !
    !                          (sin(theta)(d/dtheta)u) +
    !
    !                          (lambda/(rsin(theta))**2)u = f(theta, r).
    !
    !                        this two dimensional modified helmholtz
    !                        equation results from the fourier transform
    !                        of the three dimensional poisson equation.
    !
    ! USAGE                  call hwscsp(intl, ts, tf, m, mbdcnd, bdts, bdtf,
    !                                    rs, rf, n, nbdcnd, bdrs, bdrf, elmbda,
    !                                    f, idimf, pertrb, ierror, w)
    !
    ! ARGUMENTS
    ! ON INPUT               intl
    !                          = 0  on initial entry to hwscsp or if any
    !                               of the arguments rs, rf, n, nbdcnd
    !                               are changed from a previous call.
    !                          = 1  if rs, rf, n, nbdcnd are all unchanged
    !                               from previous call to hwscsp.
    !
    !                          note:
    !                          a call with intl=0 takes approximately
    !                          1.5 times as much time as a call with
    !                          intl = 1  .  once a call with intl = 0
    !                          has been made then subsequent solutions
    !                          corresponding to different f, bdts, bdtf,
    !                          bdrs, bdrf can be obtained faster with
    !                          intl = 1 since initialization is not
    !                          repeated.
    !
    !                        ts, tf
    !                          the range of theta (colatitude), i.e.,
    !                          ts <= theta <= tf. ts must be less
    !                          than tf.  ts and tf are in radians. a ts of
    !                          zero corresponds to the north pole and a
    !                          tf of pi corresponds to the south pole.
    !
    !                          **** important ****
    !
    !                          if tf is equal to pi then it must be
    !                          computed using the statement
    !                          tf = pi_mach(dum). this insures that tf
    !                          in the user's program is equal to pi in
    !                          this program which permits several tests
    !                          of the  input parameters that otherwise
    !                          would not be possible.
    !
    !                        m
    !                          the number of panels into which the
    !                          interval (ts, tf) is subdivided.
    !                          hence, there will be m+1 grid points
    !                          in the theta-direction given by
    !                          theta(k) = (i-1)dtheta+ts for
    !                          i = 1, 2, ..., m+1, where dtheta = (tf-ts)/m
    !                          is the panel width.
    !
    !                        mbdcnd
    !                          indicates the type of boundary condition
    !                          at theta = ts and  theta = tf.
    !
    !                          = 1  if the solution is specified at
    !                               theta = ts and theta = tf.
    !                          = 2  if the solution is specified at
    !                               theta = ts and the derivative of the
    !                               solution with respect to theta is
    !                               specified at theta = tf
    !                               (see note 2 below).
    !                          = 3  if the derivative of the solution
    !                               with respect to theta is specified
    !                               at theta = ts and theta = tf
    !                               (see notes 1, 2 below).
    !                          = 4  if the derivative of the solution
    !                               with respect to theta is specified
    !                               at theta = ts (see note 1 below) and
    !                               solution is specified at theta = tf.
    !                          = 5  if the solution is unspecified at
    !                               theta = ts = 0 and the solution is
    !                                specified at theta = tf.
    !                          = 6  if the solution is unspecified at
    !                               theta = ts = 0 and the derivative
    !                               of the solution with respect to theta
    !                               is specified at theta = tf
    !                               (see note 2 below).
    !                          = 7  if the solution is specified at
    !                               theta = ts and the solution is
    !                                unspecified at theta = tf = pi.
    !                          = 8  if the derivative of the solution
    !                               with respect to theta is specified
    !                               at theta = ts (see note 1 below)
    !                               and the solution is unspecified at
    !                               theta = tf = pi.
    !                          = 9  if the solution is unspecified at
    !                               theta = ts = 0 and theta = tf = pi.
    !
    !                          note 1:
    !                          if ts = 0, do not use mbdcnd = 3, 4, or 8,
    !                          but instead use mbdcnd = 5, 6, or 9  .
    !
    !                          note 2:
    !                          if tf = pi, do not use mbdcnd = 2, 3, or 6,
    !                          but instead use mbdcnd = 7, 8, or 9  .
    !
    !                        bdts
    !                          a one-dimensional array of length n+1 that
    !                          specifies the values of the derivative of
    !                          the solution with respect to theta at
    !                          theta = ts.  when mbdcnd = 3, 4, or 8,
    !
    !                            bdts(j) = (d/dtheta)u(ts, r(j)),
    !                            j = 1, 2, ..., n+1  .
    !
    !                          when mbdcnd has any other value, bdts is
    !                          a dummy variable.
    !
    !                        bdtf
    !                          a one-dimensional array of length n+1 that
    !                          specifies the values of the derivative of
    !                          the solution with respect to theta at
    !                          theta = tf.  when mbdcnd = 2, 3, or 6,
    !
    !                          bdtf(j) = (d/dtheta)u(tf, r(j)),
    !                          j = 1, 2, ..., n+1  .
    !
    !                          when mbdcnd has any other value, bdtf is
    !                          a dummy variable.
    !
    !                        rs, rf
    !                          the range of r, i.e., rs <= r < rf.
    !                          rs must be less than rf.  rs must be
    !                          non-negative.
    !
    !                        n
    !                          the number of panels into which the
    !                          interval (rs, rf) is subdivided.
    !                          hence, there will be n+1 grid points in the
    !                          r-direction given by r(j) = (j-1)dr+rs
    !                          for j = 1, 2, ..., n+1, where dr = (rf-rs)/n
    !                          is the panel width.
    !                          n must be greater than 2
    !
    !                        nbdcnd
    !                          indicates the type of boundary condition
    !                          at r = rs and r = rf.
    !
    !                          = 1  if the solution is specified at
    !                               r = rs and r = rf.
    !                          = 2  if the solution is specified at
    !                               r = rs and the derivative
    !                               of the solution with respect to r
    !                               is specified at r = rf.
    !                          = 3  if the derivative of the solution
    !                               with respect to r is specified at
    !                               r = rs and r = rf.
    !                          = 4  if the derivative of the solution
    !                               with respect to r is specified at
    !                               rs and the solution is specified at
    !                               r = rf.
    !                          = 5  if the solution is unspecified at
    !                               r = rs = 0 (see note below)  and the
    !                               solution is specified at r = rf.
    !                          = 6  if the solution is unspecified at
    !                               r = rs = 0 (see note below) and the
    !                               derivative of the solution with
    !                               respect to r is specified at r = rf.
    !
    !                          note:
    !                          nbdcnd = 5 or 6 cannot be used with
    !                          mbdcnd = 1, 2, 4, 5, or 7.  the former
    !                          indicates that the solution is unspecified
    !                          at r = 0, the latter indicates that the
    !                          solution is specified).
    !                          use instead   nbdcnd = 1 or 2  .
    !
    !                        bdrs
    !                          a one-dimensional array of length m+1 that
    !                          specifies the values of the derivative of
    !                          the solution with respect to r at r = rs.
    !
    !                          when nbdcnd = 3 or 4,
    !                            bdrs(i) = (d/dr)u(theta(i), rs),
    !                            i = 1, 2, ..., m+1  .
    !
    !                          when nbdcnd has any other value, bdrs is
    !                          a dummy variable.
    !
    !                        bdrf
    !                          a one-dimensional array of length m+1
    !                          that specifies the values of the
    !                          derivative of the solution with respect
    !                          to r at r = rf.
    !
    !                          when nbdcnd = 2, 3, or 6,
    !                            bdrf(i) = (d/dr)u(theta(i), rf),
    !                            i = 1, 2, ..., m+1  .
    !
    !                          when nbdcnd has any other value, bdrf is
    !                          a dummy variable.
    !
    !                        elmbda
    !                          the constant lambda in the helmholtz
    !                          equation.  if lambda > 0, a solution
    !                          may not exist.  however, hwscsp will
    !                          attempt to find a solution.  if nbdcnd = 5
    !                          or 6 or  mbdcnd = 5, 6, 7, 8, or 9, elmbda
    !                          must be zero.
    !
    !                        f
    !                          a two-dimensional array, of dimension at
    !                          least (m+1)*(n+1), specifying values of the
    !                          right side of the helmholtz equation and
    !                          boundary values (if any).
    !
    !                          on the interior, f is defined as follows:
    !                          for i = 2, 3, ..., m and j = 2, 3, ..., n
    !                          f(i, j) = f(theta(i), r(j)).
    !
    !                          on the boundaries, f is defined as follows:
    !                          for j=1, 2, ..., n+1,  i=1, 2, ..., m+1,
    !
    !                          mbdcnd   f(1, j)            f(m+1, j)
    !                          ------   ----------        ----------
    !
    !                            1      u(ts, r(j))        u(tf, r(j))
    !                            2      u(ts, r(j))        f(tf, r(j))
    !                            3      f(ts, r(j))        f(tf, r(j))
    !                            4      f(ts, r(j))        u(tf, r(j))
    !                            5      f(0, r(j))         u(tf, r(j))
    !                            6      f(0, r(j))         f(tf, r(j))
    !                            7      u(ts, r(j))        f(pi, r(j))
    !                            8      f(ts, r(j))        f(pi, r(j))
    !                            9      f(0, r(j))         f(pi, r(j))
    !
    !                            nbdcnd   f(i, 1)            f(i, n+1)
    !                            ------   --------------    --------------
    !
    !                              1      u(theta(i), rs)    u(theta(i), rf)
    !                              2      u(theta(i), rs)    f(theta(i), rf)
    !                              3      f(theta(i), rs)    f(theta(i), rf)
    !                              4      f(theta(i), rs)    u(theta(i), rf)
    !                              5      f(ts, 0)           u(theta(i), rf)
    !                              6      f(ts, 0)           f(theta(i), rf)
    !
    !                          note:
    !                          if the table calls for both the solution
    !                          u and the right side f at a corner then
    !                          the solution must be specified.
    !
    !                        idimf
    !                          the row (or first) dimension of the array
    !                          f as it appears in the program calling
    !                          hwscsp.  this parameter is used to specify
    !                          the variable dimension of f.  idimf must
    !                          be at least m+1  .
    !
    !                        w
    !                          A FishpackWorkspace derived data type variable
    !                          that must be declared by the user.  the first
    !                          two declarative statements in the user program
    !                          calling sepeli must be:
    !
    !                               use type_fishpackworkspace
    !                               type(fishpackworkspace) :: w
    !
    !                          The first statement makes the fishpack module
    !                          defined in the file "type_FishpackWorkspace.f90" available to the
    !                          user program calling hwscsp. The second statement
    !                          declares a derived type variable (defined in
    !                          the module "type_FishpackWorkspace.f90") which is used internally
    !                          in hwscsp to dynamically allocate real and complex
    !                          workspace used in solution.  an error flag
    !                          (ierror = 20) is set if the required workspace
    !                          allocation fails (for example if n, m are too large)
    !                          real and complex values are set in the components
    !                          of w on a initial (intl=0) call to hwscsp.  these
    !                          must be preserved on non-initial calls (intl=1)
    !                          to hwscsp.  this eliminates redundant calculations
    !                          and saves compute time.
    !               ****       IMPORTANT!  The user program calling hwscsp should
    !                          include the statement:
    !
    !                               call w%destroy()
    !
    !                          after the final approximation is generated by
    !                          hwscsp.  The will deallocate the real and complex
    !                          workspace of W.  Failure to include this statement
    !                          could result in serious memory leakage.
    !
    !
    ! ON OUTPUT              f
    !                          contains the solution u(i, j) of the finite
    !                          difference approximation for the grid point
    !                          (theta(i), r(j)),  i = 1, 2, ..., m+1,
    !                                            j = 1, 2, ..., n+1  .
    !
    !                        pertrb
    !                          if a combination of periodic or derivative
    !                          boundary conditions is specified for a
    !                          poisson equation (lambda = 0), a solution
    !                          may not exist.  pertrb is a constant,
    !                          calculated and subtracted from f, which
    !                          ensures that a solution exists.  hwscsp
    !                          then computes this solution, which is a
    !                          least squares solution to the original
    !                          approximation. this solution is not unique
    !                          and is unnormalized. the value of pertrb
    !                          should be small compared to the right side
    !                          f. otherwise , a solution is obtained to
    !                          an essentially different problem. this
    !                          comparison should always be made to insure
    !                          that a meaningful solution has been obtained.
    !
    !                        ierror
    !                          an error flag that indicates invalid input
    !                          parameters.  except for numbers 0 and 10,
    !                          a solution is not attempted.
    !
    !                          = 1  ts<0. or tf>pi
    !                          = 2  ts>=tf
    !                          = 3  m<5
    !                          = 4  mbdcnd<1 or mbdcnd>9
    !                          = 5  rs<0
    !                          = 6  rs>=rf
    !                          = 7  n<5
    !                          = 8  nbdcnd<1 or nbdcnd>6
    !                          = 9  elmbda>0
    !                          = 10 idimf<m+1
    !                          = 11 elmbda/=0 and mbdcnd>=5
    !                          = 12 elmbda/=0 and nbdcnd equals 5 or 6
    !                          = 13 mbdcnd equals 5, 6 or 9 and ts/=0
    !                          = 14 mbdcnd>=7 and tf/=pi
    !                          = 15 ts.eq.0 and mbdcnd equals 3, 4 or 8
    !                          = 16 tf.eq.pi and mbdcnd equals 2, 3 or 6
    !                          = 17 nbdcnd>=5 and rs/=0
    !                          = 18 nbdcnd>=5 and mbdcnd equals 1, 2, 4, 5 or
    !                          = 20 if the dynamic allocation of real and
    !                               complex workspace in the derived type
    !                               (fishpackworkspace) variable w fails (e.g.,
    !                               if n, m are too large for the platform used)
    !
    !                          since this is the only means of indicating
    !                          a possliby incorrect call to hwscsp, the
    !                          user should test ierror after a call.
    !
    !                        w
    !                          the derived type(fishpackworkspace) variable w
    !                          contains real and complex values that must not
    !                          be destroyed if hwscsp is called again with
    !                          intl=1.
    !
    !
    ! HISTORY                Written by Roland Sweet AT NCAR in the late
    !                        1970'S.  Released on NCAR's public software
    !                        libraries in January 1980. Revised by John
    !                        Adams in June 2004 using Fortran 90 dynamically
    !                        allocated workspace and derived datat types
    !                        to eliminate mixed mode conflicts in the earlier
    !                        versions.
    !
    !
    ! ALGORITHM              The routine defines the finite difference
    !                        equations, incorporates boundary data, and
    !                        adjusts the right side of singular systems
    !                        and then calls blktri to solve the system.
    !
    ! REFERENCES             Swarztrauber, P. and R. Sweet, "Efficient
    !                        FORTRAN subprograms for the solution of
    !                        elliptic equations"
    !                          NCAR TN/IA-109, July, 1975, 138 pp.
    !
    module subroutine hwscsp(intl, ts, tf, m, mbdcnd, bdts, bdtf, rs, rf, n, &
        nbdcnd, bdrs, bdrf, elmbda, f, idimf, pertrb, ierror, workspace)

        ! Dummy arguments
        integer(ip), intent(in)     :: intl
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: mbdcnd
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: nbdcnd
        integer(ip), intent(in)     :: idimf
        integer(ip), intent(out)    :: ierror
        real(wp),    intent(in)     :: ts
        real(wp),    intent(in)     :: tf
        real(wp),    intent(in)     :: rs
        real(wp),    intent(in)     :: rf
        real(wp),    intent(in)     :: elmbda
        real(wp),    intent(out)    :: pertrb
        real(wp),    intent(in)     :: bdts(:)
        real(wp),    intent(in)     :: bdtf(:)
        real(wp),    intent(in)     :: bdrs(:)
        real(wp),    intent(in)     :: bdrf(:)
        real(wp),    intent(inout)  :: f(:,:)
        class(FishpackWorkspace), intent(inout)  :: workspace

        ! Check input arguments
        call hwscsp_check_input_arguments(ts, tf, m, mbdcnd, rs, rf, &
            n, nbdcnd, elmbda, idimf, ierror)

        ! Check error flag
        if (ierror /= 0) return

        ! Set up workspace on initial call only
        if (intl == 0) call hwscsp_initialize_workspace(n, m, nbdcnd, workspace)

        ! Solve system
        associate( &
            indx => workspace%workspace_indices, &
            rew => workspace%real_workspace, &
            cxw => workspace%complex_workspace &
            )
            associate( &
                w => rew, &
                wc => cxw, &
                s => rew(indx(1):), &
                an => rew(indx(2):), &
                bn => rew(indx(3):), &
                cn => rew(indx(4):), &
                r => rew(indx(5):), &
                am => rew(indx(6):), &
                bm => rew(indx(7):), &
                cm => rew(indx(8):), &
                sint => rew(indx(9):), &
                bmh => rew(indx(10):) &
                )
                call hwscsp_lower_routine(intl, ts, tf, m, mbdcnd, bdts, bdtf, rs, rf, n, &
                    nbdcnd, bdrs, bdrf, elmbda, f, idimf, pertrb, w, wc, s, an, bn, &
                    cn, r, am, bm, cm, sint, bmh, ierror)
            end associate
        end associate

    end subroutine hwscsp

    subroutine hwscsp_initialize_workspace(n, m, nbdcnd, workspace)

        ! Dummy arguments
        integer(ip), intent(in)  :: nbdcnd
        integer(ip), intent(in)  :: n
        integer(ip), intent(in)  :: m
        class(FishpackWorkspace), intent(out) :: workspace

        ! Local variables
        integer(ip) :: irwk, icwk, indx(SIZE_OF_WORKSPACE_INDICES)

        ! Compute workspace indices
        indx = hwscsp_get_workspace_indices(n, m, nbdcnd)

        ! Compute required blktri workspace lengths
        call workspace%compute_blktri_workspace_lengths(n, m, irwk, icwk)

        ! Adjust workspace requirements for hwscsp
        irwk = indx(10) + m + 1
        icwk = icwk + 3 * m

        ! Allocate memory
        call workspace%create(irwk, icwk, SIZE_OF_WORKSPACE_INDICES)

        ! Set workspace indices
        workspace%workspace_indices = indx

    end subroutine hwscsp_initialize_workspace

    pure function hwscsp_get_workspace_indices(n, m, nbdcnd) result (return_value)

        ! Dummy arguments
        integer(ip), intent(in) :: n, m, nbdcnd
        integer(ip)             :: return_value(SIZE_OF_WORKSPACE_INDICES)

        ! Local variables
        integer(ip)  :: j, nck, l, k

        nck = n

        select case (nbdcnd)
            case (1, 5)
                nck = nck - 1
            case (3)
                nck = nck + 1
        end select

        k = 1
        l = 4
        k = k + 1

        do
            if (nck <= l) exit
            l = 2*l
            k = k + 1
        end do

        l = 2*l

        associate( indx => return_value)

            indx(1) = (k - 2)*l + k + max(2*n, 6*m) + 13

            do j = 1, 5
                indx(j+1) = indx(j) + n + 1
            end do

            do j = 6, 9
                indx(j+1) = indx(j) + m + 1
            end do

        end associate

    end function hwscsp_get_workspace_indices

    subroutine hwscsp_check_input_arguments(ts, tf, m, mbdcnd, rs, rf, &
        n, nbdcnd, elmbda, idimf, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: m
        integer(ip), intent(in)  :: mbdcnd
        integer(ip), intent(in)  :: n
        integer(ip), intent(in)  :: nbdcnd
        integer(ip), intent(in)  :: idimf
        integer(ip), intent(out) :: ierror
        real(wp),    intent(in)  :: ts
        real(wp),    intent(in)  :: tf
        real(wp),    intent(in)  :: rs
        real(wp),    intent(in)  :: rf
        real(wp),    intent(in)  :: elmbda

        if (ts < ZERO .or. tf > PI) then
            ierror = 1
            return
        else if (ts >= tf) then
            ierror = 2
            return
        else if (m < 5) then
            ierror = 3
            return
        else if (mbdcnd < 1 .or. mbdcnd > 9) then
            ierror = 4
            return
        else if (rs < ZERO) then
            ierror = 5
            return
        else if (rs >= rf) then
            ierror = 6
            return
        else if (n < 5) then
            ierror = 7
            return
        else if (nbdcnd < 1 .or. nbdcnd > 6) then
            ierror = 8
            return
        else if (elmbda > ZERO) then
            ierror = 9
            return
        else if (idimf < m + 1) then
            ierror = 10
            return
        else if (elmbda /= ZERO .and. mbdcnd >= 5) then
            ierror = 11
            return
        else if (elmbda /= ZERO) then
            select case (nbdcnd)
                case (5, 6)
                    ierror = 12
                    return
            end select
        else if (ts /= ZERO) then
            select case (mbdcnd)
                case (5, 6, 9)
                    ierror = 13
                    return
            end select
        else if (mbdcnd >= 7 .and. tf /= PI) then
            ierror = 14
            return
        else if (ts == ZERO) then
            select case (mbdcnd)
                case (3:4, 8)
                    ierror = 15
                    return
            end select
        else if (tf == PI) then
            select case (mbdcnd)
                case (2, 3, 6)
                    ierror = 16
                    return
            end select
        else if (nbdcnd >= 5 .and. rs /= ZERO) then
            ierror = 17
            return
        else if (5 <= nbdcnd) then
            select case (mbdcnd)
                case (1:2, 5, 7)
                    ierror = 18
                    return
            end select
        else
            ierror = 0
        end if

    end subroutine hwscsp_check_input_arguments

    subroutine hwscsp_lower_routine(intl, ts, tf, m, mbdcnd, bdts, bdtf, rs, rf, n, &
        nbdcnd, bdrs, bdrf, elmbda, f, idimf, pertrb, w, wc, s, an, bn &
        , cn, r, am, bm, cm, sint, bmh, ierror)

        ! Dummy arguments

        integer(ip), intent(in)     :: intl
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: mbdcnd
        integer(ip), intent(in)     :: n
        integer(ip), intent(in)     :: nbdcnd
        integer(ip), intent(in)     :: idimf
        integer(ip), intent(out)    :: ierror
        real(wp),    intent(in)     :: ts
        real(wp),    intent(in)     :: tf
        real(wp),    intent(in)     :: rs
        real(wp),    intent(in)     :: rf
        real(wp),    intent(in)     :: elmbda
        real(wp),    intent(out)    :: pertrb
        real(wp),    intent(in)     :: bdts(:)
        real(wp),    intent(in)     :: bdtf(:)
        real(wp),    intent(in)     :: bdrs(:)
        real(wp),    intent(in)     :: bdrf(:)
        real(wp),    intent(inout) :: f(idimf,n + 1)
        real(wp),    intent(out) :: w(:)
        real(wp),    intent(out) :: s(:)
        real(wp),    intent(out) :: an(:)
        real(wp),    intent(out) :: bn(:)
        real(wp),    intent(out) :: cn(:)
        real(wp),    intent(out) :: r(:)
        real(wp),    intent(out) :: am(:)
        real(wp),    intent(out) :: bm(:)
        real(wp),    intent(out) :: cm(:)
        real(wp),    intent(out) :: sint(:)
        real(wp),    intent(out) :: bmh(:)
        complex(wp), intent(out) :: wc(:)

        ! Local variables
        integer(ip)         :: mp1, i, np1, j, mp, np
        integer(ip)         :: its, itf, itsp, itfm, ictr, jrs
        integer(ip)         :: l, jrf, jrsp, jrfm, munk, nunk, ising, iflg
        real(wp)            :: dth, tdt, hdth, sdts
        real(wp)            :: theta, t1, dr, hdr
        real(wp)            :: tdr, dr2, czr, at, ct, wts, wtf
        real(wp)            :: ar, wtnm, yps, cr, wrs, wrf
        real(wp)            :: wrz, summation, r2, hne, yhld
        real(wp)            :: rs2, rf2, rsq, xp, yph, xps
        real(wp), parameter :: FOUR = 4.0_wp
        real(wp), parameter :: SIX = 6.0_wp
        type(GeneralizedCyclicReductionUtility) :: util

        mp1 = m + 1
        dth = (tf - ts)/m
        tdt = dth + dth
        hdth = dth/2
        sdts = ONE/(dth**2)

        do i = 1, mp1
            theta = ts + real(i - 1, kind=wp)*dth
            sint(i) = sin(theta)
            if (sint(i) == ZERO) cycle
            t1 = sdts/sint(i)
            am(i) = t1*sin(theta - hdth)
            cm(i) = t1*sin(theta + hdth)
            bm(i) = -(am(i)+cm(i))
        end do

        np1 = n + 1
        dr = (rf - rs)/n
        hdr = dr/2
        tdr = dr + dr
        dr2 = dr**2
        czr = SIX*dth/(dr2*(cos(ts) - cos(tf)))

        do j = 1, np1
            r(j) = rs + real(j - 1, kind=wp)*dr
            an(j) = (r(j)-hdr)**2/dr2
            cn(j) = (r(j)+hdr)**2/dr2
            bn(j) = -(an(j)+cn(j))
        end do

        mp = 1
        np = 1

        !
        ! Boundary condition at phi=ps
        !
        select case (mbdcnd)
            case (1:2,7)
                at = am(2)
                its = 2
            case (3:4,8)
                at = am(1)
                its = 1
                cm(1) = cm(1) + am(1)
            case (5:6,9)
                its = 1
                bm(1) = -FOUR*sdts
                cm(1) = -bm(1)
        end select

        !
        ! Boundary condition at phi=pf
        !
        select case (mbdcnd)
            case (1,4:5)
                ct = cm(m)
                itf = m
            case (2:3,6)
                ct = cm(m+1)
                am(m+1) = am(m+1) + cm(m+1)
                itf = m + 1
            case (7:9)
                itf = m + 1
                am(m+1) = FOUR*sdts
                bm(m+1) = -am(m+1)
        end select

        wts = sint(its+1)*am(its+1)/cm(its)
        wtf = sint(itf-1)*cm(itf-1)/am(itf)
        itsp = its + 1
        itfm = itf - 1
        !
        ! Boundary condition at r=rs
        !
        ictr = 0
        select case (nbdcnd)
            case default
                ar = an(2)
                jrs = 2
            case (3:4)
                ar = an(1)
                jrs = 1
                cn(1) = cn(1) + an(1)
            case (5:6)
                jrs = 2
                ictr = 1
                s(n) = an(n)/bn(n)
                do j = 3, n
                    l = n - j + 2
                    s(l) = an(l)/(bn(l)-cn(l)*s(l+1))
                end do
                s(2) = -s(2)
                do j = 3, n
                    s(j) = -s(j)*s(j-1)
                end do
                wtnm = wts + wtf
                do i = itsp, itfm
                    wtnm = wtnm + sint(i)
                end do
                yps = czr*wtnm*(s(2)-ONE)
        end select

        !
        ! Boundary condition at r=rf
        !
        select case (nbdcnd)
            case (1,4:5)
                cr = cn(n)
                jrf = n
            case (2:3,6)
                cr = cn(n+1)
                an(n+1) = an(n+1) + cn(n+1)
                jrf = n + 1
        end select

        wrs = an(jrs+1)*r(jrs)**2/cn(jrs)
        wrf = cn(jrf-1)*r(jrf)**2/an(jrf)
        wrz = an(jrs)/czr
        jrsp = jrs + 1
        jrfm = jrf - 1
        munk = itf - its + 1
        nunk = jrf - jrs + 1
        bmh(its:itf) = bm(its:itf)
        ising = 0

        if  (nbdcnd == 3 .or. nbdcnd == 6 ) then
            select case (mbdcnd)
                case (3,6,8:9)
                    if (elmbda >= ZERO) then
                        ising = 1
                        summation = wts*wrs + wts*wrf + wtf*wrs + wtf*wrf
                        if (ictr /= 0) then
                            summation = summation + wrz
                        end if
                        do j = jrsp, jrfm
                            r2 = r(j)**2
                            do i = itsp, itfm
                                summation = summation + r2*sint(i)
                            end do
                        end do
                        do j = jrsp, jrfm
                            summation = summation + (wts + wtf)*r(j)**2
                        end do
                        do i = itsp, itfm
                            summation = summation + (wrs + wrf)*sint(i)
                        end do
                        hne = summation
                    end if
            end select
        end if

        select case (mbdcnd)
            case (1:4, 7:8)
                bm(its) = bmh(its) + elmbda/sint(its)**2
        end select

        select case (mbdcnd)
            case (1:6)
                bm(itf) = bmh(itf) + elmbda/sint(itf)**2
        end select

        bm(itsp:itfm) = bmh(itsp:itfm) + elmbda/sint(itsp:itfm)**2

        select case (mbdcnd)
            case (1:2, 7)
                f(2, jrs:jrf) = f(2, jrs:jrf) - at*f(1, jrs:jrf)/r(jrs:jrf)**2
            case (3:4, 8)
                f(1, jrs:jrf) = f(1, jrs:jrf) + tdt*bdts(jrs:jrf)*at/r(jrs:jrf)**2
        end select

        select case (mbdcnd)
            case (1, 4:5)
                f(m, jrs:jrf) = f(m, jrs:jrf) - ct*f(m+1, jrs:jrf)/r(jrs:jrf)**2
            case (2:3, 6)
                f(m+1, jrs:jrf)=f(m+1, jrs:jrf)-tdt*bdtf(jrs:jrf)*ct/r(jrs:jrf)**2
        end select

        case_block: block
            select case (nbdcnd)
                case default
                    if (mbdcnd /= 3) exit case_block
                    yhld = f(its, 1) - czr/tdt*(sin(tf)*bdtf(2)-sin(ts)*bdts(2))
                    f(:mp1, 1) = yhld
                case (1:2)
                    rs2 = (rs + dr)**2
                    f(its:itf, 2) = f(its:itf, 2) - ar*f(its:itf, 1)/rs2
                case (3:4)
                    f(its:itf, 1) = f(its:itf, 1) + tdr*bdrs(its:itf)*ar/rs**2
            end select
        end block case_block

        select case (nbdcnd)
            case (1, 4:5)
                rf2 = (rf - dr)**2
                f(its:itf, n) = f(its:itf, n) - cr*f(its:itf, n+1)/rf2
            case (2:3, 6)
                f(its:itf, n+1) = f(its:itf, n+1) - tdr*bdrf(its:itf)*cr/rf**2
        end select

        pertrb = ZERO

        if (ising /= 0) then
            summation = wts*wrs*f(its, jrs) + wts*wrf*f(its, jrf) + wtf*wrs*f(itf, &
                jrs) + wtf*wrf*f(itf, jrf)

            if (ictr /= 0) summation = summation + wrz*f(its, 1)

            do j = jrsp, jrfm
                r2 = r(j)**2
                do i = itsp, itfm
                    summation = summation + r2*sint(i)*f(i, j)
                end do
            end do

            summation = summation &
                + dot_product(r(jrsp:jrfm)**2, wts*f(its, jrsp:jrfm)+ &
                wtf*f(itf, jrsp:jrfm))

            summation = summation &
                + dot_product(sint(itsp:itfm), wrs*f(itsp:itfm, jrs)+ &
                wrf*f(itsp:itfm, jrf))

            pertrb = summation/hne

            f(:mp1, :np1) = f(:mp1, :np1) - pertrb

        end if

        do j = jrs, jrf
            rsq = r(j)**2
            f(its:itf, j) = rsq*f(its:itf, j)
        end do

        iflg = intl

        call util%blktrii(iflg, np, nunk, an(jrs:), bn(jrs:), cn(jrs:), mp, munk, &
            am(its:), bm(its:), cm(its:), idimf, f(its:, jrs:), ierror, w, wc)

        if (ierror /= 0) then
            error stop 'fishpack library: blktrii call failed in hwscsp_lower_routine'
        end if

        iflg = iflg + 1

        do while(iflg == 1)
            !
            ! Iterate solver
            !
            call util%blktrii(iflg, np, nunk, an(jrs:), bn(jrs:), cn(jrs:), mp, &
                munk, am(its:), bm(its:), cm(its:), idimf, f(its:, jrs:), ierror, w, wc)

            if (ierror /= 0) then
                error stop 'fishpack library: blktrii call failed in hwscsp_lower_routine'
            end if
            !
            ! Increment solver flag
            !
            iflg = iflg + 1
        end do

        if (nbdcnd == 0) f(:mp1, jrf+1) = f(:mp1, jrs)

        if (mbdcnd == 0) f(itf+1, :np1) = f(its, :np1)

        xp = ZERO

        if (ictr /= 0) then
            if (ising == 0) then
                summation = wts*f(its, 2) + wtf*f(itf, 2)
                summation = summation + dot_product(sint(itsp:itfm), f(itsp:itfm, 2))
                yph = czr*summation
                xp = (f(its, 1)-yph)/yps
                do j = jrs, jrf
                    xps = xp*s(j)
                    f(its:itf, j) = f(its:itf, j) + xps
                end do
            end if
            f(:mp1, 1) = xp
        end if

    end subroutine hwscsp_lower_routine

end submodule centered_axisymmetric_spherical_solver
!
! REVISION HISTORY
!
! September 1973    Version 1
! April     1976    Version 2
! January   1978    Version 3
! December  1979    Version 3.1
! February  1985    Documentation upgrade
! November  1988    Version 3.2, FORTRAN 77 changes
! June      2004    Version 5.0, Fortran 90 changes
!