!
! Rate equations when D and T are at different temperatures.
!
      PROGRAM main
      USE physvars
      USE mathvars
      USE allocatablevars
        IMPLICIT NONE
        REAL     :: te, td, tt, ti, ne
        INTEGER  :: nni

        REAL,   DIMENSION(1:3,1:3) :: cab, a_ab
        REAL,   DIMENSION(1:3,1:3) :: cab_sing, a_ab_sing
        REAL,   DIMENSION(1:3,1:3) :: cab_reg, a_ab_reg
        REAL,   DIMENSION(1:3,1:3) :: cab_qm, a_ab_qm

        REAL    :: cint1, cint2
        INTEGER :: ia, ib

        REAL    :: a_tot, a_i, a_e, ac_tot, ac_i, ac_e, aq_tot, aq_i
        REAL    ::  aq_e, ac_s_i, ac_s_e, ac_r_i, ac_r_e, ep, zp, mp
!
! DT plasma with alpha particle projectile
!
       CALL define_plasma(te,td,tt,ne,nni) ! e-DT

        ep=1.
        mp=4*MPKEV
        zp=2.
!
! Plasma parameters
!
        ti=0.5*(td+tt) ! use average ion temp
        CALL write_output(te,ti,ne,nni,betab,zb,mb,nb)
!*!
! ======================================================
!*!
        CALL bps_rate_cab_matrix(nni, betab, zb, mb, nb, &
          cab, cab_sing, cab_reg, cab_qm)

        PRINT *, "cab:"
        PRINT *, cab(1,1:nni+1)
        PRINT *, cab(2,1:nni+1)
        PRINT *, cab(3,1:nni+1)
        PRINT *, ""
!*!
! ======================================================
!*!
        ep=1./betab(1)
        CALL bps_acoeff_ab_matrix(nni,ep,betab,zb,mb,nb,a_ab,a_ab_sing,a_ab_reg,a_ab_qm)
        PRINT *, "A_ab:"
        PRINT *, a_ab(1,1:nni+1)
        PRINT *, a_ab(2,1:nni+1)
        PRINT *, a_ab(3,1:nni+1)
        PRINT *, ""
!*!
! ======================================================
!*!
        ia=1
        ib=2
        zp=zb(ia)
        mp=mb(ia)
        CALL bps_acoeff_ab_matrix(nni,ep,betab,zb,mb,nb,a_ab,a_ab_sing,a_ab_reg,a_ab_qm)
        CALL bps_acoeff_ei_mass(nni, ep, zp, mp, betab, zb, mb, nb, &
            a_tot, a_i, a_e, ac_tot, ac_i, ac_e, aq_tot, aq_i, aq_e, &
            ac_s_i, ac_s_e, ac_r_i, ac_r_e)
        PRINT *, ia, ib, a_tot, a_e, a_i
        PRINT *, ia, ib, a_ab(1,1)+a_ab(1,2)+a_ab(1,3), a_ab(1,1), a_ab(1,2)+a_ab(1,3)
        PRINT *, ""
!*!
! ======================================================
!*!
        ia=2
        ib=3
        PRINT *, ""
        CALL c_from_a_integral(nni,ia,ib,betab,zb,mb,nb,cint1)
        PRINT *, 0, 0, cab(ia,ib)
        PRINT *, ia, ib, cint1
        ia=3
        ib=2
        CALL c_from_a_integral(nni,ia,ib,betab,zb,mb,nb,cint2)
        PRINT *, ia, ib, cint2
        PRINT *, ia, ib, 100*ABS(cint1-cint2)/cint1
        PRINT *, ia, ib, 100*ABS(cab(ia,ib)-cint2)/cint1
        PRINT *, ""

        ia=1
        ib=2
        CALL c_from_a_integral(nni,ia,ib,betab,zb,mb,nb,cint1)
        PRINT *, 0, 0, cab(ia,ib)
        PRINT *, ia, ib, cint1
        ia=2
        ib=1
        CALL c_from_a_integral(nni,ia,ib,betab,zb,mb,nb,cint2)
        PRINT *, ia, ib, cint2
        PRINT *, ia, ib, 100*ABS(cint1-cint2)/cint1
        PRINT *, ia, ib, 100*ABS(cab(ia,ib)-cint2)/cint1

        CALL close_output
        CALL close_plasma
      END PROGRAM main
!
! Returns the plasma species arrays: betab, mb, nb, zb
! Allocates other plasma arrays
!
      SUBROUTINE define_plasma(te, td, tt, ne, nni)
      USE allocatablevars
      USE physvars
        IMPLICIT NONE
        REAL                                :: te     ! [keV]
        REAL                                :: td     ! [keV]
        REAL                                :: tt     ! [keV]
        REAL                                :: ne     ! [cm^-3]
        INTEGER                             :: nni    ! number of ion species

!       REAL,    DIMENSION(:), ALLOCATABLE  :: betab  ! [1/keV]
!       REAL,    DIMENSION(:), ALLOCATABLE  :: mb     ! [keV]
!       REAL,    DIMENSION(:), ALLOCATABLE  :: nb     ! [cm^-3]
!       REAL,    DIMENSION(:), ALLOCATABLE  :: zb     ! [e]
!       REAL,    DIMENSION(:), ALLOCATABLE  :: gb, etab, mpb, mbpb

        te=10.   ! [keV] electron temp
        td=10.   ! [keV] deuteron temp
        tt=10.   ! [keV] triton   temp
        ne=1.E25 ! [cm^-3]

        nni=2  ! number of ion species
        ALLOCATE(betab(1:nni+1),zb(1:nni+1),mb(nni+1),nb(1:nni+1))   ! allocatablevars
        ALLOCATE(gb(1:nni+1),etab(1:nni+1),mpb(nni+1),mbpb(1:nni+1)) ! allocatablevars

        zb(1)=-1.      ! Species charges
        zb(2)=+1.      !
        zb(3)=+1.      !
        mb(1)=MEKEV    ! Species masses [keV]
        mb(2)=2*MPKEV  !
        mb(3)=3*MPKEV  !

!        mb(1)=MEKEV    ! Species masses [keV]
!        mb(2)=2*MEKEV  !
!        mb(3)=3*MEKEV  !

        betab(1)=1./te ! inverse temp array   [keV^-1]
        betab(2)=1./td !
        betab(3)=1./tt !

!
! Construct density and temperature arrays
!
        nb(1)=1.                          ! ONLY FOR EQUIMOLAR DT
        nb(2:nni+1)=1./(zb(2:nni+1)*nni)  ! charge neutrality
        nb=nb*ne                          ! number density array [cm^-3]
      END SUBROUTINE define_plasma

      SUBROUTINE close_plasma
      USE allocatablevars
        DEALLOCATE(betab,zb,mb,nb)   ! allocatablevars
        DEALLOCATE(gb,etab,mpb)      ! allocatablevars
!       DEALLOCATE(mb,nb,zb,betab,gb)
!       DEALLOCATE(ab,etab)
!       DEALLOCATE(mpb,mbpb)
!       DEALLOCATE(kb2)
      END SUBROUTINE close_plasma

      SUBROUTINE write_output(te,ti,ne,nni,betab,zb,mb,nb)
      USE physvars
        IMPLICIT NONE
        REAL,                        INTENT(IN) :: te     ! [keV]
        REAL,                        INTENT(IN) :: ti     ! [keV]
        REAL,                        INTENT(IN) :: ne     ! [cm^-3]
        INTEGER,                     INTENT(IN) :: nni    ! number of ion species
        REAL,    DIMENSION(1:nni+1), INTENT(IN) :: betab  ! [1/keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN) :: zb     ! [e]
        REAL,    DIMENSION(1:nni+1), INTENT(IN) :: mb     ! [keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN) :: nb     ! [cm^-3]
        REAL,    DIMENSION(1:nni+1) :: gb
        REAL     :: etae, ge, gi, ze
        REAL     :: ln_bps_mass, delta_mass
        REAL     :: c_ei_born, ln_bps_born
        REAL     :: c_ei_tot, c_ei_i,c_ei_e, c_eic_tot, c_eic_i, c_eic_e
        REAL     :: c_eiq_tot, c_eiq_i, c_eiq_e, c_eic_s_i, c_eic_s_e
        REAL     :: c_eic_r_i ,c_eic_r_e
        REAL,    DIMENSION(1:nni+1)  :: c_eib
        REAL,    DIMENSION(1:nni+1,1:nni+1)  :: c_ab, c_ab_sing, c_ab_reg, c_ab_qm
!
! open output files
!
        OPEN(UNIT=1, FILE="main.CeI.dat")
