subroutine optimization_sa(parameters_end)
    use dimensions; use structural_p2; use nrtype; use optimization
    implicit none
    real(SP),dimension(parameters_to_est),intent(out)::parameters_end
    real(SP),dimension(parameters_to_est)::p_g
    real(SP),dimension(parameters_to_est,2)::limits
    real(SP),dimension(parameters_to_est,parameters_to_est)::xi
    real(SP),dimension(parameters_to_est+1,parameters_to_est)::parameters
    real(SP),dimension((parameters_to_est+1)*parameters_to_est)::parameters_v
    real(SP),dimension(parameters_to_est+1)::obj_fct
    real(SP)::ftol=0.0005_sp,temptr,obj_fct_end
    real(DP),dimension(parameters_to_est)::u
    interface
        function SMM(parameters)
        use nrtype;use dimensions
        implicit none
        real(SP),dimension(parameters_to_est),intent(in)::parameters
        real(SP)::SMM
        end function
    end interface
    integer::p_l,iter,p_l2,it
    integer,parameter:: INIT=100
    real(SP),dimension(INIT,parameters_to_est):: final_p
    real(SP),dimension(INIT):: value_SMM
    character::end_key
    !integer,allocatable::seed(:)
    integer,dimension(parameters_to_est)::seed=254
    integer::M

    !Set seed
    !call random_seed(size=M)
    !ALLOCATE (seed(M))
    call random_seed(PUT=seed)

    !Set initial simplex
    !
    !!Solve for INIT different initial conditions
    !!sigma
    !limits(1,1)=1.2_sp
    !limits(1,2)=4.0_sp
    !!transfer in medicaid
    !limits(2,1)=1.0_sp
    !limits(2,2)=20.0_sp
    !!alpha mu
    !limits(3,1)=1.0_sp
    !limits(3,2)=1.2_sp
    !limits(4,1)=7.0_sp
    !limits(4,2)=8.0_sp
    !limits(5,1)=10.0_sp
    !limits(5,2)=11.0_sp
    !!delta
    !limits(6,1)=50.0_sp
    !limits(6,2)=1000.0_sp
    !!nu
    !limits(7,1)=1.2_sp
    !limits(7,2)=7.3_sp
    !!lambda
    !limits(8,1)=1.0_sp
    !limits(8,2)=7.0_sp
    !
    !!!sigma ep
    !!limits(14:17,1)=0.001_sp
    !!limits(14:17,2)=0.01_sp
    !!Beta
    !!limits(14,1)=0.90_sp
    !!limits(14,2)=0.98_sp
    !
    !
    !open(unit=11,file='param_op.txt')
    !open(unit=12,file='value_op.txt')
    !do it=1,INIT
    !    print*,'optimization',it,'out of',INIT
    !    do p_l=1,parameters_to_est+1
    !        call random_seed(PUT=seed)
    !        call RANDOM_NUMBER(u)
    !        call random_seed(GET=seed)
    !        do p_l2=1,parameters_to_est
    !            parameters(p_l,p_l2)=limits(p_l2,1)+(limits(p_l2,2)-limits(p_l2,1))*real(u(p_l2))
    !        end do
    !        call p2R(parameters(p_l,:))
    !        obj_fct(p_l)=SMM(parameters(p_l,:))
    !        !read*,end_key
    !    end do
    !    print*,'dont forget to change parameter number in amoeba if changed the number of parameters'
    !    call amoeba(parameters,obj_fct,ftol,SMM,iter)
    !    call R2p(parameters(1,:),parameters_end)
    !    final_p(it,:)=parameters_end
    !    value_SMM(it)=obj_fct(1)
    !    print*,final_p(it,:)
    !    write(11,*) final_p(it,:)
    !    write(12,*) value_SMM(it)
    !end do
    !parameters_end=final_p(minloc(value_SMM,1),:)
    print*,'Optimization started'
    open(unit=11,file='initial_simplex.txt')
        read(11,*) parameters_v
    close(11)
    parameters=reshape(parameters_v,(/parameters_to_est+1,parameters_to_est/),order=(/2,1/))
    do p_l=1,parameters_to_est+1
        print*,'p_l',p_l
        call p2R(parameters(p_l,:))
        obj_fct(p_l)=SMM(parameters(p_l,:))
        !print*,'pause'
        !read*,end_key
    end do
    print*,'amoeba started'
    call amoeba(parameters,obj_fct,ftol,SMM,iter)
    call R2p(parameters(1,:),parameters_end)

end subroutine


!	Find estimated conditional expectations and conditional covariance matrices for transformations of latent vector.
!	dimtrans is the dimension of the transformation.
!	postdensity contains posterior weights.
!	theta contains posterior quadrature points.

!	covtran is the conditional covariance of the transformation of the latent vector.
!	meantran is the conditional mean of the transformation of the latent vector.

subroutine eaptrans(dimtrans,postdensity,theta,covtran,meantran)
implicit none
interface
!	Multinomial covariance matrix.
!	density is vector of probabilities.
!	meanth is vector of means.
!	quadpoint is array of weights.
	function mcovth(density,meanth,quadpoint)
		implicit none
		real(kind=8),intent(in)::density(:),meanth(:),quadpoint(:,:)
		real(kind=8)::mcovth(size(meanth),size(meanth))
	end function mcovth
!	Multinomial mean.
!	density is vector of probabilities
!	quadpoint is array of weights.
	function mmeanth(density,quadpoint)
		implicit none
		real(kind=8),intent(in)::density(:),quadpoint(:,:)
		real(kind=8)::mmeanth(size(quadpoint,1))
	end function mmeanth
!	Define the transformation
!	m is the dimension of the result.
!	theta is the input.
	function transform(m,theta)
		implicit none
		integer,intent(in)::m
		real (kind=8),intent(in)::theta(:)
		real(kind=8)::transform(m)

	end function transform

end interface
integer,intent(in)::dimtrans
real(kind=8),intent(in)::postdensity(:,:),theta(:,:,:)
real(kind=8),intent(out)::covtran(:,:,:),meantran(:,:)
!	dimlatout is the dimension of the transformed latent vector.
!	item is an item.
!	ncat is the total number of underlying categories.
!	ncatobs is the total number of observed categories.
!	nitems is the number of items.
!	nquad is the number of quadrature points.
!	nscale is the location in beta of the initial item discrimination.
!	nscale1 is the location in beta of the last item discrimination.
!	obs is observation number.
!	quad counts quadrature points.
!	resp is a single response.
!	row is a row counter.

integer::obs,quad
!	scales is for scale parameters.

real(kind=8)::meanquad(dimtrans,size(postdensity,1))

!	Obtain results for each observation.
do obs=1,size(postdensity,2)

!	Cycle through quadrature points.

	do quad=1,size(postdensity,1)

! Probability computation.

		meanquad(:,quad)=transform(dimtrans,theta(:,quad,obs))

	end do

!	mean and covariance.
	meantran(:,obs)=mmeanth(postdensity(:,obs),meanquad)
    covtran(:,:,obs)=mcovth(postdensity(:,obs),meantran(:,obs),meanquad)

end do
return
end subroutine eaptrans


subroutine sfhinfo(pset, age, mfrac, sfr, frac_linear)
  ! Get the SFR integrated from T=0 to T=age, normalized by the SFR integrated
  ! from T=0 to T=Tmax, where Tmax is the maximum isochrone/SSP age.
  !
  ! Inputs
  ! ---------
  !
  ! pset:
  !   A `PARAMS` structure containing the SFH parameters.
  !
  ! age:
  !   The age (in forward Gyr) at which to calculate the SFR and mass
  !   fractions.
  !
  ! Outputs:
  ! ----------
  !
  ! mfrac:
  !    Fraction of mass formed by `age` \equiv mass_formed(age) /
  !    mass_formed(maxtime) where maxtime is the age of the oldest isochrone.
  !
  ! sfr:
  !    The SFR at `age`, normalized s.t. the integral of the SFR from 0 to the
  !    oldest isochrone age is 1.  Infinite SFR from bursts is not included.
  !
  ! frac_linear:
  !   If pset%sfh=5, this gives the fraction of m_formed(age) that was formed
  !   in the linear portion.
  !
  use sps_vars, only: time_full, ntfull, tiny_number, &
                      sfh_tab, ntabsfh, &
                      PARAMS, SP
  use sps_utils, only: locate
  implicit none

  type(PARAMS), intent(in) :: pset
  real(SP), intent(in) :: age

  real(SP), intent(out) :: mfrac, sfr, frac_linear

  real(SP) :: Tmax, Tprime, Tz, Ttrunc, Thi
  real(SP) :: m, gammainc
  real(SP) :: mass_tau, mass_linear, mfrac_burst
  real(SP) :: total_mass_tau, total_mass_linear
  real(SP) :: sfr_tau, sfr_linear, sfr_trunc, sfr_const
  integer :: power, itab

  ! Defaults
  mfrac = 1.
  sfr = 0.
  frac_linear = 0.

  if (pset%sfh.eq.0) then
     ! SSPs
     mfrac = 1.0
     sfr = 0. ! actually the sfr is infinity

  else if ((pset%sfh.eq.1).or.(pset%sfh.eq.4).or.(pset%sfh.eq.5)) then
     ! Compute tau model component, for SFH=1,4,5
     !
     ! Integration limits are from 0 to Tmax and 0 to Tprime, where
     !   - Tmax is the maximum isochrone age, and
     !   - Tprime is the given `age`,
     ! both adjusted for sf_start, and we'll clip them to Ttrunc.
     Tmax = 10**(time_full(ntfull) - 9) - pset%sf_start
     Tprime = age - pset%sf_start
     ! Ttrunc only matters if nonzero and not before sf_start.
     if ((pset%sf_trunc.lt.tiny_number).or.(pset%sf_trunc.lt.pset%sf_start)) then
        Ttrunc = Tmax
     else
        Ttrunc = pset%sf_trunc - pset%sf_start
     endif

     ! Now integrate to get mass formed by Tprime and by Tmax, dealing with
     ! truncation that happens after sf_start but before Tmax and/or Tprime.
     if (pset%sfh.eq.1) power = 1
     if ((pset%sfh.eq.4).or.(pset%sfh.eq.5)) power = 2
     total_mass_tau = pset%tau * gammainc(power, min(Tmax, Ttrunc) / pset%tau)
     if (Tprime.lt.0) then
        ! Deal with sf that hasn't started yet
        mass_tau = 0.
        sfr_tau = 0.
     else
        mass_tau = pset%tau * gammainc(power, min(Tprime, Ttrunc) / pset%tau)
        ! The SFR at Tprime (unnormalized)
        sfr_tau = (min(Tprime, Ttrunc) / pset%tau)**(power-1.) * exp(-min(Tprime, Ttrunc) / pset%tau)
     endif

  endif

  ! Add the constant and burst portions, for SFH=1,4.
  if ((pset%sfh.eq.1).or.(pset%sfh.eq.4)) then

     ! Fraction of the burst mass formed by Tprime
     if (Tprime.gt.(pset%tburst-pset%sf_start)) then
        mfrac_burst = 1.0
     else
        mfrac_burst = 0.0
     endif
     ! SFR from constant portion at Tprime
     if (Tprime.gt.0) then
        sfr_const = 1.0 / min(Tmax, Ttrunc)
     else
        sfr_const = 0.0
     endif

     ! Add formed mass fractions for each component, weighted by component fractions.
     ! Fraction of the constant mass formed by Tprime is just Tprime/Tmax
     mfrac = (1. - pset%const - pset%fburst) * mass_tau / total_mass_tau + &
          pset%const * max(min(Tprime, Ttrunc), 0.0) * sfr_const + &
          pset%fburst * mfrac_burst

     ! N.B. for Tprime = tburst, sfr is infinite, but we ignore that case.
     ! For constant SFR=1, total_mass_const = Tmax
     if (Tprime.gt.Ttrunc) then
        ! We've truncated.
        sfr = 0.
     else
        sfr = (1. - pset%const - pset%fburst) * sfr_tau / total_mass_tau + &
              pset%const * sfr_const
     endif

  ! Add the linear portion, for Simha, SFH=5.
  ! This is the integral of sfr_trunc*(1 - m * (T - Ttrunc)) from Ttrunc to Tz
  else if (pset%sfh.eq.5) then
     m = -pset%sf_slope
     if (m.gt.0) then
        ! find time at which SFR=0, if m>0
        Tz = Ttrunc + 1.0 / m
     else
        ! m <= 0 will never reach SFR=0
        Tz = Tmax
     endif

     ! Logic for Linear portion
     if ((Ttrunc.le.0).or.(Ttrunc.gt.Tmax)) then
        ! Truncation does not occur during the SFH.
        total_mass_linear = 0.
        mass_linear = 0.
        sfr = sfr_tau / total_mass_tau
        frac_linear = 0.
     else
        ! Truncation does occur, integrate linear to zero crossing or Tmax.
        Thi = min(Tz, Tmax)
        sfr_trunc = (Ttrunc/pset%tau) * exp(-Ttrunc/pset%tau)
        total_mass_linear = sfr_trunc * ((Thi - Ttrunc) - m/2.*(Thi**2 + Ttrunc**2) + &
                                         m * Thi * Ttrunc)

        if (Ttrunc.ge.Tprime) then
           ! But Tprime has not reached truncation yet.
           mass_linear = 0.0
           sfr = sfr_tau / (total_mass_tau + total_mass_linear)
        else
           ! Tprime is past truncation, how much mass formed?
           Thi = min(Tz, Tprime)
           mass_linear = sfr_trunc * ((Thi - Ttrunc) - m/2.*(Thi**2 + Ttrunc**2) + &
                                      m * Thi * Ttrunc)
           sfr = max(sfr_trunc * (1 - m * (Tprime - Ttrunc)), 0.) / (total_mass_tau + total_mass_linear)
        endif

     endif

     ! Fractions including tau and linear portions, wrapped in if/else to avoid NaNs
     if (Tprime.ge.0) then
        mfrac = (mass_tau + mass_linear) / (total_mass_tau + total_mass_linear)
        ! Mass fraction of the simha SFH at Tprime that formed in the linear portion.
        frac_linear = mass_linear / (mass_linear + mass_tau)
     else
        mfrac = 0.0
        frac_linear = 0.0
        sfr = 0.0
     endif

  endif

  ! Tabular.  Simple linear interpolation to get the sfr.
  ! The table is in units of yrs of forward time and M_sun/yr.
  if ((pset%sfh.eq.2).or.(pset%sfh.eq.3)) then
     itab = max(min(locate(sfh_tab(1, 1:ntabsfh), age*1e9), ntabsfh-1), 1)
     m = (sfh_tab(2, itab+1) - sfh_tab(2, itab)) / (sfh_tab(1, itab+1) - sfh_tab(1, itab))
     sfr = sfh_tab(2, itab) + m * (age*1e9 - sfh_tab(1, itab))
     sfr = max(sfr, 0.0) * 1e9 ! convert to per Gyr
  endif

  ! Convert SFR from per Gyr to per year
  sfr = sfr / 1e9

end subroutine sfhinfo

function gammainc(power, arg)
  !
  ! Calculate incomplete gamma for a = 1 or 2

  use sps_vars, only: SP
  implicit none
  integer, intent(in) :: power
  real(SP), intent(in) :: arg

  real(SP) :: gammainc

  if (power.eq.2) then
     gammainc = 1.0 - exp(-arg) - arg * exp(-arg)
  else if (power.eq.1) then
     gammainc = 1.0 - exp(-arg)
  else
     write(*,*) "gammainc: power must be 1 or 2"
     STOP
  endif

end function gammainc


program P1564
    implicit none
    integer :: n
    integer(16) :: i, j
    integer(16) :: fact
    integer(16) :: modulo

    modulo = 1000000
    modulo = modulo * 1000000

    read *, n
    fact = 36288
    do i = 11, n
        j = i
        fact = fact * j
        do while (mod(fact, 10) == 0)
            fact = fact / 10
        end do
        fact = mod(fact, modulo);
    end do
    write (*, '(I0.5)') mod(fact, 100000)