!
! write header
!
        WRITE(6,'(A)') '#'
        WRITE(6,'(A)') '#'
        WRITE(6,'(A, 3X,A17)') '#','Plasma Parameters'
        WRITE(6,'(A, 4X,A28, X,D12.4, X,D12.4)')  '#','electron and ion temp [keV]:', te, ti
        WRITE(6,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','number density nb   [cm^-3]:', nb
        WRITE(6,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','mass array mb         [amu]:', mb/AMUKEV
        WRITE(6,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','mass array mb         [keV]:', mb
        WRITE(6,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','charge array zb            :', zb
        WRITE(1,'(A)') '#'
        WRITE(1,'(A)') '#'
        WRITE(1,'(A, 3X,A17)') '#','Plasma Parameters'
        WRITE(1,'(A, 4X,A28, X,D12.4, X,D12.4)')  '#','electron and ion temp [keV]:', te, ti
        WRITE(1,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','number density nb   [cm^-3]:', nb
        WRITE(1,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','mass array mb         [amu]:', mb/AMUKEV
        WRITE(1,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','mass array mb         [keV]:', mb
        WRITE(1,'(A, 4X,A28, X,D12.4, X,5D12.4)') '#','charge array zb            :', zb
!
! Print plasma parameters
!
        CALL param(nni, betab, nb, gb, ge, gi, etae, ze)
        WRITE(6,'(A1, 2X,A9, 4X,A7, 4X,A7, 8X,A2, 7X,A2, 10X,A4, 9X,A9)') &
          '#','ne[cm^-3]','Te[keV]', 'Ti[keV]','ge','gi','etae','ze/2**1.5'
        WRITE(6,'(A1,11D12.4)') '#',ne, te, ti, ge, gi, etae, ze/2**1.5
        WRITE(1,'(A1, 2X,A9, 4X,A7, 4X,A7, 8X,A2, 7X,A2, 10X,A4, 9X,A9)') &
          '#','ne[cm^-3]','Te[keV]', 'Ti[keV]','ge','gi','etae','ze/2**1.5'
        WRITE(1,'(A1,11D12.4)') '#',ne, te, ti, ge, gi, etae, ze/2**1.5

        CALL bps_rate_cei_born(nni,betab,zb,mb,nb,ln_bps_born,c_ei_born)
        CALL bps_rate_cei_mass(nni, betab, zb, mb, nb, ln_bps_mass,   &
          delta_mass, c_ei_tot, c_ei_i,c_ei_e,c_eic_tot,c_eic_i,c_eic_e,    &
          c_eiq_tot,c_eiq_i,c_eiq_e, c_eic_s_i,c_eic_s_e,c_eic_r_i ,c_eic_r_e, c_eib)
        CALL bps_rate_cab_matrix(nni, betab, zb, mb, nb, &
            c_ab, c_ab_sing, c_ab_reg, c_ab_qm)

        WRITE(6,*) "-----------------------------------"
        WRITE(6,'(A14,E13.5,2X,A10)') "cei_born     :",c_ei_born, "[1/cm^3 s]"
        WRITE(6,'(A14,E13.5,2X,A10)') "cei_mass     :",c_ei_i,    "[1/cm^3 s]"
        WRITE(6,'(A14,E13.5,2X,A10)') "cab_mass_sum :",SUM(c_ab(1,2:nni+1)), "[1/cm^3 s]"
        WRITE(6,'(A14,E13.5)')        "% diff       :",100*ABS((c_ei_i-c_ei_born)/c_ei_i)
        WRITE(6,*) ""
        WRITE(6,'(A14,E13.5)')        "ln_bps_born  :",ln_bps_born
        WRITE(6,'(A14,E13.5)')        "ln_bps_mass  :",ln_bps_mass
        WRITE(6,'(A14,E13.5)')        "% diff       :",100*ABS((ln_bps_mass-ln_bps_born)/ln_bps_mass)
        WRITE(6,*) ""
        WRITE(6,'(A14,E13.5,2X,A10)') "cei_reg_mass :",c_eic_r_i,   "[1/cm^3 s]"
        WRITE(6,'(A14,E13.5,2X,A10)') "cei_sing_mass:",c_eic_s_i,   "[1/cm^3 s]"
        WRITE(6,'(A14,E13.5,2X,A10)') "cei_qm_mass  :",c_eiq_i,     "[1/cm^3 s]"
        WRITE(6,'(A14,E13.5,2X,A10)') "delta_mass   :",delta_mass
        WRITE(6,*) "-----------------------------------"
        WRITE(6,'(A14,E13.5,2X,A10)') "cab_reg_mass :",SUM(c_ab_reg(1,2:nni+1)),   "[1/cm^3 s]"
        WRITE(6,'(A14,E13.5,2X,A10)') "cab_sing_mass:",SUM(c_ab_sing(1,2:nni+1)),  "[1/cm^3 s]"
        WRITE(6,'(A14,E13.5,2X,A10)') "cab_qm_mass  :",SUM(c_ab_qm(1,2:nni+1)),    "[1/cm^3 s]"
        WRITE(6,*) "-----------------------------------"

        WRITE(1,*) "-----------------------------------"
        WRITE(1,'(A14,E13.5,2X,A10)') "cei_born     :",c_ei_born, "[1/cm^3 s]"
        WRITE(1,'(A14,E13.5,2X,A10)') "cei_mass     :",c_ei_i,    "[1/cm^3 s]"
        WRITE(1,'(A14,E13.5,2X,A10)') "cab_mass_sum :",SUM(c_ab(1,2:nni+1)), "[1/cm^3 s]"
        WRITE(1,'(A14,E13.5)')        "% diff       :",100*ABS((c_ei_i-c_ei_born)/c_ei_i)
        WRITE(1,*) ""
        WRITE(1,'(A14,E13.5)')        "ln_bps_born  :",ln_bps_born
        WRITE(1,'(A14,E13.5)')        "ln_bps_mass  :",ln_bps_mass
        WRITE(1,'(A14,E13.5)')        "% diff       :",100*ABS((ln_bps_mass-ln_bps_born)/ln_bps_mass)
        WRITE(1,*) ""
        WRITE(1,'(A14,E13.5,2X,A10)') "cei_reg_mass :",c_eic_r_i,   "[1/cm^3 s]"
        WRITE(1,'(A14,E13.5,2X,A10)') "cei_sing_mass:",c_eic_s_i,   "[1/cm^3 s]"
        WRITE(1,'(A14,E13.5,2X,A10)') "cei_qm_mass  :",c_eiq_i,     "[1/cm^3 s]"
        WRITE(1,'(A14,E13.5,2X,A10)') "delta_mass   :",delta_mass
        WRITE(1,*) "-----------------------------------"
        WRITE(1,'(A14,E13.5,2X,A10)') "cab_reg_mass :",SUM(c_ab_reg(1,2:nni+1)),   "[1/cm^3 s]"
        WRITE(1,'(A14,E13.5,2X,A10)') "cab_sing_mass:",SUM(c_ab_sing(1,2:nni+1)),  "[1/cm^3 s]"
        WRITE(1,'(A14,E13.5,2X,A10)') "cab_qm_mass  :",SUM(c_ab_qm(1,2:nni+1)),    "[1/cm^3 s]"
        WRITE(1,*) "-----------------------------------"
!
!      WRITE(6,'(A5, 2X,A7, 5X,A5, 7X,A3, 9X,A3, 9X,A6, 6X,A4, 8X,A4, 8X,A6, 6X,A4, 8X,A4)') &
!        "#  iu", "ep[keV]", "a_tot", "a_i", "a_e", "ac_tot", "ac_i_lim", "ac_e", &
!        "aq_tot", "aq_i", "aq_e"
!      WRITE(1,'(A)') "#"
!      WRITE(1,'(A5, 2X,A7, 5X,A5, 7X,A3, 9X,A3, 9X,A6, 6X,A4, 8X,A4, 8X,A6, 6X,A4, 8X,A4)') &
!        "#  iu", "ep[keV]", "a_tot", "a_i", "a_e", "ac_tot", "ac_i", "ac_e", "aq_tot", "aq_i","aq_e"
      END SUBROUTINE write_output
!
      SUBROUTINE close_output
      IMPLICIT NONE
      CLOSE(1)
      END SUBROUTINE close_output

      SUBROUTINE dedx_fr_acoeff_bps(nni,ep,zp,mp,betab,zb,mb,nb,  &
            dedx_a_tot, dedx_a_i, dedx_a_e, dedxc_a_tot, dedxc_a_i, dedxc_a_e, &
            dedxq_a_tot, dedxq_a_i, dedxq_a_e, dedxc_a_s_i, dedxc_a_s_e,       &
            dedxc_a_r_i, dedxc_a_r_e)

      USE physvars
      USE mathvars
        IMPLICIT NONE                                      ! Plasma:
        INTEGER,                     INTENT(IN)  :: nni    !  number of ions
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: betab  !  temp array [1/keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: mb     !  mass array [keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: nb     !  density [1/cc]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: zb     !  charge array
                                                           !
                                                           ! Projectile
        REAL,                        INTENT(IN)  :: ep     !  projectile energy [keV]
        REAL,                        INTENT(IN)  :: mp     !  projectile mass   [keV]
        REAL,                        INTENT(IN)  :: zp     !  projectile charge
                                                           !
                                                              ! dE/dx [MeV/micron]
        REAL,                        INTENT(OUT) :: dedx_a_tot  !  electron + ion
        REAL,                        INTENT(OUT) :: dedx_a_i    !  ion contribution
        REAL,                        INTENT(OUT) :: dedx_a_e    !  electron contribution
        REAL,                        INTENT(OUT) :: dedxc_a_tot !  classical
        REAL,                        INTENT(OUT) :: dedxc_a_i   !  classical
        REAL,                        INTENT(OUT) :: dedxc_a_e   !  classical
        REAL,                        INTENT(OUT) :: dedxq_a_tot !  quantum
        REAL,                        INTENT(OUT) :: dedxq_a_i   !  quantum
        REAL,                        INTENT(OUT) :: dedxq_a_e   !  quantum
        REAL,                        INTENT(OUT) :: dedxc_a_s_i
        REAL,                        INTENT(OUT) :: dedxc_a_s_e
        REAL,                        INTENT(OUT) :: dedxc_a_r_i
        REAL,                        INTENT(OUT) :: dedxc_a_r_e

        REAL :: a_tot_p, a_i_p, a_e_p, ac_tot_p, ac_i_p, ac_e_p, aq_tot_p, aq_i_p, aq_e_p
        REAL :: ac_s_i_p, ac_s_e_p, ac_r_i_p, ac_r_e_p
        REAL :: a_tot_m, a_i_m, a_e_m, ac_tot_m, ac_i_m, ac_e_m, aq_tot_m, aq_i_m, aq_e_m
        REAL :: ac_s_i_m, ac_s_e_m, ac_r_i_m, ac_r_e_m
        REAL :: a_tot,   a_i,   a_e,   ac_tot,   ac_i,   ac_e,   aq_tot,   aq_i,   aq_e
        REAL :: ac_s_i,ac_s_e, ac_r_i,ac_r_e
        REAL :: epm, epp, dep, dep2, te, ti

        te  =1./betab(1)
        ti  =1./betab(2)
        dep =ep*1.E-2
        dep2=2*dep

        dedx_a_tot  = 0 ! electron + ion
        dedx_a_i    = 0 ! ion contribution
        dedx_a_e    = 0 ! electron contribution
        dedxc_a_tot = 0 ! classical
        dedxc_a_i   = 0 ! classical
        dedxc_a_e   = 0 ! classical
        dedxq_a_tot = 0 ! quantum
        dedxq_a_i   = 0 ! quantum
        dedxq_a_e   = 0 ! quantum
        dedxc_a_s_i = 0
        dedxc_a_s_e = 0
        dedxc_a_r_i = 0
        dedxc_a_r_e = 0

        epp=ep+dep
        CALL bps_acoeff_ei_mass(nni,epp,zp,mp,betab,zb,mb,nb,a_tot_p,a_i_p, &
          a_e_p,ac_tot_p,ac_i_p,ac_e_p,aq_tot_p,aq_i_p,aq_e_p,ac_s_i_p,ac_s_e_p,&
          ac_r_i_p,ac_r_e_p)
!*!
!PRINT *, "**1:",ac_i_p, ac_e_p
!STOP
!*!

        epm=ep-dep
        CALL bps_acoeff_ei_mass(nni,epm,zp,mp,betab,zb,mb,nb,a_tot_m,a_i_m, &
          a_e_m,ac_tot_m,ac_i_m,ac_e_m,aq_tot_m,aq_i_m,aq_e_m,ac_s_i_m,ac_s_e_m,&
          ac_r_i_m,ac_r_e_m)

        CALL bps_acoeff_ei_mass(nni,ep,zp,mp,betab,zb,mb,nb,a_tot,a_i, &
          a_e,ac_tot,ac_i,ac_e,aq_tot,aq_i,aq_e,ac_s_i,ac_s_e,&
          ac_r_i,ac_r_e)

!       dedx_tot = (1 - te/ep)*a_tot  - te*(a_tot_p -a_tot_m)/(2*dep)
        dedx_a_i   = (1 - te/ep)*a_i    - ti*(a_i_p   -a_i_m)/dep2
        dedx_a_e   = (1 - te/ep)*a_e    - te*(a_e_p   -a_e_m)/dep2
        dedx_a_tot = dedx_a_e + dedx_a_i

!       dedxc_tot= (1 - te/ep)*ac_tot - te*(ac_tot_p-ac_tot_m)/(2*dep)
        dedxc_a_i  = (1 - te/ep)*ac_i   - ti*(ac_i_p  -ac_i_m)/dep2
        dedxc_a_e  = (1 - te/ep)*ac_e   - te*(ac_e_p  -ac_e_m)/dep2
        dedxc_a_tot= dedxc_a_e + dedxc_a_i

!       dedxq_tot= (1 - te/ep)*aq_tot - te*(aq_tot_p-aq_tot_m)/(2*dep)
        dedxq_a_i  = (1 - ti/ep)*aq_i   - ti*(aq_i_p  -aq_i_m)/dep2
        dedxq_a_e  = (1 - te/ep)*aq_e   - te*(aq_e_p  -aq_e_m)/dep2
        dedxq_a_tot= dedxq_a_e + dedxq_a_i
!
        dedxc_a_s_i=(1 - te/ep)*ac_s_i   - te*(ac_s_i_p  -ac_s_i_m)/dep2
        dedxc_a_s_e=(1 - te/ep)*ac_s_e   - te*(ac_s_e_p  -ac_s_e_m)/dep2
        dedxc_a_r_i=(1 - te/ep)*ac_r_i   - te*(ac_r_i_p  -ac_r_i_m)/dep2
        dedxc_a_r_e=(1 - te/ep)*ac_r_e   - te*(ac_r_e_p  -ac_r_e_m)/dep2

      END SUBROUTINE dedx_fr_acoeff_bps

!*!
! ====================================================================
!*!
      SUBROUTINE c_from_a_integral(nni, ia, ib, betab, zb, mb, nb, cint)
      USE bpsvars
      USE physvars
      USE mathvars
        IMPLICIT NONE
        INTEGER,                     INTENT(IN) :: nni    ! number of ion species
        INTEGER,                     INTENT(IN) :: ia     !
        INTEGER,                     INTENT(IN) :: ib     !
        REAL,    DIMENSION(1:nni+1), INTENT(IN) :: betab  ! [1/keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN) :: zb     ! [e]
        REAL,    DIMENSION(1:nni+1), INTENT(IN) :: mb     ! [keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN) :: nb     ! [cm^-3]
        REAL,                        INTENT(OUT):: cint   ! [cm^-3 s^-1]
        REAL  :: a_ab_sing
        REAL  :: a_ab_reg, a_ab_qm

        REAL,    PARAMETER :: UPM=0.7745966692E0
        REAL,    PARAMETER :: W13=0.5555555556E0, W2=0.8888888889E0
        REAL    ::xmin, xmax, dx, x, xm, y
        REAL    :: a_ab, ep, mp, zp, np, tp, cnvt
        INTEGER :: ic, nmax
        cint=0

        np=nb(ia)
        zp=zb(ia)
        mp=mb(ia)
        tp=1./betab(ia)

        xmin=0.
        xmax=10. ! automate this choice later.
        nmax=2000
        dx=(xmax-xmin)/nmax
        x=xmin-dx
        cint=0
        DO ic=1,nmax,2
!
           x=x+2.E0*dx
           ep=x*tp  ! following subroutine needs to return: A for general ia and ib
           CALL bps_acoeff_ab_mass(nni,ep,mp,zp,ia,ib,betab,zb,mb,nb,a_ab,a_ab_sing,a_ab_reg,a_ab_qm)
           y=a_ab*x*EXP(-x)
           cint=cint + W2*y
!
           xm=x-dx*UPM
           ep=xm*tp
           CALL bps_acoeff_ab_mass(nni,ep,mp,zp,ia,ib,betab,zb,mb,nb,a_ab,a_ab_sing,a_ab_reg,a_ab_qm)
           y=a_ab*xm*EXP(-xm)
           cint=cint + W13*y
!
           xm=x+dx*UPM
           ep=xm*tp
           CALL bps_acoeff_ab_mass(nni,ep,mp,zp,ia,ib,betab,zb,mb,nb,a_ab,a_ab_sing,a_ab_reg,a_ab_qm)
           y=a_ab*xm*EXP(-xm)
           cint=cint + W13*y
        ENDDO
        cint=cint*dx
        cint=SQRT(2./PI)*cint

        cint=cint*2*np*CC/SQRT(mp*tp)
        cnvt=1.E7         ! MeV/micron to keV/cm
        cint=cint*cnvt    ! [cm^-3 s^-1]

      END SUBROUTINE c_from_a_integral

!======================================
!
      SUBROUTINE coeff_bps2(nni, ep, zp, mp, betab, zb, mb, nb, &
            a_tot, a_i, a_e, ac_tot, ac_i, ac_e, aq_tot, aq_i, aq_e)
      USE physvars
      USE mathvars
        IMPLICIT NONE                                      ! Plasma:
        INTEGER,                     INTENT(IN)  :: nni    !  number of ions
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: betab  !  temp array [1/keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: mb     !  mass array [keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: nb     !  density [1/cc]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: zb     !  charge array
                                                           !
                                                           ! Projectile
        REAL,                        INTENT(IN)  :: ep     !  projectile energy [keV]
        REAL,                        INTENT(IN)  :: mp     !  projectile mass   [keV]
        REAL,                        INTENT(IN)  :: zp     !  projectile charge
                                                           !
                                                           ! A-coeffs [MeV/micron]
        REAL,                        INTENT(OUT) :: a_tot  !  electron + ion
        REAL,                        INTENT(OUT) :: a_i    !  ion contribution
        REAL,                        INTENT(OUT) :: a_e    !  electron contribution
        REAL,                        INTENT(OUT) :: ac_tot !  classical
        REAL,                        INTENT(OUT) :: ac_i   !  classical
        REAL,                        INTENT(OUT) :: ac_e   !  classical
        REAL,                        INTENT(OUT) :: aq_tot !  quantum
        REAL,                        INTENT(OUT) :: aq_i   !  quantum
        REAL,                        INTENT(OUT) :: aq_e   !  quantum

        REAL,    DIMENSION(1:nni+1)  :: mpb, mbpb, kb2, ab, ab2
        REAL                         :: vp, vp2, zp2, k, k2, kd, kd2, a, b, eta
        REAL                         :: ac_r, ac_s, aq
        REAL                         :: c1, c2
        INTEGER                      :: ib, nnb
!
! initialize components of A-coefficients
!
        a_tot = 0  ! electron + ion
        a_i   = 0  ! ion contribution
        a_e   = 0  ! electron contribution
        ac_tot= 0  ! classical total
        ac_e  = 0  ! classical electron
        ac_i  = 0  ! classical ion
        aq_tot= 0  ! quantum total
        aq_e  = 0  ! quantum electron
        aq_i  = 0  ! quantum ion
!
! vp = projectile speed [cm/s]
!
!            [ 2 Ep ]
!    = c sqrt[ ---- ]  where mp and Ep are in keV and
!            [ mpc2 ]  c is the speed of light in cm/s
!
!
!        ep^2 kb^2
! c1  =  --------- = 2 zp**2 * Be * kb^2 * a0  [keV/cm]
!           4 Pi                               [MeV/micron]
!
!       [ betab mbc2 ]^1/2  vp
! c2 =  |----------- |      --  [dimensionless]
!       [   2 Pi     ]      c2
!
! where
!          e^2
! Be  =  --------- = 13.606E-3   [keV]
!        8 Pi a0                 Bohr radius: a0=5.29E9 cm
!
        NNB = nni+1                 ! number of ions + electrons
        vp  = CC*SQRT(2*ep/mp)      ! [cm/s]
        vp2 = vp*vp                 ! [cm^2/s^2]
        kb2 = DEBYE2*zb*zb*nb*betab ! [1/cm^2]
        kd2 = SUM(kb2)              ! [1/cm^2]
        kd  = SQRT(kd2)             ! [1/cm]
        k2  = kb2(1)                ! [1/cm^2]
        k   = SQRT(k2)              ! [1/cm]   k = k_e
        zp2 = zp**2                 ! [dimensionless]
                                    ! ab=(1/2) betab(ib)*mbc2(ib)*vp2/CC2
        ab  =0.5*betab*mb*vp2/CC2   ! [dimensionless]
        ab2 = SQRT(ab)              ! [dimensionless]
        mpb = mp*mb/(mp+mb)         ! [keV]
        mbpb= mb/mpb                ! [dimensionless]
!
! Loop over charged plasma species
!
        DO ib=1,nni+1
        IF (zb(ib) .NE. 0.) THEN
           a  =ab(ib)
           b  =-Log( 2*betab(ib)*BEKEV* ABS(zp*zb(ib))*k*A0CM*mbpb(ib) ) - &
             2*GAMMA + 2
           eta=ABS(zp*zb(ib))*2.1870E8/vp ! defined with projectile velocity vp

           c1=2*zp2*BEKEV*kb2(ib)*A0CM ! [keV/cm]
           c1=c1*1.E-7               ! [MeV/micron]
           c2=SQRT(a/PI)             ! [dimensionless]
                                     ! c2=SQRT(betab(ib)*mb(ib)/TWOPI)*vp/CC
!
! A-classical-singular
!
           CALL a_sing2(a,b,ac_s)
           ac_s=c1*c2*ac_s
!
! A-classical-regular
!
           CALL a_reg2(ib,nni,vp,k2,kb2,betab,mb,ac_r)
           ac_r=c1*ac_r
!
! A-quantum
!
           CALL a_quantum2(ib,a,eta,aq) ! eta = dimensionless quantum param.
           aq=c1*c2*aq
!
! construct electron and ion components
!
           CALL a_collect(ib,NNB,ac_s,ac_r,aq,a_tot,a_e,a_i,&
             ac_tot,ac_e,ac_i,aq_tot,aq_e,aq_i)
        ENDIF
        ENDDO
      END SUBROUTINE coeff_bps2

!======================================
! Singular contribution: short distance
!
      SUBROUTINE a_sing2(a, b, ac_s)
        REAL,    INTENT(IN)  :: a
        REAL,    INTENT(IN)  :: b
        REAL,    INTENT(OUT) :: ac_s
        REAL                 :: u0, u1, du, u, um
        INTEGER, PARAMETER :: NS=1000 ! integration regions: must be even
        REAL,    PARAMETER :: UPM=0.7745966692E0 ! parameters for Gaussian Quad
        REAL,    PARAMETER :: W13=0.5555555556E0, W2=0.8888888889E0
           ac_s=0
           u0=0
           u1=1
           du=(u1-u0)/NS
           u=u0-du
           DO iu=1,NS,2 ! Gaussian quadrature
              u=u+2.E0*du
              ac_s=ac_s+W2*dab_sing2(u,a,b)
              um=u-du*UPM
              ac_s=ac_s+W13*dab_sing2(um,a,b)
              um=u+du*UPM
              ac_s=ac_s+W13*dab_sing2(um,a,b)
           ENDDO
           ac_s=ac_s*du
      END SUBROUTINE a_sing2
!
      FUNCTION dab_sing2(u, a, b)
        IMPLICIT NONE
        REAL,        INTENT(IN)  :: u        ! [dimensionless]
        REAL,        INTENT(IN)  :: a        ! [dimensionless]
                                             ! a=(1/2)*beta*mpc2*vp^2/C^2
        REAL,        INTENT(IN)  :: b        ! [dimensionless]
        REAL                     :: dab_sing2 ! [dimensionless]
        dab_sing2=SQRT(u)*EXP(-a*u)*(-LOG(u/(1-u)) + b)
      END FUNCTION dab_sing2
!
!======================================

!======================================
! Regular contribution: long distance
!
      SUBROUTINE a_reg2(ib, nni, vp, k2, kb2, betab, mb, ac_r)
        INTEGER,                     INTENT(IN)  :: ib
        INTEGER,                     INTENT(IN)  :: nni
        REAL,                        INTENT(IN)  :: k2
        REAL,                        INTENT(IN)  :: kb2
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: betab
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: mb
        REAL,                        INTENT(OUT) :: ac_r
        REAL               :: u0, u1, du, u, um
        INTEGER, PARAMETER :: NR=10 ! integration regions: must be even
        REAL,    PARAMETER :: UPM=0.7745966692E0 ! parameters for Gaussian Quad
        REAL,    PARAMETER :: W13=0.5555555556E0, W2=0.8888888889E0
        ac_r=0
        u0=0.
        u1=1.
        du=(u1-u0)/NR
        u=u0-du
        DO iu=1,NR,2 ! Gaussian quadrature
           u=u+2.E0*du
           ac_r=ac_r+W2*dab_reg2(u,vp,ib,nni,k2,kb2,betab,mb)
           um=u-du*UPM
           ac_r=ac_r+W13*dab_reg2(um,vp,ib,nni,k2,kb2,betab,mb)
           um=u+du*UPM
           ac_r=ac_r+W13*dab_reg2(um,vp,ib,nni,k2,kb2,betab,mb)
        ENDDO
        ac_r=ac_r*du
      END SUBROUTINE a_reg2
!
      FUNCTION dab_reg2(u, vp, ib, nni, k2, kb2, betab, mb)
      USE mathvars
      USE physvars
        IMPLICIT NONE
        REAL,                        INTENT(IN)  :: u       !  [dimensionless]
        REAL,                        INTENT(IN)  :: vp      !  Projectile velocity [cm/s]
        INTEGER,                     INTENT(IN)  :: ib      !  Species number
        INTEGER,                     INTENT(IN)  :: nni     !  Number of ion species
        REAL,                        INTENT(IN)  :: k2      !  Wave-number squared [1/cm^2]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: kb2     !  Debye wavenumber squared [1/cm^2]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: betab   !  Temperature array [1/keV]
        REAL,    DIMENSION(1:nni+1), INTENT(IN)  :: mb      !  Mass array [keV]
        REAL                                     :: dab_reg2 !  [dimensionless]
        REAL,    DIMENSION(1:nni+1) :: alfb, ab
        REAL                        :: fr, fi, fabs, farg, h
        REAL                        :: kcb, r_ib, bm_ic, bm_ib, a_ic, a_ib, ex, au
        INTEGER                     :: ic
        ab=SQRT(0.5*betab*mb)*vp/CC
        alfb=kb2/k2
        CALL frfi(u,nni,alfb,ab,fr,fi,fabs,farg)
        h=2*(fr*farg + fi*LOG(fabs))
!
! construct spectral weight ratio Rb=rho_b/rho_tot
!
        r_ib=0
        bm_ib=betab(ib)*mb(ib)
        a_ib =ab(ib)*ab(ib)
        DO ic=1,nni+1
           kcb=kb2(ic)/k2
           bm_ic=betab(ic)*mb(ic)
           a_ic =ab(ic)*ab(ic)
           IF (ic == ib) THEN
              ex=1
           ELSE
              au=(a_ic-a_ib)*u
              ex=EXP(-au)
           ENDIF
           r_ib=r_ib + kcb*SQRT(bm_ic/bm_ib)*ex
        ENDDO
        r_ib=1/r_ib
        dab_reg2=-u*r_ib*h/TWOPI
      END FUNCTION dab_reg2
!
!======================================

!======================================
!
      SUBROUTINE a_quantum2(ib, a, eta, aq)
        IMPLICIT NONE
        INTEGER, INTENT(IN)  :: ib    ! species index
        REAL,    INTENT(IN)  :: a     ! [dimensionless] (1/2) betab mb vp^2
        REAL,    INTENT(IN)  :: eta   ! [dimensionless] ep eb/4pi hbar vp
        REAL,    INTENT(OUT) :: aq
        REAL               :: u0, u1, du, u, um
        INTEGER, PARAMETER :: NQ=1000            ! integration regions quantum : must be even
        REAL,    PARAMETER :: UPM=0.7745966692E0 ! parameters for Gaussian Quad
        REAL,    PARAMETER :: W13=0.5555555556E0, W2=0.8888888889E0
        REAL    :: daq2
        INTEGER :: iu
        aq=0
        u0=0.
        aq=0
        IF (ib == 1) THEN
           u0=0
           u1=4./SQRT(a)
        ELSE
           u0=1-10./SQRT(a)
           u0=MAX(0.,u0)
           u1=1+10./SQRT(a)
        ENDIF
        du=(u1-u0)/NQ
        u=u0-du
        DO iu=1,NQ,2 ! Gaussian quadrature
           u=u+2.E0*du
           aq=aq+W2*daq2(u,a,eta)
           um=u-du*UPM
           aq=aq+W13*daq2(um,a,eta)
           um=u+du*UPM
           aq=aq+W13*daq2(um,a,eta)
        ENDDO
        aq=aq*du
      END SUBROUTINE a_quantum2
!
      FUNCTION daq2(u, a, eta)
      USE physvars
        IMPLICIT NONE
        REAL,                        INTENT(IN)  :: u          ! [dimensionless]
        REAL,                        INTENT(IN)  :: a          ! [dimensionless]
        REAL,                        INTENT(IN)  :: eta        ! [dimensionless]
        REAL                                     :: daq2  ! [dimensionless]
        REAL            :: repsi, au, eu, au2, ap, am, psilog, ch, sh, csh
        eu=eta/u
        psilog=repsi(eu) - LOG(eu)
        au =2*a*u
        au2=a*u*u
        ap = au-au2-a
        am =-au-au2-a
        ch =0.5*(EXP(ap)+EXP(am))
        sh =0.5*(EXP(ap)-EXP(am))
        csh=2*(ch - sh/au)/au
        daq2=-psilog*csh
      END FUNCTION daq2
!======================================


      SUBROUTINE CSPLINE (TAU, C, N, IBCBEG, IBCEND, NDIM)

!  TAKEN FROM "A PRACTICAL GUIDE TO SPLINES", BY CARL DE BOOR. 1978.
!  SPRINGER-VERLAG.  THE INPUT PARAMETER "NDIM" HAS BEEN ADDED TO
!  ALLOW FOR MULTIPLE CALLS WITH DIFFERENT VALUES OF N. - DENNIS DUNDORE

!  SUBSTANTIAL MODIFICATIONS MADE BY STEVE WALES, APRIL 1983,
!  PRINCIPALLY TO HANDLE COMPLEX NUMBERS (C) & UPDATE THE FORTRAN.

! *****************************  I N P U T  ****************************

!  N = NUMBER OF DATA POINTS.  ASSUMED TO BE .GE. 2.

!  (TAU(I), C(1,I),I=1,...,N) = ABSCISSAE AND ORDINATES OF THE DATA
!      POINTS.  TAU IS ASSUMED TO BE STRICTLY INCREASING.

!  IBCBEG, IBCEND = BOUNDARY CONDITION INDICATORS, AND
!  C(2,1), C(2,N) = BOUNDARY CONDITION INFORMATION.  SPECIFICALLY,
!      IBCBEG = 0 IMPLIES NO BOUNDARY CONDITION AT TAU(1) IS GIVEN.
!            IN THIS CASE, THE "NOT-A-KNOT" CONDITION IS USED, IE THE
!            JUMP IN THE 3-RD DERIVATIVE ACROSS TAU(2) IS FORCED TO 0.,
!            THUS THE 1-ST AND 2-ND POLYNOMIAL PIECES ARE MADE TO
!            COINCIDE.
!      IBCBEG = 1 IMPLIES THAT THE SLOPE AT TAU(1) IS SET EQUAL TO C(2,1)
!            INPUT BY USER.
!      IBCBEG = 2 IMPLIES THAT THE 2-ND DERIVATIVE AT TAU(1) IS SET EQUAL
!            TO C(2,1), SUPPLIED BY INPUT.
!      IBCEND = 0, 1, OR 2 HAS ANALOGOUS MEANING CONCERNING THE BOUNDARY
!            CONDITION AT TAU(N), WITH INFORMATION SUPPLIED BY C(2,N).

!  NDIM = ROW DIMENSION OF C MATRIX:  C(4,NDIM)

! **************************  O U T P U T  ****************************

!  C(J,I), J=1,...,4;  I=1,...,L=N-1  =  THE POLY COEFFS OF THE CUBI!
!      SPLINE WITH INTERIOR KNOTS TAU(2),...,TAU(N-1).  PRECISELY, IN THE
!      INTERVAL (TAU(I), TAU(I+1)), THE SPLINE F IS GIVEN BY

!       F(X) = C(1,I) + H*(C(2,I) + H*(C(3,I)/2. + H*C(4,I)/6.))

!      WHERE H = X - TAU(I).

!     THE COEFFICIENTS CALCULATED ARE, 1) THE VALUE, 2) THE SLOPE, AND
!     3) THE CURVATURE AT EACH OF THE KNOTS 1 TO N-1, AND 4) THE RATE OF
!     CHANGE OF THE CURVATURE OVER THE FOLLOWING INTERVAL.  IN ADDITION,
!     WE HAVE THE VALUE AND THE SLOPE AT THE LAST POINT. THE LAST TWO
!     POSTIONS AT THE LAST POINT ARE THEN SET TO THE CURVATURE AT THAT
!     POINT (IN C(3,N)) AND THE MEAN VALUE OVER THE ENTIRE INTERVAL,
!     CALCULATED AS THE INTEGRAL OVER THE INTERVAL DIVIDED BY THE LENGTH
!     OF THE INTERVAL (IN C(4,N)).

! **********************************************************************

      IMPLICIT REAL (KIND=8) (A-H,O-Z)
      REAL (KIND=8) ::    TAU(N)
      REAL (KIND=8) :: C(4,NDIM), G, DTAU, DIVDF1, DIVDF3

      L = N - 1

      DO 10 M = 2,N
          C(3,M) = TAU(M) - TAU(M-1)
          C(4,M) = (C(1,M) - C(1,M-1)) / C(3,M)
   10 CONTINUE

!   * BEGINNING BOUNDARY CONDITION SECTION *

      IF (IBCBEG == 0)  THEN   ! IBCBEG = 0
          IF (N.GT.2)  THEN    !     N > 2
              C(4,1) = C(3,3)
              C(3,1) = C(3,2) + C(3,3)
              C(2,1) = ((C(3,2) + 2.0*C(3,1))*C(4,2)*C(3,3) + &
                             C(3,2)**2 * C(4,3)) / C(3,1)
            ELSE                                        !     N = 2
              C(4,1) = 1.0
              C(3,1) = 1.0
              C(2,1) = 2.0 * C(4,2)
          END IF

      ELSE IF (IBCBEG == 1)  THEN   ! IBCBEG = 1
          C(4,1) = 1.0
          C(3,1) = 0.0

      ELSE IF (IBCBEG == 2)  THEN   ! IBCBEG = 2
          C(4,1) = 2.0
          C(3,1) = 1.0
          C(2,1) = 3.0*C(4,2) - C(2,1)*C(3,2)/2.0
      END IF

!   * RUNNING CALCULATIONS TO N-1 - LOOP IS NOT EXECUTED IF N = 2 *

      DO 20 M = 2,L
          G = -C(3,M+1) / C(4,M-1)
          C(2,M) = G*C(2,M-1) + 3.0*(C(3,M)*C(4,M+1) + C(3,M+1)*C(4,M))
          C(4,M) = G*C(3,M-1) + 2.0*(C(3,M) + C(3,M+1))
   20 CONTINUE

!   * ENDING BOUNDARY CONDITION SECTION *

      IF (IBCEND /= 1)  THEN
          IF (IBCEND == 0)  THEN
                IF (N == 2 .AND. IBCBEG == 0)  THEN
                  C(2,N) = C(4,N)
              ELSE IF ((N == 3 .AND. IBCBEG == 0) .OR. N == 2)  THEN
                  C(2,N) = 2.0 * C(4,N)
                  C(4,N) = 1.
                  G = -1.0 / C(4,N-1)
              ELSE
                  G = C(3,N-1) + C(3,N)
                  C(2,N) = ((C(3,N) + 2.0*G) * C(4,N)*C(3,N-1) + &
                        C(3,N)**2 * (C(1,N-1)-C(1,N-2)) / C(3,N-1)) / G
                  G = -G / C(4,N-1)
                  C(4,N) = C(3,N-1)
              END IF

          ELSE IF (IBCEND == 2)  THEN
              C(2,N) = 3.0 * C(4,N) + C(2,N)*C(3,N)/2.0
              C(4,N) = 2.0
              G = -1.0 / C(4,N-1)
          END IF

          IF ( IBCBEG.GT.0 .OR. N.GT.2)  THEN
              C(4,N) = G*C(3,N-1) + C(4,N)
              C(2,N) = (G*C(2,N-1) + C(2,N)) / C(4,N)
          END IF
      END IF

!   * RUN THE ENDING BOUNDARY EFFECT BACK THROUGH THE EQUATIONS *

      DO 40 J = L,1,-1
          C(2,J) = (C(2,J) - C(3,J)*C(2,J+1)) / C(4,J)
   40 CONTINUE

!   * FINAL CALCULATIONS *

      DO 50 I = 2,N
          DTAU = C(3,I)
          DIVDF1 = (C(1,I)-C(1,I-1)) / DTAU
          DIVDF3 = C(2,I-1) + C(2,I) - 2.0*DIVDF1
          C(3,I-1) = 2.0 * (DIVDF1-C(2,I-1)-DIVDF3) / DTAU
          C(4,I-1) = (DIVDF3/DTAU) * (6.0/DTAU)
   50 CONTINUE

!     * ADD THE CURVATURE AT THE LAST POINT IN THE THIRD POSITION OF THE
!       LAST NODE *

      C(3,N) = C(3,L) + (TAU(N)-TAU(L)) * C(4,L)

!     * ADD THE MEAN VALUE OF THE ENTIRE INTERVAL IN THE FOURTH POSITION OF
!       THE LAST NODE.  MEAN VALUE IS CALCULATED AS THE INTEGRAL OVER THE
!       INTERVAL DIVIDED BY THE LENGTH OF THE INTERVAL. *

      C(4,N) = 0.0
      DO 60 I = 1,L   ! INTEGRATE OVER THE INTERVAL
          DTAU = TAU(I+1) - TAU(I)
          C(4,N) = C(4,N) + DTAU*(C(1,I) + DTAU*(C(2,I)/2.0 +     &
                            DTAU*(C(3,I)/6.0 + DTAU*C(4,I)/24.0)))
   60 CONTINUE
      C(4,N) = C(4,N) / (TAU(N)-TAU(1))   ! DIVIDE BY LENGTH OF INTERVAL

      RETURN
      END

      SUBROUTINE VSPLINE (TAU, C, M, MDIM, F, N)

!     VSPLINE CALCULATES THE CUBIC SPLINE VALUES FOR A SET OF N POINTS
!     IN F FROM THE M-POINT CUBI! SPLINE FIT IN ! AND THE NODES IN TAU.
!     THE POINTS ARE RETURNED IN F.  ALL OF THE POINTS IN F MUST LIE
!     BETWEEN TAU(1) AND TAU(M).

!     * * * * * * * * * * * * *   WARNINGS   * * * * * * * * * * * * *

!     POINTS OUTSIDE OF THE SPLINE FIT REGION ARE EXTRAPOLATED FROM THE END
!     INTERVALS.  THIS CAN RESULT IN WILD VALUES IF EXTRAPOLATED TOO FAR.
!     ALSO THE POINTS MUST BE IN STRICTLY ASCENDING ORDER, IF NOT THE
!     POINTS WHICH ARE OUT OF ORDER WILL BE EXTRAPOLATED FROM THE CURRENT
!     INTERVAL AGAIN RESULTING IN WILD VALUES.

      IMPLICIT REAL (KIND=8) (A-H,O-Z)
      REAL (KIND=8) ::     TAU(M)
      REAL (KIND=8) :: C(4,MDIM), F(N), SPLINE

      J = 1
      DO 20 I = 1,N
   10 J1 = J + 1
      IF (TAU(J1).LT.REAL(F(I)) .AND. J1.LT.M) THEN ! CHECK TO MAKE SURE
           J = J + 1   ! THIS POINT IS NOT
           GO TO 10    ! IN THE NEXT INTERVAL.
      END IF
      H = DBLE (F(I)) - TAU(J)   ! DISTANCE FROM START OF INTERVAL
      F(I) = SPLINE (C(1,J), H)
   20 CONTINUE
      RETURN
      END
!**********************************************************************C
      FUNCTION SPLINE ( C, H )

!     THIS FUNCTION EVALUATES THE SPLINE AT THE POINT H

      IMPLICIT REAL (KIND=8) ( A-H, O-Z )
      REAL (KIND=8) C(4), SPLINE

      SPLINE = C(1) + H * ( C(2) + H * ( C(3) / 2.0 + H * C(4) / 6.0 ) )
      RETURN
      END

      FUNCTION SPLINEX ( C, H )

!     THIS FUNCTION EVALUATES THE SPLINE DERIVATIVE AT THE POINT H

      IMPLICIT REAL (KIND=8) ( A-H, O-Z )
      REAL (KIND=8) :: C(4), SPLINEX

      SPLINEX = C(2) + H * ( C(3) + H * C(4) / 2.0 )
      RETURN
      END

      FUNCTION SPLINEXX ( C, H )

!     THIS FUNCTION EVALUATES THE SPLINE 2ND DERIVATIVE AT THE POINT H

      IMPLICIT REAL (KIND=8) ( A-H, O-Z )
      REAL (KIND=8) :: C(4), SPLINEXX

      SPLINEXX = C(3) + H * C(4)
      RETURN
      END
!**********************************************************************C
      SUBROUTINE SPLINEALL ( C, H, F, FX, FXX )

!     THIS ROUTINE EVALUATES THE
!        SPLINE,
!        SPLINE DERIVATIVE, AND
!        SPLINE 2ND DERIVATIVE AT THE POINT H

      IMPLICIT REAL (KIND=8) ( A-H, O-Z )
      PARAMETER ( HALF = 0.5, SIXTH = 1.0 / 6.0 )
      REAL (KIND=8) :: C(4), F, FX, FXX

      F   = C(1) + H * ( C(2) + H * ( HALF * C(3) + SIXTH * H * C(4) ) )
      FX  = C(2) + H * ( C(3) + H * HALF * C(4) )
      FXX = C(3) + H * C(4)

      RETURN
      END


C
C***********************************************************************
C                                                                      *
C            NACHOS II - A Finite Element Computer Program             *
C                        for Incompressible Flow Problems              *
C                                                                      *
C     Copyright (c) 1986,2019   National Technology & Engineering      *
C                               Solutions of Sandia, LLC (NTESS)       *
C                                                                      *
C                            All rights reserved.                      *
C                                                                      *
C     This software is distributed under the BSD 3-Clause License.     *
C                                                                      *
C***********************************************************************
C
      SUBROUTINE SHAPE9 (NGAUSS,GS1,GS2)
C
C     ******************************************************************
C
C     SUBROUTINE TO CALCULATE THE VALUES OF THE NINE NODE 'LAGRANGE'
C     SHAPE FUNCTIONS AND THEIR DERIVATIVES AT THE INTEGRATION POINTS
C     (N X N GAUSS INTEGRATION RULE)
C
C     ******************************************************************
C
      COMMON /QUAD9/ F9Q(9,9),F9L(4,9),DF9QDS(9,9),DF9QDT(9,9)
C
      DIMENSION GS1(*), GS2(*)
      DIMENSION SI(8), TI(8)
C
      DATA (SI(I),I=1,8)/-1.,1.,1.,-1.,0.,1.,0.,-1./
      DATA (TI(I),I=1,8)/-1.,-1.,1.,1.,-1.,0.,1.,0./
C
C     STATEMENT FUNCTIONS FOR THE SHAPE FUNCTIONS AND THEIR DERIVATIVES
C
      FC(I,S,T)=.25*(1.+S*SI(I))*(1.+T*TI(I))*(S*SI(I)+T*TI(I)-1.)
      FM(I,S,T)=.50*((1.-S**2)*(1.+T*TI(I))*TI(I)**2+(1.-T**2)*(1.+S*SI
     1(I))*SI(I)**2)
      BUBBLE(S,T)=(1.-S**2)*(1.-T**2)
      G(I,S,T)=.25*(1.+S*SI(I))*(1.+T*TI(I))
      DFCDS(I,S,T)=.25*(1.+T*TI(I))*(2.*S*SI(I)+T*TI(I))*SI(I)
      DFMDS(I,S,T)=.50*((1.+T*TI(I))*(-2.*S)*TI(I)**2+(1.-T**2)*SI(I))
      DFCDT(I,S,T)=.25*(1.+S*SI(I))*(2.*T*TI(I)+S*SI(I))*TI(I)
      DFMDT(I,S,T)=.50*((1.+S*SI(I))*(-2.*T)*SI(I)**2+(1.-S**2)*TI(I))
      DBUBDS(S,T)=-2.*S*(1.-T**2)
      DBUBDT(S,T)=-2.*T*(1.-S**2)
C
C     ******************************************************************
C
C     EVALUATE FUNCTIONS
C
      DO 10 I=1,4
      L=1
      DO 10 K=1,NGAUSS
      DO 10 J=1,NGAUSS
      DF9QDS(I,L)=DFCDS(I,GS1(J),GS2(K))+.25*DBUBDS(GS1(J),GS2(K))
      DF9QDT(I,L)=DFCDT(I,GS1(J),GS2(K))+.25*DBUBDT(GS1(J),GS2(K))
      F9Q(I,L)=FC(I,GS1(J),GS2(K))+.25*BUBBLE(GS1(J),GS2(K))
      F9L(I,L)=G(I,GS1(J),GS2(K))
      L=L+1
   10 CONTINUE
      DO 20 I=5,8
      L=1
      DO 20 K=1,NGAUSS
      DO 20 J=1,NGAUSS
      DF9QDS(I,L)=DFMDS(I,GS1(J),GS2(K))-.5*DBUBDS(GS1(J),GS2(K))
      DF9QDT(I,L)=DFMDT(I,GS1(J),GS2(K))-.5*DBUBDT(GS1(J),GS2(K))
      F9Q(I,L)=FM(I,GS1(J),GS2(K))-.5*BUBBLE(GS1(J),GS2(K))
      L=L+1
   20 CONTINUE
      L=1
      DO 30 K=1,NGAUSS
      DO 30 J=1,NGAUSS
      DF9QDS(9,L)=DBUBDS(GS1(J),GS2(K))
      DF9QDT(9,L)=DBUBDT(GS1(J),GS2(K))
      F9Q(9,L)=BUBBLE(GS1(J),GS2(K))
      L=L+1
   30 CONTINUE
C
      RETURN
      END


Program testXscat

Use Kinds, Only: dp
Use Global, Only: m0c2
Use Global, Only: Pi
Use Xscat, Only: Thompson_AD
Use Xscat, Only: KN_AD
Use Xscat, Only: mu_Thomp
Use Xscat, Only: mu_KN
Use Xscat, Only: Coherent_AD
Use Xscat, Only: Incoherent_AD
Use Xscat, Only: mu_CohS
Use Xscat, Only: mu_IncS
Use Random_Numbers, Only: RNG_type
Use Utilities, Only: Bisection_Search
Use Quadratures, Only: Romberg_Quad
Use FileIO_Utilities, Only: creturn
Implicit None
Integer :: unit
Integer :: i,j,k,z
Integer, Parameter :: n_mu = 10000
Integer, Parameter :: n_mu_samp = 50
Real(dp) :: mu
Real(dp) :: mus(0:n_mu_samp)
Integer, Parameter :: n_alpha = 4
Real(dp), Parameter :: calphas(1:n_alpha) = (/ 1.E-3_dp , 3.E-3_dp , 1.E-2_dp , 3.E-2_dp /)
Real(dp), Parameter :: ialphas(1:n_alpha) = (/ 1.E-2_dp , 1.E-1_dp , 1._dp    , 10._dp   /)
Integer, Parameter :: n_trials = 1E6
Real(dp),Parameter :: trial_val = 1._dp / Real(n_trials,dp)
Real(dp) :: mu_count_Th(1:n_mu_samp),mu_count_KN(1:n_mu_samp,1:n_alpha)
Real(dp) :: AD_alpha
Real(dp) :: dmu
Integer, Parameter :: n_Zs = 30
Real(dp) :: alpha_new
Real(dp) :: mu_count_CS(1:n_mu_samp,1:n_alpha,1:n_Zs),mu_count_IS(1:n_mu_samp,1:n_alpha,1:n_Zs)
Integer :: AD_Z

Type(RNG_type) :: RNG

Write(*,*)
!Run baseline angular distributions (Thompson and Klein-Nishina)
Write(*,'(A)',ADVANCE='NO') 'Baseline Thompson and Klein-Nishina...'
Open(NEWUNIT=unit,FILE='ADs.tst',ACTION='WRITE',STATUS='REPLACE')
Do i = 0,n_mu
    mu = -1._dp + Real(i,dp)*2._dp/Real(n_mu,dp)
    Write(unit,'(3ES23.15E2)',ADVANCE='NO') mu , Thompson_AD(mu) , KN_AD(mu,ialphas(1))
    Do j = 2,n_alpha
        Write(unit,'(ES23.15E2)',ADVANCE='NO') KN_AD(mu,ialphas(j))
    End Do
    Write(unit,*)
End Do
Close(unit)
Write(*,'(A)') ' Done.'
!Run baseline Coherent distributions (Thompson adjusted for Atomic Form Factor)
Write(*,'(A)',ADVANCE='NO') 'Baseline Coherent (Thompson*AFF**2)...'
Open(NEWUNIT=unit,FILE='ADs-cs.tst',ACTION='WRITE',STATUS='REPLACE')
Do i = 0,n_mu
    mu = -1._dp + Real(i,dp)*2._dp/Real(n_mu,dp)
    Write(unit,'(ES23.15E2)',ADVANCE='NO') mu
    Do j = 1,n_Zs
        Do k = 1,n_alpha
            Write(unit,'(ES23.15E2)',ADVANCE='NO') Coherent_AD(j,mu,calphas(k))
        End Do
    End Do
    Write(unit,*)
End Do
Close(unit)
Write(*,'(A)') ' Done.'
!Run baseline Incoherent distributions (Klein-Nishina adjusted for Atomic Form Factor)
Write(*,'(A)',ADVANCE='NO') 'Baseline Incoherent (Klein-Nishina*ISF)...'
Open(NEWUNIT=unit,FILE='ADs-is.tst',ACTION='WRITE',STATUS='REPLACE')
Do i = 0,n_mu
    mu = -1._dp + Real(i,dp)*2._dp/Real(n_mu,dp)
    Write(unit,'(ES23.15E2)',ADVANCE='NO') mu
    Do j = 1,n_Zs
        Do k = 1,n_alpha
            Write(unit,'(ES23.15E2)',ADVANCE='NO') Incoherent_AD(j,mu,ialphas(k),alpha_new)
        End Do
    End Do
    Write(unit,*)
End Do
Close(unit)
Write(*,'(A)') ' Done.'

!Run sampling trials from the baseline distributions
Call RNG%Initialize(seed = 7777777)
Do i = 0,n_mu_samp
    mu = -1._dp + Real(i,dp)*2._dp/Real(n_mu_samp,dp)
    mus(i) = mu
End Do
!Sample from the Thompson distribution
Write(*,'(A,I0)',ADVANCE='NO') 'Sampling Thompson and Klein-Nishina... 0/',n_alpha
mu_count_Th = 0._dp
Do i = 1,n_trials
    mu = mu_Thomp(RNG)
    j = Bisection_Search(mu,mus,n_mu_samp+1) - 1
    mu_count_Th(j) = mu_count_Th(j) + trial_val
    If (Mod(i,100) .EQ. 0) Then
        Write(*,'(A,I0,A,I3,A)',ADVANCE='NO') creturn//'Sampling Thompson and Klein-Nishina... 0/',n_alpha, &
                                            & ' (',100*i/n_trials,'%)'
    End If
End Do
!Sample from the Kelin-Nishina distribution
mu_count_KN = 0._dp
Do j = 1,n_alpha
    Do i = 1,n_trials
        mu = mu_KN(RNG,ialphas(j))
        k = Bisection_Search(mu,mus,n_mu_samp+1) - 1
        mu_count_KN(k,j) = mu_count_KN(k,j) + trial_val
        If (Mod(i,100) .EQ. 0) Then
            Write(*,'(A,I0,A,I0,A,I3,A)',ADVANCE='NO') creturn//'Sampling Thompson and Klein-Nishina... ',j,'/',n_alpha, &
                                                     & ' (',100*i/n_trials,'%)'
        End If
    End Do
End Do
!write to file
Open(NEWUNIT=unit,FILE='ADs-samp.tst',ACTION='WRITE',STATUS='REPLACE')
mu_count_Th = mu_count_Th * Romberg_Quad(Thompson_AD,-1._dp,1._dp,0._dp,1.E-12_dp)
Do j = 1,n_alpha
    AD_alpha = ialphas(j)
    mu_count_KN(:,j) = mu_count_KN(:,j) * Romberg_Quad(KN_AD_single_arg,-1._dp,1._dp,0._dp,1.E-12_dp)
End Do
Do i = 1,n_mu_samp
    mu = 0.5_dp * (mus(i) + mus(i-1))
    dmu = mus(i) - mus(i-1)
    Write(unit,'(3ES23.15E2)',ADVANCE='NO') mu , mu_count_Th(i) / dmu , mu_count_KN(i,1) / dmu
    Do j = 2,n_alpha
        Write(unit,'(ES23.15E2)',ADVANCE='NO') mu_count_KN(i,j) / dmu
    End Do
    Write(unit,*)
End Do
Close(unit)
Write(*,'(A)') ' Done.'

!Run sampling trials from the corrected distributions
!Sample from the Coherent Scatter distribution
mu_count_CS = 0._dp
Do z = 1,n_Zs
    Do j = 1,n_alpha
        Do i = 1,n_trials
            mu = mu_CohS(RNG,z,calphas(j))
            k = Bisection_Search(mu,mus,n_mu_samp+1) - 1
            mu_count_CS(k,j,z) = mu_count_CS(k,j,z) + trial_val
            If (Mod(i,100) .EQ. 0) Then
                Write(*,'(A,I0,A,I0,A,I3,A)',ADVANCE='NO') creturn//'Sampling Coherent... ', n_alpha*(z-1)+j,'/',n_alpha*n_Zs, &
                                                         & ' (',100*i/n_trials,'%)'
            End If
        End Do
    End Do
End Do
!write to file
Open(NEWUNIT=unit,FILE='ADs-cs-samp.tst',ACTION='WRITE',STATUS='REPLACE')
Do z = 1,n_Zs
    AD_Z = z
    Do j = 1,n_alpha
        AD_alpha = calphas(j)
        mu_count_CS(:,j,z) = mu_count_CS(:,j,z) * Romberg_Quad(CS_AD_single_arg,-1._dp,1._dp,0._dp,1.E-12_dp)
    End Do
End Do
Do i = 1,n_mu_samp
    mu = 0.5_dp * (mus(i) + mus(i-1))
    dmu = mus(i) - mus(i-1)
    Write(unit,'(ES23.15E2)',ADVANCE='NO') mu
    Do j = 1,n_Zs
        Do k = 1,n_alpha
            Write(unit,'(ES23.15E2)',ADVANCE='NO') mu_count_CS(i,k,j) / dmu
        End Do
    End Do
    Write(unit,*)
End Do
Close(unit)
Write(*,'(A)') ' Done.'
!Sample from the Incoherent Scatter distribution
mu_count_IS = 0._dp
Do z = 1,n_Zs
    Do j = 1,n_alpha
        Do i = 1,n_trials
            Call mu_IncS(RNG,z,ialphas(j),mu,alpha_new)
            k = Bisection_Search(mu,mus,n_mu_samp+1) - 1
            mu_count_IS(k,j,z) = mu_count_IS(k,j,z) + trial_val
            If (Mod(i,100) .EQ. 0) Then
                Write(*,'(A,I0,A,I0,A,I3,A)',ADVANCE='NO') creturn//'Sampling Incoherent... ',n_alpha*(z-1)+j,'/',n_alpha*n_Zs, &
                                                         & ' (',100*i/n_trials,'%)'
            End If
        End Do
    End Do
End Do
!write to file
Open(NEWUNIT=unit,FILE='ADs-is-samp.tst',ACTION='WRITE',STATUS='REPLACE')
Do z = 1,n_Zs
    AD_Z = z
    Do j = 1,n_alpha
        AD_alpha = ialphas(j)
        mu_count_IS(:,j,z) = mu_count_IS(:,j,z) * Romberg_Quad(IS_AD_single_arg,-1._dp,1._dp,0._dp,1.E-12_dp)
    End Do
End Do
Do i = 1,n_mu_samp
    mu = 0.5_dp * (mus(i) + mus(i-1))
    dmu = mus(i) - mus(i-1)
    Write(unit,'(ES23.15E2)',ADVANCE='NO') mu
    Do j = 1,n_Zs
        Do k = 1,n_alpha
            Write(unit,'(ES23.15E2)',ADVANCE='NO') mu_count_IS(i,k,j) / dmu
        End Do
    End Do
    Write(unit,*)
End Do
Close(unit)
Write(*,'(A)') ' Done.'

Write(*,*)

Contains

Function KN_AD_single_arg(mu) Result(kn)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: kn
    Real(dp), Intent(In) :: mu

    kn = KN_AD(mu,AD_alpha)
End Function

Function CS_AD_single_arg(mu) Result(cs)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: cs
    Real(dp), Intent(In) :: mu

    cs = Coherent_AD(AD_Z,mu,AD_alpha)
End Function

Function IS_AD_single_arg(mu) Result(is)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: is
    Real(dp), Intent(In) :: mu

    is = Incoherent_AD(AD_Z,mu,AD_alpha,alpha_new)
End Function

End Program


c
c
c =========================================================
      subroutine src1d(meqn,mbc,mx1d,q1d,maux,aux1d,t,dt)
c =========================================================
      use geoclaw_module

      implicit double precision (a-h,o-z)

      dimension   q1d(mx1d, meqn)
      dimension aux1d(mx1d, maux)
c

c
c     # This routine should be a simplified version of src2
c     # which applies source terms for a 1-d slice of data along the
c     # edge of a grid.  This is called only from qad where the conservative
c     # fix-up is applied and is used to apply source terms over partial
c     # time steps to the coarse grid cell values used in solving Riemann
c     # problems at the interface between coarse and fine grids.

c     # incorporates friction using Manning coefficient
        g=grav
        coeff = coeffmanning
        tol = 1.d-30  !# to prevent divide by zero in gamma

      if (coeffmanning.gt.0.d0.and.frictiondepth.gt.0.d0) then
        do i=1,mx1d
           h=q1d(i,1)
           if (h.lt.frictiondepth) then
c            # apply friction source term only in shallower water
             hu=q1d(i,2)
             hv=q1d(i,3)

             if (h.lt.tol) then
                q1d(i,2)=0.d0
                q1d(i,3)=0.d0
             else
                gamma= dsqrt(hu**2 + hv**2)*(g*coeff**2)/(h**(7/3))
                dgamma=1.d0 + dt*gamma
                q1d(i,2)= q1d(i,2)/dgamma
                q1d(i,3)= q1d(i,3)/dgamma
             endif
           endif
        enddo
      endif

*     ! coriolis--------------------------------------------------------
*     ! coriolis--------------------------------------------------------
      if (icoordsys.eq.2.and.icoriolis.eq.1) then
         w = 2.d0*pi/(86400.d0) !angular velocity of earth
         do i=1,mx1d
            cor = 2.d0*w*sin(aux1d(i,3))
            ct = cor*dt
*           !integrate momentum exactly using matrix exponential
*           !forth order term should be sufficient since cor^3 ~= eps
            hu0 = q1d(i,2)
            hv0 = q1d(i,3)
*           !dq/dt = 2w*sin(latitude)*[0 1 ; -1 0] q = Aq
*           !e^Adt = [a11 a12; a21 a22] + I
            a11 = -0.5d0*ct**2 + ct**4/24.d0
            a12 = ct - ct**3/6.0d0
            a21 = -ct + ct**3/6.0d0
            a22 = a11
*           !q = e^Adt * q0
            q1d(i,2) = q1d(i,2) + hu0*a11 + hv0*a12
            q1d(i,3) = q1d(i,3) + hu0*a21 + hv0*a22
            enddo
         endif
*     ! ----------------------------------------------------------------
c
      return
      end


C     Fortranification of Paul's DiscreteSIR.py

      program DiscreteSIR
      implicit none

      call simulate()

      stop
      end program DiscreteSIR

C  ******************************************************************************
C  *                                                                            *
C  *   A function for computing the updated amounts of infected and recovered   *
C  *                                                                            *
C  ******************************************************************************
      double precision function randbn(n, p)
      double precision n, p, q, s, a, r, x, u
      double precision pyrand
      integer i

      q = 1.0 - p
      s = p/q
      a = (n+1)*s
      r = exp(n*log(q))
      x = 0
      u = pyrand(.false.)
      do while (.true.)
         if (u < r) then
            randbn = x
            return
         else
            u = u - r
            x = x + 1
            r = r * ((a/x) - s)
         end if
      end do
      end function randbn

C  ******************************************************************************
C  *                                                                            *
C  *      Actual model code here, this should be interchangeable with SEIR      *
C  *                                                                            *
C  ******************************************************************************
      subroutine sir(u_0, u_1, u_2, u_3, params_0,
     &               params_1, params_2, params_3, params_4)
      double precision u_0, u_1, u_2, u_3
      double precision params_0, params_1, params_2, params_3, params_4
      double precision S, I, R, Y, beta, gamma, iota, N, delta_t
      double precision lambda_, ifrac, rfrac, infection, recovery
      double precision randbn

      S = u_0
      I = u_1
      R = u_2
      Y = u_3

      beta = params_0
      gamma = params_1
      iota = params_2
      N = params_3
      delta_t = params_4

      lambda_ = beta * (I + iota) / N
      ifrac = 1.0 - exp(-lambda_ * delta_t)
      rfrac = 1.0 - exp(-gamma * delta_t)
      infection = randbn(S, ifrac)
      recovery = randbn(I, rfrac)

C     Set the return values
      u_0 = S - infection
      u_1 = I + infection - recovery
      u_2 = R + recovery
      u_3 = Y + infection

      end subroutine sir

C  ******************************************************************************
C  *                                                                            *
C  * Driver functions for the simulation, should be top level container in GrFN *
C  *                                                                            *
C  ******************************************************************************
      subroutine simulate()
      integer, parameter :: tf = 200
      integer, parameter :: tl = tf/0.1
      integer j
      double precision t, S, I, R, Y
      double precision u0_0, u0_1, u0_2, u0_3, u_0, u_1, u_2, u_3
      double precision params_0, params_1, params_2, params_3, params_4
      double precision tmp, pyrand

      tmp = pyrand(.true.)    ! initialize

      params_0 = 0.1
      params_1 = 0.05
      params_2 = 0.01
      params_3 = 1000.0
      params_4 = 0.1

      u0_0  = 999.0
      u0_1  = 1.0
      u0_2  = 0.0
      u0_3  = 0.0

      S = u0_0
      I = u0_1
      R = u0_2
      Y = u0_3

      u_0 = u0_0
      u_1 = u0_1
      u_2 = u0_2
      u_3 = u0_3

      do j = 1, tl
         call sir(u_0, u_1, u_2, u_3,
     &             params_0, params_1, params_2, params_3, params_4)
         S = u_0
         I = u_1
         R = u_2
         Y = u_3
!         write (*,*) S
      end do

 10   format(4(X,F4.0))
      write(*, 10) S, I, R, Y

      end subroutine simulate

C  ******************************************************************************
C  *                                                                            *
C  *               Pretend to be Python's ramdon-number generator               *
C  *                                                                            *
C  ******************************************************************************
      double precision function pyrand(do_init)
      double precision retval
      logical do_init

      if (do_init .eqv. .TRUE.) then        ! initialize
         open (2, file = 'PYTHON-RANDOM_SEQ')
         retval = 0.0
      else
         read (2, 10) retval
 10      format(F20.18)
      end if

      pyrand = retval

      end function pyrand

      subroutine print_output(tl, S, I, R, Y)
      integer tl
      double precision, dimension(0:tl) :: S, I, R, Y

 10   format("[", 3(X,F4.0), " ...", 3(X,F4.0), "]")
      write (*, 10) S(1), S(2), S(3), S(tl-2), S(tl-1), S(tl)
      write (*, 10) I(1), I(2), I(3), I(tl-2), I(tl-1), I(tl)
      write (*, 10) R(1), R(2), R(3), R(tl-2), R(tl-1), R(tl)
      write (*, 10) Y(1), Y(2), Y(3), Y(tl-2), Y(tl-1), Y(tl)
      end subroutine print_output


!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_INIT_RANKS_EXTEND

    USE MR_KINDS

    USE MR_DEF_RANKS
    USE MR_DEF_RANKS_

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_INIT_RANKS_EXTEND

!***********************************************************************************************************************************

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFREADION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_INIT_RANKS_EXTEND( NLOOPS )

    IMPLICIT NONE

    INTEGER            , INTENT(IN ) :: NLOOPS

    NI_  = NI * NLOOPS ; NJ_  = NJ

    NND_ = (2*NI_+1) * (2*NJ_+1)
    NEM_ =       NI_ * NJ_

  END SUBROUTINE MR_INIT_RANKS_EXTEND

  END MODULE MR_MOD_INIT_RANKS_EXTEND


!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
module mod_submod32
integer a, b, m
interface
    module subroutine check_arr(arr)
        integer, intent(in) :: arr(:)
    end subroutine
end interface
end module mod_submod32

submodule (mod_submod32) submod_submod32
contains
    module procedure check_arr
        a = lbound(arr, DIM=1)
        b = size(arr)
        m = maxval(arr)
    end procedure
end submodule submod_submod32

program prog
    use mod_submod32
    integer x(7:15)
    x(7:15) = 0
    x(9:10) = 1
    x(15) = 10
    print *, "lbound: ", lbound(x)
    print *, "kind: ", kind(x)
    print *, "maxval: ", maxval(x)
    call check_arr(x)
    if ( a .EQ. lbound(x, DIM=1) .AND. b .EQ. size(x) .AND. maxval(x) .EQ. m) then
        print *, " PASS "
    else
        print *, "FAILED: lbound of arr in submod is ", a, " and lbound of x is ", lbound(x, DIM=1)
        print *, "FAILED: size of arr in submod is ", b, " and size of x is ", size(x)
        print *, "FAILED: maxval of arr in submod is", m, " and maxval of x is", maxval(x)
    end if
end program prog


MODULE FIND_BOUND
! Find Mesh Boundarys
CONTAINS

SUBROUTINE FindBoundary(NP,X,Y,N_ab,N_bc,N_de,N_ea,ab,bc,de,ea)
! This subroutine is to find mesh boundary
implicit none

! Mesh Information
integer NP
real*8 X(1:NP),Y(1:NP)

! Record boundary nodes
integer N_ab
integer, allocatable::  ab(:)
integer N_bc
integer, allocatable::  bc(:)
integer N_de
integer, allocatable::  de(:)
integer N_ea
integer, allocatable::  ea(:)

! Local variables
integer:: i=0, i_ab=1, i_bc=1, i_de=1, i_ea=1
integer status_msg
!-------------------------------------------------------------------------------------------------------

! Message
print*, 'Enter Subroutine FindBoundary...'
!-------------------------------------------------------------------------------------------------------

! Find Boundary Nodes
do i = 1,NP
  ! ab
  if( ABS(Y(i) - 0.D0) < 1D-10 ) then
   N_ab = N_ab + 1
  end if

  ! bc
  if( ABS(X(i)**2 + Y(i)**2 - 1) < 1D-4 .and. ABS(Y(i) - 0.D0) > 1D-10) then
   N_bc = N_bc + 1
  end if

  ! de
  if( ABS(Y(i) - 2.D0) < 1D-10 ) then
   N_de = N_de + 1
  end if

  ! ea
  if( ABS(X(i) + 3.5D0) < 1D-10 .and. ABS(Y(i) - 0.D0) > 1D-10 .and. ABS(Y(i) - 2.D0) > 1D-10 ) then
   N_ea = N_ea + 1
  end if

end do

print*, 'N_ab=', N_ab
print*, 'N_bc=', N_bc
print*, 'N_de=', N_de
print*, 'N_ea=', N_ea

ALLOCATE(ab(1:N_ab), STAT = status_msg )
print*, 'memory allocate state for ab is:("0" means success)  ',status_msg
ALLOCATE(bc(1:N_bc), STAT = status_msg )
print*, 'memory allocate state for bc is:("0" means success)  ',status_msg
ALLOCATE(de(1:N_de), STAT = status_msg )
print*, 'memory allocate state for de is:("0" means success)  ',status_msg
ALLOCATE(ea(1:N_ea), STAT = status_msg )
print*, 'memory allocate state for ea is:("0" means success)  ',status_msg

do i = 1,NP
  ! ab
  if( ABS(Y(i) - 0.D0) < 1D-10 ) then
   ab(i_ab) = i
   i_ab = i_ab + 1
  end if

  ! bc
  if( ABS(X(i)**2 + Y(i)**2 - 1) < 1D-4 .and. ABS(Y(i) - 0.D0) > 1D-10) then
   bc(i_bc) = i
   i_bc = i_bc + 1
  end if

  ! de
  if( ABS(Y(i) - 2.D0) < 1D-10 ) then
   de(i_de) = i
   i_de = i_de + 1
  end if

  ! ea
  if( ABS(X(i) + 3.5D0) < 1D-10 .and. ABS(Y(i) - 0.D0) > 1D-10 .and. ABS(Y(i) - 2.D0) > 1D-10 ) then
   ea(i_ea) = i
   i_ea = i_ea + 1
  end if

end do
!------------------------------------------------------------------------------------------------------------------------

! Message
print*, 'Subroutine FindBoundary exit...'
print*, ''
!------------------------------------------------------------------------------------------------------------------------

! Program end
END SUBROUTINE FindBoundary
END MODULE FIND_BOUND


!-----------------------------------------------------------------------------!
! \file   example/metis.f90
!
! Copyright (c) 2021 Oak Ridge National Laboratory, UT-Battelle, LLC.
!
! This example is based on metis.cc at
! https://gist.github.com/erikzenker/c4dc42c8d5a8c1cd3e5a
!-----------------------------------------------------------------------------!

program metis_example
  use, intrinsic :: ISO_C_BINDING
  use, intrinsic :: ISO_FORTRAN_ENV
  use formetis
  implicit none
  integer, parameter :: STDOUT = OUTPUT_UNIT, STDIN = INPUT_UNIT
  integer(c_int), parameter :: nvertices(1) = (/6/)
  integer(c_int), parameter :: nedges(1) = (/7/)
  integer(c_int), parameter :: xadj(nvertices(1) + 1) &
    = (/0,2,5,7,9,12,14/)
  integer(c_int), parameter :: adjncy(nedges(1) * 2) &
    = (/1,3,0,4,2,1,5,0,4,3,1,5,4,2/)
  integer(c_int), dimension(1) :: nweights = (/1/)
  integer(c_int), dimension(1) :: nparts = (/2/)
  integer(c_int), dimension(1) :: objval
  integer(c_int), dimension(:), allocatable :: vwgt
  integer(c_int), dimension(:), allocatable :: part
  integer(c_int) :: mresult

  ! Print version information
  write(STDOUT, "(a)") "========================================"
  write(STDOUT, "(a, a)") "Formetis version: ", get_formetis_version()
  write(STDOUT, "(a, 2(i1,'.'), (i1), a)") "(Numeric version: ", &
      formetis_version_major, formetis_version_minor, formetis_version_patch, &
      ")"
  write(STDOUT, "(a)") "========================================"

  allocate(vwgt(nvertices(1) * nweights(1)))
  allocate(part(nvertices(1)))
  call PartGraphKway( &
    nvtxs=nvertices, ncon=nweights, xadj=xadj, adjncy=adjncy, &
    nparts=nparts, edgecut=objval, part=part, swig_result=mresult &
  )
  if (mresult /= OK) then
    write(STDOUT, *) "Error:", mresult
    stop 1
  endif
  write(STDOUT, *) "edgecut=", objval
  write(STDOUT, *) "part=", part
  write(STDOUT, *) "vwgt=", vwgt

end program

!-----------------------------------------------------------------------------!
! end of example/metis.f90
!-----------------------------------------------------------------------------!


! { dg-do run }
! PR 15553 : the array used to be filled with garbage
! this problem disappeared between 2004-05-20 and 2004-09-15
program arrpack
  implicit none

  double precision x(10,10)
  integer i, j

  x = -1
  do i=1,6
     do j=1,5
        x(i,j) = i+j*10
     end do
  end do
  call pack (x, 6, 5)

  if (any(reshape(x(1:10,1:3), (/ 30 /)) &
          /= (/ 11, 12, 13, 14, 15, 16,  &
                21, 22, 23, 24, 25, 26,  &
                31, 32, 33, 34, 35, 36,  &
                41, 42, 43, 44, 45, 46,  &
                51, 52, 53, 54, 55, 56 /))) call abort ()

contains

  subroutine pack (arr, ni, nj)
    integer, intent(in) :: ni, nj
    double precision, intent(inout) :: arr(:,:)
    double precision :: tmp(ni,nj)
    tmp(:,:) = arr(1:ni, 1:nj)
    call copy (arr, tmp, ni, nj)
  end subroutine pack

  subroutine copy (dst, src, ni, nj)
    integer, intent(in) :: ni, nj
    double precision, intent(out) :: dst(ni, nj)
    double precision, intent(in)  :: src(ni, nj)
    dst = src
  end subroutine copy

end program arrpack


	REAL FUNCTION LINEAR (X0,X,Y,N,I)

!	Interpolates linearly the function y(x) at x=x0.
!	Re written by GBA June 8, 2012

!	Variables
	real x(n),y(n)

!	Several options
	if ( i >= 0 ) then
		i = iplace(x0,x,max0(1,i),n)
	else
		i = -i
	endif
	if ( i == 0 ) then
		linear = 0.
!		linear = -1.e10
		ierr = linerr(x0,x(1),x(n),n)
	elseif ( x0 == x(n) ) then
		linear = y(n)
	else
		linear = y(i) + (y(i+1)-y(i))*(x0-x(i))/(x(i+1)-x(i))
	endif
	return
	end

	FUNCTION LINERR(X0,X1,XN,N)
!	Reports error in interpolation
	data ierr/0/
	if (ierr.eq.0) then
		ierr=1
		linerr=1
		write (6,'(10x,a)') ' ---------------------------------------------------------------------------------'
		write (6,1) X0,X1,XN,N
		write (6,'(10x,a)') ' ----------- Error reported only once, but it may occur more than once. ----------'
1		format (10x,' --- LINEAR:  X0 = ',1PE10.3,' is outside X range ---',2E10.3,I10)
!		stop
	endif
	return
	end

!      REAL FUNCTION LINEAR (X0,X,Y,N,I0)
!c     INTERPOLATES LINEARLY THE FUNCTION Y(X) AT X=X0.
!      REAL X(N),Y(N)
!	data ierr/0/
!      IF (I0) 21,20,20
!   20 I=IPLACE(X0,X,MAX0(1,I0),N)
!      GOTO 22
!   21 I=-I0
!   22 I0=I
!      IF (I.EQ.0) GOTO 2
!      IF (X0.EQ.X(I).OR.X(I).EQ.X(I+1)) GOTO 1
!      LINEAR=Y(I) + (Y(I+1)-Y(I))*(X0-X(I))/(X(I+1)-X(I))
!      RETURN
!    1 LINEAR=Y(I)
!      RETURN
!    2 if (ierr.eq.0) then
!	ierr=1
!c	write (6,*) 'I,I0 =',i,i0
!	write (6,3) X0,X(1),X(N),N
!	write (6,*) '---   Error reported only once. It may occur more than once. ---'
!      endif
!    3 FORMAT (' --- LINEAR:  X0 = ',1PE10.3,' is outside X range ---',2E10.3,I10)
!      LINEAR=0.
!      RETURN
!      END


module mp_lu_decomposition

#ifdef ISO_C_BINDING

   implicit none

   public :: lu_decomposition_local
   public :: lu_inverse_local
   public :: lu_matrix_multiply_local

   interface lu_decomposition_local
!    module procedure lu_decomposition_local_real
      module procedure lu_decomposition_local_complex
   end interface

   interface lu_inverse_local
!    module procedure lu_inverse_local_real
      module procedure lu_inverse_local_complex
   end interface

   interface lu_matrix_multiply_local
!    module procedure lu_decomposition_local_real
      module procedure lu_matrix_multiply_local_complex
   end interface

contains

   subroutine lu_decomposition_local_complex(mp_comm, root, win, lu, idx, d)

      use mpi

      implicit none

      integer, intent(in) :: win, mp_comm, root
      complex, dimension(:, :), intent(in out) :: lu
      integer, dimension(:), intent(out) :: idx
      real, intent(out) :: d

      real, parameter :: zero = 1.0e-20
      real, dimension(size(lu, 1)) :: vv
      complex, dimension(size(lu, 2)) :: dum

      integer :: i, j, k, n, imax, lo, hi
      integer :: iproc, nproc, ierr
      real :: dmax, tmp

      n = size(lu, 1)

      call mpi_comm_size(mp_comm, nproc, ierr)
      call mpi_comm_rank(mp_comm, iproc, ierr)

      d = 1.0
      !the following is a loop to avoid copying entire matrix
      ! with (cabs(lu))
      do i = 1, n
         vv(i) = maxval(cabs(lu(i, :)))
      end do
      if (any(vv == 0.0)) &
         write (*, *) 'singular matrix in lu_decomposition on process ', iproc
      vv = 1.0 / vv
      do j = 1, n
         !divide up the work using row_limits
         call split_n_tasks(n - j, iproc, nproc, lo, hi, llim=j + 1)

         !pivot if needed
         dmax = -1.0
         do k = j, n
            tmp = vv(k) * abs(lu(k, j))
            if (tmp > dmax) then
               dmax = tmp
               imax = k
            end if
         end do

         if (iproc == root) then
            idx(j) = imax
            if (j /= imax) then
               dum = lu(imax, :)
               lu(imax, :) = lu(j, :)
               lu(j, :) = dum
               vv(imax) = vv(j)
               d = -d
            end if
            if (lu(j, j) == 0.0) lu(j, j) = zero
         else
            if (j /= imax) vv(imax) = vv(j)
         end if

         call mpi_win_fence(0, win, ierr)

         !get the lead multiplier
         do i = lo, hi
            lu(i, j) = lu(i, j) / lu(j, j)
         end do

         call mpi_win_fence(0, win, ierr)

         do k = lo, hi
            do i = j + 1, n
               lu(i, k) = lu(i, k) - lu(i, j) * lu(j, k)
            end do
         end do

         call mpi_win_fence(0, win, ierr)
      end do

   end subroutine lu_decomposition_local_complex

   subroutine lu_inverse_local_complex(mp_comm, win, lu, idx, inverse)

      use linear_solve, only: lu_back_substitution

      implicit none

      integer, intent(in) :: win, mp_comm
      complex, dimension(:, :), intent(in) :: lu
      integer, dimension(:), intent(in) :: idx
      complex, dimension(:, :), intent(out) :: inverse

      integer :: i, n, nproc, iproc, ierr
      integer :: lo, hi

      n = size(lu, 1)

      call mpi_comm_size(mp_comm, nproc, ierr)
      call mpi_comm_rank(mp_comm, iproc, ierr)

      call split_n_tasks(n, iproc, nproc, lo, hi)

      do i = lo, hi
         inverse(i, :) = 0
         inverse(i, i) = 1.0
      end do

      call mpi_win_fence(0, win, ierr)

      do i = lo, hi
         call lu_back_substitution(lu, idx, inverse(:, i))
      end do

      call mpi_win_fence(0, win, ierr)

   end subroutine lu_inverse_local_complex

   subroutine lu_matrix_multiply_local_complex(mp_comm, win, mat, b)

      implicit none

      integer, intent(in) :: win, mp_comm
      complex, dimension(:, :), intent(in) :: mat
      complex, dimension(:), intent(out) :: b
      complex, dimension(size(b)) :: a

      integer :: i, n, nproc, iproc
      integer :: lo, hi, ierr

      n = size(mat, 1)

      call mpi_comm_size(mp_comm, nproc, ierr)
      call mpi_comm_rank(mp_comm, iproc, ierr)

      call split_n_tasks(n, iproc, nproc, lo, hi)

      do i = lo, hi
         a(i) = sum(mat(i, :) * b(:))
      end do

      call mpi_win_fence(0, win, ierr)

      do i = lo, hi
         b(i) = a(i)
      end do

      call mpi_win_fence(0, win, ierr)

   end subroutine lu_matrix_multiply_local_complex

   subroutine split_n_tasks(n, iproc, nproc, lo, hi, llim)

      implicit none

      integer, intent(in) :: n, iproc, nproc
      integer, intent(out) :: lo, hi
      integer, optional, intent(in) :: llim

      integer :: n_div, n_mod, llim_local

      llim_local = 1
      if (present(llim)) llim_local = llim

      n_div = n / nproc
      n_mod = mod(n, nproc)

      lo = iproc * n_div + min(iproc, n_mod) + llim_local
      hi = lo + n_div - 1
      if (iproc < n_mod) hi = hi + 1

   end subroutine split_n_tasks

#endif

end module mp_lu_decomposition


*DECK GAMLN
      REAL FUNCTION GAMLN (Z, IERR)
C***BEGIN PROLOGUE  GAMLN
C***SUBSIDIARY
C***PURPOSE  Compute the logarithm of the Gamma function
C***LIBRARY   SLATEC
C***CATEGORY  C7A
C***TYPE      SINGLE PRECISION (GAMLN-S, DGAMLN-D)
C***KEYWORDS  LOGARITHM OF GAMMA FUNCTION
C***AUTHOR  Amos, D. E., (SNL)
C***DESCRIPTION
C
C         GAMLN COMPUTES THE NATURAL LOG OF THE GAMMA FUNCTION FOR
C         Z.GT.0.  THE ASYMPTOTIC EXPANSION IS USED TO GENERATE VALUES
C         GREATER THAN ZMIN WHICH ARE ADJUSTED BY THE RECURSION
C         G(Z+1)=Z*G(Z) FOR Z.LE.ZMIN.  THE FUNCTION WAS MADE AS
C         PORTABLE AS POSSIBLE BY COMPUTING ZMIN FROM THE NUMBER OF BASE
C         10 DIGITS IN A WORD, RLN=MAX(-ALOG10(R1MACH(4)),0.5E-18)
C         LIMITED TO 18 DIGITS OF (RELATIVE) ACCURACY.
C
C         SINCE INTEGER ARGUMENTS ARE COMMON, A TABLE LOOK UP ON 100
C         VALUES IS USED FOR SPEED OF EXECUTION.
C
C     DESCRIPTION OF ARGUMENTS
C
C         INPUT
C           Z      - REAL ARGUMENT, Z.GT.0.0E0
C
C         OUTPUT
C           GAMLN  - NATURAL LOG OF THE GAMMA FUNCTION AT Z
C           IERR   - ERROR FLAG
C                    IERR=0, NORMAL RETURN, COMPUTATION COMPLETED
C                    IERR=1, Z.LE.0.0E0,    NO COMPUTATION
C
C***REFERENCES  COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
C                 BY D. E. AMOS, SAND83-0083, MAY, 1983.
C***ROUTINES CALLED  I1MACH, R1MACH
C***REVISION HISTORY  (YYMMDD)
C   830501  DATE WRITTEN
C   830501  REVISION DATE from Version 3.2
C   910415  Prologue converted to Version 4.0 format.  (BAB)
C   920128  Category corrected.  (WRB)
C   921215  GAMLN defined for Z negative.  (WRB)
C***END PROLOGUE  GAMLN
C
      INTEGER I, I1M, K, MZ, NZ, IERR, I1MACH
      REAL CF, CON, FLN, FZ, GLN, RLN, S, TLG, TRM, TST, T1, WDTOL, Z,
     * ZDMY, ZINC, ZM, ZMIN, ZP, ZSQ
      REAL R1MACH
      DIMENSION CF(22), GLN(100)
C           LNGAMMA(N), N=1,100
      DATA GLN(1), GLN(2), GLN(3), GLN(4), GLN(5), GLN(6), GLN(7),
     1     GLN(8), GLN(9), GLN(10), GLN(11), GLN(12), GLN(13), GLN(14),
     2     GLN(15), GLN(16), GLN(17), GLN(18), GLN(19), GLN(20),
     3     GLN(21), GLN(22)/
     4     0.00000000000000000E+00,     0.00000000000000000E+00,
     5     6.93147180559945309E-01,     1.79175946922805500E+00,
     6     3.17805383034794562E+00,     4.78749174278204599E+00,
     7     6.57925121201010100E+00,     8.52516136106541430E+00,
     8     1.06046029027452502E+01,     1.28018274800814696E+01,
     9     1.51044125730755153E+01,     1.75023078458738858E+01,
     A     1.99872144956618861E+01,     2.25521638531234229E+01,
     B     2.51912211827386815E+01,     2.78992713838408916E+01,
     C     3.06718601060806728E+01,     3.35050734501368889E+01,
     D     3.63954452080330536E+01,     3.93398841871994940E+01,
     E     4.23356164607534850E+01,     4.53801388984769080E+01/
      DATA GLN(23), GLN(24), GLN(25), GLN(26), GLN(27), GLN(28),
     1     GLN(29), GLN(30), GLN(31), GLN(32), GLN(33), GLN(34),
     2     GLN(35), GLN(36), GLN(37), GLN(38), GLN(39), GLN(40),
     3     GLN(41), GLN(42), GLN(43), GLN(44)/
     4     4.84711813518352239E+01,     5.16066755677643736E+01,
     5     5.47847293981123192E+01,     5.80036052229805199E+01,
     6     6.12617017610020020E+01,     6.45575386270063311E+01,
     7     6.78897431371815350E+01,     7.12570389671680090E+01,
     8     7.46582363488301644E+01,     7.80922235533153106E+01,
     9     8.15579594561150372E+01,     8.50544670175815174E+01,
     A     8.85808275421976788E+01,     9.21361756036870925E+01,
     B     9.57196945421432025E+01,     9.93306124547874269E+01,
     C     1.02968198614513813E+02,     1.06631760260643459E+02,
     D     1.10320639714757395E+02,     1.14034211781461703E+02,
     E     1.17771881399745072E+02,     1.21533081515438634E+02/
      DATA GLN(45), GLN(46), GLN(47), GLN(48), GLN(49), GLN(50),
     1     GLN(51), GLN(52), GLN(53), GLN(54), GLN(55), GLN(56),
     2     GLN(57), GLN(58), GLN(59), GLN(60), GLN(61), GLN(62),
     3     GLN(63), GLN(64), GLN(65), GLN(66)/
     4     1.25317271149356895E+02,     1.29123933639127215E+02,
     5     1.32952575035616310E+02,     1.36802722637326368E+02,
     6     1.40673923648234259E+02,     1.44565743946344886E+02,
     7     1.48477766951773032E+02,     1.52409592584497358E+02,
     8     1.56360836303078785E+02,     1.60331128216630907E+02,
     9     1.64320112263195181E+02,     1.68327445448427652E+02,
     A     1.72352797139162802E+02,     1.76395848406997352E+02,
     B     1.80456291417543771E+02,     1.84533828861449491E+02,
     C     1.88628173423671591E+02,     1.92739047287844902E+02,
     D     1.96866181672889994E+02,     2.01009316399281527E+02,
     E     2.05168199482641199E+02,     2.09342586752536836E+02/
      DATA GLN(67), GLN(68), GLN(69), GLN(70), GLN(71), GLN(72),
     1     GLN(73), GLN(74), GLN(75), GLN(76), GLN(77), GLN(78),
     2     GLN(79), GLN(80), GLN(81), GLN(82), GLN(83), GLN(84),
     3     GLN(85), GLN(86), GLN(87), GLN(88)/
     4     2.13532241494563261E+02,     2.17736934113954227E+02,
     5     2.21956441819130334E+02,     2.26190548323727593E+02,
     6     2.30439043565776952E+02,     2.34701723442818268E+02,
     7     2.38978389561834323E+02,     2.43268849002982714E+02,
     8     2.47572914096186884E+02,     2.51890402209723194E+02,
     9     2.56221135550009525E+02,     2.60564940971863209E+02,
     A     2.64921649798552801E+02,     2.69291097651019823E+02,
     B     2.73673124285693704E+02,     2.78067573440366143E+02,
     C     2.82474292687630396E+02,     2.86893133295426994E+02,
     D     2.91323950094270308E+02,     2.95766601350760624E+02,
     E     3.00220948647014132E+02,     3.04686856765668715E+02/
      DATA GLN(89), GLN(90), GLN(91), GLN(92), GLN(93), GLN(94),
     1     GLN(95), GLN(96), GLN(97), GLN(98), GLN(99), GLN(100)/
     2     3.09164193580146922E+02,     3.13652829949879062E+02,
     3     3.18152639620209327E+02,     3.22663499126726177E+02,
     4     3.27185287703775217E+02,     3.31717887196928473E+02,
     5     3.36261181979198477E+02,     3.40815058870799018E+02,
     6     3.45379407062266854E+02,     3.49954118040770237E+02,
     7     3.54539085519440809E+02,     3.59134205369575399E+02/
C             COEFFICIENTS OF ASYMPTOTIC EXPANSION
      DATA CF(1), CF(2), CF(3), CF(4), CF(5), CF(6), CF(7), CF(8),
     1     CF(9), CF(10), CF(11), CF(12), CF(13), CF(14), CF(15),
     2     CF(16), CF(17), CF(18), CF(19), CF(20), CF(21), CF(22)/
     3     8.33333333333333333E-02,    -2.77777777777777778E-03,
     4     7.93650793650793651E-04,    -5.95238095238095238E-04,
     5     8.41750841750841751E-04,    -1.91752691752691753E-03,
     6     6.41025641025641026E-03,    -2.95506535947712418E-02,
     7     1.79644372368830573E-01,    -1.39243221690590112E+00,
     8     1.34028640441683920E+01,    -1.56848284626002017E+02,
     9     2.19310333333333333E+03,    -3.61087712537249894E+04,
     A     6.91472268851313067E+05,    -1.52382215394074162E+07,
     B     3.82900751391414141E+08,    -1.08822660357843911E+10,
     C     3.47320283765002252E+11,    -1.23696021422692745E+13,
     D     4.88788064793079335E+14,    -2.13203339609193739E+16/
C
C             LN(2*PI)
      DATA CON                    /     1.83787706640934548E+00/
C
C***FIRST EXECUTABLE STATEMENT  GAMLN
      IERR=0
      IF (Z.LE.0.0E0) GO TO 70
      IF (Z.GT.101.0E0) GO TO 10
      NZ = Z
      FZ = Z - NZ
      IF (FZ.GT.0.0E0) GO TO 10
      IF (NZ.GT.100) GO TO 10
      GAMLN = GLN(NZ)
      RETURN
   10 CONTINUE
      WDTOL = R1MACH(4)
      WDTOL = MAX(WDTOL,0.5E-18)
      I1M = I1MACH(11)
      RLN = R1MACH(5)*I1M
      FLN = MIN(RLN,20.0E0)
      FLN = MAX(FLN,3.0E0)
      FLN = FLN - 3.0E0
      ZM = 1.8000E0 + 0.3875E0*FLN
      MZ = ZM + 1
      ZMIN = MZ
      ZDMY = Z
      ZINC = 0.0E0
      IF (Z.GE.ZMIN) GO TO 20
      ZINC = ZMIN - NZ
      ZDMY = Z + ZINC
   20 CONTINUE
      ZP = 1.0E0/ZDMY
      T1 = CF(1)*ZP
      S = T1
      IF (ZP.LT.WDTOL) GO TO 40
      ZSQ = ZP*ZP
      TST = T1*WDTOL
      DO 30 K=2,22
        ZP = ZP*ZSQ
        TRM = CF(K)*ZP
        IF (ABS(TRM).LT.TST) GO TO 40
        S = S + TRM
   30 CONTINUE
   40 CONTINUE
      IF (ZINC.NE.0.0E0) GO TO 50
      TLG = ALOG(Z)
      GAMLN = Z*(TLG-1.0E0) + 0.5E0*(CON-TLG) + S
      RETURN
   50 CONTINUE
      ZP = 1.0E0
      NZ = ZINC
      DO 60 I=1,NZ
        ZP = ZP*(Z+(I-1))
   60 CONTINUE
      TLG = ALOG(ZDMY)
      GAMLN = ZDMY*(TLG-1.0E0) - ALOG(ZP) + 0.5E0*(CON-TLG) + S
      RETURN
C
C
   70 CONTINUE
      GAMLN = R1MACH(2)
      IERR=1
      RETURN
      END


  subroutine setPhotoChannelSigma (sDCM, egamma, photoData)

! ======================================================================
!    Main routine to extract ds/do for channel 1-4 (single pion
!    production):
!
!    Written by K. K. Gudima, Fall 2003?
!    Modified by AJS, May, 2004.
!    Modified by KKG, Sep., 2004
!    Edited by AJS, January, 2005.
!    Modified by AJS, February, 2005.
!    Edited by AJS, LANL T-2, December, 2011.
!    Edited by LMK, XCP-3, July 2013 (included error protection).
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64
    use standardDCMParams, only: zro, one, two, radianToDegree, emnucg
    use standardDCMData,   only: domo2, domo2i, gppipn, gppi0p, elg, &
         & thetai, photonEG

    implicit none
    class(StandardDCM),            intent(inout) :: sDCM
    real(real64),                  intent(in   ) :: egamma
    type(sDCMPhotonCrossSections), intent(  out) :: photoData

    integer(int32) :: ie, ieg1, ieg2, j, jch
    real(real64)   :: deleg, den1, eg1, eg2, sig1, sig2, sint, temp

    real(real64), dimension(2, 20) :: sig = zro
    real(real64), dimension(2, 19) :: r   = zro

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

    ! Obtain cross section for gamma energy in each channel at each angle
    do jch = 1,2

       ! Obtain ieg1/2 values for nearest cross section data
       if (egamma <= elg(jch,2)) then
          ieg1 = 2
          ieg2 = 3
       elseif (egamma >= elg(jch,50)) then
          ieg1 = 49
          ieg2 = 50
       else
          do ie = 3,50
             if (egamma >= elg(jch,ie-1) .and. egamma <= elg(jch,ie)) then
                ieg1 = ie - 1
                ieg2 = ie
                go to 10
             endif
          enddo
       endif

10     continue

       ! Check ieg1/2 values for validity (i.e. within range)
       if (ieg1 < 2 .or. ieg1 > 49 .or. ieg2 < 3 .or. ieg2 > 50) then
          write(sDCM%io%message,2000) ieg1, ieg2
          call sDCM%io%print(3, 3, sDCM%io%message)
          write(sDCM%io%message,2010)
          call sDCM%io%print(3, 3, sDCM%io%message)

          ! Obtain nearest index
          if ( ieg1 <  2 ) ieg1 =  2
          if ( ieg1 > 49 ) ieg1 = 49
          if ( ieg2 <  3 ) ieg2 =  3
          if ( ieg2 > 50 ) ieg2 = 50
       endif

       ! Obtain interpolation energies for the channel
       eg1 = elg(jch,ieg1)
       eg2 = elg(jch,ieg2)
       temp = eg2 - eg1
       if (temp < div0Lim .and. temp > -div0Lim) then
          temp = div0Lim
          write(sDCM%io%message,1000) "116"
          call sDCM%io%print(4, 3, sDCM%io%message)
       end if

       ! Obtain interpolation values (den1 and deleg)
       den1 = zro
       if (eg2.ne.eg1) den1 = one/(temp)
       deleg = egamma - eg1
       sint = zro

       ! Obtain cross section for all bins
       do j = 1,19

          ! Obtain points nearest data for the channel
          if (jch == 1)     then
             sig1 = gppipn(ieg1,j)
             sig2 = gppipn(ieg2,j)
          elseif (jch == 2) then
             sig1 = gppi0p(ieg1,j)
             sig2 = gppi0p(ieg2,j)
          endif

          ! Perform linear interpolation
          sig(jch,j) = sig1 + (sig2 - sig1)*(den1*deleg)

          ! Calculate the channel's angle-integrated cross section
          if (j >= 2) then
             sint = sint + domo2(j)*(sig(jch,j-1) + sig(jch,j))
          endif
          r(jch,j) = sint

       enddo
       sig(jch,20) = sint

       ! Normalize 'r" for all bins in the channel
       do j = 1,19
          if (sint > zro) r(jch,j) = r(jch,j)/sint
       enddo

    end do

    ! Obtain "fine" mesh cross section based on the "course" mesh cross sections
    do jch = 1,2
       sint = zro
       do j = 1,181
          ! Interpolate for angle "j" based on course mesh (theta, sig)
          photoData%si(jch,j) = photonEG%qintxs(thetai(j), sig, jch, 2, 19)

          ! Calculate angle-integrated cross section
          if (j >= 2) then
             sint = sint + domo2i(j)*(photoData%si(jch,j-1) + photoData%si(jch,j))
          endif
          photoData%ri(jch,j) = sint
       end do
       photoData%si(jch,182) = sint

       ! Normalize "ri" for each angle
       do j = 1,181
          if (sint > zro) photoData%ri(jch,j) = photoData%ri(jch,j)/sint
       enddo

    end do

    return

! ======================================================================
1000 format("Divide by zero error prevented in ", &
          & "'setPhotoChannelSigma.f90', line(s)", A)
2000 format("Photon cross section interpolation bounds (ieg1=", i3, &
          & ", ieg2=", i3, ") could not be obtained.")
2010 format("   Will round to nearest valid bound...")
! ======================================================================
  end subroutine setPhotoChannelSigma


      subroutine qlI4sub2ma(xpi,musq,Ival)
      implicit none
C---  Calculates the boxes with two adjacent internal mass

C     Uses the ordering for the routine xpi wanted by FF
C     psq(1) lies between msq(1) and msq(2) and so on
C     xpi(1-4) = msq(1),msq(2),msq(3),msq(4)
C     xpi(5-8) = psq(1),psq(2),psq(3),psq(4)
C     xpi(9-10) = s12,s23
C     xpi(11) = +xpi(5)+xpi(6)+xpi(7)+xpi(8)-xpi(9)-xpi(10)
C     xpi(12) = -xpi(5)+xpi(6)-xpi(7)+xpi(8)+xpi(9)+xpi(10)
C     xpi(13) = +xpi(5)-xpi(6)+xpi(7)-xpi(8)+xpi(9)+xpi(10)

      include 'qlconstants.f'
      double precision xpi(13),musq,Y(4,4),Yalt(4,4)
      double complex Ival(-2:0)
      integer ier
      logical qlzero,qlnonzero

      call qlYcalc(xpi,Y,Yalt)

      if    ((qlzero(Y(1,2)))
     . .and. (qlzero(Y(2,3)))
     . .and. (qlzero(Y(1,4)))) then
         call qlbox11(Y,musq,Ival)

      elseif((qlzero(Y(1,2)))
     . .and. (qlzero(Y(2,3)))
     . .and. (qlnonzero(Y(1,4)))) then
         call qlbox12(Y,musq,Ival)

      elseif((qlzero(Yalt(1,2)))
     . .and. (qlzero(Yalt(2,3)))
     . .and. (qlnonzero(Yalt(1,4)))) then
         call qlbox12(Yalt,musq,Ival)

      elseif((qlzero(Y(1,2)))
     . .and. (qlnonzero(Y(2,3)))
     . .and. (qlnonzero(Y(1,4)))) then
         call qlbox13(Y,musq,Ival)
      else
             Ival(-2)=czip
             Ival(-1)=czip
             xpi(11) = +xpi(5)+xpi(6)+xpi(7)+xpi(8)-xpi(9)-xpi(10)
             xpi(12) = -xpi(5)+xpi(6)-xpi(7)+xpi(8)+xpi(9)+xpi(10)
             xpi(13) = +xpi(5)-xpi(6)+xpi(7)-xpi(8)+xpi(9)+xpi(10)
             call qlI4fin(Ival(0),xpi,ier)
      endif
      return
      end


c=======================================================================
c
c     subroutine ALLOCMDD
c
c     Asset allocation strategy s.t. Maximum Drawdown constraint
c
c-----------------------------------------------------------------------
      SUBROUTINE allocmdd ( ndate, nasset, radata, cov, rmean, neq, nin,
     &                      ccst, bcst, cinf, csup,
     &                      delta, lambda,
     &                      iwork, dwork, wopt, info )
c-----------------------------------------------------------------------
c
c     INPUT
c       ndate  : number of dates                            integer
c       nasset : number of risky assets                     integer
c       radata : returns assets  matrix(ndate*nasset)        double
c       cov    : covariance  matrix(nasset*nasset)           double
c       rmean  : mean returns  vector(nasset)                double
c       neq    : number of equality constraints             integer
c       nin    : number of inequality constraints           integer
c       ccst   : matrix of constraints (nasset*(neq+nin))    double
c       bcst   : vector of constraints  (neq+nin)            double
c       cinf   : lower bound (nasset)                        double
c       csup   : upper bound (nasset)                        double
c       delta  : maximum drawdown                            double
c       lambda : risk aversion                               double
c
c     WORKSPACE
c       iwork  : 13*nasset+2*ndate+2*nin+neq+1    integer
c       dwork  :                                       double
c                    (   nasset*(6*nasset+ndate+nin+neq+29)
c                        + 4*(ndate+nin) + 2*neq             )
c
c     OUTPUT
c        wopt   : optimal portfolio (nasset)                 double
c        info   : diagnostic argument                        integer
c
c     CALL
c        YM      : copy a vectorized matrix in a vectorized matrix
c        PMX     : computing M*X = matrix
c                  ( M matrix(n*m), X scalar, gives M*X matrix(n*m) )
c        YV      : copy a vector in a vector
c        IVX     : initialization at a scalar of a vector
c        QP      : quadratic solver (vectorized version)
c        TESTSDP : test if covariance matrix is SDP
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER ndate, nasset, neq, nin, info
      DOUBLE PRECISION delta, lambda
      DOUBLE PRECISION radata(ndate,*), cov(*), rmean(*),
     &                 ccst(nasset,*), bcst(*), cinf(*), csup(*),
     &                 wopt(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER ncst, neqtot, nintot, ncstot, i, j, k, icc,
     &        piwork, pdwork, piwk, pgk, psp, pss, psa, pdwk, piwq,
     &        plin, pdwq, plagr, pbcs, pccs, pro, pcov, pisdp, pdsdp
      DOUBLE PRECISION sum
c
c     external subroutines
      EXTERNAL qp, YM, PMX, YV, IVX, testsdp
c
c-----------------------------------------------------------------------
c
c     initialisations
      info = 0
      ncst = neq + nin
      neqtot = neq
      nintot = nin + ndate
      ncstot = neqtot + nintot
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      piwork = 1
      piwk = piwork
c     piwk  : pointer for KATAVEP who needs (12*nasset)
      pgk = piwk + (12*nasset)
c     pgk   : pointer Kato groups, so (nasset) more
c     the call of KATAVEP needs (13*nasset)
      pisdp  = piwk + (12 * nasset)
c     pisdp  : pointer for TESTSDP (nasset)
c
c     pointers for QUAPRO who uses a part of the same space
      piwq = piwork
c     piwq  : pointer for QUAPRO who needs
c             (  3*nasset + 2*nintot + neqtot + 1 ),
c             so (3*nasset + 2*(nin+ndate) + neq + 1 ) more
c     pinext = piwq + ( 3*nasset + 2*ndate + 2*nin + neq + 1 )
c     pinext : pointer for the next iwork array
c
c     together KATAVEP/TESTSDP and QUAPRO need (union of space)
c     ( 14*nasset + 2*nin + neq + 7 )
c
c     Total size of iwork array = ( 14*nasset + 2*ndate + 2*nin + neq + 1 )
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pro = 1
c     pro  : pointer for robust cov. matrix, so (nasset*nasset) more
      pcov = pro + (nasset*nasset)
c     pcov : pointer for covariance matrix, so (nasset*nasset) more
      pdwork = pcov + (nasset*nasset)
c
      psp = pdwork
c     psp  : pointer for vector spectr of KATAVEP, so (nasset) more
      pss = psp + (nasset)
c     pss  : pointer for vector eigsor of KATAVEP, so (nasset) more
      psa = pss + (nasset)
c     psa  : pointer for vector spectr of KATAVEP, so (nasset) more
      pdwk = psa + (nasset)
c     pdwk : pointer for KATAVEP workspace, needs nasset*(4*nasset+26)
c     so KATAVEP needs nasset*(4*nasset+29)
      pdsdp = pdwk + nasset*(4*nasset + 26)
c     pdsdp : pointer for TESTSDP (nasset*(2*nasset + 7))
c
c     pointers for QUAPRO who uses a part of the same space
c     than KATAVEP
      plin = pdwork
c     plin  : pointer for linear part vector, so ( nasset ) more
      pdwq = plin + ( nasset )
c     pdwq  : pointer for QUAPRO workspace who needs
c             (nasset*nasset + 6*nasset + 2*nintot),
c             so ( nasset*(nasset+6) + 2*nintot ) more
      plagr = pdwq + ( nasset*(nasset+6) + 2*nintot )
c     plagr  : pointer for Lagrange multipliers vector
c              ( nasset + nintot + neqtot ),
c              so ( nasset + nintot + neqtot ) more
      pbcs = plagr +  ( nasset + nintot + neqtot )
c     pbcs : pointer for the constraints vector ( nintot + neqtot ),
c              so ( nintot + neqtot ) more
      pccs = pbcs +  ( nintot + neqtot )
c     pccs : pointer for the constraints matrix
c              nasset*( nintot + neqtot ),
c              so nasset*( nintot + neqtot ) more
c     so QUAPRO needs :  nasset
c                      + nasset*(nasset+6) + 2*(nintot)
c                      + nasset + nintot + neqtot
c                      + nintot + neqtot
c                      + nasset*( nintot + neqtot )
c
c                      = nasset*(1+(nasset+6)+1 + nintot+neqtot)
c                      + 2*nintot + nintot + neqtot + nintot + neqtot
c
c                      = nasset*( 2*nasset + nintot + neqtot + 8 )
c                      + 4*nintot + 2*neqtot
c
c                      = nasset*( 2*nasset + ndate + nin + neq + 8 )
c                      + 4*(ndate+nin) + 2*neq
c
c     together KATAVEP/TESTSDP and QUAPRO need (union of space)
c                        nasset*( 6*nasset + ndate + nin + neq + 36 )
c                      + 4*(ndate+nin) + 2*neq
c
c     Total size of dwork array
c                      = nasset*nasset
c                      + nasset*nasset
c                      + nasset*( 6*nasset + ndate + nin + neq + 36 )
c                      + 4*(ndate+nin) + 2*neq
c
c                      = nasset*( 8*nasset + ndate + nin + neq + 36 )
c                      + 4*(ndate+nin) + 2*neq
c
c-----------------------------------------------------------------------
c
      CALL YM ( nasset, nasset, cov, dwork(pro) )
c
c     covariance matrix SDP ?
      CALL testsdp (nasset,dwork(pro),iwork(pisdp),dwork(pdsdp),info)
      IF (info .NE. 0) THEN
         info = -108
         RETURN
      ENDIF
c
c     covariance matrix * lambda
      CALL PMX ( nasset, nasset, dwork(pro), lambda, dwork(pcov) )
c
c     linear part
      DO i=1,nasset
         dwork(plin+i-1) = - rmean(i)
      ENDDO
c
c     copy vector of constraints and computes new constraints
      CALL YV ( ncst, bcst, dwork(pbcs) )
      CALL IVX ( ndate, dwork(pbcs+ncst), delta )
c
c     copy matrix of constraints
      CALL YV ( nasset*ncst, ccst, dwork(pccs) )
c
c     drawdown constraints
      icc = pccs + nasset*ncst
      DO i=1,nasset
         DO j=1,ndate
            sum = 0.0
            DO k=1,ndate
               sum = sum + ( radata(j,i) - radata(k,i) )
            ENDDO
            dwork(icc) = sum / ndate
            icc = icc + 1
         ENDDO
      ENDDO
c
c     quadratic solver
      CALL qp ( nasset, dwork(pcov), dwork(plin), neqtot, nintot,
     &          dwork(pccs), dwork(pbcs), cinf, csup,
     &          iwork(piwq), dwork(pdwq), dwork(plagr), wopt,
     &          info )
c
      RETURN
      END


      subroutine ero_ysed

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine predicts daily soil loss caused by water erosion
!!    using the modified universal soil loss equation

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    cvm(:)      |none          |natural log of USLE_C (the minimum value
!!                               |of the USLE C factor for the land cover)
!!    hru_km(:)   |km**2         |area of HRU in square kilometers
!!    peakr       |m^3/s         |peak runoff rate
!!    surfq(:)    |mm H2O        |surface runoff for the day in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    cklsp(:)    |
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    bio_frcov   |              |fraction of cover by biomass - adjusted for
!!                                  canopy height
!!    grcov_fr    |              |fraction of cover by biomass as function of lai
!!    rsd_frcov   |              |fraction of cover by residue
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Exp

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use hru_module, only : hru, usle_cfac, cklsp, surfq, sedyld, sanyld, silyld, clayld, lagyld, sagyld,  &
         ihru, peakr, usle_ei
      use soil_module

      implicit none

      integer :: j           !none                   |HRU number
      real :: c              !                       |
      real :: usle           !!metric tons/ha        | daily soil loss predicted with USLE equation

      j = ihru

      !! initialize variables
      cklsp(j) = usle_cfac(j) * hru(j)%lumv%usle_mult

      !! compute sediment yield with musle
      sedyld(j) = (surfq(j) * peakr * 1000. * hru(j)%km) ** .56 * cklsp(j)

      if (sedyld(j) < 0.) sedyld(j) = 0.

      !!adjust sediment yield for protection of snow cover
      if (hru(j)%sno_mm > 0.) then
        if (sedyld(j) < 1.e-6) sedyld(j) = 0.0
      else if (hru(j)%sno_mm > 100.) then
        sedyld(j) = 0.
      else
        sedyld(j) = sedyld(j) / Exp(hru(j)%sno_mm * 3. / 25.4)
      end if

	!!Particle size distribution of sediment yield
	  sanyld(j) = sedyld(j) * soil(j)%det_san    !! Sand yield
	  silyld(j) = sedyld(j) * soil(j)%det_sil    !! Silt yield
	  clayld(j) = sedyld(j) * soil(j)%det_cla    !! Clay yield
	  sagyld(j) = sedyld(j) * soil(j)%det_sag    !! Small Aggregate yield
	  lagyld(j) = sedyld(j) * soil(j)%det_lag    !! Large Aggregate yield

      !! compute erosion with usle (written to output for comparison)
      usle = 1.292 * usle_ei * cklsp(j) / 11.8

      return
      end subroutine ero_ysed