end program P1564


module vd2d_mms_mod_4_RT

    implicit none

    real,  parameter :: pi = 3.141592653589793238462
    real,  private :: alpha,delta,g,omega1,omega2,&
        omega3,omega4,omega5,omega6,omega7,omega8

    !functions
    PUBLIC :: vd2d_mms_init_4
    PUBLIC :: vd2d_mms_u
    PUBLIC :: vd2d_mms_rho
    PUBLIC :: vd2d_mms_z
    PUBLIC :: vd2d_mms_z_src
    PUBLIC :: vd2d_mms_v
    PUBLIC :: vd2d_mms_p
    PUBLIC :: vd2d_mms_u_src
    PUBLIC :: vd2d_mms_v_src
    PUBLIC :: y_int

!————————————————————————————————————————————————————————————————————————————————————————
contains
    !————————————————————————————————————————————————————————————————————————————————————————
    subroutine vd2d_mms_init_4 (a1,d1,g1,o1,o2,o3,o4,o5,o6,o7,o8)
        implicit none
        real, intent (in) :: a1,d1,g1,o1,o2,o3,o4,o5,o6,o7,o8
        alpha = a1 ! magnitude
        delta = d1 ! y-width
        g = g1     !acceleration
        !frequencies
        omega1 = o1
        omega2 = o2
        omega3 = o3
        omega4 = o4
        omega5 = o5
        omega6 = o6
        omega7 = o7
        omega8 = o8
    end subroutine vd2d_mms_init_4
    !————————————————————————————————————————————————————————————————————————————————————————
    function vd2d_mms_u (x,y,t)
        implicit none
        real, intent (in) :: x,y,t
        real  :: vd2d_mms_u

        vd2d_mms_u = x*0.0 + y*0.0 + t*0.0
    end function vd2d_mms_u
    !————————————————————————————————————————————————————————————————————————————————————————
    function vd2d_mms_rho (x,y,t)
        implicit none
        real, intent (in) :: x,y,t
        real  :: vd2d_mms_rho

        vd2d_mms_rho =  1.0/( 9.0*vd2d_mms_z(x,y,t) + 1.0)
    end function vd2d_mms_rho
    !————————————————————————————————————————————————————————————————————————————————————————
    function vd2d_mms_z (x,y,t)
        implicit none
        real, intent (in) :: x,y,t
        real  :: vd2d_mms_z

        vd2d_mms_z= 0.5*(1.0 + tanh( (y_int(x)-y)/(2*delta) )) +t*0.0
    end function vd2d_mms_z
    !————————————————————————————————————————————————————————————————————————————————————————
    function vd2d_mms_z_src (x,y,t)
        implicit none
        real, intent (in) :: x,y,t
        real  :: vd2d_mms_z_src

        vd2d_mms_z_src=x*0.0 + y*0.0 + t*0.0

    end function vd2d_mms_z_src
    !————————————————————————————————————————————————————————————————————————————————————————
    function vd2d_mms_v (x,y,t)
        implicit none
        real, intent (in) :: x,y,t
        real  :: vd2d_mms_v

        vd2d_mms_v=x*0.0 + y*0.0 + t*0.0
    end function vd2d_mms_v
    !!————————————————————————————————————————————————————————————————————————————————————————
    function vd2d_mms_p (x,y,t)
        implicit none
        real, intent (in) :: x,y,t
        real  :: vd2d_mms_p

        vd2d_mms_p=x*0.0 + y*0.0 + t*0.0

    end function vd2d_mms_p
    !————————————————————————————————————————————————————————————————————————————————————————

    function vd2d_mms_u_src (x,y,t)
        implicit none
        real, intent (in) :: x,y,t
        real  :: vd2d_mms_u_src

        vd2d_mms_u_src = x*0.0 + y*0.0 + t*0.0
    end function vd2d_mms_u_src
    !————————————————————————————————————————————————————————————————————————————————————————
    function vd2d_mms_v_src (x,y,t)
        implicit none
        real, intent (in) :: x,y,t
        real  :: vd2d_mms_v_src

        vd2d_mms_v_src = x*0.0 - g + t*0.0 + y*0.0
    end function vd2d_mms_v_src
    !————————————————————————————————————————————————————————————————————————————————————————

    function y_int (x)
        implicit none
        real, intent (in) :: x
        real  :: y_int

        y_int = -alpha*( cos(omega1*pi*x) + &
            cos(omega2*pi*x) + cos(omega3*pi*x) + cos(omega4*pi*x) + &
            cos(omega5*pi*x) + cos(omega6*pi*x) + cos(omega7*pi*x) + &
            cos(omega8*pi*x)  )
    end function y_int

end module vd2d_mms_mod_4_RT


      subroutine intp_coef(nfilter,xintp)

      use fortranUtils

      implicit none
      integer*4     i,j,nfilter
      real*8        x,y
      real*4        xintp(0:65544)
      real*8 pi

      pi = getPi()

!c     compute the interpolation factors
      do i=0,nfilter
         j = i*8
         x = real(i)/real(nfilter)
         y = sin(pi*x)/pi
         if(x.ne.0.0  .and. x.ne.1.0) then
            xintp(j  ) = -y/(3.0+x)
            xintp(j+1) =  y/(2.0+x)
            xintp(j+2) = -y/(1.0+x)
            xintp(j+3) =  y/x
            xintp(j+4) =  y/(1.0-x)
            xintp(j+5) = -y/(2.0-x)
            xintp(j+6) =  y/(3.0-x)
            xintp(j+7) = -y/(4.0-x)
         else if( x.eq.0.0) then
            xintp(j  ) = 0.0
            xintp(j+1) = 0.0
            xintp(j+2) = 0.0
            xintp(j+3) = 1.0
            xintp(j+4) = 0.0
            xintp(j+5) = 0.0
            xintp(j+6) = 0.0
            xintp(j+7) = 0.0
         else if( x.eq.1.0) then
            xintp(j  ) = 0.0
            xintp(j+1) = 0.0
            xintp(j+2) = 0.0
            xintp(j+3) = 0.0
            xintp(j+4) = 1.0
            xintp(j+5) = 0.0
            xintp(j+6) = 0.0
            xintp(j+7) = 0.0
         end if
      end do

      return
      end


program Octal
  implicit none

  integer, parameter :: i64 = selected_int_kind(18)
  integer(i64) :: n = 0

! Will stop when n overflows from
! 9223372036854775807 to -92233720368547758078 (1000000000000000000000 octal)
  do while(n >= 0)
    write(*, "(o0)") n
    n = n + 1
  end do
end program


module rdirac

! Routines in this module solve the radial Dirac equation outward and
! inward using the implicit Adams method.

use types, only: dp
use ode1d, only: adams_interp_outward_implicit, &
    adams_interp_inward_implicit, get_midpoints, rk4_integrate4
use utils, only: stop_error

implicit none
private
public dirac_outward_adams, dirac_inward_adams

contains

subroutine dirac_outward_adams(c, kappa, Z, E, R, Rp, V, P, Q, imax)
!integrates the Dirac eq, returns r*R, where R is the radial
!solution.
! input parameters:
! kappa .... the kappa in the Dirac eq.
! Z .... the nucleus charge in Hartree atomic units
! E .... the energy at which to integration the equation
! R .... radial grid
! V .... potential on the radial grid
! c .... speed of light
! output parameters:
! Q .... f-component of the radial dirac wave function
! P .... g-component of the radial dirac wave function
real(dp), intent(in) :: c
integer, intent(in) :: kappa
integer, intent(in) :: Z
real(dp), intent(in) :: E
real(dp), intent(in) :: R(:), Rp(:)
real(dp), intent(in) :: V(:)
real(dp), intent(out) :: Q(:)
real(dp), intent(out) :: P(:)
integer, intent(out) :: imax

real(dp), parameter :: max_val = 1e6_dp
real(dp), dimension(size(R), 2, 2) :: Ctot

real(dp), dimension(size(R)) :: u1, u2, u1p, u2p
integer :: i
real(dp) :: lambda, Delta, M(2, 2), u1_tmp, u2_tmp
real(dp) :: Vmid(3)

if (size(R) < 4) call stop_error("size(R) <= 4")
Vmid = get_midpoints(R(:4), V(:4))
call integrate_radial_dirac_r_rk4(c, kappa, Z, E, R(:4), V(:4), Vmid, &
    u1(:4), u2(:4), imax)
if (imax /= 4) call stop_error("rk4 failed")

Ctot(:, 1, 1) = -kappa / R
Ctot(:, 2, 2) = +kappa / R
Ctot(:, 1, 2) = +(E-V)/c + 2*c
Ctot(:, 2, 1) = -(E-V)/c

u1p(:4) = Rp(:4) * (Ctot(:4, 1, 1) * u1(:4) + Ctot(:4, 1, 2) * u2(:4))
u2p(:4) = Rp(:4) * (Ctot(:4, 2, 1) * u1(:4) + Ctot(:4, 2, 2) * u2(:4))

do i = 4, size(R)-1
    u1p(i) = Rp(i) * (Ctot(i, 1, 1)*u1(i) + Ctot(i, 1, 2)*u2(i))
    u2p(i) = Rp(i) * (Ctot(i, 2, 1)*u1(i) + Ctot(i, 2, 2)*u2(i))
    u1_tmp  = u1(i) + adams_interp_outward_implicit(u1p, i)
    u2_tmp  = u2(i) + adams_interp_outward_implicit(u2p, i)

    lambda = 9.0_dp / 24
    Delta = 1 - lambda**2 * Rp(i+1)**2 * (Ctot(i+1, 1, 2) * Ctot(i+1, 2, 1) &
        -Ctot(i+1, 1, 1) * Ctot(i+1, 2, 2))
    M(1, 1) = (1 - lambda * Rp(i+1) * Ctot(i+1, 2, 2)) / Delta
    M(2, 1) = lambda * Rp(i+1) * Ctot(i+1, 2, 1) / Delta
    M(1, 2) = lambda * Rp(i+1) * Ctot(i+1, 1, 2) / Delta
    M(2, 2) = (1 - lambda * Rp(i+1) * Ctot(i+1, 1, 1)) / Delta

    u1(i+1) = M(1, 1) * u1_tmp + M(1, 2) * u2_tmp
    u2(i+1) = M(2, 1) * u1_tmp + M(2, 2) * u2_tmp
    if (abs(u1(i+1)) >= max_val .or. abs(u2(i+1)) >= max_val) then
        P = u1
        Q = u2
        imax = i
        return
    end if
end do
P = u1
Q = u2
imax = size(R)
end subroutine

subroutine dirac_inward_adams(c, kappa, E, R, Rp, V, P, Q, imin)
!integrates the Dirac eq. inwards, returns r*R, where R is the radial
!solution.
! input parameters:
! kappa .... the kappa in the Dirac eq.
! E .... the energy at which to integration the equation
! R .... radial grid
! V .... potential on the radial grid
! c .... speed of light
! output parameters:
! f .... f-component of the radial dirac wave function
! P .... g-component of the radial dirac wave function
real(dp), intent(in) :: c
integer, intent(in) :: kappa
real(dp), intent(in) :: E
real(dp), intent(in) :: R(:), Rp(:)
real(dp), intent(in) :: V(:)
real(dp), intent(out) :: Q(:)
real(dp), intent(out) :: P(:)
integer, intent(out) :: imin

integer :: nr
integer :: i_max
real(dp), parameter :: max_val = 1e20_dp
real(dp) :: lambda
real(dp), dimension(size(R), 2, 2) :: Ctot
real(dp), dimension(size(R)) :: u1, u2, u1p, u2p
integer :: i
real(dp) :: Delta, M(2, 2), u1_tmp, u2_tmp
real(dp) :: R_max

nr = size(R)

if (E > 0) call stop_error("E < 0 required")

i_max = nr-4
if (i_max < 2) call stop_error("size(R) too small to start inward integraion")
lambda = sqrt(-2*E-E**2/c**2)
! We require that exp(-lambda*(R-R(1)) ~ epsilon(1.0_dp),
! if we start further from
! the origin, it might sometimes blow up, if we start closer, we might not get
! as precise asymptotic.
! It follows that R ~ R(1)-log(epsilon(1.0_dp)) / lambda
R_max = R(1)-log(epsilon(1.0_dp))/lambda
do while (R(i_max) > R_max)
    if (i_max == 2) then
        print *, "E =", E, "lambda =", lambda
        call stop_error("Can't start the inward integration")
    end if
    i_max = i_max - 1
end do

u1(i_max+4:) = 0
u2(i_max+4:) = 0

u1(i_max:i_max+4) = exp(-lambda * (R(i_max:i_max+4)-R(1))) / sqrt(-E/(E+2*c**2))
u2(i_max:i_max+4) = -exp(-lambda * (R(i_max:i_max+4)-R(1)))

Ctot(:, 1, 1) = -kappa / R
Ctot(:, 2, 2) = +kappa / R
Ctot(:, 1, 2) = +(E-V)/c + 2*c
Ctot(:, 2, 1) = -(E-V)/c

u1p(i_max:i_max+4) = Rp(i_max:i_max+4) * &
    (Ctot(i_max:i_max+4, 1, 1)*u1(i_max:i_max+4) &
        + Ctot(i_max:i_max+4, 1, 2) * u2(i_max:i_max+4))
u2p(i_max:i_max+4) = Rp(i_max:i_max+4) * &
    (Ctot(i_max:i_max+4, 2, 1)*u1(i_max:i_max+4) &
        + Ctot(i_max:i_max+4, 2, 2) * u2(i_max:i_max+4))

do i = i_max, 2, -1
    u1p(i) = Rp(i) * (Ctot(i, 1, 1)*u1(i) + Ctot(i, 1, 2)*u2(i))
    u2p(i) = Rp(i) * (Ctot(i, 2, 1)*u1(i) + Ctot(i, 2, 2)*u2(i))
    u1_tmp  = u1(i) + adams_interp_inward_implicit(u1p, i)
    u2_tmp  = u2(i) + adams_interp_inward_implicit(u2p, i)

    lambda = -9.0_dp / 24
    Delta = 1 - lambda**2 * Rp(i-1)**2 * (Ctot(i-1, 1, 2) * Ctot(i-1, 2, 1) &
        -Ctot(i-1, 1, 1) * Ctot(i-1, 2, 2))
    M(1, 1) = (1 - lambda * Rp(i-1) * Ctot(i-1, 2, 2)) / Delta
    M(2, 1) = lambda * Rp(i-1) * Ctot(i-1, 2, 1) / Delta
    M(1, 2) = lambda * Rp(i-1) * Ctot(i-1, 1, 2) / Delta
    M(2, 2) = (1 - lambda * Rp(i-1) * Ctot(i-1, 1, 1)) / Delta

    u1(i-1) = M(1, 1) * u1_tmp + M(1, 2) * u2_tmp
    u2(i-1) = M(2, 1) * u1_tmp + M(2, 2) * u2_tmp
    if (abs(u1(i-1)) >= max_val .or. abs(u2(i-1)) >= max_val) then
        P = u1
        Q = u2
        imin = i
        return
    end if
end do
P = u1
Q = u2
imin = 1
end subroutine

real(dp) recursive function a_k(n, lambda, sigma, zeta, kappa, c) result(r)
integer, intent(in) :: n, kappa
real(dp), intent(in) :: lambda, sigma, c, zeta
if (n < 1) then
    r = 0
    call stop_error("a_k: n >= 1 required")
else
    r = c/(n*lambda) * (kappa + (n-sigma)*sigma*lambda/zeta - zeta*lambda/c**2)
    r = r * b_k(n, lambda, sigma, zeta, kappa, c)
end if
end function

real(dp) recursive function b_k(k, lambda, sigma, zeta, kappa, c) result(r)
integer, intent(in) :: k, kappa
real(dp), intent(in) :: lambda, sigma, c, zeta
integer :: n
if (k < 1) then
    r = 0
    call stop_error("b_k: n >=1 required")
else if (k == 1) then
    r = 1/(2*c) * (kappa + zeta/lambda)
else
    n = k-1
    r = 1/(2*n*lambda) * (kappa**2 - (n-sigma)**2 - zeta**2/c**2) * &
        b_k(n, lambda, sigma, zeta, kappa, c)
end if
end function

function get_asymptotic(r, E, c, kappa, zeta, n_terms, norm)
! Calculates the Dirac asymptotic with 'n_terms' terms
! n_terms ... 0, 1, 2, 3, ...
! With n_terms=0, we get the simplest asymptotic, with high n_terms, we get a
! very precise value
!
! Example (calculate 20 terms):
!    zeta = -V(i_max)*R(i_max)
!    Y = get_asymptotic(R(i_max), E, c, kappa, zeta, 20, .true.)
real(dp), intent(in) :: r, E, c, zeta
integer, intent(in) :: kappa, n_terms
logical, intent(in) :: norm ! .true. ... normalize the asymptotics
real(dp) :: get_asymptotic(2)

real(dp) :: lambda, sigma, a_term, b_term
real(dp), parameter :: norm_constant = 1e-12_dp
integer :: i
lambda = sqrt(c**2 - E**2/c**2)
sigma = E*zeta/(c**2*lambda)
a_term = 1
b_term = 0
do i = 1, n_terms
    a_term = a_term + a_k(i, lambda, sigma, zeta, kappa, c) / r**i
    b_term = b_term + b_k(i, lambda, sigma, zeta, kappa, c) / r**i
end do
a_term = a_term * sqrt((c**2+E)/(2*c**2))
b_term = b_term * sqrt((c**2-E)/(2*c**2))
get_asymptotic(1) = (a_term + b_term)
get_asymptotic(2) = (a_term - b_term)
if (norm) then
    ! Normalized, so that P(r) = norm_constant:
    get_asymptotic = get_asymptotic / get_asymptotic(1) * norm_constant
else
    ! Correct asymptotic form:
    get_asymptotic = get_asymptotic * r**sigma * exp(-lambda*r)
end if
end function

subroutine integrate_radial_dirac_r_rk4(c, kappa, Z, E, R, V, Vmid, P, Q, imax)
!integrates the Dirac eq, returns r*R, where R is the radial
!solution.
! input parameters:
! kappa .... the kappa in the Dirac eq.
! Z .... the nucleus charge in Hartree atomic units
! E .... the energy at which to integration the equation
! R .... radial grid
! V .... potential on the radial grid
! c .... speed of light
! output parameters:
! Q .... f-component of the radial dirac wave function
! P .... g-component of the radial dirac wave function
real(dp), intent(in) :: c
integer, intent(in) :: kappa
integer, intent(in) :: Z
real(dp), intent(in) :: E
real(dp), intent(in) :: R(:)
real(dp), intent(in) :: V(:), Vmid(:)
real(dp), intent(out) :: Q(:)
real(dp), intent(out) :: P(:)
integer, intent(out) :: imax

real(dp), parameter :: max_val = 1e6_dp
real(dp) :: y(2)
real(dp), dimension(size(R), 2, 2) :: Ctot
real(dp), dimension(size(R)-1, 2, 2) :: Cmid
real(dp), dimension(size(R)-1) :: Rmid

real(dp) :: beta, Z1
integer :: l

beta = sqrt(kappa**2-(Z/c)**2)
if (Z /= 0) then
    y(1) = R(1)**beta
    y(2) = R(1)**beta * c * (beta + kappa) / Z
else
    Z1 = V(1)
    if (kappa < 0) then
        l = -kappa-1
        y(1) = +R(1)**(l+1)
        y(2) = +R(1)**(l+2) * (E + Z1) / (c*(2*l+3))
    else
        l = kappa
        y(1) = -R(1)**(l+2) * (E + Z1) / (c*(2*l+1))
        y(2) = +R(1)**(l+1)
    end if
end if

Ctot(:, 1, 1) = -kappa / R
Ctot(:, 2, 2) = +kappa / R
Ctot(:, 1, 2) = +(E-V)/c + 2*c
Ctot(:, 2, 1) = -(E-V)/c

Rmid = (R(:size(R)-1) + R(2:)) / 2
Cmid(:, 1, 1) = -kappa / Rmid
Cmid(:, 2, 2) = +kappa / Rmid
Cmid(:, 1, 2) = +(E-Vmid)/c + 2*c
Cmid(:, 2, 1) = -(E-Vmid)/c
call rk4_integrate4(R, y, Ctot, Cmid, max_val, P, Q, imax)
end subroutine

end module


C      module PolicyMod
C        implicit none
C        type Policy
C          real beta
C          integer num_days
C        end type Policy
C      end module PolicyMod

      subroutine get_beta(intrinsic_growth_rate, gamma,
     &                    susceptible, relative_contact_rate,
     &                    beta)
        real intrinsic_growth_rate, susceptible, relative_contact_rate
        real inv_contact_rate, updated_growth_rate, gamma, beta

        inv_contact_rate = 1.0 - relative_contact_rate
        updated_growth_rate = intrinsic_growth_rate + gamma
        beta = updated_growth_rate / susceptible * inv_contact_rate
      end subroutine get_beta

      subroutine get_growth_rate(doubling_time, growth_rate)
        real doubling_time, growth_rate

        if (doubling_time .eq. 0.0) then
            growth_rate = 0.0
        else
          growth_rate = 2.0 ** (1.0 / doubling_time) - 1.0
        endif
      end subroutine get_growth_rate

      subroutine sir(s, i, r, beta, gamma, n)
        real s, i, r, n, s_n, i_n, r_n, beta, gamma, scale
        s_n = (-beta * s * i) + s
        i_n = (beta * s * i - gamma * i) + i
        r_n = gamma * i + r

        scale = n / (s_n + i_n + r_n)

        s = s_n * scale
        i = i_n * scale
        r = r_n * scale
      end subroutine sir

      subroutine sim_sir(s_n, i_n, r_n, gamma, i_day,
     &                   N_p, N_t, betas, days, T, S, E, I, R)
C        use PolicyMod
        real s_n, i_n, r_n, n, gamma, beta
        integer d, i_day, idx, d_idx, p_idx
        integer N_d, N_p, N_t, T(N_t), days(N_p)
C        type (Policy) policies(N_p)
        real S(N_t), E(N_t), I(N_t), R(N_t) betas(N_p)

        n = s_n + i_n + r_n
        d = i_day

        idx = 1
        do p_idx = 1, N_p
          beta = betas(p_idx)
          N_d = days(p_idx)
          do d_idx = 1, N_d
            T(idx) = d
            S(idx) = s_n
            I(idx) = i_n
            R(idx) = r_n
            idx = idx + 1
            call sir(s_n, i_n, r_n, beta, gamma, n)
            d = d + 1
          enddo
        enddo

        T(idx) = d
        S(idx) = s_n
        I(idx) = i_n
        R(idx) = r_n
      end subroutine sim_sir

      program main
C        use PolicyMod
        implicit none
        real s_n, i_n, r_n, beta, doubling_time, growth_rate
        integer p_idx
        integer, parameter :: i_day = 17, n_days = 20
        integer, parameter :: N_p = 3, N_t = 121, infectious_days = 14
        real, parameter :: relative_contact_rate = 0.05
        real, parameter :: gamma = 1.0 / infectious_days
        real, dimension(1:N_p) :: policy_betas
        integer, dimension(1:N_p) :: policy_days
        integer, dimension(1:N_t) :: T
        real, dimension(1:N_t) :: S, E, I, R

        s_n = 1000
        i_n = 0
        r_n = 0

        do p_idx = 1, N_p
          doubling_time = (p_idx - 1.0) * 5.0
          call get_growth_rate(doubling_time, growth_rate)
          call get_beta(growth_rate, gamma, s_n,
     &                  relative_contact_rate, beta)
          policy_betas(p_idx) = beta
          policy_days(p_idx) = n_days * p_idx
        end do

        call sim_sir(s_n, i_n, r_n, gamma, i_day,
     &               N_p, N_t, policy_betas, policy_days,
     &               T, S, E, I, R)
        print*, s_n, i_n, r_n
        print*, E
      end program main


subroutine PlmON_d1(p, dp1, lmax, z, csphase, cnorm, exitstatus)
!------------------------------------------------------------------------------
!
!   This function evalutates all of the normalized associated Legendre
!   functions up to degree lmax. The functions are initially scaled by
!   10^280 sin^m in order to minimize the effects of underflow at large m
!   near the poles (see Holmes and Featherstone 2002, J. Geodesy, 76, 279-299).
!   On a macOS system with a maximum allowable double precision value of
!   2.225073858507203E-308 the scaled portion of the algorithm will not overflow
!   for degrees less than or equal to 2800.
!
!   For each value of m, the rescaling factor is computed as
!   rescalem=rescalem*sin(theta), with the intial value of rescalem being equal
!   to 1/scalef (which is here equal to 10^280). This will gradually reduce this
!   huge number to a tiny number, and will ultimately underflow. In order to
!   prevent this underflow, when rescalem becomes less than 10^(-280), the
!   subsequent rescaling factors of sin(theta) will be directly applied to Plm,
!   and then this number will be multipled by the old value of rescalem.
!
!   Temporary variables in saved in an allocated array. In order to explicitly
!   deallocate this memory, call this routine with a spherical harmonic degree
!   of -1.
!
!   Calling Parameters
!
!       OUT
!           p           A vector of all associated Legendgre polynomials
!                       evaluated at z up to lmax. The lenght must by greater or
!                       equal to (lmax+1)*(lmax+2)/2.
!           dp1         A vector of all first derivatives of the normalized
!                       Legendgre polynomials evaluated at z up to lmax with
!                       dimension (lmax+1).
!
!       IN
!           lmax        Maximum spherical harmonic degree to compute.
!           z           cos(colatitude) or sin(latitude).
!
!       OPTIONAL (IN)
!           csphase     1: Do not include the phase factor of (-1)^m
!                       -1: Apply the phase factor of (-1)^m.
!           cnorm       0: Use real normalization.
!                       1: Use complex normalization.
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Notes:
!
!   1.  The employed normalization is the "orthonormalized convention." The
!       integral of (plm*cos(m theta))**2 or (plm*sin (m theta))**2 over all
!       space is 1.
!   2.  The integral of plm**2 over (-1,1) is (2 - delta(0,m))/2pi. If CNORM=1,
!       then this is equal to 1/2pi.
!   3.  The index of the array p corresponds to l*(l+1)/2 + m + 1. As such
!       the array p should be dimensions as (lmax+1)*(lmax+2)/2 in the
!       calling routine.
!   4.  Derivatives are calculated using the unnormalized identities
!           P'l,m = ( (l+m) Pl-1,m - l z Plm ) / (1-z**2)   (for l>m), and
!           P'll = - l z Pll / (1-z**2) (for l=m).
!   5.  The derivative is not defined at z=+-1 for all m>0, and is therefore not
!       calculated here.
!   6.  The default is to exlude the Condon-Shortley phase of (-1)^m.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use SHTOOLS, only: CSPHASE_DEFAULT
    use ftypes

    implicit none

    integer, intent(in) :: lmax
    real(dp), intent(out) :: p(:), dp1(:)
    real(dp), intent(in) :: z
    integer, intent(in), optional :: csphase, cnorm
    integer, intent(out), optional :: exitstatus
    real(dp) :: pm2, pm1, pmm, plm, rescalem, pi, u, scalef
    real(dp), save, allocatable :: f1(:), f2(:), sqr(:)
    integer :: k, kstart, m, l, sdim, astat(3)
    integer, save :: lmax_old = 0
    integer(int1) :: phase

!$OMP    threadprivate(f1, f2, sqr, lmax_old)

    if (present(exitstatus)) exitstatus = 0

    if (lmax == -1) then
        if (allocated (sqr)) deallocate (sqr)
        if (allocated (f1)) deallocate (f1)
        if (allocated (f2)) deallocate (f2)
        lmax_old = 0
        return
    end if

    pi = acos(-1.0_dp)
    sdim = (lmax+1)*(lmax+2)/2

    if (size(p) < sdim) then
        print*, "Error --- PlmBar_d1"
        print*, "P must be dimensioned as (LMAX+1)*(LMAX+2)/2 " // &
                "where LMAX is ", lmax
        print*, "Input array is dimensioned ", size(p)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(dp1) < sdim) then
        print*, "Error --- PlmBar_d1"
        print*, "DP1 must be dimensioned as (LMAX+1)*(LMAX+2)/2 " // &
                "where LMAX is ", lmax
        print*, "Input array is dimensioned ", size(dp1)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (lmax < 0) then
        print*, "Error --- PlmBar_d1"
        print*, "LMAX must be greater than or equal to 0."
        print*, "Input value is ", lmax
        if (present(exitstatus)) then
            exitstatus = 2
            return
        else
            stop
        end if

    else if (abs(z) > 1.0_dp) then
        print*, "Error --- PlmBar_d1"
        print*, "ABS(Z) must be less than or equal to 1."
        print*, "Input value is ", z
        if (present(exitstatus)) then
            exitstatus = 2
            return
        else
            stop
        end if

    else if (abs(z) == 1.0_dp) then
        print*, "Error --- PlmBar_d1"
        print*, "Derivative can not be calculated at Z = 1 or -1."
        print*, "Input value is ", z
        if (present(exitstatus)) then
            exitstatus = 2
            return
        else
            stop
        end if

    end if

    if (present(csphase)) then
        if (csphase == -1) then
            phase = -1

        else if (csphase == 1) then
                phase = 1

        else
            print*, "Error --- PlmBar_d1"
            print*, "CSPHASE must be 1 (exclude) or -1 (include)."
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if

        end if

    else
        phase = CSPHASE_DEFAULT

    end if

    scalef = 1.0e-280_dp

    if (lmax > lmax_old) then
        if (allocated (sqr)) deallocate (sqr)
        if (allocated (f1)) deallocate (f1)
        if (allocated (f2)) deallocate (f2)

        allocate (sqr(2*lmax+1), stat=astat(1))
        allocate (f1((lmax+1)*(lmax+2)/2), stat=astat(2))
        allocate (f2((lmax+1)*(lmax+2)/2), stat=astat(3))

        if (astat(1) /= 0 .or. astat(2) /= 0 .or. astat(3) /= 0) then
            print*, "Error --- PlmON_d1"
            print*, "Problem allocating arrays SQR, F1 and F2", astat(1), &
                    astat(2), astat(3)
            if (present(exitstatus)) then
                exitstatus = 3
                return
            else
                stop
            end if
        end if

        !----------------------------------------------------------------------
        !
        !   Precompute square roots of integers that are used several times.
        !
        !----------------------------------------------------------------------
        do l = 1, 2 *lmax + 1
            sqr(l) = sqrt(dble(l))
        end do

        !----------------------------------------------------------------------
        !
        !   Precompute multiplicative factors used in recursion relationships
        !       Plmbar(l,m) = x*f1(l,m)*Plmbar(l-1,m) - Plmbar(l-2,m)*f2(l,m)
        !       k = l*(l+1)/2 + m + 1
        !   Note that prefactors are not used for the case when m=l and m=l-1,
        !   as a different recursion is used for these two values.
        !
        !----------------------------------------------------------------------
        k = 3

        do l = 2, lmax, 1
            k = k + 1
            f1(k) = sqr(2*l-1) * sqr(2*l+1) / dble(l)
            f2(k) = dble(l-1) * sqr(2*l+1) / sqr(2*l-3) / dble(l)

            do m = 1, l-2
                k = k + 1
                f1(k) = sqr(2*l+1) * sqr(2*l-1) / sqr(l+m) / sqr(l-m)
                f2(k) = sqr(2*l+1) * sqr(l-m-1) * sqr(l+m-1) &
                        / sqr(2*l-3) / sqr(l+m) / sqr(l-m)
            end do

            k = k + 2

        end do

        lmax_old = lmax

    end if

    !--------------------------------------------------------------------------
    !
    !   Calculate P(l,0). These are not scaled.
    !
    !--------------------------------------------------------------------------
    u = sqrt((1.0_dp - z) * (1.0_dp + z)) ! sin(theta)

    pm2 = 1.0_dp / sqrt(4*pi)
    p(1) = pm2
    dp1(1) = 0.0_dp

    if (lmax == 0) return

    pm1 = sqr(3) * z / sqrt(4 * pi)
    p(2) = pm1
    dp1(2) = sqr(3)  /sqrt(4 * pi)

    k = 2

    do l = 2, lmax, 1
        k = k + l
        plm = f1(k) * z * pm1 - f2(k) * pm2
        p(k) = plm
        dp1(k) = dble(l) * ( sqr(2*l+1) / sqr(2*l-1) * &
            pm1 - z * plm ) / u**2
        pm2 = pm1
        pm1 = plm
    end do

    !--------------------------------------------------------------------------
    !
    !   Calculate P(m,m), P(m+1,m), and P(l,m)
    !
    !--------------------------------------------------------------------------
    if (present(cnorm)) then
        if (cnorm == 1) then
            pmm = scalef/sqrt(4*pi)

        else
            pmm = sqr(2) * scalef / sqrt(4 * pi)

        end if

    else
        pmm = sqr(2) * scalef / sqrt(4 * pi)

    end if

    rescalem = 1.0_dp / scalef
    kstart = 1

    do m = 1, lmax - 1, 1
        rescalem = rescalem * u

        ! Calculate P(m,m)
        kstart = kstart + m + 1
        pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
        p(kstart) = pmm*rescalem
        dp1(kstart) = -m * z * p(kstart) / u**2
        pm2 = pmm

        ! Calculate P(m+1,m)
        k = kstart+m+1
        pm1 = z * sqr(2*m+3) * pmm
        p(k) = pm1*rescalem
        dp1(k) = ( sqr(2*m+3) * p(k-m-1) - z * (m+1) * p(k)) / u**2

        ! Calculate P(l,m)
        do l = m + 2, lmax, 1
            k = k + l
            plm = z * f1(k) * pm1 - f2(k) * pm2
            p(k) = plm * rescalem
            dp1(k) = ( sqr(2*l+1) * sqr(l-m) * sqr(l+m) / sqr(2*l-1) * &
                    p(k-l) - z * l * p(k)) / u**2
            pm2 = pm1
            pm1 = plm

        end do

    end do

    ! Calculate P(lmax,lmax)
    rescalem = rescalem * u

    kstart = kstart + m + 1
    pmm = phase * pmm * sqr(2*lmax+1) / sqr(2*lmax)
    p(kstart) = pmm*rescalem
    dp1(kstart) = -lmax * z * p(kstart) / u**2

end subroutine PlmON_d1


module bhmie_routine

  use types
  implicit none
  save

  real(dp),parameter :: pii = 3.14159265358979323846264338327950288419716939937510582097494_dp

contains

  subroutine bhmie(x,refrel,nang,s1,s2,qext,qsca,qback,gsca,angles)

    implicit none

    ! Declare parameters:

    integer,parameter :: nmxx=1000000

    ! Arguments:

    integer, intent(in) :: nang
    real(dp), intent(in) :: x
    complex(dp), intent(in) :: refrel
    complex(dp), dimension(:),intent(out) :: s1,s2
    real(dp), intent(out) :: gsca,qback,qext,qsca
    real(dp),intent(in),optional :: angles(:)

    ! Local variables:

    integer :: j,jj,n,nstop,nmx,nn
    real(dp) :: chi,chi0,chi1,dang,dx,en,fn,p,psi,psi0,psi1,theta,xstop,ymod
    real(dp), dimension(nang) :: amu, pi, pi0, pi1, tau
    complex(dp) :: an,an1,bn,bn1,drefrl,xi,xi1,y

    complex(dp),allocatable,dimension(:) :: d
    allocate(d(nmxx))

    !***********************************************************************
    !
    ! Subroutine BHMIE is derived from the Bohren-Huffman Mie scattering
    !     subroutine to calculate scattering and absorption by a homogenous
    !     isotropic sphere.
    ! Given:
    !    X = 2*pi*a/lambda
    !    REFREL = (complex refr. index of sphere)/(real index of medium)
    !    NANG = number of angles between 0 and 90 degrees
    !           (will calculate 2*NANG-1 directions from 0 to 180 deg.)
    !           if called with NANG<2, will set NANG=2 and will compute
    !           scattering for theta=0,90,180.
    ! Returns:
    !    S1(1 - 2*NANG-1) = -i*f_22 (incid. E perp. to scatt. plane,
    !                                scatt. E perp. to scatt. plane)
    !    S2(1 - 2*NANG-1) = -i*f_11 (incid. E parr. to scatt. plane,
    !                                scatt. E parr. to scatt. plane)
    !    QEXT = C_ext/pi*a**2 = efficiency factor for extinction
    !    QSCA = C_sca/pi*a**2 = efficiency factor for scattering
    !    QBACK = 4.*pi*(dC_sca/domega)/pi*a**2
    !          = backscattering efficiency
    !    GSCA = <cos(theta)> for scattering
    !
    ! S1 and S2 are the diagonal elements of the "amplitude scattering matrix"
    ! (see eq. 3.12 of Bohren & Huffman 1983) -- the off-diagonal elements
    ! vanish for a spherical target.
    ! For unpolarized incident light, the intensity of scattered light a
    ! distance r from the sphere is just
    !          1
    !  I_s = ------ * I_in * S_11
    !        (kr)^2
    !
    ! where k=2*pi/lambda
    ! and the "Muller matrix element" S_11 = 0.5*( |S_1|^2 + |S_2|^2 )
    !
    ! for incident light polarized perp to the scattering plane,
    ! the scattered light is polarized perp to the scattering plane
    ! with intensity I_s = I_in * |S_1|^2 / (kr)^2
    !
    ! for incident light polarized parallel to the scattering plane,
    ! the scattered light is polarized parallel to the scattering plane
    ! with intensity I_s = I_in * |S_2|^2 / (kr)^2
    !
    ! History:
    ! Original program taken from Bohren and Huffman (1983), Appendix A
    ! Modified by B.T.Draine, Princeton Univ. Obs., 90.10.26
    ! in order to compute <cos(theta)>
    ! 91.05.07 (BTD): Modified to allow NANG=1
    ! 91.08.15 (BTD): Corrected error (failure to initialize P)
    ! 91.08.15 (BTD): Modified to enhance vectorizability.
    ! 91.08.15 (BTD): Modified to make NANG=2 if called with NANG=1
    ! 91.08.15 (BTD): Changed definition of QBACK.
    ! 92.01.08 (BTD): Converted to full real(dp) and complex(dp)
    !                 eliminated 2 unneed lines of code
    !                 eliminated redundant variables (e.g. APSI,APSI0)
    !                 renamed RN -> EN = real(dp) N
    !                 Note that complex(dp) and DCMPLX are not part
    !                 of f77 standard, so this version may not be fully
    !                 portable.  In event that portable version is
    !                 needed, use src/bhmie_f77.f
    ! 93.06.01 (BTD): Changed AMAX1 to generic function MAX
    ! 98.09.17 (BTD): Added variable "SINGLE" and warning in event that
    !                 code is used with single-precision arithmetic (i.e.,
    !                 compiler does not support complex(dp))
    ! 99.02.17 (BTD): Replaced calls to REAL() and IMAG() by
    !                 REAL() and AIMAG() for compatibility with g77
    !                 Note that when code is used with standard f77
    !                 compilers, it is now necessary to enable two lines
    !                 defining functions REAL(X) and AIMAG(X)
    ! 99.02.19 (BTD): added lines to be enabled to properly define
    !                 REAL() and AIMAG() if NOT using g77
    !                 ***see below!!***
    ! 01.02.16 (BTD): added IMPLICIT NONE
    ! 01.02.27 (BTD): changed definition of QBACK back to convention of
    !                 Bohren & Huffman and others:
    !                 Q_back = 4.*pi*(dC_sca/dOmega)/(pi*a^2) in backward
    !                          direction
    ! 02.03.09 (BTD): defined statement function REAL_SP to
    !                 avoid warning regarding type conversion when taking
    !                 real part of S1(1) to evaluate QEXT
    !                 some cleanup regarding type conversion
    ! 02.05.30 (BTD): introduced internal complex(dp) arrays S1,S2
    !                 to possibly increase accuracy during summations.
    !                 After summations, output scattering amplitudes
    !                 via single complex arrays S1,S2 as before.
    !                 Usage of this routine is unaffected by change.
    !                 Note: no longer need statement function REAL_SP
    ! 02.09.18 (BTD): Error in evaluation of QBACK reported by Okada Yasuhiko
    !                 Was calculating QBACK using S1 rather than S1
    !                 Corrected.
    ! 02.10.16 (BTD): Added comments explaining definition of S_1 and S_2 .
    ! 10.07.23 (TPR): Converted to Fortran 95, and inputs and outputs have
    !                 64-bit precision. Added option to specify directly
    !                 which angles to compute the scattering matrix for.
    ! end history
    !
    !***********************************************************************

    !***********************************************************************
    !*** Safety checks

    if(nang.lt.2) stop "nang should be > 1"

    !*** Obtain pi:

    dx=x
    drefrl=refrel
    y=x*drefrl
    ymod=abs(y)

    !*** Series expansion terminated after NSTOP terms
    !    Logarithmic derivatives calculated from NMX on down

    xstop=x+4._dp*x**0.3333_dp+2._dp
    nmx=nint(max(xstop,ymod))+15
    nstop=nint(xstop)

    ! BTD experiment 91.1.15: add one more term to series and compare results
    !      NMX=MAX(XSTOP,YMOD)+16
    ! test: compute 7001 wavelengths between .0001 and 1000 micron
    ! for a=1.0micron SiC grain.  When NMX increased by 1, only a single
    ! computed number changed (out of 4*7001) and it only changed by 1/8387
    ! conclusion: we are indeed retaining enough terms in series!

    if(nmx.gt.nmxx)then
       write(0,*)'error: nmx > nmxx=',nmxx,' for |m|x=',ymod
       stop
    endif

    !*** Require NANG.GE.1 in order to calculate scattering intensities

    if(present(angles)) then

       if(size(angles).ne.nang) stop "The number of angles specified should be equal to nang"
       if(angles(1).ne.0.) stop "angles(1) should be 0."
       if(angles(nang).ne.pii/2.) stop "angles(nang) should be pi/2."

       amu = cos(angles)

    else

       dang=0.

       if(nang.gt.1) dang=.5_dp*pii/real(nang-1,dp)

       do j=1,nang
          theta=real(j-1,dp)*dang
          amu(j)=cos(theta)
       end do

    end if

    pi0=0._dp
    pi1=1._dp

    s1=(0._dp,0._dp)
    s2=(0._dp,0._dp)

    !*** Logarithmic derivative D(J) calculated by downward recurrence
    !    beginning with initial value (0.,0.) at J=NMX

    d(nmx)=(0._dp,0._dp)
    nn=nmx-1

    do n=1,nn
       en=nmx-n+1
       d(nmx-n)=(en/y)-(1._dp/(d(nmx-n+1)+en/y))
    end do

    !*** Riccati-Bessel functions with real argument X
    !    calculated by upward recurrence

    psi0=cos(dx)
    psi1=sin(dx)
    chi0=-sin(dx)
    chi1=cos(dx)
    xi1=cmplx(psi1,-chi1)
    qsca=0._dp
    gsca=0._dp
    p=-1._dp
    do n=1,nstop
       en=n
       fn=(2._dp*en+1._dp)/(en*(en+1._dp))

       ! for given N, PSI  = psi_n        CHI  = chi_n
       !              PSI1 = psi_{n-1}    CHI1 = chi_{n-1}
       !              PSI0 = psi_{n-2}    CHI0 = chi_{n-2}
       ! Calculate psi_n and chi_n

       psi=(2._dp*en-1._dp)*psi1/dx-psi0
       chi=(2._dp*en-1._dp)*chi1/dx-chi0
       xi=cmplx(psi,-chi)

       !*** Store previous values of AN and BN for use
       !    in computation of g=<cos(theta)>

       if(n.gt.1)then
          an1=an
          bn1=bn
       endif

       !*** Compute AN and BN:

       an=(d(n)/drefrl+en/dx)*psi-psi1
       an=an/((d(n)/drefrl+en/dx)*xi-xi1)
       bn=(drefrl*d(n)+en/dx)*psi-psi1
       bn=bn/((drefrl*d(n)+en/dx)*xi-xi1)

       !*** Augment sums for Qsca and g=<cos(theta)>

       qsca=qsca+(2._dp*en+1._dp)*(abs(an)**2+abs(bn)**2)
       gsca=gsca+(2._dp*en+1._dp)/(en*(en+1._dp))*(real(an)*real(bn)+aimag(an)*aimag(bn))
       if(n.gt.1)then
          gsca=gsca+(en-1._dp)*(en+1._dp)/en* &
               &      (real(an1)*real(an)+aimag(an1)*aimag(an)+ &
               &      real(bn1)*real(bn)+aimag(bn1)*aimag(bn))
       endif

       !*** Now calculate scattering intensity pattern
       !    First do angles from 0 to 90

       do j=1,nang
          jj=2*nang-j
          pi(j)=pi1(j)
          tau(j)=en*amu(j)*pi(j)-(en+1.)*pi0(j)
          s1(j)=s1(j)+fn*(an*pi(j)+bn*tau(j))
          s2(j)=s2(j)+fn*(an*tau(j)+bn*pi(j))
       end do

       !*** Now do angles greater than 90 using PI and TAU from
       !    angles less than 90.
       !    P=1 for N=1,3,...; P=-1 for N=2,4,...

       p=-p
       do j=1,nang-1
          jj=2*nang-j
          s1(jj)=s1(jj)+fn*p*(an*pi(j)-bn*tau(j))
          s2(jj)=s2(jj)+fn*p*(bn*pi(j)-an*tau(j))
       end do
       psi0=psi1
       psi1=psi
       chi0=chi1
       chi1=chi
       xi1=cmplx(psi1,-chi1)

       !*** Compute pi_n for next value of n
       !    For each angle J, compute pi_n+1
       !    from PI = pi_n , PI0 = pi_n-1

       do j=1,nang
          pi1(j)=((2._dp*en+1._dp)*amu(j)*pi(j)-(en+1._dp)*pi0(j))/en
          pi0(j)=pi(j)
       end do
    end do

    !*** Have summed sufficient terms.
    !    Now compute QSCA,QEXT,QBACK,and GSCA

    gsca=2._dp*gsca/qsca
    qsca=(2._dp/(dx*dx))*qsca
    qext=(4._dp/(dx*dx))*real(s1(1))
    qback=4._dp*(abs(s1(2*nang-1))/dx)**2

  end subroutine bhmie

end module bhmie_routine


      subroutine sorce(w,b)
!     to obtain velocity derivatives in radial flow
      use kinddefine
      use gg, only:g1,g7,g9,qt
      implicit none
      real(kind=K8) :: al,area,axw,aww,c2,c4,cww,dww,four,one,thr,two,ww
      real(kind=K8) :: ww1
      real(kind=K8),intent(in) :: w
      real(kind=K8),dimension(4),intent(out) :: b
      data one/1.d+0/,two/2.d+0/,thr/3.d+0/,four/4.d+0/
      ww=w*w
      al=g7*g9
      aww=al-ww
      ww1=ww-one
      area=(((al-one)/aww)**g1)/w
      b(1)=area**qt
      axw=al*ww1*b(1)
      b(2)=w*aww/axw/qt
      c2=thr/qt+al*(two-one/qt)
      c4=al+one/qt
      cww=ww*(c2-ww*c4)-al*(one+one/qt)
      b(3)=b(2)*cww/axw/ww1
      dww=(two*c2-four*c4*ww)/cww-four/ww1
      b(4)=b(3)*(b(3)/b(2)+w*b(2)*dww-one/b(1))
      end subroutine sorce