program drive_hhe include 'implno.dek' include 'const.dek' include 'timers.dek' include 'burn_common.dek' include 'network.dek' c..this program exercises the hhe network c..declare integer i,j,nok,nbad double precision tstart,tstep,conserv,tin,din,ein,vin,zin,xin(34), 1 tout,dout,eout,xout(34) c..initialize the network call init_hhe c..keep coming back to here 20 continue call net_input(tstart,tstep,tin,din,vin,zin,ein,xin) c..start the clock call zsecond(timzer) c..a message write(6,*) write(6,*) 'starting integration' write(6,*) c..burn it call burner(tstep,tin,din,ein,xin, 1 tout,dout,eout,xout, 2 conserv,nok,nbad) c..output a summary of the integration call net_summary(tstep,tin,din,ein,tout,dout,eout,conserv, 1 nbad,nok,xout) c..back for another input point goto 20 end subroutine burner(tstep,tin,din,ein,xin,tout,dout,eout,xout, 1 conserv,nok,nbad) include 'implno.dek' include 'const.dek' include 'network.dek' c..given time step tstep, temperature tin, density din, thermal c..energy ein, and the composition xin, this routine returns the c..burned composition xout, final temperature tout, final density dout, c..and the final thermal energy eout. c..declare the pass integer nok,nbad double precision tstep,tin,din,ein,xin(1), 1 tout,dout,eout,xout(1),conserv c..local variables integer i,k,kk double precision abar,zbar,wbar,ye,xcess c..for the integration driver integer kount,nbig double precision beg,stptry,stpmin,tend,ys2(abignet*nzmax), 1 odescal,tol parameter (tol = 1.0d-6, 1 odescal = 1.0d-6) external hhe,shhe,bhhe,dhhe c external forder_ma28 c external forder_umf c external forder_y12m c external forder_ludcmp c external forder_leqs c external forder_lapack c external forder_gift c external forder_biconj c external rosen_ma28 c external rosen_umf c external rosen_y12m c external rosen_ludcmp c external rosen_leqs c external rosen_lapack c external rosen_gift c external rosen_biconj external stifbs_ma28 c external stifbs_umf c external stifbs_y12m c external stifbs_ludcmp c external stifbs_leqs c external stifbs_lapack c external stifbs_gift c external stifbs_biconj c..load the mass fractions do i=1,ionmax xmass(i) = xin(i) enddo c..get abar, zbar and a few other composition variables call azbar(xmass,aion,zion,wion,ionmax, 1 ymass,abar,zbar,wbar,ye,xcess) c..stuff the initial conditions into ys2 do i=1,ionmax ys2(i) = ymass(i) enddo c..energy, temperature, density ys2(iener) = ein ys2(itemp) = tin ys2(iden) = din c..single step (tend=tstep), hydrostatic, or expansion ending times c..the variable tstep has two meanings here. tstep in single step mode c..is the size of the time step to try. tstep in hydrostatic or expansion c..mode is the ending integration time. the integration driver really c..gets some exercise if tstep is large in single step mode. beg = 0.0d0 tend = tstep if (one_step) then stptry = tstep stpmin = tstep * 1.0d-20 else stptry = max(beg * 1.0d-10,1.0d-16) stpmin = stptry * 1.0d-12 end if c..integrate the hhe network call netint(beg,stptry,stpmin,tend,ys2, 1 tol,neqs,nok,nbad,kount,odescal, c 4 hhe,shhe,bhhe,forder_ma28) c 4 hhe,shhe,bhhe,forder_umf) c 4 hhe,shhe,bhhe,forder_y12m) c 4 hhe,dhhe,bhhe,forder_ludcmp) c 4 hhe,dhhe,bhhe,forder_leqs) c 4 hhe,dhhe,bhhe,forder_lapack) c 4 hhe,dhhe,bhhe,forder_gift) c 4 hhe,shhe,bhhe,forder_biconj) c 4 hhe,shhe,bhhe,rosen_ma28) c 4 hhe,shhe,bhhe,rosen_umf) c 4 hhe,shhe,bhhe,rosen_y12m) c 4 hhe,dhhe,bhhe,rosen_ludcmp) c 4 hhe,dhhe,bhhe,rosen_leqs) c 4 hhe,dhhe,bhhe,rosen_lapack) c 4 hhe,dhhe,bhhe,rosen_gift) c 4 hhe,shhe,bhhe,rosen_biconj) 4 hhe,shhe,bhhe,stifbs_ma28) c 4 hhe,shhe,bhhe,stifbs_umf) c 4 hhe,shhe,bhhe,stifbs_y12m) c 4 hhe,dhhe,bhhe,stifbs_ludcmp) c 4 hhe,dhhe,bhhe,stifbs_leqs) c 4 hhe,dhhe,bhhe,stifbs_lapack) c 4 hhe,dhhe,bhhe,stifbs_gift) c 4 hhe,shhe,bhhe,stifbs_biconj) c..set the output composition do i=1,ionmax xout(i) = ys2(i) * aion(i) enddo c..output temperature, density, and thermal energy tout = ys2(itemp) dout = ys2(iden) eout = ys2(iener) c..set the mass non-conservation conserv = 0.0d0 do i=1,ionmax conserv = conserv + xout(i) enddo conserv = 1.0d0 - conserv return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- c..this file contains hhe network c..routine hhe sets up the odes c..routine rhs evaluates the right hand side c..routine dhhe sets up the dense hhe jacobian c..routine bhhe build the nonzero locations for shhe c..routine shhe sets up the sparse hhe jacobian c..routine hherat generates the reaction rates for routine hhe c..routine hhetab generates the raw rates from table interpolation c..routine screen_hhe applies screening corrections to the raw rates c..routine init_hhe initializes the hhe network subroutine hhe(tt,y,dydt) include 'implno.dek' include 'const.dek' include 'burn_common.dek' include 'network.dek' include 'vector_eos.dek' c..this routine sets up the system of ode's for the 3 pp chains, c..4 cno cycles, 2 hot cno cycles, triple alfa, and an rp process aproximation c..to ni56. c..pp123 isotopes: h1, h2, he3, he4, li7, be7, b8 c..cno isotopes cycle1: h1, he4, c12, n13, c13, n14, o15, n15 c.. cycle2: o16, f17, o17 c.. cycle3: f18, o18 c.. cycle4: f19 c.. hot : o14 ne18 c.. rp : ne19, ne20, mg22, s30 ni56 c.. achain: mg24, si28, s32, ar36, ca40, ti44, cr48, fe52 c..declare the pass double precision tt,y(1),dydt(1) c..local variables logical deriva parameter (deriva = .false.) integer i double precision enuc,taud,taut,snupp,snucno,sum1,sum2,z, 1 zbarxx,ytot1,abar,zbar,ye,snuda,snudz double precision conv parameter (conv = ev2erg*1.0d6*avo) c..positive definite mass fractions do i=1,ionmax y(i) = min(1.0d0,max(y(i),1.0d-30)) enddo c..generate abar and zbar for this composition zbarxx = 0.0d0 ytot1 = 0.0d0 do i=1,ionmax ytot1 = ytot1 + y(i) zbarxx = zbarxx + zion(i) * y(i) enddo abar = 1.0d0/ytot1 zbar = zbarxx * abar ye = zbar * ytot1 c..positive definite temperatures and densities y(itemp) = min(1.0d11,max(y(itemp),1.0d4)) y(iden) = min(1.0d11,max(y(iden),1.0d-10)) c..for evolution equations with the network if (pure_network .eq. 0) then c..get the new temperature and density if need be if (trho_hist) call update2(tt,y(itemp),y(iden)) if (self_heat_const_pres) then jlo_eos = 1 jhi_eos = 1 ptot_row(1) = bpres temp_row(1) = y(itemp) abar_row(1) = abar zbar_row(1) = zbar den_row(1) = y(iden) call invert_helm_pt_quiet y(iden) = den_row(1) end if c..positive definite temperatures and densities y(itemp) = min(1.0d11,max(y(itemp),1.0d4)) y(iden) = min(1.0d11,max(y(iden),1.0d-10)) c..set the common block temperature and density btemp = y(itemp) bden = y(iden) c..for pure network else if (pure_network .eq. 1) then if (trho_hist) call update2(tt,btemp,bden) end if c..get the reaction rates if (use_tables .eq. 1) then call hhetab(ye) else call hherat(ye) end if c..do the screening here because the corrections depend on the composition call screen_hhe(y) c..get the right hand side of the odes call rhs(y,ratdum,dydt,deriva) c..if we are doing a pure network, we are done if (pure_network .eq. 1) return c..instantaneous energy generation rate enuc = 0.0d0 do i=1,ionmax enuc = enuc + dydt(i) * bion(i) enddo enuc = enuc * conv sdot = enuc c..get the neutrino losses call sneut5(btemp,bden,abar,zbar, 1 sneut,dsneutdt,dsneutdd,snuda,snudz) c..get the specific pp neutrino losses sneutpp = snupp(y(ih1),ratdum(irpp), 1 y(ibe7),ratdum(irbeec), 2 y(ib8),ratdum(irb8ep)) c..get the specific cno neutrino losses sneutcno = snucno(y(in13),bion(ic13),bion(in13), 1 y(io14),bion(in14),bion(io14), 2 y(io15),bion(in15),bion(io15), 3 y(if17),bion(io17),bion(if17), 4 y(if18),bion(io18),bion(if18)) c..sum 'em sneut = sneut + sneutpp + sneutcno c..append an energy equation dydt(iener) = enuc - sneut c..the type of temperature and density ode's depend c..on the burn mode: c..hydrostatic or single step cases if (hydrostatic .or. one_step .or. trho_hist) then dydt(itemp) = 0.0d0 dydt(iden) = 0.0d0 c..adiabatic expansion or contraction else if (expansion) then taud = 446.0d0/sqrt(den0) taut = 3.0d0 * taud dydt(itemp) = -psi * y(itemp)/taut dydt(iden) = -psi * y(iden)/taud c..self heating else if (self_heat_const_den) then c..call an eos temp_row(1) = btemp den_row(1) = bden abar_row(1) = abar zbar_row(1) = zbar jlo_eos = 1 jhi_eos = 1 call helmeos c..density equation dydt(iden) = 0.0d0 c..temperature equation that is self-consistent with an eos z = 1.0d0/cv_row(1) dydt(itemp) = z*dydt(iener) end if return end subroutine rhs(y,rate,dydt,deriva) include 'implno.dek' include 'const.dek' include 'burn_common.dek' include 'network.dek' c..evaluates the right hand side of the aprox13 odes c..declare the pass logical deriva double precision y(1),rate(1),dydt(1) c..local variables integer i double precision sixth parameter (sixth = 1.0d0/6.0d0) c..zero the abundance odes do i=1,ionmax dydt(i) = 0.0d0 enddo c..set up the system of odes: c..from pp123 c..h1 reactions dydt(ih1) = -y(ih1)*y(ih1)*(rate(irpp) + rate(irpep)) 1 - y(ih1)*y(ih2)*rate(irdpg) 2 + y(ihe3)*y(ihe3)*rate(ir33) 3 - y(ih1)*y(ili7)*rate(irli7pa) 4 - y(ibe7)*y(ih1)*rate(irbepg) 5 + y(ib8)*rate(irb8gp) 6 - y(ihe3)*y(ih1)*rate(irhep) c..h2 reactions dydt(ih2) = -y(ih1)*y(ih2)*rate(irdpg) 1 + 0.5d0*y(ih1)*y(ih1)*(rate(irpp) + rate(irpep)) c..he3 reactions dydt(ihe3) = -y(ihe3)*y(ihe3)*rate(ir33) 1 + y(ih1)*y(ih2)*rate(irdpg) 2 - y(ihe3)*y(ihe4)*rate(irhe3ag) 3 - y(ihe3)*y(ih1)*rate(irhep) c..4he reactions dydt(ihe4) = 0.5d0*y(ihe3)*y(ihe3)*rate(ir33) 1 - y(ihe3)*y(ihe4)*rate(irhe3ag) 2 + 2.0d0*y(ili7)*y(ih1)*rate(irli7pa) 3 + 2.0d0*y(ib8)*rate(irb8ep) 4 + y(ihe3)*y(ih1)*rate(irhep) c..li7 reactions dydt(ili7) = -y(ili7)*y(ih1)*rate(irli7pa) 1 + y(ibe7)*rate(irbeec) c..be7 reactions dydt(ibe7) = -y(ibe7)*y(ih1)*rate(irbepg) 1 + y(ihe3)*y(ihe4)*rate(irhe3ag) 2 - y(ibe7)*rate(irbeec) 3 + y(ib8)*rate(irb8gp) c..b8 reactions dydt(ib8) = y(ibe7)*y(ih1)*rate(irbepg) 1 - y(ib8)*rate(irb8ep) 2 - y(ib8)*rate(irb8gp) c..add in the hot cno contributions c..h1 reactions dydt(ih1) = dydt(ih1) 1 - y(ic12)*y(ih1)*rate(irc12pg) 1 + y(in13)*rate(irn13gp) 2 - y(ic13)*y(ih1)*rate(irc13pg) 3 + y(in14)*rate(irn14gp) 4 - y(in14)*y(ih1)*rate(irn14pg) 5 + y(io15)*rate(iro15gp) 6 - y(in15)*y(ih1)*rate(irn15pa) 7 + y(ic12)*y(ihe4)*rate(irc12ap) 8 - y(in15)*y(ih1)*rate(irn15pg) 9 + y(io16)*rate(iro16gp) & - y(io16)*y(ih1)*rate(iro16pg) 1 + y(if17)*rate(irf17gp) dydt(ih1) = dydt(ih1) 1 - y(io17)*y(ih1)*rate(iro17pa) 2 + y(in14)*y(ihe4)*rate(irn14ap) 3 - y(io17)*y(ih1)*rate(iro17pg) 4 + y(if18)*rate(irf18gp) 5 - y(io18)*y(ih1)*rate(iro18pa) 6 + y(in15)*y(ihe4)*rate(irn15ap) 7 - y(io18)*y(ih1)*rate(iro18pg) 8 + y(if19)*rate(irf19gp) 9 - y(if19)*y(ih1)*rate(irf19pa) & + y(io16)*y(ihe4)*rate(iro16ap) 1 - y(in13)*y(ih1)*rate(irn13pg) 2 + y(io14)*rate(iro14gp) dydt(ih1) = dydt(ih1) 1 + y(io14) * y(ihe4) * rate(iro14ap) 2 - y(if17) * y(ih1) * rate(irf17pa) 3 - y(if17) * y(ih1) * rate(irf17pg) 4 + y(ine18) * rate(irne18gp) 5 - y(if18) * y(ih1) * rate(irf18pa) 6 + y(io15) * y(ihe4) * rate(iro15ap) 7 - 8.0d0 * y(img22) * y(ih1) * 8 rate(iralam1)*(1.0d0 - ratdum(irdelta1)) 9 - 26.0d0 * y(is30) * y(ih1) * & rate(iralam2)*(1.0d0 - ratdum(irdelta2)) 1 - 3.0d0*y(ine19)*y(ih1)*rate(irne19pg) 2 - 2.0d0*y(ine20)*y(ih1)*rate(irne20pg) c..he4 reactions dydt(ihe4) = dydt(ihe4) 1 + y(in15)*y(ih1)*rate(irn15pa) 1 - y(ic12)*y(ihe4)*rate(irc12ap) 2 + y(io17)*y(ih1)*rate(iro17pa) 3 - y(in14)*y(ihe4)*rate(irn14ap) 4 + y(io18)*y(ih1)*rate(iro18pa) 5 - y(in15)*y(ihe4)*rate(irn15ap) 6 + y(if19)*y(ih1)*rate(irf19pa) 7 - y(io16)*y(ihe4)*rate(iro16ap) 8 - y(io14) * y(ihe4) * rate(iro14ap) 9 + y(if17) * y(ih1) * rate(irf17pa) & + y(if18) * y(ih1) * rate(irf18pa) dydt(ihe4) = dydt(ihe4) 1 - y(io15) * y(ihe4) * rate(iro15ap) 2 - 0.5d0 * y(ihe4) * y(ihe4) * y(ihe4) * rate(ir3a) 3 + 3.0d0 * y(ic12) * rate(irg3a) 4 - 2.0d0 * y(img22)* y(ihe4) * 5 rate(iralam1) * ratdum(irdelta1) 6 - 6.5d0 * y(is30) * y(ihe4) * 7 rate(iralam2) * ratdum(irdelta2) 8 - y(ine18) * y(ihe4) * rate(irne18ap) 9 - y(io15) * y(ihe4) * rate(iro15ag) & + 0.5d0 * y(ic12) * y(ic12) * rate(ir1212) 1 + 0.5d0 * y(ic12) * y(io16) * rate(ir1216) 2 + 0.56d0* 0.5d0 * y(io16)*y(io16) * rate(ir1616) c..(a,g) and (g,a) reactions dydt(ihe4) = dydt(ihe4) 3 - y(ihe4) * y(ic12) * rate(ircag) 4 + y(io16) * rate(iroga) 5 - y(ihe4) * y(io16) * rate(iroag) 6 + y(ine20) * rate(irnega) 7 - y(ihe4) * y(ine20) * rate(irneag) 8 + y(img24) * rate(irmgga) 9 - y(ihe4) * y(img24)* rate(irmgag) & + y(isi28) * rate(irsiga) 1 - y(ihe4) * y(isi28)*rate(irsiag) 2 + y(is32) * rate(irsga) dydt(ihe4) = dydt(ihe4) 1 - y(ihe4) * y(is32) * rate(irsag) 2 + y(iar36) * rate(irarga) 3 - y(ihe4) * y(iar36)*rate(irarag) 4 + y(ica40) * rate(ircaga) 5 - y(ihe4) * y(ica40)*rate(ircaag) 6 + y(iti44) * rate(irtiga) 7 - y(ihe4) * y(iti44)*rate(irtiag) 8 + y(icr48) * rate(ircrga) 9 - y(ihe4) * y(icr48)*rate(ircrag) & + y(ife52) * rate(irfega) 1 - y(ihe4) * y(ife52) * rate(irfeag) 2 + y(ini56) * rate(irniga) c..(a,p)(p,g) and (g,p)(p,a) reactions if (.not.deriva) then dydt(ihe4) = dydt(ihe4) 1 + 0.34d0*0.5d0*y(io16)*y(io16)*rate(irs1)*rate(ir1616) 2 - y(ihe4) * y(img24) * rate(irmgap)*(1.0d0-rate(irr1)) 3 + y(isi28) * rate(irsigp) * rate(irr1) 4 - y(ihe4) * y(isi28) * rate(irsiap)*(1.0d0-rate(irs1)) 5 + y(is32) * rate(irsgp) * rate(irs1) 6 - y(ihe4) * y(is32) * rate(irsap)*(1.0d0-rate(irt1)) 7 + y(iar36) * rate(irargp) * rate(irt1) 8 - y(ihe4) * y(iar36) * rate(irarap)*(1.0d0-rate(iru1)) 9 + y(ica40) * rate(ircagp) * rate(iru1) & - y(ihe4) * y(ica40) * rate(ircaap)*(1.0d0-rate(irv1)) 1 + y(iti44) * rate(irtigp) * rate(irv1) dydt(ihe4) = dydt(ihe4) 1 - y(ihe4) * y(iti44) * rate(irtiap)*(1.0d0-rate(irw1)) 2 + y(icr48) * rate(ircrgp) * rate(irw1) 3 - y(ihe4) * y(icr48) * rate(ircrap)*(1.0d0-rate(irx1)) 4 + y(ife52) * rate(irfegp) * rate(irx1) 5 - y(ihe4) * y(ife52) * rate(irfeap)*(1.0d0-rate(iry1)) 6 + y(ini56) * rate(irnigp) * rate(iry1) else dydt(ihe4) = dydt(ihe4) 1 + 0.34d0*0.5d0*y(io16)*y(io16)* 2 (ratdum(irs1)*rate(ir1616) + rate(irs1)*ratdum(ir1616)) 3 - y(ihe4)*y(img24)*(rate(irmgap)*(1.0d0 - ratdum(irr1)) 4 - ratdum(irmgap)*rate(irr1)) 5 + y(isi28) * (ratdum(irsigp) * rate(irr1) + 6 rate(irsigp) * ratdum(irr1)) 7 - y(ihe4)*y(isi28)*(rate(irsiap)*(1.0d0 - ratdum(irs1)) 8 - ratdum(irsiap)*rate(irs1)) 9 + y(is32) * (ratdum(irsgp) * rate(irs1) + & rate(irsgp) * ratdum(irs1)) dydt(ihe4) = dydt(ihe4) 1 - y(ihe4)*y(is32)*(rate(irsap)*(1.0d0 - ratdum(irt1)) 2 - ratdum(irsap)*rate(irt1)) 3 + y(iar36) * (ratdum(irargp) * rate(irt1) + 4 rate(irargp) * ratdum(irt1)) 5 - y(ihe4)*y(iar36)*(rate(irarap)*(1.0d0 - ratdum(iru1)) 6 - ratdum(irarap)*rate(iru1)) 7 + y(ica40) * (ratdum(ircagp) * rate(iru1) + 8 rate(ircagp) * ratdum(iru1)) 9 - y(ihe4)*y(ica40)*(rate(ircaap)*(1.0d0-ratdum (irv1)) & - ratdum(ircaap)*rate(irv1)) 1 + y(iti44) * (ratdum(irtigp) * rate(irv1) + 2 rate(irtigp) * ratdum(irv1)) dydt(ihe4) = dydt(ihe4) 1 - y(ihe4)*y(iti44)*(rate(irtiap)*(1.0d0 - ratdum(irw1)) 2 - ratdum(irtiap)*rate(irw1)) 3 + y(icr48) * (ratdum(ircrgp) * rate(irw1) + 4 rate(ircrgp) * ratdum(irw1)) 5 - y(ihe4)*y(icr48)*(rate(ircrap)*(1.0d0 - ratdum(irx1)) 6 - ratdum(ircrap)*rate(irx1)) 7 + y(ife52) * (ratdum(irfegp) * rate(irx1) + 8 rate(irfegp) * ratdum(irx1)) 9 - y(ihe4)*y(ife52)*(rate(irfeap)*(1.0d0 - ratdum(iry1)) & - ratdum(irfeap)*rate(iry1)) 1 + y(ini56) * (ratdum(irnigp) * rate(iry1) + 2 rate(irnigp) * ratdum(iry1)) end if c..c12 reactions dydt(ic12) = -y(ic12)*y(ih1)*rate(irc12pg) 1 + y(in13)*rate(irn13gp) 2 + y(in15)*y(ih1)*rate(irn15pa) 3 - y(ic12)*y(ihe4)*rate(irc12ap) 4 + sixth * y(ihe4) * y(ihe4) * y(ihe4) * rate(ir3a) 5 - y(ic12) * rate(irg3a) 6 + y(io16) * rate(iroga) 7 - y(ic12) * y(ihe4) * rate(ircag) 8 - y(ic12) * y(ic12) * rate(ir1212) 9 - y(ic12) * y(io16) * rate(ir1216) c..c13 reactions dydt(ic13) = y(in13)*rate(irn13enu) 1 - y(ic13)*y(ih1)*rate(irc13pg) 2 + y(in14)*rate(irn14gp) c..n13 reactions dydt(in13) = y(ic12)*y(ih1)*rate(irc12pg) 1 - y(in13)*rate(irn13gp) 2 - y(in13)*rate(irn13enu) 3 - y(in13)*y(ih1)*rate(irn13pg) 4 + y(io14)*rate(iro14gp) c..n14 reactions dydt(in14) = y(ic13)*y(ih1)*rate(irc13pg) 1 - y(in14)*rate(irn14gp) 2 - y(in14)*y(ih1)*rate(irn14pg) 3 + y(io15)*rate(iro15gp) 4 + y(io17)*y(ih1)*rate(iro17pa) 5 - y(in14)*y(ihe4)*rate(irn14ap) 6 + y(io14)*rate(iro14enu) c..n15 reactions dydt(in15) = y(io15)*rate(iro15enu) 1 - y(in15)*y(ih1)*rate(irn15pa) 2 + y(ic12)*y(ihe4)*rate(irc12ap) 3 - y(in15)*y(ih1)*rate(irn15pg) 4 + y(io16)*rate(iro16gp) 5 + y(io18)*y(ih1)*rate(iro18pa) 6 - y(in15)*y(ihe4)*rate(irn15ap) c..o14 reactions dydt(io14) = y(in13)*y(ih1)*rate(irn13pg) 1 - y(io14)*rate(iro14gp) 2 - y(io14)*rate(iro14enu) 3 - y(io14) * y(ihe4) * rate(iro14ap) 4 + y(if17) * y(ih1) * rate(irf17pa) c..o15 reactions dydt(io15) = y(in14)*y(ih1)*rate(irn14pg) 1 - y(io15)*rate(iro15gp) 2 - y(io15)*rate(iro15enu) 3 + y(if18) * y(ih1) * rate(irf18pa) 4 - y(io15) * y(ihe4) * rate(iro15ap) 5 - y(io15) * y(ihe4) * rate(iro15ag) c..o16 reactions dydt(io16) = y(in15)*y(ih1)*rate(irn15pg) 1 - y(io16)*rate(iro16gp) 2 - y(io16)*y(ih1)*rate(iro16pg) 3 + y(if17)*rate(irf17gp) 4 + y(if19)*y(ih1)*rate(irf19pa) 5 - y(io16)*y(ihe4)*rate(iro16ap) 6 + y(ic12) * y(ihe4) * rate(ircag) 7 - y(io16) * rate(iroga) 8 - y(io16) * y(ihe4) * rate(iroag) 9 + y(ine20) * rate(irnega) & - y(ic12) * y(io16) * rate(ir1216) 1 - y(io16) * y(io16) * rate(ir1616) c..o17 reactions dydt(io17) = y(if17)*rate(irf17enu) 1 - y(io17)*y(ih1)*rate(iro17pa) 2 + y(in14)*y(ihe4)*rate(irn14ap) 3 - y(io17)*y(ih1)*rate(iro17pg) 4 + y(if18)*rate(irf18gp) c..o18 reactions dydt(io18) = y(if18)*rate(irf18enu) 1 - y(io18)*y(ih1)*rate(iro18pa) 2 + y(in15)*y(ihe4)*rate(irn15ap) 3 - y(io18)*y(ih1)*rate(iro18pg) 4 + y(if19)*rate(irf19gp) c..f17 reactions dydt(if17) = y(io16)*y(ih1)*rate(iro16pg) 1 - y(if17)*rate(irf17gp) 2 - y(if17)*rate(irf17enu) 3 + y(io14) * y(ihe4) * rate(iro14ap) 4 - y(if17) * y(ih1) * rate(irf17pa) 5 - y(if17) * y(ih1) * rate(irf17pg) 6 + y(ine18) * rate(irne18gp) c..f18 reactions dydt(if18) = y(io17)*y(ih1)*rate(iro17pg) 1 - y(if18)*rate(irf18gp) 2 - y(if18)*rate(irf18enu) 3 + y(ine18) * rate(irne18enu) 4 - y(if18) * y(ih1) * rate(irf18pa) 5 + y(io15) * y(ihe4) * rate(iro15ap) c..f19 reactions dydt(if19) = y(io18)*y(ih1)*rate(iro18pg) 1 - y(if19)*rate(irf19gp) 2 - y(if19)*y(ih1)*rate(irf19pa) 3 + y(io16)*y(ihe4)*rate(iro16ap) 4 + y(ine19) * rate(irne19enu) c..ne18 reactions dydt(ine18) = y(if17) * y(ih1) * rate(irf17pg) 1 - y(ine18) * rate(irne18gp) 2 - y(ine18) * rate(irne18enu) 3 - y(ine18) * y(ihe4) * rate(irne18ap) c..ne19 reactions dydt(ine19) = y(io15) * y(ihe4) * rate(iro15ag) 1 - y(ine19) * rate(irne19enu) 2 - y(ine19)*y(ih1)*rate(irne19pg) c..ne20 reactions dydt(ine20) = y(io16) * y(ihe4) * rate(iroag) 1 - y(ine20) * y(ihe4) * rate(irneag) 2 - y(ine20) * rate(irnega) 3 + y(img24) * rate(irmgga) 4 - y(ine20)*y(ih1)*rate(irne20pg) 5 + 0.5d0 * y(ic12) * y(ic12) * rate(ir1212) c..mg22 reactions c..for rp o16(a,g)ne20(p,g)na21(p,g)mg22 c.. f17(p,g)ne18(a,g)mg22 c.. o15(a,g)ne19(p,g)na20(p,g)mg21(e-nu)na21(p,g)mg22 dydt(img22) = -y(img22)*y(ih1)* 1 rate(iralam1)*(1.0d0 - ratdum(irdelta1)) 2 - y(img22)*y(ihe4)*rate(iralam1)*ratdum(irdelta1) 3 + y(ine18) * y(ihe4) * rate(irne18ap) 4 + y(ine19)*y(ih1)*rate(irne19pg) 5 + y(ine20)*y(ih1)*rate(irne20pg) c..mg24 reactions dydt(img24) = y(ine20) * y(ihe4) * rate(irneag) 1 - y(img24) * y(ihe4) * rate(irmgag) 2 - y(img24) * rate(irmgga) 3 + y(isi28) * rate(irsiga) 4 + 0.5d0 * y(ic12) * y(io16) * rate(ir1216) if (.not.deriva) then dydt(img24) = dydt(img24) 1 - y(img24) * y(ihe4) * rate(irmgap)*(1.0d0-rate(irr1)) 2 + y(isi28) * rate(irr1) * rate(irsigp) else dydt(img24) = dydt(img24) 1 - y(img24)*y(ihe4)*(rate(irmgap)*(1.0d0 - ratdum(irr1)) 2 - ratdum(irmgap)*rate(irr1)) 3 + y(isi28) * (ratdum(irr1) * rate(irsigp) + 4 rate(irr1) * ratdum(irsigp)) end if c..si28 reactions dydt(isi28) = y(img24) * y(ihe4) * rate(irmgag) 1 - y(isi28) * y(ihe4) * rate(irsiag) 2 - y(isi28) * rate(irsiga) 3 + y(is32) * rate(irsga) 4 + 0.5d0 * y(ic12) * y(io16) * rate(ir1216) 5 + 0.56d0*0.5d0*y(io16)*y(io16)*rate(ir1616) if (.not.deriva) then dydt(isi28) = dydt(isi28) 1 + 0.34d0*0.5d0*y(io16)*y(io16)*rate(irs1)*rate(ir1616) 2 + y(img24) * y(ihe4) * rate(irmgap)*(1.0d0-rate(irr1)) 3 - y(isi28) * rate(irr1) * rate(irsigp) 4 - y(isi28) * y(ihe4) * rate(irsiap)*(1.0d0-rate(irs1)) 5 + y(is32) * rate(irs1) * rate(irsgp) else dydt(isi28) = dydt(isi28) 1 + 0.34d0*0.5d0*y(io16)*y(io16)* 2 (ratdum(irs1)*rate(ir1616) + rate(irs1)*ratdum(ir1616)) 3 + y(img24)*y(ihe4)*(rate(irmgap)*(1.0d0 - ratdum(irr1)) 4 - ratdum(irmgap)*rate(irr1)) 5 - y(isi28)*(ratdum(irr1) * rate(irsigp) + 6 rate(irr1) * ratdum(irsigp)) 7 - y(isi28)*y(ihe4)*(rate(irsiap)*(1.0d0 - ratdum(irs1)) 8 - ratdum(irsiap)*rate(irs1)) 9 + y(is32)*(ratdum(irs1) * rate(irsgp) + & rate(irs1) * ratdum(irsgp)) end if c..s30 reactions dydt(is30) = y(img22)*y(ih1)* 1 rate(iralam1)*(1.0d0 - ratdum(irdelta1)) 2 + y(img22)*y(ihe4)*rate(iralam1)*ratdum(irdelta1) 3 - y(is30)*y(ih1)* 4 rate(iralam2)*(1.0d0 - ratdum(irdelta2)) 5 - y(is30)*y(ihe4)*rate(iralam2)*ratdum(irdelta2) c..s32 reactions dydt(is32) = y(isi28) * y(ihe4) * rate(irsiag) 1 - y(is32) * y(ihe4) * rate(irsag) 2 - y(is32) * rate(irsga) 3 + y(iar36) * rate(irarga) 4 + 0.1d0 * 0.5d0 *y(io16)*y(io16)*rate(ir1616) if (.not.deriva) then dydt(is32) = dydt(is32) 1 + 0.34d0*0.5d0*y(io16)**2*rate(ir1616)*(1.0d0-rate(irs1)) 2 + y(isi28) * y(ihe4) * rate(irsiap)*(1.0d0-rate(irs1)) 3 - y(is32) * rate(irs1) * rate(irsgp) 4 - y(is32) * y(ihe4) * rate(irsap)*(1.0d0-rate(irt1)) 5 + y(iar36) * rate(irt1) * rate(irargp) else dydt(is32) = dydt(is32) 1 + 0.34d0*0.5d0*y(io16)**2 * 2 (rate(ir1616)*(1.0d0-ratdum(irs1))-ratdum(ir1616)*rate(irs1)) 3 + y(isi28)*y(ihe4)*(rate(irsiap)*(1.0d0-ratdum(irs1)) 4 - ratdum(irsiap)*rate(irs1)) 5 - y(is32)*(ratdum(irs1) * rate(irsgp) + 6 rate(irs1) * ratdum(irsgp)) 7 - y(is32)*y(ihe4)*(rate(irsap)*(1.0d0-ratdum(irt1)) 8 - ratdum(irsap)*rate(irt1)) 9 + y(iar36)*(ratdum(irt1) * rate(irargp) + & rate(irt1) * ratdum(irargp)) end if c..ar36 reactions dydt(iar36) = y(is32) * y(ihe4) * rate(irsag) 1 - y(iar36) * y(ihe4) * rate(irarag) 2 - y(iar36) * rate(irarga) 3 + y(ica40) * rate(ircaga) if (.not.deriva) then dydt(iar36) = dydt(iar36) 1 + y(is32) * y(ihe4) * rate(irsap)*(1.0d0-rate(irt1)) 2 - y(iar36) * rate(irt1) * rate(irargp) 3 - y(iar36) * y(ihe4) * rate(irarap)*(1.0d0-rate(iru1)) 4 + y(ica40) * rate(ircagp) * rate(iru1) else dydt(iar36) = dydt(iar36) 1 + y(is32)*y(ihe4)*(rate(irsap)*(1.0d0 - ratdum(irt1)) 2 - ratdum(irsap)*rate(irt1)) 3 - y(iar36)*(ratdum(irt1) * rate(irargp) + 4 rate(irt1) * ratdum(irargp)) 5 - y(iar36)*y(ihe4)*(rate(irarap)*(1.0d0-ratdum(iru1)) 6 - ratdum(irarap)*rate(iru1)) 7 + y(ica40)*(ratdum(ircagp) * rate(iru1) + 8 rate(ircagp) * ratdum(iru1)) end if c..ca40 reactions dydt(ica40) = y(iar36) * y(ihe4) * rate(irarag) 1 - y(ica40) * y(ihe4) * rate(ircaag) 2 - y(ica40) * rate(ircaga) 3 + y(iti44) * rate(irtiga) if (.not.deriva) then dydt(ica40) = dydt(ica40) 1 + y(iar36) * y(ihe4) * rate(irarap)*(1.0d0-rate(iru1)) 2 - y(ica40) * rate(ircagp) * rate(iru1) 3 - y(ica40) * y(ihe4) * rate(ircaap)*(1.0d0-rate(irv1)) 4 + y(iti44) * rate(irtigp) * rate(irv1) else dydt(ica40) = dydt(ica40) 1 + y(iar36)*y(ihe4)*(rate(irarap)*(1.0d0-ratdum(iru1)) 2 - ratdum(irarap)*rate(iru1)) 3 - y(ica40)*(ratdum(ircagp) * rate(iru1) + 4 rate(ircagp) * ratdum(iru1)) 5 - y(ica40)*y(ihe4)*(rate(ircaap)*(1.0d0-ratdum(irv1)) 6 - ratdum(ircaap)*rate(irv1)) 7 + y(iti44)*(ratdum(irtigp) * rate(irv1) + 8 rate(irtigp) * ratdum(irv1)) end if c..ti44 reactions dydt(iti44) = y(ica40) * y(ihe4) * rate(ircaag) 1 - y(iti44) * y(ihe4) * rate(irtiag) 2 - y(iti44) * rate(irtiga) 3 + y(icr48) * rate(ircrga) if (.not.deriva) then dydt(iti44) = dydt(iti44) 1 + y(ica40) * y(ihe4) * rate(ircaap)*(1.0d0-rate(irv1)) 2 - y(iti44) * rate(irv1) * rate(irtigp) 3 - y(iti44) * y(ihe4) * rate(irtiap)*(1.0d0-rate(irw1)) 4 + y(icr48) * rate(irw1) * rate(ircrgp) else dydt(iti44) = dydt(iti44) 1 + y(ica40)*y(ihe4)*(rate(ircaap)*(1.0d0-ratdum(irv1)) 2 - ratdum(ircaap)*rate(irv1)) 3 - y(iti44)*(ratdum(irv1) * rate(irtigp) + 4 rate(irv1) * ratdum(irtigp)) 5 - y(iti44)*y(ihe4)*(rate(irtiap)*(1.0d0-ratdum(irw1)) 6 - ratdum(irtiap)*rate(irw1)) 7 + y(icr48)*(ratdum(irw1) * rate(ircrgp) + 8 rate(irw1) * ratdum(ircrgp)) end if c..cr48 reactions dydt(icr48) = y(iti44) * y(ihe4) * rate(irtiag) 1 - y(icr48) * y(ihe4) * rate(ircrag) 2 - y(icr48) * rate(ircrga) 3 + y(ife52) * rate(irfega) if (.not.deriva) then dydt(icr48) = dydt(icr48) 1 + y(iti44) * y(ihe4) * rate(irtiap)*(1.0d0-rate(irw1)) 2 - y(icr48) * rate(irw1) * rate(ircrgp) 3 - y(icr48) * y(ihe4) * rate(ircrap)*(1.0d0-rate(irx1)) 4 + y(ife52) * rate(irx1) * rate(irfegp) else dydt(icr48) = dydt(icr48) 1 + y(iti44)*y(ihe4)*(rate(irtiap)*(1.0d0-ratdum(irw1)) 2 - ratdum(irtiap)*rate(irw1)) 3 - y(icr48)*(ratdum(irw1) * rate(ircrgp) + 4 rate(irw1) * ratdum(ircrgp)) 5 - y(icr48)*y(ihe4)*(rate(ircrap)*(1.0d0-ratdum(irx1)) 6 - ratdum(ircrap)*rate(irx1)) 7 + y(ife52)*(ratdum(irx1) * rate(irfegp) + 8 rate(irx1) * ratdum(irfegp)) end if c..fe52 reactions dydt(ife52) = y(icr48) * y(ihe4) * rate(ircrag) 1 - y(ife52) * y(ihe4) * rate(irfeag) 2 - y(ife52) * rate(irfega) 3 + y(ini56) * rate(irniga) if (.not.deriva) then dydt(ife52) = dydt(ife52) 1 + y(icr48) * y(ihe4) * rate(ircrap)*(1.0d0-rate(irx1)) 2 - y(ife52) * rate(irx1) * rate(irfegp) 3 - y(ife52) * y(ihe4) * rate(irfeap)*(1.0d0-rate(iry1)) 4 + y(ini56) * rate(iry1) * rate(irnigp) else dydt(ife52) = dydt(ife52) 1 + y(icr48)*y(ihe4)*(rate(ircrap)*(1.0d0-ratdum(irx1)) 2 - ratdum(ircrap)*rate(irx1)) 3 - y(ife52)*(ratdum(irx1) * rate(irfegp) + 4 rate(irx1) * ratdum(irfegp)) 5 - y(ife52)*y(ihe4)*(rate(irfeap)*(1.0d0-ratdum(iry1)) 6 - ratdum(irfeap)*rate(iry1)) 7 + y(ini56)*(ratdum(iry1) * rate(irnigp) + 8 rate(iry1) * ratdum(irnigp)) end if c..ni56 reactions dydt(ini56) = y(is30)*y(ih1)* 1 rate(iralam2)*(1.0d0 - ratdum(irdelta2)) 2 + y(is30)*y(ihe4)*rate(iralam2)*ratdum(irdelta2) 3 + y(ife52) * y(ihe4) * rate(irfeag) 4 - y(ini56) * rate(irniga) if (.not.deriva) then dydt(ini56) = dydt(ini56) 1 + y(ife52) * y(ihe4) * rate(irfeap)*(1.0d0-rate(iry1)) 2 - y(ini56) * rate(iry1) * rate(irnigp) else dydt(ini56) = dydt(ini56) 1 + y(ife52)*y(ihe4)*(rate(irfeap)*(1.0d0-ratdum(iry1)) 2 - ratdum(irfeap)*rate(iry1)) 3 - y(ini56)*(ratdum(iry1) * rate(irnigp) + 4 rate(iry1) * ratdum(irnigp)) end if return end subroutine dhhe(tt,y,dfdy,nlog,nphys) include 'implno.dek' include 'const.dek' include 'burn_common.dek' include 'network.dek' include 'vector_eos.dek' c..this routine sets up the dense hhe jacobian c..declare the pass integer nlog,nphys double precision tt,y(1),dfdy(nphys,nphys) c..locals logical deriva parameter (deriva = .true.) integer i,j double precision zbarxx,ytot1,abar,zbar,ye,taud,taut, 1 snuda,snudz,sum1,sum2,xx,yy,zz double precision conv,sixth parameter (conv = ev2erg*1.0d6*avo) parameter (sixth = 1.0d0/6.0d0) c..zero the jacobian do j=1,nlog do i=1,nlog dfdy(i,j) = 0.0d0 enddo enddo c..positive definite mass fractions do i=1,ionmax y(i) = min(1.0d0,max(y(i),1.0d-30)) enddo c..generate abar and zbar for this composition zbarxx = 0.0d0 ytot1 = 0.0d0 do i=1,ionmax ytot1 = ytot1 + y(i) zbarxx = zbarxx + zion(i) * y(i) enddo abar = 1.0d0/ytot1 zbar = zbarxx * abar ye = zbar * ytot1 c..positive definite temperatures and densities y(itemp) = min(1.0d11,max(y(itemp),1.0d4)) y(iden) = min(1.0d11,max(y(iden),1.0d-10)) c..for evolution equations with the network if (pure_network .eq. 0) then c..get the new temperature and density if need be if (trho_hist) call update2(tt,y(itemp),y(iden)) if (self_heat_const_pres) then jlo_eos = 1 jhi_eos = 1 ptot_row(1) = bpres temp_row(1) = y(itemp) abar_row(1) = abar zbar_row(1) = zbar den_row(1) = y(iden) call invert_helm_pt_quiet y(iden) = den_row(1) end if c..positive definite temperatures and densities y(itemp) = min(1.0d11,max(y(itemp),1.0d4)) y(iden) = min(1.0d11,max(y(iden),1.0d-10)) c..set the common block temperature and density btemp = y(itemp) bden = y(iden) c..for pure network else if (pure_network .eq. 1) then if (trho_hist) call update2(tt,btemp,bden) end if c..get the reaction rates if (use_tables .eq. 1) then call hhetab(ye) else call hherat(ye) end if c..do the screening here because the corrections depend on the composition call screen_hhe(y) c..from pp123 c..h1 jacobian elements dfdy(ih1,ih1) = -2.0d0*y(ih1)*(ratdum(irpp) + ratdum(irpep)) 1 - y(ih2)*ratdum(irdpg) 2 - y(ili7)*ratdum(irli7pa) 3 - y(ibe7)*ratdum(irbepg) 4 - y(ihe3)*ratdum(irhep) dfdy(ih1,ih2) = -y(ih1)*ratdum(irdpg) dfdy(ih1,ihe3) = 2.0d0*y(ihe3)*ratdum(ir33) 1 - y(ih1)*ratdum(irhep) dfdy(ih1,ili7) = -y(ih1)*ratdum(irli7pa) dfdy(ih1,ibe7) = -y(ih1)*ratdum(irbepg) dfdy(ih1,ib8) = ratdum(irb8gp) c..h2 jacobian elements dfdy(ih2,ih1) = -y(ih2)*ratdum(irdpg) 1 + y(ih1)*(ratdum(irpp) + ratdum(irpep)) dfdy(ih2,ih2) = -y(ih1)*ratdum(irdpg) c..he3 jacobian elements dfdy(ihe3,ih1) = y(ih2)*ratdum(irdpg) 1 - y(ihe3)*ratdum(irhep) dfdy(ihe3,ih2) = y(ih1)*ratdum(irdpg) dfdy(ihe3,ihe3) = -2.0d0*y(ihe3)*ratdum(ir33) 1 - y(ihe4)*ratdum(irhe3ag) 2 - y(ih1)*ratdum(irhep) dfdy(ihe3,ihe4) = - y(ihe3)*ratdum(irhe3ag) c..4he jacobian elements dfdy(ihe4,ih1) = 2.0d0*y(ili7)*ratdum(irli7pa) 1 + y(ihe3)*ratdum(irhep) dfdy(ihe4,ihe3) = y(ihe3)*ratdum(ir33) 1 - y(ihe4)*ratdum(irhe3ag) 2 + y(ih1)*ratdum(irhep) dfdy(ihe4,ihe4) = -y(ihe3)*ratdum(irhe3ag) dfdy(ihe4,ili7) = 2.0d0*y(ih1)*ratdum(irli7pa) dfdy(ihe4,ib8) = 2.0d0*ratdum(irb8ep) c..li7 jacobian elements dfdy(ili7,ih1) = -y(ili7)*ratdum(irli7pa) dfdy(ili7,ili7) = -y(ih1)*ratdum(irli7pa) dfdy(ili7,ibe7) = ratdum(irbeec) c..be7 jacobian elements dfdy(ibe7,ih1) = -y(ibe7)*ratdum(irbepg) dfdy(ibe7,ihe3) = y(ihe4)*ratdum(irhe3ag) dfdy(ibe7,ihe4) = y(ihe3)*ratdum(irhe3ag) dfdy(ibe7,ibe7) = -y(ih1)*ratdum(irbepg) 1 - ratdum(irbeec) dfdy(ibe7,ib8) = ratdum(irb8gp) c..b8 jacobian elements dfdy(ib8,ih1) = y(ibe7)*ratdum(irbepg) dfdy(ib8,ibe7) = y(ih1)*ratdum(irbepg) dfdy(ib8,ib8) = -ratdum(irb8ep) 1 - ratdum(irb8gp) c..add in the hotcno contributions c..h1 jacobian elements dfdy(ih1,ih1) = dfdy(ih1,ih1) 1 - y(ic12)*ratdum(irc12pg) 1 - y(ic13)*ratdum(irc13pg) 2 - y(in14)*ratdum(irn14pg) 3 - y(in15)*ratdum(irn15pa) 4 - y(in15)*ratdum(irn15pg) 5 - y(io16)*ratdum(iro16pg) 6 - y(io17)*ratdum(iro17pa) 7 - y(io17)*ratdum(iro17pg) 8 - y(io18)*ratdum(iro18pa) 9 - y(io18)*ratdum(iro18pg) & - y(if19)*ratdum(irf19pa) 1 - y(in13)*ratdum(irn13pg) 2 - y(if17) * ratdum(irf17pa) 3 - y(if17) * ratdum(irf17pg) 4 - y(if18) * ratdum(irf18pa) dfdy(ih1,ih1) = dfdy(ih1,ih1) 1 - 3.0d0*y(ine19)*ratdum(irne19pg) 2 - 2.0d0*y(ine20)*ratdum(irne20pg) 3 - 8.0d0 * y(img22) * 4 ratdum(iralam1)*(1.0d0 - ratdum(irdelta1)) 5 - 26.0d0 * y(is30) * 6 ratdum(iralam2)*(1.0d0 - ratdum(irdelta2)) dfdy(ih1,ihe4) = dfdy(ih1,ihe4) 1 + y(ic12)*ratdum(irc12ap) 1 + y(in14)*ratdum(irn14ap) 2 + y(in15)*ratdum(irn15ap) 3 + y(io16)*ratdum(iro16ap) 4 + y(io14) * ratdum(iro14ap) 5 + y(io15) * ratdum(iro15ap) dfdy(ih1,ic12) = -y(ih1)*ratdum(irc12pg) 1 + y(ihe4)*ratdum(irc12ap) dfdy(ih1,ic13) = -y(ih1)*ratdum(irc13pg) dfdy(ih1,in13) = ratdum(irn13gp) 1 - y(ih1)*ratdum(irn13pg) dfdy(ih1,in14) = ratdum(irn14gp) 1 - y(ih1)*ratdum(irn14pg) 2 + y(ihe4)*ratdum(irn14ap) dfdy(ih1,in15) = -y(ih1)*ratdum(irn15pa) 1 - y(ih1)*ratdum(irn15pg) 2 + y(ihe4)*ratdum(irn15ap) dfdy(ih1,io14) = y(ihe4) * ratdum(iro14ap) 1 + ratdum(iro14gp) dfdy(ih1,io15) = ratdum(iro15gp) 1 + y(ihe4) * ratdum(iro15ap) dfdy(ih1,io16) = ratdum(iro16gp) 1 - y(ih1)*ratdum(iro16pg) 2 + y(ihe4)*ratdum(iro16ap) dfdy(ih1,io17) = -y(ih1)*ratdum(iro17pa) 1 - y(ih1)*ratdum(iro17pg) dfdy(ih1,io18) = -y(ih1)*ratdum(iro18pa) 1 - y(ih1)*ratdum(iro18pg) dfdy(ih1,if17) = ratdum(irf17gp) 1 - y(ih1) * ratdum(irf17pa) 2 - y(ih1) * ratdum(irf17pg) dfdy(ih1,if18) = ratdum(irf18gp) 1 - y(ih1) * ratdum(irf18pa) dfdy(ih1,if19) = ratdum(irf19gp) 1 - y(ih1)*ratdum(irf19pa) dfdy(ih1,ine18) = ratdum(irne18gp) dfdy(ih1,ine19) = -3.0d0*y(ih1)*ratdum(irne19pg) dfdy(ih1,ine20) = -2.0d0*y(ih1)*ratdum(irne20pg) dfdy(ih1,img22) = -8.0d0 * y(ih1) * 1 ratdum(iralam1)*(1.0d0 - ratdum(irdelta1)) dfdy(ih1,is30) = -26.0d0 * y(ih1) * 1 ratdum(iralam2)*(1.0d0 - ratdum(irdelta2)) c..he4 jacobian elements dfdy(ihe4,ih1) = dfdy(ihe4,ih1) 1 + y(in15)*ratdum(irn15pa) 1 + y(io17)*ratdum(iro17pa) 2 + y(io18)*ratdum(iro18pa) 3 + y(if19)*ratdum(irf19pa) 4 + y(if17) * ratdum(irf17pa) 5 + y(if18) * ratdum(irf18pa) dfdy(ihe4,ihe4) = dfdy(ihe4,ihe4) 1 - y(ic12)*ratdum(irc12ap) 1 - y(in14)*ratdum(irn14ap) 2 - y(in15)*ratdum(irn15ap) 3 - y(io16)*ratdum(iro16ap) 4 - y(io14) * ratdum(iro14ap) 5 - y(io15) * ratdum(iro15ap) 6 - 1.5d0 * y(ihe4) * y(ihe4) * ratdum(ir3a) 8 - 2.0d0*y(img22)*ratdum(iralam1)*ratdum(irdelta1) 9 - 6.5d0*y(is30)*ratdum(iralam2)*ratdum(irdelta2) 1 - y(ine18) * ratdum(irne18ap) 2 - y(io15) * ratdum(iro15ag) dfdy(ihe4,ihe4) = dfdy(ihe4,ihe4) 1 - y(ic12) * ratdum(ircag) 2 - y(io16) * ratdum(iroag) 3 - y(ine20) * ratdum(irneag) 4 - y(img24) * ratdum(irmgag) 5 - y(isi28) * ratdum(irsiag) 6 - y(is32) * ratdum(irsag) 7 - y(iar36) * ratdum(irarag) 8 - y(ica40) * ratdum(ircaag) 9 - y(iti44) * ratdum(irtiag) & - y(icr48) * ratdum(ircrag) 1 - y(ife52) * ratdum(irfeag) dfdy(ihe4,ihe4) = dfdy(ihe4,ihe4) 1 - y(img24) * ratdum(irmgap) * (1.0d0-ratdum(irr1)) 2 - y(isi28) * ratdum(irsiap) * (1.0d0-ratdum(irs1)) 3 - y(is32) * ratdum(irsap) * (1.0d0-ratdum(irt1)) 4 - y(iar36) * ratdum(irarap) * (1.0d0-ratdum(iru1)) 5 - y(ica40) * ratdum(ircaap) * (1.0d0-ratdum(irv1)) 6 - y(iti44) * ratdum(irtiap) * (1.0d0-ratdum(irw1)) 7 - y(icr48) * ratdum(ircrap) * (1.0d0-ratdum(irx1)) 8 - y(ife52) * ratdum(irfeap) * (1.0d0-ratdum(iry1)) dfdy(ihe4,ic12) = -y(ihe4)*ratdum(irc12ap) 1 + 3.0d0 * ratdum(irg3a) 2 - y(ihe4) * ratdum(ircag) 3 + y(ic12) * ratdum(ir1212) 4 + 0.5d0 * y(io16) * ratdum(ir1216) dfdy(ihe4,in14) = -y(ihe4)*ratdum(irn14ap) dfdy(ihe4,in15) = y(ih1)*ratdum(irn15pa) dfdy(ihe4,io14) = -y(ihe4) * ratdum(iro14ap) dfdy(ihe4,io15) = -y(ihe4) * ratdum(iro15ap) 1 - y(ihe4) * ratdum(iro15ag) dfdy(ihe4,io16) = -y(ihe4)*ratdum(iro16ap) 1 - y(ihe4) * ratdum(iroag) 2 + ratdum(iroga) 3 + 0.5d0 * y(ic12) * ratdum(ir1216) 4 + 1.12d0 * 0.5d0 * y(io16) * ratdum(ir1616) 5 + 0.68d0*ratdum(irs1)*0.5d0*y(io16)*ratdum(ir1616) dfdy(ihe4,io17) = y(ih1)*ratdum(iro17pa) dfdy(ihe4,io18) = y(ih1)*ratdum(iro18pa) dfdy(ihe4,if17) = y(ih1) * ratdum(irf17pa) dfdy(ihe4,if18) = y(ih1) * ratdum(irf18pa) dfdy(ihe4,if19) = y(ih1)*ratdum(irf19pa) dfdy(ihe4,ine18) = -y(ihe4) * ratdum(irne18ap) dfdy(ihe4,ine20) = ratdum(irnega) 1 - y(ihe4) * ratdum(irneag) dfdy(ihe4,img22) = -2.0d0*y(ihe4)*ratdum(iralam1)*ratdum(irdelta1) dfdy(ihe4,img24) = ratdum(irmgga) 1 - y(ihe4) * ratdum(irmgag) 2 - y(ihe4) * ratdum(irmgap)*(1.0d0-ratdum(irr1)) dfdy(ihe4,isi28) = ratdum(irsiga) 1 - y(ihe4) * ratdum(irsiag) 2 - y(ihe4) * ratdum(irsiap)*(1.0d0-ratdum(irs1)) 3 + ratdum(irr1) * ratdum(irsigp) dfdy(ihe4,is30) = -6.5d0*y(ihe4)*ratdum(iralam2)*ratdum(irdelta2) dfdy(ihe4,is32) = ratdum(irsga) 1 - y(ihe4) * ratdum(irsag) 2 - y(ihe4) * ratdum(irsap)*(1.0d0-ratdum(irt1)) 3 + ratdum(irs1) * ratdum(irsgp) dfdy(ihe4,iar36) = ratdum(irarga) 1 - y(ihe4) * ratdum(irarag) 2 - y(ihe4) * ratdum(irarap)*(1.0d0-ratdum(iru1)) 3 + ratdum(irt1) * ratdum(irargp) dfdy(ihe4,ica40) = ratdum(ircaga) 1 - y(ihe4) * ratdum(ircaag) 2 - y(ihe4) * ratdum(ircaap)*(1.0d0-ratdum(irv1)) 3 + ratdum(iru1) * ratdum(ircagp) dfdy(ihe4,iti44) = ratdum(irtiga) 1 - y(ihe4) * ratdum(irtiag) 2 - y(ihe4) * ratdum(irtiap)*(1.0d0-ratdum(irw1)) 3 + ratdum(irv1) * ratdum(irtigp) dfdy(ihe4,icr48) = ratdum(ircrga) 1 - y(ihe4) * ratdum(ircrag) 2 - y(ihe4) * ratdum(ircrap)*(1.0d0-ratdum(irx1)) 3 + ratdum(irw1) * ratdum(ircrgp) dfdy(ihe4,ife52) = ratdum(irfega) 1 - y(ihe4) * ratdum(irfeag) 2 - y(ihe4) * ratdum(irfeap)*(1.0d0-ratdum(iry1)) 3 + ratdum(irx1) * ratdum(irfegp) dfdy(ihe4,ini56) = ratdum(irniga) 1 + ratdum(iry1) * ratdum(irnigp) c..c12 jacobian elements dfdy(ic12,ih1) = -y(ic12)*ratdum(irc12pg) 1 + y(in15)*ratdum(irn15pa) dfdy(ic12,ihe4) = -y(ic12)*ratdum(irc12ap) 1 + 0.5d0 * y(ihe4) * y(ihe4) * ratdum(ir3a) 2 - y(ic12) * ratdum(ircag) dfdy(ic12,ic12) = -y(ih1)*ratdum(irc12pg) 1 - y(ihe4)*ratdum(irc12ap) 2 - ratdum(irg3a) 3 - y(ihe4) * ratdum(ircag) 4 - 2.0d0 * y(ic12) * ratdum(ir1212) 5 - y(io16) * ratdum(ir1216) dfdy(ic12,in13) = ratdum(irn13gp) dfdy(ic12,in15) = y(ih1)*ratdum(irn15pa) dfdy(ic12,io16) = ratdum(iroga) 1 - y(ic12) * ratdum(ir1216) c..c13 jacobian elements dfdy(ic13,ih1) = -y(ic13)*ratdum(irc13pg) dfdy(ic13,ic13) = -y(ih1)*ratdum(irc13pg) dfdy(ic13,in13) = ratdum(irn13enu) dfdy(ic13,in14) = ratdum(irn14gp) c..n13 jacobian elements dfdy(in13,ih1) = y(ic12)*ratdum(irc12pg) 1 - y(in13)*ratdum(irn13pg) dfdy(in13,ic12) = y(ih1)*ratdum(irc12pg) dfdy(in13,in13) = -ratdum(irn13gp) 1 - ratdum(irn13enu) 2 - y(ih1)*ratdum(irn13pg) dfdy(in13,io14) = ratdum(iro14gp) c..n14 jacobian elements dfdy(in14,ih1) = y(ic13)*ratdum(irc13pg) 1 - y(in14)*ratdum(irn14pg) 2 + y(io17)*ratdum(iro17pa) dfdy(in14,ihe4) = -y(in14)*ratdum(irn14ap) dfdy(in14,ic13) = y(ih1)*ratdum(irc13pg) dfdy(in14,in14) = -ratdum(irn14gp) 1 - y(ih1)*ratdum(irn14pg) 2 - y(ihe4)*ratdum(irn14ap) dfdy(in14,io14) = ratdum(iro14enu) dfdy(in14,io15) = ratdum(iro15gp) dfdy(in14,io17) = y(ih1)*ratdum(iro17pa) c..n15 jacobian elements dfdy(in15,ih1) = -y(in15)*ratdum(irn15pa) 1 - y(in15)*ratdum(irn15pg) 2 + y(io18)*ratdum(iro18pa) dfdy(in15,ihe4) = y(ic12)*ratdum(irc12ap) 1 - y(in15)*ratdum(irn15ap) dfdy(in15,ic12) = y(ihe4)*ratdum(irc12ap) dfdy(in15,in15) = -y(ih1)*ratdum(irn15pa) 1 - y(ih1)*ratdum(irn15pg) 2 - y(ihe4)*ratdum(irn15ap) dfdy(in15,io15) = ratdum(iro15enu) dfdy(in15,io16) = ratdum(iro16gp) dfdy(in15,io18) = y(ih1)*ratdum(iro18pa) c..o14 jacobian elements dfdy(io14,ih1) = y(in13)*ratdum(irn13pg) 1 + y(if17) * ratdum(irf17pa) dfdy(io14,ihe4) = -y(io14) * ratdum(iro14ap) dfdy(io14,in13) = y(ih1)*ratdum(irn13pg) dfdy(io14,io14) = -ratdum(iro14gp) 1 - ratdum(iro14enu) 2 - y(ihe4) * ratdum(iro14ap) dfdy(io14,if17) = y(ih1) * ratdum(irf17pa) c..o15 jacobian elements dfdy(io15,ih1) = y(in14)*ratdum(irn14pg) 1 + y(if18) * ratdum(irf18pa) dfdy(io15,ihe4) = -y(io15) * ratdum(iro15ap) & - y(io15) * ratdum(iro15ag) dfdy(io15,in14) = y(ih1)*ratdum(irn14pg) dfdy(io15,io15) = -ratdum(iro15gp) 1 - ratdum(iro15enu) 2 - y(ihe4) * ratdum(iro15ap) 3 - y(ihe4) * ratdum(iro15ag) dfdy(io15,if18) = y(ih1) * ratdum(irf18pa) c..o16 jacobian elements dfdy(io16,ih1) = y(in15)*ratdum(irn15pg) 1 - y(io16)*ratdum(iro16pg) 2 + y(if19)*ratdum(irf19pa) dfdy(io16,ihe4) = -y(io16)*ratdum(iro16ap) 1 - y(io16) * ratdum(iroag) 2 + y(ic12) * ratdum(ircag) dfdy(io16,ic12) = y(ihe4) * ratdum(ircag) 1 - y(io16)*ratdum(ir1216) dfdy(io16,in15) = y(ih1)*ratdum(irn15pg) dfdy(io16,io16) = -ratdum(iro16gp) 1 - y(ih1)*ratdum(iro16pg) 2 - y(ihe4)*ratdum(iro16ap) 3 - y(ihe4) * ratdum(iroag) 4 - ratdum(iroga) 5 - y(ic12) * ratdum(ir1216) 6 - 2.0d0 * y(io16) * ratdum(ir1616) dfdy(io16,if17) = ratdum(irf17gp) dfdy(io16,if19) = y(ih1)*ratdum(irf19pa) dfdy(io16,ine20) = ratdum(irnega) c..o17 jacobian elements dfdy(io17,ih1) = -y(io17)*ratdum(iro17pa) 1 - y(io17)*ratdum(iro17pg) dfdy(io17,ihe4) = y(in14)*ratdum(irn14ap) dfdy(io17,in14) = y(ihe4)*ratdum(irn14ap) dfdy(io17,io17) = -y(ih1)*ratdum(iro17pa) 1 - y(ih1)*ratdum(iro17pg) dfdy(io17,if17) = ratdum(irf17enu) dfdy(io17,if18) = ratdum(irf18gp) c..o18 jacobian elements dfdy(io18,ih1) = -y(io18)*ratdum(iro18pa) 1 - y(io18)*ratdum(iro18pg) dfdy(io18,ihe4) = y(in15)*ratdum(irn15ap) dfdy(io18,in15) = y(ihe4)*ratdum(irn15ap) dfdy(io18,io18) = -y(ih1)*ratdum(iro18pa) 1 - y(ih1)*ratdum(iro18pg) dfdy(io18,if18) = ratdum(irf18enu) dfdy(io18,if19) = ratdum(irf19gp) c..f17 jacobian elements dfdy(if17,ih1) = y(io16)*ratdum(iro16pg) 1 - y(if17) * ratdum(irf17pa) 2 - y(if17) * ratdum(irf17pg) dfdy(if17,ihe4) = y(io14) * ratdum(iro14ap) dfdy(if17,io14) = y(ihe4) * ratdum(iro14ap) dfdy(if17,io16) = y(ih1)*ratdum(iro16pg) dfdy(if17,if17) = -ratdum(irf17gp) 1 - ratdum(irf17enu) 2 - y(ih1) * ratdum(irf17pa) 3 - y(ih1) * ratdum(irf17pg) dfdy(if17,ine18) = ratdum(irne18gp) c..f18 jacobian elements dfdy(if18,ih1) = y(io17)*ratdum(iro17pg) 1 - y(if18) * ratdum(irf18pa) dfdy(if18,ihe4) = y(io15) * ratdum(iro15ap) dfdy(if18,io15) = y(ihe4) * ratdum(iro15ap) dfdy(if18,io17) = y(ih1)*ratdum(iro17pg) dfdy(if18,if18) = -ratdum(irf18gp) 1 - ratdum(irf18enu) 2 - y(ih1) * ratdum(irf18pa) dfdy(if18,ine18) = ratdum(irne18enu) c..f19 jacobian elements dfdy(if19,ih1) = y(io18)*ratdum(iro18pg) 1 - y(if19)*ratdum(irf19pa) dfdy(if19,ihe4) = y(io16)*ratdum(iro16ap) dfdy(if19,io16) = y(ihe4)*ratdum(iro16ap) dfdy(if19,io18) = y(ih1)*ratdum(iro18pg) dfdy(if19,if19) = -ratdum(irf19gp) 1 - y(ih1)*ratdum(irf19pa) dfdy(if19,ine19) = ratdum(irne19enu) c..ne18 jacobian elements dfdy(ine18,ih1) = y(if17) * ratdum(irf17pg) dfdy(ine18,ihe4) = -y(ine18) * ratdum(irne18ap) dfdy(ine18,if17) = y(ih1) * ratdum(irf17pg) dfdy(ine18,ine18) = -ratdum(irne18gp) 1 -ratdum(irne18enu) 2 - y(ihe4) * ratdum(irne18ap) c..ne19 jacobian elements dfdy(ine19,ih1) = -y(ine19)*ratdum(irne19pg) dfdy(ine19,ihe4) = y(io15) * ratdum(iro15ag) dfdy(ine19,io15) = y(ihe4) * ratdum(iro15ag) dfdy(ine19,ine19) = -ratdum(irne19enu) 1 - y(ih1)*ratdum(irne19pg) c..ne20 jacobian elements dfdy(ine20,ih1) = -y(ine20)*ratdum(irne20pg) dfdy(ine20,ihe4) = y(io16) * ratdum(iroag) 1 - y(ine20) * ratdum(irneag) dfdy(ine20,ic12) = y(ic12) * ratdum(ir1212) dfdy(ine20,io16) = y(ihe4) * ratdum(iroag) dfdy(ine20,ine20) = -y(ih1)*ratdum(irne20pg) 1 - y(ihe4) * ratdum(irneag) 2 - ratdum(irnega) dfdy(ine20,img24) = ratdum(irmgga) c..mg22 jacobian elements dfdy(img22,ih1) = y(ine19)*ratdum(irne19pg) 1 + y(ine20)*ratdum(irne20pg) 2 - y(img22)*ratdum(iralam1)* 3 (1.0d0 - ratdum(irdelta1)) dfdy(img22,ihe4) = -y(img22)*ratdum(iralam1)*ratdum(irdelta1) 1 + y(ine18) * ratdum(irne18ap) dfdy(img22,ine18) = y(ihe4) * ratdum(irne18ap) dfdy(img22,ine19) = y(ih1)*ratdum(irne19pg) dfdy(img22,ine20) = y(ih1)*ratdum(irne20pg) dfdy(img22,img22) = -y(ih1)*ratdum(iralam1)* 1 (1.0d0 - ratdum(irdelta1)) 2 - y(ihe4)*ratdum(iralam1)*ratdum(irdelta1) c..mg24 jacobian elements dfdy(img24,ihe4) = y(ine20) * ratdum(irneag) 1 -y(img24) * ratdum(irmgag) 2 -y(img24) * ratdum(irmgap)*(1.0d0-ratdum(irr1)) dfdy(img24,ic12) = 0.5d0 * y(io16) * ratdum(ir1216) dfdy(img24,io16) = 0.5d0 * y(ic12) * ratdum(ir1216) dfdy(img24,ine20) = y(ihe4) * ratdum(irneag) dfdy(img24,img24) = -y(ihe4) * ratdum(irmgag) 1 - ratdum(irmgga) 2 - y(ihe4) * ratdum(irmgap)*(1.0d0-ratdum(irr1)) dfdy(img24,isi28) = ratdum(irsiga) 1 + ratdum(irr1) * ratdum(irsigp) c..si28 jacobian elements dfdy(isi28,ihe4) = y(img24) * ratdum(irmgag) 1 - y(isi28) * ratdum(irsiag) 2 + y(img24) * ratdum(irmgap)*(1.0d0-ratdum(irr1)) 3 - y(isi28) * ratdum(irsiap)*(1.0d0-ratdum(irs1)) dfdy(isi28,ic12) = 0.5d0 * y(io16) * ratdum(ir1216) dfdy(isi28,io16) = 0.5d0 * y(ic12) * ratdum(ir1216) 1 + 1.12d0 * 0.5d0*y(io16) * ratdum(ir1616) 2 + 0.68d0*0.5d0*y(io16)*ratdum(irs1)*ratdum(ir1616) dfdy(isi28,img24) = y(ihe4) * ratdum(irmgag) 1 + y(ihe4) * ratdum(irmgap)*(1.0d0-ratdum(irr1)) dfdy(isi28,isi28) = -y(ihe4) * ratdum(irsiag) 1 - ratdum(irsiga) 2 - ratdum(irr1) * ratdum(irsigp) 3 - y(ihe4) * ratdum(irsiap)*(1.0d0-ratdum(irs1)) dfdy(isi28,is32) = ratdum(irsga) 1 + ratdum(irs1) * ratdum(irsgp) c..s30 jacobian elements dfdy(is30,ih1) = y(img22)*ratdum(iralam1)* 1 (1.0d0 - ratdum(irdelta1)) 2 - y(is30)*ratdum(iralam2)* 3 (1.0d0 - ratdum(irdelta2)) dfdy(is30,ihe4) = y(img22)*ratdum(iralam1)*ratdum(irdelta1) 1 - y(is30)*ratdum(iralam2)*ratdum(irdelta2) dfdy(is30,img22) = y(ih1)*ratdum(iralam1)* 1 (1.0d0 - ratdum(irdelta1)) 2 + y(ihe4)*ratdum(iralam1)*ratdum(irdelta1) dfdy(is30,is30) = -y(ih1)*ratdum(iralam2)* 1 (1.0d0 - ratdum(irdelta2)) 2 - y(ihe4)*ratdum(iralam2)*ratdum(irdelta2) c..s32 jacobian elements dfdy(is32,ihe4) = y(isi28) * ratdum(irsiag) 1 - y(is32) * ratdum(irsag) 2 + y(isi28) * ratdum(irsiap)*(1.0d0-ratdum(irs1)) 3 - y(is32) * ratdum(irsap) * (1.0d0-ratdum(irt1)) dfdy(is32,io16) = 0.68d0*0.5d0*y(io16) 1 *ratdum(ir1616)*(1.0d0-ratdum(irs1)) 2 + 0.2d0 * 0.5d0*y(io16) * ratdum(ir1616) dfdy(is32,isi28) = y(ihe4) * ratdum(irsiag) 1 + y(ihe4) * ratdum(irsiap)*(1.0d0-ratdum(irs1)) dfdy(is32,is32) = -y(ihe4) * ratdum(irsag) 1 - ratdum(irsga) 2 - ratdum(irs1) * ratdum(irsgp) 3 - y(ihe4) * ratdum(irsap)*(1.0d0-ratdum(irt1)) dfdy(is32,iar36) = ratdum(irarga) 1 + ratdum(irt1) * ratdum(irargp) c..ar36 jacobian elements dfdy(iar36,ihe4) = y(is32) * ratdum(irsag) 1 - y(iar36) * ratdum(irarag) 2 + y(is32) * ratdum(irsap)*(1.0d0-ratdum(irt1)) 3 - y(iar36) * ratdum(irarap)*(1.0d0-ratdum(iru1)) dfdy(iar36,is32) = y(ihe4) * ratdum(irsag) 1 + y(ihe4) * ratdum(irsap)*(1.0d0-ratdum(irt1)) dfdy(iar36,iar36) = -y(ihe4) * ratdum(irarag) 1 - ratdum(irarga) 2 - ratdum(irt1) * ratdum(irargp) 3 - y(ihe4) * ratdum(irarap)*(1.0d0-ratdum(iru1)) dfdy(iar36,ica40) = ratdum(ircaga) 1 + ratdum(ircagp) * ratdum(iru1) c..ca40 jacobian elements dfdy(ica40,ihe4) = y(iar36) * ratdum(irarag) 1 - y(ica40) * ratdum(ircaag) 2 + y(iar36) *ratdum(irarap)*(1.0d0-ratdum(iru1)) 3 - y(ica40) *ratdum(ircaap)*(1.0d0-ratdum(irv1)) dfdy(ica40,iar36) = y(ihe4) * ratdum(irarag) 1 + y(ihe4) * ratdum(irarap)*(1.0d0-ratdum(iru1)) dfdy(ica40,ica40) = -y(ihe4) * ratdum(ircaag) 1 - ratdum(ircaga) 2 - ratdum(ircagp) * ratdum(iru1) 3 - y(ihe4) *ratdum(ircaap)*(1.0d0-ratdum(irv1)) dfdy(ica40,iti44) = ratdum(irtiga) 1 + ratdum(irtigp) * ratdum(irv1) c..ti44 jacobian elements dfdy(iti44,ihe4) = y(ica40) * ratdum(ircaag) 1 - y(iti44) * ratdum(irtiag) 2 + y(ica40) *ratdum(ircaap)*(1.0d0-ratdum(irv1)) 3 - y(iti44) *ratdum(irtiap)*(1.0d0-ratdum(irw1)) dfdy(iti44,ica40) = y(ihe4) * ratdum(ircaag) 1 + y(ihe4) * ratdum(ircaap)*(1.0d0-ratdum(irv1)) dfdy(iti44,iti44) = -y(ihe4) * ratdum(irtiag) 1 - ratdum(irtiga) 2 - ratdum(irv1) * ratdum(irtigp) 3 - y(ihe4) *ratdum(irtiap)*(1.0d0-ratdum(irw1)) dfdy(iti44,icr48) = ratdum(ircrga) 1 + ratdum(irw1) * ratdum(ircrgp) c..cr48 jacobian elements dfdy(icr48,ihe4) = y(iti44) * ratdum(irtiag) 1 - y(icr48) * ratdum(ircrag) 2 + y(iti44) * ratdum(irtiap)*(1.0d0-ratdum(irw1)) 3 - y(icr48) * ratdum(ircrap)*(1.0d0-ratdum(irx1)) dfdy(icr48,iti44) = y(ihe4) * ratdum(irtiag) 1 + y(ihe4) * ratdum(irtiap)*(1.0d0-ratdum(irw1)) dfdy(icr48,icr48) = -y(ihe4) * ratdum(ircrag) 1 - ratdum(ircrga) 2 - ratdum(irw1) * ratdum(ircrgp) 3 - y(ihe4) * ratdum(ircrap)*(1.0d0-ratdum(irx1)) dfdy(icr48,ife52) = ratdum(irfega) 1 + ratdum(irx1) * ratdum(irfegp) c..fe52 jacobian elements dfdy(ife52,ihe4) = y(icr48) * ratdum(ircrag) 1 - y(ife52) * ratdum(irfeag) 2 + y(icr48) * ratdum(ircrap)*(1.0d0-ratdum(irx1)) 3 - y(ife52) * ratdum(irfeap)*(1.0d0-ratdum(iry1)) dfdy(ife52,icr48) = y(ihe4) * ratdum(ircrag) 1 + y(ihe4) * ratdum(ircrap)*(1.0d0-ratdum(irx1)) dfdy(ife52,ife52) = - y(ihe4) * ratdum(irfeag) 1 - ratdum(irfega) 2 - ratdum(irx1) * ratdum(irfegp) 3 - y(ihe4) *ratdum(irfeap)*(1.0d0-ratdum(iry1)) dfdy(ife52,ini56) = ratdum(irniga) 1 + ratdum(iry1) * ratdum(irnigp) c..ni56 jacobian elements dfdy(ini56,ih1) = y(is30)*ratdum(iralam2)* 1 (1.0d0 - ratdum(irdelta2)) dfdy(ini56,ihe4) = y(is30)*ratdum(iralam2)*ratdum(irdelta2) 5 + y(ife52) * ratdum(irfeag) 6 + y(ife52) * ratdum(irfeap)*(1.0d0-ratdum(iry1)) dfdy(ini56,is30) = y(ih1)*ratdum(iralam2)* 1 (1.0d0 - ratdum(irdelta2)) 2 + y(ihe4)*ratdum(iralam2)*ratdum(irdelta2) dfdy(ini56,ife52) = y(ihe4) * ratdum(irfeag) 1 + y(ihe4) * ratdum(irfeap)*(1.0d0-ratdum(iry1)) dfdy(ini56,ini56) = -ratdum(irniga) 1 - ratdum(iry1) * ratdum(irnigp) c..if we are doing a pure network, we are done if (pure_network .eq. 1) return c..append the temperature derivatives of the rate equations call rhs(y,dratdumdt,zwork1,deriva) do i=1,ionmax dfdy(i,itemp) = zwork1(i) enddo c..append the density derivatives of the rate equations call rhs(y,dratdumdd,zwork1,deriva) do i=1,ionmax dfdy(i,iden) = zwork1(i) enddo c..append the energy generation rate jacobian elements do j=1,ionmax do i=1,ionmax dfdy(iener,j) = dfdy(iener,j) + dfdy(i,j)*bion(i) enddo dfdy(iener,j) = dfdy(iener,j) * conv dfdy(iener,itemp) = dfdy(iener,itemp) + dfdy(j,itemp)*bion(j) dfdy(iener,iden) = dfdy(iener,iden) + dfdy(j,iden)*bion(j) enddo dfdy(iener,itemp) = dfdy(iener,itemp) * conv dfdy(iener,iden) = dfdy(iener,iden) * conv dsdotdt = dfdy(iener,itemp) dsdotdd = dfdy(iener,iden) c..account for the neutrino losses call sneut5(btemp,bden,abar,zbar, 1 sneut,dsneutdt,dsneutdd,snuda,snudz) do j=1,ionmax dfdy(iener,j) = dfdy(iener,j) 1 - (-abar*abar*snuda + (zion(j) - zbar)*abar*snudz) enddo dfdy(iener,itemp) = dfdy(iener,itemp) - dsneutdt dfdy(iener,iden) = dfdy(iener,iden) - dsneutdd c..for hydrostatic or one step or trho_hist burns c..all the temperature and density jacobian elements are zero, c..so there is nothing to do. c..adiabatic expansion if (expansion) then taud = 446.0d0/sqrt(den0) taut = 3.0d0 * taud dfdy(itemp,itemp) = -psi/taut dfdy(iden,iden) = -psi/taud c..for self-heating, we need the specific heat at constant volume else if (self_heat_const_den) then c..call an eos temp_row(1) = btemp den_row(1) = bden abar_row(1) = abar zbar_row(1) = zbar jlo_eos = 1 jhi_eos = 1 call helmeos c..d(itemp)/d(yi) zz = 1.0d0/cv_row(1) do j=1,ionmax dfdy(itemp,j) = zz*dfdy(iener,j) enddo c..d(itemp)/d(temp) dfdy(itemp,itemp) = zz*dfdy(iener,itemp) c..d(itemp)/d(den) dfdy(itemp,iden) = zz*dfdy(iener,iden) end if return end subroutine bhhe(iloc,jloc,nzo,np) include 'implno.dek' include 'network.dek' c.. c..this routine builds the nonzero matrix locations for shhe c..input is the integer arrys iloc and jloc, both of dimension np, that c..on output contain nzo matrix element locations. c.. c..declare the pass integer np,iloc(np),jloc(np),nzo c..local variables integer i c..communicate with shhe integer neloc parameter (neloc=376) integer eloc(neloc),nterms common /elchhe/ eloc,nterms c..initialize nterms = 0 nzo = 0 do i=1,neloc eloc(i) = 0 enddo call tree_init(neqs) c..tag the nonzero locations c..from pp123 c..h1 jacobian elements call tree(ih1,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih1,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih1,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih1,ili7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih1,ibe7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih1,ib8,eloc,neloc,nterms,nzo,iloc,jloc,np) c..h2 jacobian elements call tree(ih2,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih2,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) c..he3 jacobian elements call tree(ihe3,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe3,ih2,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe3,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe3,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) c..4he jacobian elements call tree(ihe4,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,ili7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,ib8,eloc,neloc,nterms,nzo,iloc,jloc,np) c..li7 jacobian elements call tree(ili7,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ili7,ili7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ili7,ibe7,eloc,neloc,nterms,nzo,iloc,jloc,np) c..be7 jacobian elements call tree(ibe7,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ibe7,ihe3,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ibe7,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ibe7,ibe7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ibe7,ib8,eloc,neloc,nterms,nzo,iloc,jloc,np) c..b8 jacobian elements call tree(ib8,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ib8,ibe7,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ib8,ib8,eloc,neloc,nterms,nzo,iloc,jloc,np) c..and the hotcno contributions c..h1 jacobian elements call tree(ih1,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih1,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih1,ic12,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih1,ic13,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih1,in13,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih1,in14,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih1,in15,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih1,io14,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih1,io15,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih1,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih1,io17,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih1,io18,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih1,if17,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih1,if18,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih1,if19,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih1,ine18,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih1,ine19,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih1,ine20,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih1,img22,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ih1,is30,eloc,neloc,nterms,nzo,iloc,jloc,np) c..he4 jacobian elements call tree(ihe4,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,ic12,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,in14,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,in15,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,io14,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,io15,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,io17,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,io18,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,if17,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,if18,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,if19,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,ine18,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,ine20,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,img22,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,img24,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,isi28,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,is30,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,is32,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,iar36,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,ica40,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,iti44,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,icr48,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,ife52,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ihe4,ini56,eloc,neloc,nterms,nzo,iloc,jloc,np) c..c12 jacobian elements call tree(ic12,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ic12,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ic12,ic12,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ic12,in13,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ic12,in15,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ic12,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) c..c13 jacobian elements call tree(ic13,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ic13,ic13,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ic13,in13,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ic13,in14,eloc,neloc,nterms,nzo,iloc,jloc,np) c..n13 jacobian elements call tree(in13,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in13,ic12,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in13,in13,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in13,io14,eloc,neloc,nterms,nzo,iloc,jloc,np) c..n14 jacobian elements call tree(in14,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in14,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in14,ic13,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in14,in14,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in14,io14,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in14,io15,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in14,io17,eloc,neloc,nterms,nzo,iloc,jloc,np) c..n15 jacobian elements call tree(in15,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in15,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in15,ic12,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in15,in15,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in15,io15,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in15,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(in15,io18,eloc,neloc,nterms,nzo,iloc,jloc,np) c..o14 jacobian elements call tree(io14,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io14,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io14,in13,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io14,io14,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io14,if17,eloc,neloc,nterms,nzo,iloc,jloc,np) c..o15 jacobian elements call tree(io15,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io15,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io15,in14,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io15,io15,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io15,if18,eloc,neloc,nterms,nzo,iloc,jloc,np) c..o16 jacobian elements call tree(io16,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io16,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io16,ic12,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io16,in15,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io16,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io16,if17,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io16,if19,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io16,ine20,eloc,neloc,nterms,nzo,iloc,jloc,np) c..o17 jacobian elements call tree(io17,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io17,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io17,in14,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io17,io17,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io17,if17,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io17,if18,eloc,neloc,nterms,nzo,iloc,jloc,np) c..o18 jacobian elements call tree(io18,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io18,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io18,in15,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io18,io18,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io18,if18,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(io18,if19,eloc,neloc,nterms,nzo,iloc,jloc,np) c..f17 jacobian elements call tree(if17,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(if17,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(if17,io14,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(if17,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(if17,if17,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(if17,ine18,eloc,neloc,nterms,nzo,iloc,jloc,np) c..f18 jacobian elements call tree(if18,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(if18,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(if18,io15,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(if18,io17,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(if18,if18,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(if18,ine18,eloc,neloc,nterms,nzo,iloc,jloc,np) c..f19 jacobian elements call tree(if19,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(if19,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(if19,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(if19,io18,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(if19,if19,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(if19,ine19,eloc,neloc,nterms,nzo,iloc,jloc,np) c..ne18 jacobian elements call tree(ine18,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ine18,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ine18,if17,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ine18,ine18,eloc,neloc,nterms,nzo,iloc,jloc,np) c..ne19 jacobian elements call tree(ine19,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ine19,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ine19,io15,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ine19,ine19,eloc,neloc,nterms,nzo,iloc,jloc,np) c..ne20 jacobian elements call tree(ine20,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ine20,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ine20,ic12,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ine20,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ine20,ine20,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ine20,img24,eloc,neloc,nterms,nzo,iloc,jloc,np) c..mg22 jacobian elements call tree(img22,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(img22,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(img22,ine18,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(img22,ine19,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(img22,ine20,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(img22,img22,eloc,neloc,nterms,nzo,iloc,jloc,np) c..mg24 jacobian elements call tree(img24,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(img24,ic12,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(img24,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(img24,ine20,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(img24,img24,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(img24,isi28,eloc,neloc,nterms,nzo,iloc,jloc,np) c..si28 jacobian elements call tree(isi28,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(isi28,ic12,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(isi28,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(isi28,img24,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(isi28,isi28,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(isi28,is32,eloc,neloc,nterms,nzo,iloc,jloc,np) c..s30 jacobian elements call tree(is30,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(is30,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(is30,img22,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(is30,is30,eloc,neloc,nterms,nzo,iloc,jloc,np) c..s32 jacobian elements call tree(is32,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(is32,io16,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(is32,isi28,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(is32,is32,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(is32,iar36,eloc,neloc,nterms,nzo,iloc,jloc,np) c..ar36 jacobian elements call tree(iar36,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(iar36,is32,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(iar36,iar36,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(iar36,ica40,eloc,neloc,nterms,nzo,iloc,jloc,np) c..ca40 jacobian elements call tree(ica40,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ica40,iar36,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ica40,ica40,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ica40,iti44,eloc,neloc,nterms,nzo,iloc,jloc,np) c..ti44 jacobian elements call tree(iti44,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(iti44,ica40,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(iti44,iti44,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(iti44,icr48,eloc,neloc,nterms,nzo,iloc,jloc,np) c..cr48 jacobian elements call tree(icr48,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(icr48,iti44,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(icr48,icr48,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(icr48,ife52,eloc,neloc,nterms,nzo,iloc,jloc,np) c..fe52 jacobian elements call tree(ife52,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ife52,icr48,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ife52,ife52,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ife52,ini56,eloc,neloc,nterms,nzo,iloc,jloc,np) c..ni56 jacobian elements call tree(ini56,ih1,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ini56,ihe4,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ini56,is30,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ini56,ife52,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(ini56,ini56,eloc,neloc,nterms,nzo,iloc,jloc,np) c..if we are doing a pure network, we are done if (pure_network .eq. 1) return c..temperature contributions do i=1,ionmax call tree(i,itemp,eloc,neloc,nterms,nzo,iloc,jloc,np) end do c..density contributions do i=1,ionmax call tree(i,iden,eloc,neloc,nterms,nzo,iloc,jloc,np) end do c..energy equation jacobian elements do i=1,ionmax call tree(iener,i,eloc,neloc,nterms,nzo,iloc,jloc,np) enddo call tree(iener,iener,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(iener,itemp,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(iener,iden,eloc,neloc,nterms,nzo,iloc,jloc,np) c..neutrino losses do i=1,ionmax call tree(iener,i,eloc,neloc,nterms,nzo,iloc,jloc,np) enddo call tree(iener,itemp,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(iener,iden,eloc,neloc,nterms,nzo,iloc,jloc,np) c..the temperature and density equation jacobian elements c..depend on the burning mode c..hydrostatic or single step if (hydrostatic .or. one_step .or. trho_hist) then call tree(itemp,itemp,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(iden,iden,eloc,neloc,nterms,nzo,iloc,jloc,np) c..adiabatic expansion else if (expansion) then call tree(itemp,itemp,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(iden,iden,eloc,neloc,nterms,nzo,iloc,jloc,np) c..self heating else if (self_heat_const_den) then do i=1,ionmax call tree(itemp,i,eloc,neloc,nterms,nzo,iloc,jloc,np) enddo call tree(itemp,itemp,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(itemp,iden,eloc,neloc,nterms,nzo,iloc,jloc,np) call tree(iden,iden,eloc,neloc,nterms,nzo,iloc,jloc,np) end if c..store the number of non-zero matrix elements in common non_zero_elements = nzo c..write a diagnostic c write(6,*) ' ' c write(6,*) nzo,' matrix elements' c write(6,*) nterms,' jacobian contributions' c write(6,*) ' ' return end subroutine shhe(tt,y,dfdy,nzo) include 'implno.dek' include 'const.dek' include 'burn_common.dek' include 'network.dek' include 'vector_eos.dek' c..this routine sets up the sparse hhe jacobian. c..input is tt (irrelevant here) and the abundances y(1). c..output is the jacobian dfdy(nzo). c..declare the pass integer nzo double precision tt,y(1),dfdy(1) c..locals logical deriva parameter (deriva = .true.) integer i,nt,iat double precision zbarxx,ytot1,abar,zbar,ye,taud,taut, 1 snuda,snudz,a1,a2,a3,a4,zz double precision conv,sixth parameter (conv = ev2erg*1.0d6*avo) parameter (sixth = 1.0d0/6.0d0) c..communicate with the jacobian builder integer neloc parameter (neloc=376) integer eloc(neloc),nterms common /elchhe/ eloc,nterms c..initialize nt = 0 do i=1,nzo dfdy(i) = 0.0d0 enddo do i=1,ionmax xsum(i) = 0.0d0 enddo c..positive definite mass fractions do i=1,ionmax y(i) = min(1.0d0,max(y(i),1.0d-30)) enddo c..generate abar and zbar for this composition zbarxx = 0.0d0 ytot1 = 0.0d0 do i=1,ionmax ytot1 = ytot1 + y(i) zbarxx = zbarxx + zion(i) * y(i) enddo abar = 1.0d0/ytot1 zbar = zbarxx * abar ye = zbar * ytot1 c..positive definite temperatures and densities y(itemp) = min(1.0d11,max(y(itemp),1.0d4)) y(iden) = min(1.0d11,max(y(iden),1.0d-10)) c..for evolution equations with the network if (pure_network .eq. 0) then c..get the new temperature and density if need be if (trho_hist) call update2(tt,y(itemp),y(iden)) if (self_heat_const_pres) then jlo_eos = 1 jhi_eos = 1 ptot_row(1) = bpres temp_row(1) = y(itemp) abar_row(1) = abar zbar_row(1) = zbar den_row(1) = y(iden) call invert_helm_pt_quiet y(iden) = den_row(1) end if c..positive definite temperatures and densities y(itemp) = min(1.0d11,max(y(itemp),1.0d4)) y(iden) = min(1.0d11,max(y(iden),1.0d-10)) c..set the common block temperature and density btemp = y(itemp) bden = y(iden) c..for pure network else if (pure_network .eq. 1) then if (trho_hist) call update2(tt,btemp,bden) end if c..get the reaction rates if (use_tables .eq. 1) then call hhetab(ye) else call hherat(ye) end if c..do the screening here because the corrections depend on the composition call screen_hhe(y) c..from pp123 c..h1 jacobian elements c..d(h1)/d(h1) a1 = -2.0d0*y(ih1)*(ratdum(irpp) + ratdum(irpep)) 1 - y(ih2)*ratdum(irdpg) 2 - y(ili7)*ratdum(irli7pa) 3 - y(ibe7)*ratdum(irbepg) 4 - y(ihe3)*ratdum(irhep) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(ih1) c..d(h1)/d(ih2) a1 = -y(ih1)*ratdum(irdpg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih2) = xsum(ih2) + a1 * bion(ih1) c..d(h1)/d(ihe3) a1 = 2.0d0*y(ihe3)*ratdum(ir33) 1 - y(ih1)*ratdum(irhep) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe3) = xsum(ihe3) + a1 * bion(ih1) c..d(h1)/d(ili7) a1 = -y(ih1)*ratdum(irli7pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ili7) = xsum(ili7) + a1 * bion(ih1) c..d(h1)/d(ibe7) a1 = -y(ih1)*ratdum(irbepg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ibe7) = xsum(ibe7) + a1 * bion(ih1) c..d(h1)/d(ib8) a1 = ratdum(irb8gp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ib8) = xsum(ib8) + a1 * bion(ih1) c..h2 jacobian elements c..d(ih2)/d(ih1) a1 = -y(ih2)*ratdum(irdpg) 1 + y(ih1)*(ratdum(irpp) + ratdum(irpep)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(ih2) c..d(ih2)/d(ih2) a1 = -y(ih1)*ratdum(irdpg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih2) = xsum(ih2) + a1 * bion(ih1) c..he3 jacobian elements c..d(ihe3)/d(ih1) a1 = y(ih2)*ratdum(irdpg) 1 - y(ihe3)*ratdum(irhep) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(ihe3) c..d(ihe3)/d(ih2) a1 = y(ih1)*ratdum(irdpg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih2) = xsum(ih2) + a1 * bion(ihe3) c..d(ihe3)/d(ihe3) a1 = -2.0d0*y(ihe3)*ratdum(ir33) 1 - y(ihe4)*ratdum(irhe3ag) 2 - y(ih1)*ratdum(irhep) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe3) = xsum(ihe3) + a1 * bion(ihe3) c..d(ihe3)/d(ihe4) a1 = - y(ihe3)*ratdum(irhe3ag) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(ihe3) c..4he jacobian elements c..d(ihe4)/d(ih1) a1 = 2.0d0*y(ili7)*ratdum(irli7pa) 1 + y(ihe3)*ratdum(irhep) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(ihe4) c..d(ihe4)/d(ihe3) a1 = y(ihe3)*ratdum(ir33) 1 - y(ihe4)*ratdum(irhe3ag) 2 + y(ih1)*ratdum(irhep) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe3) = xsum(ihe3) + a1 * bion(ihe4) c..d(ihe4)/d(ihe4) a1 = -y(ihe3)*ratdum(irhe3ag) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(ihe4) c..d(ihe4)/d(ili7) a1 = 2.0d0*y(ih1)*ratdum(irli7pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ili7) = xsum(ili7) + a1 * bion(ihe4) c..d(ihe4)/d(ib8) a1 = 2.0d0*ratdum(irb8ep) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ib8) = xsum(ib8) + a1 * bion(ihe4) c..li7 jacobian elements c..d(ili7)/d(ih1) a1 = -y(ili7)*ratdum(irli7pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(ili7) c..d(ili7)/d(ili7) a1 = -y(ih1)*ratdum(irli7pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ili7) = xsum(ili7) + a1 * bion(ili7) c..d(ili7)/d(ibe7) a1 = ratdum(irbeec) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ibe7) = xsum(ibe7) + a1 * bion(ili7) c..be7 jacobian elements c..d(ibe7)/d(ih1) a1 = -y(ibe7)*ratdum(irbepg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(ibe7) c..d(ibe7)/d(ihe3) a1 = y(ihe4)*ratdum(irhe3ag) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe3) = xsum(ihe3) + a1 * bion(ibe7) c..d(ibe7)/d(ihe4) a1 = y(ihe3)*ratdum(irhe3ag) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(ibe7) c..d(ibe7)/d(ibe7) a1 = -y(ih1)*ratdum(irbepg) 1 - ratdum(irbeec) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ibe7) = xsum(ibe7) + a1 * bion(ibe7) c..d(ibe7)/d(ib8) a1 = ratdum(irb8gp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ib8) = xsum(ib8) + a1 * bion(ibe7) c..b8 jacobian elements c..d(ib8)/d(ih1) a1 = y(ibe7)*ratdum(irbepg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(ib8) c..d(ib8)/d(ibe7) a1 = y(ih1)*ratdum(irbepg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ibe7) = xsum(ibe7) + a1 * bion(ib8) c..d(ib8)/d(ib8) a1 = -ratdum(irb8ep) 1 - ratdum(irb8gp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ib8) = xsum(ib8) + a1 * bion(ib8) c..add in the hot cno contributions c..h1 jacobian elements c..d(h1)/d(h1) a1 = -y(ic12)*ratdum(irc12pg) 1 - y(ic13)*ratdum(irc13pg) 2 - y(in14)*ratdum(irn14pg) 3 - y(in15)*ratdum(irn15pa) 4 - y(in15)*ratdum(irn15pg) 5 - y(io16)*ratdum(iro16pg) 6 - y(io17)*ratdum(iro17pa) 7 - y(io17)*ratdum(iro17pg) 8 - y(io18)*ratdum(iro18pa) 9 - y(io18)*ratdum(iro18pg) & - y(if19)*ratdum(irf19pa) 1 - y(in13)*ratdum(irn13pg) 2 - y(if17) * ratdum(irf17pa) 3 - y(if17) * ratdum(irf17pg) 4 - y(if18) * ratdum(irf18pa) a1 = a1 1 - 3.0d0*y(ine19)*ratdum(irne19pg) 2 - 2.0d0*y(ine20)*ratdum(irne20pg) 3 - 8.0d0 * y(img22)*ratdum(iralam1)*(1.0d0 - ratdum(irdelta1)) 4 - 26.0d0 * y(is30)*ratdum(iralam2)*(1.0d0 - ratdum(irdelta2)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(ih1) c..d(h1)/d(he4) a1 = y(ic12)*ratdum(irc12ap) 1 + y(in14)*ratdum(irn14ap) 2 + y(in15)*ratdum(irn15ap) 3 + y(io16)*ratdum(iro16ap) 4 + y(io14) * ratdum(iro14ap) 5 + y(io15) * ratdum(iro15ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(ih1) c..d(h1)/d(c12) a1 = -y(ih1)*ratdum(irc12pg) 1 + y(ihe4)*ratdum(irc12ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic12) = xsum(ic12) + a1 * bion(ih1) c..d(h1)/d(c13) a1 = -y(ih1)*ratdum(irc13pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic13) = xsum(ic13) + a1 * bion(ih1) c..d(h1)/d(n13) a1 = ratdum(irn13gp) 1 - y(ih1)*ratdum(irn13pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in13) = xsum(in13) + a1 * bion(ih1) c..d(h1)/d(n14) a1 = ratdum(irn14gp) 1 - y(ih1)*ratdum(irn14pg) 2 + y(ihe4)*ratdum(irn14ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in14) = xsum(in14) + a1 * bion(ih1) c..d(h1)/d(n15) a1 = -y(ih1)*ratdum(irn15pa) 1 - y(ih1)*ratdum(irn15pg) 2 + y(ihe4)*ratdum(irn15ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in15) = xsum(in15) + a1 * bion(ih1) c..d(h1)/d(o14) a1 = y(ihe4) * ratdum(iro14ap) 1 + ratdum(iro14gp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io14) = xsum(io14) + a1 * bion(ih1) c..d(h1)/d(o15) a1 = ratdum(iro15gp) 1 + y(ihe4) * ratdum(iro15ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io15) = xsum(io15) + a1 * bion(ih1) c..d(h1)/d(o16) a1 = ratdum(iro16gp) 1 - y(ih1)*ratdum(iro16pg) 2 + y(ihe4)*ratdum(iro16ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(ih1) c..d(h1)/d(o17) a1 = -y(ih1)*ratdum(iro17pa) 1 - y(ih1)*ratdum(iro17pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io17) = xsum(io17) + a1 * bion(ih1) c..d(h1)/d(o18) a1 = -y(ih1)*ratdum(iro18pa) 1 - y(ih1)*ratdum(iro18pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io18) = xsum(io18) + a1 * bion(ih1) c..d(h1)/d(f17) a1 = ratdum(irf17gp) 1 - y(ih1) * ratdum(irf17pa) 2 - y(ih1) * ratdum(irf17pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(if17) = xsum(if17) + a1 * bion(ih1) c..d(h1)/d(f18) a1 = ratdum(irf18gp) 1 - y(ih1) * ratdum(irf18pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(if18) = xsum(if18) + a1 * bion(ih1) c..d(h1)/d(f19) a1 = ratdum(irf19gp) 1 - y(ih1)*ratdum(irf19pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(if19) = xsum(if19) + a1 * bion(ih1) c..d(h1)/d(ne18) a1 = ratdum(irne18gp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ine18) = xsum(ine18) + a1 * bion(ih1) c..d(h1)/d(ne19) a1 = -3.0d0*y(ih1)*ratdum(irne19pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ine19) = xsum(ine19) + a1 * bion(ih1) c..d(h1)/d(ne20) a1 = -2.0d0*y(ih1)*ratdum(irne20pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ine20) = xsum(ine20) + a1 * bion(ih1) c..d(h1)/d(mg22) a1 = -8.0d0 * y(ih1)* ratdum(iralam1)*(1.0d0 - ratdum(irdelta1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(img22) = xsum(img22) + a1 * bion(ih1) c..d(h1)/d(s30) a1 = -26.0d0 * y(ih1)*ratdum(iralam2)*(1.0d0 - ratdum(irdelta2)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(is30) = xsum(is30) + a1 * bion(ih1) c..he4 jacobian elements c..d(he4)/d(h1) a1 = y(in15)*ratdum(irn15pa) 1 + y(io17)*ratdum(iro17pa) 2 + y(io18)*ratdum(iro18pa) 3 + y(if19)*ratdum(irf19pa) 4 + y(if17) * ratdum(irf17pa) 5 + y(if18) * ratdum(irf18pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(ihe4) c..d(he4)/d(he4) a1 = -y(ic12)*ratdum(irc12ap) 1 - y(in14)*ratdum(irn14ap) 2 - y(in15)*ratdum(irn15ap) 3 - y(io16)*ratdum(iro16ap) 4 - y(io14) * ratdum(iro14ap) 5 - y(io15) * ratdum(iro15ap) 6 - 1.5d0 * y(ihe4) * y(ihe4) * ratdum(ir3a) 7 - y(io16) * ratdum(iroag) 8 - 2.0d0 * y(img22)*ratdum(iralam1)*ratdum(irdelta1) 9 - 6.5d0 * y(is30) * ratdum(iralam2) * ratdum(irdelta2) & - y(ic12) * ratdum(ircag) 1 - y(ine18) * ratdum(irne18ap) 2 - y(io15) * ratdum(iro15ag) a1 = a1 1 - y(ic12) * ratdum(ircag) 2 - y(io16) * ratdum(iroag) 3 - y(ine20) * ratdum(irneag) 4 - y(img24) * ratdum(irmgag) 5 - y(isi28) * ratdum(irsiag) 6 - y(is32) * ratdum(irsag) 7 - y(iar36) * ratdum(irarag) 8 - y(ica40) * ratdum(ircaag) 9 - y(iti44) * ratdum(irtiag) & - y(icr48) * ratdum(ircrag) 1 - y(ife52) * ratdum(irfeag) a1 = a1 1 - y(img24) * ratdum(irmgap) * (1.0d0-ratdum(irr1)) 2 - y(isi28) * ratdum(irsiap) * (1.0d0-ratdum(irs1)) 3 - y(is32) * ratdum(irsap) * (1.0d0-ratdum(irt1)) 4 - y(iar36) * ratdum(irarap) * (1.0d0-ratdum(iru1)) 5 - y(ica40) * ratdum(ircaap) * (1.0d0-ratdum(irv1)) 6 - y(iti44) * ratdum(irtiap) * (1.0d0-ratdum(irw1)) 7 - y(icr48) * ratdum(ircrap) * (1.0d0-ratdum(irx1)) 8 - y(ife52) * ratdum(irfeap) * (1.0d0-ratdum(iry1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(ihe4) c..d(he4)/d(c12) a1 = -y(ihe4)*ratdum(irc12ap) 1 + 3.0d0 * ratdum(irg3a) 2 - y(ihe4) * ratdum(ircag) 3 + y(ic12) * ratdum(ir1212) 4 + 0.5d0 * y(io16) * ratdum(ir1216) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic12) = xsum(ic12) + a1 * bion(ihe4) c..d(he4)/d(n14) a1 = -y(ihe4)*ratdum(irn14ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in14) = xsum(in14) + a1 * bion(ihe4) c..d(he4)/d(n15) a1 = y(ih1)*ratdum(irn15pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in15) = xsum(in15) + a1 * bion(ihe4) c..d(he4)/d(o14) a1 = -y(ihe4) * ratdum(iro14ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io14) = xsum(io14) + a1 * bion(ihe4) c..d(he4)/d(o15) a1 = -y(ihe4) * ratdum(iro15ap) & - y(ihe4) * ratdum(iro15ag) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io15) = xsum(io15) + a1 * bion(ihe4) c..d(he4)/d(o16) a1 = -y(ihe4)*ratdum(iro16ap) 1 - y(ihe4) * ratdum(iroag) 2 + ratdum(iroga) 3 + 0.5d0 * y(ic12) * ratdum(ir1216) 4 + 1.12d0 * 0.5d0 * y(io16) * ratdum(ir1616) 5 + 0.68d0*ratdum(irs1)*0.5d0*y(io16)*ratdum(ir1616) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(ihe4) c..d(he4)/d(o17) a1 = y(ih1)*ratdum(iro17pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io17) = xsum(io17) + a1 * bion(ihe4) c..d(he4)/d(o18) a1 = y(ih1)*ratdum(iro18pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io18) = xsum(io18) + a1 * bion(ihe4) c..d(he4)/d(f17) a1 = y(ih1) * ratdum(irf17pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(if17) = xsum(if17) + a1 * bion(ihe4) c..d(he4)/d(f18) a1 = y(ih1) * ratdum(irf18pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(if18) = xsum(if18) + a1 * bion(ihe4) c..d(he4)/d(f19) a1 = y(ih1)*ratdum(irf19pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(if19) = xsum(if19) + a1 * bion(ihe4) c..d(he4)/d(ne18) a1 = -y(ihe4) * ratdum(irne18ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ine18) = xsum(ine18) + a1 * bion(ihe4) c..d(he4)/d(ne20) a1 = ratdum(irnega) 1 - y(ihe4) * ratdum(irneag) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ine20) = xsum(ine20) + a1 * bion(ihe4) c..d(he4)/d(mg22) a1 = -2.0d0*y(ihe4)*ratdum(iralam1)*ratdum(irdelta1) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(img22) = xsum(img22) + a1 * bion(ihe4) c..d(he4)/d(mg24) a1 = ratdum(irmgga) 1 - y(ihe4) * ratdum(irmgag) 2 - y(ihe4) * ratdum(irmgap) * (1.0d0-ratdum(irr1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(img24) = xsum(img24) + a1 * bion(ihe4) c..d(he4)/d(si28) a1 = ratdum(irsiga) 1 - y(ihe4) * ratdum(irsiag) 2 - y(ihe4) * ratdum(irsiap) * (1.0d0-ratdum(irs1)) 3 + ratdum(irr1) * ratdum(irsigp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(isi28) = xsum(isi28) + a1 * bion(ihe4) c..d(he4)/d(s30) a1 = -6.5d0 * y(ihe4) * ratdum(iralam2) * ratdum(irdelta2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(is30) = xsum(is30) + a1 * bion(ihe4) c..d(he4)/d(s32) a1 = ratdum(irsga) 1 - y(ihe4) * ratdum(irsag) 2 - y(ihe4) * ratdum(irsap) * (1.0d0-ratdum(irt1)) 3 + ratdum(irs1) * ratdum(irsgp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(is32) = xsum(is32) + a1 * bion(ihe4) c..d(he4)/d(ar36) a1 = ratdum(irarga) 1 - y(ihe4) * ratdum(irarag) 2 - y(ihe4) * ratdum(irarap) * (1.0d0-ratdum(iru1)) 3 + ratdum(irt1) * ratdum(irargp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(iar36) = xsum(iar36) + a1 * bion(ihe4) c..d(he4)/d(ca40) a1 = ratdum(ircaga) 1 - y(ihe4) * ratdum(ircaag) 2 - y(ihe4) * ratdum(ircaap) * (1.0d0-ratdum(irv1)) 3 + ratdum(iru1) * ratdum(ircagp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ica40) = xsum(ica40) + a1 * bion(ihe4) c..d(he4)/d(ti44) a1 = ratdum(irtiga) 1 - y(ihe4) * ratdum(irtiag) 2 - y(ihe4) * ratdum(irtiap) * (1.0d0-ratdum(irw1)) 3 + ratdum(irv1) * ratdum(irtigp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(iti44) = xsum(iti44) + a1 * bion(ihe4) c..d(he4)/d(cr48) a1 = ratdum(ircrga) 1 - y(ihe4) * ratdum(ircrag) 2 - y(ihe4) * ratdum(ircrap) * (1.0d0-ratdum(irx1)) 3 + ratdum(irw1) * ratdum(ircrgp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(icr48) = xsum(icr48) + a1 * bion(ihe4) c..d(he4)/d(fe52) a1 = ratdum(irfega) 1 - y(ihe4) * ratdum(irfeag) 2 - y(ihe4) * ratdum(irfeap) * (1.0d0-ratdum(iry1)) 3 + ratdum(irx1) * ratdum(irfegp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ife52) = xsum(ife52) + a1 * bion(ihe4) c..d(he4)/d(ni56) a1 = ratdum(irniga) 1 + ratdum(iry1) * ratdum(irnigp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ini56) = xsum(ini56) + a1 * bion(ihe4) c..c12 jacobian elements c..d(c12)/d(h1) a1 = -y(ic12)*ratdum(irc12pg) 1 + y(in15)*ratdum(irn15pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(ic12) c..d(c12)/d(he4) a1 = -y(ic12)*ratdum(irc12ap) 1 + 0.5d0 * y(ihe4) * y(ihe4) * ratdum(ir3a) 2 - y(ic12) * ratdum(ircag) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(ic12) c..d(c12)/d(c12) a1 = -y(ih1)*ratdum(irc12pg) 1 - y(ihe4)*ratdum(irc12ap) 2 - ratdum(irg3a) 3 - y(ihe4) * ratdum(ircag) 4 - 2.0d0 * y(ic12) * ratdum(ir1212) 5 - y(io16) * ratdum(ir1216) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic12) = xsum(ic12) + a1 * bion(ic12) c..d(c12)/d(n13) a1 = ratdum(irn13gp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in13) = xsum(in13) + a1 * bion(ic12) c..d(c12)/d(n15) a1 = y(ih1)*ratdum(irn15pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in15) = xsum(in15) + a1 * bion(ic12) c..d(c12)/d(o16) a1 = ratdum(iroga) 1 - y(ic12) * ratdum(ir1216) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(ic12) c..c13 jacobian elements c..d(c13)/d(h1) a1 = -y(ic13)*ratdum(irc13pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(ic13) c..d(c13)/d(c13) a1 = -y(ih1)*ratdum(irc13pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic13) = xsum(ic13) + a1 * bion(ic13) c..d(c13)/d(n13) a1 = ratdum(irn13enu) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in13) = xsum(in13) + a1 * bion(ic13) c..d(c13)/d(n14) a1 = ratdum(irn14gp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in14) = xsum(in14) + a1 * bion(ic13) c..n13 jacobian elements c..d(n13)/d(h1) a1 = y(ic12)*ratdum(irc12pg) 1 - y(in13)*ratdum(irn13pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(in13) c..d(n13)/d(c12) a1 = y(ih1)*ratdum(irc12pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic12) = xsum(ic12) + a1 * bion(in13) c..d(n13)/d(n13) a1 = -ratdum(irn13gp) 1 - ratdum(irn13enu) 2 - y(ih1)*ratdum(irn13pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in13) = xsum(in13) + a1 * bion(in13) c..d(n13)/d(o14) a1 = ratdum(iro14gp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io14) = xsum(io14) + a1 * bion(in13) c..n14 jacobian elements c..d(n14)/d(h1) a1 = y(ic13)*ratdum(irc13pg) 1 - y(in14)*ratdum(irn14pg) 2 + y(io17)*ratdum(iro17pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(in14) c..d(n14)/d(he4) a1 = -y(in14)*ratdum(irn14ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(in14) c..d(n14)/d(c13) a1 = y(ih1)*ratdum(irc13pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic13) = xsum(ic13) + a1 * bion(in14) c..d(n14)/d(n14) a1 = -ratdum(irn14gp) 1 - y(ih1)*ratdum(irn14pg) 2 - y(ihe4)*ratdum(irn14ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in14) = xsum(in14) + a1 * bion(in14) c..d(n14)/d(o14) a1 = ratdum(iro14enu) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io14) = xsum(io14) + a1 * bion(in14) c..d(n14)/d(o15) a1 = ratdum(iro15gp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io15) = xsum(io15) + a1 * bion(in14) c..d(n14)/d(o17) a1 = y(ih1)*ratdum(iro17pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io17) = xsum(io17) + a1 * bion(in14) c..n15 jacobian elements c..d(n15)/d(h1) a1 = -y(in15)*ratdum(irn15pa) 1 - y(in15)*ratdum(irn15pg) 2 + y(io18)*ratdum(iro18pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(in15) c..d(n15)/d(he4) a1 = y(ic12)*ratdum(irc12ap) 1 - y(in15)*ratdum(irn15ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(in15) c..d(n15)/d(c12) a1 = y(ihe4)*ratdum(irc12ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic12) = xsum(ic12) + a1 * bion(in15) c..d(n15)/d(n15) a1 = -y(ih1)*ratdum(irn15pa) 1 - y(ih1)*ratdum(irn15pg) 2 - y(ihe4)*ratdum(irn15ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in15) = xsum(in15) + a1 * bion(in15) c..d(n15)/d(o15) a1 = ratdum(iro15enu) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io15) = xsum(io15) + a1 * bion(in15) c..d(n15)/d(o16) a1 = ratdum(iro16gp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(in15) c..d(n15)/d(o18) a1 = y(ih1)*ratdum(iro18pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io18) = xsum(io18) + a1 * bion(in15) c..o14 jacobian elements c..d(o14)/d(h1) a1 = y(in13)*ratdum(irn13pg) 1 + y(if17) * ratdum(irf17pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(io14) c..d(o14)/d(he4) a1 = -y(io14) * ratdum(iro14ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(io14) c..d(o14)/d(n13) a1 = y(ih1)*ratdum(irn13pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in13) = xsum(in13) + a1 * bion(io14) c..d(o14)/d(o14) a1 = -ratdum(iro14gp) 1 - ratdum(iro14enu) 2 - y(ihe4) * ratdum(iro14ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io14) = xsum(io14) + a1 * bion(io14) c..d(o14)/d(f17) a1 = y(ih1) * ratdum(irf17pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(if17) = xsum(if17) + a1 * bion(io14) c..o15 jacobian elements c..d(o15)/d(h1) a1 = y(in14)*ratdum(irn14pg) 1 + y(if18) * ratdum(irf18pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(io15) c..d(o15)/d(he4) a1 = -y(io15) * ratdum(iro15ap) 1 - y(io15) * ratdum(iro15ag) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(io15) c..d(o15)/d(n14) a1 = y(ih1)*ratdum(irn14pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in14) = xsum(in14) + a1 * bion(io15) c..d(o15)/d(o15) a1 = -ratdum(iro15gp) 1 - ratdum(iro15enu) 2 - y(ihe4) * ratdum(iro15ap) 3 - y(ihe4) * ratdum(iro15ag) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io15) = xsum(io15) + a1 * bion(io15) c..d(o15)/d(f18) a1 = y(ih1) * ratdum(irf18pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(if18) = xsum(if18) + a1 * bion(io15) c..o16 jacobian elements c..d(o16)/d(h1) a1 = y(in15)*ratdum(irn15pg) 1 - y(io16)*ratdum(iro16pg) 2 + y(if19)*ratdum(irf19pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(io16) c..d(o16)/d(he4) a1 = -y(io16)*ratdum(iro16ap) 1 - y(io16) * ratdum(iroag) 2 + y(ic12) * ratdum(ircag) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(io16) c..d(o16)/d(c12) a1 = y(ihe4) * ratdum(ircag) 1 - y(io16)*ratdum(ir1216) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic12) = xsum(ic12) + a1 * bion(io16) c..d(o16)/d(n15) a1 = y(ih1)*ratdum(irn15pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in15) = xsum(in15) + a1 * bion(io16) c..d(o16)/d(o16) a1 = -ratdum(iro16gp) 1 - y(ih1)*ratdum(iro16pg) 2 - y(ihe4)*ratdum(iro16ap) 3 - y(ihe4) * ratdum(iroag) 4 - ratdum(iroga) 5 - y(ic12) * ratdum(ir1216) 6 - 2.0d0 * y(io16) * ratdum(ir1616) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(io16) c..d(o16)/d(f17) a1 = ratdum(irf17gp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(if17) = xsum(if17) + a1 * bion(io16) c..d(o16)/d(f19) a1 = y(ih1)*ratdum(irf19pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(if19) = xsum(if19) + a1 * bion(io16) c..d(o16)/d(ne20) a1 = ratdum(irnega) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ine20) = xsum(ine20) + a1 * bion(io16) c..o17 jacobian elements c..d(o17)/d(h1) a1 = -y(io17)*ratdum(iro17pa) 1 - y(io17)*ratdum(iro17pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(io17) c..d(o17)/d(he4) a1 = y(in14)*ratdum(irn14ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(io17) c..d(o17)/d(n14) a1 = y(ihe4)*ratdum(irn14ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in14) = xsum(in14) + a1 * bion(io17) c..d(o17)/d(o17) a1 = -y(ih1)*ratdum(iro17pa) 1 - y(ih1)*ratdum(iro17pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io17) = xsum(io17) + a1 * bion(io17) c..d(o17)/d(f17) a1 = ratdum(irf17enu) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(if17) = xsum(if17) + a1 * bion(io17) c..d(o17)/d(f18) a1 = ratdum(irf18gp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(if18) = xsum(if18) + a1 * bion(io17) c..o18 jacobian elements c..d(o18)/d(h1) a1 = -y(io18)*ratdum(iro18pa) 1 - y(io18)*ratdum(iro18pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(io18) c..d(o18)/d(he4) a1 = y(in15)*ratdum(irn15ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(io18) c..d(o18)/d(n15) a1 = y(ihe4)*ratdum(irn15ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(in15) = xsum(in15) + a1 * bion(io18) c..d(o18)/d(o18) a1 = -y(ih1)*ratdum(iro18pa) 1 - y(ih1)*ratdum(iro18pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io18) = xsum(io18) + a1 * bion(io18) c..d(o18)/d(f18) a1 = ratdum(irf18enu) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(if18) = xsum(if18) + a1 * bion(io18) c..d(o18)/d(f19) a1 = ratdum(irf19gp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(if19) = xsum(if19) + a1 * bion(io18) c..f17 jacobian elements c..d(f17)/d(h1) a1 = y(io16)*ratdum(iro16pg) 1 - y(if17) * ratdum(irf17pa) 2 - y(if17) * ratdum(irf17pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(if17) c..d(f17)/d(he4) a1 = y(io14) * ratdum(iro14ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(if17) c..d(f17)/d(o14) a1 = y(ihe4) * ratdum(iro14ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io14) = xsum(io14) + a1 * bion(if17) c..d(f17)/d(o16) a1 = y(ih1)*ratdum(iro16pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(if17) c..d(f17)/d(f17) a1 = -ratdum(irf17gp) 1 - ratdum(irf17enu) 2 - y(ih1) * ratdum(irf17pa) 3 - y(ih1) * ratdum(irf17pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(if17) = xsum(if17) + a1 * bion(if17) c..d(f17)/d(ne18) a1 = ratdum(irne18gp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ine18) = xsum(ine18) + a1 * bion(if17) c..f18 jacobian elements c..d(f18)/d(h1) a1 = y(io17)*ratdum(iro17pg) 1 - y(if18) * ratdum(irf18pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(if18) c..d(f18)/d(he4) a1 = y(io15) * ratdum(iro15ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(if18) c..d(f18)/d(o15) a1 = y(ihe4) * ratdum(iro15ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io15) = xsum(io15) + a1 * bion(if18) c..d(f18)/d(o17) a1 = y(ih1)*ratdum(iro17pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io17) = xsum(io17) + a1 * bion(if18) c..d(f18)/d(f18) a1 = -ratdum(irf18gp) 1 - ratdum(irf18enu) 2 - y(ih1) * ratdum(irf18pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(if18) = xsum(if18) + a1 * bion(if18) c..d(f18)/d(ne18) a1 = ratdum(irne18enu) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ine22) = xsum(ine22) + a1 * bion(if18) c..f19 jacobian elements c..d(f19)/d(h1) a1 = y(io18)*ratdum(iro18pg) 1 - y(if19)*ratdum(irf19pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(if19) c..d(f19)/d(he4) a1 = y(io16)*ratdum(iro16ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(if19) c..d(f19)/d(o16) a1 = y(ihe4)*ratdum(iro16ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(if19) c..d(f19)/d(o18) a1 = y(ih1)*ratdum(iro18pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io18) = xsum(io18) + a1 * bion(if19) c..d(f19)/d(f19) a1 = -ratdum(irf19gp) 1 - y(ih1)*ratdum(irf19pa) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(if19) = xsum(if19) + a1 * bion(if19) c..d(f19)/d(ne19) a1 = ratdum(irne19enu) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ine19) = xsum(ine19) + a1 * bion(if19) c..ne18 jacobian elements c..d(ne18)/d(h1) a1 = y(if17) * ratdum(irf17pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(ine18) c..d(ne18)/d(he4) a1 = -y(ine18) * ratdum(irne18ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(ine18) c..d(ne18)/d(f17) a1 = y(ih1) * ratdum(irf17pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(if17) = xsum(if17) + a1 * bion(ine18) c..d(ne18)/d(ne18) a1 = -ratdum(irne18gp) 1 - ratdum(irne18enu) 2 - y(ihe4) * ratdum(irne18ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ine18) = xsum(ine18) + a1 * bion(ine18) c..ne19 jacobian elements c..d(ne19)/d(h1) a1 = -y(ine19)*ratdum(irne19pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(ine19) c..d(ne19)/d(he4) a1 = y(io15) * ratdum(iro15ag) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(ine19) c..d(ne19)/d(o15) a1 = y(ihe4) * ratdum(iro15ag) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io15) = xsum(io15) + a1 * bion(ine19) c..d(ne19)/d(ne19) a1 = -ratdum(irne19enu) 1 - y(ih1)*ratdum(irne19pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ine19) = xsum(ine19) + a1 * bion(ine19) c..ne20 jacobian elements c..d(ne20)/d(h1) a1 = -y(ine20)*ratdum(irne20pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(ine20) c..d(ne20)/d(he4) a1 = y(io16) * ratdum(iroag) 1 - y(ine20) * ratdum(irneag) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(ine20) c..d(ne20)/d(c12) a1 = y(ic12) * ratdum(ir1212) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic12) = xsum(ic12) + a1 * bion(ine20) c..d(ne20)/d(o16) a1 = y(ihe4) * ratdum(iroag) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(ine20) c..d(ne20)/d(ne20) a1 = -y(ih1)*ratdum(irne20pg) 1 - y(ihe4) * ratdum(irneag) 2 - ratdum(irnega) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ine20) = xsum(ine20) + a1 * bion(ine20) c..d(ne20)/d(mg24) a1 = ratdum(irmgga) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(img24) = xsum(img24) + a1 * bion(ine20) c..mg22 jacobian elements c..d(mg22)/d(h1) a1 = y(ine19)*ratdum(irne19pg) 1 + y(ine20)*ratdum(irne20pg) 2 - y(img22)*ratdum(iralam1)*(1.0d0 - ratdum(irdelta1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(img22) c..d(mg22)/d(he4) a1 = -y(img22)*ratdum(iralam1)*ratdum(irdelta1) 1 + y(ine18) * ratdum(irne18ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(img22) c..d(mg22)/d(ne18) a1 = y(ihe4) * ratdum(irne18ap) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ine18) = xsum(ine18) + a1 * bion(img22) c..d(mg22)/d(ne19) a1 = y(ih1)*ratdum(irne19pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ine19) = xsum(ine19) + a1 * bion(img22) c..d(mg22)/d(ne20) a1 = y(ih1)*ratdum(irne20pg) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ine20) = xsum(ine20) + a1 * bion(img22) c..d(mg22)/d(mg22) a1 = -y(ih1)*ratdum(iralam1)*(1.0d0 - ratdum(irdelta1)) 1 - y(ihe4)*ratdum(iralam1)*ratdum(irdelta1) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(img22) = xsum(img22) + a1 * bion(img22) c..mg24 jacobian elements c..d(mg24)/d(he4) a1 = y(ine20) * ratdum(irneag) 1 - y(img24) * ratdum(irmgag) 2 - y(img24) * ratdum(irmgap) * (1.0d0-ratdum(irr1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(img24) c..d(mg24)/d(c12) a1 = 0.5d0 * y(io16) * ratdum(ir1216) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic12) = xsum(ic12) + a1 * bion(img24) c..d(mg24)/d(o16) a1 = 0.5d0 * y(ic12) * ratdum(ir1216) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(img24) c..d(mg24)/d(ne20) a1 = y(ihe4) * ratdum(irneag) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ine20) = xsum(ine20) + a1 * bion(img24) c..d(mg24)/d(mg24) a1 = -y(ihe4) * ratdum(irmgag) 1 - ratdum(irmgga) 2 - y(ihe4) * ratdum(irmgap) * (1.0d0-ratdum(irr1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(img24) = xsum(img24) + a1 * bion(img24) c..d(mg24)/d(si28) a1 = ratdum(irsiga) 1 + ratdum(irr1) * ratdum(irsigp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(isi28) = xsum(isi28) + a1 * bion(img24) c..si28 jacobian elements c..d(si28)/d(he4) a1 = y(img24) * ratdum(irmgag) 1 - y(isi28) * ratdum(irsiag) 2 + y(img24) * ratdum(irmgap) * (1.0d0-ratdum(irr1)) 3 - y(isi28) * ratdum(irsiap) * (1.0d0-ratdum(irs1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(isi28) c..d(si28)/d(c12) a1 = 0.5d0 * y(io16) * ratdum(ir1216) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ic12) = xsum(ic12) + a1 * bion(isi28) c..d(si28)/d(o16) a1 = 0.5d0 * y(ic12) * ratdum(ir1216) 1 + 1.12d0 * 0.5d0*y(io16) * ratdum(ir1616) 2 + 0.68d0 * 0.5d0*y(io16)*ratdum(irs1)*ratdum(ir1616) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(isi28) c..d(si28)/d(mg24) a1 = y(ihe4) * ratdum(irmgag) 1 + y(ihe4) * ratdum(irmgap) * (1.0d0-ratdum(irr1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(img24) = xsum(img24) + a1 * bion(isi28) c..d(si28)/d(si28) a1 = -y(ihe4) * ratdum(irsiag) 1 - ratdum(irsiga) 2 - ratdum(irr1) * ratdum(irsigp) 3 - y(ihe4) * ratdum(irsiap) * (1.0d0-ratdum(irs1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(isi28) = xsum(isi28) + a1 * bion(isi28) c..d(si28)/d(s32) a1 = ratdum(irsga) 1 + ratdum(irs1) * ratdum(irsgp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(is32) = xsum(is32) + a1 * bion(isi28) c..s30 jacobian elements c..d(s30)/d(h1) a1 = y(img22)*ratdum(iralam1)*(1.0d0 - ratdum(irdelta1)) 1 - y(is30)*ratdum(iralam2)*(1.0d0 - ratdum(irdelta2)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(is30) c..d(s30)/d(he4) a1 = y(img22)*ratdum(iralam1)*ratdum(irdelta1) 1 - y(is30)*ratdum(iralam2)*ratdum(irdelta2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(is30) c..d(s30)/d(mg22) a1 = y(ih1)*ratdum(iralam1)*(1.0d0 - ratdum(irdelta1)) 1 + y(ihe4)*ratdum(iralam1)*ratdum(irdelta1) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(img22) = xsum(img22) + a1 * bion(is30) c..d(s30)/d(s30) a1 = -y(ih1)*ratdum(iralam2)*(1.0d0 - ratdum(irdelta2)) 1 - y(ihe4)*ratdum(iralam2)*ratdum(irdelta2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(is30) = xsum(is30) + a1 * bion(is30) c..s32 jacobian elements c..d(s32)/d(he4) a1 = y(isi28) * ratdum(irsiag) 1 - y(is32) * ratdum(irsag) 2 + y(isi28) * ratdum(irsiap) * (1.0d0-ratdum(irs1)) 3 - y(is32) * ratdum(irsap) * (1.0d0-ratdum(irt1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(is32) c..d(s32)/d(o16) a1 = 0.68d0*0.5d0*y(io16) 1 *ratdum(ir1616)*(1.0d0-ratdum(irs1)) 2 + 0.2d0 * 0.5d0*y(io16) * ratdum(ir1616) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(io16) = xsum(io16) + a1 * bion(is32) c..d(s32)/d(si28) a1 = y(ihe4) * ratdum(irsiag) 1 + y(ihe4) * ratdum(irsiap) * (1.0d0-ratdum(irs1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(isi28) = xsum(isi28) + a1 * bion(is32) c..d(s32)/d(s32) a1 = -y(ihe4) * ratdum(irsag) 1 - ratdum(irsga) 2 - ratdum(irs1) * ratdum(irsgp) 3 - y(ihe4) * ratdum(irsap) * (1.0d0-ratdum(irt1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(is32) = xsum(is32) + a1 * bion(is32) c..d(s32)/d(ar36) a1 = ratdum(irarga) 1 + ratdum(irt1) * ratdum(irargp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(iar36) = xsum(iar36) + a1 * bion(is32) c..ar36 jacobian elements c..d(ar36)/d(he4) a1 = y(is32) * ratdum(irsag) 1 - y(iar36) * ratdum(irarag) 2 + y(is32) * ratdum(irsap) * (1.0d0-ratdum(irt1)) 3 - y(iar36) * ratdum(irarap) * (1.0d0-ratdum(iru1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(iar36) c..d(ar36)/d(s32) a1 = y(ihe4) * ratdum(irsag) 1 + y(ihe4) * ratdum(irsap) * (1.0d0-ratdum(irt1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(is32) = xsum(is32) + a1 * bion(iar36) c..d(ar36)/d(ar36) a1 = -y(ihe4) * ratdum(irarag) 1 - ratdum(irarga) 2 - ratdum(irt1) * ratdum(irargp) 3 - y(ihe4) * ratdum(irarap) * (1.0d0-ratdum(iru1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(iar36) = xsum(iar36) + a1 * bion(iar36) c..d(ar36)/d(ca40) a1 = ratdum(ircaga) 1 + ratdum(ircagp) * ratdum(iru1) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ica40) = xsum(ica40) + a1 * bion(iar36) c..ca40 jacobian elements c..d(ca40)/d(he4) a1 = y(iar36) * ratdum(irarag) 1 - y(ica40) * ratdum(ircaag) 2 + y(iar36) * ratdum(irarap)*(1.0d0-ratdum(iru1)) 3 - y(ica40) * ratdum(ircaap)*(1.0d0-ratdum(irv1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(ica40) c..d(ca40)/d(ar36) a1 = y(ihe4) * ratdum(irarag) 1 + y(ihe4) * ratdum(irarap)*(1.0d0-ratdum(iru1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(iar36) = xsum(iar36) + a1 * bion(ica40) c..d(ca40)/d(ca40) a1 = -y(ihe4) * ratdum(ircaag) 1 - ratdum(ircaga) 2 - ratdum(ircagp) * ratdum(iru1) 3 - y(ihe4) * ratdum(ircaap)*(1.0d0-ratdum(irv1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ica40) = xsum(ica40) + a1 * bion(ica40) c..d(ca40)/d(ti44) a1 = ratdum(irtiga) 1 + ratdum(irtigp) * ratdum(irv1) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(iti44) = xsum(iti44) + a1 * bion(ica40) c..ti44 jacobian elements c..d(ti44)/d(he4) a1 = y(ica40) * ratdum(ircaag) 1 - y(iti44) * ratdum(irtiag) 2 + y(ica40) * ratdum(ircaap)*(1.0d0-ratdum(irv1)) 3 - y(iti44) * ratdum(irtiap)*(1.0d0-ratdum(irw1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(iti44) c..d(ti44)/d(ca40) a1 = y(ihe4) * ratdum(ircaag) 1 + y(ihe4) * ratdum(ircaap)*(1.0d0-ratdum(irv1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ica40) = xsum(ica40) + a1 * bion(iti44) c..d(ti44)/d(ti44) a1 = -y(ihe4) * ratdum(irtiag) 1 - ratdum(irtiga) 2 - ratdum(irv1) * ratdum(irtigp) 3 - y(ihe4) * ratdum(irtiap)*(1.0d0-ratdum(irw1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(iti44) = xsum(iti44) + a1 * bion(iti44) c..d(ti44)/d(cr48) a1 = ratdum(ircrga) 1 + ratdum(irw1) * ratdum(ircrgp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(icr48) = xsum(icr48) + a1 * bion(iti44) c..cr48 jacobian elements c..d(cr48)/d(he4) a1 = y(iti44) * ratdum(irtiag) 1 - y(icr48) * ratdum(ircrag) 2 + y(iti44) * ratdum(irtiap)*(1.0d0-ratdum(irw1)) 3 - y(icr48) * ratdum(ircrap)*(1.0d0-ratdum(irx1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(icr48) c..d(cr48)/d(ti44) a1 = y(ihe4) * ratdum(irtiag) 1 + y(ihe4) * ratdum(irtiap)*(1.0d0-ratdum(irw1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(iti44) = xsum(iti44) + a1 * bion(icr48) c..d(cr48)/d(cr48) a1 = -y(ihe4) * ratdum(ircrag) 1 - ratdum(ircrga) 2 - ratdum(irw1) * ratdum(ircrgp) 3 - y(ihe4) * ratdum(ircrap)*(1.0d0-ratdum(irx1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(icr48) = xsum(icr48) + a1 * bion(icr48) c..d(cr48)/d(fe52) a1 = ratdum(irfega) 1 + ratdum(irx1) * ratdum(irfegp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ife52) = xsum(ife52) + a1 * bion(icr48) c..fe52 jacobian elements c..d(fe52)/d(he4) a1 = y(icr48) * ratdum(ircrag) 1 - y(ife52) * ratdum(irfeag) 2 + y(icr48) * ratdum(ircrap) * (1.0d0-ratdum(irx1)) 3 - y(ife52) * ratdum(irfeap) * (1.0d0-ratdum(iry1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(ife52) c..d(fe52)/d(cr48) a1 = y(ihe4) * ratdum(ircrag) 1 + y(ihe4) * ratdum(ircrap) * (1.0d0-ratdum(irx1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(icr48) = xsum(icr48) + a1 * bion(ife52) c..d(fe52)/d(fe52) a1 = -y(ihe4) * ratdum(irfeag) 1 - ratdum(irfega) 2 - ratdum(irx1) * ratdum(irfegp) 3 - y(ihe4) * ratdum(irfeap) * (1.0d0-ratdum(iry1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ife52) = xsum(ife52) + a1 * bion(ife52) c..d(fe52)/d(ni56) a1 = ratdum(irniga) 1 + ratdum(iry1) * ratdum(irnigp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ini56) = xsum(ini56) + a1 * bion(ife52) c..ni56 jacobian elements c..d(ni56)/d(h1) a1 = y(is30)*ratdum(iralam2)*(1.0d0 - ratdum(irdelta2)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ih1) = xsum(ih1) + a1 * bion(ini56) c..d(ni56)/d(he4) a1 = y(ife52) * ratdum(irfeag) 5 + y(ife52) * ratdum(irfeap) * (1.0d0-ratdum(iry1)) 6 + y(is30)*ratdum(iralam2)*ratdum(irdelta2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ihe4) = xsum(ihe4) + a1 * bion(ini56) c..d(ni56)/d(s30) a1 = y(ih1)*ratdum(iralam2)*(1.0d0 - ratdum(irdelta2)) 1 + y(ihe4)*ratdum(iralam2)*ratdum(irdelta2) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(is30) = xsum(is30) + a1 * bion(ini56) c..d(ni56)/d(fe52) a1 = y(ihe4) * ratdum(irfeag) 1 + y(ihe4) * ratdum(irfeap) * (1.0d0-ratdum(iry1)) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ife52) = xsum(ife52) + a1 * bion(ini56) c..d(ni56)/d(ni56) a1 = -ratdum(irniga) 1 - ratdum(iry1) * ratdum(irnigp) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 xsum(ini56) = xsum(ini56) + a1 * bion(ini56) c..if we are doing a pure network, we are done if (pure_network .eq. 1) goto 678 c..append the temperature derivatives of the rate equations call rhs(y,dratdumdt,zwork1,deriva) c..d(yi)/dtemp do i=1,ionmax nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + zwork1(i) enddo c..append the density derivatives of the rate equations call rhs(y,dratdumdd,zwork2,deriva) c..d(yi)/d(den) do i=1,ionmax nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + zwork2(i) enddo c..energy jacobian elements c..d(iener)/d(ixx) do i=1,ionmax a1 = xsum(i) * conv nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 enddo c..d(iener)/d(iener) a1 = 0.0d0 nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..d(iener)/d(temp) a1 = 0.0d0 do i=1,ionmax a1 = a1 + zwork1(i)*bion(i) enddo a1 = a1 * conv nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 dsdotdt = dfdy(iat) c..d(iener)/d(den) a1 = 0.0d0 do i=1,ionmax a1 = a1 + zwork2(i)*bion(i) enddo a1 = a1 * conv nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 dsdotdd = dfdy(iat) c..account for the neutrino losses call sneut5(btemp,bden,abar,zbar, 1 sneut,dsneutdt,dsneutdd,snuda,snudz) c..d(ener)/d(yi) do i=1,ionmax a1 = -(-abar*abar*snuda + (zion(i) - zbar)*abar*snudz) nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 enddo c..d(iener)/d(temp) a1 = -dsneutdt nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..d(iener)/d(den) a1 = -dsneutdd nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..the temperature and density equation jacobian elements c..depend on the burning mode c..hydrostatic if (hydrostatic .or. one_step .or. trho_hist) then c..d(itemp)/d(itemp) a1 = 0.0d0 nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..d(iden)/d(iden) a1 = 0.0d0 nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..adiabatic expansion else if (expansion) then taud = 446.0d0/sqrt(den0) taut = 3.0d0 * taud c..d(itemp)/d(itemp) a1 = -psi/taut nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..d(iden)/d(iden) a1 = -psi/taud nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..self heating else if (self_heat_const_den) then c..call an eos temp_row(1) = btemp den_row(1) = bden abar_row(1) = abar zbar_row(1) = zbar jlo_eos = 1 jhi_eos = 1 call helmeos c..temperature jacobian elements c..d(itemp)/d(yi) zz = 1.0d0/cv_row(1) do i=1,ionmax a1 = zz * xsum(i) * conv nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 enddo c..d(itemp)/d(itemp) a1 = 0.0d0 do i=1,ionmax a1 = a1 + zwork1(i)*bion(i) enddo a1 = a1*conv a4 = (a1 - dsneutdt) * zz nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a4 c..d(itemp)/d(iden) a1 = 0.0d0 do i=1,ionmax a1 = a1 + zwork2(i)*bion(i) enddo a1 = a1*conv a4 = (a1 - dsneutdd) * zz nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a4 c..d(iden)/d(iden) a1 = 0.0d0 nt = nt + 1 iat = eloc(nt) dfdy(iat) = dfdy(iat) + a1 c..end of burning mode ifs end if c..bullet check the counting 678 if (nt .ne. nterms) then write(6,*) 'nt =',nt,' nterms =',nterms write(6,*) 'error in routine shhe: nt .ne. nterms' stop 'error in routine shhe' end if return end subroutine hherat(ye) include 'implno.dek' include 'burn_common.dek' include 'network.dek' c..this routine generates nuclear reaction rates for the hhe network. c..declare integer i double precision ye,rrate,drratedt,drratedd c..zero the rates do i=1,nrat ratraw(i) = 0.0d0 enddo do i=1,nrat dratrawdt(i) = 0.0d0 enddo do i=1,nrat dratrawdd(i) = 0.0d0 enddo if (btemp .lt. 1.0e6) return c..get the temperature factors call tfactors(btemp) c..p(p,e+nu)d call rate_pp(btemp,bden, 1 ratraw(irpp),dratrawdt(irpp),dratrawdd(irpp), 2 rrate,drratedt,drratedd) c..p(e-p,nu)d call rate_pep(btemp,bden,ye, 1 ratraw(irpep),dratrawdt(irpep),dratrawdd(irpep), 2 rrate,drratedt,drratedd) c..d(p,g)3he call rate_dpg(btemp,bden, 1 ratraw(irdpg),dratrawdt(irdpg),dratrawdd(irdpg), 2 rrate,drratedt,drratedd) c..he3(p,e+nu)he4 call rate_hep(btemp,bden, 1 ratraw(irhep),dratrawdt(irhep),dratrawdd(irhep), 2 rrate,drratedt,drratedd) c..he3(he3,2p)he4 call rate_he3he3(btemp,bden, 1 ratraw(ir33),dratrawdt(ir33),dratrawdd(ir33), 2 rrate,drratedt,drratedd) c..3he(4he,nu)7be call rate_he3he4(btemp,bden, 1 ratraw(irhe3ag),dratrawdt(irhe3ag),dratrawdd(irhe3ag), 2 rrate,drratedt,drratedd) c..7be(e-,nu)7li call rate_be7em(btemp,bden,ye, 1 ratraw(irbeec),dratrawdt(irbeec),dratrawdd(irbeec), 2 rrate,drratedt,drratedd) c..7be(p,g)8b call rate_be7pg(btemp,bden, 1 ratraw(irbepg),dratrawdt(irbepg),dratrawdd(irbepg), 1 ratraw(irb8gp),dratrawdt(irb8gp),dratrawdd(irb8gp)) c..8b(p=>n)8be=>2 he4 positron decay (half-life = 0.77 sec) call rate_b8ep(btemp,bden, 1 ratraw(irb8ep),dratrawdt(irb8ep),dratrawdd(irb8ep), 2 rrate,drratedt,drratedd) c..7li(p,g)8be => 2a and 7li(p,a)a call rate_li7pag(btemp,bden, 1 ratraw(irli7pa),dratrawdt(irli7pa),dratrawdd(irli7pa), 2 rrate,drratedt,drratedd) c..from hotcno c..12c(p,g)13n call rate_c12pg(btemp,bden, 1 ratraw(irc12pg),dratrawdt(irc12pg),dratrawdd(irc12pg), 2 ratraw(irn13gp),dratrawdt(irn13gp),dratrawdd(irn13gp)) c..13n(e+nu)13c call rate_n13em(btemp,bden, 1 ratraw(irn13enu),dratrawdt(irn13enu),dratrawdd(irn13enu), 2 rrate,drratedt,drratedd) c..13c(p,g)14n call rate_c13pg(btemp,bden, 1 ratraw(irc13pg),dratrawdt(irc13pg),dratrawdd(irc13pg), 2 ratraw(irn14gp),dratrawdt(irc13pg),dratrawdd(irn14gp)) c..14n(p,g)15o call rate_n14pg(btemp,bden, 1 ratraw(irn14pg),dratrawdt(irn14pg),dratrawdd(irn14pg), 2 ratraw(iro15gp),dratrawdt(irn14pg),dratrawdd(iro15gp)) c..15o(e+nu)15n call rate_o15em(btemp,bden, 1 ratraw(iro15enu),dratrawdt(iro15enu),dratrawdd(iro15enu), 2 rrate,drratedt,drratedd) c..15n(p,a)12c fcz3 call rate_n15pa(btemp,bden, 1 ratraw(irn15pa),dratrawdt(irn15pa),dratrawdd(irn15pa), 2 ratraw(irc12ap),dratrawdt(irc12ap),dratrawdd(irc12ap)) c..15n(p,g)16o call rate_n15pg(btemp,bden, 1 ratraw(irn15pg),dratrawdt(irn15pg),dratrawdd(irn15pg), 2 ratraw(iro16gp),dratrawdt(iro16gp),dratrawdd(iro16gp)) c..16o(p,g)17f call rate_o16pg(btemp,bden, 1 ratraw(iro16pg),dratrawdt(iro16pg),dratrawdd(iro16pg), 2 ratraw(irf17gp),dratrawdt(irf17gp),dratrawdd(irf17gp)) c..17f(e+nu)17o call rate_f17em(btemp,bden, 1 ratraw(irf17enu),dratrawdt(irf17enu),dratrawdd(irf17enu), 2 rrate,drratedt,drratedd) c..17o(p,a)14n call rate_o17pa(btemp,bden, 1 ratraw(iro17pa),dratrawdt(iro17pa),dratrawdd(iro17pa), 2 ratraw(irn14ap),dratrawdt(irn14ap),dratrawdd(irn14ap)) c..17o(p,g)18f call rate_o17pg(btemp,bden, 1 ratraw(iro17pg),dratrawdt(iro17pg),dratrawdd(iro17pg), 2 ratraw(irf18gp),dratrawdt(irf18gp),dratrawdd(irf18gp)) c..18f(e+nu)18o call rate_f18em(btemp,bden, 1 ratraw(irf18enu),dratrawdt(irf18enu),dratrawdd(irf18enu), 2 rrate,drratedt,drratedd) c..18o(p,a)15n call rate_o18pa(btemp,bden, 1 ratraw(iro18pa),dratrawdt(iro18pa),dratrawdd(iro18pa), 2 ratraw(irn15ap),dratrawdt(irn15ap),dratrawdd(irn15ap)) c..18o(p,g)19f call rate_o18pg(btemp,bden, 1 ratraw(iro18pg),dratrawdt(iro18pg),dratrawdd(iro18pg), 2 ratraw(irf19gp),dratrawdt(irf19gp),dratrawdd(irf19gp)) c..19f(p,a)16o call rate_f19pa(btemp,bden, 1 ratraw(irf19pa),dratrawdt(irf19pa),dratrawdd(irf19pa), 2 ratraw(iro16ap),dratrawdt(iro16ap),dratrawdd(iro16ap)) c..add these for the hot cno cycles c..13n(p,g)14o call rate_n13pg(btemp,bden, 1 ratraw(irn13pg),dratrawdt(irn13pg),dratrawdd(irn13pg), 2 ratraw(iro14gp),dratrawdt(iro14gp),dratrawdd(iro14gp)) c..14o(e+nu)14n call rate_o14em(btemp,bden, 1 ratraw(iro14enu),dratrawdt(iro14enu),dratrawdd(iro14enu), 2 rrate,drratedt,drratedd) c..14o(a,p)17f cf88 q = 1.191 call rate_o14ap(btemp,bden, 1 ratraw(iro14ap),dratrawdt(iro14ap),dratrawdd(iro14ap), 2 ratraw(irf17pa),dratrawdt(irf17pa),dratrawdd(irf17pa)) c..17f(p,g)18ne call rate_f17pg(btemp,bden, 1 ratraw(irf17pg),dratrawdt(irf17pg),dratrawdd(irf17pg), 2 ratraw(irne18gp),dratrawdt(irne18gp),dratrawdd(irne18gp)) c..18ne(e+nu)18f call rate_ne18em(btemp,bden, 1 ratraw(irne18enu),dratrawdt(irne18enu),dratrawdd(irne18enu), 2 rrate,drratedt,drratedd) c..18f(p,a)15o call rate_f18pa(btemp,bden, 1 ratraw(irf18pa),dratrawdt(irf18pa),dratrawdd(irf18pa), 2 ratraw(iro15ap),dratrawdt(iro15ap),dratrawdd(iro15ap)) c..triple alpha to c12 call rate_tripalf(btemp,bden, 1 ratraw(ir3a),dratrawdt(ir3a),dratrawdd(ir3a), 2 ratraw(irg3a),dratrawdt(irg3a),dratrawdd(irg3a)) c..18ne(a,p)21na call rate_ne18ap(btemp,bden, 1 ratraw(irne18ap),dratrawdt(irne18ap),dratrawdd(irne18ap), 2 rrate,drratedt,drratedd) c..19ne(p,g)20na call rate_ne19pg(btemp,bden, 1 ratraw(irne19pg),dratrawdt(irne19pg),dratrawdd(irne19pg), 2 rrate,drratedt,drratedd) c..15o(a,g)19ne call rate_o15ag(btemp,bden, 1 ratraw(iro15ag),dratrawdt(iro15ag),dratrawdd(iro15ag), 2 rrate,drratedt,drratedd) c..44ti(a,p)47v call rate_ti44ap(btemp,bden, 1 ratraw(irtiap),dratrawdt(irtiap),dratrawdd(irtiap), 2 rrate,drratedt,drratedd) c g47v=1.0+exp(-1.206*t9m1+1.059+9.997d-2*t9) c ratraw(irtiap) = ratraw(irtiap)*g47v c..26si(a,p)29p call rate_si26ap(btemp,bden, 1 ratraw(irsi26ap),dratrawdt(irsi26ap),dratrawdd(irsi26ap), 2 rrate,drratedt,drratedd) c..19ne(e+nu)19f call rate_ne19em(btemp,bden, 1 ratraw(irne19enu),dratrawdt(irne19enu),dratrawdd(irne19enu), 2 rrate,drratedt,drratedd) c..20ne(p,g)21na call rate_ne20pg(btemp,bden, 1 ratraw(irne20pg),dratrawdt(irne20pg),dratrawdd(irne20pg), 2 rrate,drratedt,drratedd) c..c12(a,g)o16 call rate_c12ag(btemp,bden, 1 ratraw(ircag),dratrawdt(ircag),dratrawdd(ircag), 2 ratraw(iroga),dratrawdt(iroga),dratrawdd(iroga)) c..o16(a,g)ne20 call rate_o16ag(btemp,bden, 1 ratraw(iroag),dratrawdt(iroag),dratrawdd(iroag), 2 ratraw(irnega),dratrawdt(irnega),dratrawdd(irnega)) c..ne20(a,g)mg24 call rate_ne20ag(btemp,bden, 1 ratraw(irneag),dratrawdt(irneag),dratrawdd(irneag), 2 ratraw(irmgga),dratrawdt(irmgga),dratrawdd(irmgga)) c..mg24(a,g)si28 call rate_mg24ag(btemp,bden, 1 ratraw(irmgag),dratrawdt(irmgag),dratrawdd(irmgag), 2 ratraw(irsiga),dratrawdt(irsiga),dratrawdd(irsiga)) c..mg24(a,p)al27 call rate_mg24ap(btemp,bden, 1 ratraw(irmgap),dratrawdt(irmgap),dratrawdd(irmgap), 2 ratraw(iralpa),dratrawdt(iralpa),dratrawdd(iralpa)) c..al27(p,g)si28 call rate_al27pg(btemp,bden, 1 ratraw(iralpg),dratrawdt(iralpg),dratrawdd(iralpg), 2 ratraw(irsigp),dratrawdt(irsigp),dratrawdd(irsigp)) c..si28(a,g)s32 call rate_si28ag(btemp,bden, 1 ratraw(irsiag),dratrawdt(irsiag),dratrawdd(irsiag), 2 ratraw(irsga),dratrawdt(irsga),dratrawdd(irsga)) c..si28(a,p)p31 call rate_si28ap(btemp,bden, 1 ratraw(irsiap),dratrawdt(irsiap),dratrawdd(irsiap), 2 ratraw(irppa),dratrawdt(irppa),dratrawdd(irppa)) c..p31(p,g)s32 call rate_p31pg(btemp,bden, 1 ratraw(irppg),dratrawdt(irppg),dratrawdd(irppg), 2 ratraw(irsgp),dratrawdt(irsgp),dratrawdd(irsgp)) c..s32(a,g)ar36 call rate_s32ag(btemp,bden, 1 ratraw(irsag),dratrawdt(irsag),dratrawdd(irsag), 2 ratraw(irarga),dratrawdt(irarga),dratrawdd(irarga)) c..s32(a,p)cl35 call rate_s32ap(btemp,bden, 1 ratraw(irsap),dratrawdt(irsap),dratrawdd(irsap), 2 ratraw(irclpa),dratrawdt(irclpa),dratrawdd(irclpa)) c..cl35(p,g)ar36 call rate_cl35pg(btemp,bden, 1 ratraw(irclpg),dratrawdt(irclpg),dratrawdd(irclpg), 2 ratraw(irargp),dratrawdt(irargp),dratrawdd(irargp)) c..ar36(a,g)ca40 call rate_ar36ag(btemp,bden, 1 ratraw(irarag),dratrawdt(irarag),dratrawdd(irarag), 2 ratraw(ircaga),dratrawdt(ircaga),dratrawdd(ircaga)) c..ar36(a,p)k39 call rate_ar36ap(btemp,bden, 1 ratraw(irarap),dratrawdt(irarap),dratrawdd(irarap), 2 ratraw(irkpa),dratrawdt(irkpa),dratrawdd(irkpa)) c..k39(p,g)ca40 call rate_k39pg(btemp,bden, 1 ratraw(irkpg),dratrawdt(irkpg),dratrawdd(irkpg), 2 ratraw(ircagp),dratrawdt(ircagp),dratrawdd(ircagp)) c..ca40(a,g)ti44 call rate_ca40ag(btemp,bden, 1 ratraw(ircaag),dratrawdt(ircaag),dratrawdd(ircaag), 2 ratraw(irtiga),dratrawdt(irtiga),dratrawdd(irtiga)) c..ca40(a,p)sc43 call rate_ca40ap(btemp,bden, 1 ratraw(ircaap),dratrawdt(ircaap),dratrawdd(ircaap), 2 ratraw(irscpa),dratrawdt(irscpa),dratrawdd(irscpa)) c..sc43(p,g)ti44 call rate_sc43pg(btemp,bden, 1 ratraw(irscpg),dratrawdt(irscpg),dratrawdd(irscpg), 2 ratraw(irtigp),dratrawdt(irtigp),dratrawdd(irtigp)) c..ti44(a,g)cr48 call rate_ti44ag(btemp,bden, 1 ratraw(irtiag),dratrawdt(irtiag),dratrawdd(irtiag), 2 ratraw(ircrga),dratrawdt(ircrga),dratrawdd(ircrga)) c..ti44(a,p)v47 call rate_ti44ap(btemp,bden, 1 ratraw(irtiap),dratrawdt(irtiap),dratrawdd(irtiap), 2 ratraw(irvpa),dratrawdt(irvpa),dratrawdd(irvpa)) c..v47(p,g)cr48 call rate_v47pg(btemp,bden, 1 ratraw(irvpg),dratrawdt(irvpg),dratrawdd(irvpg), 2 ratraw(ircrgp),dratrawdt(ircrgp),dratrawdd(ircrgp)) c..cr48(a,g)fe52 call rate_cr48ag(btemp,bden, 1 ratraw(ircrag),dratrawdt(ircrag),dratrawdd(ircrag), 2 ratraw(irfega),dratrawdt(irfega),dratrawdd(irfega)) c..cr48(a,p)mn51 call rate_cr48ap(btemp,bden, 1 ratraw(ircrap),dratrawdt(ircrap),dratrawdd(ircrap), 2 ratraw(irmnpa),dratrawdt(irmnpa),dratrawdd(irmnpa)) c..mn51(p,g)fe52 call rate_mn51pg(btemp,bden, 1 ratraw(irmnpg),dratrawdt(irmnpg),dratrawdd(irmnpg), 2 ratraw(irfegp),dratrawdt(irfegp),dratrawdd(irfegp)) c..fe52(a,g)ni56 call rate_fe52ag(btemp,bden, 1 ratraw(irfeag),dratrawdt(irfeag),dratrawdd(irfeag), 2 ratraw(irniga),dratrawdt(irniga),dratrawdd(irniga)) c..fe52(a,p)co55 call rate_fe52ap(btemp,bden, 1 ratraw(irfeap),dratrawdt(irfeap),dratrawdd(irfeap), 2 ratraw(ircopa),dratrawdt(ircopa),dratrawdd(ircopa)) c..co55(p,g)ni56 call rate_co55pg(btemp,bden, 1 ratraw(ircopg),dratrawdt(ircopg),dratrawdd(ircopg), 2 ratraw(irnigp),dratrawdt(irnigp),dratrawdd(irnigp)) c..c12 + c12 call rate_c12c12(btemp,bden, 1 ratraw(ir1212),dratrawdt(ir1212),dratrawdd(ir1212), 2 rrate,drratedt,drratedd) c..c12 + o16 call rate_c12o16(btemp,bden, 1 ratraw(ir1216),dratrawdt(ir1216),dratrawdd(ir1216), 2 rrate,drratedt,drratedd) c..o16 + o16 call rate_o16o16(btemp,bden, 1 ratraw(ir1616),dratrawdt(ir1616),dratrawdd(ir1616), 2 rrate,drratedt,drratedd) return end subroutine hhetab(ye) include 'implno.dek' include 'burn_common.dek' include 'network.dek' c..uses tables instead of analytical expressions to evaluate the c..raw reaction rates. a cubic polynomial is hardwired for speed. integer i,j,imax,iat,mp,ifirst parameter (mp = 4) double precision ye,tlo,thi,tstp,bden_sav,btemp_sav,ye_sav, 1 x,x1,x2,x3,x4,a,b,c,d,e,f,g,h,p,q, 2 alfa,beta,gama,delt data ifirst/0/ c..make the table if (ifirst .eq. 0) then ifirst = 1 c..set the log temperature loop limits thi = 10.0d0 tlo = 6.0d0 imax = int(thi-tlo)*120 + 1 if (imax .gt. nrattab) stop 'imax too small in hhetab' tstp = (thi - tlo)/float(imax-1) c..save the input btemp_sav = btemp bden_sav = bden ye_sav = ye c..form the table bden = 1.0d0 ye = 1.0d0 do i=1,imax btemp = tlo + float(i-1)*tstp btemp = 10.0d0**(btemp) call hherat(ye) ttab(i) = btemp do j=1,nrat rattab(j,i) = ratraw(j) drattabdt(j,i) = dratrawdt(j) drattabdd(j,i) = dratrawdd(j) enddo enddo c..restore the input bden = bden_sav btemp = btemp_sav ye = ye_sav end if c..normal execution starts here c..set the density dependence vector dtab(irpp) = bden dtab(irdpg) = bden dtab(ir33) = bden dtab(irhe3ag) = bden dtab(irbeec) = bden*ye dtab(irbepg) = bden dtab(irb8gp) = 1.0d0 dtab(irb8ep) = 1.0d0 dtab(irli7pa) = bden dtab(irpep) = ye*bden*bden dtab(irhep) = bden dtab(irc12pg) = bden dtab(irn13gp) = 1.0d0 dtab(irn13enu) = 1.0d0 dtab(irc13pg) = bden dtab(irn14gp) = 1.0d0 dtab(irn14pg) = bden dtab(iro15gp) = 1.0d0 dtab(iro15enu) = 1.0d0 dtab(irn15pa) = bden dtab(irc12ap) = bden dtab(irn15pg) = bden dtab(iro16gp) = 1.0d0 dtab(iro16pg) = bden dtab(irf17gp) = 1.0d0 dtab(irf17enu) = 1.0d0 dtab(iro17pa) = bden dtab(irn14ap) = bden dtab(iro17pg) = bden dtab(irf18gp) = 1.0d0 dtab(irf18enu) = 1.0d0 dtab(iro18pa) = bden dtab(irn15ap) = bden dtab(iro18pg) = bden dtab(irf19gp) = 1.0d0 dtab(irf19pa) = bden dtab(iro16ap) = bden dtab(irn13pg) = bden dtab(iro14gp) = 1.0d0 dtab(iro14enu) = 1.0d0 dtab(iro14ap) = bden dtab(irf17pa) = bden dtab(irf17pg) = bden dtab(irne18gp) = 1.0d0 dtab(irne18enu)= 1.0d0 dtab(irf18pa) = bden dtab(iro15ap) = bden dtab(ir3a) = bden*bden dtab(irg3a) = 1.0d0 dtab(irne18ap) = bden dtab(irne19pg) = bden dtab(iro15ag) = bden dtab(irtiap) = bden dtab(irsi26ap) = bden dtab(irne19enu)= 1.0d0 dtab(irne20pg) = bden dtab(ircag) = bden dtab(iroga) = 1.0d0 dtab(iroag) = bden dtab(irnega) = 1.0d0 dtab(irneag) = bden dtab(irmgga) = 1.0d0 dtab(irmgag) = bden dtab(irsiga) = 1.0d0 dtab(irmgap) = bden dtab(iralpa) = bden dtab(iralpg) = bden dtab(irsigp) = 1.0d0 dtab(irsiag) = bden dtab(irsga) = 1.0d0 dtab(irppa) = bden dtab(irsiap) = bden dtab(irppg) = bden dtab(irsgp) = 1.0d0 dtab(irsag) = bden dtab(irarga) = 1.0d0 dtab(irsap) = bden dtab(irclpa) = bden dtab(irclpg) = bden dtab(irargp) = 1.0d0 dtab(irarag) = bden dtab(ircaga) = 1.0d0 dtab(irarap) = bden dtab(irkpa) = bden dtab(irkpg) = bden dtab(ircagp) = 1.0d0 dtab(ircaag) = bden dtab(irtiga) = 1.0d0 dtab(ircaap) = bden dtab(irscpa) = bden dtab(irscpg) = bden dtab(irtigp) = 1.0d0 dtab(irtiag) = bden dtab(ircrga) = 1.0d0 dtab(irtiap) = bden dtab(irvpa) = bden dtab(irvpg) = bden dtab(ircrgp) = 1.0d0 dtab(ircrag) = bden dtab(irfega) = 1.0d0 dtab(ircrap) = bden dtab(irmnpa) = bden dtab(irmnpg) = bden dtab(irfegp) = 1.0d0 dtab(irfeag) = bden dtab(irniga) = 1.0d0 dtab(irfeap) = bden dtab(ircopa) = bden dtab(ircopg) = bden dtab(irnigp) = 1.0d0 dtab(ir1212) = bden dtab(ir1216) = bden dtab(ir1616) = bden c..hash locate the temperature iat = int((log10(btemp) - tlo)/tstp) + 1 iat = max(1,min(iat - mp/2 + 1,imax - mp + 1)) c..setup the lagrange interpolation coefficients for a cubic x = btemp x1 = ttab(iat) x2 = ttab(iat+1) x3 = ttab(iat+2) x4 = ttab(iat+3) a = x - x1 b = x - x2 c = x - x3 d = x - x4 e = x1 - x2 f = x1 - x3 g = x1 - x4 h = x2 - x3 p = x2 - x4 q = x3 - x4 alfa = b*c*d/(e*f*g) beta = -a*c*d/(e*h*p) gama = a*b*d/(f*h*q) delt = -a*b*c/(g*p*q) c..crank off the raw reaction rates do j=1,nrat ratraw(j) = (alfa*rattab(j,iat) 1 + beta*rattab(j,iat+1) 2 + gama*rattab(j,iat+2) 3 + delt*rattab(j,iat+3) 4 ) * dtab(j) dratrawdt(j) = (alfa*drattabdt(j,iat) 1 + beta*drattabdt(j,iat+1) 2 + gama*drattabdt(j,iat+2) 3 + delt*drattabdt(j,iat+3) 4 ) * dtab(j) dratrawdd(j) = alfa*drattabdd(j,iat) 1 + beta*drattabdd(j,iat+1) 2 + gama*drattabdd(j,iat+2) 3 + delt*drattabdd(j,iat+3) enddo c..hand finish the three body and weak reactions dratrawdd(ir3a) = bden * dratrawdd(ir3a) dratrawdd(irbeec) = ye * dratrawdd(irbeec) dratrawdd(irpep) = ye * bden * dratrawdd(irpep) return end subroutine screen_hhe(y) include 'implno.dek' include 'burn_common.dek' include 'network.dek' c..this routine computes the screening factors c..and applies them to the raw reaction rates, c..producing the final reaction rates used by the c..right hand sides and jacobian matrix elements c..this routine assumes screen_on = 1 or = 0 has been set at a higer level, c..presumably in the top level driver c..declare integer i,jscr double precision y(*),sc1a,sc1adt,sc1add,sc2a,sc2adt,sc2add, 1 sc3a,sc3adt,sc3add, 2 abar,zbar,z2bar,ytot1,zbarxx,z2barxx, 3 wp22mg,wp30s,alamt,denom,denomdd,denomdt,zz integer init data init/1/ c..initialize do i=1,nrat ratdum(i) = ratraw(i) dratdumdt(i) = dratrawdt(i) dratdumdd(i) = dratrawdd(i) scfac(i) = 1.0d0 dscfacdt(i) = 0.0d0 dscfacdt(i) = 0.0d0 end do c..debugs c write(6,*) 'before screening' c do i=1,nrat c write(6,111) i,ratnam(i),ratdum(i),dratdumdt(i),dratdumdd(i) c 111 format(1x,i4,' ',a,' ',1p3e12.4) c enddo c read(5,*) c..if screening is on if (screen_on .ne. 0) then c..with the passed composition, compute abar,zbar and other variables zbarxx = 0.0d0 z2barxx = 0.0d0 ytot1 = 0.0d0 do i=1,ionmax ytot1 = ytot1 + y(i) zbarxx = zbarxx + zion(i) * y(i) z2barxx = z2barxx + zion(i) * zion(i) * y(i) enddo abar = 1.0d0/ytot1 zbar = zbarxx * abar z2bar = z2barxx * abar c..pp jscr = 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ih1),aion(ih1),zion(ih1),aion(ih1), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irpp) = ratraw(irpp) * sc1a dratdumdt(irpp) = dratrawdt(irpp)*sc1a+ratraw(irpp)*sc1adt dratdumdd(irpp) = dratrawdd(irpp)*sc1a+ratraw(irpp)*sc1add scfac(irpp) = sc1a dscfacdt(irpp) = sc1adt dscfacdt(irpp) = sc1add ratdum(irpep) = ratraw(irpep) * sc1a dratdumdt(irpep) = dratrawdt(irpep)*sc1a + ratraw(irpep)*sc1adt dratdumdd(irpep) = dratrawdd(irpep)*sc1a + ratraw(irpep)*sc1add scfac(irpep) = sc1a dscfacdt(irpep) = sc1adt dscfacdd(irpep) = sc1add c..d + p jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ih2),aion(ih2),zion(ih1),aion(ih1), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irdpg) = ratraw(irdpg) * sc1a dratdumdt(irdpg)= dratrawdt(irdpg)*sc1a+ratraw(irdpg)*sc1adt dratdumdd(irdpg)= dratrawdd(irdpg)*sc1a+ratraw(irdpg)*sc1add scfac(irdpg) = sc1a dscfacdt(irdpg) = sc1adt dscfacdt(irdpg) = sc1add c..he3 + p jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ihe3),aion(ihe3),zion(ih1),aion(ih1), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irhep) = ratraw(irhep) * sc1a dratdumdt(irhep) = dratrawdt(irhep)*sc1a + ratraw(irhep)*sc1adt dratdumdd(irhep) = dratrawdd(irhep)*sc1a + ratraw(irhep)*sc1add scfac(irhep) = sc1a dscfacdt(irhep) = sc1adt dscfacdd(irhep) = sc1add c..he3 + he3 jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ihe3),aion(ihe3),zion(ihe3),aion(ihe3), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(ir33) = ratraw(ir33) * sc1a dratdumdt(ir33) = dratrawdt(ir33)*sc1a+ratraw(ir33)*sc1adt dratdumdd(ir33) = dratrawdd(ir33)*sc1a+ratraw(ir33)*sc1add scfac(ir33) = sc1a dscfacdt(ir33) = sc1adt dscfacdt(ir33) = sc1add c..he3 + he4 jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ihe3),aion(ihe3),zion(ihe4),aion(ihe4), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irhe3ag) = ratraw(irhe3ag) * sc1a dratdumdt(irhe3ag) = dratrawdt(irhe3ag)*sc1a 1 + ratraw(irhe3ag)*sc1adt dratdumdd(irhe3ag) = dratrawdd(irhe3ag)*sc1a 1 + ratraw(irhe3ag)*sc1add scfac(irhe3ag) = sc1a dscfacdt(irhe3ag) = sc1adt dscfacdt(irhe3ag) = sc1add c..be7 + p and inverse jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ibe7),aion(ibe7),zion(ih1),aion(ih1), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irbepg) = ratraw(irbepg) * sc1a dratdumdt(irbepg)= dratrawdt(irbepg)*sc1a+ratraw(irbepg)*sc1adt dratdumdd(irbepg)= dratrawdd(irbepg)*sc1a+ratraw(irbepg)*sc1add scfac(irbepg) = sc1a dscfacdt(irbepg) = sc1adt dscfacdt(irbepg) = sc1add c..li7 + p jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ili7),aion(ili7),zion(ih1),aion(ih1), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irli7pa) = ratraw(irli7pa) * sc1a dratdumdt(irli7pa)= dratrawdt(irli7pa)*sc1a+ratraw(irli7pa)*sc1adt dratdumdd(irli7pa)= dratrawdd(irli7pa)*sc1a+ratraw(irli7pa)*sc1add scfac(irli7pa) = sc1a dscfacdt(irli7pa)= sc1adt dscfacdt(irli7pa)= sc1add c..hot cno contributions c..c12 + p jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ic12),aion(ic12),zion(ih1),aion(ih1), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irc12pg) = ratraw(irc12pg) * sc1a dratdumdt(irc12pg) =dratrawdt(irc12pg)*sc1a+ratraw(irc12pg)*sc1adt dratdumdd(irc12pg) =dratrawdd(irc12pg)*sc1a+ratraw(irc12pg)*sc1add scfac(irc12pg) = sc1a dscfacdt(irc12pg) = sc1adt dscfacdd(irc12pg) = sc1add c..c13 + p jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ic13),aion(ic13),zion(ih1),aion(ih1), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irc13pg) = ratraw(irc13pg) * sc1a dratdumdt(irc13pg) =dratrawdt(irc13pg)*sc1a+ratraw(irc13pg)*sc1adt dratdumdd(irc13pg) =dratrawdd(irc13pg)*sc1a+ratraw(irc13pg)*sc1add scfac(irc13pg) = sc1a dscfacdt(irc13pg) = sc1adt dscfacdd(irc13pg) = sc1add c..n14 + p jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(in14),aion(in14),zion(ih1),aion(ih1), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irn14pg) = ratraw(irn14pg) * sc1a dratdumdt(irn14pg) =dratrawdt(irn14pg)*sc1a+ratraw(irn14pg)*sc1adt dratdumdd(irn14pg) =dratrawdd(irn14pg)*sc1a+ratraw(irn14pg)*sc1add scfac(irn14pg) = sc1a dscfacdt(irn14pg) = sc1adt dscfacdd(irn14pg) = sc1add c..n15 + p jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(in15),aion(in15),zion(ih1),aion(ih1), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irn15pg) = ratraw(irn15pg) * sc1a dratdumdt(irn15pg) =dratrawdt(irn15pg)*sc1a+ratraw(irn15pg)*sc1adt dratdumdd(irn15pg) =dratrawdd(irn15pg)*sc1a+ratraw(irn15pg)*sc1add scfac(irn15pg) = sc1a dscfacdt(irn15pg) = sc1adt dscfacdd(irn15pg) = sc1add ratdum(irn15pa) = ratraw(irn15pa) * sc1a dratdumdt(irn15pa) =dratrawdt(irn15pa)*sc1a+ratraw(irn15pa)*sc1adt dratdumdd(irn15pa) =dratrawdd(irn15pa)*sc1a+ratraw(irn15pa)*sc1adt scfac(irn15pa) = sc1a dscfacdt(irn15pa) = sc1adt dscfacdd(irn15pa) = sc1add c..c12 + a jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ic12),aion(ic12),zion(ihe4),aion(ihe4), 2 jscr,init,sc1a,sc1add,sc1add) ratdum(irc12ap) = ratraw(irc12ap) * sc1a dratdumdt(irc12ap) =dratrawdt(irc12ap)*sc1a+ratraw(irc12ap)*sc1adt dratdumdd(irc12ap) =dratrawdd(irc12ap)*sc1a+ratraw(irc12ap)*sc1add scfac(irc12ap) = sc1a dscfacdt(irc12ap) = sc1adt dscfacdd(irc12ap) = sc1add ratdum(ircag) = ratraw(ircag) * sc1a dratdumdt(ircag) = dratrawdt(ircag)*sc1a + ratraw(ircag)*sc1adt dratdumdd(ircag) = dratrawdd(ircag)*sc1a + ratraw(ircag)*sc1add scfac(ircag) = sc1a dscfacdt(ircag) = sc1adt dscfacdt(ircag) = sc1add c..o16 + p jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(io16),aion(io16),zion(ih1),aion(ih1), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(iro16pg) = ratraw(iro16pg) * sc1a dratdumdt(iro16pg) =dratrawdt(iro16pg)*sc1a+ratraw(iro16pg)*sc1adt dratdumdd(iro16pg) =dratrawdd(iro16pg)*sc1a+ratraw(iro16pg)*sc1add scfac(iro16pg) = sc1a dscfacdt(iro16pg) = sc1adt dscfacdd(iro16pg) = sc1add c..o17 + p jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(io17),aion(io17),zion(ih1),aion(ih1), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(iro17pg) = ratraw(iro17pg) * sc1a dratdumdt(iro17pg) =dratrawdt(iro17pg)*sc1a+ratraw(iro17pg)*sc1adt dratdumdd(iro17pg) =dratrawdd(iro17pg)*sc1a+ratraw(iro17pg)*sc1add scfac(iro17pg) = sc1a dscfacdt(iro17pg) = sc1adt dscfacdd(iro17pg) = sc1add ratdum(iro17pa) = ratraw(iro17pa) * sc1a dratdumdt(iro17pa) =dratrawdt(iro17pa)*sc1a+ratraw(iro17pa)*sc1adt dratdumdd(iro17pa) =dratrawdd(iro17pa)*sc1a+ratraw(iro17pa)*sc1add scfac(iro17pa) = sc1a dscfacdt(iro17pa) = sc1adt dscfacdd(iro17pa) = sc1add c..n14 + a jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(in14),aion(in14),zion(ihe4),aion(ihe4), 2 jscr,init,sc1a,sc1add,sc1add) ratdum(irn14ap) = ratraw(irn14ap) * sc1a dratdumdt(irn14ap) =dratrawdt(irn14ap)*sc1a+ratraw(irn14ap)*sc1adt dratdumdd(irn14ap) =dratrawdd(irn14ap)*sc1a+ratraw(irn14ap)*sc1add scfac(irn14ap) = sc1a dscfacdt(irn14ap) = sc1adt dscfacdd(irn14ap) = sc1add c..o18 + p jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(io18),aion(io18),zion(ih1),aion(ih1), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(iro18pg) = ratraw(iro18pg) * sc1a dratdumdt(iro18pg) =dratrawdt(iro18pg)*sc1a+ratraw(iro18pg)*sc1adt dratdumdd(iro18pg) =dratrawdd(iro18pg)*sc1a+ratraw(iro18pg)*sc1add scfac(iro18pg) = sc1a dscfacdt(iro18pg) = sc1adt dscfacdd(iro18pg) = sc1add ratdum(iro18pa) = ratraw(iro18pa) * sc1a dratdumdt(iro18pa) =dratrawdt(iro18pa)*sc1a+ratraw(iro18pa)*sc1adt dratdumdd(iro18pa) =dratrawdd(iro18pa)*sc1a+ratraw(iro18pa)*sc1add scfac(iro18pa) = sc1a dscfacdt(iro18pa) = sc1adt dscfacdd(iro18pa) = sc1add c..n15 + a jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(in15),aion(in15),zion(ihe4),aion(ihe4), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irn15ap) = ratraw(irn15ap) * sc1a dratdumdt(irn15ap) =dratrawdt(irn15ap)*sc1a+ratraw(irn15ap)*sc1adt dratdumdd(irn15ap) =dratrawdd(irn15ap)*sc1a+ratraw(irn15ap)*sc1add scfac(irn15ap) = sc1a dscfacdt(irn15ap) = sc1adt dscfacdd(irn15ap) = sc1add c..f19 + p jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(if19),aion(if19),zion(ih1),aion(ih1), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irf19pa) = ratraw(irf19pa) * sc1a dratdumdt(irf19pa) =dratrawdt(irf19pa)*sc1a+ratraw(irf19pa)*sc1adt dratdumdd(irf19pa) =dratrawdd(irf19pa)*sc1a+ratraw(irf19pa)*sc1add scfac(irf19pa) = sc1a dscfacdt(irf19pa) = sc1adt dscfacdd(irf19pa) = sc1add c..o16 + a jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(io16),aion(io16),zion(ihe4),aion(ihe4), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(iro16ap) = ratraw(iro16ap) * sc1a dratdumdt(iro16ap) =dratrawdt(iro16ap)*sc1a+ratraw(iro16ap)*sc1adt dratdumdd(iro16ap) =dratrawdd(iro16ap)*sc1a+ratraw(iro16ap)*sc1add scfac(iro16ap) = sc1a dscfacdt(iro16ap) = sc1adt dscfacdd(iro16ap) = sc1add c..n13 + p jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(in13),aion(in13),zion(ih1),aion(ih1), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irn13pg) = ratraw(irn13pg) * sc1a dratdumdt(irn13pg) =dratrawdt(irn13pg)*sc1a+ratraw(irn13pg)*sc1adt dratdumdd(irn13pg) =dratrawdd(irn13pg)*sc1a+ratraw(irn13pg)*sc1add scfac(irn13pg) = sc1a dscfacdt(irn13pg) = sc1adt dscfacdd(irn13pg) = sc1add c..f17 + p jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(if17),aion(if17),zion(ih1),aion(ih1), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irf17pg) = ratraw(irf17pg) * sc1a dratdumdt(irf17pg) =dratrawdt(irf17pg)*sc1a+ratraw(irf17pg)*sc1adt dratdumdd(irf17pg) =dratrawdd(irf17pg)*sc1a+ratraw(irf17pg)*sc1add scfac(irf17pg) = sc1a dscfacdt(irf17pg) = sc1adt dscfacdd(irf17pg) = sc1add ratdum(irf17pa) = ratraw(irf17pa) * sc1a dratdumdt(irf17pa) =dratrawdt(irf17pa)*sc1a+ratraw(irf17pa)*sc1adt dratdumdd(irf17pa) =dratrawdd(irf17pa)*sc1a+ratraw(irf17pa)*sc1add scfac(irf17pa) = sc1a dscfacdt(irf17pa) = sc1adt dscfacdd(irf17pa) = sc1add c..o14 + a jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(io14),aion(io14),zion(ihe4),aion(ihe4), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(iro14ap) = ratraw(iro14ap) * sc1a dratdumdt(iro14ap) =dratrawdt(iro14ap)*sc1a+ratraw(iro14ap)*sc1adt dratdumdd(iro14ap) =dratrawdd(iro14ap)*sc1a+ratraw(iro14ap)*sc1add scfac(iro14ap) = sc1a dscfacdt(iro14ap) = sc1adt dscfacdd(iro14ap) = sc1add c..f18 + p jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(if18),aion(if18),zion(ih1),aion(ih1), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irf18pa) = ratraw(irf18pa) * sc1a dratdumdt(irf18pa) =dratrawdt(irf18pa)*sc1a+ratraw(irf18pa)*sc1adt dratdumdd(irf18pa) =dratrawdd(irf18pa)*sc1a+ratraw(irf18pa)*sc1add scfac(irf18pa) = sc1a dscfacdt(irf18pa) = sc1adt dscfacdd(irf18pa) = sc1add c..o15 + a jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(io15),aion(io15),zion(ihe4),aion(ihe4), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(iro15ap) = ratraw(iro15ap) * sc1a dratdumdt(iro15ap) =dratrawdt(iro15ap)*sc1a+ratraw(iro15ap)*sc1adt dratdumdd(iro15ap) =dratrawdd(iro15ap)*sc1a+ratraw(iro15ap)*sc1add scfac(iro15ap) = sc1a dscfacdt(iro15ap) = sc1adt dscfacdd(iro15ap) = sc1add c..triple alpha jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ihe4),aion(ihe4),zion(ihe4),aion(ihe4), 2 jscr,init,sc1a,sc1adt,sc1add) jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ihe4),aion(ihe4),4.0d0,8.0d0, 2 jscr,init,sc2a,sc2adt,sc2add) sc3a = sc1a * sc2a sc3adt = sc1adt * sc2a + sc1a * sc2adt sc3add = sc1add * sc2a + sc1a * sc2add ratdum(ir3a) = ratraw(ir3a) * sc3a dratdumdt(ir3a) = dratrawdt(ir3a)*sc3a + ratraw(ir3a)*sc3adt dratdumdd(ir3a) = dratrawdd(ir3a)*sc3a + ratraw(ir3a)*sc3add scfac(ir3a) = sc3a dscfacdt(ir3a) = sc3adt dscfacdd(ir3a) = sc3add c..ne18 to na21 jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 10.0d0,18.0d0,zion(ihe4),aion(ihe4), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irne18ap) = ratraw(irne18ap) * sc1a dratdumdt(irne18ap)= dratrawdt(irne18ap)*sc1a 1 + ratraw(irne18ap)*sc1adt dratdumdd(irne18ap)= dratrawdd(irne18ap)*sc1a 2 + ratraw(irne18ap)*sc1add scfac(irne18ap) = sc1a dscfacdt(irne18ap) = sc1adt dscfacdd(irne18ap) = sc1add c..o15 to ne19 jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(io15),aion(io15),zion(ihe4),aion(ihe4), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(iro15ag) = ratraw(iro15ag) * sc1a dratdumdt(iro15ag) =dratrawdt(iro15ag)*sc1a+ratraw(iro15ag)*sc1adt dratdumdd(iro15ag) =dratrawdd(iro15ag)*sc1a+ratraw(iro15ag)*sc1add scfac(iro15ag) = sc1a dscfacdt(iro15ag) = sc1adt dscfacdd(iro15ag) = sc1add c..ne19 + p jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 10.0d0,19.0d0,zion(ih1),aion(ih1), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irne19pg) = ratraw(irne19pg) * sc1a dratdumdt(irne19pg)= dratrawdt(irne19pg)*sc1a 1 + ratraw(irne19pg)*sc1adt dratdumdd(irne19pg)= dratrawdd(irne19pg)*sc1a 1 + ratraw(irne19pg)*sc1add scfac(irne19pg) = sc1a dscfacdt(irne19pg) = sc1adt dscfacdd(irne19pg) = sc1add c..si26 + a jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 14.0d0,26.0d0,zion(ihe4),aion(ihe4), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irsi26ap) = ratraw(irsi26ap) * sc1a dratdumdt(irsi26ap)= dratrawdt(irsi26ap)*sc1a 1 + ratraw(irsi26ap)*sc1adt dratdumdd(irsi26ap)= dratrawdd(irsi26ap)*sc1a 1 + ratraw(irsi26ap)*sc1add scfac(irsi26ap) = sc1a dscfacdt(irsi26ap) = sc1adt dscfacdd(irsi26ap) = sc1add c..ti44 + alpha jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 22.0d0,44.0d0,zion(ihe4),aion(ihe4), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irtiap) = ratraw(irtiap) * sc1a dratdumdt(irtiap) = dratrawdt(irtiap)*sc1a + ratraw(irtiap)*sc1adt dratdumdd(irtiap) = dratrawdd(irtiap)*sc1a + ratraw(irtiap)*sc1add scfac(irtiap) = sc1a dscfacdt(irtiap) = sc1adt dscfacdd(irtiap) = sc1add c..c12 to o16 jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ic12),aion(ic12),zion(ihe4),aion(ihe4), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(ircag) = ratraw(ircag) * sc1a dratdumdt(ircag) = dratrawdt(ircag)*sc1a + ratraw(ircag)*sc1adt dratdumdd(ircag) = dratrawdd(ircag)*sc1a + ratraw(ircag)*sc1add scfac(ircag) = sc1a dscfacdt(ircag) = sc1adt dscfacdt(ircag) = sc1add c..o16 to ne20 jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(io16),aion(io16),zion(ihe4),aion(ihe4), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(iroag) = ratraw(iroag) * sc1a dratdumdt(iroag) = dratrawdt(iroag)*sc1a + ratraw(iroag)*sc1adt dratdumdd(iroag) = dratrawdd(iroag)*sc1a + ratraw(iroag)*sc1add scfac(iroag) = sc1a dscfacdt(iroag) = sc1adt dscfacdd(iroag) = sc1add c..ne20 to mg24 jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ine20),aion(ine20),zion(ihe4),aion(ihe4), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irneag) = ratraw(irneag) * sc1a dratdumdt(irneag) = dratrawdt(irneag)*sc1a + ratraw(irneag)*sc1adt dratdumdd(irneag) = dratrawdd(irneag)*sc1a + ratraw(irneag)*sc1add scfac(irneag) = sc1a dscfacdt(irneag) = sc1adt dscfacdd(irneag) = sc1add c..mg24 to si28 jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(img24),aion(img24),zion(ihe4),aion(ihe4), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irmgag) = ratraw(irmgag) * sc1a dratdumdt(irmgag) = dratrawdt(irmgag)*sc1a + ratraw(irmgag)*sc1adt dratdumdd(irmgag) = dratrawdd(irmgag)*sc1a + ratraw(irmgag)*sc1add scfac(irmgag) = sc1a dscfacdt(irmgag) = sc1adt dscfacdd(irmgag) = sc1add ratdum(irmgap) = ratraw(irmgap) * sc1a dratdumdt(irmgap) = dratrawdt(irmgap)*sc1a + ratraw(irmgap)*sc1adt dratdumdd(irmgap) = dratrawdd(irmgap)*sc1a + ratraw(irmgap)*sc1add scfac(irmgap) = sc1a dscfacdt(irmgap) = sc1adt dscfacdd(irmgap) = sc1add jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 13.0d0,27.0d0,1.0d0,1.0d0, 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(iralpa) = ratraw(iralpa) * sc1a dratdumdt(iralpa) = dratrawdt(iralpa)*sc1a + ratraw(iralpa)*sc1adt dratdumdd(iralpa) = dratrawdd(iralpa)*sc1a + ratraw(iralpa)*sc1add scfac(iralpa) = sc1a dscfacdt(iralpa) = sc1adt dscfacdd(iralpa) = sc1add ratdum(iralpg) = ratraw(iralpg) * sc1a dratdumdt(iralpg) = dratrawdt(iralpg)*sc1a + ratraw(iralpg)*sc1adt dratdumdd(iralpg) = dratrawdd(iralpg)*sc1a + ratraw(iralpg)*sc1add scfac(iralpg) = sc1a dscfacdt(iralpg) = sc1adt dscfacdd(iralpg) = sc1add c..si28 to s32 jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(isi28),aion(isi28),zion(ihe4),aion(ihe4), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irsiag) = ratraw(irsiag) * sc1a dratdumdt(irsiag) = dratrawdt(irsiag)*sc1a + ratraw(irsiag)*sc1adt dratdumdd(irsiag) = dratrawdd(irsiag)*sc1a + ratraw(irsiag)*sc1add scfac(irsiag) = sc1a dscfacdt(irsiag) = sc1adt dscfacdd(irsiag) = sc1add ratdum(irsiap) = ratraw(irsiap) * sc1a dratdumdt(irsiap) = dratrawdt(irsiap)*sc1a + ratraw(irsiap)*sc1adt dratdumdd(irsiap) = dratrawdd(irsiap)*sc1a + ratraw(irsiap)*sc1add scfac(irsiap) = sc1a dscfacdt(irsiap) = sc1adt dscfacdd(irsiap) = sc1add jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 15.0d0,31.0d0,1.0d0,1.0d0, 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irppa) = ratraw(irppa) * sc1a dratdumdt(irppa) = dratrawdt(irppa)*sc1a + ratraw(irppa)*sc1adt dratdumdd(irppa) = dratrawdd(irppa)*sc1a + ratraw(irppa)*sc1add scfac(irppa) = sc1a dscfacdt(irppa) = sc1adt dscfacdd(irppa) = sc1add ratdum(irppg) = ratraw(irppg) * sc1a dratdumdt(irppg) = dratrawdt(irppg)*sc1a + ratraw(irppg)*sc1adt dratdumdd(irppg) = dratrawdd(irppg)*sc1a + ratraw(irppg)*sc1add scfac(irppg) = sc1a dscfacdt(irppg) = sc1adt dscfacdd(irppg) = sc1add c..s32 to ar36 jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(is32),aion(is32),zion(ihe4),aion(ihe4), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irsag) = ratraw(irsag) * sc1a dratdumdt(irsag) = dratrawdt(irsag)*sc1a + ratraw(irsag)*sc1adt dratdumdd(irsag) = dratrawdd(irsag)*sc1a + ratraw(irsag)*sc1add scfac(irsag) = sc1a dscfacdt(irsag) = sc1adt dscfacdd(irsag) = sc1add ratdum(irsap) = ratraw(irsap) * sc1a dratdumdt(irsap) = dratrawdt(irsap)*sc1a + ratraw(irsap)*sc1adt dratdumdd(irsap) = dratrawdd(irsap)*sc1a + ratraw(irsap)*sc1add scfac(irsap) = sc1a dscfacdt(irsap) = sc1adt dscfacdd(irsap) = sc1add jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 17.0d0,35.0d0,1.0d0,1.0d0, 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irclpa) = ratraw(irclpa) * sc1a dratdumdt(irclpa) = dratrawdt(irclpa)*sc1a + ratraw(irclpa)*sc1adt dratdumdd(irclpa) = dratrawdd(irclpa)*sc1a + ratraw(irclpa)*sc1add scfac(irclpa) = sc1a dscfacdt(irclpa) = sc1adt dscfacdt(irclpa) = sc1add ratdum(irclpg) = ratraw(irclpg) * sc1a dratdumdt(irclpg) = dratrawdt(irclpg)*sc1a + ratraw(irclpg)*sc1adt dratdumdd(irclpg) = dratrawdd(irclpg)*sc1a + ratraw(irclpg)*sc1add scfac(irclpg) = sc1a dscfacdt(irclpg) = sc1adt dscfacdd(irclpg) = sc1add c..ar36 to ca40 jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(iar36),aion(iar36),zion(ihe4),aion(ihe4), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irarag) = ratraw(irarag) * sc1a dratdumdt(irarag) = dratrawdt(irarag)*sc1a + ratraw(irarag)*sc1adt dratdumdd(irarag) = dratrawdd(irarag)*sc1a + ratraw(irarag)*sc1add scfac(irarag) = sc1a dscfacdt(irarag) = sc1adt dscfacdd(irarag) = sc1add ratdum(irarap) = ratraw(irarap) * sc1a dratdumdt(irarap) = dratrawdt(irarap)*sc1a + ratraw(irarap)*sc1adt dratdumdd(irarap) = dratrawdd(irarap)*sc1a + ratraw(irarap)*sc1add scfac(irarap) = sc1a dscfacdt(irarap) = sc1adt dscfacdd(irarap) = sc1add jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 19.0d0,39.0d0,1.0d0,1.0d0, 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irkpa) = ratraw(irkpa) * sc1a dratdumdt(irkpa) = dratrawdt(irkpa)*sc1a + ratraw(irkpa)*sc1adt dratdumdd(irkpa) = dratrawdd(irkpa)*sc1a + ratraw(irkpa)*sc1add scfac(irkpa) = sc1a dscfacdt(irkpa) = sc1adt dscfacdd(irkpa) = sc1add ratdum(irkpg) = ratraw(irkpg) * sc1a dratdumdt(irkpg) = dratrawdt(irkpg)*sc1a + ratraw(irkpg)*sc1adt dratdumdd(irkpg) = dratrawdd(irkpg)*sc1a + ratraw(irkpg)*sc1add scfac(irkpg) = sc1a dscfacdt(irkpg) = sc1adt dscfacdd(irkpg) = sc1add c..ca40 to ti44 jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ica40),aion(ica40),zion(ihe4),aion(ihe4), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(ircaag) = ratraw(ircaag) * sc1a dratdumdt(ircaag) = dratrawdt(ircaag)*sc1a + ratraw(ircaag)*sc1adt dratdumdd(ircaag) = dratrawdd(ircaag)*sc1a + ratraw(ircaag)*sc1add scfac(ircaag) = sc1a dscfacdt(ircaag) = sc1adt dscfacdd(ircaag) = sc1add ratdum(ircaap) = ratraw(ircaap) * sc1a dratdumdt(ircaap) = dratrawdt(ircaap)*sc1a + ratraw(ircaap)*sc1adt dratdumdd(ircaap) = dratrawdd(ircaap)*sc1a + ratraw(ircaap)*sc1add scfac(ircaap) = sc1a dscfacdt(ircaap) = sc1adt dscfacdd(ircaap) = sc1add jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 21.0d0,43.0d0,1.0d0,1.0d0, 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irscpa) = ratraw(irscpa) * sc1a dratdumdt(irscpa) = dratrawdt(irscpa)*sc1a + ratraw(irscpa)*sc1adt dratdumdd(irscpa) = dratrawdd(irscpa)*sc1a + ratraw(irscpa)*sc1add scfac(irscpa) = sc1a dscfacdt(irscpa) = sc1adt dscfacdd(irscpa) = sc1add ratdum(irscpg) = ratraw(irscpg) * sc1a dratdumdt(irscpg) = dratrawdt(irscpg)*sc1a + ratraw(irscpg)*sc1adt dratdumdd(irscpg) = dratrawdd(irscpg)*sc1a + ratraw(irscpg)*sc1add scfac(irscpg) = sc1a dscfacdt(irscpg) = sc1adt dscfacdd(irscpg) = sc1add c..ti44 to cr48 jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(iti44),aion(iti44),zion(ihe4),aion(ihe4), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irtiag) = ratraw(irtiag) * sc1a dratdumdt(irtiag) = dratrawdt(irtiag)*sc1a + ratraw(irtiag)*sc1adt dratdumdd(irtiag) = dratrawdd(irtiag)*sc1a + ratraw(irtiag)*sc1add scfac(irtiag) = sc1a dscfacdt(irtiag) = sc1adt dscfacdd(irtiag) = sc1add ratdum(irtiap) = ratraw(irtiap) * sc1a dratdumdt(irtiap) = dratrawdt(irtiap)*sc1a + ratraw(irtiap)*sc1adt dratdumdd(irtiap) = dratrawdd(irtiap)*sc1a + ratraw(irtiap)*sc1add scfac(irtiap) = sc1a dscfacdt(irtiap) = sc1adt dscfacdd(irtiap) = sc1add jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 23.0d0,47.0d0,1.0d0,1.0d0, 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irvpa) = ratraw(irvpa) * sc1a dratdumdt(irvpa) = dratrawdt(irvpa)*sc1a + ratraw(irvpa)*sc1adt dratdumdd(irvpa) = dratrawdd(irvpa)*sc1a + ratraw(irvpa)*sc1add scfac(irvpa) = sc1a dscfacdt(irvpa) = sc1adt dscfacdd(irvpa) = sc1add ratdum(irvpg) = ratraw(irvpg) * sc1a dratdumdt(irvpg) = dratrawdt(irvpg)*sc1a + ratraw(irvpg)*sc1adt dratdumdd(irvpg) = dratrawdd(irvpg)*sc1a + ratraw(irvpg)*sc1add scfac(irvpg) = sc1a dscfacdt(irvpg) = sc1adt dscfacdd(irvpg) = sc1add c..cr48 to fe52 jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(icr48),aion(icr48),zion(ihe4),aion(ihe4), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(ircrag) = ratraw(ircrag) * sc1a dratdumdt(ircrag) = dratrawdt(ircrag)*sc1a + ratraw(ircrag)*sc1adt dratdumdd(ircrag) = dratrawdd(ircrag)*sc1a + ratraw(ircrag)*sc1add scfac(ircrag) = sc1a dscfacdt(ircrag) = sc1adt dscfacdd(ircrag) = sc1add ratdum(ircrap) = ratraw(ircrap) * sc1a dratdumdt(ircrap) = dratrawdt(ircrap)*sc1a + ratraw(ircrap)*sc1adt dratdumdd(ircrap) = dratrawdd(ircrap)*sc1a + ratraw(ircrap)*sc1add scfac(ircrap) = sc1a dscfacdt(ircrap) = sc1adt dscfacdd(ircrap) = sc1add jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 25.0d0,51.0d0,1.0d0,1.0d0, 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irmnpa) = ratraw(irmnpa) * sc1a dratdumdt(irmnpa) = dratrawdt(irmnpa)*sc1a + ratraw(irmnpa)*sc1adt dratdumdd(irmnpa) = dratrawdd(irmnpa)*sc1a + ratraw(irmnpa)*sc1add scfac(irmnpa) = sc1a dscfacdt(irmnpa) = sc1adt dscfacdd(irmnpa) = sc1add ratdum(irmnpg) = ratraw(irmnpg) * sc1a dratdumdt(irmnpg) = dratrawdt(irmnpg)*sc1a + ratraw(irmnpg)*sc1adt dratdumdd(irmnpg) = dratrawdd(irmnpg)*sc1a + ratraw(irmnpg)*sc1add scfac(irmnpg) = sc1a dscfacdt(irmnpg) = sc1adt dscfacdd(irmnpg) = sc1add c..fe52 to ni56 jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ife52),aion(ife52),zion(ihe4),aion(ihe4), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(irfeag) = ratraw(irfeag) * sc1a dratdumdt(irfeag) = dratrawdt(irfeag)*sc1a + ratraw(irfeag)*sc1adt dratdumdd(irfeag) = dratrawdd(irfeag)*sc1a + ratraw(irfeag)*sc1add scfac(irfeag) = sc1a dscfacdt(irfeag) = sc1adt dscfacdd(irfeag) = sc1add ratdum(irfeap) = ratraw(irfeap) * sc1a dratdumdt(irfeap) = dratrawdt(irfeap)*sc1a + ratraw(irfeap)*sc1adt dratdumdd(irfeap) = dratrawdd(irfeap)*sc1a + ratraw(irfeap)*sc1add scfac(irfeap) = sc1a dscfacdt(irfeap) = sc1adt dscfacdd(irfeap) = sc1add jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 27.0d0,55.0d0,1.0d0,1.0d0, 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(ircopa) = ratraw(ircopa) * sc1a dratdumdt(ircopa) = dratrawdt(ircopa)*sc1a + ratraw(ircopa)*sc1adt dratdumdd(ircopa) = dratrawdd(ircopa)*sc1a + ratraw(ircopa)*sc1add scfac(ircopa) = sc1a dscfacdt(ircopa) = sc1adt dscfacdd(ircopa) = sc1add ratdum(ircopg) = ratraw(ircopg) * sc1a dratdumdt(ircopg) = dratrawdt(ircopg)*sc1a + ratraw(ircopg)*sc1adt dratdumdd(ircopg) = dratrawdd(ircopg)*sc1a + ratraw(ircopg)*sc1add scfac(ircopg) = sc1a dscfacdt(ircopg) = sc1adt dscfacdd(ircopg) = sc1add c..c12 + c12 jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ic12),aion(ic12),zion(ic12),aion(ic12), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(ir1212) = ratraw(ir1212) * sc1a dratdumdt(ir1212) = dratrawdt(ir1212)*sc1a + ratraw(ir1212)*sc1adt dratdumdd(ir1212) = dratrawdd(ir1212)*sc1a + ratraw(ir1212)*sc1add scfac(ir1212) = sc1a dscfacdt(ir1212) = sc1adt dscfacdd(ir1212) = sc1add c..c12 + o16 jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(ic12),aion(ic12),zion(io16),aion(io16), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(ir1216) = ratraw(ir1216) * sc1a dratdumdt(ir1216) = dratrawdt(ir1216)*sc1a + ratraw(ir1216)*sc1adt dratdumdd(ir1216) = dratrawdd(ir1216)*sc1a + ratraw(ir1216)*sc1add scfac(ir1216) = sc1a dscfacdt(ir1216) = sc1adt dscfacdd(ir1216) = sc1add c..o16 + o16 jscr = jscr + 1 call screen5(btemp,bden,zbar,abar,z2bar, 1 zion(io16),aion(io16),zion(io16),aion(io16), 2 jscr,init,sc1a,sc1adt,sc1add) ratdum(ir1616) = ratraw(ir1616) * sc1a dratdumdt(ir1616) = dratrawdt(ir1616)*sc1a + ratraw(ir1616)*sc1adt dratdumdd(ir1616) = dratrawdd(ir1616)*sc1a + ratraw(ir1616)*sc1add scfac(ir1616) = sc1a dscfacdt(ir1616) = sc1adt dscfacdd(ir1616) = sc1add c..reset the screen initialization flag init = 0 c..end of screen block if end if c..test for 26si decay or 26si (a,p) wp22mg = 1.071d-1 ratdum(irdelta1) = 0.0d0 ratdum(iralam1) = wp22mg dratdumdt(iralam1) = 0.0d0 dratdumdd(iralam1) = 0.0d0 alamt = y(ihe4)*ratdum(irsi26ap) if (ratdum(iralam1) .le. alamt) then ratdum(iralam1) = ratdum(irsi26ap) dratdumdt(iralam1) = dratdumdt(irsi26ap) dratdumdd(iralam1) = dratdumdd(irsi26ap) ratdum(irdelta1) = 1.0d0 end if c..test for 44ti decay or 44ti (a,p) wp30s = 6.667d-2 ratdum(irdelta2) = 0.0d0 ratdum(iralam2) = wp30s dratdumdt(iralam2) = 0.0d0 dratdumdd(iralam2) = 0.0d0 alamt = y(ihe4) * ratdum(irtiap) if (ratdum(iralam2) .le. alamt) then ratdum(iralam2) = ratdum(irtiap) dratdumdt(iralam2) = dratdumdt(irtiap) dratdumdd(iralam2) = dratdumdd(irtiap) ratdum(irdelta2) = 1.0d0 end if c..now form those lovely dummy proton link rates ratdum(irr1) = 0.0d0 dratdumdt(irr1) = 0.0d0 dratdumdd(irr1) = 0.0d0 denom = ratdum(iralpa) + ratdum(iralpg) denomdt = dratdumdt(iralpa) + dratdumdt(iralpg) denomdd = dratdumdd(iralpa) + dratdumdd(iralpg) if (denom .ne. 0.0) then zz = 1.0d0/denom ratdum(irr1) = ratdum(iralpa)*zz dratdumdt(irr1) = (dratdumdt(iralpa) - ratdum(irr1)*denomdt)*zz dratdumdd(irr1) = (dratdumdd(iralpa) - ratdum(irr1)*denomdd)*zz end if ratdum(irs1) = 0.0d0 dratdumdt(irs1) = 0.0d0 dratdumdd(irs1) = 0.0d0 denom = ratdum(irppa) + ratdum(irppg) denomdt = dratdumdt(irppa) + dratdumdt(irppg) denomdd = dratdumdd(irppa) + dratdumdd(irppg) if (denom .ne. 0.0) then zz = 1.0d0/denom ratdum(irs1) = ratdum(irppa)*zz dratdumdt(irs1) = (dratdumdt(irppa) - ratdum(irs1)*denomdt)*zz dratdumdd(irs1) = (dratdumdd(irppa) - ratdum(irs1)*denomdd)*zz end if ratdum(irt1) = 0.0d0 dratdumdt(irt1) = 0.0d0 dratdumdd(irt1) = 0.0d0 denom = ratdum(irclpa) + ratdum(irclpg) denomdt = dratdumdt(irclpa) + dratdumdt(irclpg) denomdd = dratdumdd(irclpa) + dratdumdd(irclpg) if (denom .ne. 0.0) then zz = 1.0d0/denom ratdum(irt1) = ratdum(irclpa)*zz dratdumdt(irt1) = (dratdumdt(irclpa) - ratdum(irt1)*denomdt)*zz dratdumdd(irt1) = (dratdumdd(irclpa) - ratdum(irt1)*denomdd)*zz end if ratdum(iru1) = 0.0d0 dratdumdt(iru1) = 0.0d0 dratdumdd(iru1) = 0.0d0 denom = ratdum(irkpa) + ratdum(irkpg) denomdt = dratdumdt(irkpa) + dratdumdt(irkpg) denomdd = dratdumdd(irkpa) + dratdumdd(irkpg) if (denom .ne. 0.0) then zz = 1.0d0/denom ratdum(iru1) = ratdum(irkpa)*zz dratdumdt(iru1) = (dratdumdt(irkpa) - ratdum(iru1)*denomdt)*zz dratdumdd(iru1) = (dratdumdd(irkpa) - ratdum(iru1)*denomdd)*zz end if ratdum(irv1) = 0.0d0 dratdumdt(irv1) = 0.0d0 dratdumdd(irv1) = 0.0d0 denom = ratdum(irscpa) + ratdum(irscpg) denomdt = dratdumdt(irscpa) + dratdumdt(irscpg) denomdd = dratdumdd(irscpa) + dratdumdd(irscpg) if (denom .ne. 0.0) then zz = 1.0d0/denom ratdum(irv1) = ratdum(irscpa)*zz dratdumdt(irv1) = (dratdumdt(irscpa) - ratdum(irv1)*denomdt)*zz dratdumdd(irv1) = (dratdumdd(irscpa) - ratdum(irv1)*denomdd)*zz end if ratdum(irw1) = 0.0d0 dratdumdt(irw1) = 0.0d0 dratdumdd(irw1) = 0.0d0 denom = ratdum(irvpa) + ratdum(irvpg) denomdt = dratdumdt(irvpa) + dratdumdt(irvpg) denomdd = dratdumdd(irvpa) + dratdumdd(irvpg) if (denom .ne. 0.0) then zz = 1.0d0/denom ratdum(irw1) = ratdum(irvpa)*zz dratdumdt(irw1) = (dratdumdt(irvpa) - ratdum(irw1)*denomdt)*zz dratdumdd(irw1) = (dratdumdd(irvpa) - ratdum(irw1)*denomdd)*zz end if ratdum(irx1) = 0.0d0 dratdumdt(irx1) = 0.0d0 dratdumdd(irx1) = 0.0d0 denom = ratdum(irmnpa) + ratdum(irmnpg) denomdt = dratdumdt(irmnpa) + dratdumdt(irmnpg) denomdd = dratdumdd(irmnpa) + dratdumdd(irmnpg) if (denom .ne. 0.0) then zz = 1.0d0/denom ratdum(irx1) = ratdum(irmnpa)*zz dratdumdt(irx1) = (dratdumdt(irmnpa) - ratdum(irx1)*denomdt)*zz dratdumdd(irx1) = (dratdumdd(irmnpa) - ratdum(irx1)*denomdd)*zz endif ratdum(iry1) = 0.0d0 dratdumdt(iry1) = 0.0d0 dratdumdd(iry1) = 0.0d0 denom = ratdum(ircopa) + ratdum(ircopg) denomdt = dratdumdt(ircopa) + dratdumdt(ircopg) denomdd = dratdumdd(ircopa) + dratdumdd(ircopg) if (denom .ne. 0.0) then zz = 1.0d0/denom ratdum(iry1) = ratdum(ircopa)*zz dratdumdt(iry1) = (dratdumdt(ircopa) - ratdum(iry1)*denomdt)*zz dratdumdd(iry1) = (dratdumdd(ircopa) - ratdum(iry1)*denomdd)*zz end if c..write the rates c do i=1,nrat c write(6,111) i,ratnam(i),ratraw(i),scfac(i),ratdum(i) c 111 format(1x,i4,' ',a,' ',1p3e12.4) c enddo c read(5,*) return end subroutine init_hhe include 'implno.dek' include 'const.dek' include 'network.dek' c.. c..this routine initializes stuff for the hhe network c.. c..declare integer i double precision mev2erg,mev2gr parameter (mev2erg = ev2erg*1.0d6, 1 mev2gr = mev2erg/clight**2) c..for easy zeroing of the isotope pointers integer isotp(nisotp) equivalence (isotp(1),ih1) c..for easy zeroing of the rate pointers integer rts(numrates) equivalence (rts(1),ir3a) c..zero all the isotope pointers do i=1,nisotp isotp(i) = 0 enddo c..zero all the rate pointers do i=1,numrates rts(i) = 0 enddo c..set the size of the network and the number of rates idnet = idhhe ionmax = 34 iener = ionmax + 1 itemp = ionmax + 2 iden = ionmax + 3 neqs = iden nrat = 125 netname = 'hhe' c..set the id numbers of the elements ih1 = 1 ih2 = 2 ihe3 = 3 ihe4 = 4 ili7 = 5 ibe7 = 6 ib8 = 7 ic12 = 8 ic13 = 9 in13 = 10 in14 = 11 in15 = 12 io14 = 13 io15 = 14 io16 = 15 io17 = 16 io18 = 17 if17 = 18 if18 = 19 if19 = 20 ine18 = 21 ine19 = 22 ine20 = 23 img22 = 24 img24 = 25 isi28 = 26 is30 = 27 is32 = 28 iar36 = 29 ica40 = 30 iti44 = 31 icr48 = 32 ife52 = 33 ini56 = 34 c..set the names of the elements ionam(ih1) = 'h1 ' ionam(ih2) = 'h2 ' ionam(ihe3) = 'he3 ' ionam(ihe4) = 'he4 ' ionam(ili7) = 'li7 ' ionam(ibe7) = 'be7 ' ionam(ib8) = 'b8 ' ionam(ic12) = 'c12 ' ionam(ic13) = 'c13 ' ionam(in13) = 'n13 ' ionam(in14) = 'n14 ' ionam(in15) = 'n15 ' ionam(io14) = 'o14 ' ionam(io15) = 'o15 ' ionam(io16) = 'o16 ' ionam(io17) = 'o17 ' ionam(io18) = 'o18 ' ionam(if17) = 'f17 ' ionam(if18) = 'f18 ' ionam(if19) = 'f19 ' ionam(ine18) = 'ne18' ionam(ine19) = 'ne19' ionam(ine20) = 'ne20' ionam(img22) = 'mg22' ionam(img24) = 'mg24' ionam(isi28) = 'si28' ionam(is30) = 's30' ionam(is32) = 's32 ' ionam(iar36) = 'ar36' ionam(ica40) = 'ca40' ionam(iti44) = 'ti44' ionam(icr48) = 'cr48' ionam(ife52) = 'fe52' ionam(ini56) = 'ni56' ionam(iener) = 'ener ' ionam(itemp) = 'temp ' ionam(iden) = 'den ' c..set the number of nucleons in the element aion(ih1) = 1.0d0 aion(ih2) = 2.0d0 aion(ihe3) = 3.0d0 aion(ili7) = 7.0d0 aion(ibe7) = 7.0d0 aion(ib8) = 8.0d0 aion(ihe4) = 4.0d0 aion(ic12) = 12.0d0 aion(ic13) = 13.0d0 aion(in13) = 13.0d0 aion(in14) = 14.0d0 aion(in15) = 15.0d0 aion(io14) = 14.0d0 aion(io15) = 15.0d0 aion(io16) = 16.0d0 aion(io17) = 17.0d0 aion(io18) = 18.0d0 aion(if17) = 17.0d0 aion(if18) = 18.0d0 aion(if19) = 19.0d0 aion(ine18) = 18.0d0 aion(ine19) = 19.0d0 aion(ine20) = 20.0d0 aion(img22) = 22.0d0 aion(img24) = 24.0d0 aion(isi28) = 28.0d0 aion(is30) = 30.0d0 aion(is32) = 32.0d0 aion(iar36) = 36.0d0 aion(ica40) = 40.0d0 aion(iti44) = 44.0d0 aion(icr48) = 48.0d0 aion(ife52) = 52.0d0 aion(ini56) = 56.0d0 c..set the number of protons in the element zion(ih1) = 1.0d0 zion(ih2) = 1.0d0 zion(ihe3) = 2.0d0 zion(ili7) = 3.0d0 zion(ibe7) = 4.0d0 zion(ib8) = 5.0d0 zion(ihe4) = 2.0d0 zion(ic12) = 6.0d0 zion(ic13) = 6.0d0 zion(in13) = 7.0d0 zion(in14) = 7.0d0 zion(in15) = 7.0d0 zion(io14) = 8.0d0 zion(io15) = 8.0d0 zion(io16) = 8.0d0 zion(io17) = 8.0d0 zion(io18) = 8.0d0 zion(if17) = 9.0d0 zion(if18) = 9.0d0 zion(if19) = 9.0d0 zion(ine18) = 10.0d0 zion(ine19) = 10.0d0 zion(ine20) = 10.0d0 zion(img22) = 12.0d0 zion(img24) = 12.0d0 zion(isi28) = 14.0d0 zion(is30) = 16.0d0 zion(is32) = 16.0d0 zion(iar36) = 18.0d0 zion(ica40) = 20.0d0 zion(iti44) = 22.0d0 zion(icr48) = 24.0d0 zion(ife52) = 26.0d0 zion(ini56) = 28.0d0 c..set the binding energy of the element bion(ih1) = 0.0d0 bion(ih2) = 2.2250d0 bion(ihe3) = 7.7204d0 bion(ili7) = 39.2440d0 bion(ibe7) = 37.6000d0 bion(ib8) = 37.7380d0 bion(ihe4) = 28.2928d0 bion(ic12) = 92.1624d0 bion(ic13) = 97.1088d0 bion(in13) = 94.1064d0 bion(in14) = 104.6598d0 bion(in15) = 115.4932d0 bion(io14) = 98.7324d0 bion(io15) = 111.9558d0 bion(io16) = 127.6202d0 bion(io17) = 131.7636d0 bion(io18) = 139.8080d0 bion(if17) = 128.2212d0 bion(if18) = 137.3706d0 bion(if19) = 147.8020d0 bion(ine18) = 132.1390d0 bion(ine19) = 143.7780d0 bion(ine20) = 160.64788d0 bion(img22) = 168.57680d0 bion(img24) = 198.25790d0 bion(isi28) = 236.53790d0 bion(is30) = 243.68660d0 bion(is32) = 271.78250d0 bion(iar36) = 306.72020d0 bion(ica40) = 342.05680d0 bion(iti44) = 375.47720d0 bion(icr48) = 411.46900d0 bion(ife52) = 447.70800d0 bion(ini56) = 483.99500d0 c..set the number of neutrons and mass do i=1,ionmax nion(i) = aion(i) - zion(i) enddo c..mass of each isotope do i = 1,ionmax mion(i) = nion(i)*mn + zion(i)*mp - bion(i)*mev2gr enddo c..molar mass do i = 1,ionmax wion(i) = avo * mion(i) enddo c..a common approximation do i = 1,ionmax wion(i) = aion(i) enddo c..set the partition functions - statistical weights, ground-state only here do i=1,ionmax wpart(i) = 1.0d0 enddo c..set the id numbers of the reaction rates irc12pg = 1 irn13gp = 2 irn13enu = 3 irc13pg = 4 irn14gp = 5 irn14pg = 6 iro15gp = 7 iro15enu = 8 irn15pa = 9 irc12ap = 10 irn15pg = 11 iro16gp = 12 iro16pg = 13 irf17gp = 14 irf17enu = 15 iro17pa = 16 irn14ap = 17 iro17pg = 18 irf18gp = 19 irf18enu = 20 iro18pa = 21 irn15ap = 22 iro18pg = 23 irf19gp = 24 irf19pa = 25 iro16ap = 26 irn13pg = 27 iro14gp = 28 iro14enu = 29 iro14ap = 30 irf17pa = 31 irf17pg = 32 irne18gp = 33 irne18enu= 34 irf18pa = 35 iro15ap = 36 ir3a = 37 irg3a = 38 irne18ap = 39 iro15ag = 40 irne19pg = 41 irsi26ap = 42 irtiap = 43 irne19enu= 44 irne20pg = 45 irpp = 46 irdpg = 47 ir33 = 48 irhe3ag = 49 irbeec = 50 irbepg = 51 irb8gp = 52 irb8ep = 53 irli7pa = 54 ircag = 55 iroga = 56 iroag = 57 irnega = 58 irneag = 59 irmgga = 60 irmgag = 61 irsiga = 62 irmgap = 63 iralpa = 64 iralpg = 65 irsigp = 66 irsiag = 67 irsga = 68 irsiap = 69 irppa = 70 irppg = 71 irsgp = 72 irsag = 73 irarga = 74 irsap = 75 irclpa = 76 irclpg = 77 irargp = 78 irarag = 79 ircaga = 80 irarap = 81 irkpa = 82 irkpg = 83 ircagp = 84 ircaag = 85 irtiga = 86 ircaap = 87 irscpa = 88 irscpg = 89 irtigp = 90 irtiag = 91 ircrga = 92 irtiap = 93 irvpa = 94 irvpg = 95 ircrgp = 96 ircrag = 97 irfega = 98 ircrap = 99 irmnpa = 100 irmnpg = 101 irfegp = 102 irfeag = 103 irniga = 104 irfeap = 105 ircopa = 106 ircopg = 107 irnigp = 108 ir1212 = 109 ir1216 = 110 ir1616 = 111 iralam1 = 112 irdelta1 = 113 iralam2 = 114 irdelta2 = 115 irr1 = 116 irs1 = 117 irt1 = 118 iru1 = 119 irv1 = 120 irw1 = 121 irx1 = 122 iry1 = 123 irpep = 124 irhep = 125 c..set the names of the reaction rates ratnam(irc12pg) = 'c12(p,g)n13' ratnam(irn13gp) = 'n13(g,p)c12' ratnam(irn13enu) = 'n13(p=>n)c13' ratnam(irc13pg) = 'c13(p,g)n14' ratnam(irn14gp) = 'n14(g,p)c13' ratnam(irn14pg) = 'n14(p,g)o15' ratnam(iro15gp) = 'o15(g,p)n14' ratnam(iro15enu) = 'o15(p=>n)n15' ratnam(irn15pa) = 'n15(p,a)c12' ratnam(irc12ap) = 'c12(a,p)n15' ratnam(irn15pg) = 'n15(p,g)o16' ratnam(iro16gp) = 'o16(g,p)n15' ratnam(iro16pg) = 'o16(p,g)f17' ratnam(irf17gp) = 'f17(g,p)o16' ratnam(irf17enu) = 'f17(p=>n)o17' ratnam(iro17pa) = 'o17(p,a)n14' ratnam(irn14ap) = 'n14(a,p)o17' ratnam(iro17pg) = 'o17(p,g)f18' ratnam(irf18gp) = 'f18(g,p)o17' ratnam(irf18enu) = 'f18(p=>n)o18' ratnam(iro18pa) = 'o18(p,a)n15' ratnam(irn15ap) = '15n(a,p)o18' ratnam(iro18pg) = 'o18(p,g)f19' ratnam(irf19gp) = 'f19(g,p)o18' ratnam(irf19pa) = 'f19(p,a)o16' ratnam(iro16ap) = 'o16(a,p)f19' ratnam(irn13pg) = 'n13(p,g)o14' ratnam(iro14gp) = 'o14(g,p)n13' ratnam(iro14enu) = 'o14(p=>n)n14' ratnam(iro14ap) = 'o14(a,p)f17' ratnam(irf17pa) = 'f17(p,a)o14' ratnam(irf17pg) = 'f17(p,g)ne18' ratnam(irne18gp) = 'ne18(g,p)f17' ratnam(irne18enu)= 'ne18(p=>n)f18' ratnam(irf18pa) = 'f18(p,a)o15' ratnam(iro15ap) = 'o15(a,p)f18' ratnam(ir3a) = 'r3a ' ratnam(irg3a) = 'rg3a' ratnam(irne18ap) = 'ne18(a,p)na21' ratnam(iro15ag) = 'o15(a,g)ne19' ratnam(irne19pg) = 'ne19(p,g)na20' ratnam(irsi26ap) = 'si26(a,p)p29' ratnam(irtiap) = 'ti44(a,p)v47' ratnam(irpp) = 'p(p,e+nu)h2' ratnam(irdpg) = '2h(p,g)he3' ratnam(ir33) = 'he3(he3,2p)he4' ratnam(irhe3ag) = 'he3(a,g)be7' ratnam(irbeec) = 'be7(p=>n)li7' ratnam(irbepg) = 'be7(p,g)b8' ratnam(irb8gp) = 'b8(g,p)be7' ratnam(irb8ep) = 'b8(p=>n)2he4' ratnam(irli7pa) = 'li7(p,a)2he4' ratnam(irpep) = 'p(e-p,nu)h2' ratnam(irhep) = 'he3(p,e+nu)he4' ratnam(irne19enu)= 'ne19(p=>n)f19' ratnam(irne20pg) = 'ne20(p,g)na21' ratnam(ircag) = 'c12(a,g)o16' ratnam(iroga) = 'o16(g,a)c12' ratnam(iroag) = 'o16(a,g)ne20' ratnam(irnega) = 'ne20(g,a)o16' ratnam(irneag) = 'ne20(a,g)mg24' ratnam(irmgga) = 'mg24(g,a)ne20' ratnam(irmgag) = 'mg24(a,g)si28' ratnam(irsiga) = 'si28(g,a)mg24' ratnam(irmgap) = 'mg24(a,p)al27' ratnam(iralpa) = 'al27(p,a)mg24' ratnam(iralpg) = 'al27(p,g)si28' ratnam(irsigp) = 'si28(g,p)al27' ratnam(irsiag) = 'si28(a,g)s32' ratnam(irsga) = 's32(g,a)si28' ratnam(irsiap) = 'si28(a,p)p31' ratnam(irppa) = 'p31(p,a)si28' ratnam(irppg) = 'p31(p,g)s32' ratnam(irsgp) = 's32(g,p)p31 ' ratnam(irsag) = 's32(a,g)ar36' ratnam(irarga) = 'ar36(g,a)s32' ratnam(irsap) = 's32(a,p)cl35' ratnam(irclpa) = 'cl35(p,a)s32' ratnam(irclpg) = 'cl35(p,g)ar36' ratnam(irargp) = 'ar36(g,p)cl35' ratnam(irarag) = 'ar36(a,g)ca40' ratnam(ircaga) = 'ca40(g,a)ar36' ratnam(irarap) = 'ar36(a,p)k39' ratnam(irkpa) = 'k39(p,a)ar36' ratnam(irkpg) = 'k39(p,g)ca40' ratnam(ircagp) = 'ca40(g,p)k39' ratnam(ircaag) = 'ca40(a,g)ti44' ratnam(irtiga) = 'ti44(g,a)ca40' ratnam(ircaap) = 'ca40(a,p)sc43' ratnam(irscpa) = 'sc43(p,a)ca40' ratnam(irscpg) = 'sc43(p,g)ti44' ratnam(irtigp) = 'ti44(g,p)sc43' ratnam(irtiag) = 'ti44(a,g)cr48' ratnam(ircrga) = 'cr48(g,a)ti44' ratnam(irtiap) = 'ti44(a,p)v47' ratnam(irvpa) = 'v47(p,a)ti44' ratnam(irvpg) = 'v47(p,g)cr48' ratnam(ircrgp) = 'cr48(g,p)v47' ratnam(ircrag) = 'cr48(a,g)fe52' ratnam(irfega) = 'fe52(g,a)cr48' ratnam(ircrap) = 'cr48(a,p)mn51' ratnam(irmnpa) = 'mn51(p,a)cr48' ratnam(irmnpg) = 'mn51(p,g)fe52' ratnam(irfegp) = 'fe52(g,p)mn51' ratnam(irfeag) = 'fe52(a,g)ni56' ratnam(irniga) = 'ni56(g,a)fe52' ratnam(irfeap) = 'fe52(a,p)co55' ratnam(ircopa) = 'co55(p,a)fe52' ratnam(ircopg) = 'co55(p,g)ni56' ratnam(irnigp) = 'ni56(g,p)co55' ratnam(ir1212) = 'r1212' ratnam(ir1216) = 'r1216' ratnam(ir1616) = 'r1616' ratnam(iralam1) = 'alam1' ratnam(irdelta1) = 'delta1' ratnam(iralam2) = 'alam2' ratnam(irdelta2) = 'delta2' ratnam(irr1) = 'r1' ratnam(irs1) = 's1' ratnam(irt1) = 't1' ratnam(iru1) = 'u1' ratnam(irv1) = 'v1' ratnam(irw1) = 'w1' ratnam(irx1) = 'x1' ratnam(iry1) = 'y1' return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine netint(start,stptry,stpmin,stopp,bc, 1 eps,ylogi,nok,nbad,kount,odescal, 2 derivs,jakob,bjakob,steper) include 'implno.dek' include 'burn_common.dek' include 'network.dek' c..ode integrator for stiff odes c..tuned for nnuclear reacton networks c..input: c..start = beginning integration point c..stptry = suggested first step size c..stpmin = minimum allowable step size c..stopp = ending integration point c..bc = initial conditions, array of physical dimension yphys c..eps = desired fraction error during the integration c..odescal = error scaling factor c..derivs = name of the routine that contains the odes c..jakob = name of the routine that contains the jacobian of the odes c..bjakob = name of the routine that sets the pointers of the sparse jacobian c..steper = name of the routine that will take a single step c..output: c..nok = number of succesful steps taken c..nbad = number of bad steps taken, bad but retried and then succesful c..kount = total number of steps taken c..declare the pass external derivs,jakob,bjakob,steper integer ylogi,nok,nbad,kount double precision start,stptry,stpmin,stopp,bc(ylogi),eps, 1 odescal c..for communicating a root find c..common block communication double precision nse_temp_switch common /nsetsw/ nse_temp_switch c..local variables character*5 cdtname integer nmax,stpmax,i,ii,nstp,idt parameter (nmax = abignet*nzmax, stpmax=200000) double precision yscal(nmax),y(nmax),dydx(nmax),xdum(nmax), 1 sum,cons,t9,tau_nse,tau_qse, 1 x,h,hdid,hnext,tiny parameter (tiny=1.0d-15) c..for saving the old abundances double precision ylast(nmax) c..for a root find on the trajectory external time_switch double precision up_zbrent,time_switch,xb,tol_switch parameter (tol_switch = 1.0e-12) integer niter c..for smooth plot timesteps double precision ratio,xfloor,ychangemax,ynew,yold,yy,dtx c..for some more informative printouts double precision zbarxx,ytot1,abar,zbar,wbar,ye,xcess, 1 ttz,ddz,ttz1,ddz1,ttz2,ddz2,tlo,thi c..for nse character*3 cmode integer igues,nse_switch double precision xmun,xmup c..here are the format statements for printouts as we integrate 100 format(1x,i6,' ',a,a,1pe11.4,a,a,a,1pe11.4, 1 3(a6,1pe10.3),5(a5,1pe9.2)) 101 format(1x,1p12e10.2) c..initialize if (ylogi .gt. nmax) stop 'ylogi > nmax in routine netint' x = start h = sign(stptry,stopp-start) nok = 0 nbad = 0 kount = 0 idt = 0 nse_temp_switch = 10.0d9 thi = nse_temp_switch*(1.0d0 + tol_switch) tlo = nse_temp_switch*(1.0d0 - tol_switch) cmode = ' ' c..store the first step do i=1,ylogi y(i) = bc(i) enddo c..take at most stpmax steps do nstp=1,stpmax c..store the old abundances do i=1,ionmax ylast(i) = y(i) enddo c..positive definite abundance fractions do i=1,ionmax y(i) = min(1.0d0, max(y(i),1.0d-30)) enddo c..form the mass fractions and nonconservation sum = 0.0d0 do i=1,ionmax xdum(i) = y(i) * aion(i) end do do i=1,ionmax sum = sum + xdum(i) end do cons = 1.0d0 - sum c..renorm the abundances c sum = 1.0d0/sum c do i=1,ionmax c xdum(i) = sum * xdum(i) c end do c do i=1,ionmax c y(i) = min(1.0d0,max(xdum(i)/aion(i),1.0d-30)) c end do c..get the right hand sides c if (nse_on .eq. 0) then call derivs(x,y,dydx) c..scaling vector used to monitor accuracy do i=1,ylogi yscal(i) = max(odescal,abs(y(i))) enddo c end if c..store intermediate results kount = kount+1 c..detailed file print if (iprint_files .eq. 1) call net_output(kount,x,y,derivs) c..screen print if (iprint_screen .eq. 1) then call azbar(xdum,aion,zion,wion,ionmax, 1 zwork1,abar,zbar,wbar,ye,xcess) ttz = -1.0d0 ddz = -1.0d0 if (pure_network .eq. 0) then ttz = y(itemp) ddz = y(iden) else ttz = btemp ddz = bden end if if (trho_hist) call update2(x,ttz,ddz) if (idt .eq. 0) then cdtname = 'time ' else cdtname = ionam(idt) end if call indexx(ionmax,xdum,izwork1) write(6,100) kount,cmode,' time',x, 1 ' dt(',cdtname,')',hdid,(ionam(izwork1(ii)), 2 xdum(izwork1(ii)),ii=ionmax,ionmax-2,-1), 3 ' temp',ttz,' den ',ddz,' enuc',sdot-sneut, 4 ' ye ',ye,' sum ',cons c read(5,*) end if c call flush(6) c call flush_(6) c..if the step can overshoot the stop point cut it if ((x+h-stopp)*(x+h-start) .gt. 0.0d0) h = stopp - x c.. do an nse step - this should now be made a subroutine c..if nse evolution is allowed if (allow_nse_evol .eq. 1) then c..get the thermodymanic conditions if (pure_network .eq. 0) then ttz = y(itemp) ddz = y(iden) else ttz = btemp ddz = bden end if c if (trho_hist) call update2(x+h,ttz,ddz) c..if we are interpolating a trajectory c..get the values at the present time point and the suggested next time point if (trho_hist) then call update2(x,ttz1,ddz1) call update2(x+h,ttz2,ddz2) c..if both are above the nse point if (ttz1 .ge. nse_temp_switch .and. 1 ttz2 .ge. nse_temp_switch) then ttz = ttz2 ddz = ddz2 xb = 0.0d0 nse_switch = 0 c write(6,*) 'both above' c..if we are falling out of nse else if (ttz1 .ge. thi .and. 1 ttz2 .le. tlo) then xb = up_zbrent(time_switch,x,x+h,tol_switch,niter) h = max(xb - x,tol_switch) call update2(xb,ttz,ddz) nse_switch = 1 c write(6,*) 'ttz2 below',ttz1.ge.thi,ttz2.le.tlo c..if we are going into nse else if (ttz1 .le. tlo .and. 1 ttz2 .ge. thi) then xb = up_zbrent(time_switch,x,x+h,tol_switch,niter) h = max(xb - x,tol_switch) call update2(xb,ttz,ddz) nse_switch = 1 c write(6,*) 'ttz2 above',ttz1.le.tlo,ttz2.ge.thi c..if we are out of nse, then these values get reset c..this also applies if we are within tol_switch of nse_temp_switch else ttz = ttz2 ddz = ddz2 xb = 0.0d0 nse_switch = 0 c write(6,*) 'both below' end if end if c write(6,119) x,xb,h,ttz,ddz c write(6,119) ttz1,ttz2,ttz,tlo,thi c 119 format(1x,1p6e24.16) c read(5,*) c t9 = ttz * 1.0d-9 c tau_nse = ddz**(0.2d0) * exp(179.7d0/t9 - 40.5d0) c tau_qse = exp(149.7d0/t9 - 39.15d0) c..initialize for what type of integration cmode = 'int' nse_on = 0 c..check for nse conditions c if (ttz .ge. 10.0e9 .and. h.gt.tau_nse .and. x.gt.tau_nse) then if (ttz .ge. nse_temp_switch ) then cmode = 'nse' nse_on = 1 call azbar(xdum,aion,zion,wion,ionmax, 1 zwork1,abar,zbar,wbar,ye,xcess) igues = 1 call nse(ttz,ddz,ye,igues,1,1,xdum,xmun,xmup,0) c..claim we did the requested time step x = x + h hdid = h c..estimate the next time step hnext = 1.0e30 ratio = 1.0d30 xfloor = 1.0e-5 ychangemax = 0.10d0 if (kount .ne. 1) then do i=1,ionmax ynew = xdum(i)/aion(i) yy = abs(ynew - y(i)) if (yy*ratio .gt. y(i) .and. y(i) .ge. xfloor) then ratio=y(i)/yy idt = i end if enddo end if hnext = min(ratio*h*ychangemax,2.0d0*h) if (nse_switch .eq. 1) then hnext = max(2.0d0*tol_switch,1.0d-2*hnext) end if if (hnext .eq. 2.0d0*h) idt = 0 c write(6,119) hnext c..update the abundance vector do i = 1,ionmax y(i) = xdum(i)/aion(i) end do c..end of nse if end if end if c..do an integration step if (nse_on .eq. 0) then call steper(y,dydx,ylogi,x,h,eps,yscal,hdid,hnext, 1 derivs,jakob,bjakob,nstp,idt) end if if (hdid.eq.h) then nok = nok+1 else nbad = nbad+1 end if c..this is the normal exit point, save the final step if ( (nstp .eq. stpmax) .or. 1 (x-stopp)*(stopp-start).ge. 0.0d0 .or. 3 (psi .ge. 1.0 .and. y(itemp) .lt. temp_stop) .or. 4 (psi .le. -1.0 .and. y(itemp) .gt. temp_stop) .or. 5 (detonation .and. y(iden) .lt. den_stop) .or. c 5 (detonation .and. abs(1.0d0-cs_cj/y(ivelx)).lt.1.0e-4) .or. 6 (y(id_stop)*aion(id_stop) .lt. xmass_stop) ) then c write(6,*) 'bailing' c write(6,*) id_stop,y(id_stop),aion(id_stop),xmass_stop c write(6,*) y(itemp),temp_stop c write(6,*) stopp do i=1,ylogi bc(i) = y(i) enddo kount = kount+1 c..detailed file print if (iprint_files .eq. 1) call net_output(kount,x,y,derivs) c..screen print if (iprint_screen .eq. 1) then call azbar(xdum,aion,zion,wion,ionmax, 1 zwork1,abar,zbar,wbar,ye,xcess) ttz = -1.0d0 ddz = -1.0d0 if (pure_network .eq. 0) then ttz = y(itemp) ddz = y(iden) else ttz = btemp ddz = bden end if if (trho_hist) call update2(x,ttz,ddz) call indexx(ionmax,xdum,izwork1) write(6,100) kount,cmode,' time',x, 1 ' dt(',cdtname,')',hdid,(ionam(izwork1(ii)), 2 xdum(izwork1(ii)),ii=ionmax,ionmax-2,-1), 3 ' temp',ttz,' den ',ddz,' enuc',sdot-sneut, 4 ' ye ',ye,' sum ',cons end if c call flush(6) c call flush_(6) return end if c..set the step size for the next iteration; stay above stpmin c dtx = 1.0e30 c if (kount .ne. 1) then c ratio = 1.0d30 c xfloor = 1.0e-10 c ychangemax = 0.05d0 c do i=1,ionmax c ynew = max(y(i),1.0d-20) c yold = ylast(i) c yy = abs(ynew - yold) c if (yy*ratio .gt. yold .and. yold .ge. xfloor) ratio=yold/yy c enddo c dtx = min(ratio*h*ychangemax,2.0d0*h) c end if c c h = min(hnext,dtx) c..limit timestep changes to a factor of two c h = min(hnext,2.0d0*h) c..normal timestep choice h = hnext if (abs(h).lt.stpmin) stop 'h < stpmin in netint' c..back for another iteration or death enddo stop 'more than stpmax steps required in netint' end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine net_input(tstart,tstep,tin,din,vin,zin,ein,xin) include 'implno.dek' include 'const.dek' include 'vector_eos.dek' include 'burn_common.dek' include 'network.dek' include 'cjdet.dek' c..declare the pass double precision tstart,tstep,tin,din,vin,zin,ein,xin(*) c..local variables character*80 string,word integer i,j,k,ibtype,ictype,igues,kkase,ians,getnam double precision xneut,xh1,xhe4,xc12,xc13,xn14,xo16,xne20,xne22, 1 xsi28,xfe52,xfe54,xfe56,xni56,zye,sum,abar,zbar, 2 wbar,xcess,ye,ye_orig,xmup,xmun,qdum,a,z,xelem, 3 andgrev,value c..bigbang specifics double precision fac,f1,zeta3 parameter (zeta3 = 1.20205690315732d0) c..popular format statements 01 format(1x,a,a,a) 02 format(1x,a,'=',1pe10.3,' ',a,'=',1pe10.3,' ', 1 a,'=',1pe10.3,' ',a,'=',1pe10.3,' ', 2 a,'=',1pe10.3) 03 format(a) 04 format(1x,a,'=',i2,' ',a,'=',i2,' ', 1 a,'=',i2,' ',a,'=',i2,' ', 2 a,'=',i2) c..initialize the common block variables call net_initialize c..inititailize local variables ibtype = 0 ictype = 0 tstart = 0.0d0 tstep = 0.0d0 bpres = 0.0d0 tin = 0.0d0 din = 0.0d0 vin = 0.0d0 zin = 0.0d0 zye = 0.0d0 do i=1,ionmax xin(i) = 1.0d-30 end do c--------------------------------------------------------------------------- c..get the burn type 10 write(6,01) 'give burning mode:' write(6,01) ' ibtype = 0 = stop' write(6,01) ' 1 = onestep' write(6,01) ' 2 = hydrostatic' write(6,01) ' 3 = expansion' write(6,01) ' 4 = self-heat at constant density' write(6,01) ' 5 = self heat at constant pressure' write(6,01) ' 6 = self-heat pressure-temp trajectory' write(6,01) ' 7 = big bang ' write(6,01) ' 8 = detonation' write(6,01) ' 9 = temp-den trajectory' read(5,*) ibtype if (ibtype .lt. 0 .or. ibtype .gt. 9) goto 10 c..set the burn type logical if (ibtype .eq. 0) then stop 'normal termination' else if (ibtype .eq. 1) then one_step = .true. else if (ibtype .eq. 2) then hydrostatic = .true. else if (ibtype .eq. 3) then expansion = .true. else if (ibtype .eq. 4) then self_heat_const_den = .true. else if (ibtype .eq. 5) then self_heat_const_pres = .true. else if (ibtype .eq. 6) then pt_hist = .true. else if (ibtype .eq. 7) then bbang = .true. else if (ibtype .eq. 8) then detonation = .true. else if (ibtype .eq. 9) then trho_hist = .true. else goto 10 end if c..general options 11 write(6,*) write(6,04) 'set general options:' write(6,04) 'screen_on',screen_on write(6,04) 'use_tables',use_tables write(6,04) 'weak_on',weak_on write(6,04) 'ffn_on',ffn_on write(6,04) 'pure_network',pure_network write(6,04) 'nse_analysis',nse_analysis write(6,04) 'allow_nse_evol',allow_nse_evol write(6,04) 'iprint_files',iprint_files write(6,04) 'iprint_screen',iprint_screen write(6,02) 'sthreshold',sthreshold,' set > 1 to disable' write(6,*) write(6,01) 'if these are ok, enter 1, otherwise enter 0 =>' read(5,*) ians if (ians .lt. 0 .or. ians .gt. 1) goto 11 if (ians .eq. 0) then 12 write(6,01) 'give the 9 integer and one real vector =>' read(5,*) screen_on, use_tables, weak_on, ffn_on, 1 pure_network, nse_analysis, allow_nse_evol, 2 iprint_files, iprint_screen, 3 sthreshold if (screen_on .lt. 0 .or. screen_on .gt. 1) goto 12 if (use_tables .lt. 0 .or. use_tables .gt. 1) goto 12 if (weak_on .lt. 0 .or. weak_on .gt. 1) goto 12 if (ffn_on .lt. 0 .or. ffn_on .gt. 1) goto 12 if (pure_network .lt. 0 .or. pure_network .gt. 1) goto 12 if (nse_analysis .lt. 0 .or. nse_analysis .gt. 1) goto 12 if (iprint_files .lt. 0 .or. iprint_files .gt. 1) goto 12 if (iprint_screen .lt. 0 .or. iprint_screen .gt. 1) goto 12 goto 11 end if c..get the bigbang parameters if (bbang) then eta1 = 4.0e-10 xnnu = 3.0d0 hubble = 65.0d0 cmbtemp = 2.73d0 13 write(6,*) write(6,02) 'bigbang parameters:' write(6,02) 'eta =',eta1 write(6,02) 'number of neutrino families = ',xnnu write(6,02) 'hubble constant = ',hubble write(6,02) 'present cmb temperature = ',cmbtemp write(6,01) 'if these are ok, enter 1, otherwise enter 0 =>' read(5,*) ians if (ians .lt. 0 .or. ians .gt. 1) goto 13 if (ians .eq. 0) then write(6,01) 'give eta, xnu, hubble, and cmbtemp =>' read(5,*) eta1, xnnu, hubble, cmbtemp goto 13 end if end if c..get an alternative the stopping condition; when the c..mass fraction of a given isotope falls below a given level 14 write(6,*) write(6,*) 'stop when an isotope falls below a given abundance?', 1 ' 1=yes 0=no' read(5,*) ians if (ians .lt. 0 .or. ians .gt. 1) goto 14 if (ians .eq. 0) then name_stop = 'he4 ' xmass_stop = -1.0d30 end if 15 if (ians .eq. 1) then write(6,*) 'give the name of the isotope and the mass fraction' write(6,*) 'for example: c12 0.50' read(5,03) string j = 1 i = getnam(string,word,j) name_stop = word(1:5) i = getnam(string,word,j) xmass_stop = value(word) write(6,*) name_stop,xmass_stop end if c..check that the name_stop isotope is in the network do i=1,ionmax if (ionam(i) .eq. name_stop) then id_stop = i goto 16 end if enddo write(6,*) 'name_stop not in network' write(6,*) goto 15 16 continue c..get the initial thermodynamics write(6,*) if (self_heat_const_pres) then write(6,01) 'give the ending time, temperature, pressure =>' read(5,*) tstep,tin,bpres else if (bbang) then write(6,01) 'give the ending time, initial temperature =>' read(5,*) tstep,tin else if (.not. (trho_hist .or. pt_hist)) then write(6,01) 'give the ending time, temperature, density =>' read(5,*) tstep,tin,din end if c..limit the temperature since the rates are invalid much above t9=100 tin = min(1.0d11,tin) c..get the composition if (.not. bbang) then 20 write(6,01) 'give initial composition:' write(6,01) ' ictype = 0 = leave alone; read from file' write(6,01) ' 1 = solar abundances' write(6,01) ' 2 = nse' write(6,01) ' 3 = specify initial composition' read(5,*) ictype if (ictype .lt. 0 .or. ictype .gt. 3) goto 20 if (ictype .eq. 3) then write(6,01) 1 'n h1 he4 c12 c13 n14 o16 ne20 ne22 si28 fe52 fe54 fe56 ni56 =>' read(5,*) xneut,xh1,xhe4,xc12,xc13,xn14,xo16,xne20,xne22,xsi28, 1 xfe52,xfe54,xfe56,xni56 end if end if c..get the output root file name write(6,*) ' ' write(6,01) 'give output root name, for default "foo_"=>' read(5,03) hfile if (hfile(1:2) .eq. ' ') hfile = 'foo_' c--------------------------------------------------------------------------- c..set some more variables based on the burn type c..adiabatic expansion c..psi = 1 is an adiabatic expansion, -1 in an adiabatic implosion if (expansion) then psi = 1.0d0 c psi = -1.0d0 den0 = din temp0 = tin temp_stop = 1.0d7 c temp_stop = 1.0d10 if ( (psi .ge. 1.0 .and. temp_stop .ge. tin) .or. 1 (psi .le. -1.0 .and. temp_stop .le. tin)) 2 stop 'bad adiabatic temp_stop in routine burner' c..big bang else if (bbang) then c..set the initial n and p abundances; equation 3 of wagoner et al 1967 fac = exp((mn - mp)*clight**2/(kerg*tin)) xneut = 1.0d0/(1.0d0 + fac) xh1 = 1.0d0 - xneut c..set the density from the temperature and eta1 f1 = 30.0d0 * zeta3/pi**4 * asol/(kerg*avo) din = f1 * eta1 * tin**3 c..thermodynamic profile being given else if (trho_hist .or. pt_hist) then write(6,*) 'give the trajectory file =>' read(5,03) trho_file end if c--------------------------------------------------------------------------- c..read the thermodynamic trajectory and initial abundances c..transfer the info stored in xsum and zsum from the update2 call if (trho_hist) then call update2(tstart,tin,din) do i=1,ionmax xin(i) = xsum(i) enddo tstart = zwork1(1) tstep = zwork1(2) zye = zwork1(3) end if if (pt_hist) then call update3(tstart,tin,bpres) do i=1,ionmax xin(i) = xsum(i) enddo tstart = zwork1(1) tstep = zwork1(2) zye = zwork1(3) end if c..massage the input composition, includes possible changes to the c..the abundances read in from the trho_hist file c..solar abundances if (ictype .eq. 1) then do i=1,ionmax xin(i) = andgrev(ionam(i),z,a,xelem) enddo if (iprot .ne. 0) xin(iprot) = andgrev('h1 ',z,a,xelem) c..put it in nse else if (ictype .eq. 2) then if (zye .eq. 0.0) zye = 0.5d0 igues = 1 call nse(tin,din,zye,igues,1,1,xin,xmun,xmup,0) c..set the composition variables else if (ictype .eq. 3 .or. bbang) then if (ineut .ne. 0) xin(ineut) = xneut if (ih1 .ne. 0) xin(ih1) = xh1 if (iprot .ne. 0) xin(iprot) = xh1 if (ih1 .ne. 0 .and. iprot .ne. 0) xin(iprot) = 0.0d0 if (ihe4 .ne. 0) xin(ihe4) = xhe4 if (ic12 .ne. 0) xin(ic12) = xc12 if (ic13 .ne. 0) xin(ic13) = xc13 if (in14 .ne. 0) xin(in14) = xn14 if (io16 .ne. 0) xin(io16) = xo16 if (ine20 .ne. 0) xin(ine20) = xne20 if (ine22 .ne. 0) xin(ine22) = xne22 if (isi28 .ne. 0) xin(isi28) = xsi28 if (ife52 .ne. 0) xin(ife52) = xfe52 if (ife54 .ne. 0) xin(ife54) = xfe54 if (ife56 .ne. 0) xin(ife56) = xfe56 if (ini56 .ne. 0) xin(ini56) = xni56 end if c..write out the input composition so far c write(6,02) (ionam(i),xin(i), i=1,ionmax) c read(5,*) c..normalize the composition do i=1,ionmax xin(i) = min(1.0d0,max(xin(i),1.0d-30)) end do sum = 0.0d0 do i=1,ionmax sum = sum + xin(i) enddo sum = 1.0d0/sum do i=1,ionmax xin(i) = min(1.0d0,max(xin(i) * sum,1.0d-30)) enddo c--------------------------------------------------------------------------- c..get the ye of the initial compositon call azbar(xin,aion,zion,wion,ionmax, 1 zwork1,abar,zbar,wbar,ye_orig,xcess) c..modify the composition if ye_orig is less than 0.55 c if (ye_orig .le. 0.55) then c c..set the mass fraction of fe58 to set the desired ye c ye_want = 0.495d0 c ye_want = 0.50d0 c if (ye_want .eq. 0.5) then c xin(ife58) = 0.0d0 c else c xin(ife58) = (ye_orig - ye_want) / c 1 (ye_orig - zion(ife58)/aion(ife58)) c end if c c..reset the mass fractions of everything else c sum = 1.0d0 - xin(ife58) c do i=1,ionmax c if (i .ne. ife58) xin(i) = xin(i) * sum c enddo c end if c--------------------------------------------------------------------------- c..modify for a detonation c..get the chapman-jouget solution if (detonation) then kkase = 1 mach = 0.0d0 do i=1,ionmax xmass_up(i) = xin(i) enddo temp_up = tin den_up = din call cjsolve(kkase,xmass_up,temp_up,den_up,mach, 1 qburn_cj,xmass_cj,ener_up,pres_up,cs_up, 2 vel_det,vel_cj,temp_cj,den_cj,ener_cj,pres_cj,cs_cj) write(6,*) ' ' write(6,63) 'cj state (should be sonic with vel_mat = cs_cj):' write(6,61) 'temp_cj',temp_cj,'den_cj ',den_cj, 1 'pres_cj',pres_cj write(6,61) 'cs_cj ',cs_cj, 2 'vel_mat',vel_cj,'vel_det',vel_det write(6,61) 'mach_cj',vel_cj/cs_cj,'qburn_cj',qburn_cj 63 format(1x,a) 61 format(1x,a7,'=',1pe10.3,' ',a7,'=',1pe10.3,' ', 1 a7,'=',1pe10.3,' ',a4,'=',1pe10.3) write(6,*) ' ' write(6,*) 'top 10 cj nse mass fractions:' call indexx(ionmax,xmass_cj,izwork1) write(6,02) (ionam(izwork1(i)), 1 xmass_cj(izwork1(i)), i=ionmax,ionmax-9,-1) c..get shock solution kkase = 4 mach_sh = vel_det/cs_up call cjsolve(kkase,xmass_up,temp_up,den_up,mach_sh, 1 qdum,xmass_up,ener_up,pres_up,cs_up, 2 vel_det,vel_sh,temp_sh,den_sh,ener_sh,pres_sh,cs_sh) c..reset the initial conditions for znd detonations tin = temp_sh din = den_sh vin = vel_sh zin = 1.0e-16*vel_sh den_stop = 1.00d0 * den_cj write(6,*) write(6,*) 'resetting initial conditions for a detonation to:' write(6,64) 'tin=',tin,' din=',din,' vin=',vin,' zin=',zin 64 format(1x,4(a,1pe12.4) ) end if c--------------------------------------------------------------------------- c..get the abundance variables for the final mixture call azbar(xin,aion,zion,wion,ionmax, 1 zwork1,abar,zbar,wbar,ye,xcess) c..get the thermodynamic state temp_row(1) = tin den_row(1) = din ptot_row(1) = bpres abar_row(1) = abar zbar_row(1) = zbar jlo_eos = 1 jhi_eos = 1 c write(6,*) tin,abar,zbar if (self_heat_const_pres .or. pt_hist) then den_row(1) = bpres * abar/(avo * kerg * tin) call invert_helm_pt din = den_row(1) c write(6,778) bpres,din c read(5,*) else call helmeos bpres = ptot_row(1) endif ein = etot_row(1) c--------------------------------------------------------------------------- c..write out the final input write(6,*) write(6,02) 'tstart',tstart,'tstep',tstep write(6,02) 'tin',tin,'din',din,'bpres',bpres,'ein',ein c..largest mass fractions call indexx(ionmax,xin,izwork1) j = min(20,ionmax) k = max(ionmax-19,1) write(6,*) j,' largest mass fractions' do i=ionmax,k,-1 if (xin(izwork1(i)) .gt. 1.0e-12) 1 write(6,02) ionam(izwork1(i)),xin(izwork1(i)) end do c..nonconservation, abar, zbar of the mixture sum = 0.0d0 do i=1,ionmax sum = sum + xin(i) enddo write(6,02) '1-sum',1.0d0 - sum write(6,02) 'abar',abar,'zbar',zbar,'ye',zbar/abar write(6,*) c read(5,*) c..there is probably a better place for this c..if requested, adjust the number of equations being solved if (pure_network .eq. 1) then neqs = ionmax btemp = tin bden = din end if return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- c.. c..this routine contains auxillary network routine c..routines for a tree construction to mark nonzero matrix locations c..routine screen6 computes screening factors c..routine screen5 computes screening factors c..routine snupp computes neutrino loss rates for the pp chain c..routine snucno computes neutrino loss rates for the cno cycles c..routine sneut5 computes neutrino loss rates c..routine ifermi12 does an inverse fermi integral of order 1/2 c..routine zfermim12 does an inverse fermi integral of order -1/2 c..routine ecapnuc02 computes electron capture rates c..routine ecapnuc computes electron capture rates c..routine mazurek computes ni56 electron capture rates c..routine time_scales computes various timescales c..interfaces to a balanced tree sort subroutine tree_init(n) implicit none common/locatdat/nmax integer nmax,n nmax=n+1 call avlinit(30*nmax+2048) return end subroutine tree(i,j,eloc,neloc,nterm,nzo,iloc,jloc,np) implicit none common/locatdat/nmax integer nmax integer i,j,neloc,eloc(neloc),nterm,nzo,np,iloc(np),jloc(np) integer iat,nzo_old nzo_old = nzo nterm = nterm + 1 if (nterm .gt. neloc) then write(6,10) 'nterm=',nterm write(6,10) 'neloc=',neloc 10 format(1x,a,' ',i6) stop 'nterm > neloc in routine tree' end if call avlinsert(i*nmax+j,iat,nzo) eloc(nterm) = iat if (nzo .gt. np) stop 'nzo > np in routine tree' if (nzo .ne. nzo_old) then eloc(nterm) = nzo iloc(nzo) = i jloc(nzo) = j end if return end subroutine tree_out(irow,icol,nzo,np) implicit none common/locatdat/nmax integer nmax,np,nzo,i,irow(np),icol(np) call avlgetlist(np,icol,nzo) call avlfree() do i=1,nzo irow(i)=icol(i)/nmax icol(i)=icol(i)-irow(i)*nmax enddo return end c.... AVL sort c.... c.... In 1960 two Russian mathematicians, Georgii Maksimovich c.... Adel'son-Vel'skii and Evgenii Mikhailovich Landis developed a c.... technique for keeping a binary search tree balanced as items are c.... inserted into it. called AVL trees. c.... c.... efficiently sort integers in N log N operations c.... c.... implemetation taken from c.... http://www.moorpark.cc.ca.us/~csalazar/cs20/nonlin.txt (buggy) c.... see also c.... http://swww.ee.uwa.edu.au/~plsd210/ds/AVL.html c.... http://www.purists.org/georg/avltree/ (my favorite site) c.... c.... implemented by Alexander Heger, 20010129 c.... avldelete by Alexander Heger, 20010205 c======================================================================= c======================================================================= MODULE avl_data implicit none c integer, parameter :: maxavldata = 65536 integer :: maxavldata integer, parameter :: maxavlindex = 4 integer, parameter :: NULL = 0 integer, parameter :: l_LEFT = 1 integer, parameter :: l_RIGHT = l_LEFT+1 ! do not change integer, parameter :: l_BAL = 3 integer, parameter :: l_KEY = 4 integer, parameter :: i_ROOT = 1 integer, parameter :: i_NODEOFFSET = 1 integer, parameter :: l_ROOT = l_RIGHT integer, parameter :: l_RIGHTHEAVY = 1 ! do not change integer, parameter :: l_BALANCED = 0 ! do not change integer, parameter :: l_LEFTHEAVY = -l_RIGHTHEAVY integer, parameter :: l_UNBALANCED = l_BALANCED+1 integer, parameter :: l_GARBAGE = l_LEFT c.... tree data integer :: maxel integer :: garbage c integer, dimension(maxavlindex,maxavldata) :: ichild integer, allocatable, dimension(:,:) :: ichild SAVE END MODULE avl_data c======================================================================= MODULE avl_stack implicit none integer, parameter :: maxdepth = 48 integer, parameter :: i_STACKBASE = 1 integer, dimension(maxdepth) :: istack,lrstack integer :: ipstack END MODULE avl_stack c======================================================================= subroutine avlinit(nmax) USE avl_data implicit none integer, intent(IN) :: nmax SELECT CASE (nmax) CASE (1:) maxavldata=nmax+1 CASE (0) maxavldata=1024 END SELECT IF (nmax >= 0) THEN CALL avlfree() ALLOCATE(ichild(maxavlindex,maxavldata)) ENDIF c.... initialize root pointer and zero number of elements ichild(l_ROOT,i_ROOT)=NULL maxel=0 c.... initialize garbage list garbage=NULL end c======================================================================= subroutine avlfree() USE avl_data implicit none IF (ALLOCATED(ichild)) DEALLOCATE(ichild) end c======================================================================= subroutine avlgetlist(nmax,list,n) USE avl_data USE avl_stack implicit none c.... some constants integer, intent(IN) :: nmax integer, dimension(nmax), intent(OUT) :: list integer, intent(OUT) :: n c.... running variables integer :: i, lr, ii n=0 i=ichild(l_ROOT,i_ROOT) IF (i == NULL) RETURN IF (nmax < maxel) THEN WRITE(*,"(' [AVL LIST] ERROR: list too small for data.')") n=-1 RETURN ENDIF c.... recursively traverse tree to get sorted list of key values ipstack=i_STACKBASE-1 lr=l_LEFT DO IF (lr <= l_LEFT) THEN c.... add left branch ii=ichild(l_LEFT,i) IF (ii /= NULL) THEN ipstack=ipstack+1 istack(ipstack)=i lrstack(ipstack)=l_RIGHT i=ii lr=l_LEFT CYCLE ENDIF ENDIF IF (lr <= l_RIGHT) THEN c.... add node n=n+1 list(n)=ichild(l_KEY,i) c.... add right branch ii=ichild(l_RIGHT,i) IF (ii /= NULL) THEN ipstack=ipstack+1 istack(ipstack)=i lrstack(ipstack)=l_RIGHT+1 i=ii lr=l_LEFT CYCLE ENDIF ENDIF IF (ipstack < i_STACKBASE) EXIT i=istack(ipstack) lr=lrstack(ipstack) ipstack=ipstack-1 ENDDO IF (n /= maxel) THEN WRITE(*,"(' [AVL LIST] ERROR in AVL data.')") n=-1 RETURN ENDIF END c======================================================================= subroutine avltree() USE avl_data USE avl_stack implicit none c.... some constants character*(*), parameter :: form = "(I5)" integer, parameter :: nwidth = 5 integer, parameter :: nmax = 1024 c.... running variables integer, dimension(nmax) :: level, index character*(nwidth*nmax),dimension(5,maxdepth+1) :: line character*(nwidth) :: item integer :: i, lr, ii integer :: n, maxlevel integer :: l1,l2 IF (nmax < maxel) THEN WRITE(*,"(' [AVL TREE] ERROR: too much data.')") RETURN ENDIF n=0 maxlevel=0 i=ichild(l_ROOT,i_ROOT) IF (i == NULL) RETURN c.... recursively traverse tree to get sorted list of key values ipstack=i_STACKBASE-1 lr=l_LEFT DO IF (lr <= l_LEFT) THEN c.... add left branch ii=ichild(l_LEFT,i) IF (ii /= NULL) THEN ipstack=ipstack+1 istack(ipstack)=i lrstack(ipstack)=l_RIGHT i=ii lr=l_LEFT CYCLE ENDIF ENDIF IF (lr <= l_RIGHT) THEN c.... add node n=n+1 index(n)=i level(n)=ipstack+1 maxlevel=MAX(maxlevel,ipstack+1) c.... add right branch ii=ichild(l_RIGHT,i) IF (ii /= NULL) THEN ipstack=ipstack+1 istack(ipstack)=i lrstack(ipstack)=l_RIGHT+1 i=ii lr=l_LEFT CYCLE ENDIF ENDIF IF (ipstack < i_STACKBASE) EXIT i=istack(ipstack) lr=lrstack(ipstack) ipstack=ipstack-1 ENDDO line=" " DO i=1,n l1=1+nwidth*(i-1) l2=nwidth*i write(item,form) index(i) line(1,level(i))(l1:l2)=item write(item,form) ichild(l_KEY,index(i)) line(2,level(i))(l1:l2)=item write(item,form) ichild(l_BAL,index(i)) line(3,level(i))(l1:l2)=item write(item,form) ichild(l_LEFT,index(i)) line(4,level(i))(l1:l2)=item write(item,form) ichild(l_RIGHT,index(i)) line(5,level(i))(l1:l2)=item line(1,maxlevel+1)(l1:l2)='------------' ENDDO WRITE(*,"(A)") line(1,maxlevel+1)(1:nwidth*n)//"|" DO ii=1,maxlevel DO i=1,5 WRITE(*,"(A)") line(i,ii)(1:nwidth*n)//"|" ENDDO ENDDO WRITE(*,"(A)") line(1,maxlevel+1)(1:nwidth*n)//"|" END c======================================================================= subroutine avlincrease USE avl_data implicit none integer, allocatable, dimension(:,:) :: ichild_temp c integer, dimension(:,:) :: ichild_temp ALLOCATE(ichild_temp(maxavlindex,maxavldata)) ichild_temp(:,:)=ichild(:,:) DEALLOCATE(ichild) maxavldata=maxavldata*2 ALLOCATE(ichild(maxavlindex,maxavldata)) ichild(:,:)=ichild_temp(:,:) DEALLOCATE(ichild_temp) WRITE (*,"(' [AVL INCREASE] INFO: now ',I8,' elements.')") & maxavldata end c======================================================================= subroutine avlinsert(key,ijk,nzo) USE avl_data USE avl_stack implicit none integer, intent(IN) :: key integer, intent(OUT):: ijk,nzo integer :: i, ii, lr, irevbal, ic, ip, lrs, lri ijk = 1 i=i_root lr=l_ROOT ii=ichild(lr,i) ipstack=i_STACKBASE istack(ipstack)=i lrstack(ipstack)=lr c.... find location and insert DO WHILE (ii /= NULL) i=ii ijk = i c write(6,*) ijk SELECT CASE (key - ichild(l_KEY,i)) CASE (0) c write(6,*) 'same as ',ijk-1 ijk = ijk - 1 RETURN ! element already present: done. CASE (:-1) lr=l_LEFT CASE DEFAULT lr=l_RIGHT END SELECT ipstack=ipstack+1 istack(ipstack)=i lrstack(ipstack)=lr ii=ichild(lr,i) ENDDO c.... initialize new element maxel=maxel+1 nzo = maxel IF (garbage /= NULL) THEN ii=garbage garbage=ichild(l_GARBAGE,garbage) ELSE IF (maxel == maxavldata-1) CALL avlincrease ii=maxel+i_NODEOFFSET ENDIF ichild(lr,i)=ii ichild(l_KEY,ii)=key ichild(l_BAL,ii)=l_BALANCED ichild(l_LEFT:l_RIGHT,ii)=NULL c.... balance tree irevbal=l_UNBALANCED DO WHILE ((ipstack > i_STACKBASE) .AND. (irevbal /= l_BALANCED)) i=istack(ipstack) lr=lrstack(ipstack) ipstack=ipstack-1 lri=(l_LEFT+l_RIGHT)-lr ! pointer to the opposite direction ! sign for balance determination lrs=2*lr-(l_LEFT+l_RIGHT) SELECT CASE (ichild(l_BAL,i)*lrs) CASE (l_LEFTHEAVY) ichild(l_BAL,i)=l_BALANCED irevbal=l_BALANCED CASE (l_BALANCED) ichild(l_BAL,i)=lrs CASE DEFAULT c.... update tree ic=ichild(lr,i) IF (ichild(l_BAL,ic) == lrs) THEN c.... single rotation ichild(l_BAL,i)=l_BALANCED ichild(l_BAL,ic)=l_BALANCED ichild(lr,i)=ichild(lri,ic) ichild(lri,ic)=i ichild(lrstack(ipstack),istack(ipstack))=ic ELSE IF (ichild(l_BAL,ic) == -lrs) THEN c.... double rotation ip=ichild(lri,ic) SELECT CASE (ichild(l_BAL,ip)*lrs) CASE (l_LEFTHEAVY) ichild(l_BAL,i)=l_BALANCED ichild(l_BAL,ic)=lrs CASE (l_BALANCED) ichild(l_BAL,i)=l_BALANCED ichild(l_BAL,ic)=l_BALANCED CASE DEFAULT ichild(l_BAL,i)=-lrs ichild(l_BAL,ic)=l_BALANCED END SELECT ichild(l_BAL,ip)=l_BALANCED ichild(lri,ic)=ichild(lr,ip) ichild(lr,ip)=ic ichild(lr,i)=ichild(lri,ip) ichild(lri,ip)=i ichild(lrstack(ipstack),istack(ipstack))=ip ENDIF irevbal=l_BALANCED END SELECT ENDDO END c======================================================================= subroutine avldelete(key) USE avl_data USE avl_stack implicit none integer, intent(IN) :: key integer :: i, ii, lr, irevbal, ic, ip, lrs, lri, i0, ipstack0 lr=l_ROOT ipstack=i_STACKBASE istack(ipstack)=i_ROOT lrstack(ipstack)=l_ROOT i=ichild(l_ROOT,i_ROOT) c.... find location to delete DO IF (i == NULL) RETURN ! element not present SELECT CASE (key - ichild(l_KEY,i)) CASE (0) EXIT ! element found CASE (:-1) lr=l_LEFT CASE DEFAULT lr=l_RIGHT END SELECT ipstack=ipstack+1 istack(ipstack)=i lrstack(ipstack)=lr i=ichild(lr,i) ENDDO i0=i c.... find closest element to replace it c.... decide whether to take left or right branch SELECT CASE (ichild(l_BAL,i)) CASE (l_LEFTHEAVY) lri=l_LEFT CASE (l_RIGHTHEAVY) lri=l_RIGHT CASE DEFAULT lri=(l_LEFT+l_RIGHT)-lr END SELECT c.... now search for it ii=ichild(lri,i) IF (ii /= NULL) THEN ipstack0=ipstack c.... go one step in lrx direction ipstack=ipstack+1 istack(ipstack)=i lrstack(ipstack)=lri c.... now seach element most in opposite direction lr=(l_LEFT+l_RIGHT)-lri i=ii ii=ichild(lr,i) DO WHILE (ii /= NULL) ipstack=ipstack+1 istack(ipstack)=i lrstack(ipstack)=lr i=ii ii=ichild(lr,i) ENDDO c.... found element to swap c.... do swap ic=ichild(lri,i) ichild(lri,i)=ichild(lri,i0) ichild(lr,i)=ichild(lr,i0) ichild(l_BAL,i)=ichild(l_BAL,i0) ichild(lrstack(ipstack0),istack(ipstack0))=i c.... CORRECT STACK istack(ipstack0+1)=i ichild(lrstack(ipstack),istack(ipstack))=ic ELSE c.... element last of chain c.... just remove it ic=NULL ENDIF c.... move rest of branch one level up ichild(lrstack(ipstack),istack(ipstack))=ic c.... (i): balance=balance - lrs c.... start regular re-balancing loop irevbal=l_UNBALANCED DO WHILE ((ipstack > i_STACKBASE) .AND. (irevbal /= l_BALANCED)) i=istack(ipstack) lr=lrstack(ipstack) ipstack=ipstack-1 c.... lri=(l_LEFT+l_RIGHT)-lr lrs=2*lr-(l_LEFT+l_RIGHT) SELECT CASE (ichild(l_BAL,i)*lrs) CASE (l_RIGHTHEAVY) ichild(l_BAL,i)=l_BALANCED CASE (l_BALANCED) ichild(l_BAL,i)=-lrs irevbal=l_BALANCED CASE DEFAULT c.... update tree ic=ichild(lri,i) IF (ichild(l_BAL,ic) == lrs) THEN c.... double rotation ip=ichild(lr,ic) SELECT CASE (ichild(l_BAL,ip)*lrs) CASE (l_RIGHTHEAVY) ichild(l_BAL,i)=l_BALANCED ichild(l_BAL,ic)=-lrs CASE (l_LEFTHEAVY) ichild(l_BAL,i)=lrs ichild(l_BAL,ic)=l_BALANCED CASE DEFAULT ichild(l_BAL,i)=l_BALANCED ichild(l_BAL,ic)=l_BALANCED END SELECT ichild(l_BAL,ip)=l_BALANCED ichild(lri,i)=ichild(lr,ip) ichild(lr,ip)=i ichild(lr,ic)=ichild(lri,ip) ichild(lri,ip)=ic ichild(lrstack(ipstack),istack(ipstack))=ip ELSE c.... single rotation IF (ichild(l_BAL,ic) == l_BALANCED) THEN ichild(l_BAL,i)=-lrs ichild(l_BAL,ic)=lrs irevbal=l_BALANCED ELSE ichild(l_BAL,i)=l_BALANCED ichild(l_BAL,ic)=l_BALANCED ENDIF ichild(lri,i)=ichild(lr,ic) ichild(lr,ic)=i ichild(lrstack(ipstack),istack(ipstack))=ic ENDIF END SELECT ENDDO c.... free element ichild(l_GARBAGE,i0)=garbage garbage=i0 maxel=maxel-1 END subroutine screen6(jscreen, 1 temp,den,zbar,abar,z2bar, 1 z1,a1,z2,a2, 2 scor,scordt,scordd) include 'implno.dek' include 'const.dek' include 'network.dek' c..this subroutine calculates screening factors and their derivatives c..for nuclear reaction rates in the weak, intermediate and strong regimes. c..based on graboske, dewit, grossman and cooper apj 181 457 1973 for c..weak screening. based on alastuey and jancovici apj 226 1034 1978, c..with plasma parameters from itoh et al apj 234 1079 1979, for strong c..screening. c..vector version c..input: c..jscreen = length of vector c..temp = temperature c..den = density c..zbar = mean charge per nucleus c..abar = mean number of nucleons per nucleus c..z2bar = mean square charge per nucleus c..z1 a1 = charge and number in the entrance channel c..z2 a2 = charge and number in the exit channel c..output: c..scor = screening correction c..scordt = derivative of screening correction with temperature c..scordd = derivative of screening correction with density c..declare the pass integer jscreen double precision temp,den,zbar,abar,z2bar, 1 z1(jscreen),a1(jscreen),z2(jscreen),a2(jscreen), 2 scor(jscreen),scordt(jscreen),scordd(jscreen) c..local variables integer i,init double precision bb,cc,dccdt,dccdd, 1 pp,dppdt,dppdd,qq,dqqdt,dqqdd,rr,drrdt,drrdd, 2 ss,dssdt,dssdd,tt,dttdt,dttdd,uu,duudt,duudd, 3 vv,dvvdt,dvvdd,a3,da3,tempi,dtempi,deni, 4 qlam0z,qlam0zdt,qlam0zdd, 5 h12w,dh12wdt,dh12wdd,h12,dh12dt,dh12dd, 6 h12x,dh12xdt,dh12xdd,alfa,beta, 7 taufac,taufacdt,gamp,gampdt,gampdd, 8 gamef,gamefdt,gamefdd, 9 tau12,tau12dt,alph12,alph12dt,alph12dd, & xlgfac,dxlgfacdt,dxlgfacdd, 1 gamp14,gamp14dt,gamp14dd, 2 xni,dxnidd,ytot c..screening variables c..zs13 = (z1+z2)**(1./3.) c..zhat = combination of z1 and z2 raised to the 5/3 power c..zhat2 = combination of z1 and z2 raised to the 5/12 power c..lzav = log of effective charge c..aznut = combination of a1,z1,a2,z2 raised to 1/3 power integer nscreen_max parameter (nscreen_max = 2*abignet + 40) double precision zs13(nscreen_max),zhat(nscreen_max), 1 zhat2(nscreen_max),lzav(nscreen_max), 2 aznut(nscreen_max),zs13inv(nscreen_max), 3 fac1(nscreen_max),fac2(nscreen_max), 4 h12_vec(nscreen_max), 5 dh12dt_vec(nscreen_max), 6 dh12dd_vec(nscreen_max) c..parameter fact is the cube root of 2 double precision x13,x14,x53,x532,x512,fact,co2,gamefx,gamefs, 1 blend_frac parameter (x13 = 1.0d0/3.0d0, 1 x14 = 1.0d0/4.0d0, 3 x53 = 5.0d0/3.0d0, 4 x532 = 5.0d0/32.0d0, 5 x512 = 5.0d0/12.0d0, 6 fact = 1.25992104989487d0, 7 co2 = x13 * 4.248719d3, 8 gamefx = 0.3d0, 9 gamefs = 0.8d0, & blend_frac = 0.05d0) data init/0/ c..compute and store the more expensive screening factors if (init .eq. 0) then init = 1 if (jscreen .gt. nscreen_max) 1 stop 'jscreen > nscreen_max in screen6' do i=1,jscreen zs13(i) = (z1(i) + z2(i))**x13 zs13inv(i) = 1.0d0/zs13(i) zhat(i) = (z1(i) + z2(i))**x53 - z1(i)**x53 - z2(i)**x53 zhat2(i) = (z1(i) + z2(i))**x512 - z1(i)**x512 -z2(i)**x512 lzav(i) = x53 * log(z1(i)*z2(i)/(z1(i) + z2(i))) aznut(i) = (z1(i)**2*z2(i)**2*a1(i)*a2(i)/(a1(i)+a2(i)))**x13 fac1(i) = 0.896434d0 * zhat(i) fac2(i) = 3.44740d0 * zhat2(i) enddo endif c..calculate average plasma ytot = 1.0d0/abar rr = den * ytot tempi = 1.0d0/temp dtempi = -tempi*tempi deni = 1.0d0/den pp = sqrt(rr*tempi*(z2bar + zbar)) qq = 0.5d0/pp *(z2bar + zbar) dppdt = qq*rr*dtempi dppdd = qq*ytot*tempi qlam0z = 1.88d8 * tempi * pp qlam0zdt = 1.88d8 * (dtempi*pp + tempi*dppdt) qlam0zdd = 1.88d8 * tempi * dppdd taufac = co2 * tempi**x13 taufacdt = -x13*taufac*tempi qq = rr * zbar xni = qq**x13 dxnidd = x13 * xni * deni gamp = 2.27493d5 * tempi * xni gampdt = 2.27493d5 * dtempi * xni gampdd = 2.27493d5 * tempi * dxnidd c..calculate individual screening factors, start the pipeline do i=1,jscreen bb = z1(i) * z2(i) qq = fact * bb * zs13inv(i) gamef = qq * gamp gamefdt = qq * gampdt gamefdd = qq * gampdd tau12 = taufac * aznut(i) tau12dt = taufacdt * aznut(i) qq = 1.0d0/tau12 alph12 = gamef * qq alph12dt = (gamefdt - alph12*tau12dt) * qq alph12dd = gamefdd * qq c..limit alph12 to 1.6 to prevent unphysical behavior. c..this should really be replaced by a pycnonuclear reaction rate formula if (alph12 .gt. 1.6) then alph12 = 1.6d0 alph12dt = 0.0d0 alph12dd = 0.0d0 gamef = 1.6d0 * tau12 gamefdt = 1.6d0 * tau12dt gamefdd = 0.0d0 qq = zs13(i)/(fact * bb) gamp = gamef * qq gampdt = gamefdt * qq gampdd = 0.0d0 end if c..weak screening regime h12w = bb * qlam0z dh12wdt = bb * qlam0zdt dh12wdd = bb * qlam0zdd h12 = h12w dh12dt = dh12wdt dh12dd = dh12wdd c..intermediate and strong sceening regime if (gamef .gt. gamefx) then qq = sqrt(gamp) gamp14 = sqrt(qq) rr = 1.0d0/gamp qq = 0.25d0*gamp14*rr gamp14dt = qq * gampdt gamp14dd = qq * gampdd cc = gamp * fac1(i) - gamp14 * fac2(i) 1 - 0.5551d0 * (log(gamp) + lzav(i)) 2 - 2.996d0 dccdt = gampdt * fac1(i) - gamp14dt * fac2(i) 1 - 0.5551d0*rr*gampdt dccdd = gampdd * fac1(i) - gamp14dd * fac2(i) 1 - 0.5551d0*rr*gampdd qq = alph12 * alph12 a3 = qq * alph12 da3 = 3.0d0 * qq qq = 0.014d0 + 0.0128d0*alph12 dqqdt = 0.0128d0*alph12dt dqqdd = 0.0128d0*alph12dd rr = x532 - alph12*qq drrdt = -(alph12dt*qq + alph12*dqqdt) drrdd = -(alph12dd*qq + alph12*dqqdd) ss = tau12*rr dssdt = tau12dt*rr + tau12*drrdt dssdd = tau12*drrdd tt = -0.0098d0 + 0.0048d0*alph12 dttdt = 0.0048d0*alph12dt dttdd = 0.0048d0*alph12dd uu = 0.0055d0 + alph12*tt duudt = alph12dt*tt + alph12*dttdt duudd = alph12dd*tt + alph12*dttdd vv = gamef * alph12 * uu dvvdt= gamefdt*alph12*uu + gamef*(alph12dt*uu + alph12*duudt) dvvdd= gamefdd*alph12*uu + gamef*(alph12dd*uu + alph12*duudd) h12 = cc - a3 * (ss + vv) rr = da3 * (ss + vv) dh12dt = dccdt - rr*alph12dt - a3*(dssdt + dvvdt) dh12dd = dccdd - rr*alph12dd - a3*(dssdd + dvvdd) rr = 1.0d0 - 0.0562d0*a3 ss = -0.0562d0*da3 drrdt = ss*alph12dt drrdd = ss*alph12dd if (rr .ge. 0.77d0) then xlgfac = rr dxlgfacdt = drrdt dxlgfacdd = drrdd else xlgfac = 0.77d0 dxlgfacdt = 0.0d0 dxlgfacdd = 0.0d0 end if h12 = log(xlgfac) + h12 rr = 1.0d0/xlgfac dh12dt = rr*dxlgfacdt + dh12dt dh12dd = rr*dxlgfacdd + dh12dd if (gamef .le. gamefs) then rr = 2.0d0*(gamefs - gamef) drrdt = -2.0d0*gamefdt drrdd = -2.0d0*gamefdd ss = 2.0d0*(gamef-gamefx) dssdt = 2.0d0*gamefdt dssdd = 2.0d0*gamefdd c..store current values for possible blending h12x = h12 dh12xdt = dh12dt dh12xdd = dh12dd vv = h12 h12 = h12w*rr + vv*ss dh12dt = dh12wdt*rr + h12w*drrdt + dh12dt*ss + vv*dssdt dh12dd = dh12wdd*rr + h12w*drrdd + dh12dd*ss + vv*dssdd c..blend the transition region - from bill paxton if (gamefs - gamef .lt. blend_frac*(gamefs - gamefx)) then alfa = (gamefs - gamef) / (blend_frac*(gamefs - gamefx)) alfa = 0.5d0 * (1d0 - cos(pi*alfa)) beta = 1.0d0 - alfa h12 = alfa * h12 + beta * h12x dh12dt = alfa * dh12dt + beta * dh12xdt dh12dd = alfa * dh12dd + beta * dh12xdd end if end if c..end of intermediate and strong screening if end if c..store what we got h12 = max(min(h12,300.0d0),0.0d0) if (h12 .eq. 300.0d0) then dh12dt = 0.0d0 dh12dt = 0.0d0 end if scor(i) = exp(h12) scordt(i) = scor(i) * dh12dt scordd(i) = scor(i) * dh12dd c h12_vec(i) = h12 c dh12dt_vec(i) = dh12dt c dh12dt_vec(i) = dh12dd c scor(i) = exp(h12_vec(i)) c scordt(i) = scor(i) * dh12dt_vec(i) c scordd(i) = scor(i) * dh12dd_vec(i) c..end of individual screening pipeline end do c..crank the exponential c do i=1,jscreen c scor(i) = exp(h12_vec(i)) c enddo c do i=1,jscreen c scordt(i) = scor(i) * dh12dt_vec(i) c enddo c do i=1,jscreen c scordd(i) = scor(i) * dh12dd_vec(i) c enddo return end subroutine screen5(temp,den,zbar,abar,z2bar, 1 z1,a1,z2,a2,jscreen,init, 2 scor,scordt,scordd) include 'implno.dek' include 'const.dek' include 'network.dek' c..this subroutine calculates screening factors and their derivatives c..for nuclear reaction rates in the weak, intermediate and strong regimes. c..based on graboske, dewit, grossman and cooper apj 181 457 1973 for c..weak screening. based on alastuey and jancovici apj 226 1034 1978, c..with plasma parameters from itoh et al apj 234 1079 1979, for strong c..screening. c..input: c..temp = temperature c..den = density c..zbar = mean charge per nucleus c..abar = mean number of nucleons per nucleus c..z2bar = mean square charge per nucleus c..z1 a1 = charge and number in the entrance channel c..z2 a2 = charge and number in the exit channel c..jscreen = counter of which reaction is being calculated c..init = flag to compute the more expensive functions just once c..output: c..scor = screening correction c..scordt = derivative of screening correction with temperature c..scordd = derivative of screening correction with density c..declare the pass integer jscreen,init double precision temp,den,zbar,abar,z2bar,z1,a1,z2,a2, 1 scor,scordt,scordd c..local variables double precision aa,daadt,daadd,bb,cc,dccdt,dccdd, 1 pp,dppdt,dppdd,qq,dqqdt,dqqdd,rr,drrdt,drrdd, 2 ss,dssdt,dssdd,tt,dttdt,dttdd,uu,duudt,duudd, 3 vv,dvvdt,dvvdd,a3,da3,tempi,dtempi,deni, 4 qlam0z,qlam0zdt,qlam0zdd, 5 h12w,dh12wdt,dh12wdd,h12,dh12dt,dh12dd, 6 h12x,dh12xdt,dh12xdd,alfa,beta, 7 taufac,taufacdt,gamp,gampdt,gampdd, 8 gamef,gamefdt,gamefdd, 9 tau12,tau12dt,alph12,alph12dt,alph12dd, & xlgfac,dxlgfacdt,dxlgfacdd, 1 gamp14,gamp14dt,gamp14dd, 2 xni,dxnidd,ytot, 3 temp_old,den_old,zbar_old,abar_old c..screening variables c..zs13 = (z1+z2)**(1./3.) c..zhat = combination of z1 and z2 raised to the 5/3 power c..zhat2 = combination of z1 and z2 raised to the 5/12 power c..lzav = log of effective charge c..aznut = combination of a1,z1,a2,z2 raised to 1/3 power integer nscreen_max parameter (nscreen_max = 2*abignet + 40) double precision zs13(nscreen_max),zhat(nscreen_max), 1 zhat2(nscreen_max),lzav(nscreen_max), 2 aznut(nscreen_max),zs13inv(nscreen_max) c..parameter fact is the cube root of 2 double precision x13,x14,x53,x532,x512,fact,co2,gamefx,gamefs, 1 blend_frac parameter (x13 = 1.0d0/3.0d0, 1 x14 = 1.0d0/4.0d0, 3 x53 = 5.0d0/3.0d0, 4 x532 = 5.0d0/32.0d0, 5 x512 = 5.0d0/12.0d0, 6 fact = 1.25992104989487d0, 7 co2 = x13 * 4.248719d3, 8 gamefx = 0.3d0, 9 gamefs = 0.8d0, & blend_frac = 0.05d0) data temp_old/-1.0d0/, den_old/-1.0d0/, 1 zbar_old/-1.0d0/, abar_old/-1.0d0/ c..compute and store the more expensive screening factors if (init .eq. 1) then if (jscreen .gt. nscreen_max) 1 stop 'jscreen > nscreen_max in screen5' zs13(jscreen) = (z1 + z2)**x13 zs13inv(jscreen) = 1.0d0/zs13(jscreen) zhat(jscreen) = (z1 + z2)**x53 - z1**x53 - z2**x53 zhat2(jscreen) = (z1 + z2)**x512 - z1**x512 -z2**x512 lzav(jscreen) = x53 * log(z1*z2/(z1 + z2)) aznut(jscreen) = (z1**2 * z2**2 * a1*a2 / (a1 + a2))**x13 endif c..calculate average plasma, if need be if (temp_old .ne. temp .or. 1 den_old .ne. den .or. 2 zbar_old .ne. zbar .or. 3 abar_old .ne. abar ) then temp_old = temp den_old = den zbar_old = zbar abar_old = abar ytot = 1.0d0/abar rr = den * ytot tempi = 1.0d0/temp dtempi = -tempi*tempi deni = 1.0d0/den pp = sqrt(rr*tempi*(z2bar + zbar)) qq = 0.5d0/pp *(z2bar + zbar) dppdt = qq*rr*dtempi dppdd = qq*ytot*tempi qlam0z = 1.88d8 * tempi * pp qlam0zdt = 1.88d8 * (dtempi*pp + tempi*dppdt) qlam0zdd = 1.88d8 * tempi * dppdd taufac = co2 * tempi**x13 taufacdt = -x13*taufac*tempi qq = rr*zbar xni = qq**x13 dxnidd = x13 * xni * deni aa = 2.27493d5 * tempi * xni daadt = 2.27493d5 * dtempi * xni daadd = 2.27493d5 * tempi * dxnidd end if c..calculate individual screening factors bb = z1 * z2 gamp = aa gampdt = daadt gampdd = daadd qq = fact * bb * zs13inv(jscreen) gamef = qq * gamp gamefdt = qq * gampdt gamefdd = qq * gampdd tau12 = taufac * aznut(jscreen) tau12dt = taufacdt * aznut(jscreen) qq = 1.0d0/tau12 alph12 = gamef * qq alph12dt = (gamefdt - alph12*tau12dt) * qq alph12dd = gamefdd * qq c..limit alph12 to 1.6 to prevent unphysical behavior. c..this should really be replaced by a pycnonuclear reaction rate formula if (alph12 .gt. 1.6) then alph12 = 1.6d0 alph12dt = 0.0d0 alph12dd = 0.0d0 gamef = 1.6d0 * tau12 gamefdt = 1.6d0 * tau12dt gamefdd = 0.0d0 qq = zs13(jscreen)/(fact * bb) gamp = gamef * qq gampdt = gamefdt * qq gampdd = 0.0d0 end if c..weak screening regime h12w = bb * qlam0z dh12wdt = bb * qlam0zdt dh12wdd = bb * qlam0zdd h12 = h12w dh12dt = dh12wdt dh12dd = dh12wdd c..intermediate and strong sceening regime if (gamef .gt. gamefx) then gamp14 = gamp**x14 rr = 1.0d0/gamp qq = 0.25d0*gamp14*rr gamp14dt = qq * gampdt gamp14dd = qq * gampdd cc = 0.896434d0 * gamp * zhat(jscreen) 1 - 3.44740d0 * gamp14 * zhat2(jscreen) 2 - 0.5551d0 * (log(gamp) + lzav(jscreen)) 3 - 2.996d0 dccdt = 0.896434d0 * gampdt * zhat(jscreen) 1 - 3.44740d0 * gamp14dt * zhat2(jscreen) 2 - 0.5551d0*rr*gampdt dccdd = 0.896434d0 * gampdd * zhat(jscreen) 1 - 3.44740d0 * gamp14dd * zhat2(jscreen) 2 - 0.5551d0*rr*gampdd a3 = alph12 * alph12 * alph12 da3 = 3.0d0 * alph12 * alph12 qq = 0.014d0 + 0.0128d0*alph12 dqqdt = 0.0128d0*alph12dt dqqdd = 0.0128d0*alph12dd rr = x532 - alph12*qq drrdt = -(alph12dt*qq + alph12*dqqdt) drrdd = -(alph12dd*qq + alph12*dqqdd) ss = tau12*rr dssdt = tau12dt*rr + tau12*drrdt dssdd = tau12*drrdd tt = -0.0098d0 + 0.0048d0*alph12 dttdt = 0.0048d0*alph12dt dttdd = 0.0048d0*alph12dd uu = 0.0055d0 + alph12*tt duudt = alph12dt*tt + alph12*dttdt duudd = alph12dd*tt + alph12*dttdd vv = gamef * alph12 * uu dvvdt= gamefdt*alph12*uu + gamef*alph12dt*uu + gamef*alph12*duudt dvvdd= gamefdd*alph12*uu + gamef*alph12dd*uu + gamef*alph12*duudd h12 = cc - a3 * (ss + vv) rr = da3 * (ss + vv) dh12dt = dccdt - rr*alph12dt - a3*(dssdt + dvvdt) dh12dd = dccdd - rr*alph12dd - a3*(dssdd + dvvdd) rr = 1.0d0 - 0.0562d0*a3 ss = -0.0562d0*da3 drrdt = ss*alph12dt drrdd = ss*alph12dd if (rr .ge. 0.77d0) then xlgfac = rr dxlgfacdt = drrdt dxlgfacdd = drrdd else xlgfac = 0.77d0 dxlgfacdt = 0.0d0 dxlgfacdd = 0.0d0 end if h12 = log(xlgfac) + h12 rr = 1.0d0/xlgfac dh12dt = rr*dxlgfacdt + dh12dt dh12dd = rr*dxlgfacdd + dh12dd if (gamef .le. gamefs) then rr = 2.0d0*(gamefs - gamef) drrdt = -2.0d0*gamefdt drrdd = -2.0d0*gamefdd ss = 2.0d0*(gamef - gamefx) dssdt = 2.0d0*gamefdt dssdd = 2.0d0*gamefdd c..store current values for possible blending h12x = h12 dh12xdt = dh12dt dh12xdd = dh12dd vv = h12 h12 = h12w*rr + vv*ss dh12dt = dh12wdt*rr + h12w*drrdt + dh12dt*ss + vv*dssdt dh12dd = dh12wdd*rr + h12w*drrdd + dh12dd*ss + vv*dssdd c..blend the transition region - from bill paxton if (gamefs - gamef .lt. blend_frac*(gamefs - gamefx)) then alfa = (gamefs - gamef) / (blend_frac*(gamefs - gamefx)) alfa = 0.5d0 * (1d0 - cos(pi*alfa)) beta = 1.0d0 - alfa h12 = alfa * h12 + beta * h12x dh12dt = alfa * dh12dt + beta * dh12xdt dh12dd = alfa * dh12dd + beta * dh12xdd end if end if c..end of intermediate and strong screening if end if c..machine limit the output h12 = max(min(h12,300.0d0),0.0d0) scor = exp(h12) if (h12 .eq. 300.0d0) then scordt = 0.0d0 scordd = 0.0d0 else scordt = scor * dh12dt scordd = scor * dh12dd end if c write(6,111) 'weak =',h12w,' total =',h12, c 1 ' 1-ratio =',1.0d0-h12w/h12,' correction',scor c 111 format(1x,4(a,1pe13.6)) c read(5,*) return end double precision function snupp(yp,ratepp,ybe7,ratebeec, 1 yb8,rateb8epnu) include 'implno.dek' include 'const.dek' c..computes approximate neutrino losses from pp chain reactions c..see page 142 of astro 289j notes for these loss formulas c..input: c..yp = proton molar abbundance c..ratepp = pp reaction rate c..ybe7 = be7 molar abundance c..ratebeec = be7 electron capture reaction rate c..yb8 = b8 molar abundance c..rateb8epnu = b8 decay reaction rate c..declare the pass double precision yp,ratepp,ybe7,ratebeec,yb8,rateb8epnu c..local variables double precision pp1nu,pp2nu,pp3nu,conv parameter (conv = ev2erg*1.0d6*avo) c..nu losses from p(p,e-nu)h2 pp1nu = yp*yp*ratepp * 0.5d0 * 0.263d0 c..nu losses from be7(n=>p)li7 pp2nu = ybe7 * ratebeec * 0.81d0 c..nu losses from b8(p=>n)be8=>2a pp3nu = yb8 * rateb8epnu * 7.73d0 c..sum the pp-chain neutrino losses and convert to erg/g/s snupp = (pp1nu + pp2nu + pp3nu) * conv return end double precision function snucno(yn13,bc13,bn13,yo14,bn14,bo14, 1 yo15,bn15,bo15,yf17,bo17,bf17, 2 yf18,bo18,bf18) include 'implno.dek' include 'const.dek' c..computes approximate neutrino losses from cno cycle reactions c..see page 142 of astro 289j notes for these loss formulas c..input: c..yn13 = n13 molar abundance c..bc13 = c13 binding energy in mev c..bn13 = n13 binding energy in mev c..yo14 = o14 molar abundance c..bn14 = n14 binding energy in mev c..bo14 = o14 binding energy in mev c..yo15 = o15 molar abundance c..bn15 = n15 binding energy in mev c..bo15 = o15 binding energy in mev c..yf17 = f17 molar abundance c..bo17 = o17 binding energy in mev c..bf17 = f17 binding energy in mev c..yf18 = f18 molar abundance c..bo18 = o18 binding energy in mev c..bf18 = f18 binding energy in mev c..declare the pass double precision yn13,bc13,bn13,yo14,bn14,bo14, 1 yo15,bn15,bo15,yf17,bo17,bf17, 2 yf18,bo18,bf18 c..local variables double precision sum,sum2,enu13n,enu14o,enu15o,enu17f,enu18f, 1 conv,lntwo,tm1,tm2,tm3,tm4,tm5 parameter (conv = ev2erg*1.0d6*avo, 1 lntwo = 0.693147181d0, 2 tm1 = lntwo/597.9d0, 3 tm2 = lntwo/70.606d0, 4 tm3 = lntwo/124.0, 5 tm4 = lntwo/64.49, 6 tm5 = lntwo/6586.2) c..13n(e+nu)13c sum = bc13 - bn13 - 0.782d0 - 1.022d0 sum = 1.0d0 + sum/0.511d0 sum2 = sum*sum enu13n = 0.5d0 * sum * 0.511d0 * (1.0d0 - 1.0d0/sum2) 1 * (1.0d0 - 1.0d0/(4.0d0*sum) - 1.0d0/(9.0d0*sum2)) enu13n = yn13 * enu13n * tm1 c..hot cno cycle 14o(e+nu)14n sum = bn14 - bo14 - 0.782d0 - 1.022d0 sum = 1.0d0 + sum/0.511d0 sum2 = sum*sum enu14o = 0.5d0 * sum * 0.511d0 * (1.0d0 - 1.0d0/sum2) 1 * (1.0d0 - 1.0d0/(4.0d0*sum) - 1.0d0/(9.0d0*sum2)) enu14o = yo14 * enu14o * tm2 c..15o(e+nu)15n sum = bn15 - bo15 - 0.782d0 - 1.022d0 sum = 1.0d0 + sum/0.511d0 sum2 = sum*sum enu15o = 0.5d0 * sum * 0.511d0 * (1.0d0 - 1.0d0/sum2) 1 * (1.0d0 - 1.0d0/(4.0d0*sum) - 1.0d0/(9.0d0*sum2)) enu15o = yo15 * enu15o * tm3 c..17f(e+nu)17o sum = bo17 - bf17 - 0.782d0 - 1.022d0 sum = 1.0d0 + sum/0.511d0 sum2 = sum*sum enu17f = 0.5d0 * sum * 0.511d0 * (1.0d0 - 1.0d0/sum2) 1 * (1.0d0 - 1.0d0/(4.0d0*sum) - 1.0d0/(9.0d0*sum2)) enu17f = yf17 * enu17f * tm4 c..18f(e+nu)18o sum = bo18 - bf18 - 0.782d0 - 1.022d0 sum = 1.0d0 + sum/0.511d0 sum2 = sum*sum enu18f = 0.5d0 * sum * 0.511d0 * (1.0d0 - 1.0d0/sum2) 1 * (1.0d0 - 1.0d0/(4.0d0*sum) - 1.0d0/(9.0d0*sum2)) enu18f = yf18 * enu18f * tm5 c..sum the cno cycle losses and convert to erg/g/s snucno = (enu13n + enu14o + enu15o + enu17f + enu18f) * conv return end subroutine sneut5(temp,den,abar,zbar, 1 snu,dsnudt,dsnudd,dsnuda,dsnudz) include 'implno.dek' include 'const.dek' c..this routine computes neutrino losses from the analytic fits of c..itoh et al. apjs 102, 411, 1996, and also returns their derivatives. c..input: c..temp = temperature c..den = density c..abar = mean atomic weight c..zbar = mean charge c..output: c..snu = total neutrino loss rate in erg/g/sec c..dsnudt = derivative of snu with temperature c..dsnudd = derivative of snu with density c..dsnuda = derivative of snu with abar c..dsnudz = derivative of snu with zbar c..declare the pass double precision temp,den,abar,zbar, 1 snu,dsnudt,dsnudd,dsnuda,dsnudz c..local variables double precision spair,spairdt,spairdd,spairda,spairdz, 1 splas,splasdt,splasdd,splasda,splasdz, 2 sphot,sphotdt,sphotdd,sphotda,sphotdz, 3 sbrem,sbremdt,sbremdd,sbremda,sbremdz, 4 sreco,srecodt,srecodd,srecoda,srecodz double precision t9,xl,xldt,xlp5,xl2,xl3,xl4,xl5,xl6,xl7,xl8,xl9, 1 xlmp5,xlm1,xlm2,xlm3,xlm4,xlnt,cc,den6,tfermi, 2 a0,a1,a2,a3,b1,b2,c00,c01,c02,c03,c04,c05,c06, 3 c10,c11,c12,c13,c14,c15,c16,c20,c21,c22,c23,c24, 4 c25,c26,dd00,dd01,dd02,dd03,dd04,dd05,dd11,dd12, 5 dd13,dd14,dd15,dd21,dd22,dd23,dd24,dd25,b,c,d,f0, 6 f1,deni,tempi,abari,zbari,f2,f3,z,xmue,ye, 7 dum,dumdt,dumdd,dumda,dumdz, 8 gum,gumdt,gumdd,gumda,gumdz c..pair production double precision rm,rmdd,rmda,rmdz,rmi,gl,gldt, 1 zeta,zetadt,zetadd,zetada,zetadz,zeta2,zeta3, 2 xnum,xnumdt,xnumdd,xnumda,xnumdz, 3 xden,xdendt,xdendd,xdenda,xdendz, 4 fpair,fpairdt,fpairdd,fpairda,fpairdz, 5 qpair,qpairdt,qpairdd,qpairda,qpairdz c..plasma double precision gl2,gl2dt,gl2dd,gl2da,gl2dz,gl12,gl32,gl72,gl6, 1 ft,ftdt,ftdd,ftda,ftdz,fl,fldt,fldd,flda,fldz, 2 fxy,fxydt,fxydd,fxyda,fxydz c..photo double precision tau,taudt,cos1,cos2,cos3,cos4,cos5,sin1,sin2, 1 sin3,sin4,sin5,last,xast, 2 fphot,fphotdt,fphotdd,fphotda,fphotdz, 3 qphot,qphotdt,qphotdd,qphotda,qphotdz c..brem double precision t8,t812,t832,t82,t83,t85,t86,t8m1,t8m2,t8m3,t8m5, 1 t8m6, 2 eta,etadt,etadd,etada,etadz,etam1,etam2,etam3, 3 fbrem,fbremdt,fbremdd,fbremda,fbremdz, 4 gbrem,gbremdt,gbremdd,gbremda,gbremdz, 5 u,gm1,gm2,gm13,gm23,gm43,gm53,v,w,fb,gt,gb, 6 fliq,fliqdt,fliqdd,fliqda,fliqdz, 7 gliq,gliqdt,gliqdd,gliqda,gliqdz c..recomb double precision ifermi12,zfermim12,nu,nudt,nudd,nuda,nudz, 1 nu2,nu3,bigj,bigjdt,bigjdd,bigjda,bigjdz c..numerical constants double precision fac1,fac2,fac3,oneth,twoth,con1,sixth,iln10 parameter (fac1 = 5.0d0 * pi / 3.0d0, 2 fac2 = 10.0d0 * pi, 3 fac3 = pi / 5.0d0, 4 oneth = 1.0d0/3.0d0, 5 twoth = 2.0d0/3.0d0, 6 con1 = 1.0d0/5.9302d0, 7 sixth = 1.0d0/6.0d0, 8 iln10 = 4.342944819032518d-1) c..theta is sin**2(theta_weinberg) = 0.2319 plus/minus 0.00005 (1996) c..xnufam is the number of neutrino flavors = 3.02 plus/minus 0.005 (1998) c..change theta and xnufam if need be, and the changes will automatically c..propagate through the routine. cv and ca are the vector and axial currents. double precision theta,xnufam,cv,ca,cvp,cap,tfac1,tfac2,tfac3, 1 tfac4,tfac5,tfac6 parameter (theta = 0.2319d0, 1 xnufam = 3.0d0, 2 cv = 0.5d0 + 2.0d0 * theta, 3 cvp = 1.0d0 - cv, 4 ca = 0.5d0, 5 cap = 1.0d0 - ca, 6 tfac1 = cv*cv + ca*ca + 7 (xnufam-1.0d0) * (cvp*cvp+cap*cap), 8 tfac2 = cv*cv - ca*ca + 9 (xnufam-1.0d0) * (cvp*cvp - cap*cap), & tfac3 = tfac2/tfac1, 1 tfac4 = 0.5d0 * tfac1, 2 tfac5 = 0.5d0 * tfac2, 3 tfac6 = cv*cv + 1.5d0*ca*ca + (xnufam - 1.0d0)* 4 (cvp*cvp + 1.5d0*cap*cap)) c..initialize spair = 0.0d0 spairdt = 0.0d0 spairdd = 0.0d0 spairda = 0.0d0 spairdz = 0.0d0 splas = 0.0d0 splasdt = 0.0d0 splasdd = 0.0d0 splasda = 0.0d0 splasdz = 0.0d0 sphot = 0.0d0 sphotdt = 0.0d0 sphotdd = 0.0d0 sphotda = 0.0d0 sphotdz = 0.0d0 sbrem = 0.0d0 sbremdt = 0.0d0 sbremdd = 0.0d0 sbremda = 0.0d0 sbremdz = 0.0d0 sreco = 0.0d0 srecodt = 0.0d0 srecodd = 0.0d0 srecoda = 0.0d0 srecodz = 0.0d0 snu = 0.0d0 dsnudt = 0.0d0 dsnudd = 0.0d0 dsnuda = 0.0d0 dsnudz = 0.0d0 if (temp .lt. 1.0e7) return c..to avoid lots of divisions deni = 1.0d0/den tempi = 1.0d0/temp abari = 1.0d0/abar zbari = 1.0d0/zbar c..some composition variables ye = zbar*abari xmue = abar*zbari c..some frequent factors t9 = temp * 1.0d-9 xl = t9 * con1 xldt = 1.0d-9 * con1 xlp5 = sqrt(xl) xl2 = xl*xl xl3 = xl2*xl xl4 = xl3*xl xl5 = xl4*xl xl6 = xl5*xl xl7 = xl6*xl xl8 = xl7*xl xl9 = xl8*xl xlmp5 = 1.0d0/xlp5 xlm1 = 1.0d0/xl xlm2 = xlm1*xlm1 xlm3 = xlm1*xlm2 xlm4 = xlm1*xlm3 rm = den*ye rmdd = ye rmda = -rm*abari rmdz = den*abari rmi = 1.0d0/rm a0 = rm * 1.0d-9 a1 = a0**oneth zeta = a1 * xlm1 zetadt = -a1 * xlm2 * xldt a2 = oneth * a1*rmi * xlm1 zetadd = a2 * rmdd zetada = a2 * rmda zetadz = a2 * rmdz zeta2 = zeta * zeta zeta3 = zeta2 * zeta c..pair neutrino section c..for reactions like e+ + e- => nu_e + nubar_e c..equation 2.8 gl = 1.0d0 - 13.04d0*xl2 +133.5d0*xl4 +1534.0d0*xl6 +918.6d0*xl8 gldt = xldt*(-26.08d0*xl +534.0d0*xl3 +9204.0d0*xl5 +7348.8d0*xl7) c..equation 2.7 a1 = 6.002d19 + 2.084d20*zeta + 1.872d21*zeta2 a2 = 2.084d20 + 2.0d0*1.872d21*zeta if (t9 .lt. 10.0) then b1 = exp(-5.5924d0*zeta) b2 = -b1*5.5924d0 else b1 = exp(-4.9924d0*zeta) b2 = -b1*4.9924d0 end if xnum = a1 * b1 c = a2*b1 + a1*b2 xnumdt = c*zetadt xnumdd = c*zetadd xnumda = c*zetada xnumdz = c*zetadz if (t9 .lt. 10.0) then a1 = 9.383d-1*xlm1 - 4.141d-1*xlm2 + 5.829d-2*xlm3 a2 = -9.383d-1*xlm2 + 2.0d0*4.141d-1*xlm3 - 3.0d0*5.829d-2*xlm4 else a1 = 1.2383d0*xlm1 - 8.141d-1*xlm2 a2 = -1.2383d0*xlm2 + 2.0d0*8.141d-1*xlm3 end if b1 = 3.0d0*zeta2 xden = zeta3 + a1 xdendt = b1*zetadt + a2*xldt xdendd = b1*zetadd xdenda = b1*zetada xdendz = b1*zetadz a1 = 1.0d0/xden fpair = xnum*a1 fpairdt = (xnumdt - fpair*xdendt)*a1 fpairdd = (xnumdd - fpair*xdendd)*a1 fpairda = (xnumda - fpair*xdenda)*a1 fpairdz = (xnumdz - fpair*xdendz)*a1 c..equation 2.6 a1 = 10.7480d0*xl2 + 0.3967d0*xlp5 + 1.005d0 a2 = xldt*(2.0d0*10.7480d0*xl + 0.5d0*0.3967d0*xlmp5) xnum = 1.0d0/a1 xnumdt = -xnum*xnum*a2 a1 = 7.692d7*xl3 + 9.715d6*xlp5 a2 = xldt*(3.0d0*7.692d7*xl2 + 0.5d0*9.715d6*xlmp5) c = 1.0d0/a1 b1 = 1.0d0 + rm*c xden = b1**(-0.3d0) d = -0.3d0*xden/b1 xdendt = -d*rm*c*c*a2 xdendd = d*rmdd*c xdenda = d*rmda*c xdendz = d*rmdz*c qpair = xnum*xden qpairdt = xnumdt*xden + xnum*xdendt qpairdd = xnum*xdendd qpairda = xnum*xdenda qpairdz = xnum*xdendz c..equation 2.5 a1 = exp(-2.0d0*xlm1) a2 = a1*2.0d0*xlm2*xldt spair = a1*fpair spairdt = a2*fpair + a1*fpairdt spairdd = a1*fpairdd spairda = a1*fpairda spairdz = a1*fpairdz a1 = spair spair = gl*a1 spairdt = gl*spairdt + gldt*a1 spairdd = gl*spairdd spairda = gl*spairda spairdz = gl*spairdz a1 = tfac4*(1.0d0 + tfac3 * qpair) a2 = tfac4*tfac3 a3 = spair spair = a1*a3 spairdt = a1*spairdt + a2*qpairdt*a3 spairdd = a1*spairdd + a2*qpairdd*a3 spairda = a1*spairda + a2*qpairda*a3 spairdz = a1*spairdz + a2*qpairdz*a3 c..plasma neutrino section c..for collective reactions like gamma_plasmon => nu_e + nubar_e c..equation 4.6 a1 = 1.019d-6*rm a2 = a1**twoth a3 = twoth*a2/a1 b1 = sqrt(1.0d0 + a2) b2 = 1.0d0/b1 c00 = 1.0d0/(temp*temp*b1) gl2 = 1.1095d11 * rm * c00 gl2dt = -2.0d0*gl2*tempi d = rm*c00*b2*0.5d0*b2*a3*1.019d-6 gl2dd = 1.1095d11 * (rmdd*c00 - d*rmdd) gl2da = 1.1095d11 * (rmda*c00 - d*rmda) gl2dz = 1.1095d11 * (rmdz*c00 - d*rmdz) gl = sqrt(gl2) gl12 = sqrt(gl) gl32 = gl * gl12 gl72 = gl2 * gl32 gl6 = gl2 * gl2 * gl2 c..equation 4.7 ft = 2.4d0 + 0.6d0*gl12 + 0.51d0*gl + 1.25d0*gl32 gum = 1.0d0/gl2 a1 =(0.25d0*0.6d0*gl12 +0.5d0*0.51d0*gl +0.75d0*1.25d0*gl32)*gum ftdt = a1*gl2dt ftdd = a1*gl2dd ftda = a1*gl2da ftdz = a1*gl2dz c..equation 4.8 a1 = 8.6d0*gl2 + 1.35d0*gl72 a2 = 8.6d0 + 1.75d0*1.35d0*gl72*gum b1 = 225.0d0 - 17.0d0*gl + gl2 b2 = -0.5d0*17.0d0*gl*gum + 1.0d0 c = 1.0d0/b1 fl = a1*c d = (a2 - fl*b2)*c fldt = d*gl2dt fldd = d*gl2dd flda = d*gl2da fldz = d*gl2dz c..equation 4.9 and 4.10 cc = log10(2.0d0*rm) xlnt = log10(temp) xnum = sixth * (17.5d0 + cc - 3.0d0*xlnt) xnumdt = -iln10*0.5d0*tempi a2 = iln10*sixth*rmi xnumdd = a2*rmdd xnumda = a2*rmda xnumdz = a2*rmdz xden = sixth * (-24.5d0 + cc + 3.0d0*xlnt) xdendt = iln10*0.5d0*tempi xdendd = a2*rmdd xdenda = a2*rmda xdendz = a2*rmdz c..equation 4.11 if (abs(xnum) .gt. 0.7d0 .or. xden .lt. 0.0d0) then fxy = 1.0d0 fxydt = 0.0d0 fxydd = 0.0d0 fxydz = 0.0d0 fxyda = 0.0d0 else a1 = 0.39d0 - 1.25d0*xnum - 0.35d0*sin(4.5d0*xnum) a2 = -1.25d0 - 4.5d0*0.35d0*cos(4.5d0*xnum) b1 = 0.3d0 * exp(-1.0d0*(4.5d0*xnum + 0.9d0)**2) b2 = -b1*2.0d0*(4.5d0*xnum + 0.9d0)*4.5d0 c = min(0.0d0, xden - 1.6d0 + 1.25d0*xnum) if (c .eq. 0.0) then dumdt = 0.0d0 dumdd = 0.0d0 dumda = 0.0d0 dumdz = 0.0d0 else dumdt = xdendt + 1.25d0*xnumdt dumdd = xdendd + 1.25d0*xnumdd dumda = xdenda + 1.25d0*xnumda dumdz = xdendz + 1.25d0*xnumdz end if d = 0.57d0 - 0.25d0*xnum a3 = c/d c00 = exp(-1.0d0*a3**2) f1 = -c00*2.0d0*a3/d c01 = f1*(dumdt + a3*0.25d0*xnumdt) c02 = f1*(dumdd + a3*0.25d0*xnumdd) c03 = f1*(dumda + a3*0.25d0*xnumda) c04 = f1*(dumdz + a3*0.25d0*xnumdz) fxy = 1.05d0 + (a1 - b1)*c00 fxydt = (a2*xnumdt - b2*xnumdt)*c00 + (a1-b1)*c01 fxydd = (a2*xnumdd - b2*xnumdd)*c00 + (a1-b1)*c02 fxyda = (a2*xnumda - b2*xnumda)*c00 + (a1-b1)*c03 fxydz = (a2*xnumdz - b2*xnumdz)*c00 + (a1-b1)*c04 end if c..equation 4.1 and 4.5 splas = (ft + fl) * fxy splasdt = (ftdt + fldt)*fxy + (ft+fl)*fxydt splasdd = (ftdd + fldd)*fxy + (ft+fl)*fxydd splasda = (ftda + flda)*fxy + (ft+fl)*fxyda splasdz = (ftdz + fldz)*fxy + (ft+fl)*fxydz a2 = exp(-gl) a3 = -0.5d0*a2*gl*gum a1 = splas splas = a2*a1 splasdt = a2*splasdt + a3*gl2dt*a1 splasdd = a2*splasdd + a3*gl2dd*a1 splasda = a2*splasda + a3*gl2da*a1 splasdz = a2*splasdz + a3*gl2dz*a1 a2 = gl6 a3 = 3.0d0*gl6*gum a1 = splas splas = a2*a1 splasdt = a2*splasdt + a3*gl2dt*a1 splasdd = a2*splasdd + a3*gl2dd*a1 splasda = a2*splasda + a3*gl2da*a1 splasdz = a2*splasdz + a3*gl2dz*a1 a2 = 0.93153d0 * 3.0d21 * xl9 a3 = 0.93153d0 * 3.0d21 * 9.0d0*xl8*xldt a1 = splas splas = a2*a1 splasdt = a2*splasdt + a3*a1 splasdd = a2*splasdd splasda = a2*splasda splasdz = a2*splasdz c..photoneutrino process section c..for reactions like e- + gamma => e- + nu_e + nubar_e c.. e+ + gamma => e+ + nu_e + nubar_e c..equation 3.8 for tau, equation 3.6 for cc, c..and table 2 written out for speed if (temp .ge. 1.0d7 .and. temp .lt. 1.0d8) then tau = log10(temp * 1.0d-7) cc = 0.5654d0 + tau c00 = 1.008d11 c01 = 0.0d0 c02 = 0.0d0 c03 = 0.0d0 c04 = 0.0d0 c05 = 0.0d0 c06 = 0.0d0 c10 = 8.156d10 c11 = 9.728d8 c12 = -3.806d9 c13 = -4.384d9 c14 = -5.774d9 c15 = -5.249d9 c16 = -5.153d9 c20 = 1.067d11 c21 = -9.782d9 c22 = -7.193d9 c23 = -6.936d9 c24 = -6.893d9 c25 = -7.041d9 c26 = -7.193d9 dd01 = 0.0d0 dd02 = 0.0d0 dd03 = 0.0d0 dd04 = 0.0d0 dd05 = 0.0d0 dd11 = -1.879d10 dd12 = -9.667d9 dd13 = -5.602d9 dd14 = -3.370d9 dd15 = -1.825d9 dd21 = -2.919d10 dd22 = -1.185d10 dd23 = -7.270d9 dd24 = -4.222d9 dd25 = -1.560d9 else if (temp .ge. 1.0d8 .and. temp .lt. 1.0d9) then tau = log10(temp * 1.0d-8) cc = 1.5654d0 c00 = 9.889d10 c01 = -4.524d8 c02 = -6.088d6 c03 = 4.269d7 c04 = 5.172d7 c05 = 4.910d7 c06 = 4.388d7 c10 = 1.813d11 c11 = -7.556d9 c12 = -3.304d9 c13 = -1.031d9 c14 = -1.764d9 c15 = -1.851d9 c16 = -1.928d9 c20 = 9.750d10 c21 = 3.484d10 c22 = 5.199d9 c23 = -1.695d9 c24 = -2.865d9 c25 = -3.395d9 c26 = -3.418d9 dd01 = -1.135d8 dd02 = 1.256d8 dd03 = 5.149d7 dd04 = 3.436d7 dd05 = 1.005d7 dd11 = 1.652d9 dd12 = -3.119d9 dd13 = -1.839d9 dd14 = -1.458d9 dd15 = -8.956d8 dd21 = -1.549d10 dd22 = -9.338d9 dd23 = -5.899d9 dd24 = -3.035d9 dd25 = -1.598d9 else if (temp .ge. 1.0d9) then tau = log10(t9) cc = 1.5654d0 c00 = 9.581d10 c01 = 4.107d8 c02 = 2.305d8 c03 = 2.236d8 c04 = 1.580d8 c05 = 2.165d8 c06 = 1.721d8 c10 = 1.459d12 c11 = 1.314d11 c12 = -1.169d11 c13 = -1.765d11 c14 = -1.867d11 c15 = -1.983d11 c16 = -1.896d11 c20 = 2.424d11 c21 = -3.669d9 c22 = -8.691d9 c23 = -7.967d9 c24 = -7.932d9 c25 = -7.987d9 c26 = -8.333d9 dd01 = 4.724d8 dd02 = 2.976d8 dd03 = 2.242d8 dd04 = 7.937d7 dd05 = 4.859d7 dd11 = -7.094d11 dd12 = -3.697d11 dd13 = -2.189d11 dd14 = -1.273d11 dd15 = -5.705d10 dd21 = -2.254d10 dd22 = -1.551d10 dd23 = -7.793d9 dd24 = -4.489d9 dd25 = -2.185d9 end if taudt = iln10*tempi c..equation 3.7, compute the expensive trig functions only one time cos1 = cos(fac1*tau) cos2 = cos(fac1*2.0d0*tau) cos3 = cos(fac1*3.0d0*tau) cos4 = cos(fac1*4.0d0*tau) cos5 = cos(fac1*5.0d0*tau) last = cos(fac2*tau) sin1 = sin(fac1*tau) sin2 = sin(fac1*2.0d0*tau) sin3 = sin(fac1*3.0d0*tau) sin4 = sin(fac1*4.0d0*tau) sin5 = sin(fac1*5.0d0*tau) xast = sin(fac2*tau) a0 = 0.5d0*c00 1 + c01*cos1 + dd01*sin1 + c02*cos2 + dd02*sin2 2 + c03*cos3 + dd03*sin3 + c04*cos4 + dd04*sin4 3 + c05*cos5 + dd05*sin5 + 0.5d0*c06*last f0 = taudt*fac1*(-c01*sin1 + dd01*cos1 - c02*sin2*2.0d0 1 + dd02*cos2*2.0d0 - c03*sin3*3.0d0 + dd03*cos3*3.0d0 2 - c04*sin4*4.0d0 + dd04*cos4*4.0d0 3 - c05*sin5*5.0d0 + dd05*cos5*5.0d0) 4 - 0.5d0*c06*xast*fac2*taudt a1 = 0.5d0*c10 1 + c11*cos1 + dd11*sin1 + c12*cos2 + dd12*sin2 2 + c13*cos3 + dd13*sin3 + c14*cos4 + dd14*sin4 3 + c15*cos5 + dd15*sin5 + 0.5d0*c16*last f1 = taudt*fac1*(-c11*sin1 + dd11*cos1 - c12*sin2*2.0d0 1 + dd12*cos2*2.0d0 - c13*sin3*3.0d0 + dd13*cos3*3.0d0 2 - c14*sin4*4.0d0 + dd14*cos4*4.0d0 - c15*sin5*5.0d0 3 + dd15*cos5*5.0d0) - 0.5d0*c16*xast*fac2*taudt a2 = 0.5d0*c20 1 + c21*cos1 + dd21*sin1 + c22*cos2 + dd22*sin2 2 + c23*cos3 + dd23*sin3 + c24*cos4 + dd24*sin4 3 + c25*cos5 + dd25*sin5 + 0.5d0*c26*last f2 = taudt*fac1*(-c21*sin1 + dd21*cos1 - c22*sin2*2.0d0 1 + dd22*cos2*2.0d0 - c23*sin3*3.0d0 + dd23*cos3*3.0d0 2 - c24*sin4*4.0d0 + dd24*cos4*4.0d0 - c25*sin5*5.0d0 3 + dd25*cos5*5.0d0) - 0.5d0*c26*xast*fac2*taudt c..equation 3.4 dum = a0 + a1*zeta + a2*zeta2 dumdt = f0 + f1*zeta + a1*zetadt + f2*zeta2 + 2.0d0*a2*zeta*zetadt dumdd = a1*zetadd + 2.0d0*a2*zeta*zetadd dumda = a1*zetada + 2.0d0*a2*zeta*zetada dumdz = a1*zetadz + 2.0d0*a2*zeta*zetadz z = exp(-cc*zeta) xnum = dum*z xnumdt = dumdt*z - dum*z*cc*zetadt xnumdd = dumdd*z - dum*z*cc*zetadd xnumda = dumda*z - dum*z*cc*zetada xnumdz = dumdz*z - dum*z*cc*zetadz xden = zeta3 + 6.290d-3*xlm1 + 7.483d-3*xlm2 + 3.061d-4*xlm3 dum = 3.0d0*zeta2 xdendt = dum*zetadt - xldt*(6.290d-3*xlm2 1 + 2.0d0*7.483d-3*xlm3 + 3.0d0*3.061d-4*xlm4) xdendd = dum*zetadd xdenda = dum*zetada xdendz = dum*zetadz dum = 1.0d0/xden fphot = xnum*dum fphotdt = (xnumdt - fphot*xdendt)*dum fphotdd = (xnumdd - fphot*xdendd)*dum fphotda = (xnumda - fphot*xdenda)*dum fphotdz = (xnumdz - fphot*xdendz)*dum c..equation 3.3 a0 = 1.0d0 + 2.045d0 * xl xnum = 0.666d0*a0**(-2.066d0) xnumdt = -2.066d0*xnum/a0 * 2.045d0*xldt dum = 1.875d8*xl + 1.653d8*xl2 + 8.449d8*xl3 - 1.604d8*xl4 dumdt = xldt*(1.875d8 + 2.0d0*1.653d8*xl + 3.0d0*8.449d8*xl2 1 - 4.0d0*1.604d8*xl3) z = 1.0d0/dum xden = 1.0d0 + rm*z xdendt = -rm*z*z*dumdt xdendd = rmdd*z xdenda = rmda*z xdendz = rmdz*z z = 1.0d0/xden qphot = xnum*z qphotdt = (xnumdt - qphot*xdendt)*z dum = -qphot*z qphotdd = dum*xdendd qphotda = dum*xdenda qphotdz = dum*xdendz c..equation 3.2 sphot = xl5 * fphot sphotdt = 5.0d0*xl4*xldt*fphot + xl5*fphotdt sphotdd = xl5*fphotdd sphotda = xl5*fphotda sphotdz = xl5*fphotdz a1 = sphot sphot = rm*a1 sphotdt = rm*sphotdt sphotdd = rm*sphotdd + rmdd*a1 sphotda = rm*sphotda + rmda*a1 sphotdz = rm*sphotdz + rmdz*a1 a1 = tfac4*(1.0d0 - tfac3 * qphot) a2 = -tfac4*tfac3 a3 = sphot sphot = a1*a3 sphotdt = a1*sphotdt + a2*qphotdt*a3 sphotdd = a1*sphotdd + a2*qphotdd*a3 sphotda = a1*sphotda + a2*qphotda*a3 sphotdz = a1*sphotdz + a2*qphotdz*a3 if (sphot .le. 0.0) then sphot = 0.0d0 sphotdt = 0.0d0 sphotdd = 0.0d0 sphotda = 0.0d0 sphotdz = 0.0d0 end if c..bremsstrahlung neutrino section c..for reactions like e- + (z,a) => e- + (z,a) + nu + nubar c.. n + n => n + n + nu + nubar c.. n + p => n + p + nu + nubar c..equation 4.3 den6 = den * 1.0d-6 t8 = temp * 1.0d-8 t812 = sqrt(t8) t832 = t8 * t812 t82 = t8*t8 t83 = t82*t8 t85 = t82*t83 t86 = t85*t8 t8m1 = 1.0d0/t8 t8m2 = t8m1*t8m1 t8m3 = t8m2*t8m1 t8m5 = t8m3*t8m2 t8m6 = t8m5*t8m1 tfermi = 5.9302d9*(sqrt(1.0d0+1.018d0*(den6*ye)**twoth)-1.0d0) c.."weak" degenerate electrons only if (temp .gt. 0.3d0 * tfermi) then c..equation 5.3 dum = 7.05d6 * t832 + 5.12d4 * t83 dumdt = (1.5d0*7.05d6*t812 + 3.0d0*5.12d4*t82)*1.0d-8 z = 1.0d0/dum eta = rm*z etadt = -rm*z*z*dumdt etadd = rmdd*z etada = rmda*z etadz = rmdz*z etam1 = 1.0d0/eta etam2 = etam1 * etam1 etam3 = etam2 * etam1 c..equation 5.2 a0 = 23.5d0 + 6.83d4*t8m2 + 7.81d8*t8m5 f0 = (-2.0d0*6.83d4*t8m3 - 5.0d0*7.81d8*t8m6)*1.0d-8 xnum = 1.0d0/a0 dum = 1.0d0 + 1.47d0*etam1 + 3.29d-2*etam2 z = -1.47d0*etam2 - 2.0d0*3.29d-2*etam3 dumdt = z*etadt dumdd = z*etadd dumda = z*etada dumdz = z*etadz c00 = 1.26d0 * (1.0d0+etam1) z = -1.26d0*etam2 c01 = z*etadt c02 = z*etadd c03 = z*etada c04 = z*etadz z = 1.0d0/dum xden = c00*z xdendt = (c01 - xden*dumdt)*z xdendd = (c02 - xden*dumdd)*z xdenda = (c03 - xden*dumda)*z xdendz = (c04 - xden*dumdz)*z fbrem = xnum + xden fbremdt = -xnum*xnum*f0 + xdendt fbremdd = xdendd fbremda = xdenda fbremdz = xdendz c..equation 5.9 a0 = 230.0d0 + 6.7d5*t8m2 + 7.66d9*t8m5 f0 = (-2.0d0*6.7d5*t8m3 - 5.0d0*7.66d9*t8m6)*1.0d-8 z = 1.0d0 + rm*1.0d-9 dum = a0*z dumdt = f0*z z = a0*1.0d-9 dumdd = z*rmdd dumda = z*rmda dumdz = z*rmdz xnum = 1.0d0/dum z = -xnum*xnum xnumdt = z*dumdt xnumdd = z*dumdd xnumda = z*dumda xnumdz = z*dumdz c00 = 7.75d5*t832 + 247.0d0*t8**(3.85d0) dd00 = (1.5d0*7.75d5*t812 + 3.85d0*247.0d0*t8**(2.85d0))*1.0d-8 c01 = 4.07d0 + 0.0240d0 * t8**(1.4d0) dd01 = 1.4d0*0.0240d0*t8**(0.4d0)*1.0d-8 c02 = 4.59d-5 * t8**(-0.110d0) dd02 = -0.11d0*4.59d-5 * t8**(-1.11d0)*1.0d-8 z = den**(0.656d0) dum = c00*rmi + c01 + c02*z dumdt = dd00*rmi + dd01 + dd02*z z = -c00*rmi*rmi dumdd = z*rmdd + 0.656d0*c02*den**(-0.454d0) dumda = z*rmda dumdz = z*rmdz xden = 1.0d0/dum z = -xden*xden xdendt = z*dumdt xdendd = z*dumdd xdenda = z*dumda xdendz = z*dumdz gbrem = xnum + xden gbremdt = xnumdt + xdendt gbremdd = xnumdd + xdendd gbremda = xnumda + xdenda gbremdz = xnumdz + xdendz c..equation 5.1 dum = 0.5738d0*zbar*ye*t86*den dumdt = 0.5738d0*zbar*ye*6.0d0*t85*den*1.0d-8 dumdd = 0.5738d0*zbar*ye*t86 dumda = -dum*abari dumdz = 0.5738d0*2.0d0*ye*t86*den z = tfac4*fbrem - tfac5*gbrem sbrem = dum * z sbremdt = dumdt*z + dum*(tfac4*fbremdt - tfac5*gbremdt) sbremdd = dumdd*z + dum*(tfac4*fbremdd - tfac5*gbremdd) sbremda = dumda*z + dum*(tfac4*fbremda - tfac5*gbremda) sbremdz = dumdz*z + dum*(tfac4*fbremdz - tfac5*gbremdz) c..liquid metal with c12 parameters (not too different for other elements) c..equation 5.18 and 5.16 else u = fac3 * (log10(den) - 3.0d0) a0 = iln10*fac3*deni c..compute the expensive trig functions of equation 5.21 only once cos1 = cos(u) cos2 = cos(2.0d0*u) cos3 = cos(3.0d0*u) cos4 = cos(4.0d0*u) cos5 = cos(5.0d0*u) sin1 = sin(u) sin2 = sin(2.0d0*u) sin3 = sin(3.0d0*u) sin4 = sin(4.0d0*u) sin5 = sin(5.0d0*u) c..equation 5.21 fb = 0.5d0 * 0.17946d0 + 0.00945d0*u + 0.34529d0 1 - 0.05821d0*cos1 - 0.04969d0*sin1 2 - 0.01089d0*cos2 - 0.01584d0*sin2 3 - 0.01147d0*cos3 - 0.00504d0*sin3 4 - 0.00656d0*cos4 - 0.00281d0*sin4 5 - 0.00519d0*cos5 c00 = a0*(0.00945d0 1 + 0.05821d0*sin1 - 0.04969d0*cos1 2 + 0.01089d0*sin2*2.0d0 - 0.01584d0*cos2*2.0d0 3 + 0.01147d0*sin3*3.0d0 - 0.00504d0*cos3*3.0d0 4 + 0.00656d0*sin4*4.0d0 - 0.00281d0*cos4*4.0d0 5 + 0.00519d0*sin5*5.0d0) c..equation 5.22 ft = 0.5d0 * 0.06781d0 - 0.02342d0*u + 0.24819d0 1 - 0.00944d0*cos1 - 0.02213d0*sin1 2 - 0.01289d0*cos2 - 0.01136d0*sin2 3 - 0.00589d0*cos3 - 0.00467d0*sin3 4 - 0.00404d0*cos4 - 0.00131d0*sin4 5 - 0.00330d0*cos5 c01 = a0*(-0.02342d0 1 + 0.00944d0*sin1 - 0.02213d0*cos1 2 + 0.01289d0*sin2*2.0d0 - 0.01136d0*cos2*2.0d0 3 + 0.00589d0*sin3*3.0d0 - 0.00467d0*cos3*3.0d0 4 + 0.00404d0*sin4*4.0d0 - 0.00131d0*cos4*4.0d0 5 + 0.00330d0*sin5*5.0d0) c..equation 5.23 gb = 0.5d0 * 0.00766d0 - 0.01259d0*u + 0.07917d0 1 - 0.00710d0*cos1 + 0.02300d0*sin1 2 - 0.00028d0*cos2 - 0.01078d0*sin2 3 + 0.00232d0*cos3 + 0.00118d0*sin3 4 + 0.00044d0*cos4 - 0.00089d0*sin4 5 + 0.00158d0*cos5 c02 = a0*(-0.01259d0 1 + 0.00710d0*sin1 + 0.02300d0*cos1 2 + 0.00028d0*sin2*2.0d0 - 0.01078d0*cos2*2.0d0 3 - 0.00232d0*sin3*3.0d0 + 0.00118d0*cos3*3.0d0 4 - 0.00044d0*sin4*4.0d0 - 0.00089d0*cos4*4.0d0 5 - 0.00158d0*sin5*5.0d0) c..equation 5.24 gt = -0.5d0 * 0.00769d0 - 0.00829d0*u + 0.05211d0 1 + 0.00356d0*cos1 + 0.01052d0*sin1 2 - 0.00184d0*cos2 - 0.00354d0*sin2 3 + 0.00146d0*cos3 - 0.00014d0*sin3 4 + 0.00031d0*cos4 - 0.00018d0*sin4 5 + 0.00069d0*cos5 c03 = a0*(-0.00829d0 1 - 0.00356d0*sin1 + 0.01052d0*cos1 2 + 0.00184d0*sin2*2.0d0 - 0.00354d0*cos2*2.0d0 3 - 0.00146d0*sin3*3.0d0 - 0.00014d0*cos3*3.0d0 4 - 0.00031d0*sin4*4.0d0 - 0.00018d0*cos4*4.0d0 5 - 0.00069d0*sin5*5.0d0) dum = 2.275d-1 * zbar * zbar*t8m1 * (den6*abari)**oneth dumdt = -dum*tempi dumdd = oneth*dum*deni dumda = -oneth*dum*abari dumdz = 2.0d0*dum*zbari gm1 = 1.0d0/dum gm2 = gm1*gm1 gm13 = gm1**oneth gm23 = gm13 * gm13 gm43 = gm13*gm1 gm53 = gm23*gm1 c..equation 5.25 and 5.26 v = -0.05483d0 - 0.01946d0*gm13 + 1.86310d0*gm23 - 0.78873d0*gm1 a0 = oneth*0.01946d0*gm43 - twoth*1.86310d0*gm53 + 0.78873d0*gm2 w = -0.06711d0 + 0.06859d0*gm13 + 1.74360d0*gm23 - 0.74498d0*gm1 a1 = -oneth*0.06859d0*gm43 - twoth*1.74360d0*gm53 + 0.74498d0*gm2 c..equation 5.19 and 5.20 fliq = v*fb + (1.0d0 - v)*ft fliqdt = a0*dumdt*(fb - ft) fliqdd = a0*dumdd*(fb - ft) + v*c00 + (1.0d0 - v)*c01 fliqda = a0*dumda*(fb - ft) fliqdz = a0*dumdz*(fb - ft) gliq = w*gb + (1.0d0 - w)*gt gliqdt = a1*dumdt*(gb - gt) gliqdd = a1*dumdd*(gb - gt) + w*c02 + (1.0d0 - w)*c03 gliqda = a1*dumda*(gb - gt) gliqdz = a1*dumdz*(gb - gt) c..equation 5.17 dum = 0.5738d0*zbar*ye*t86*den dumdt = 0.5738d0*zbar*ye*6.0d0*t85*den*1.0d-8 dumdd = 0.5738d0*zbar*ye*t86 dumda = -dum*abari dumdz = 0.5738d0*2.0d0*ye*t86*den z = tfac4*fliq - tfac5*gliq sbrem = dum * z sbremdt = dumdt*z + dum*(tfac4*fliqdt - tfac5*gliqdt) sbremdd = dumdd*z + dum*(tfac4*fliqdd - tfac5*gliqdd) sbremda = dumda*z + dum*(tfac4*fliqda - tfac5*gliqda) sbremdz = dumdz*z + dum*(tfac4*fliqdz - tfac5*gliqdz) end if c..recombination neutrino section c..for reactions like e- (continuum) => e- (bound) + nu_e + nubar_e c..equation 6.11 solved for nu xnum = 1.10520d8 * den * ye /(temp*sqrt(temp)) xnumdt = -1.50d0*xnum*tempi xnumdd = xnum*deni xnumda = -xnum*abari xnumdz = xnum*zbari c..the chemical potential nu = ifermi12(xnum) c..a0 is d(nu)/d(xnum) a0 = 1.0d0/(0.5d0*zfermim12(nu)) nudt = a0*xnumdt nudd = a0*xnumdd nuda = a0*xnumda nudz = a0*xnumdz nu2 = nu * nu nu3 = nu2 * nu c..table 12 if (nu .ge. -20.0 .and. nu .lt. 0.0) then a1 = 1.51d-2 a2 = 2.42d-1 a3 = 1.21d0 b = 3.71d-2 c = 9.06e-1 d = 9.28d-1 f1 = 0.0d0 f2 = 0.0d0 f3 = 0.0d0 else if (nu .ge. 0.0 .and. nu .le. 10.0) then a1 = 1.23d-2 a2 = 2.66d-1 a3 = 1.30d0 b = 1.17d-1 c = 8.97e-1 d = 1.77d-1 f1 = -1.20d-2 f2 = 2.29d-2 f3 = -1.04d-3 end if c..equation 6.7, 6.13 and 6.14 if (nu .ge. -20.0 .and. nu .le. 10.0) then zeta = 1.579d5*zbar*zbar*tempi zetadt = -zeta*tempi zetadd = 0.0d0 zetada = 0.0d0 zetadz = 2.0d0*zeta*zbari c00 = 1.0d0/(1.0d0 + f1*nu + f2*nu2 + f3*nu3) c01 = f1 + f2*2.0d0*nu + f3*3.0d0*nu2 dum = zeta*c00 dumdt = zetadt*c00 + zeta*c01*nudt dumdd = zeta*c01*nudd dumda = zeta*c01*nuda dumdz = zetadz*c00 + zeta*c01*nudz z = 1.0d0/dum dd00 = dum**(-2.25) dd01 = dum**(-4.55) c00 = a1*z + a2*dd00 + a3*dd01 c01 = -(a1*z + 2.25*a2*dd00 + 4.55*a3*dd01)*z z = exp(c*nu) dd00 = b*z*(1.0d0 + d*dum) gum = 1.0d0 + dd00 gumdt = dd00*c*nudt + b*z*d*dumdt gumdd = dd00*c*nudd + b*z*d*dumdd gumda = dd00*c*nuda + b*z*d*dumda gumdz = dd00*c*nudz + b*z*d*dumdz z = exp(nu) a1 = 1.0d0/gum bigj = c00 * z * a1 bigjdt = c01*dumdt*z*a1 + c00*z*nudt*a1 - c00*z*a1*a1 * gumdt bigjdd = c01*dumdd*z*a1 + c00*z*nudd*a1 - c00*z*a1*a1 * gumdd bigjda = c01*dumda*z*a1 + c00*z*nuda*a1 - c00*z*a1*a1 * gumda bigjdz = c01*dumdz*z*a1 + c00*z*nudz*a1 - c00*z*a1*a1 * gumdz c..equation 6.5 z = exp(zeta + nu) dum = 1.0d0 + z a1 = 1.0d0/dum a2 = 1.0d0/bigj sreco = tfac6 * 2.649d-18 * ye * zbar**13 * den * bigj*a1 srecodt = sreco*(bigjdt*a2 - z*(zetadt + nudt)*a1) srecodd = sreco*(1.0d0*deni + bigjdd*a2 - z*(zetadd + nudd)*a1) srecoda = sreco*(-1.0d0*abari + bigjda*a2 - z*(zetada+nuda)*a1) srecodz = sreco*(14.0d0*zbari + bigjdz*a2 - z*(zetadz+nudz)*a1) end if c..convert from erg/cm^3/s to erg/g/s c..comment these out to duplicate the itoh et al plots spair = spair*deni spairdt = spairdt*deni spairdd = spairdd*deni - spair*deni spairda = spairda*deni spairdz = spairdz*deni splas = splas*deni splasdt = splasdt*deni splasdd = splasdd*deni - splas*deni splasda = splasda*deni splasdz = splasdz*deni sphot = sphot*deni sphotdt = sphotdt*deni sphotdd = sphotdd*deni - sphot*deni sphotda = sphotda*deni sphotdz = sphotdz*deni sbrem = sbrem*deni sbremdt = sbremdt*deni sbremdd = sbremdd*deni - sbrem*deni sbremda = sbremda*deni sbremdz = sbremdz*deni sreco = sreco*deni srecodt = srecodt*deni srecodd = srecodd*deni - sreco*deni srecoda = srecoda*deni srecodz = srecodz*deni c..the total neutrino loss rate snu = splas + spair + sphot + sbrem + sreco dsnudt = splasdt + spairdt + sphotdt + sbremdt + srecodt dsnudd = splasdd + spairdd + sphotdd + sbremdd + srecodd dsnuda = splasda + spairda + sphotda + sbremda + srecoda dsnudz = splasdz + spairdz + sphotdz + sbremdz + srecodz return end double precision function ifermi12(f) include 'implno.dek' c..this routine applies a rational function expansion to get the inverse c..fermi-dirac integral of order 1/2 when it is equal to f. c..maximum error is 4.19d-9. reference: antia apjs 84,101 1993 c..declare integer i,m1,k1,m2,k2 double precision f,an,a1(12),b1(12),a2(12),b2(12),rn,den,ff c..load the coefficients of the expansion data an,m1,k1,m2,k2 /0.5d0, 4, 3, 6, 5/ data (a1(i),i=1,5)/ 1.999266880833d4, 5.702479099336d3, 1 6.610132843877d2, 3.818838129486d1, 2 1.0d0/ data (b1(i),i=1,4)/ 1.771804140488d4, -2.014785161019d3, 1 9.130355392717d1, -1.670718177489d0/ data (a2(i),i=1,7)/-1.277060388085d-2, 7.187946804945d-2, 1 -4.262314235106d-1, 4.997559426872d-1, 2 -1.285579118012d0, -3.930805454272d-1, 3 1.0d0/ data (b2(i),i=1,6)/-9.745794806288d-3, 5.485432756838d-2, 1 -3.299466243260d-1, 4.077841975923d-1, 2 -1.145531476975d0, -6.067091689181d-2/ if (f .lt. 4.0d0) then rn = f + a1(m1) do i=m1-1,1,-1 rn = rn*f + a1(i) enddo den = b1(k1+1) do i=k1,1,-1 den = den*f + b1(i) enddo ifermi12 = log(f * rn/den) else ff = 1.0d0/f**(1.0d0/(1.0d0 + an)) rn = ff + a2(m2) do i=m2-1,1,-1 rn = rn*ff + a2(i) enddo den = b2(k2+1) do i=k2,1,-1 den = den*ff + b2(i) enddo ifermi12 = rn/(den*ff) end if return end double precision function zfermim12(x) include 'implno.dek' c..this routine applies a rational function expansion to get the fermi-dirac c..integral of order -1/2 evaluated at x. maximum error is 1.23d-12. c..reference: antia apjs 84,101 1993 c..declare integer i,m1,k1,m2,k2 double precision x,an,a1(12),b1(12),a2(12),b2(12),rn,den,xx c..load the coefficients of the expansion data an,m1,k1,m2,k2 /-0.5d0, 7, 7, 11, 11/ data (a1(i),i=1,8)/ 1.71446374704454d7, 3.88148302324068d7, 1 3.16743385304962d7, 1.14587609192151d7, 2 1.83696370756153d6, 1.14980998186874d5, 3 1.98276889924768d3, 1.0d0/ data (b1(i),i=1,8)/ 9.67282587452899d6, 2.87386436731785d7, 1 3.26070130734158d7, 1.77657027846367d7, 2 4.81648022267831d6, 6.13709569333207d5, 3 3.13595854332114d4, 4.35061725080755d2/ data (a2(i),i=1,12)/-4.46620341924942d-15, -1.58654991146236d-12, 1 -4.44467627042232d-10, -6.84738791621745d-8, 2 -6.64932238528105d-6, -3.69976170193942d-4, 3 -1.12295393687006d-2, -1.60926102124442d-1, 4 -8.52408612877447d-1, -7.45519953763928d-1, 5 2.98435207466372d0, 1.0d0/ data (b2(i),i=1,12)/-2.23310170962369d-15, -7.94193282071464d-13, 1 -2.22564376956228d-10, -3.43299431079845d-8, 2 -3.33919612678907d-6, -1.86432212187088d-4, 3 -5.69764436880529d-3, -8.34904593067194d-2, 4 -4.78770844009440d-1, -4.99759250374148d-1, 5 1.86795964993052d0, 4.16485970495288d-1/ if (x .lt. 2.0d0) then xx = exp(x) rn = xx + a1(m1) do i=m1-1,1,-1 rn = rn*xx + a1(i) enddo den = b1(k1+1) do i=k1,1,-1 den = den*xx + b1(i) enddo zfermim12 = xx * rn/den c.. else xx = 1.0d0/(x*x) rn = xx + a2(m2) do i=m2-1,1,-1 rn = rn*xx + a2(i) enddo den = b2(k2+1) do i=k2,1,-1 den = den*xx + b2(i) enddo zfermim12 = sqrt(x)*rn/den end if return end subroutine mazurek(btemp,bden,y56,ye,rn56ec,sn56ec) include 'implno.dek' c..this routine evaluates mazurel's 1973 fits for the ni56 electron c..capture rate rn56ec and neutrino loss rate sn56ec c..input: c..y56 = nickel56 molar abundance c..ye = electron to baryon number, zbar/abar c..output: c..rn56ec = ni56 electron capture rate c..sn56ec = ni56 neutrino loss rate c..declare integer ifirst,jp,kp,jr,jd,ii,ik,ij,j,k double precision btemp,bden,y56,ye,rn56ec,sn56ec, 1 rnt(2),rne(2,7),datn(2,6,7), 2 tv(7),rv(6),rfdm(4),rfd0(4),rfd1(4),rfd2(4), 3 tfdm(5),tfd0(5),tfd1(5),tfd2(5), 4 t9,r,rfm,rf0,rf1,rf2,dfacm,dfac0,dfac1,dfac2, 5 tfm,tf0,tf1,tf2,tfacm,tfac0,tfac1,tfac2 c..initialize data rv /6.0, 7.0, 8.0, 9.0, 10.0, 11.0/ data tv /2.0, 4.0, 6.0, 8.0, 10.0, 12.0, 14.0/ data (((datn(ii,ik,ij),ik=1,6),ij=1,7),ii=1,1) / 1 -3.98, -2.84, -1.41, 0.20, 1.89, 3.63, 2 -3.45, -2.62, -1.32, 0.22, 1.89, 3.63, 3 -2.68, -2.30, -1.19, 0.27, 1.91, 3.62, 4 -2.04, -1.87, -1.01, 0.34, 1.94, 3.62, 5 -1.50, -1.41, -0.80, 0.45, 1.99, 3.60, 6 -1.00, -0.95, -0.54, 0.60, 2.06, 3.58, 7 -0.52, -0.49, -0.21, 0.79, 2.15, 3.55 / data (((datn(ii,ik,ij),ik=1,6),ij=1,7),ii=2,2) / 1 -3.68, -2.45, -0.80, 1.12, 3.13, 5.19, 2 -2.91, -2.05, -0.64, 1.16, 3.14, 5.18, 3 -1.95, -1.57, -0.40, 1.24, 3.16, 5.18, 4 -1.16, -0.99, -0.11, 1.37, 3.20, 5.18, 5 -0.48, -0.40, 0.22, 1.54, 3.28, 5.16, 6 0.14, 0.19, 0.61, 1.78, 3.38, 5.14, 7 0.75, 0.78, 1.06, 2.07, 3.51, 5.11 / data ifirst /0/ c..first time; calculate the cubic interp parameters for ni56 electron capture if (ifirst .eq. 0) then ifirst = 1 do k=2,4 rfdm(k)=1./((rv(k-1)-rv(k))*(rv(k-1)-rv(k+1))*(rv(k-1)-rv(k+2))) rfd0(k)=1./((rv(k)-rv(k-1))*(rv(k)-rv(k+1))*(rv(k)-rv(k+2))) rfd1(k)=1./((rv(k+1)-rv(k-1))*(rv(k+1)-rv(k))*(rv(k+1)-rv(k+2))) rfd2(k)=1./((rv(k+2)-rv(k-1))*(rv(k+2)-rv(k))*(rv(k+2)-rv(k+1))) enddo do j=2,5 tfdm(j)=1./((tv(j-1)-tv(j))*(tv(j-1)-tv(j+1))*(tv(j-1)-tv(j+2))) tfd0(j)=1./((tv(j)-tv(j-1))*(tv(j)-tv(j+1))*(tv(j)-tv(j+2))) tfd1(j)=1./((tv(j+1)-tv(j-1))*(tv(j+1)-tv(j))*(tv(j+1)-tv(j+2))) tfd2(j)=1./((tv(j+2)-tv(j-1))*(tv(j+2)-tv(j))*(tv(j+2)-tv(j+1))) enddo end if c..calculate ni56 electron capture and neutrino loss rates rn56ec = 0.0 sn56ec = 0.0 if ( (btemp .lt. 2.0e9) .or. (bden*ye .lt. 1.0e6)) return t9 = max(btemp,1.4d10) * 1.0d-9 r = max(6.0d0,min(11.0d0,log10(bden*ye))) jp = min(max(2,int(0.5d0*t9)),5) kp = min(max(2,int(r)-5),4) rfm = r - rv(kp-1) rf0 = r - rv(kp) rf1 = r - rv(kp+1) rf2 = r - rv(kp+2) dfacm = rf0*rf1*rf2*rfdm(kp) dfac0 = rfm*rf1*rf2*rfd0(kp) dfac1 = rfm*rf0*rf2*rfd1(kp) dfac2 = rfm*rf0*rf1*rfd2(kp) tfm = t9 - tv(jp-1) tf0 = t9 - tv(jp) tf1 = t9 - tv(jp+1) tf2 = t9 - tv(jp+2) tfacm = tf0*tf1*tf2*tfdm(jp) tfac0 = tfm*tf1*tf2*tfd0(jp) tfac1 = tfm*tf0*tf2*tfd1(jp) tfac2 = tfm*tf0*tf1*tfd2(jp) c..evaluate the spline fits do jr = 1,2 do jd = jp-1,jp+2 rne(jr,jd) = dfacm*datn(jr,kp-1,jd) + dfac0*datn(jr,kp,jd) 1 + dfac1*datn(jr,kp+1,jd) + dfac2*datn(jr,kp+2,jd) enddo rnt(jr) = tfacm*rne(jr,jp-1) + tfac0*rne(jr,jp) 1 + tfac1*rne(jr,jp+1) + tfac2*rne(jr,jp+2) enddo c..set the output rn56ec = 10.0d0**rnt(1) sn56ec = 6.022548d+23 * 8.18683d-7 * y56 * 10.0d0**rnt(2) return end subroutine ecapnuc02(temp,den,abar,zbar,rpen,rnep,spenc,snepc) include 'implno.dek' include 'vector_eos.dek' c..given the electron degeneracy parameter etakep (chemical potential c..without the electron's rest mass divided by kt) and the temperature temp, c..this routine calculates rates for c..electron capture on protons rpen (captures/sec/proton), c..positron capture on neutrons rnep (captures/sec/neutron), c..and their associated neutrino energy loss rates c..spenc (erg/sec/proton) and snepc (erg/sec/neutron) c..declare the pass double precision temp,den,abar,zbar,rpen,rnep,spenc,snepc c..local variables integer iflag double precision t9,t5,qn,etaef,etael,zetan,eta,etael2, 1 etael3,etael4,f1l,f2l,f3l,f4l,f5l,f1g, 2 f2g,f3g,f4g,f5g,exmeta,eta2,eta3,eta4, 3 fac0,fac1,fac2,fac3,rie1,rie2,facv0,facv1, 4 facv2,facv3,facv4,rjv1,rjv2,spen,snep, 5 pi2,exeta,zetan2,f0,etael5, 6 qn1,ft,twoln,cmk5,cmk6,bk,pi,qn2,c2me, 7 xmp,xmn,qndeca,tmean,etakep parameter (qn1 = -2.0716446d-06, 1 ft = 1083.9269d0, 2 twoln = 0.6931472d0, 3 cmk5 = 1.3635675d-49, 4 cmk6 = 2.2993864d-59, 5 bk = 1.38062e-16, 6 pi = 3.1415927d0, 7 pi2 = pi * pi, 8 qn2 = 2.0716446d-06, 9 c2me = 8.1872665d-07, & xmp = 1.6726485d-24, 1 xmn = 1.6749543d-24, 2 qndeca = 1.2533036d-06, 3 tmean = 886.7d0) c 3 tmean = 935.14d0) c..tmean and qndeca are the mean lifetime and decay energy of the neutron c..xmp,xnp are masses of the p and n in grams. c..c2me is the constant used to convert the neutrino energy c..loss rate from mec2/s (as in the paper) to ergs/particle/sec. c..initialize rpen = 0.0d0 rnep = 0.0d0 spen = 0.0d0 snep = 0.0d0 t9 = temp * 1.0d-9 iflag = 0 qn = qn1 c..call an eos to get the chemical potential temp_row(1) = temp den_row(1) = den abar_row(1) = abar zbar_row(1) = zbar jlo_eos = 1 jhi_eos = 1 call helmeos etakep = etaele_row(1) c..chemical potential including the electron rest mass etaef = etakep + c2me/bk/temp c..iflag=1 is for electrons, iflag=2 is for positrons 502 iflag = iflag + 1 if (iflag.eq.1) etael = qn2/bk/temp if (iflag.eq.2) etael = c2me/bk/temp if (iflag.eq.2) etaef = -etaef t5 = temp*temp*temp*temp*temp zetan = qn/bk/temp eta = etaef - etael c..protect from overflowing with large eta values if (eta .le. 6.8e+02) then exeta = exp(eta) else exeta = 0.0d0 end if etael2 = etael*etael etael3 = etael2*etael etael4 = etael3*etael etael5 = etael4*etael zetan2 = zetan*zetan if (eta .le. 6.8e+02) then f0 = log(1.0d0 + exeta) else f0 = eta end if c..if eta le. 0., the following fermi integrals apply f1l = exeta f2l = 2.0d0 * f1l f3l = 6.0d0 * f1l f4l = 24.0d0 * f1l f5l = 120.0d0 * f1l c..if eta gt. 0., the following fermi integrals apply: f1g = 0.0d0 f2g = 0.0d0 f3g = 0.0d0 f4g = 0.0d0 f5g = 0.0d0 if (eta .gt. 0.0) then exmeta = dexp(-eta) eta2 = eta*eta eta3 = eta2*eta eta4 = eta3*eta f1g = 0.5d0*eta2 + 2.0d0 - exmeta f2g = eta3/3.0d0 + 4.0d0*eta + 2.0d0*exmeta f3g = 0.25d0*eta4 + 0.5d0*pi2*eta2 + 12.0d0 - 6.0d0*exmeta f4g = 0.2d0*eta4*eta + 2.0d0*pi2/3.0d0*eta3 + 48.0d0*eta 1 + 24.0d0*exmeta f5g = eta4*eta2/6.0d0 + 5.0d0/6.0d0*pi2*eta4 2 + 7.0d0/6.0d0*pi2*eta2 + 240.0d0 -120.d0*exmeta end if c..factors which are multiplied by the fermi integrals fac3 = 2.0d0*zetan + 4.0d0*etael fac2 = 6.0d0*etael2 + 6.0d0*etael*zetan + zetan2 fac1 = 4.0d0*etael3 + 6.0d0*etael2*zetan + 2.0d0*etael*zetan2 fac0 = etael4 + 2.0d0*zetan*etael3 + etael2*zetan2 c..electron capture rates onto protons with no blocking rie1 = f4l + fac3*f3l + fac2*f2l + fac1*f1l + fac0*f0 rie2 = f4g + fac3*f3g + fac2*f2g + fac1*f1g + fac0*f0 c..neutrino emission rate for electron capture: facv4 = 5.0d0*etael + 3.0d0*zetan facv3 = 10.0d0*etael2 + 12.0d0*etael*zetan + 3.0d0*zetan2 facv2 = 10.0d0*etael3 + 18.0d0*etael2*zetan 1 + 9.0d0*etael*zetan2 + zetan2*zetan facv1 = 5.0d0*etael4 + 12.0d0*etael3*zetan 1 + 9.0d0*etael2*zetan2 + 2.0d0*etael*zetan2*zetan facv0 = etael5 + 3.0d0*etael4*zetan 1 + 3.0d0*etael3*zetan2 + etael2*zetan2*zetan rjv1 = f5l + facv4*f4l + facv3*f3l 1 + facv2*f2l + facv1*f1l + facv0*f0 rjv2 = f5g + facv4*f4g + facv3*f3g 1 + facv2*f2g + facv1*f1g + facv0*f0 c..for electrons capture onto protons if (iflag.eq.2) go to 503 if (eta.gt.0.) go to 505 rpen = twoln*cmk5*t5*rie1/ft spen = twoln*cmk6*t5*temp*rjv1/ft spenc = twoln*cmk6*t5*temp*rjv1/ft*c2me go to 504 505 rpen = twoln*cmk5*t5*rie2/ft spen = twoln*cmk6*t5*temp*rjv2/ft spenc = twoln*cmk6*t5*temp*rjv2/ft*c2me 504 continue qn = qn2 go to 502 c..for positrons capture onto neutrons 503 if (eta.gt.0.) go to 507 rnep = twoln*cmk5*t5*rie1/ft snep = twoln*cmk6*t5*temp*rjv1/ft snepc = twoln*cmk6*t5*temp*rjv1/ft*c2me c if (rho.lt.1.0e+06) snep=snep+qndeca*xn(9)/xmn/tmean go to 506 507 rnep = twoln*cmk5*t5*rie2/ft snep = twoln*cmk6*t5*temp*rjv2/ft snepc = twoln*cmk6*t5*temp*rjv2/ft*c2me c if (rho.lt.1.0e+06) snep=snep+qndeca*xn(9)/xmn/tmean 506 continue return end subroutine ecapnuc(etakep,temp,rpen,rnep,spenc,snepc) include 'implno.dek' c..given the electron degeneracy parameter etakep (chemical potential c..without the electron's rest mass divided by kt) and the temperature c..temp, this routine calculates rates for c..electron capture on protons rpen (captures/sec/proton), c..positron capture on neutrons rnep (captures/sec/neutron), c..and their associated neutrino energy loss rates c..spenc (erg/sec/proton) and snepc (erg/sec/neutron) c..declare the pass double precision etakep,temp,rpen,rnep,spenc,snepc c..local variables integer iflag double precision t9,t5,qn,etaef,etael,zetan,eta,etael2, 1 etael3,etael4,f1l,f2l,f3l,f4l,f5l,f1g, 2 f2g,f3g,f4g,f5g,exmeta,eta2,eta3,eta4, 3 fac0,fac1,fac2,fac3,rie1,rie2,facv0,facv1, 4 facv2,facv3,facv4,rjv1,rjv2,spen,snep, 5 pi2,exeta,zetan2,f0,etael5,bktinv, 6 qn1,ftinv,twoln,cmk5,cmk6,bk,pi,qn2,c2me, 7 xmp,xmn,qndeca,tmean parameter (qn1 = -2.0716446d-06, 1 ftinv = 1.0d0/1083.9269d0, 2 twoln = 0.6931472d0, 3 cmk5 = 1.3635675d-49, 4 cmk6 = 2.2993864d-59, 5 bk = 1.38062e-16, 6 pi = 3.1415927d0, 7 pi2 = pi * pi, 8 qn2 = 2.0716446d-06, 9 c2me = 8.1872665d-07, & xmp = 1.6726485d-24, 1 xmn = 1.6749543d-24, 2 qndeca = 1.2533036d-06, 3 tmean = 886.7d0) c 3 tmean = 935.14d0) double precision third,sixth parameter (third = 1.0d0/3.0d0, 1 sixth = 1.0d0/6.0d0) c..tmean and qndeca are the mean lifetime and decay energy of the neutron c..xmp,xnp are masses of the p and n in grams. c..c2me is the constant used to convert the neutrino energy c..loss rate from mec2/s (as in the paper) to ergs/particle/sec. c..initialize rpen = 0.0d0 rnep = 0.0d0 spen = 0.0d0 snep = 0.0d0 t9 = temp * 1.0d-9 bktinv = 1.0d0/(bk *temp) iflag = 0 qn = qn1 c..chemical potential including the electron rest mass etaef = etakep + c2me*bktinv c..iflag=1 is for electrons, iflag=2 is for positrons 502 iflag = iflag + 1 if (iflag.eq.1) etael = qn2*bktinv if (iflag.eq.2) then etael = c2me*bktinv etaef = -etaef endif t5 = temp*temp*temp*temp*temp zetan = qn*bktinv eta = etaef - etael c..protect from overflowing with large eta values if (eta .le. 6.8e+02) then exeta = exp(eta) else exeta = 0.0d0 end if etael2 = etael*etael etael3 = etael2*etael etael4 = etael3*etael etael5 = etael4*etael zetan2 = zetan*zetan if (eta .le. 6.8e+02) then f0 = log(1.0d0 + exeta) else f0 = eta end if c..if eta le. 0., the following fermi integrals apply f1l = exeta f2l = 2.0d0 * f1l f3l = 6.0d0 * f1l f4l = 24.0d0 * f1l f5l = 120.0d0 * f1l c..if eta gt. 0., the following fermi integrals apply: f1g = 0.0d0 f2g = 0.0d0 f3g = 0.0d0 f4g = 0.0d0 f5g = 0.0d0 if (eta .gt. 0.0) then exmeta = dexp(-eta) eta2 = eta*eta eta3 = eta2*eta eta4 = eta3*eta f1g = 0.5d0*eta2 + 2.0d0 - exmeta f2g = eta3*third + 4.0d0*eta + 2.0d0*exmeta f3g = 0.25d0*eta4 + 0.5d0*pi2*eta2 + 12.0d0 - 6.0d0*exmeta f4g = 0.2d0*eta4*eta + 2.0d0*pi2*third*eta3 + 48.0d0*eta 1 + 24.0d0*exmeta f5g = eta4*eta2*sixth + 5.0d0*sixth*pi2*eta4 2 + 7.0d0*sixth*pi2*eta2 + 240.0d0 -120.d0*exmeta end if c..factors which are multiplied by the fermi integrals fac3 = 2.0d0*zetan + 4.0d0*etael fac2 = 6.0d0*etael2 + 6.0d0*etael*zetan + zetan2 fac1 = 4.0d0*etael3 + 6.0d0*etael2*zetan + 2.0d0*etael*zetan2 fac0 = etael4 + 2.0d0*zetan*etael3 + etael2*zetan2 c..electron capture rates onto protons with no blocking rie1 = f4l + fac3*f3l + fac2*f2l + fac1*f1l + fac0*f0 rie2 = f4g + fac3*f3g + fac2*f2g + fac1*f1g + fac0*f0 c..neutrino emission rate for electron capture: facv4 = 5.0d0*etael + 3.0d0*zetan facv3 = 10.0d0*etael2 + 12.0d0*etael*zetan + 3.0d0*zetan2 facv2 = 10.0d0*etael3 + 18.0d0*etael2*zetan 1 + 9.0d0*etael*zetan2 + zetan2*zetan facv1 = 5.0d0*etael4 + 12.0d0*etael3*zetan 1 + 9.0d0*etael2*zetan2 + 2.0d0*etael*zetan2*zetan facv0 = etael5 + 3.0d0*etael4*zetan 1 + 3.0d0*etael3*zetan2 + etael2*zetan2*zetan rjv1 = f5l + facv4*f4l + facv3*f3l 1 + facv2*f2l + facv1*f1l + facv0*f0 rjv2 = f5g + facv4*f4g + facv3*f3g 1 + facv2*f2g + facv1*f1g + facv0*f0 c..for electrons capture onto protons if (iflag.eq.2) go to 503 if (eta.gt.0.) go to 505 rpen = twoln*cmk5*t5*rie1*ftinv spen = twoln*cmk6*t5*temp*rjv1*ftinv spenc = twoln*cmk6*t5*temp*rjv1*ftinv*c2me go to 504 505 rpen = twoln*cmk5*t5*rie2*ftinv spen = twoln*cmk6*t5*temp*rjv2*ftinv spenc = twoln*cmk6*t5*temp*rjv2*ftinv*c2me 504 continue qn = qn2 go to 502 c..for positrons capture onto neutrons 503 if (eta.gt.0.) go to 507 rnep = twoln*cmk5*t5*rie1*ftinv snep = twoln*cmk6*t5*temp*rjv1*ftinv snepc = twoln*cmk6*t5*temp*rjv1*ftinv*c2me go to 506 507 rnep = twoln*cmk5*t5*rie2*ftinv snep = twoln*cmk6*t5*temp*rjv2*ftinv snepc = twoln*cmk6*t5*temp*rjv2*ftinv*c2me 506 continue return end subroutine time_scales(tt,dd,taud,tau_nse,tau_qse) include 'implno.dek' c..input: c..tt = temperature c..dd = desnity c.. c..output: c..taud = e-folding timescale for density in an adiabatic expansion c..tau_nse = timescale to reach nse c..tau_qse = timescale to reach qse c..declare the pass double precision tt,dd,taud,tau_nse,tau_qse c..local variables double precision t9,tmin parameter (tmin = 2.5d9) c..go if (tt .gt. tmin) then t9 = tt * 1.0d-9 tau_nse = dd**(0.2d0) * exp(179.7d0/t9 - 40.5d0) tau_qse = exp(149.7d0/t9 - 39.15d0) else tau_nse = 1.0d20 tau_qse = 1.0d20 end if taud = 446.0d0/sqrt(dd) return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- c..function wien1 c..function dwien1dx c..function wien2 c..function dwien2dx c..function func1 c..function dfunc1dx c..function func2 c..function dfunc2dx c..function bb_qromb c..function bb_trapzd c..routine bb_polint does polynomial interpolation double precision function wien1(x) include 'implno.dek' include 'const.dek' c..this is the function given in c..weinberg's "gravitation and cosmology" page 537, equation 15.6.40 c..declare the pass double precision x c..communicate xcom via common block double precision xcom common /tes1/ xcom c..local variables external func1 double precision func1,f1,con c..the integration limits ylo and yhi, along with the integration c..tolerance tol, will give at least 9 significant figures of precision double precision ylo,yhi,tol parameter (ylo = 1.0d-6, 1 yhi = 50.0d0, 2 tol = 1.0d-10, 3 con = 45.0d0/(2.0d0*pi*pi*pi*pi)) c..for quadrature integer nquad,ifirst parameter (nquad = 100) double precision xquad(nquad),wquad(nquad) data ifirst/0/ c..initialization of the quadrature abcissas and weights if (ifirst .eq. 0) then ifirst = 1 call bb_gauleg(ylo,yhi,xquad,wquad,nquad) end if c..don't do any integration if x is large enough if (x .gt. 50.0) then wien1 = 1.0d0 c..do the integration else xcom = x c call bb_qromb(func1,ylo,yhi,tol,f1) call bb_qgaus(func1,xquad,wquad,nquad,f1) wien1 = 1.0d0 + con * f1 end if return end double precision function dwien1dx(x) include 'implno.dek' include 'const.dek' c..this is the derivative with respect to x of the function given in c..weinberg's "gravitation and cosmology" page 537, equation 15.6.40 c..declare the pass double precision x c..communicate xcom via common block double precision xcom common /tes1/ xcom c..local variables external dfunc1dx double precision dfunc1dx,df1,con c..the integration limits ylo and yhi, along with the integration c..tolerance tol, will give at least 9 significant figures of precision double precision ylo,yhi,tol parameter (ylo = 1.0d-6, 1 yhi = 50.0d0, 2 tol = 1.0d-10, 3 con = 45.0d0/(2.0d0*pi*pi*pi*pi)) c..for quadrature integer nquad,ifirst parameter (nquad = 100) double precision xquad(nquad),wquad(nquad) data ifirst/0/ c..initialization of the quadrature abcissas and weights if (ifirst .eq. 0) then ifirst = 1 call bb_gauleg(ylo,yhi,xquad,wquad,nquad) end if c..don't do any integration if x is large enough if (x .gt. 50.0) then dwien1dx = 0.0d0 c..do the integration else xcom = x c call bb_qromb(dfunc1dx,ylo,yhi,tol,df1) call bb_qgaus(dfunc1dx,xquad,wquad,nquad,df1) dwien1dx = con * df1 end if return end double precision function wien2(x) include 'implno.dek' include 'const.dek' include 'network.dek' c..this is the function given in c..weinberg's "gravitation and cosmology" page 537, equation 15.6.40 c..declare the pass double precision x c..communicate xcom via common block double precision xcom common /tes1/ xcom c..communicate the number of neutrino families c..using 2 families of neutrinos duplicates the time-temperature c..table in wienberg's "gravitation and cosmology", page 540, table 15.4 c..brought in through network.dek c double precision xnnu c common /nufam/ xnnu c..local variables external func2 double precision func2,f2,wien1 c..the integration limits ylo and yhi, along with the integration c..tolerance tol, will give at least 9 significant figures of precision double precision ylo,yhi,tol,con1,con2,con3,fthirds parameter (ylo = 1.0d-6, 1 yhi = 50.0d0, 2 tol = 1.0d-10, 3 con2 = 4.0d0/11.0d0, 4 con3 = 30.0d0/(pi*pi*pi*pi), 5 fthirds = 4.0d0/3.0d0) c..for quadrature integer nquad,ifirst parameter (nquad = 100) double precision xquad(nquad),wquad(nquad) data ifirst/0/ c..initialization of the quadrature abcissas and weights if (ifirst .eq. 0) then ifirst = 1 call bb_gauleg(ylo,yhi,xquad,wquad,nquad) c..a constant that depends on the number of neutrino families con1 = xnnu * 7.0d0/8.0d0 end if c..don't do any integration if x is large enough if (x .gt. 50.0) then wien2 = 1.0d0 + con1*con2**fthirds c..do the integration else xcom = x c call bb_qromb(func2,ylo,yhi,tol,f2) call bb_qgaus(func2,xquad,wquad,nquad,f2) wien2 = 1.0d0 + con1 * (con2 * wien1(x))**fthirds + con3 * f2 end if return end double precision function dwien2dx(x) include 'implno.dek' include 'const.dek' include 'network.dek' c..this is the derivative with respect to x of the function given in c..weinberg's "gravitation and cosmology" page 537, equation 15.6.40 c..declare the pass double precision x c..communicate xcom via common block double precision xcom common /tes1/ xcom c..communicate the number of neutrino families c..using 2 families of neutrinos duplicates the time-temperature c..table in wienberg's "gravitation and cosmology", page 540, table 15.4 c..brought in through network.dek c double precision xnnu c common /nufam/ xnnu c..local variables external dfunc2dx double precision dfunc2dx,df2,wien1,w1,dwien1dx,dw1 c..the integration limits ylo and yhi, along with the integration c..tolerance tol, will give at least 9 significant figures of precision double precision ylo,yhi,tol,con1,con2,con3,fthirds,third parameter (ylo = 1.0d-6, 1 yhi = 50.0d0, 2 tol = 1.0d-10, 3 con2 = 4.0d0/11.0d0, 4 con3 = 30.0d0/(pi*pi*pi*pi), 5 fthirds = 4.0d0/3.0d0, 6 third = 1.0d0/3.0d0) c..for quadrature integer nquad,ifirst parameter (nquad = 100) double precision xquad(nquad),wquad(nquad) data ifirst/0/ c..initialization of the quadrature abcissas and weights if (ifirst .eq. 0) then ifirst = 1 call bb_gauleg(ylo,yhi,xquad,wquad,nquad) c..a constant that depends on the number of neutrino families con1 = xnnu * 7.0d0/8.0d0 end if c..don't do any integration if x is large enough if (x .gt. 50.0) then dwien2dx = 0.0d0 c..do the integration else xcom = x c call bb_qromb(dfunc2dx,ylo,yhi,tol,df2) call bb_qgaus(dfunc2dx,xquad,wquad,nquad,df2) w1 = wien1(x) dw1 = dwien1dx(x) c w2 = 1.0d0 + con1*(con2*w1)**fthirds + con3*f2 dwien2dx = fthirds*con1*(con2*w1)**third * con2*dw1 + con3*df2 end if return end double precision function func1(y) include 'implno.dek' include 'const.dek' c..this is the integrand of the function given in c..weinberg's "gravitation and cosmology" page 537, equation 15.6.40 c..declare the pass double precision y c..local variables double precision y2,x2,aa,aalim parameter (aalim = 200.0d0) c..communicate xcom via common block double precision xcom common /tes1/ xcom func1 = 0.0d0 if (aa .le. aalim) then y2 = y * y x2 = xcom * xcom aa = sqrt(y2 + x2) func1 = (aa + y2/(3.0d0*aa)) * y2 / (exp(aa) + 1.0d0) end if return end double precision function dfunc1dx(y) include 'implno.dek' include 'const.dek' c..this is the derivative with respect to x of the integrand in the function c..given by weinberg's "gravitation and cosmology" page 537, equation 15.6.40 c..declare the pass double precision y c..local variables double precision y2,x2,aa,daa,zz,denom,ddenom,f1,aalim parameter (aalim = 200.0d0) c..communicate xcom via common block double precision xcom common /tes1/ xcom dfunc1dx = 0.0d0 if (aa .le. aalim) then y2 = y * y x2 = xcom * xcom aa = sqrt(y2 + x2) daa = xcom/aa zz = exp(aa) denom = zz + 1.0d0 ddenom = zz * daa f1 = (aa + y2/(3.0d0*aa)) * y2 / denom dfunc1dx = (1.0d0 - y2/(3.0d0*aa**2)) * daa * y2 / denom 1 - f1/denom * ddenom end if return end double precision function func2(y) include 'implno.dek' include 'const.dek' c..this is the integrand of the function given in c..weinberg's "gravitation and cosmology" page 539, equation 15.6.48 c..declare the pass double precision y c..local variables double precision y2,x2,aa,aalim parameter (aalim = 200.0d0) c..communicate xcom via common block double precision xcom common /tes1/ xcom func2 = 0.0d0 if (aa .le. aalim) then y2 = y * y x2 = xcom * xcom aa = sqrt(y2 + x2) func2 = aa * y2 / (exp(aa) + 1.0d0) end if return end double precision function dfunc2dx(y) include 'implno.dek' include 'const.dek' c..this is the derivative with respect to x of the integrand c..of the function given in weinberg's "gravitation and cosmology" c..page 539, equation 15.6.48 c..declare the pass double precision y c..local variables double precision y2,x2,aa,daa,zz,denom,ddenom,aalim,f2 parameter (aalim = 200.0d0) c..communicate xcom via common block double precision xcom common /tes1/ xcom dfunc2dx = 0.0d0 if (aa .le. aalim) then y2 = y * y x2 = xcom * xcom aa = sqrt(y2 + x2) daa = xcom/aa zz = exp(aa) denom = zz + 1.0d0 ddenom = zz * daa f2 = aa * y2 / denom dfunc2dx = (daa*y2 - f2*ddenom)/denom end if return end subroutine bb_qromb(func,a,b,eps,ss) include 'implno.dek' c..returns as ss the integral of the function func from a to b with fractional c..accuracy eps. integration by romberg's method of order 2k where e.g k=2 is c..simpson's rule. c.. c..jmax limits the total number of steps; k is the c..the number of points used in the extrapolation; arrays s and h store the c..trapazoidal approximations and their relative step sizes. c..declare external func integer j,jmax,jmaxp,k,km parameter (jmax=20, jmaxp=jmax+1, k=5, km=k-1) double precision a,b,ss,s(jmaxp),h(jmaxp),eps,dss,func h(1) = 1.0d0 do j=1,jmax call bb_trapzd(func,a,b,s(j),j) if (j .ge. k) then call bb_polint(h(j-km),s(j-km),k,0.0d0,ss,dss) if (abs(dss) .le. eps*abs(ss)) return end if s(j+1) = s(j) h(j+1) = 0.25d0 * h(j) enddo c write(6,*) ' after ',jmax,' iterations ' c write(6,*) ' of trying to integrate between ',a,' and ',b c write(6,*) ' and fractional accuracy ',eps c write(6,*) ' the integral is ',ss c write(6,*) ' and error estimate ',dss c write(6,*) ' so that abs(dss) ',abs(dss), c 1 ' > eps*abs(ss)',eps*abs(ss) ss = 0.0d0 c stop 'too many steps in qromb' return end subroutine bb_trapzd(func,a,b,s,n) include 'implno.dek' c..this routine computes the n'th stage of refinement of an extended c..trapazoidal rule. func is input as the name of a function to be c..integrated between limits a and b. when n=1 the routine returns as s c..the crudest estimate of the integral of func(x)dx from a to b. c..subsequent calls with n=2,3... will improve the accuracy of s by adding c..2**(n-2) additional interior points. s should not be modified between c..sequential calls. c.. c..this routine is the workhorse of all the following closed formula c..integration routines. c.. c..local it is the number of points to be added on the next call c..local del is the step size. c.. c..declare external func integer n,it,j double precision func,a,b,s,del,x,sum,tnm c..go if (n.eq.1) then s = 0.5d0 * (b-a) * ( func(a) + func(b) ) else it = 2**(n-2) tnm = it del = (b-a)/tnm x = a + (0.5d0 *del) sum = 0.0d0 do j=1,it sum = sum + func(x) x = x + del enddo s = 0.5d0 * (s + (b-a)*sum/tnm) end if return end subroutine bb_polint(xa,ya,n,x,y,dy) include 'implno.dek' c..given arrays xa and ya of length n and a value x, this routine returns a c..value y and an error estimate dy. if p(x) is the polynomial of degree n-1 c..such that ya = p(xa) then the returned value is y = p(x) c..declare integer n,nmax,ns,i,m parameter (nmax=10) double precision xa(n),ya(n),x,y,dy,c(nmax),d(nmax),dif,dift, 1 ho,hp,w,den c..find the index ns of the closest table entry; initialize the c and d tables ns = 1 dif = abs(x - xa(1)) do i=1,n dift = abs(x - xa(i)) if (dift .lt. dif) then ns = i dif = dift end if c(i) = ya(i) d(i) = ya(i) enddo c..first guess for y y = ya(ns) c..for each column of the table, loop over the c's and d's and update them ns = ns - 1 do m=1,n-1 do i=1,n-m ho = xa(i) - x hp = xa(i+m) - x w = c(i+1) - d(i) den = ho - hp if (den .eq. 0.0) stop ' 2 xa entries are the same in polint' den = w/den d(i) = hp * den c(i) = ho * den enddo c..after each column is completed, decide which correction c or d, to add c..to the accumulating value of y, that is, which path to take in the table c..by forking up or down. ns is updated as we go to keep track of where we c..are. the last dy added is the error indicator. if (2*ns .lt. n-m) then dy = c(ns+1) else dy = d(ns) ns = ns - 1 end if y = y + dy enddo return end subroutine bb_qgaus(func,x,w,n,ss) include 'implno.dek' c..returns as ss the quadrature summation of the function func as determined c..by the abcissas x and weights w. c..declare external func integer i,n double precision func,ss,x(n),w(n) ss = 0.0d0 do i=1,n ss = ss + w(i)*func(x(i)) enddo return end subroutine bb_gauleg(x1,x2,x,w,n) include 'implno.dek' include 'const.dek' c..given the lower and upper limits of integration x1 and x2, and given n, c..this routine returns arrays x and w of length n, containing the c..abscissas and weights of the gauss-legendre n-point quadrature formula c..declare integer i,m,j,n double precision x1,x2,x(n),w(n),eps,xm,xl,p1,p2,p3,pp,z,z1 parameter (eps=1.0e-14) c..roots are symmetric in the interval so we only have to find half of them m = (n+1)/2 xm = 0.5d0 * (x2 + x1) xl = 0.5d0 * (x2 - x1) c..loop over the desired roots and make a slick guess at each one do i=1,m z = cos(3.141592653589d0 * (i-0.25d0)/(n + 0.5d0)) c..newton do while loop 1 continue p1 = 1.0d0 p2 = 0.0d0 c..loop the recurrence relation to get the legendre polynomial at z do j=1,n p3 = p2 p2 = p1 p1 = ((2.0d0 * j - 1.0d0) * z * p2 - (j - 1.0d0)*p3)/j enddo c..p1 is now the desired legendre polynomial. pp is the derivative. pp = n * (z*p1 - p2)/(z*z - 1.0d0) z1 = z z = z1 - p1/pp if (abs(z-z1) .gt. eps) goto 1 c..scale to the users interval x(i) = xm - xl*z x(n+1-i) = xm + xl * z w(i) = 2.0d0 * xl/((1.0d0 - z*z)*pp*pp) w(n+1-i) = w(i) enddo return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine net_decay_abund(xout) include 'implno.dek' include 'burn_common.dek' include 'network.dek' c..decays the composition c..declare the pass double precision xout(*) c..local variables character*80 decayed integer i,lenstr integer nsol parameter (nsol = 286) character*5 namsol(nsol) integer nzsol(nsol),nasol(nsol) double precision xstable(nsol),ag(nsol) c..popular format statements 01 format(a,'decayed.dat') 02 format(1x,i4,i4,1p2e12.4,a6) c..for the file name and open it write(decayed,01) hfile(1:lenstr(hfile,80)) call sqeeze(decayed) open(unit=51,file=decayed,status='unknown') c..convert to integers do i=1,ionmax izwork1(i) = int(zion(i)) izwork2(i) = int(aion(i)) enddo c..do the work call decay_andgrev(ionmax,izwork1,izwork2,xout, 1 nsol,namsol,nzsol,nasol,xstable,ag) c call decay_lodders(ionmax,izwork1,izwork2,xout, c 1 nsol,namsol,nzsol,nasol,xstable,ag) c..write it out write(51,02) (nzsol(i), nasol(i), xstable(i), 1 ag(i), namsol(i), i=1,nsol) c..close up shop close(unit=51) return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- c..this file contains abundance routines c..function andgrev returns the solar abundance of an isotope or element c..routine decay_andgrev reduces an abundance vector to the stable isotopes double precision function andgrev(nam,z,a,xelem) include 'implno.dek' c..anders and grevesse 1989 solar abundances from h1 to u238 c..or the lodders 2003 solar abundances from h1 to u238 c..input: c..name of the isotope nam c..output c..mass fraction andgrev c..charge z c..number of nucleons a c..elemental mass fraction associated with this isotope xelem c..declare the pass character*(*) nam double precision z,a,xelem c..for the solar abundance data integer solsiz parameter (solsiz = 286) character*5 namsol(solsiz) integer izsol(solsiz),iasol(solsiz),jcode(solsiz) double precision sol(solsiz) c..local variables integer i,j,ifirst,jbeg,jend double precision sum,zsol,yesol data ifirst/0/ c..bring in the solar abundance data c..names of the stable isotopes data (namsol(j), j=1,120) / 1 'h1 ','h2 ','he3 ','he4 ','li6 ','li7 ','be9 ','b10 ', 2 'b11 ','c12 ','c13 ','n14 ','n15 ','o16 ','o17 ','o18 ', 3 'f19 ','ne20 ','ne21 ','ne22 ','na23 ','mg24 ','mg25 ','mg26 ', 4 'al27 ','si28 ','si29 ','si30 ','p31 ','s32 ','s33 ','s34 ', 5 's36 ','cl35 ','cl37 ','ar36 ','ar38 ','ar40 ','k39 ','k40 ', 6 'k41 ','ca40 ','ca42 ','ca43 ','ca44 ','ca46 ','ca48 ','sc45 ', 7 'ti46 ','ti47 ','ti48 ','ti49 ','ti50 ','v50 ','v51 ','cr50 ', 8 'cr52 ','cr53 ','cr54 ','mn55 ','fe54 ','fe56 ','fe57 ','fe58 ', 9 'co59 ','ni58 ','ni60 ','ni61 ','ni62 ','ni64 ','cu63 ','cu65 ', & 'zn64 ','zn66 ','zn67 ','zn68 ','zn70 ','ga69 ','ga71 ','ge70 ', 1 'ge72 ','ge73 ','ge74 ','ge76 ','as75 ','se74 ','se76 ','se77 ', 2 'se78 ','se80 ','se82 ','br79 ','br81 ','kr78 ','kr80 ','kr82 ', 3 'kr83 ','kr84 ','kr86 ','rb85 ','rb87 ','sr84 ','sr86 ','sr87 ', 4 'sr88 ','y89 ','zr90 ','zr91 ','zr92 ','zr94 ','zr96 ','nb93 ', 5 'mo92 ','mo94 ','mo95 ','mo96 ','mo97 ','mo98 ','mo100','ru96 '/ data (namsol(j), j=121,240) / 1 'ru98 ','ru99 ','ru100','ru101','ru102','ru104','rh103','pd102', 2 'pd104','pd105','pd106','pd108','pd110','ag107','ag109','cd106', 3 'cd108','cd110','cd111','cd112','cd113','cd114','cd116','in113', 4 'in115','sn112','sn114','sn115','sn116','sn117','sn118','sn119', 5 'sn120','sn122','sn124','sb121','sb123','te120','te122','te123', 6 'te124','te125','te126','te128','te130','i127 ','xe124','xe126', 7 'xe128','xe129','xe130','xe131','xe132','xe134','xe136','cs133', 8 'ba130','ba132','ba134','ba135','ba136','ba137','ba138','la138', 9 'la139','ce136','ce138','ce140','ce142','pr141','nd142','nd143', & 'nd144','nd145','nd146','nd148','nd150','sm144','sm147','sm148', 1 'sm149','sm150','sm152','sm154','eu151','eu153','gd152','gd154', 2 'gd155','gd156','gd157','gd158','gd160','tb159','dy156','dy158', 3 'dy160','dy161','dy162','dy163','dy164','ho165','er162','er164', 4 'er166','er167','er168','er170','tm169','yb168','yb170','yb171', 5 'yb172','yb173','yb174','yb176','lu175','lu176','hf174','hf176'/ data (namsol(j), j=241,286) / 1 'hf177','hf178','hf179','hf180','ta180','ta181','w180 ','w182 ', 2 'w183 ','w184 ','w186 ','re185','re187','os184','os186','os187', 3 'os188','os189','os190','os192','ir191','ir193','pt190','pt192', 4 'pt194','pt195','pt196','pt198','au197','hg196','hg198','hg199', 5 'hg200','hg201','hg202','hg204','tl203','tl205','pb204','pb206', 6 'pb207','pb208','bi209','th232','u235 ','u238'/ c..anders & grevesse 1989 solar mass fractions data (sol(i),i=1,45)/ 1 7.0573E-01, 4.8010E-05, 2.9291E-05, 2.7521E-01, 6.4957E-10, 2 9.3490E-09, 1.6619E-10, 1.0674E-09, 4.7301E-09, 3.0324E-03, 3 3.6501E-05, 1.1049E-03, 4.3634E-06, 9.5918E-03, 3.8873E-06, 4 2.1673E-05, 4.0515E-07, 1.6189E-03, 4.1274E-06, 1.3022E-04, 5 3.3394E-05, 5.1480E-04, 6.7664E-05, 7.7605E-05, 5.8052E-05, 6 6.5301E-04, 3.4257E-05, 2.3524E-05, 8.1551E-06, 3.9581E-04, 7 3.2221E-06, 1.8663E-05, 9.3793E-08, 2.5320E-06, 8.5449E-07, 8 7.7402E-05, 1.5379E-05, 2.6307E-08, 3.4725E-06, 4.4519E-10, 9 2.6342E-07, 5.9898E-05, 4.1964E-07, 8.9734E-07, 1.4135E-06/ data (sol(i),i=46,90)/ 1 2.7926E-09, 1.3841E-07, 3.8929E-08, 2.2340E-07, 2.0805E-07, 2 2.1491E-06, 1.6361E-07, 1.6442E-07, 9.2579E-10, 3.7669E-07, 3 7.4240E-07, 1.4863E-05, 1.7160E-06, 4.3573E-07, 1.3286E-05, 4 7.1301E-05, 1.1686E-03, 2.8548E-05, 3.6971E-06, 3.3579E-06, 5 4.9441E-05, 1.9578E-05, 8.5944E-07, 2.7759E-06, 7.2687E-07, 6 5.7528E-07, 2.6471E-07, 9.9237E-07, 5.8765E-07, 8.7619E-08, 7 4.0593E-07, 1.3811E-08, 3.9619E-08, 2.7119E-08, 4.3204E-08, 8 5.9372E-08, 1.7136E-08, 8.1237E-08, 1.7840E-08, 1.2445E-08, 9 1.0295E-09, 1.0766E-08, 9.1542E-09, 2.9003E-08, 6.2529E-08/ data (sol(i),i=91,135)/ 1 1.1823E-08, 1.1950E-08, 1.2006E-08, 3.0187E-10, 2.0216E-09, 2 1.0682E-08, 1.0833E-08, 5.4607E-08, 1.7055E-08, 1.1008E-08, 3 4.3353E-09, 2.8047E-10, 5.0468E-09, 3.6091E-09, 4.3183E-08, 4 1.0446E-08, 1.3363E-08, 2.9463E-09, 4.5612E-09, 4.7079E-09, 5 7.7706E-10, 1.6420E-09, 8.7966E-10, 5.6114E-10, 9.7562E-10, 6 1.0320E-09, 5.9868E-10, 1.5245E-09, 6.2225E-10, 2.5012E-10, 7 8.6761E-11, 5.9099E-10, 5.9190E-10, 8.0731E-10, 1.5171E-09, 8 9.1547E-10, 8.9625E-10, 3.6637E-11, 4.0775E-10, 8.2335E-10, 9 1.0189E-09, 1.0053E-09, 4.5354E-10, 6.8205E-10, 6.4517E-10/ data (sol(i),i=136,180)/ 1 5.3893E-11, 3.9065E-11, 5.5927E-10, 5.7839E-10, 1.0992E-09, 2 5.6309E-10, 1.3351E-09, 3.5504E-10, 2.2581E-11, 5.1197E-10, 3 1.0539E-10, 7.1802E-11, 3.9852E-11, 1.6285E-09, 8.6713E-10, 4 2.7609E-09, 9.8731E-10, 3.7639E-09, 5.4622E-10, 6.9318E-10, 5 5.4174E-10, 4.1069E-10, 1.3052E-11, 3.8266E-10, 1.3316E-10, 6 7.1827E-10, 1.0814E-09, 3.1553E-09, 4.9538E-09, 5.3600E-09, 7 2.8912E-09, 1.7910E-11, 1.6223E-11, 3.3349E-10, 4.1767E-09, 8 6.7411E-10, 3.3799E-09, 4.1403E-09, 1.5558E-09, 1.2832E-09, 9 1.2515E-09, 1.5652E-11, 1.5125E-11, 3.6946E-10, 1.0108E-09/ data (sol(i),i=181,225)/ 1 1.2144E-09, 1.7466E-09, 1.1240E-08, 1.3858E-12, 1.5681E-09, 2 7.4306E-12, 9.9136E-12, 3.5767E-09, 4.5258E-10, 5.9562E-10, 3 8.0817E-10, 3.6533E-10, 7.1757E-10, 2.5198E-10, 5.2441E-10, 4 1.7857E-10, 1.7719E-10, 2.9140E-11, 1.4390E-10, 1.0931E-10, 5 1.3417E-10, 7.2470E-11, 2.6491E-10, 2.2827E-10, 1.7761E-10, 6 1.9660E-10, 2.5376E-12, 2.8008E-11, 1.9133E-10, 2.6675E-10, 7 2.0492E-10, 3.2772E-10, 2.9180E-10, 2.8274E-10, 8.6812E-13, 8 1.4787E-12, 3.7315E-11, 3.0340E-10, 4.1387E-10, 4.0489E-10, 9 4.6047E-10, 3.7104E-10, 1.4342E-12, 1.6759E-11, 3.5397E-10/ data (sol(i),i=226,270)/ 1 2.4332E-10, 2.8557E-10, 1.6082E-10, 1.6159E-10, 1.3599E-12, 2 3.2509E-11, 1.5312E-10, 2.3624E-10, 1.7504E-10, 3.4682E-10, 3 1.4023E-10, 1.5803E-10, 4.2293E-12, 1.0783E-12, 3.4992E-11, 4 1.2581E-10, 1.8550E-10, 9.3272E-11, 2.4131E-10, 1.1292E-14, 5 9.4772E-11, 7.8768E-13, 1.6113E-10, 8.7950E-11, 1.8989E-10, 6 1.7878E-10, 9.0315E-11, 1.5326E-10, 5.6782E-13, 5.0342E-11, 7 5.1086E-11, 4.2704E-10, 5.2110E-10, 8.5547E-10, 1.3453E-09, 8 1.1933E-09, 2.0211E-09, 8.1702E-13, 5.0994E-11, 2.1641E-09, 9 2.2344E-09, 1.6757E-09, 4.8231E-10, 9.3184E-10, 2.3797E-12/ data (sol(i),i=271,286)/ 1 1.7079E-10, 2.8843E-10, 3.9764E-10, 2.2828E-10, 5.1607E-10, 2 1.2023E-10, 2.7882E-10, 6.7411E-10, 3.1529E-10, 3.1369E-09, 3 3.4034E-09, 9.6809E-09, 7.6127E-10, 1.9659E-10, 3.8519E-13, 4 5.3760E-11/ c..charge of the stable isotopes data (izsol(i),i=1,117)/ 1 1, 1, 2, 2, 3, 3, 4, 5, 5, 6, 6, 7, 7, 2 8, 8, 8, 9, 10, 10, 10, 11, 12, 12, 12, 13, 14, 3 14, 14, 15, 16, 16, 16, 16, 17, 17, 18, 18, 18, 19, 4 19, 19, 20, 20, 20, 20, 20, 20, 21, 22, 22, 22, 22, 5 22, 23, 23, 24, 24, 24, 24, 25, 26, 26, 26, 26, 27, 6 28, 28, 28, 28, 28, 29, 29, 30, 30, 30, 30, 30, 31, 7 31, 32, 32, 32, 32, 32, 33, 34, 34, 34, 34, 34, 34, 8 35, 35, 36, 36, 36, 36, 36, 36, 37, 37, 38, 38, 38, 9 38, 39, 40, 40, 40, 40, 40, 41, 42, 42, 42, 42, 42/ data (izsol(i),i=118,234)/ 1 42, 42, 44, 44, 44, 44, 44, 44, 44, 45, 46, 46, 46, 2 46, 46, 46, 47, 47, 48, 48, 48, 48, 48, 48, 48, 48, 3 49, 49, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 51, 4 51, 52, 52, 52, 52, 52, 52, 52, 52, 53, 54, 54, 54, 5 54, 54, 54, 54, 54, 54, 55, 56, 56, 56, 56, 56, 56, 6 56, 57, 57, 58, 58, 58, 58, 59, 60, 60, 60, 60, 60, 7 60, 60, 62, 62, 62, 62, 62, 62, 62, 63, 63, 64, 64, 8 64, 64, 64, 64, 64, 65, 66, 66, 66, 66, 66, 66, 66, 9 67, 68, 68, 68, 68, 68, 68, 69, 70, 70, 70, 70, 70/ data (izsol(i),i=235,286)/ 1 70, 70, 71, 71, 72, 72, 72, 72, 72, 72, 73, 73, 74, 2 74, 74, 74, 74, 75, 75, 76, 76, 76, 76, 76, 76, 76, 3 77, 77, 78, 78, 78, 78, 78, 78, 79, 80, 80, 80, 80, 4 80, 80, 80, 81, 81, 82, 82, 82, 82, 83, 90, 92, 92/ c..number of nucleons (protons and neutrons) in the stable isotopes data (iasol(i),i=1,117)/ 1 1, 2, 3, 4, 6, 7, 9, 10, 11, 12, 13, 14, 15, 2 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 3 29, 30, 31, 32, 33, 34, 36, 35, 37, 36, 38, 40, 39, 4 40, 41, 40, 42, 43, 44, 46, 48, 45, 46, 47, 48, 49, 5 50, 50, 51, 50, 52, 53, 54, 55, 54, 56, 57, 58, 59, 6 58, 60, 61, 62, 64, 63, 65, 64, 66, 67, 68, 70, 69, 7 71, 70, 72, 73, 74, 76, 75, 74, 76, 77, 78, 80, 82, 8 79, 81, 78, 80, 82, 83, 84, 86, 85, 87, 84, 86, 87, 9 88, 89, 90, 91, 92, 94, 96, 93, 92, 94, 95, 96, 97/ data (iasol(i),i=118,234)/ 1 98, 100, 96, 98, 99, 100, 101, 102, 104, 103, 102, 104, 105, 2 106, 108, 110, 107, 109, 106, 108, 110, 111, 112, 113, 114, 116, 3 113, 115, 112, 114, 115, 116, 117, 118, 119, 120, 122, 124, 121, 4 123, 120, 122, 123, 124, 125, 126, 128, 130, 127, 124, 126, 128, 5 129, 130, 131, 132, 134, 136, 133, 130, 132, 134, 135, 136, 137, 6 138, 138, 139, 136, 138, 140, 142, 141, 142, 143, 144, 145, 146, 7 148, 150, 144, 147, 148, 149, 150, 152, 154, 151, 153, 152, 154, 8 155, 156, 157, 158, 160, 159, 156, 158, 160, 161, 162, 163, 164, 9 165, 162, 164, 166, 167, 168, 170, 169, 168, 170, 171, 172, 173/ data (iasol(i),i=235,286)/ 1 174, 176, 175, 176, 174, 176, 177, 178, 179, 180, 180, 181, 180, 2 182, 183, 184, 186, 185, 187, 184, 186, 187, 188, 189, 190, 192, 3 191, 193, 190, 192, 194, 195, 196, 198, 197, 196, 198, 199, 200, 4 201, 202, 204, 203, 205, 204, 206, 207, 208, 209, 232, 235, 238/ c..jcode tells the type progenitors each stable species can have. c..jcode = 0 if the species is the only stable one of that a c.. = 1 if the species can have proton-rich progenitors c.. = 2 if the species can have neutron-rich progenitors c.. = 3 if the species can only be made as itself (eg k40) data (jcode(i),i=1,117)/ 1 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3 0, 0, 0, 0, 0, 0, 2, 0, 0, 1, 0, 2, 0, 4 3, 0, 1, 0, 0, 0, 2, 2, 0, 1, 0, 1, 0, 5 2, 3, 0, 1, 0, 0, 2, 0, 1, 0, 0, 2, 0, 6 1, 0, 0, 0, 2, 0, 0, 1, 0, 0, 0, 2, 0, 7 0, 1, 0, 0, 2, 2, 0, 1, 1, 0, 2, 2, 2, 8 0, 0, 1, 1, 1, 0, 2, 2, 0, 2, 1, 1, 1, 9 0, 0, 0, 0, 2, 2, 2, 0, 1, 1, 0, 3, 0/ data (jcode(i),i=118,234)/ 1 2, 2, 1, 1, 0, 1, 0, 2, 2, 0, 1, 1, 0, 2 2, 2, 2, 0, 0, 1, 1, 1, 0, 2, 2, 2, 2, 3 1, 2, 1, 1, 1, 1, 0, 0, 0, 2, 2, 2, 0, 4 2, 1, 1, 1, 3, 0, 2, 2, 2, 0, 1, 1, 1, 5 0, 3, 0, 2, 2, 2, 0, 1, 1, 1, 0, 3, 0, 6 2, 3, 0, 1, 1, 0, 2, 0, 1, 0, 2, 0, 0, 7 2, 2, 1, 0, 1, 0, 1, 2, 2, 0, 0, 1, 1, 8 0, 2, 0, 2, 2, 0, 1, 1, 1, 0, 2, 0, 2, 9 0, 1, 1, 0, 0, 2, 2, 0, 1, 1, 0, 0, 0/ data (jcode(i),i=235,286)/ 1 2, 2, 0, 3, 1, 1, 0, 0, 0, 2, 3, 0, 1, 2 0, 0, 2, 2, 0, 2, 1, 1, 1, 0, 0, 2, 2, 3 0, 0, 1, 1, 0, 0, 2, 2, 0, 1, 1, 0, 0, 4 0, 0, 2, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0/ c include 'solar_data_lodders_2003.f' c..sum; stuff residual into hydrogen if (ifirst .eq. 0) then ifirst = 1 sum = 0.0d0 do j=1,solsiz sum = sum + sol(j) enddo sum = 1.0d0 - sum sol(1) = sol(1) + sum sum = 0.0d0 do j=1,solsiz if (izsol(j) .ge. 3) then sum = sum + sol(j) endif enddo zsol = sum sum = 0.0d0 do j=1,solsiz if (izsol(j) .ge. 3) then sum = sum + float(izsol(j))/float(iasol(j))*sol(j) endif enddo yesol = sum end if c..straight sweep andgrev = 0.0d0 z = 0.0d0 a = 0.0d0 if (len(nam) .lt. 5) stop 'nam < 5 characters in routine andgrev' do i=1,solsiz if ( namsol(i)(1:5) .eq. nam(1:5) ) then c..load the mass fraction, charge, and number of nucleons andgrev = sol(i) z = float(izsol(i)) a = float(iasol(i)) c..load the elmental mass fraction associated with this isotope xelem = 0.0d0 jbeg = max(1,i-12) jend = min(i+12,solsiz) do j=jbeg,jend if (izsol(j) .eq. z) xelem = xelem + sol(j) enddo c..bail return end if enddo c write(6,*) 'warning: no such entry ',nam(1:5) return end subroutine decay_andgrev(nin,nz,na,xin, 1 nout,namout,nzout,naout,xout,ag) include 'implno.dek' c..converts a radioactive nucleosynthesis down to their final c..stable mass fractions c..declare the pass integer nin,nout character*5 namout(nout) integer nz(nin),na(nin),nzout(nout),naout(nout) double precision xin(nin),xout(nout),ag(nout) c..for the solar abundance data integer solsiz parameter (solsiz = 286) character*5 namsol(solsiz) integer izsol(solsiz),iasol(solsiz),jcode(solsiz) double precision sol(solsiz) c..local variables integer i,j double precision termx,sum,xx c..bring in the solar abundance data c..names of the stable isotopes data (namsol(j), j=1,120) / 1 'h1 ','h2 ','he3 ','he4 ','li6 ','li7 ','be9 ','b10 ', 2 'b11 ','c12 ','c13 ','n14 ','n15 ','o16 ','o17 ','o18 ', 3 'f19 ','ne20 ','ne21 ','ne22 ','na23 ','mg24 ','mg25 ','mg26 ', 4 'al27 ','si28 ','si29 ','si30 ','p31 ','s32 ','s33 ','s34 ', 5 's36 ','cl35 ','cl37 ','ar36 ','ar38 ','ar40 ','k39 ','k40 ', 6 'k41 ','ca40 ','ca42 ','ca43 ','ca44 ','ca46 ','ca48 ','sc45 ', 7 'ti46 ','ti47 ','ti48 ','ti49 ','ti50 ','v50 ','v51 ','cr50 ', 8 'cr52 ','cr53 ','cr54 ','mn55 ','fe54 ','fe56 ','fe57 ','fe58 ', 9 'co59 ','ni58 ','ni60 ','ni61 ','ni62 ','ni64 ','cu63 ','cu65 ', & 'zn64 ','zn66 ','zn67 ','zn68 ','zn70 ','ga69 ','ga71 ','ge70 ', 1 'ge72 ','ge73 ','ge74 ','ge76 ','as75 ','se74 ','se76 ','se77 ', 2 'se78 ','se80 ','se82 ','br79 ','br81 ','kr78 ','kr80 ','kr82 ', 3 'kr83 ','kr84 ','kr86 ','rb85 ','rb87 ','sr84 ','sr86 ','sr87 ', 4 'sr88 ','y89 ','zr90 ','zr91 ','zr92 ','zr94 ','zr96 ','nb93 ', 5 'mo92 ','mo94 ','mo95 ','mo96 ','mo97 ','mo98 ','mo100','ru96 '/ data (namsol(j), j=121,240) / 1 'ru98 ','ru99 ','ru100','ru101','ru102','ru104','rh103','pd102', 2 'pd104','pd105','pd106','pd108','pd110','ag107','ag109','cd106', 3 'cd108','cd110','cd111','cd112','cd113','cd114','cd116','in113', 4 'in115','sn112','sn114','sn115','sn116','sn117','sn118','sn119', 5 'sn120','sn122','sn124','sb121','sb123','te120','te122','te123', 6 'te124','te125','te126','te128','te130','i127 ','xe124','xe126', 7 'xe128','xe129','xe130','xe131','xe132','xe134','xe136','cs133', 8 'ba130','ba132','ba134','ba135','ba136','ba137','ba138','la138', 9 'la139','ce136','ce138','ce140','ce142','pr141','nd142','nd143', & 'nd144','nd145','nd146','nd148','nd150','sm144','sm147','sm148', 1 'sm149','sm150','sm152','sm154','eu151','eu153','gd152','gd154', 2 'gd155','gd156','gd157','gd158','gd160','tb159','dy156','dy158', 3 'dy160','dy161','dy162','dy163','dy164','ho165','er162','er164', 4 'er166','er167','er168','er170','tm169','yb168','yb170','yb171', 5 'yb172','yb173','yb174','yb176','lu175','lu176','hf174','hf176'/ data (namsol(j), j=241,286) / 1 'hf177','hf178','hf179','hf180','ta180','ta181','w180 ','w182 ', 2 'w183 ','w184 ','w186 ','re185','re187','os184','os186','os187', 3 'os188','os189','os190','os192','ir191','ir193','pt190','pt192', 4 'pt194','pt195','pt196','pt198','au197','hg196','hg198','hg199', 5 'hg200','hg201','hg202','hg204','tl203','tl205','pb204','pb206', 6 'pb207','pb208','bi209','th232','u235 ','u238'/ c..anders & grevesse 1989 solar mass fractions data (sol(i),i=1,45)/ 1 7.0573E-01, 4.8010E-05, 2.9291E-05, 2.7521E-01, 6.4957E-10, 2 9.3490E-09, 1.6619E-10, 1.0674E-09, 4.7301E-09, 3.0324E-03, 3 3.6501E-05, 1.1049E-03, 4.3634E-06, 9.5918E-03, 3.8873E-06, 4 2.1673E-05, 4.0515E-07, 1.6189E-03, 4.1274E-06, 1.3022E-04, 5 3.3394E-05, 5.1480E-04, 6.7664E-05, 7.7605E-05, 5.8052E-05, 6 6.5301E-04, 3.4257E-05, 2.3524E-05, 8.1551E-06, 3.9581E-04, 7 3.2221E-06, 1.8663E-05, 9.3793E-08, 2.5320E-06, 8.5449E-07, 8 7.7402E-05, 1.5379E-05, 2.6307E-08, 3.4725E-06, 4.4519E-10, 9 2.6342E-07, 5.9898E-05, 4.1964E-07, 8.9734E-07, 1.4135E-06/ data (sol(i),i=46,90)/ 1 2.7926E-09, 1.3841E-07, 3.8929E-08, 2.2340E-07, 2.0805E-07, 2 2.1491E-06, 1.6361E-07, 1.6442E-07, 9.2579E-10, 3.7669E-07, 3 7.4240E-07, 1.4863E-05, 1.7160E-06, 4.3573E-07, 1.3286E-05, 4 7.1301E-05, 1.1686E-03, 2.8548E-05, 3.6971E-06, 3.3579E-06, 5 4.9441E-05, 1.9578E-05, 8.5944E-07, 2.7759E-06, 7.2687E-07, 6 5.7528E-07, 2.6471E-07, 9.9237E-07, 5.8765E-07, 8.7619E-08, 7 4.0593E-07, 1.3811E-08, 3.9619E-08, 2.7119E-08, 4.3204E-08, 8 5.9372E-08, 1.7136E-08, 8.1237E-08, 1.7840E-08, 1.2445E-08, 9 1.0295E-09, 1.0766E-08, 9.1542E-09, 2.9003E-08, 6.2529E-08/ data (sol(i),i=91,135)/ 1 1.1823E-08, 1.1950E-08, 1.2006E-08, 3.0187E-10, 2.0216E-09, 2 1.0682E-08, 1.0833E-08, 5.4607E-08, 1.7055E-08, 1.1008E-08, 3 4.3353E-09, 2.8047E-10, 5.0468E-09, 3.6091E-09, 4.3183E-08, 4 1.0446E-08, 1.3363E-08, 2.9463E-09, 4.5612E-09, 4.7079E-09, 5 7.7706E-10, 1.6420E-09, 8.7966E-10, 5.6114E-10, 9.7562E-10, 6 1.0320E-09, 5.9868E-10, 1.5245E-09, 6.2225E-10, 2.5012E-10, 7 8.6761E-11, 5.9099E-10, 5.9190E-10, 8.0731E-10, 1.5171E-09, 8 9.1547E-10, 8.9625E-10, 3.6637E-11, 4.0775E-10, 8.2335E-10, 9 1.0189E-09, 1.0053E-09, 4.5354E-10, 6.8205E-10, 6.4517E-10/ data (sol(i),i=136,180)/ 1 5.3893E-11, 3.9065E-11, 5.5927E-10, 5.7839E-10, 1.0992E-09, 2 5.6309E-10, 1.3351E-09, 3.5504E-10, 2.2581E-11, 5.1197E-10, 3 1.0539E-10, 7.1802E-11, 3.9852E-11, 1.6285E-09, 8.6713E-10, 4 2.7609E-09, 9.8731E-10, 3.7639E-09, 5.4622E-10, 6.9318E-10, 5 5.4174E-10, 4.1069E-10, 1.3052E-11, 3.8266E-10, 1.3316E-10, 6 7.1827E-10, 1.0814E-09, 3.1553E-09, 4.9538E-09, 5.3600E-09, 7 2.8912E-09, 1.7910E-11, 1.6223E-11, 3.3349E-10, 4.1767E-09, 8 6.7411E-10, 3.3799E-09, 4.1403E-09, 1.5558E-09, 1.2832E-09, 9 1.2515E-09, 1.5652E-11, 1.5125E-11, 3.6946E-10, 1.0108E-09/ data (sol(i),i=181,225)/ 1 1.2144E-09, 1.7466E-09, 1.1240E-08, 1.3858E-12, 1.5681E-09, 2 7.4306E-12, 9.9136E-12, 3.5767E-09, 4.5258E-10, 5.9562E-10, 3 8.0817E-10, 3.6533E-10, 7.1757E-10, 2.5198E-10, 5.2441E-10, 4 1.7857E-10, 1.7719E-10, 2.9140E-11, 1.4390E-10, 1.0931E-10, 5 1.3417E-10, 7.2470E-11, 2.6491E-10, 2.2827E-10, 1.7761E-10, 6 1.9660E-10, 2.5376E-12, 2.8008E-11, 1.9133E-10, 2.6675E-10, 7 2.0492E-10, 3.2772E-10, 2.9180E-10, 2.8274E-10, 8.6812E-13, 8 1.4787E-12, 3.7315E-11, 3.0340E-10, 4.1387E-10, 4.0489E-10, 9 4.6047E-10, 3.7104E-10, 1.4342E-12, 1.6759E-11, 3.5397E-10/ data (sol(i),i=226,270)/ 1 2.4332E-10, 2.8557E-10, 1.6082E-10, 1.6159E-10, 1.3599E-12, 2 3.2509E-11, 1.5312E-10, 2.3624E-10, 1.7504E-10, 3.4682E-10, 3 1.4023E-10, 1.5803E-10, 4.2293E-12, 1.0783E-12, 3.4992E-11, 4 1.2581E-10, 1.8550E-10, 9.3272E-11, 2.4131E-10, 1.1292E-14, 5 9.4772E-11, 7.8768E-13, 1.6113E-10, 8.7950E-11, 1.8989E-10, 6 1.7878E-10, 9.0315E-11, 1.5326E-10, 5.6782E-13, 5.0342E-11, 7 5.1086E-11, 4.2704E-10, 5.2110E-10, 8.5547E-10, 1.3453E-09, 8 1.1933E-09, 2.0211E-09, 8.1702E-13, 5.0994E-11, 2.1641E-09, 9 2.2344E-09, 1.6757E-09, 4.8231E-10, 9.3184E-10, 2.3797E-12/ data (sol(i),i=271,286)/ 1 1.7079E-10, 2.8843E-10, 3.9764E-10, 2.2828E-10, 5.1607E-10, 2 1.2023E-10, 2.7882E-10, 6.7411E-10, 3.1529E-10, 3.1369E-09, 3 3.4034E-09, 9.6809E-09, 7.6127E-10, 1.9659E-10, 3.8519E-13, 4 5.3760E-11/ c..charge of the stable isotopes data (izsol(i),i=1,117)/ 1 1, 1, 2, 2, 3, 3, 4, 5, 5, 6, 6, 7, 7, 2 8, 8, 8, 9, 10, 10, 10, 11, 12, 12, 12, 13, 14, 3 14, 14, 15, 16, 16, 16, 16, 17, 17, 18, 18, 18, 19, 4 19, 19, 20, 20, 20, 20, 20, 20, 21, 22, 22, 22, 22, 5 22, 23, 23, 24, 24, 24, 24, 25, 26, 26, 26, 26, 27, 6 28, 28, 28, 28, 28, 29, 29, 30, 30, 30, 30, 30, 31, 7 31, 32, 32, 32, 32, 32, 33, 34, 34, 34, 34, 34, 34, 8 35, 35, 36, 36, 36, 36, 36, 36, 37, 37, 38, 38, 38, 9 38, 39, 40, 40, 40, 40, 40, 41, 42, 42, 42, 42, 42/ data (izsol(i),i=118,234)/ 1 42, 42, 44, 44, 44, 44, 44, 44, 44, 45, 46, 46, 46, 2 46, 46, 46, 47, 47, 48, 48, 48, 48, 48, 48, 48, 48, 3 49, 49, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 51, 4 51, 52, 52, 52, 52, 52, 52, 52, 52, 53, 54, 54, 54, 5 54, 54, 54, 54, 54, 54, 55, 56, 56, 56, 56, 56, 56, 6 56, 57, 57, 58, 58, 58, 58, 59, 60, 60, 60, 60, 60, 7 60, 60, 62, 62, 62, 62, 62, 62, 62, 63, 63, 64, 64, 8 64, 64, 64, 64, 64, 65, 66, 66, 66, 66, 66, 66, 66, 9 67, 68, 68, 68, 68, 68, 68, 69, 70, 70, 70, 70, 70/ data (izsol(i),i=235,286)/ 1 70, 70, 71, 71, 72, 72, 72, 72, 72, 72, 73, 73, 74, 2 74, 74, 74, 74, 75, 75, 76, 76, 76, 76, 76, 76, 76, 3 77, 77, 78, 78, 78, 78, 78, 78, 79, 80, 80, 80, 80, 4 80, 80, 80, 81, 81, 82, 82, 82, 82, 83, 90, 92, 92/ c..number of nucleons (protons and neutrons) in the stable isotopes data (iasol(i),i=1,117)/ 1 1, 2, 3, 4, 6, 7, 9, 10, 11, 12, 13, 14, 15, 2 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 3 29, 30, 31, 32, 33, 34, 36, 35, 37, 36, 38, 40, 39, 4 40, 41, 40, 42, 43, 44, 46, 48, 45, 46, 47, 48, 49, 5 50, 50, 51, 50, 52, 53, 54, 55, 54, 56, 57, 58, 59, 6 58, 60, 61, 62, 64, 63, 65, 64, 66, 67, 68, 70, 69, 7 71, 70, 72, 73, 74, 76, 75, 74, 76, 77, 78, 80, 82, 8 79, 81, 78, 80, 82, 83, 84, 86, 85, 87, 84, 86, 87, 9 88, 89, 90, 91, 92, 94, 96, 93, 92, 94, 95, 96, 97/ data (iasol(i),i=118,234)/ 1 98, 100, 96, 98, 99, 100, 101, 102, 104, 103, 102, 104, 105, 2 106, 108, 110, 107, 109, 106, 108, 110, 111, 112, 113, 114, 116, 3 113, 115, 112, 114, 115, 116, 117, 118, 119, 120, 122, 124, 121, 4 123, 120, 122, 123, 124, 125, 126, 128, 130, 127, 124, 126, 128, 5 129, 130, 131, 132, 134, 136, 133, 130, 132, 134, 135, 136, 137, 6 138, 138, 139, 136, 138, 140, 142, 141, 142, 143, 144, 145, 146, 7 148, 150, 144, 147, 148, 149, 150, 152, 154, 151, 153, 152, 154, 8 155, 156, 157, 158, 160, 159, 156, 158, 160, 161, 162, 163, 164, 9 165, 162, 164, 166, 167, 168, 170, 169, 168, 170, 171, 172, 173/ data (iasol(i),i=235,286)/ 1 174, 176, 175, 176, 174, 176, 177, 178, 179, 180, 180, 181, 180, 2 182, 183, 184, 186, 185, 187, 184, 186, 187, 188, 189, 190, 192, 3 191, 193, 190, 192, 194, 195, 196, 198, 197, 196, 198, 199, 200, 4 201, 202, 204, 203, 205, 204, 206, 207, 208, 209, 232, 235, 238/ c..jcode tells the type progenitors each stable species can have. c..jcode = 0 if the species is the only stable one of that a c.. = 1 if the species can have proton-rich progenitors c.. = 2 if the species can have neutron-rich progenitors c.. = 3 if the species can only be made as itself (eg k40) data (jcode(i),i=1,117)/ 1 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3 0, 0, 0, 0, 0, 0, 2, 0, 0, 1, 0, 2, 0, 4 3, 0, 1, 0, 0, 0, 2, 2, 0, 1, 0, 1, 0, 5 2, 3, 0, 1, 0, 0, 2, 0, 1, 0, 0, 2, 0, 6 1, 0, 0, 0, 2, 0, 0, 1, 0, 0, 0, 2, 0, 7 0, 1, 0, 0, 2, 2, 0, 1, 1, 0, 2, 2, 2, 8 0, 0, 1, 1, 1, 0, 2, 2, 0, 2, 1, 1, 1, 9 0, 0, 0, 0, 2, 2, 2, 0, 1, 1, 0, 3, 0/ data (jcode(i),i=118,234)/ 1 2, 2, 1, 1, 0, 1, 0, 2, 2, 0, 1, 1, 0, 2 2, 2, 2, 0, 0, 1, 1, 1, 0, 2, 2, 2, 2, 3 1, 2, 1, 1, 1, 1, 0, 0, 0, 2, 2, 2, 0, 4 2, 1, 1, 1, 3, 0, 2, 2, 2, 0, 1, 1, 1, 5 0, 3, 0, 2, 2, 2, 0, 1, 1, 1, 0, 3, 0, 6 2, 3, 0, 1, 1, 0, 2, 0, 1, 0, 2, 0, 0, 7 2, 2, 1, 0, 1, 0, 1, 2, 2, 0, 0, 1, 1, 8 0, 2, 0, 2, 2, 0, 1, 1, 1, 0, 2, 0, 2, 9 0, 1, 1, 0, 0, 2, 2, 0, 1, 1, 0, 0, 0/ data (jcode(i),i=235,286)/ 1 2, 2, 0, 3, 1, 1, 0, 0, 0, 2, 3, 0, 1, 2 0, 0, 2, 2, 0, 2, 1, 1, 1, 0, 0, 2, 2, 3 0, 0, 1, 1, 0, 0, 2, 2, 0, 1, 1, 0, 0, 4 0, 0, 2, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0/ c include 'solar_data_lodders_2003.f' c..initialize if (nout .lt. solsiz) stop 'not < solsiz in routine decay_andgrev' do i=1,solsiz xout(i) = 0.0d0 namout(i) = namsol(i) nzout(i) = izsol(i) naout(i) = iasol(i) enddo c..start the conversion do 400 i=1,nin c..for every isotope in the solar list do 390 j=1,solsiz if (na(i) .ne. iasol(j)) goto 390 if (jcode(j) .eq. 0) goto 350 if (nz(i).ge.izsol(j) .and. jcode(j).eq.1) goto 350 if (nz(i).le.izsol(j) .and. jcode(j).eq.2) goto 350 if (nz(i).eq.izsol(j) .and. jcode(j).eq.3) goto 350 goto 390 350 termx = xin(i) xout(j) = xout(j) + termx c..record the isotope that makes the largest contribution c..to this stable isotope c if (termx .le. prod(j)) goto 389 c prod(j) = termx c nzprod(j) = nz(i) c naprod(j) = na(i) c389 continue goto 400 390 continue 400 continue c..scaled to solar do i=1,solsiz ag(i) = xout(i)/sol(i) enddo return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine net_output(kount,x,y,derivs) include 'implno.dek' include 'const.dek' include 'vector_eos.dek' include 'burn_common.dek' include 'network.dek' include 'cjdet.dek' c..writes the output c..declare the pass external derivs integer kount double precision x,y(*) c..local variables character*8 atim character*9 adat character*80 string integer k,kk,j,lop,ilop,jrem,kb,ke,nn,lenstr double precision sum,xcons,ycons,yex,ydum(abignet), 1 dydt_dum(nzmax*abignet),xdum(abignet), 2 abar,zbar,wbar,ye,xcess,zero,tdum,ddum,pdum, 3 ener,denerdt,zc12,xc12,ff, 4 chem_pot(nzmax*abignet),chem_sum, 5 ydum_sav(nzmax*abignet) parameter (zero = 0.0d0) c..for nse integer igues double precision xmun,xmup,t9,tau_nse,tau_qse,taud c..popular format statements 01 format(1x,'*',t13,a,t33,a,t47,a,t61,a,t75,a,t89,a, 1 t103,a,t117,a,t131,a,t145,a,t159,a) 03 format(a30,i4.4,a2,i8,a) 04 format(1x,i6,1pe20.12,1p15e14.6) 05 format(1x,i6,1pe20.12,1p12e14.6) 07 format(1x,'* ',a,4(a,1pe11.3)) c write(6,*) kount,neqs,nzone c..initialize the files with their headers if (kount .eq. 1) then c..for every spatial zone do k=1,max(1,nzone) kk = neqs*(k-1) c..logical unit 22 records the energetics write(string,03) hfile,0,'_z',k,'.dat' call sqeeze(string) call today(adat,atim) open (unit=22, file=string, status='unknown') c..logical unit 23 records the thermodynamics write(string,03) hfile,1,'_z',k,'.dat' call sqeeze(string) open (unit=23, file=string, status='unknown') write(22,01) adat,atim write(23,01) adat,atim if (one_step) then write(22,07) 'one_step:',' btemp=',btemp,' bden=',bden write(23,07) 'one_step:',' btemp=',btemp,' bden=',bden else if (hydrostatic) then write(22,07) 'hydrostatic:',' btemp=',btemp,' bden=',bden write(23,07) 'hydrostatic:',' btemp=',btemp,' bden=',bden else if (expansion) then write(22,07) 'expansion:',' temp0=',temp0,' den0=',den0, 1 ' temp_stop=',temp_stop write(23,07) 'expansion:',' temp0=',temp0,' den0=',den0, 1 ' temp_stop=',temp_stop else if (self_heat_const_den) then write(22,07) 'self_heat:',' temp0=',y(itemp+kk), 1 ' den0=',y(iden+kk) write(23,07) 'self_heat:',' temp0=',y(itemp+kk), 1 ' den0=',y(iden+kk) else if (self_heat_const_pres) then write(22,07) 'self_heat:',' temp0=',y(itemp+kk), 1 ' den0=',y(iden+kk) write(23,07) 'self_heat:',' temp0=',y(itemp+kk), 1 ' den0=',y(iden+kk) else if (detonation) then write(22,07) 'detonation:',' temp0=',temp_up, 1 ' den0=',den_up, 2 ' pres0=',pres_up, 3 ' mach=',mach_sh write(23,07) 'detonation:',' temp0=',temp_up, 1 ' den0=',den_up, 2 ' pres0=',pres_up, 3 ' mach=',mach_sh else if (trho_hist) then call update2(zero,tdum,ddum) write(22,07) 'trho_hist:',' mass interior =',mint, 1 ' shell mass =',mshell write(23,07) 'trho_hist:',' mass interior =',mint, 1 ' shell mass =',mshell else if (pt_hist) then call update3(zero,tdum,pdum) write(22,07) 'pt_hist: ',' mass interior =',mint, 1 ' shell mass =',mshell write(23,07) 'pt_hist: ',' mass interior =',mint, 1 ' shell mass =',mshell end if write(22,01) 'time','temp','den','ener','sdot','sneut', 1 's-snu','ye','1-sum' write(23,01) 'time','pos','vel','temp','den','pres','ener', 1 'entr','cs' c..write the cj solution for detonation if (detonation) then write(23,05) 1,x,y(iposx+kk),vel_cj, 1 temp_cj,den_cj,pres_cj, 2 ener_cj,cs_cj end if c..close up the files close(unit=22) close(unit=23) c..end of spatial loop enddo c..if we are doing an nse analysis, we'll write out another file if (nse_analysis .eq. 1) then c..for every spatial zone do k=1,max(1,nzone) kk = neqs*(k-1) c..logical unit 25 records the nse analysis write(string,03) hfile,0,'_z',k,'_nse.dat' call sqeeze(string) call today(adat,atim) open (unit=25, file=string, status='unknown') write(25,01) adat,atim if (one_step) then write(25,07) 'one_step:',' btemp=',btemp,' bden=',bden else if (hydrostatic) then write(25,07) 'hydrostatic:',' btemp=',btemp,' bden=',bden else if (expansion) then write(25,07) 'expansion:',' temp0=',temp0,' den0=',den0, 1 ' temp_stop=',temp_stop else if (self_heat_const_den) then write(25,07) 'self_heat:',' temp0=',y(itemp+kk), 1 ' den0=',y(iden+kk) else if (self_heat_const_pres) then write(25,07) 'self_heat:',' temp0=',y(itemp+kk), 1 ' den0=',y(iden+kk) else if (detonation) then write(25,07) 'detonation:',' temp0=',temp_up, 1 ' den0=',den_up, 2 ' pres0=',pres_up, 3 ' mach=',mach_sh else if (trho_hist) then call update2(zero,tdum,ddum) write(25,07) 'trho_hist:',' mass interior =',mint, 1 ' shell mass =',mshell else if (pt_hist) then call update3(zero,tdum,pdum) write(25,07) 'pt_hist: ',' mass interior =',mint, 1 ' shell mass =',mshell end if write(25,01) 'time','temp','den','ye','tqse','tnse','delta', 1 '1-sum' c..write the cj solution for a detonation if (detonation) then write(25,05) 1,x,y(iposx+kk),vel_cj, 1 temp_cj,den_cj,pres_cj, 2 ener_cj,cs_cj end if c..close up the files close(unit=25) c..end of spatial loop enddo end if c..done writing thermodynamic headers c..for every spatial zone do k=1,max(1,nzone) kk = neqs*(k-1) c..write out the isotopic mass fractions in blocks of 8 c..lop is how many groups of 8 exist; jrem is the remainder lop = ionmax/8 jrem = ionmax - 8*lop do ilop = 1,lop+1 kb = 1 + 8*(ilop-1) ke = 8 + 8*(ilop-1) if (ilop .eq. lop+1 .and. jrem .eq. 0) goto 50 if (ilop .eq. lop+1) ke = ionmax c..logical unit 34 records the abundance evolution c..open the output file write(string,03) hfile,ilop+1,'_z',k,'.dat' call sqeeze(string) open (unit=34, file=string, status='unknown') write(34,01) adat,atim if (one_step) then write(34,07) 'one_step:',' btemp=',btemp,' bden=',bden else if (hydrostatic) then write(34,07) 'hydrostatic:',' btemp=',btemp,' bden=',bden else if (expansion) then write(34,07) 'expansion:',' temp0=',temp0,' den0=',den0, 1 ' temp_stop=',temp_stop else if (self_heat_const_den) then write(34,07) 'self_heat:',' temp0=',y(itemp+kk), 1 ' den0=',y(iden+kk) else if (detonation) then write(34,07) 'detonation:',' temp0=',temp_up, 1 ' den0=',den_up, 1 ' pres0=',pres_up, 2 ' mach=',mach_sh else if (trho_hist) then call update2(zero,tdum,ddum) write(34,07) 'trho_hist:',' mass interior =',mint, 1 ' shell mass =',mshell else if (pt_hist) then call update3(zero,tdum,ddum) write(34,07) 'pt_hist: ',' mass interior =',mint, 1 ' shell mass =',mshell end if write(34,01) 'time',(ionam(nn), nn=kb,ke) close(unit=34) 50 continue enddo c..end of the spatial loop enddo c..if we are doing an nse analysis, we'll write out another c..set of abundance file if (nse_analysis .eq. 1) then c..for every spatial zone do k=1,max(1,nzone) kk = neqs*(k-1) c..write out the isotopic mass fractions in blocks of 8 c..lop is how many groups of 8 exist; jrem is the remainder lop = ionmax/8 jrem = ionmax - 8*lop do ilop = 1,lop+1 kb = 1 + 8*(ilop-1) ke = 8 + 8*(ilop-1) if (ilop .eq. lop+1 .and. jrem .eq. 0) goto 60 if (ilop .eq. lop+1) ke = ionmax c..logical unit 35 records the abundance evolution c..open the output file write(string,03) hfile,ilop+1,'_z',k,'_nse.dat' call sqeeze(string) open (unit=35, file=string, status='unknown') write(35,01) adat,atim if (one_step) then write(35,07) 'one_step:',' btemp=',btemp,' bden=',bden else if (hydrostatic) then write(35,07) 'hydrostatic:',' btemp=',btemp,' bden=',bden else if (expansion) then write(35,07) 'expansion:',' temp0=',temp0,' den0=',den0, 1 ' temp_stop=',temp_stop else if (self_heat_const_den) then write(35,07) 'self_heat:',' temp0=',y(itemp+kk), 1 ' den0=',y(iden+kk) else if (detonation) then write(35,07) 'detonation:',' temp0=',temp_up, 1 ' den0=',den_up, 1 ' pres0=',pres_up, 2 ' mach=',mach_sh else if (trho_hist) then call update2(zero,tdum,ddum) write(35,07) 'trho_hist:',' mass interior =',mint, 1 ' shell mass =',mshell else if (pt_hist) then call update3(zero,tdum,ddum) write(35,07) 'pt_hist: ',' mass interior =',mint, 1 ' shell mass =',mshell end if write(35,01) 'time',(ionam(nn), nn=kb,ke) close(unit=35) 60 continue enddo c..end of the spatial loop and nse analyis test if enddo end if c write(6,*) 'wrote mass fraction headers' c..end of the file initialization end if c write(6,*) 'done with initialization' c..normal execution starts here c..for any time point c..for every spatial zone do k=1,max(1,nzone) kk = neqs*(k-1) c..open the files in append mode (f77) or position mode (f90) c..energetics file write(string,03) hfile,0,'_z',k,'.dat' call sqeeze(string) c open (unit=22, file=string, status='old', access='append') open (unit=22, file=string, status='old', position='append') c..thermodynamics file write(string,03) hfile,1,'_z',k,'.dat' call sqeeze(string) c open (unit=23, file=string, status='old', access='append') open (unit=23, file=string, status='old', position='append') c..form the mass fractions do j=1,ionmax xdum(j) = min(1.0d0,max(y(j+kk)*aion(j),1.0d-30)) enddo c..mass conservation sum = 0.0d0 do j=1,ionmax sum = sum + xdum(j) enddo sum = 1.0d0 - sum xcons = sum c..y sum c sum = 0.0d0 c do j=1,ionmax c if (zion(j) .gt. 2.0) then c sum = sum + max(y(j+kk),1.0d-30) c endif c enddo c ycons = sum c..get ye using normalized mass fractions sum = 0.0d0 do j=1,ionmax sum = sum + xdum(j) enddo sum = 1.0d0/sum do j=1,ionmax xdum(j) = min(1.0d0,max(sum*xdum(j),1.0d-30)) enddo c..get abar, zbar and a few other composition variables call azbar(xdum,aion,zion,wion,ionmax, 1 ydum,abar,zbar,wbar,yex,xcess) c..get the right hand sides, exact energy generation rate and so on if (nse_on .eq. 0) then call derivs(x,y,dydt_dum) if (pure_network .eq. 0) then ener = y(iener + kk) denerdt = dydt_dum(iener + kk) else ener = 0.0d0 denerdt = 0.0d0 end if else sdot = 0.0d0 sneut = 0.0d0 ener = 0.0d0 denerdt = 0.0d0 end if c..call an eos if (pure_network .eq. 0) then temp_row(1) = y(itemp+kk) den_row(1) = y(iden+kk) else temp_row(1) = btemp den_row(1) = bden end if if (trho_hist) call update2(x,temp_row(1),den_row(1)) abar_row(1) = abar zbar_row(1) = zbar jlo_eos = 1 jhi_eos = 1 if (pt_hist) then call update3(x,temp_row(1),bpres) den_row(1) = bpres * abar/(avo * kerg * temp_row(1)) call invert_helm_pt else call helmeos c call eosfxt end if c..figure some time scales call time_scales(temp_row(1),den_row(1),taud,tau_nse,tau_qse) c..compute the chemical potentials do j=1,ionmax chem_pot(j) = abar*((zion(j) - zbar)*deionz_row(1) 1 + (aion(j) - abar)*deiona_row(1)) end do sum = 0.0d0 do j=1,ionmax sum = sum + chem_pot(j) * dydt_dum(j) end do chem_sum = sum c..and write what we found c..total c12+c12 rate, mass fraction of c12, function c zc12 = ratdum(ir1212n) + ratdum(ir1212p) + ratdum(ir1212a) c xc12 = y(ic12)*aion(ic12) c ff = sdot/(y(ic12)**2 * zc12) * 2.0d0/3.0d0 write(22,05) kount,x,temp_row(1),den_row(1), 1 ener,sdot,sneut,denerdt,yex,xcons, 2 chem_sum,chem_sum/denerdt c 2 xc12,zc12/den_row(1),ff write(23,05) kount,x,y(iposx+kk),y(ivelx+kk), 1 temp_row(1),den_row(1),ptot_row(1), 2 ener,stot_row(1),cs_row(1) c..write the cj solution for detonation if (detonation) then write(23,05) kount,x,y(iposx+kk),vel_cj, 1 temp_cj,den_cj,pres_cj, 2 ener_cj,cs_cj end if c..close up the files close(unit=22) close(unit=23) c..end of spatial loop end do c write(6,*) 'done with thermo file' c..for every spatial zone do k=1,max(1,nzone) kk = neqs*(k-1) c..write out the isotopic mass fractions in blocks of 8 c..lop is how many groups of 8 exist; jrem is the remainder lop = ionmax/8 jrem = ionmax - 8*lop do ilop = 1,lop+1 kb = 1 + 8*(ilop-1) ke = 8 + 8*(ilop-1) if (ilop .eq. lop+1 .and. jrem .eq. 0) goto 70 if (ilop .eq. lop+1) ke = ionmax c..open the output file in append mode (f77) or position mode (f90) c..abundance evolution file write(string,03) hfile,ilop+1,'_z',k,'.dat' call sqeeze(string) c open (unit=34, file=string, status='old', access='append') open (unit=34, file=string, status='old', position='append') write(34,04) kount,x,(y(nn+kk)*aion(nn), nn=kb,ke) c write(34,04) kount,x,(y(nn+kk), nn=kb,ke) close(unit=34) 70 continue enddo c..end of spatial zone loop enddo c write(6,*) 'done with mass fractions file' c..start of nse analysis if (nse_analysis .eq. 1) then c..for every spatial zone do k=1,max(1,nzone) kk = neqs*(k-1) c..open the files in append mode (f77) or position mode (f90) c..nse analysis file write(string,03) hfile,0,'_z',k,'_nse.dat' call sqeeze(string) c open (unit=25, file=string, status='old', access='append') open (unit=25, file=string, status='old', position='append') c..form the mass fractions do j=1,ionmax xdum(j) = min(1.0d0,max(y(j+kk)*aion(j),1.0d-30)) enddo c..normalized mass fractions sum = 0.0d0 do j=1,ionmax sum = sum + xdum(j) enddo xcons = 1.0d0 - sum sum = 1.0d0/sum do j=1,ionmax xdum(j) = min(1.0d0,max(sum*xdum(j),1.0d-30)) enddo c..get abar, zbar and a few other composition variables call azbar(xdum,aion,zion,wion,ionmax, 1 ydum,abar,zbar,wbar,yex,xcess) c..set the temperature and density if (pure_network .eq. 0) then temp_row(1) = y(itemp+kk) den_row(1) = y(iden+kk) else temp_row(1) = btemp den_row(1) = bden end if if (trho_hist) call update2(x,temp_row(1),den_row(1)) if (pt_hist) then call update3(x,temp_row(1),bpres) den_row(1) = bpres * abar/(avo * kerg * temp_row(1)) call invert_helm_pt end if c..with the temperature, density, and ye c..compute the nse state if the temperature is high enough if (temp_row(1) .gt. 2.0e9) then igues = 1 call nse(temp_row(1),den_row(1),yex,igues,1,1,xsum,xmun,xmup,0) else do j=1,ionmax xsum(j) = 1.0e20 enddo end if c..figure delta on the top 20 nse mass fractions call indexx(ionmax,xsum,izwork1) sum = 0.0d0 kb = 0 do j = ionmax, max(1,ionmax-19), -1 if (xsum(izwork1(j)) .ge. 1.0e-6) then kb = kb + 1 tdum = (xsum(izwork1(j)) - xdum(izwork1(j)))/xsum(izwork1(j)) c tdum = (xsum(izwork1(j)) - xdum(izwork1(j)))**2 sum = sum + tdum end if enddo sum = sum/float(kb) c sum = sqrt(sum/kb) c..figure the time scales call time_scales(temp_row(1),den_row(1),taud,tau_nse,tau_qse) c..write out what we got write(25,05) kount,x,temp_row(1),den_row(1),yex, 1 tau_qse,tau_nse,sum,xcons c..close up the files close(unit=25) c..write out the isotopic mass fractions in blocks of 8 c..lop is how many groups of 8 exist; jrem is the remainder lop = ionmax/8 jrem = ionmax - 8*lop do ilop = 1,lop+1 kb = 1 + 8*(ilop-1) ke = 8 + 8*(ilop-1) if (ilop .eq. lop+1 .and. jrem .eq. 0) goto 80 if (ilop .eq. lop+1) ke = ionmax c..open the output file in append mode (f77) or position mode (f90) c..abundance evolution file write(string,03) hfile,ilop+1,'_z',k,'_nse.dat' call sqeeze(string) c open (unit=35, file=string, status='old', access='append') open (unit=35, file=string, status='old', position='append') write(35,04) kount,x,(xsum(nn+kk), nn=kb,ke) close(unit=35) 80 continue enddo c..end of spatial zone loop enddo c..end of the nse analysis if end if return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine net_final_abund(xout) include 'implno.dek' include 'burn_common.dek' include 'network.dek' c..writes out the final composition c..declare the pass double precision xout(*) c..local variables character*80 final integer i,lenstr c..popular format statements 01 format(a,'final.dat') 02 format(1x,i4,i4,1pe14.6,a6) c..for the file name and open it write(final,01) hfile(1:lenstr(hfile,80)) call sqeeze(final) open(unit=51,file=final,status='unknown') c..convert to integers do i=1,ionmax izwork1(i) = int(zion(i)) izwork2(i) = int(aion(i)) enddo c..write it out write(51,02) (izwork1(i), izwork2(i), xout(i), 1 ionam(i), i=1,ionmax) c..close up shop close(unit=51) return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine update2(tt,temp,den) include 'implno.dek' include 'network.dek' c..this routine evaluates the temperature temp and density den of c..as a function of time tt. c..declare the pass double precision tt,den,temp c..local variables, norder sets the order of the c..interpolation (2 points = linear, 3 = quadratic ...) integer i,j,k,ntime,ntmax,jat,norder parameter (ntmax=10000, norder=2) double precision ztime(ntmax),zden(ntmax),ztemp(ntmax),dy,sum, 1 abar,zbar,wbar,ye_orig,xcess character*80 string,word integer ipos,getnam,kiso double precision x,value integer init data init/0/ c..stuff to do once if (init .eq. 0) then init = 1 open (unit=17, file=trho_file, status='old') ntime = 0 read(17,07) string c read(17,*) mint,mshell read(17,*) mshell c..read the isotope abundance and name c read(17,*) kiso read(17,07) string read(17,07) string ipos = 1 c do k=1,7 do k=1,4 j = getnam(string,word,ipos) enddo kiso = value(word) c..now read the mass fractions c read(17,07) string c read(17,07) string do k=1,kiso read(17,07) string 07 format(a) ipos = 1 j = getnam(string,word,ipos) x = value(word) j = getnam(string,word,ipos) j = getnam(string,word,ipos) j = getnam(string,word,ipos) c write(6,08) word(1:5),x c..see if the isotope is in the network c..store it in the common block xsum array do i=1,ionmax if (ionam(i)(1:5) .eq. word(1:5)) then xsum(i) = x c write(6,*) 'found it' goto 09 end if enddo c..isotope not in network, check special cases if (word(1:5) .eq. 'nt1 ') then xsum(ineut) = x goto 09 else if (word(1:5) .eq. 'n ') then xsum(ineut) = x goto 09 else if (word(1:5) .eq. 'h1 ') then xsum(iprot) = x goto 09 else if (word(1:5) .eq. 'p ') then xsum(iprot) = x goto 09 else if (word(1:5) .eq. 'd ') then if (ih2 .ne. 0) xsum(ih2) = x goto 09 end if c..not in the network write(6,08) word(1:5),x,' isotope not in network' 08 format(1x,a,' ',1pe13.5,a) c stop 'isotope not in network' c..back for another isotope 09 continue enddo c..renormalize the abundances c sum = 1.0d0 c do i=1,ionmax c sum = sum + xsum(i) c enddo c sum = 1.0d0/sum c do i=1,ionmax c xsum(i) = xsum(i) * sum c enddo c..get some abundance variables c call azbar(xsum,aion,zion,wion,ionmax, c 1 zwork1,abar,zbar,wbar,ysum(1),xcess) c..now read the thermodynamic history read(17,07) string read(17,07) string do i=1,ntmax read(17,*,end=10) k,ztime(i),x,x,zden(i),ztemp(i) ztemp(i) = ztemp(i) * 1.0d9 ntime = ntime + 1 enddo stop 'more than ntmax points in update2' 10 close (unit=17) c..reset the zero point c zsum(1) = ztime(1) c do i=1,ntime c ztime(i) = ztime(i) - zsum(1) c end do c..store the beginning and end points in the common block zsum array zwork1(1) = ztime(1) zwork1(2) = ztime(ntime) end if c..locate and interpolate to get the temperature and density if (tt .lt. ztime(1)) then temp = ztemp(1) den = zden(1) else if (tt .gt. ztime(ntime)) then temp = ztemp(ntime) den = zden(ntime) else call up_locate(ztime,ntime,tt,jat) jat = max(1,min(jat - norder/2 + 1,ntime - norder + 1)) call up_polint(ztime(jat),ztemp(jat),norder,tt,temp,dy) call up_polint(ztime(jat),zden(jat),norder,tt,den,dy) end if c..bound the temperature, since a lot of rates go nuts c..above t9=10 temp = max(1.0d7,min(temp,1.0d10)) return end subroutine update3(tt,temp,pres) include 'implno.dek' include 'network.dek' c..this routine evaluates the temperature temp and pressure pres c..as a function of time tt. c..declare the pass double precision tt,pres,temp c..local variables, norder sets the order of the c..interpolation (2 points = linear, 3 = quadratic ...) integer i,j,k,ntime,ntmax,jat,norder parameter (ntmax=10000, norder=2) double precision ztime(ntmax),zpres(ntmax),ztemp(ntmax),dy,sum, 1 abar,zbar,wbar,ye_orig,xcess character*80 string,word integer ipos,getnam,kiso double precision x,value integer init data init/0/ c..stuff to do once if (init .eq. 0) then init = 1 open (unit=17, file=trho_file, status='old') ntime = 0 read(17,07) string c read(17,*) mint,mshell read(17,*) mshell c..read the isotope abundance and name c read(17,*) kiso read(17,07) string read(17,07) string ipos = 1 c do k=1,7 do k=1,4 j = getnam(string,word,ipos) enddo kiso = value(word) c..now read the mass fractions c read(17,07) string c read(17,07) string do k=1,kiso read(17,07) string 07 format(a) ipos = 1 j = getnam(string,word,ipos) x = value(word) j = getnam(string,word,ipos) j = getnam(string,word,ipos) j = getnam(string,word,ipos) c write(6,08) word(1:5),x c..see if the isotope is in the network c..store it in the common block xsum array do i=1,ionmax if (ionam(i)(1:5) .eq. word(1:5)) then xsum(i) = x c write(6,*) 'found it' goto 09 end if enddo c..isotope not in network, check special cases if (word(1:5) .eq. 'nt1 ') then xsum(ineut) = x goto 09 else if (word(1:5) .eq. 'n ') then xsum(ineut) = x goto 09 else if (word(1:5) .eq. 'h1 ') then xsum(iprot) = x goto 09 else if (word(1:5) .eq. 'p ') then xsum(iprot) = x goto 09 else if (word(1:5) .eq. 'd ') then if (ih2 .ne. 0) xsum(ih2) = x goto 09 end if c..not in the network write(6,08) word(1:5),x,' isotope not in network' 08 format(1x,a,' ',1pe13.5,a) c stop 'isotope not in network' c..back for another isotope 09 continue enddo c..renormalize the abundances c sum = 1.0d0 c do i=1,ionmax c sum = sum + xsum(i) c enddo c sum = 1.0d0/sum c do i=1,ionmax c xsum(i) = xsum(i) * sum c enddo c..get some abundance variables c call azbar(xsum,aion,zion,wion,ionmax, c 1 zwork1,abar,zbar,wbar,ysum(1),xcess) c..now read the thermodynamic history read(17,07) string read(17,07) string do i=1,ntmax read(17,*,end=10) k,ztime(i),x,x,zpres(i),ztemp(i) ztemp(i) = ztemp(i) * 1.0d9 ntime = ntime + 1 enddo stop 'more than ntmax points in update2' 10 close (unit=17) c..reset the zero point c zsum(1) = ztime(1) c do i=1,ntime c ztime(i) = ztime(i) - zsum(1) c end do c..store the beginning and end points in the common block zsum array zwork1(1) = ztime(1) zwork1(2) = ztime(ntime) end if c..locate and interpolate to get the temperature and pressure if (tt .lt. ztime(1)) then temp = ztemp(1) pres = zpres(1) else if (tt .gt. ztime(ntime)) then temp = ztemp(ntime) pres = zpres(ntime) else call up_locate(ztime,ntime,tt,jat) jat = max(1,min(jat - norder/2 + 1,ntime - norder + 1)) call up_polint(ztime(jat),ztemp(jat),norder,tt,temp,dy) call up_polint(ztime(jat),zpres(jat),norder,tt,pres,dy) end if c..bound the temperature, since a lot of rates go nuts c..above t9=10 temp = max(1.0d7,min(temp,1.0d10)) return end subroutine up_polint(xa,ya,n,x,y,dy) implicit none save c..given arrays xa and ya of length n and a value x, this routine returns a c..value y and an error estimate dy. if p(x) is the polynomial of degree n-1 c..such that ya = p(xa) ya then the returned value is y = p(x) c..declare integer n,nmax,ns,i,m parameter (nmax=10) double precision xa(n),ya(n),x,y,dy,c(nmax),d(nmax),dif,dift, 1 ho,hp,w,den c..find the index ns of the closest table entry; initialize the c and d tables ns = 1 dif = abs(x - xa(1)) do i=1,n dift = abs(x - xa(i)) if (dift .lt. dif) then ns = i dif = dift end if c(i) = ya(i) d(i) = ya(i) enddo c..first guess for y y = ya(ns) c..for each column of the table, loop over the c's and d's and update them ns = ns - 1 do m=1,n-1 do i=1,n-m ho = xa(i) - x hp = xa(i+m) - x w = c(i+1) - d(i) den = ho - hp if (den .eq. 0.0) stop ' 2 xa entries are the same in polint' den = w/den d(i) = hp * den c(i) = ho * den enddo c..after each column is completed, decide which correction c or d, to add c..to the accumulating value of y, that is, which path to take in the table c..by forking up or down. ns is updated as we go to keep track of where we c..are. the last dy added is the error indicator. if (2*ns .lt. n-m) then dy = c(ns+1) else dy = d(ns) ns = ns - 1 end if y = y + dy enddo return end subroutine up_locate(xx,n,x,j) implicit none save c..given an array xx of length n, and a value of x, this routine returns c..a value j such that x is between xx(j) and xx(j+1). the array xx must be c..monotonic. j=0 or j=n indicates that x is out of range. bisection is used c..to find the entry c..declare integer n,j,jl,ju,jm double precision xx(n),x c..initialize jl = 0 ju = n+1 c..compute a midpoint, and replace either the upper or lower limit 10 if (ju-jl .gt. 1) then jm = (ju+jl)/2 if ( (xx(n) .ge. xx(1)) .eqv. (x .ge. xx(jm)) ) then jl = jm else ju = jm end if goto 10 end if if (x .eq. xx(1))then j = 1 else if(x .eq. xx(n))then j = n - 1 else j = jl end if return end double precision function up_zbrent(func,x1,x2,tol,niter) implicit none save c..using brent's method this routine finds the root of a function func c..between the limits x1 and x2. the root is when accuracy is less than tol. c.. c..note: eps the the machine floating point precision c..declare external func integer niter,itmax,iter parameter (itmax = 100) double precision func,x1,x2,tol,a,b,c,d,e,fa, 1 fb,fc,xm,tol1,p,q,r,s,eps parameter (eps=3.0d-15) c..initialize niter = 0 a = x1 b = x2 fa = func(a) fb = func(b) if ( (fa .gt. 0.0 .and. fb .gt. 0.0) .or. 1 (fa .lt. 0.0 .and. fb .lt. 0.0) ) then write(6,100) x1,fa,x2,fb 100 format(1x,' x1=',1pe11.3,' f(x1)=',1pe11.3,/, 1 1x,' x2=',1pe11.3,' f(x2)=',1pe11.3) stop 'root not bracketed in routine up_zbrent' end if c = b fc = fb c..rename a,b,c and adjusting bound interval d do iter =1,itmax niter = niter + 1 if ( (fb .gt. 0.0 .and. fc .gt. 0.0) .or. 1 (fb .lt. 0.0 .and. fc .lt. 0.0) ) then c = a fc = fa d = b-a e = d end if if (abs(fc) .lt. abs(fb)) then a = b b = c c = a fa = fb fb = fc fc = fa end if tol1 = 2.0d0 * eps * abs(b) + 0.5d0 * tol xm = 0.5d0 * (c-b) c..convergence check if (abs(xm) .le. tol1 .or. fb .eq. 0.0) then up_zbrent = b return end if c..attempt quadratic interpolation if (abs(e) .ge. tol1 .and. abs(fa) .gt. abs(fb)) then s = fb/fa if (a .eq. c) then p = 2.0d0 * xm * s q = 1.0d0 - s else q = fa/fc r = fb/fc p = s * (2.0d0 * xm * q *(q-r) - (b-a)*(r - 1.0d0)) q = (q - 1.0d0) * (r - 1.0d0) * (s - 1.0d0) end if c..check if in bounds if (p .gt. 0.0) q = -q p = abs(p) c..accept interpolation if (2.0d0*p .lt. min(3.0d0*xm*q - abs(tol1*q),abs(e*q))) then e = d d = p/q c..or bisect else d = xm e = d end if c..bounds decreasing to slowly use bisection else d = xm e = d end if c..move best guess to a a = b fa = fb if (abs(d) .gt. tol1) then b = b + d else b = b + sign(tol1,xm) end if fb = func(b) enddo stop 'too many iterations in routine up_zbrent' end double precision function time_switch(t) implicit none save c..used by a root finding routine to find a time where the c..temperature is equal to a given value. c..declare the pass double precision t c..common block communication double precision nse_temp_switch common /nsetsw/ nse_temp_switch c..local variables double precision tl,dl c..get the temperature and desnity at this time call update2(t,tl,dl) c..set the output quantity time_switch = tl - nse_temp_switch return end c subroutine locate(xx,n,x,j) c implicit none c save c..given an array xx of length n, and a value of x, this routine returns c..a value j such that x is between xx(j) and xx(j+1). the array xx must be c..monotonic. j=0 or j=n indicates that x is out of range. bisection is used c..to find the entry c..declare c integer n,j,jl,ju,jm c double precision xx(n),x c..initialize c jl = 0 c ju = n+1 c..compute a midpoint, and replace either the upper or lower limit c 10 if (ju-jl .gt. 1) then c jm = (ju+jl)/2 c if ( (xx(n) .ge. xx(1)) .eqv. (x .ge. xx(jm)) ) then c jl = jm c else c ju = jm c end if c goto 10 c end if c if (x .eq. xx(1))then c j = 1 c else if(x .eq. xx(n))then c j = n - 1 c else c j = jl c end if c return c end c--------------------------------------------------------------------- c--------------------------------------------------------------------- c..reaction rate library c..torch rates c..li7(t,n) a(an,g) be9(p,d) be9(p,n) b10(a,n) b11(a,n) c..n14(p,a) c11(p,g) c12(a,n) c13(a,n) c13(p,n) c14(a,g) c..c14(p,n) c14(p,g) o16(p,a) n14(p,n) n14(a,n) n15(p,n) c..n15(a,n) n15(a,g) o14(a,g) o17(a,g) o17(a,n) o18(a,g) c..o18(a,n) ne20(p,a) f18(p,g) f19(p,g) f19(p,n) f19(a,p) c..na22(n,a) ne20(p,g) na23(p,a) ne20(n,g) ne21(p,g) ne21(a,g) c..ne22(p,g) ne22(a,g) na22(n,p) ne22(a,n) na21(p,g) mg24(p,a) c..ne21(a,n) na22(p,g) na23(p,g) na23(p,n) mg24(p,g) al27(p,a) c..mg25(p,g) mg25(a,p) mg25(a,g) mg25(a,n) mg26(p,g) mg26(a,g) c..mg26(a,n) al25(p,g) al26(p,g) al27(a,n) si27(p,g) si28(p,g) c..si29(p,g) si30(p,g) c..bigbang rates: c..n(e-nu)p p(e-,nu)n d(p,n) d(n,g) d(d,p) d(d,n) c..t(p,n) d(d,g) t(p,g) t(d,n) t(t,2n) he3(d,p) c..he3(t,d) he3(t,np) he4(np,g) he4(d,g) he4(t,n) li6(p,he3) c..li6(n,g) li7(d,n) lit(t,2n) li7(he3,np) li6(p,g) li7(p,n) c..be7(d,p) be7(t,np) be7(3he,2p) li6(a,g) li7(a,n) be9(p,g) c..b10(p,a) li7(a,g) b11(p,a) be7(a,g) b11(p,n) b8(a,p) c..b10(p,g) c11(n,a) be9(a,n) b11(p,g) b11(a,p) c..pp123 rates: c..p(p,e+nu) p(n,g) d(p,g) he3(n,g) he3+he3 he3(a,g) c..be7(e-,nu) be7(p,g) li7(p,g) li7(p,a) b8(e+,nu) c..cno rates: c..c12(p,g) n13(e-nu) c13(p,g) n14(p,g) o15(e-nu) n14(a,g) c..n15(p,g) n15(p,a) o16(p,g) o17(p,a) o17(p,g) o18(p,a) c..o18(p,g) f17(e-nu) f18(e-nu) f19(p,a) c..hot cno rates c..n13(p,g) o14(e-nu) o14(a,p) o15(a,g) f17(p,g) ne18(e-nu) c..f18(p,a) ne18(a,p) ne19(p,g) ne19(e-nu) si26(a,p) c..alfa chain rates: c..a(aa,g) c12(a,g) c12+c12 c12+o16 o16+o16 o16(a,g) c..ne20(a,g) ne20(a,g) mg24(a,g) mg24(a,p) al27(p,g) si28(a,g) c..si28(a,p) p31(p,g) s32(a,g) s32(a,p) cl35(p,g) ar36(a,g) c..ar36(a,p) k39(p,g) ca40(a,g) ca40(a,p) sc43(p,g) ti44(a,g) c..ti44(a,p) v47(p,g) cr48(a,g) cr(a,p) mn51(p,g) fe52(a,g) c..fe52(a,p) co55(p,g) c..photodisintegration rates: c..fe52(n,g) fe53(n,g) fe54(p,g) subroutine tfactors(temp) include 'implno.dek' include 'tfactors.dek' c..sets various popular temperature factors into common block c..this routine must be called before any of the rates are called c..declare the pass double precision temp c..all these are in common block t9 = temp * 1.0d-9 t92 = t9*t9 t93 = t9*t92 t94 = t9*t93 t95 = t9*t94 t96 = t9*t95 t912 = sqrt(t9) t932 = t9*t912 t952 = t9*t932 t972 = t9*t952 t913 = t9**oneth t923 = t913*t913 t943 = t9*t913 t953 = t9*t923 t973 = t953*t923 t9113 = t973*t943 t914 = t9**(0.25d0) t934 = t914*t914*t914 t954 = t9*t914 t974 = t9*t934 t915 = t9**onefif t935 = t915*t915*t915 t945 = t915 * t935 t965 = t9 * t915 t916 = t9**onesix t976 = t9 * t916 t9i76 = 1.0d0/t976 t917 = t9**onesev t927 = t917*t917 t947 = t927*t927 t918 = sqrt(t914) t938 = t918*t918*t918 t958 = t938*t918*t918 t9i = 1.0d0/t9 t9i2 = t9i*t9i t9i3 = t9i2*t9i t9i12 = 1.0d0/t912 t9i32 = t9i*t9i12 t9i52 = t9i*t9i32 t9i72 = t9i*t9i52 t9i13 = 1.0d0/t913 t9i23 = t9i13*t9i13 t9i43 = t9i*t9i13 t9i53 = t9i*t9i23 t9i14 = 1.0d0/t914 t9i34 = t9i14*t9i14*t9i14 t9i54 = t9i*t9i14 t9i15 = 1.0d0/t915 t9i35 = t9i15*t9i15*t9i15 t9i45 = t9i15 * t9i35 t9i65 = t9i*t9i15 t9i17 = 1.0d0/t917 t9i27 = t9i17*t9i17 t9i47 = t9i27*t9i27 t9i18 = 1.0d0/t918 t9i38 = t9i18*t9i18*t9i18 t9i58 = t9i38*t9i18*t9i18 return end subroutine rate_aan(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,bb,dbb,cc,dcc,dd,ddd c..he4(an,g)be9 aa = 1.0d0 + 0.344*t9 bb = t92 * aa dbb = 2.0d0 * t9 * aa + t92*0.344 cc = 1.0d0/bb dcc = -cc*cc*dbb dd = 2.59e-6 * exp(-1.062*t9i) ddd = dd*1.062*t9i2 term = cc * dd dtermdt = dcc*dd + cc*ddd c..rates fr = den * den * term dfrdt = den * den * dtermdt * 1.0d-9 dfrdd = 2.0d0 * den * term rev = 5.84e19 * t93 * exp(-18.260*t9i) drevdt = rev*(3.0d0*t9i + 18.260*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_be9pd(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb, 1 cc,dcc,dd,ddd,q1 parameter (q1 = 1.0d0/0.2704d0) c..be9(p,d)be8 =>2a aa = 2.11e+11 * t9i23 * exp(-10.359*t9i13 - t92*q1) daa = aa*(-twoth*t9i + oneth*10.359*t9i43 - 2.0d0*t9*q1) bb = 1.0d0 + 0.04*t913 + 1.09*t923 + 0.307*t9 1 + 3.21*t943 + 2.30*t953 dbb = oneth*0.04*t9i23 + twoth*1.09*t9i13 + 0.307 1 + fourth*3.21*t913 + fiveth*2.30*t923 cc = 5.79e+08 * t9i * exp(-3.046*t9i) dcc = cc*(-t9i + 3.046*t9i2) dd = 8.50e+08 * t9i34 * exp(-5.800*t9i) ddd = dd*(-0.75d0*t9i + 5.800*t9i2) term = aa*bb + cc + dd dtermdt = daa*bb + aa*dbb + dcc + ddd c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 8.07e-11 * t9i32 *exp(-7.555*t9i) drevdt = rev*(-1.5d0*t9i + 7.555*t9i2) rr = den * rev * term drrdt = den * (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = rev * term return end subroutine rate_be9pn(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,aa,daa,bb,dbb,cc,dcc,zz,dzz c..be9(p,n)b9 aa = 5.58e7*(1.0d0 + 0.042*t912 + 0.985*t9) daa = 5.58e7*(0.5d0*0.042*t9i12 + 0.985) zz = exp(-21.473*t9i) dzz = zz*21.473*t9i2 bb = aa * zz dbb = daa*zz + aa*dzz cc = 1.02e+09 * t9i32 * exp(-26.725*t9i) dcc = cc*(-1.5d0*t9i + 26.725*t9i2) term = bb + cc dtermdt = dbb + dcc c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term bb = 0.998 * aa dbb = 0.998 * daa cc = 0.998 * 1.02e+09 * t9i32 * exp(-5.252*t9i) dcc = cc*(-1.5d0*t9i + 5.252*t9i2) term = bb + cc dtermdt = dbb + dcc rr = den * term drrdt = den * dtermdt * 1.0d-9 drrdd = term return end subroutine rate_b10an(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,q1 parameter (q1 = 1.0d0/91.948921d0) c..b10(a,n)n13 term = 1.20e+13 * t9i23 * exp(-27.989*t9i13 - t92*q1) dtermdt = -twoth*term*t9i 1 + term*(oneth*27.989*t9i43 - 2.0d0*t9*q1) c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 9.34 * exp(-12.287*t9i) drevdt = rev*12.287*t9i2 rr = den * rev * term drrdt = den * (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = rev*term return end subroutine rate_b11an(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ee,dee,ff,dff,q1 parameter (q1 = 1.0d0/0.0196d0) c..b11(a,n)n14 aa = 6.97e+12 * t9i23 * exp(-28.234*t9i13 - t92*q1) daa = aa*(-twoth*t9i + oneth*28.234*t9i43 - 2.0d0*t9*q1) bb = 1.0d0 + 0.015*t913 + 8.115*t923 + 0.838*t9 1 + 39.804*t943 + 10.456*t953 dbb = oneth*0.015*t9i23 + twoth*8.115*t9i13 + 0.838 1 + fourth*39.804*t913 + fiveth*10.456*t923 cc = aa * bb dcc = daa*bb + aa*dbb dd = 1.79 * t9i32 * exp(-2.827*t9i) ddd = dd*(-1.5d0*t9i + 2.827*t9i2) ee = 1.71e+03 * t9i32 * exp(-5.178*t9i) dee = ee*(-1.5d0*t9i + 5.178*t9i2) ff = 4.49e+06 * t935 * exp(-8.596*t9i) dff = ff*(0.6d0*t9i + 8.596*t9i2) term = cc + dd + ee + ff dtermdt = dcc + ddd + dee + dff c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 3.67 * exp(-1.835*t9i) drevdt = rev*1.835*t9i2 rr = den * rev * term drrdt = den * (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = rev*term return end subroutine rate_n14pa(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,bb,dbb,cc,dcc,dd,ddd, 1 t9a,dt9a,t9a13,dt9a13,t9a56,dt9a56,zz c..n14(p,a)b11 aa = 1.0d0 + 0.0478*t9 bb = aa**twoth dbb = twoth*bb/aa*0.0478 zz = 1.0d0/bb cc = aa + 7.56e-03*t953*zz dcc = 0.0478 + (fiveth*7.56e-3*t923 - 7.56e-3*t953*zz*dbb)*zz zz = 1.0d0/cc t9a = t9*zz dt9a = (1.0d0 - t9a*dcc)*zz zz = dt9a/t9a t9a13 = t9a**oneth dt9a13 = oneth*t9a13*zz t9a56 = t9a**fivsix dt9a56 = fivsix*t9a56*zz dd = 2.63e+16 * t9a56 * t9i32 * exp(-31.883/t9a13) ddd = dd*(dt9a56/t9a56 - 1.5d0*t9i 1 + 31.883/t9a13**2 * dt9a13) term = dd * exp(-33.915*t9i) dtermdt = term*(ddd/dd + 33.915*t9i2) c..rate fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 0.272 * dd drevdt = 0.272 * ddd rr = den * rev drrdt = den * drevdt * 1.0d-9 drrdd = rev return end subroutine rate_c11pg(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,q1 parameter (q1 = 1.0d0/2.647129d0) c..c11(p,g)n12 aa = 4.24e+04 * t9i23 * exp(-13.658*t9i13 - t92*q1) daa = aa*(-twoth*t9i + oneth*13.658*t9i43 - 2.0d0*t9*q1) bb = 1.0d0 + 0.031*t913 + 3.11*t923 + 0.665*t9 1 + 4.61*t943 + 2.50*t953 dbb = oneth*0.031*t9i23 + twoth*3.11*t9i13 + 0.665 1 + fourth*4.61*t913 + fiveth*2.50*t923 cc = aa * bb dcc = daa*bb + aa*dbb dd = 8.84e+03 * t9i32 * exp(-7.021*t9i) ddd = dd*(-1.5d0*t9i + 7.021*t9i2) term = cc + dd dtermdt = dcc + ddd c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 2.33e+10 * t932 * exp(-6.975*t9i) drevdt = rev*(1.5d0*t9i + 6.975*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_c12an(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,aa,daa,bb,dbb c..c12(a,n)o15 aa = 2.48e7 * (1.0d0 + 0.188*t912 + 0.015*t9) daa = 2.48e7 * (0.5d0*0.188*t9i12 + 0.015) bb = exp(-98.661*t9i) dbb = bb*98.661*t9i2 term = aa * bb dtermdt = daa*bb + aa*dbb c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rr = den * 1.41 * aa drrdt = den * 1.41 * daa * 1.0d-9 drrdd = 1.41 * aa return end subroutine rate_c13an(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ee,dee,ff,dff,gg,dgg,q1 parameter (q1 = 1.0d0/1.648656d0) c..c13(a,n)o16 aa = 6.77e+15 * t9i23 * exp(-32.329*t9i13 - t92*q1) daa = aa*(-twoth*t9i + oneth*32.329*t9i43 - 2.0d0*t9*q1) bb = 1.0d0 + 0.013*t913 + 2.04*t923 + 0.184*t9 dbb = oneth*0.013*t9i23 + twoth*2.04*t9i13 + 0.184 cc = aa * bb dcc = daa*bb + aa*dbb dd = 3.82e+05 * t9i32 * exp(-9.373*t9i) ddd = dd*(-1.5d0*t9i + 9.373*t9i2) ee = 1.41e+06 * t9i32 * exp(-11.873*t9i) dee = ee*(-1.5d0*t9i + 11.873*t9i2) ff = 2.0e+09 * t9i32 * exp(-20.409*t9i) dff = ff*(-1.5d0*t9i + 20.409*t9i2) gg = 2.92e+09 * t9i32 * exp(-29.283*t9i) dgg = gg*(-1.5d0*t9i + 29.283*t9i2) term = cc + dd + ee + ff + gg dtermdt = dcc + ddd + dee + dff + dgg c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 5.79e+00 * exp(-25.711*t9i) drevdt = rev*25.711*t9i2 rr = den * rev * term drrdt = den * (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = rev * term return end subroutine rate_c13pn(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,aa,daa,bb,dbb c..c13(p,n)n13 aa = 1.88e+08*(1.0d0 - 0.167*t912 + 0.037*t9) daa = 1.88e+08*(0.037 - 0.5d0*0.167*t9i12) bb = exp(-34.846*t9i) dbb = bb*34.846*t9i2 term = aa * bb dtermdt = daa*bb + aa*dbb c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rr = den * 0.998 * aa drrdt = den * 0.998 * daa * 1.0d-9 drrdd = 0.998 * aa return end subroutine rate_c14ag(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ee,dee,ff,dff,q1 parameter (q1 = 1.0d0/7.086244d0) c..c14(a,g)o18 aa = 1.528e+09 * t9i23 * exp(-32.513*t9i13 - t92*q1) daa = aa*(-twoth*t9i + oneth*32.513*t9i43 - 2.0d0*t9*q1) bb = 1.0d0 + 0.0128*t913 - 0.869*t923 - 0.0779*t9 1 + 0.321*t943 + 0.0732*t953 dbb = oneth*0.0128*t9i23 - twoth*0.869*t9i13 - 0.0779 1 + fourth*0.321*t913 + fiveth*0.0732*t923 cc = aa * bb dcc = daa*bb + aa*dbb dd = 3.375e+08 * t9i2 * exp(-32.513*t9i13) ddd = dd*(-2.0d0*t9i + oneth*32.513*t9i43) ee = 9.29e-08 * t9i32 * exp(-2.048*t9i) dee = ee*(-1.5d0*t9i + 2.048*t9i2) ff = 2.77e+03 * t9i45 * exp(-9.876*t9i) dff = ff*(-0.8d0*t9i + 9.876*t9i2) term = cc + dd + ee + ff dtermdt = dcc + ddd + dee + dff c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 5.42e+10 * t932 * exp(-72.262*t9i) drevdt = rev*(1.5d0*t9i + 72.262*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_c14pn(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,aa,daa,bb,dbb,cc,dcc,zz,dzz c..c14(p,n)n14 aa = 7.19e+05*(1.0d0 + 0.361*t912 + 0.502*t9) daa = 7.19e+05*(0.5d0*0.361*t9i12 + 0.502) zz = exp(-7.263*t9i) dzz = zz*7.263*t9i2 bb = aa * zz dbb = daa*zz + aa*dzz cc = 3.34e+08 * t9i12 * exp(-12.246*t9i) dcc = cc*(-0.5d0*t9i + 12.246*t9i2) term = bb + cc dtermdt = dbb + dcc c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term cc = 3.34e+08 * t9i12 * exp(-4.983*t9i) dcc = cc*(-0.5d0*t9i + 4.983*t9i2) rr = den * 0.333 * (aa + cc) drrdt = den * 0.333 * (daa + dcc) * 1.0d-9 drrdd = 0.333 * (aa + cc) return end subroutine rate_c14pg(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ee,dee,q1 parameter (q1 = 1.0d0/32.729841d0) c..c14(p,g)n14 aa = 6.80e+06 * t9i23 * exp(-13.741*t9i13 - t92*q1) daa = aa*(-twoth*t9i + oneth*13.741*t9i43 - 2.0d0*t9*q1) bb = 1.0d0 + 0.03*t913 + 0.503*t923 + 0.107*t9 1 + 0.213*t943 + 0.115*t953 dbb = oneth*0.03*t9i23 + twoth*0.503*t9i13 + 0.107 1 + fourth*0.213*t913 + fiveth*0.115*t923 cc = aa * bb dcc = daa*bb + aa*dbb dd = 5.36e+03 * t9i32 * exp(-3.811*t9i) ddd = dd*(-1.5d0*t9i + 3.811*t9i2) ee = 9.82e+04 * t9i13 * exp(-4.739*t9i) dee = ee*(-oneth*t9i + 4.739*t9i2) term = cc + dd + ee dtermdt = dcc + ddd + dee c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 9.00e+09 * t932 * exp(-118.452*t9i) drevdt = rev*(1.5d0*t9i + 118.452*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_o16pa(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,bb,dbb,cc,dcc,dd,ddd, 1 t9a,dt9a,t9a13,dt9a13,t9a56,dt9a56,zz c..o16(p,a)n13 aa = 1.0d0 + 0.0776*t9 bb = aa**twoth dbb = twoth*bb/aa*0.0776 zz = 1.0d0/bb cc = aa + 0.0264*t953*zz dcc = 0.0776 + (fiveth*0.0264*t923 - 0.0264*t953*zz*dbb)*zz zz = 1.0d0/cc t9a = t9*zz dt9a = (1.0d0 - t9a*dcc)*zz zz = dt9a/t9a t9a13 = t9a**oneth dt9a13 = oneth*t9a13*zz t9a56 = t9a**fivsix dt9a56 = fivsix * t9a56*zz dd = 1.88e+18 * t9a56 * t9i32 * exp(-35.829/t9a13) ddd = dd*(dt9a56/t9a56 - 1.5d0*t9i 1 + 35.829/t9a13**2 * dt9a13) term = dd * exp(-60.561*t9i) dtermdt = term*(ddd/dd + 60.561*t9i2) c..rate fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 0.172 * dd drevdt = 0.172 * ddd rr = den * rev drrdt = den * drevdt * 1.0d-9 drrdd = rev return end subroutine rate_n14pn(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,aa,daa,bb,dbb c..n14(p,n)o14 aa = 6.74e+07 * (1.0d0 + 0.658*t912 + 0.379*t9) daa = 6.74e+07 * (0.5d0*0.658*t9i12 + 0.379) bb = exp(-68.762*t9i) dbb = bb*68.762*t9i2 term = aa * bb dtermdt = daa*bb + aa*dbb c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rr = den * 2.99 * aa drrdt = den * 2.99 * daa * 1.0d-9 drrdd = 2.99 * aa return end subroutine rate_n14an(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,aa,daa,bb,dbb,cc,dcc,zz,dzz,q1 parameter (q1 = 1.0d0/7.828804d0) c..n14(a,n)f17 aa = 5.24e9*(1.0d0 - 1.15*t912 + 0.365*t9) daa = 5.24e9*(0.365 - 0.5d0*1.15*t9i12) zz = exp(-t92*q1) dzz = -zz*2.0d0*t9*q1 bb = aa * zz dbb = daa*zz + aa*dzz cc = 3.28e10 * t9i32 * exp(-1.5766e1*t9i) dcc = cc*(-1.5d0*t9i + 1.5766e1*t9i2) term = (bb + cc) * exp(-54.942*t9i) dtermdt = term*((dbb+dcc)/(bb+cc) + 54.942*t9i2) c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term term = 1.48 * (bb + cc) dtermdt = 1.48 * (dbb + dcc) rr = den * term drrdt = den * dtermdt * 1.0d-9 drrdd = term return end subroutine rate_n15pn(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,t9a,aa,daa,bb,dbb c..n15(p,n)o15 t9a = min(t9,10.0d0) aa = 3.51e+08 * (1.0d0 + 0.452*t912 - 0.191*t9a) if (t9a .eq. 10.0) then daa = 3.51e+08 * 0.5d0*0.452*t9i12 else daa = 3.51e+08 * (0.5d0*0.452*t9i12 - 0.191) end if bb = exp(-41.032*t9i) dbb = bb*41.032*t9i2 term = aa * bb dtermdt = daa*bb + aa*dbb c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term term = 0.998 * aa dtermdt = 0.998 * daa rr = den * term drrdt = den * dtermdt * 1.0d-9 drrdd = term return end subroutine rate_n15an(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,aa,daa,bb,dbb c..n15(a,n)f18 aa = 3.14e8 * (1.0d0 - 0.641*t912 + 0.108*t9) daa = 3.14e8 * (0.108 - 0.5d0*0.641*t9i12) bb = exp(-74.479*t9i) dbb = bb*74.479*t9i2 term = aa * bb dtermdt = daa*bb + aa*dbb c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term term = 2.0d0 * aa dtermdt = 2.0d0 * daa rr = den * term drrdt = den * dtermdt * 1.0d-9 drrdd = term return end subroutine rate_n15ag(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ee,dee,q1 parameter (q1 = 1.0d0/0.379456d0) c..n15(a,g)f19 aa = 2.54e+10 * t9i23 * exp(-36.211*t9i13 - t92*q1) daa = aa*(-twoth*t9i + oneth*36.211*t9i43 - 2.0d0*t9*q1) bb = 1.0d0 + 0.012*t913 + 1.69*t923 + 0.136*t9 1 + 1.91*t943 + 0.391*t953 dbb = oneth*0.012*t9i23 + twoth*1.69*t9i13 + 0.136 1 + fourth*1.91*t913 + fiveth*0.391*t923 cc = aa * bb dcc = daa*bb + aa*dbb dd = 9.83e-03 * t9i32 * exp(-4.232*t9i) ddd = dd*(-1.5d0*t9i + 4.232*t9i2) ee = 1.52e+03 * t9 * exp(-9.747*t9i) dee = ee*(t9i + 9.747*t9i2) term = cc + dd + ee dtermdt = dcc + ddd + dee c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 5.54e+10 * t932 * exp(-46.578*t9i) drevdt = rev*(1.5d0*t9i + 46.578*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_o14ag(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ee,dee,ff,dff,q1 parameter (q1 = 1.0d0/0.514089d0) c..o14(a,g)ne18 aa = 9.47e+08 * t9i23 * exp(-39.388*t9i13 - t92*q1) daa = aa*(-twoth*t9i + oneth*39.388*t9i43 - 2.0d0*t9*q1) bb = 1.0d0 + 0.011*t913 + 1.974*t923 + 0.146*t9 1 + 3.036*t943 + 0.572*t953 dbb = oneth*0.011*t9i23 + twoth*1.974*t9i13 + 0.146 1 + fourth*3.036*t913 + fiveth*0.572*t923 cc = aa * bb dcc = daa*bb + aa*dbb dd = 1.16e-01 * t9i32 * exp(-11.733*t9i) ddd = dd*(-1.5d0*t9i + 11.733*t9i2) ee = 3.39e+01 * t9i32 * exp(-22.609*t9i) dee = ee*(-1.5d0*t9i + 22.609*t9i2) ff = 9.10e-03 * t95 * exp(-12.159*t9i) dff = ff*(5.0d0*t9i + 12.159*t9i2) term = cc + dd + ee + ff dtermdt = dcc + ddd + dee + dff c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 5.42e+10 * t932 * exp(-59.328*t9i) drevdt = rev*(1.5d0*t9i + 59.328*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_o17ag(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb, 1 t9a,dt9a,t9a13,dt9a13,t9a56,dt9a56, 2 ft9a,dft9a,fpt9a,dfpt9a,gt9x,dgt9x,zz c..o17(a,g)ne21 aa = 1.0d0 + 0.1646*t9 zz = 1.0d0/aa t9a = t9*zz dt9a = (1.0d0 - t9a*0.1646)*zz zz = dt9a/t9a t9a13 = t9a**oneth dt9a13 = oneth*t9a13*zz t9a56 = t9a**fivsix dt9a56 = fivsix * t9a56*zz aa = 0.786/t9a daa = -aa*zz bb = aa**3.51 dbb = 3.51*bb/aa * daa ft9a = exp(-bb) dft9a = -ft9a*dbb aa = t9a/1.084 bb = aa**1.69 dbb = 1.69*bb/aa * dt9a/1.084 fpt9a = exp(-bb) dfpt9a = -fpt9a*dbb aa = oneth*exp(-10.106*t9i) daa = aa*10.106*t9i2 gt9x = 1.0d0 + aa dgt9x = daa zz = 1.0d0/gt9x aa = 1.73e17 * fpt9a*zz daa = (1.73e17*dfpt9a - aa*dgt9x)*zz bb = 3.50e15 * ft9a*zz dbb = (3.50e15*dft9a - bb*dgt9x)*zz term = (aa+bb) * t9a56 * t9i32 * exp(-39.914/t9a13) dtermdt = term*((daa+dbb)/(aa+bb) + dt9a56/t9a56 1 - 1.5d0*t9i + 39.914/t9a13**2 * dt9a13) c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 8.63e+10 * t932 * exp(-85.305*t9i) drevdt = rev*(1.5d0*t9i + 85.305*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_o17an(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,bb,dbb,cc,dcc,dd, 1 t9a,dt9a,t9a13,dt9a13,t9a56,dt9a56,gt9x,dgt9x,zz c..o17(a,n)ne20 aa = 1.0d0 + 0.0268*t9 bb = aa**twoth dbb = twoth*bb/aa*0.0268 zz = 1.0d0/bb cc = aa + 0.0232*t953*zz dcc = 0.0268 + (fiveth*0.0232*t923 - 0.0232*t953*zz*dbb)*zz zz = 1.0d0/cc t9a = t9*zz dt9a = (1.0d0 - t9a*dcc)*zz zz = dt9a/t9a t9a13 = t9a**oneth dt9a13 = oneth*t9a13*zz t9a56 = t9a**fivsix dt9a56 = fivsix * t9a56*zz dd = oneth*exp(-10.106*t9i) gt9x = 1.0d0 + dd dgt9x = dd*10.106*t9i2 term = 1.03e+18/gt9x * t9a56 * t9i32 * exp(-39.914/t9a13) dtermdt = term*(-dgt9x/gt9x + dt9a56/t9a56 1 - 1.5d0*t9i + 39.914/t9a13**2 * dt9a13) c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 1.86e+01 * exp(-6.852*t9i) drevdt = rev*6.852*t9i2 rr = den * rev * term drrdt = den * (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = rev * term return end subroutine rate_o18ag(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ee,dee,ff,dff,gg,dgg,hh,dhh,theta,q1 parameter (theta = 0.1d0, 1 q1 = 1.0d0/0.117649d0) c..o18(a,g)ne22 c..giessen et al 1994 nuc phys a 567, 146 for t9 less than 0.3 c..cf88 otherwise if (t9.lt.0.3) then aa = 1.066d-41 * t9i32 * exp(-5.507d-01*t9i) daa = aa*(-1.5d0*t9i + 5.507d-1*t9i2) bb = 1.852d-13 * t9i32 * exp(-2.070*t9i) dbb = bb*(-1.5d0*t9i + 2.070*t9i2) cc = 1.431d-02 * t9i32 * exp(-4.462*t9i) dcc = cc*(-1.5d0*t9i + 4.462*t9i2) dd = 2.055d-04 * t9i32 * exp(-5.374*t9i) ddd = dd*(-1.5d0*t9i + 5.374*t9i2) ee = 5.332d+00 * t9i32 * exp(-6.285*t9i) dee = ee*(-1.5d0*t9i + 6.285*t9i2) ff = 1.457d+00 * t9i32 * exp(-7.121*t9i) dff = ff*(-1.5d0*t9i + 7.121*t9i2) gg = 3.121d-02 * t9i32 * exp(-7.292*t9i) dgg = gg*(-1.5d0*t9i + 7.292*t9i2) hh = 6.23d+03 * t9 * exp(-16.987*t9i) dhh = hh*(t9i + 16.987*t9i2) term = aa + bb + cc + dd + ee + ff + gg + hh dtermdt = daa + dbb + dcc + ddd + dee + dff + dgg + dhh else aa = 1.82d+12 * t9i23 * exp(-40.057*t9i13 - t92*q1) daa = aa*(-twoth*t9i + oneth*40.057*t9i43 - 2.0d0*t9*q1) bb = 1.0d0 + 0.01*t913 + 0.988*t923 + 0.072*t9 1 + 3.17*t943 + 0.586*t953 dbb = oneth*0.01*t9i23 + twoth*0.988*t9i13 + 0.072 1 + fourth*3.17*t913 + fiveth*0.586*t923 cc = aa * bb dcc = daa*bb + aa*dbb dd = 7.54 * t9i32 * exp(-6.228*t9i) ddd = dd*(-1.5d0*t9i + 6.228*t9i2) ee = 34.8 * t9i32 * exp(-7.301*t9i) dee = ee*(-1.5d0*t9i + 7.301*t9i2) ff = 6.23d+03 * t9 * exp(-16.987*t9i) dff = ff*(t9i + 16.987*t9i2) gg = theta * 1.0d-11 * t9i32 * exp(-1.994*t9i) dgg = gg*(-1.5d0*t9i + 1.994*t9i2) term = cc + dd + ee + ff + gg dtermdt = dcc + ddd + dee + dff + dgg end if c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 5.85d+10 * t932 * exp(-112.208*t9i) drevdt = rev*(1.5d0*t9i + 112.208*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_o18an(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,aa,bb,dbb,cc,dcc,dd, 1 ee,dee,ff,dff,gg,dgg,hh,dhh,ft9a,dft9a,gt9,dgt9, 2 t9a,dt9a,t9a13,dt9a13,t9a56,dt9a56,gt9i,zz c..o18(a,n)ne21 aa = 1.0d0 + 0.0483*t9 bb = aa**twoth dbb = twoth*bb/aa*0.0483 zz = 1.0d0/bb cc = aa + 0.00569*t953*zz dcc = 0.0483 + (fiveth*0.00569*t923 - 0.00569*t953*zz*dbb)*zz zz = 1.0d0/cc t9a = t9*zz dt9a = (1.0d0 - t9a*dcc)*zz zz = dt9a/t9a t9a13 = t9a**oneth dt9a13 = oneth*t9a13*zz t9a56 = t9a**fivsix dt9a56 = fivsix * t9a56*zz dd = 5.0d0 * exp(-23.002*t9i) gt9 = 1.0d0 + dd gt9i = 1.0d0/gt9 dgt9 = dd*23.002*t9i2 ee = 0.431/t9a dee = -ee*zz ff = ee**3.89 dff = 3.89*ff/ee*dee ft9a = exp(-ff) dft9a = -ft9a*dff gg = 7.22e+17 * ft9a*gt9i * t9a56 * t9i32 * exp(-40.056/t9a13) dgg = gg*(-dff - gt9i*dgt9 + dt9a56/t9a56 - 1.5d0*t9i 1 + 40.056/t9a13**2 *dt9a13) hh = 150.31 / gt9 * exp(-8.045*t9i) dhh = hh*(-gt9i*dgt9 + 8.045*t9i2) term = gg + hh dtermdt = dgg + dhh c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term c..must protect the 8.045*t9i from overflow, so write it this way gg = 7.22e+17*gt9i * t9a56 * t9i32 1 * exp(-ff - 40.056/t9a13 + 8.045*t9i) dgg = gg*(-gt9i*dgt9 + dt9a56/t9a56 - 1.5d0*t9i 1 - dff + 40.056/t9a13**2*dt9a13 - 8.045*t9i2) hh = 150.31 * gt9i dhh = -hh*gt9i*dgt9 term = 0.784 * (gg + hh) dtermdt = 0.784 * (dgg + dhh) rr = den * term drrdt = den * dtermdt * 1.0d-9 drrdd = term return end subroutine rate_ne20pa(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,bb,dbb,cc,dcc,dd,ddd, 1 ee,dee,ff,dff,t9a,dt9a,t9a13,dt9a13,t9a56,dt9a56, 2 zz,t9b c..ne20(p,a)f17 aa = 1.0d0 + 0.0612*t9 bb = aa**twoth dbb = twoth*bb/aa*0.0612 zz = 1.0d0/bb cc = aa + 0.013*t953*zz dcc = 0.0612 + (fiveth*0.013*t923 - 0.013*t953*zz*dbb)*zz zz = 1.0d0/cc t9a = t9*zz dt9a = (1.0d0 - t9a*dcc)*zz zz = dt9a/t9a t9a13 = t9a**oneth dt9a13 = oneth*t9a13*zz t9a56 = t9a**fivsix dt9a56 = fivsix * t9a56*zz t9b = min(t9,10.0d0) dd = 5.31 + 0.544*t9b - 0.0523*t9b*t9b ddd = 0.544 - 2.0d0*0.0523*t9b if (t9b .eq. 10.0) ddd = 0.0d0 ee = 3.25e19 * dd * t9a56 * t9i32 * exp(-43.176/t9a13) dee = ee*(ddd/dd + dt9a56/t9a56 - 1.5d0*t9i 1 + 43.176/t9a13**2 * dt9a13) ff = exp(-47.969*t9i) dff = ff*47.969*t9i2 term = ee * ff dtermdt = dee*ff + ee*dff c..rate fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 0.0537 * ee drevdt = 0.0537 * dee rr = den * rev drrdt = den * drevdt * 1.0d-9 drrdd = rev return end subroutine rate_f18pg(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ee,dee,ff,dff,gg,dgg c..f18(p,g)ne19 c..wiescher and kettner, apj 263, 891 1982 aa = 1.658e+7 * t9i23 * exp(-18.06*t9i13) daa = aa*(-twoth*t9i + oneth*18.06*t9i43) bb = 4.604 + 0.106*t913 + 0.053*t923 + 0.009*t9 1 - 0.036*t943 - 0.015*t953 dbb = oneth*0.106*t9i23 + twoth*0.053*t9i13 + 0.009 1 - fourth*0.036*t913 - fiveth*0.015*t923 c..for temps greater than about t9 = 20, bb goes negative if (bb .le. 0.0) then bb = 0.0d0 dbb = 0.0d0 end if cc = aa * bb dcc = daa*bb + aa*dbb dd = 4.55e-14 * t9i32* exp(-0.302*t9i) ddd = dd*(-1.5d0*t9i + 0.302*t9i2) ee = 327.0 * t9i32 * exp(-3.84*t9i) dee = ee*(-1.5d0*t9i + 3.84*t9i2) ff = 1.32e+04 * t9i32 * exp(-5.22*t9i) dff = ff*(-1.5d0*t9i + 5.22*t9i2) gg = 93.0 * t9i32 * exp(-4.29*t9i) dgg = gg*(-1.5d0*t9i + 4.29*t9i2) term = cc + dd + ee + ff + gg dtermdt = dcc + ddd + dee + dff + dgg c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 2.73e+10 * t932 * exp(-74.396*t9i) drevdt = rev*(1.5d0*t9i + 74.396*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_f19pg(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ee,dee,ff,dff,gg,dgg,hh,dhh,zz,q1 parameter (q1 = 1.0d0/0.173056d0) c..f19(p,g)ne20 aa = 6.04e+07 * t9i23 * exp(-18.113*t9i13 - t92*q1) daa = aa*(-twoth*t9i + oneth*18.113*t9i43 - 2.0d0*t9*q1) bb = 1.0d0 + 0.023*t913 + 2.06*t923 + 0.332*t9 1 + 3.16*t943 + 1.30*t953 dbb = oneth*0.023*t9i23 + twoth*2.06*t9i13 + 0.332 1 + fourth*3.16*t913 + fiveth*1.30*t923 cc = aa * bb dcc = daa*bb + aa*dbb dd = 6.32e+02 * t9i32 * exp(-3.752*t9i) ddd = dd*(-1.5d0*t9i + 3.752*t9i2) ee = 7.56e+04 * t9i27 * exp(-5.722*t9i) dee = ee*(-twosev*t9i + 5.722*t9i2) ff = 7.0*exp(-16.44*t9i) dff = ff*16.44*t9i2 gg = 4.0 * exp(-2.09*t9i) dgg = gg*2.09*t9i2 hh = 1.0d0 + ff + gg dhh = dff + dgg zz = 1.0d0/hh term = (cc + dd + ee)*zz dtermdt = (dcc + ddd + dee - term*dhh)*zz c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 3.7e+10 * t932 * exp(-149.093*t9i) drevdt = rev*(1.5d0*t9i + 149.093*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_f19pn(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,aa,daa,bb,dbb c..f19(p,n)ne19 aa = 1.27e+08 * (1.0d0 - 0.147*t912 + 0.069*t9) daa = 1.27e+08 * (0.069 - 0.5d0*0.147*t9i12) bb = exp(-46.659*t9i) dbb = bb*46.659*t9i2 term = aa * bb dtermdt = daa*bb + aa*dbb c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term term = 0.998 * aa dtermdt = 0.998 * daa rr = den * term drrdt = den * dtermdt * 1.0d-9 drrdd = term return end subroutine rate_f19ap(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,q1 parameter (q1 = 1.0d0/0.405769) c..f19(a,p)ne22 aa = 4.50e+18 * t9i23 * exp(-43.467*t9i13 - t92*q1) daa = -twoth*aa*t9i + aa*(oneth*43.467*t9i43 - 2.0d0*t9*q1) bb = 7.98e+04 * t932 * exp(-12.760*t9i) dbb = 1.5d0*bb*t9i + bb*12.760*t9i2 term = aa + bb dtermdt = daa + dbb c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 6.36 * exp(-19.439*t9i) drevdt = rev*19.439*t9i2 rr = den * rev * term drrdt = den * (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = rev * term return end subroutine rate_na22na(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa, 1 t9b,t9b2,t9b3 c..na22(n,a)f19 t9b = min(t9,10.0d0) t9b2 = t9b*t9b t9b3 = t9b2*t9b aa = 1.0d0 + 0.8955*t9b - 0.05645*t9b2 + 7.302e-04*t9b3 daa = 0.8955 - 2.0d0*0.05645*t9b + 3.0d0*7.302e-4*t9b2 if (t9b .eq. 10.0) daa = 0.0d0 term = 1.21e6 * exp(aa) dtermdt = term*daa c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 1.10 * exp(-22.620*t9i) drevdt = rev*22.620*t9i2 rr = den * rev * term drrdt = den * (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = rev * term return end subroutine rate_ne20pg(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ff,gg,dgg,zz c..ne20(p,g)na21 aa = 9.55e+06 * exp(-19.447*t9i13) daa = aa*oneth*19.447*t9i43 bb = 1.0d0 + 0.0127*t9i23 dbb = -twoth*0.0127*t9i53 cc = t92 * bb * bb dcc = 2.0d0*cc*t9i + 2.0d0*t92*bb*dbb zz = 1.0d0/cc dd = aa*zz ddd = (daa - dd*dcc)*zz aa = 2.05e+08 * t9i23 * exp(-19.447*t9i13) daa = aa*(-twoth*t9i + oneth*19.447*t9i43) bb = sqrt (t9/0.21) dbb = 0.5d0/(bb * 0.21) cc = 2.67 * exp(-bb) dcc = -cc*dbb ff = 1.0d0 + cc gg = aa*ff dgg = daa*ff + aa*dcc aa = 18.0 * t9i32 * exp(-4.242*t9i) daa = aa*(-1.5d0*t9i + 4.242*t9i2) bb = 10.2 * t9i32 * exp(-4.607*t9i) dbb = bb*(-1.5d0*t9i + 4.607*t9i2) cc = 3.6e+04 * t9i14 * exp(-11.249*t9i) dcc = cc*(-0.25d0*t9i + 11.249*t9i2) term = dd + gg + aa + bb + cc dtermdt = ddd + dgg + daa + dbb + dcc c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 4.63e+09 * t932 * exp(-28.216*t9i) drevdt = rev*(1.5d0*t9i + 28.216*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_na23pa(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ee,dee,ff,dff,gg,dgg,hh,dhh,theta,q1,q2 parameter (theta = 0.1d0, 1 q1 = 1.0d0/0.0169d0, 2 q2 = 1.0d0/0.017161d0) c..na23(p,a)ne20 c..el eid & champagne 1995 if (t9.le.2.0) then aa = 1.26d+10 * t9i23 * exp(-20.758*t9i13 - t92*q1) daa = -twoth*aa*t9i + aa*(oneth*20.758*t9i43 - 2.0d0*t9*q1) bb = 1.0d0 + 0.02*t913 - 13.8*t923 - 1.93*t9 1 + 234.0*t943 + 83.6*t953 dbb = oneth*0.02*t9i23 - twoth*13.8*t9i13 - 1.93 1 + fourth*234.0*t913 + fiveth*83.6*t923 cc = aa * bb dcc = daa*bb + aa*dbb dd = 4.38 * t9i32 * exp(-1.979*t9i) ddd = -1.5d0*dd*t9i + dd*1.979*t9i2 ee = 6.50d+06 * (t9**(-1.366)) * exp(-6.490*t9i) dee = -1.366d0*ee*t9i + ee*6.490*t9i2 ff = 1.19d+08 * (t9**1.055) * exp(-11.411*t9i) dff = 1.055*ff*t9i + ff*11.411*t9i2 gg = theta * 9.91d-14 * t9i32 * exp(-0.418*t9i) dgg = -1.5d0*gg*t9i + gg*0.418*t9i2 term = cc + dd + ee + ff + gg dtermdt = dcc + ddd + dee + dff + dgg c..cf88 + one term from gorres, wiesher & rolfs 1989, apj 343, 365 else aa = 8.56d+09 * t9i23 * exp(-20.766*t9i13 - t92*q2) daa = -twoth*aa*t9i + aa*(oneth*20.766*t9i43 - 2.0d0*t9*q2) bb = 1.0d0 + 0.02*t913 + 8.21*t923 + 1.15*t9 1 + 44.36*t943 + 15.84*t953 dbb = oneth*0.02*t9i23 + twoth*8.21*t9i13 + 1.15 1 + fourth*44.36*t913 + fiveth*15.84*t923 cc = aa * bb dcc = daa*bb + aa*dbb dd = 4.02 * t9i32 * exp(-1.99*t9i) ddd = -1.5d0*dd*t9i + dd*1.99*t9i2 ee = 1.18d+04 * t9i54 * exp(-3.148*t9i) dee = -1.25d0*ee*t9i + ee*3.148*t9i2 ff = 8.59d+05 * t943 * exp(-4.375*t9i) dff = fourth*ff*t9i + ff*4.375*t9i2 gg = theta * 3.06d-12 * t9i32 * exp(-0.447*t9i) dgg = -1.5d0*gg*t9i + gg*0.447*t9i2 hh = theta * 0.820 * t9i32 * exp(-1.601*t9i) dhh = -1.5d0*hh*t9i + hh*1.601*t9i2 term = cc + dd + ee + ff + gg + hh dtermdt = dcc + ddd + dee + dff + dgg + dhh end if c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 1.25 * exp(-27.606*t9i) drevdt = rev*27.606*t9i2 rr = den * rev * term drrdt = den * (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = rev * term return end subroutine rate_ne20ng(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc c..ne20(n,g)ne21 c..wm88 Apj 239, 943; fit over range of experimental data, constant otherwise if (t9 .lt. 5.8025d-2) then term = 5.449d+03 dtermdt = 0.0d0 else if (t9 .gt. 1.1605) then term = 6.977d+04 dtermdt = 0.0d0 else if (t9 .ge. 5.8025d-2 .and. t9 .le. 2.9012d-1) then term = 4.7219d+3 + 2.5248d+4*t9 - 2.7448d+5*t92 1 + 9.2848d+5*t93 dtermdt = 2.5248d+4 - 2.0d0*2.7448d+5*t9 1 + 3.0d0*9.2848d+5*t92 else aa = 1.802d+04 * (t9/0.348)**4.43 daa = 4.43 * aa * t9i bb = -5.931 * (t9-0.348) + 1.268 * (t9-0.348)**2 dbb = -5.931 + 2.0d0*1.268*(t9 - 0.348) cc = exp(bb) dcc = cc*dbb term = aa * cc dtermdt = daa*cc + aa*dcc end if c..rate fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 4.650d+09 * t932 * exp(-78.46*t9i) drevdt = rev*(1.5d0*t9i + 78.46*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_ne21pg(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ee,dee,ff,dff,gg,dgg,hh,dhh,xx,dxx,zz, 2 theta,q1 parameter (theta = 0.1d0, 1 q1 = 1.0d0/0.003364d0) c..ne21(p,g)na22 c..el eid & champagne 1995 if (t9.le.2.0) then aa = 3.4d+08 * t9i23 * exp(-19.41*t9i13) daa = aa*(-twoth*t9i + oneth*19.41*t9i43) bb = (16.7*t9 - 1.0)**2 dbb = 2.0d0*(16.7*t9 - 1.0)*16.7 cc = 0.56 * exp(-bb) dcc = -cc*dbb dd = 1.0d0 + cc ddd = dcc ee = aa * dd dee = daa*dd + aa*ddd ff = 6.12 * t9i32 * exp(-1.403*t9i) dff = ff*(-1.5d0*t9i + 1.403*t9i2) gg = 1.35d+04 * t9i32 * exp(-3.008*t9i) dgg = gg*(-1.5d0*t9i + 3.008*t9i2) aa = t9**0.67 daa = 0.67*aa*t9i zz = 1.0d0/aa hh = 3.12d+06 * t9**(-0.72) * exp(-8.268*zz) dhh = hh*(-0.72d0*t9i + 8.268*zz*zz*daa) xx = theta * 1.1d-03 * t9i32 * exp(-1.114*t9i) dxx = xx*(-1.5d0*t9i + 1.114*t9i2) term = ee + ff + gg + hh + xx dtermdt = dee + dff + dgg + dhh + dxx c..cf88 else aa = theta * 2.95d+08 * t9i23 * exp(-19.462*t9i13 -t92*q1) daa = aa*(-twoth*t9i + oneth*19.462*t9i43 - 2.0d0*t9*q1) bb = 1.0d0 + 0.021*t913 + 13.29*t923 + 1.99*t9 1 + 124.1*t943 + 47.29*t953 dbb = oneth*0.021*t9i23 + twoth*13.29*t9i13 + 1.99 1 + fourth*124.1*t913 + fiveth*47.29*t923 cc = aa * bb dcc = daa*bb + aa*dbb dd = theta * 7.80d-01 * t9i32 * exp(-1.085*t9i) ddd = dd*(-1.5d0*t9i + 1.085*t9i2) ee = 4.37d+08 * t9i23 * exp(-19.462*t9i13) dee = ee*(-twoth*t9i + oneth*19.462*t9i43) ff = 5.85 * t9i32 * exp(-1.399*t9i) dff = ff*(-1.5d0*t9i + 1.399*t9i2) gg = 1.29d+04 * t9i32 * exp(-3.009*t9i) dgg = gg*(-1.5d0*t9i + 3.009*t9i2) hh = 3.15d+05 * t9i35 * exp(-5.763*t9i) dhh = hh*(-0.6d0*t9i + 5.763*t9i2) term = cc + dd + ee + ff + gg + hh dtermdt = dcc + ddd + dee + dff + dgg + dhh end if c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 1.06d+10 * t932 * exp(-78.194*t9i) drevdt = rev*(1.5d0*t9i + 78.194*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_ne21ag(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,gg,dgg,hh,dhh,zz, 2 t9a,dt9a,t9a13,dt9a13,t9a56,dt9a56 c..ne21(a,g)mg25 aa = 1.0d0 + 0.0537*t9 zz = 1.0d0/aa t9a = t9*zz dt9a = (1.0d0 - t9a*0.0537)*zz zz = dt9a/t9a t9a13 = t9a**oneth dt9a13 = oneth*t9a13*zz t9a56 = t9a**fivsix dt9a56 = fivsix * t9a56*zz aa = 8.72e-03*t9 - 6.87e-04*t92 + 2.15e-05*t93 daa = 8.72e-3 - 2.0d0*6.87e-4*t9 + 3.0d0*2.15e-5*t92 bb = 1.52e-04 * exp(-46.90*t9i13*aa) dbb = bb*46.90*(oneth*t9i43*aa - t9i13*daa) cc = 1.5*exp(-4.068*t9i) dcc = cc*4.068*t9i2 gg = 2.0 * exp(-20.258*t9i) dgg = gg*20.258*t9i2 hh = 1.0d0 + cc + gg dhh = dcc + dgg zz = 1.0d0/hh dd = bb*zz ddd = (dbb - dd*dhh)*zz aa = 4.94e+19 * t9a56 * t9i32 * exp(-46.89/t9a13) daa = aa*(dt9a56/t9a56 - 1.5d0*t9i 1 + 46.89/t9a13**2 * dt9a13) bb = 2.66e+07 * t9i32 * exp(-22.049*t9i) dbb = bb*(-1.5d0*t9i + 22.049*t9i2) cc = aa + bb dcc = daa + dbb term = dd * cc dtermdt = ddd*cc + dd*dcc c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 4.06e+10 * t932 * exp(-114.676*t9i) drevdt = rev*(1.5d0*t9i + 114.676*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_ne21an(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ee,dee,zz, 2 t9a,dt9a,t9a13,dt9a13,t9a56,dt9a56 c..ne21(a,n)mg24 aa = 1.0d0 + 0.0537*t9 zz = 1.0d0/aa t9a = t9*zz dt9a = (1.0d0 - t9a*0.0537)*zz zz = dt9a/t9a t9a13 = t9a**oneth dt9a13 = oneth*t9a13*zz t9a56 = t9a**fivsix dt9a56 = fivsix * t9a56*zz aa = 4.94e+19 * t9a56 * t9i32 * exp(-46.89/t9a13) daa = aa*(dt9a56/t9a56 - 1.5d0*t9i 1 + 46.89/t9a13**2 * dt9a13) bb = 2.66e+07 * t9i32 * exp(-22.049*t9i) dbb = bb*(-1.5d0*t9i + 22.049*t9i2) cc = 2.0d0*exp(-20.258*t9i) dcc = cc*20.258*t9i2 dd = 1.5*exp(-4.068*t9i) ddd = dd*4.068*t9i2 ee = 1.0d0 + cc + dd dee = dcc + ddd zz = 1.0d0/ee term = (aa + bb)*zz dtermdt = (daa + dbb - term*dee)*zz c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 12.9 * exp(-29.606*t9i) drevdt = rev*29.606*t9i2 rr = den * rev * term drrdt = den * (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = rev * term return end subroutine rate_ne22pg(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ee,dee,ff,dff,gg,dgg,theta parameter (theta = 0.1d0) c..ne22(p,g)na23 c..el eid & champagne 1995 if (t9.le.2.0) then aa = 1.05d+09 * t9i23 * exp(-19.431*t9i13) daa = aa*(-twoth*t9i + oneth*19.431*t9i43) bb = 1.24d-09 * t9i32 * exp(-0.414*t9i) dbb = bb*(-1.5d0*t9i + 0.414*t9i2) cc = 2.90d-02 * t9i32 * exp(-1.752*t9i) dcc = cc*(-1.5d0*t9i + 1.752*t9i2) dd = 9.30d+04 * t9**(-1.174) * exp(-5.100*t9i) ddd = dd*(-1.174*t9i + 5.100*t9i2) ee = 5.71d+05 * t9**(0.249) * exp(-7.117*t9i) dee = ee*(0.249*t9i + 7.117*t9i2) ff = theta * 3.25d-04 * t9i32 * exp(-0.789*t9i) dff = ff*(-1.5d0*t9i + 0.789*t9i2) gg = theta * 0.10 * t9i32 * exp(-1.161*t9i) dgg = gg*(-1.5d0*t9i + 1.161*t9i2) term = aa + bb + cc + dd + ee + ff + gg dtermdt = daa + dbb + dcc + ddd + dee + dff + dgg c..cf88 else aa = 1.15d+09 * t9i23 * exp(-19.475*t9i13) daa = aa*(-twoth*t9i + oneth*19.475*t9i43) bb = 9.77d-12 * t9i32 * exp(-0.348*t9i) dbb = bb*(-1.5d0*t9i + 0.348*t9i2) cc = 8.96d+03 * t9i32 * exp(-4.84*t9i) dcc = cc*(-1.5d0*t9i + 4.84*t9i2) dd = 6.52d+04 * t9i32 * exp(-5.319*t9i) ddd = dd*(-1.5d0*t9i + 5.319*t9i2) ee = 7.97d+05 * t9i12 * exp(-7.418*t9i) dee = ee*(-0.5d0*t9i + 7.418*t9i2) ff = theta * 1.63d-01 * t9i32 * exp(-1.775*t9i) dff = ff*(-1.5d0*t9i + 1.775*t9i2) term = aa + bb + cc + dd + ee + ff dtermdt = daa + dbb + dcc + ddd + dee + dff end if c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 4.67d+09 * t932 * exp(-102.048*t9i) drevdt = rev*(1.5d0*t9i + 102.048*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_ne22ag(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb, 1 cc,dcc,dd,ddd,res1,dres1, 2 ft9a,dft9a,fpt9a,dfpt9a,gt9x,dgt9x, 3 t9a,dt9a,t9a13,dt9a13,t9a56,dt9a56, 4 rdmass,res2,zz parameter (rdmass = 22.0d0*4.0d0/26.0d0, 1 res2 = -11.604d0 * 22.0d0/26.0d0) c..ne22(a,g)mg26 c..kappeler 1994 apj 437, 396 if (t9 .lt. 1.25) then res1 = 1.54d-01*(t9*rdmass)**(-1.5) dres1 = -1.5d0 * res1 * t9i aa = 1.7d-36 * res1 * exp(res2*t9i*0.097) daa = aa/res1*dres1 - aa*res2*0.097*t9i2 bb = 1.5d-7 * res1 * exp(res2*t9i*0.400) dbb = bb/res1*dres1 - bb * res2 * 0.400 * t9i2 cc = 0.5 * res1 * 3.7d-2 * exp(res2*t9i*0.633) dcc = cc/res1*dres1 - cc*res2*0.633*t9i2 dd = res1 * 3.6d+1 * exp(res2*t9i*0.828) ddd = dd/res1*dres1 - dd*res2*0.828*t9i2 term = aa + bb + cc + dd dtermdt = daa + dbb + dcc + ddd c..cf88 else aa = 1.0d0 + 0.0548*t9 zz = 1.0d0/aa t9a = t9*zz dt9a = (1.0d0 - t9a*0.0548)*zz zz = dt9a/t9a t9a13 = t9a**oneth dt9a13 = oneth*t9a13*zz t9a56 = t9a**fivsix dt9a56 = fivsix * t9a56*zz aa = 0.197/t9a daa = -aa*zz bb = aa**4.82 dbb = 4.82*bb/aa * daa ft9a = exp(-bb) dft9a = -ft9a*dbb aa = t9a/0.249 bb = aa**2.31 dbb = 2.31*bb/aa * dt9a/0.249 fpt9a = exp(-bb) dfpt9a = -fpt9a*dbb aa = 5.0d0*exp(-14.791*t9i) daa = aa*14.791*t9i2 gt9x = 1.0d0 + aa dgt9x = daa zz = 1.0d0/gt9x aa = 4.16e19 * fpt9a*zz daa = (4.16e19*dfpt9a - aa*dgt9x)*zz bb = 2.08e16 * ft9a*zz dbb = (2.08e16*dft9a - bb*dgt9x)*zz term = (aa+bb) * t9a56 * t9i32 * exp(-47.004/t9a13) dtermdt = term*((daa+dbb)/(aa+bb) + dt9a56/t9a56 1 - 1.5d0*t9i + 47.004/t9a13**2 * dt9a13) end if c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 6.15d+10 * t932 * exp(-123.151*t9i) drevdt = rev*(1.5d0*t9i + 123.151*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_na22np(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa c..na22(n,p)ne22 aa = 1.0d0 - 3.037e-02*t9 + 8.380e-03*t92 - 7.101e-04*t93 daa = -3.037e-02 + 2.0d0*8.380e-03*t9 - 3.0d0*7.101e-04*t92 term = 1.24e+08 * exp(aa) dtermdt = term*daa c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 7.01*exp(-42.059*t9i) drevdt = rev*42.059*t9i2 rr = den * rev * term drrdt = den * (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = rev * term return end subroutine rate_ne22an(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,gg,dgg,ft9a,dft9a,gt9x,dgt9x, 2 t9a,dt9a,t9a13,dt9a13,t9a56,dt9a56,res1,res2, 3 zz parameter (res1 = 2.4731857150793075d-2, 1 res2 = -9.8187694549560547d0) c..note: res1=1.54d-1*(88./26.)**(-1.5) res2=-11.604*(22./26.) c..ne22(a,n)mg25 c..kappeler 1994 apj 437, 396 ; wiescher suggest only 828 kev, ignore 633 kev if (t9 .lt. 0.6) then term = res1*1.64d+02 * t9i32 * exp(t9i*0.828*res2) dtermdt = -1.5d0*term*t9i - term*res2*0.828*t9i2 c..cf88 else aa = 1.0d0 + 0.0548*t9 zz = 1.0d0/aa t9a = t9*zz dt9a = (1.0d0 - t9a*0.0548)*zz zz = dt9a/t9a t9a13 = t9a**oneth dt9a13 = oneth*t9a13*zz t9a56 = t9a**fivsix dt9a56 = fivsix * t9a56*zz aa = 0.197/t9a daa = -aa*zz bb = aa**4.82 dbb = 4.82*bb/aa * daa ft9a = exp(-bb) dft9a = -ft9a*dbb gg = bb dgg = dbb aa = 5.0d0*exp(-14.791*t9i) daa = aa*14.791*t9i2 gt9x = 1.0d0 + aa dgt9x = daa zz = 1.0d0/gt9x aa = ft9a*zz daa = (dft9a - aa*dgt9x)*zz bb = 4.16e+19 * t9a56 * t9i32 * exp(-47.004/t9a13) dbb = bb*(dt9a56/t9a56 - 1.5d0*t9i 1 + 47.004/t9a13**2 * dt9a13) cc = aa*bb dcc = daa*bb + aa*dbb dd = 1.44e-04*zz * exp(-5.577*t9i) ddd = -dd*zz*dgt9x + dd*5.577*t9i2 term = cc + dd dtermdt = dcc + ddd end if c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 7.833d-5 drevdt = 0.0d0 if (t9 .gt. 0.008) then rev = 0.544 * exp(5.577*t9i) drevdt = -rev*5.577*t9i2 end if rr = den * rev * term drrdt = den * (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = rev * term return end subroutine rate_na21pg(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,q1 parameter (q1 = 1.0d0/0.133956d0) c..na21(p,g)mg22 aa = 1.41e+05 * t9i23 * exp(-20.739*t9i13 - t92*q1) daa = aa*(-twoth*t9i + oneth*20.739*t9i43 - 2.0d0*t9*q1) bb = 1.0d0 + 0.020*t913 + 4.741*t923 + 0.667*t9 1 + 16.380*t943 + 5.858*t953 dbb = oneth*0.020*t9i23 + twoth*4.741*t9i13 + 0.667 1 + fourth*16.380*t913 + fiveth*5.858*t923 cc = aa * bb dcc = daa*bb + aa*dbb dd = 6.72e+02 * t9i34 * exp(-2.436*t9i) ddd = dd*(-0.75d0*t9i + 2.436*t9i2) term = cc + dd dtermdt = dcc + ddd c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 7.44e+10 * t932 * exp(-63.790*t9i) drevdt = rev*(1.5d0*t9i + 63.790*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_mg24pa(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,gg,t9a,dt9a,t9a13,dt9a13,t9a56,dt9a56,zz c..mg24(p,a)na21 aa = 1.0d0 + 0.127*t9 zz = 1.0d0/aa t9a = t9*zz dt9a = (1.0d0 - t9a*0.127)*zz zz = dt9a/t9a t9a13 = t9a**oneth dt9a13 = oneth*t9a13*zz t9a56 = t9a**fivsix dt9a56 = fivsix * t9a56*zz gg = min(t9,12.0d0) aa = 4.43 + 3.31*gg - 0.229*gg*gg daa = 3.31 - 2.0d0*0.229*gg if (gg .eq. 12.0) daa = 0.0d0 bb = 1.81e21 * t9a56 * t9i32 * exp(-49.967/t9a13) dbb = bb*(dt9a56/t9a56 - 1.5d0*t9i 1 + 49.967/t9a13**2 * dt9a13) cc = aa*bb dcc = daa*bb + aa*dbb dd = exp(-79.843*t9i) ddd = dd*79.843*t9i2 term = cc * dd dtermdt = dcc*dd + cc*ddd c..rate fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 0.0771 * cc drevdt = 0.0771 * dcc rr = den * rev drrdt = den * drevdt * 1.0d-9 drrdd = rev return end subroutine rate_na22pg(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb c..na22(p,g)mg23 aa = 9.63e-05 * t932 * exp(-0.517*t9i) daa = aa*(1.5d0*t9i + 0.517*t9i2) bb = 2.51e+04 * t9 * exp(-2.013*t9i) dbb = bb*(t9i + 2.013*t9i2) term = aa + bb dtermdt = daa + dbb c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 3.27e+10 * t932 * exp(-87.933*t9i) drevdt = rev*(1.5d0*t9i + 87.933*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_na23pg(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ee,dee,ff,dff,gg,dgg,hh,hhi,xx,dxx, 2 theta,q1 parameter (theta = 0.1d0, 1 q1 = 1.0d0/0.088209d0) c..na23(p,g)mg24 c..el eid & champagne 1995 if (t9.le.2.0) then aa = 2.47d+09 * t9i23 * exp(-20.758*t9i13) daa = aa*(-twoth*t9i + oneth*20.758*t9i43) bb = 9.19d+01 * t9i32 * exp(-2.789*t9i) dbb = bb*(-1.5d0*t9i + 2.789*t9i2) cc = 1.72d+04 * t9i32 * exp(-3.433*t9i) dcc = cc*(-1.5d0*t9i + 3.433*t9i2) dd = 3.44d+04 * t9**0.323 * exp(-5.219*t9i) ddd = dd*(0.323*t9i + 5.219*t9i2) ee = theta * 2.34d-04 * t9i32 * exp(-1.590*t9i) dee = ee*(-1.5d0*t9i + 1.590*t9i2) term = aa + bb + cc + dd + ee dtermdt = daa + dbb + dcc + ddd + dee c..cf88 + gorres, wiesher & rolfs 1989, apj 343, 365 else aa = 2.93d+08 * t9i23 * exp(-20.766*t9i13 - t92*q1) daa = aa*(-twoth*t9i + oneth*20.766*t9i43 - 2.0d0*t9*q1) bb = 1.0d0 + 0.02*t913 + 1.61*t923 + 0.226*t9 1 + 4.94*t943 + 1.76*t953 dbb = oneth*0.02*t9i23 + twoth*1.61*t9i13 + 0.226 1 + fourth*4.94*t913 + fiveth*1.76*t923 xx = aa * bb dxx = daa*bb + aa*dbb cc = 9.34d+01 * t9i32 * exp(-2.789*t9i) dcc = cc*(-1.5d0*t9i + 2.789*t9i2) dd = 1.89d+04 * t9i32 * exp(-3.434*t9i) ddd = dd*(-1.5d0*t9i + 3.434*t9i2) ee = 5.1d+04 * t915 * exp(-5.51*t9i) dee = ee*(0.2d0*t9i + 5.51*t9i2) ff = theta * 0.820 * t9i32 * exp(-1.601*t9i) dff = ff*(-1.5d0*t9i + 1.601*t9i2) gg = 1.5 * exp(-5.105*t9i) dgg = gg*5.105*t9i2 hh = 1.0d0 + gg hhi = 1.0d0/hh term = (xx + cc + dd + ee + ff) * hhi dtermdt = (dxx + dcc + ddd + dee + dff - term*dgg)*hhi end if c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 7.49d+10 * t932 * exp(-135.665*t9i) drevdt = rev*(1.5d0*t9i + 135.665*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_na23pn(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,aa,bb,dbb,cc,dcc, 1 t9a,dt9a,t9a32,dt9a32,zz c..na23(p,n)mg24 aa = 1.0d0 + 0.141*t9 zz = 1.0d0/aa t9a = t9*zz dt9a = (1.0d0 - t9a*0.141)*zz aa = sqrt(t9a) t9a32 = t9a * aa dt9a32 = 1.5d0 * aa * dt9a bb = 9.29d8 * (1.0d0 - 0.881d0 * t9a32 * t9i32) dbb = -9.29d8 * 0.881d0 * t9i32*(dt9a32 - 1.5d0*t9a32*t9i) cc = exp(-56.173*t9i) dcc = cc*56.173*t9i2 term = bb * cc dtermdt = dbb*cc + bb*dcc c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term term = 0.998 * bb dtermdt = 0.998 * dbb rr = den * term drrdt = den * dtermdt * 1.0d-9 drrdd = term return end subroutine rate_mg24pg(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ee,dee,ff,dff,gg,ggi c..mg24(p,g)al25 aa = 5.60e+08 * t9i23 * exp(-22.019*t9i13) daa = aa*(-twoth*t9i + oneth*22.019*t9i43) bb = 1.0d0 + 0.019*t913 - 0.173*t923 - 0.023*t9 dbb = oneth*0.019*t9i23 - twoth*0.173*t9i13 - 0.023 c..stop negative rates above t9 = 10 if (bb .le. 0.0) then bb = 0.0d0 dbb = 0.0d0 end if cc = aa * bb dcc = daa*bb + aa*dbb dd = 1.48e+03 * t9i32 * exp(-2.484*t9i) ddd = dd*(-1.5d0*t9i + 2.484*t9i2) ee = 4.00e+03 * exp(-4.180*t9i) dee = ee*4.180*t9i2 ff = 5.0 * exp(-15.882*t9i) dff = ff*15.882*t9i2 gg = 1.0d0 + ff ggi = 1.0d0/gg term = (cc + dd + ee) * ggi dtermdt = (dcc + ddd + dee - term*dff)*ggi c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 3.13e+09 * t932 * exp(-26.358*t9i) drevdt = rev*(1.5d0*t9i + 26.358*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_al27pa(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ee,dee,ff,dff,gg,dgg,theta parameter (theta = 0.1d0) c..al27(p,a)mg24 c..champagne 1996 aa = 4.71d+05 * t9i23 * exp(-23.25*t9i13 - 3.57*t92) daa = -twoth*aa*t9i + aa*(oneth*23.25*t9i43 - 2.0d0*3.57*t9) bb = 1.0d0 + 0.018*t913 - 7.29*t923 - 0.914*t9 1 + 77.2*t943 + 24.6*t953 dbb = oneth*0.018*t9i23 - twoth*7.29*t9i13 - 0.914 1 + fourth*77.2*t913 + fiveth*24.6*t923 cc = aa * bb dcc = daa*bb + aa*dbb dd = 2.23d+04 * (t9**3.989) * exp(-2.148 * t9**(-1.293)) ddd = 3.989*dd*t9i + 1.293*dd*2.148*t9**(-2.293) ee = 0.17 * 1.29d-09 * t9i32 * exp(-0.836*t9i) dee = -1.5d0*ee*t9i + ee*0.836*t9i2 ff = theta * 2.73d-03 * t9i32 * exp(-2.269*t9i) dff = -1.5d0*ff*t9i + ff*2.269*t9i2 gg = theta * 2.60d-02 * t9i32 * exp(-2.492*t9i) dgg = -1.5d0*gg*t9i + gg*2.492*t9i2 term = cc + dd + ee + ff + gg dtermdt = dcc + ddd + dee + dff + dgg c..rate fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 1.81*exp(-18.572*t9i) drevdt = rev*18.572*t9i2 rr = den * rev * term drrdt = den * (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = rev * term return end subroutine rate_mg25pg(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ee,dee,ff,dff,gg,dgg,q1,q2 parameter (q1 = 1.0d0/0.0036d0, 1 q2 = 1.0d0/169.0d0) c..mg25(p,g)al26 aa = 3.57e+09 * t9i23 * exp(-22.031*t9i13 - t92*q1) daa = aa*(-twoth*t9i + oneth*22.031*t9i43 - 2.0d0*t9*q1) bb = 1.0d0 + 0.019*t913 + 7.669*t923 + 1.015*t9 1 + 167.4*t943 + 56.35*t953 dbb = oneth*0.019*t9i23 + twoth*7.669*t9i13 + 1.015 1 + fourth*167.4*t913 + fiveth*56.35*t923 cc = aa * bb dcc = daa*bb + aa*dbb dd = 3.07e-13 * t9i32 * exp(-0.435*t9i) ddd = dd*(-1.5d0*t9i + 0.435*t9i2) ee = 1.94e-07 * t9i32 * exp(-0.673*t9i) dee = ee*(-1.5d0*t9i + 0.673*t9i2) ff = 3.15e-05 * t9**(-3.40)* exp(-1.342*t9i - t92*q2) dff = ff*(-3.40d0*t9i + 1.342*t9i2 - 2.0d0*t9*q2) gg = 1.77e+04 * t958 * exp(-3.049*t9i - t92*q2) dgg = gg*(0.625*t9i + 3.049*t9i2 - 2.0d0*t9*q2) term = cc + dd + ee + ff + gg dtermdt = dcc + ddd + dee + dff + dgg c..rate fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 1.03e+10 * t932 * exp(-73.183*t9i) drevdt = rev*(1.5d0*t9i + 73.183*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_mg25ap(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc c..mg25(a,p)si28 aa = -23.271*t9i13 + 6.46*t9 - 2.39*t92 + 0.506*t93 1 - 6.04e-2*t94 + 3.75e-3*t95 - 9.38e-5*t96 daa = oneth*23.271*t9i43 + 6.46 - 2.0d0*2.39*t9 + 3.0d0*0.506*t92 1 - 4.0d0*6.04e-2*t93 + 5.0d0*3.75e-3*t94 - 6.0d0*9.38e-5*t95 bb = 3.23e8 * t9i23 * exp(aa) dbb = -twoth*bb*t9i + bb*daa c..dbb/bb cc = -twoth*t9i + daa term = bb * exp(-13.995*t9i) dtermdt = term*cc + term*13.995*t9i2 c..rate fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 2.86 * bb drevdt = 2.86 * dbb rr = den * rev drrdt = den * drevdt * 1.0d-9 drrdd = rev return end subroutine rate_mg25ag(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ee,dee,gt9x,dgt9x,t9a,dt9a,t9a13,dt9a13, 2 t9a56,dt9a56,zz c..mg25(a,g)si29 aa = 1.0d0 + 0.0630*t9 zz = 1.0d0/aa t9a = t9*zz dt9a = (1.0d0 - t9a*0.0630)*zz zz = dt9a/t9a t9a13 = t9a**oneth dt9a13 = oneth*t9a13*zz t9a56 = t9a**fivsix dt9a56 = fivsix * t9a56*zz aa = oneth*10.0d0*exp(-13.180*t9i) daa = aa*13.180*t9i2 gt9x = 1.0d0 + aa dgt9x = daa bb = 1.0d0/gt9x dbb = -bb*bb*dgt9x cc = 3.59e+20 * bb * t9a56 * t9i32 * exp(-53.41/t9a13) dcc = cc*(dbb*gt9x + dt9a56/t9a56 - 1.5d0*t9i 1 + 53.41/t9a13**2 * dt9a13) dd = 0.0156*t9 - 1.79e-03*t92 + 9.08e-05*t93 ddd = 0.0156 - 2.0d0*1.79e-03*t9 + 3.0d0*9.08e-05*t92 ee = 5.87e-04*exp(-53.42*t9i13*dd) dee = ee*53.42*(oneth*t9i43*dd - t9i13*ddd) term = cc * ee dtermdt = dcc*ee + cc*dee c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 1.90e+11 * t932 * exp(-129.128*t9i) drevdt = rev*(1.5d0*t9i + 129.128*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_mg25an(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,zz, 1 gt9x,dgt9x,t9a,dt9a,t9a13,dt9a13,t9a56,dt9a56 c..mg25(a,n)si28 aa = 1.0d0 + 0.0630*t9 zz = 1.0d0/aa t9a = t9*zz dt9a = (1.0d0 - t9a*0.0630)*zz zz = dt9a/t9a t9a13 = t9a**oneth dt9a13 = oneth*t9a13*zz t9a56 = t9a**fivsix dt9a56 = fivsix * t9a56*zz aa = oneth*10.0d0*exp(-13.180*t9i) daa = aa*13.180*t9i2 gt9x = 1.0d0 + aa dgt9x = daa bb = 1.0d0/gt9x dbb = -bb*bb*dgt9x term = 3.59e+20 * bb * t9a56 * t9i32 * exp(-53.41/t9a13) dtermdt = term*(dbb*gt9x + dt9a56/t9a56 - 1.5d0*t9i 1 + 53.41/t9a13**2 * dt9a13) c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 20.0*exp(-30.792*t9i) drevdt = rev*30.792*t9i2 rr = den * rev * term drrdt = den * (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = rev * term return end subroutine rate_mg26pg(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ee,dee,ff,dff,gg,dgg,hh,dhh,theta parameter (theta = 0.1d0) c..mg26(p,g)al27 c..champagne 1996 aa = 8.54d-12 * t9i32 * exp(-0.605*t9i) daa = aa*(-1.5d0*t9i + 0.605*t9i2) bb = 2.75d-06 * t9i32 * exp(-1.219*t9i) dbb = bb*(-1.5d0*t9i + 1.219*t9i2) cc = 1.30d-02 * t9i32 * exp(-1.728*t9i) dcc = cc*(-1.5d0*t9i + 1.728*t9i2) dd = 8.06d+00 * t9i32 * exp(-2.537*t9i) ddd = dd*(-1.5d0*t9i + 2.537*t9i2) ee = 1.45d+03 * t9i32 * exp(-3.266*t9i) dee = ee*(-1.5d0*t9i + 3.266*t9i2) ff = 4.03d+04 * t9i32 * exp(-3.784*t9i) dff = ff*(-1.5d0*t9i + 3.784*t9i2) gg = 8.82d+04 * t9**(-0.21) * exp(-4.194*t9i) dgg = gg*(-0.21*t9i + 4.194*t9i2) hh = theta * 1.93d-05 * t9i32 * exp(-1.044*t9i) dhh = hh*(-1.5d0*t9i + 1.044*t9i2) term = aa + bb + cc + dd + ee + ff + gg + hh dtermdt = daa + dbb + dcc + ddd + dee + dff + dgg + dhh c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 3.14d+09 * t932 * exp(-95.99*t9i) drevdt = rev*(1.5d0*t9i + 95.99*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_mg26ag(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ee,dee,gt9x,dgt9x,t9a,dt9a,t9a13,dt9a13, 2 t9a56,dt9a56,zz c..mg26(a,g)si30 aa = 1.0d0 + 0.0628*t9 zz = 1.0d0/aa t9a = t9*zz dt9a = (1.0d0 - t9a*0.0628)*zz zz = dt9a/t9a t9a13 = t9a**oneth dt9a13 = oneth*t9a13*zz t9a56 = t9a**fivsix dt9a56 = fivsix * t9a56*zz aa = 5.0d0*exp(-20.990*t9i) daa = aa*20.990*t9i2 gt9x = 1.0d0 + aa dgt9x = daa bb = 1.0d0/gt9x dbb = -bb*bb*dgt9x cc = 2.93e+20 * bb * t9a56 * t9i32 * exp(-53.505/t9a13) dcc = cc*(dbb*gt9x + dt9a56/t9a56 - 1.5d0*t9i 1 + 53.505/t9a13**2 * dt9a13) dd = 0.0751*t9 - 0.0105*t92 + 5.57e-04*t93 ddd = 0.0751 - 2.0d0*0.0105*t9 + 3.0d0*5.57e-04*t92 ee = 4.55e-2 * exp(-53.51*t9i13*dd) dee = ee*53.51*(oneth*t9i43*dd - t9i13*ddd) term = cc * ee dtermdt = dcc*ee + cc*dee c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 6.38e+10 * t932 * exp(-123.52*t9i) drevdt = rev*(1.5d0*t9i + 123.52*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_mg26an(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,zz, 1 gt9x,dgt9x,t9a,dt9a,t9a13,dt9a13,t9a56,dt9a56 c..mg26(a,n)si29 aa = 1.0d0 + 0.0628*t9 zz = 1.0d0/aa t9a = t9*zz dt9a = (1.0d0 - t9a*0.0628)*zz zz = dt9a/t9a t9a13 = t9a**oneth dt9a13 = oneth*t9a13*zz t9a56 = t9a**fivsix dt9a56 = fivsix * t9a56*zz aa = 5.0d0*exp(-20.990*t9i) daa = aa*20.990*t9i2 gt9x = 1.0d0 + aa dgt9x = daa bb = 1.0d0/gt9x dbb = -bb*bb*dgt9x term = 2.93e+20 * bb * t9a56 * t9i32 * exp(-53.505/t9a13) dtermdt= term*(dbb*gt9x + dt9a56/t9a56 - 1.5d0*t9i 1 + 53.505/t9a13**2 * dt9a13) c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 1.68*exp(-0.401*t9i) drevdt = rev*0.401*t9i2 rr = den * rev * term drrdt = den * (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = rev * term return end subroutine rate_al25pg(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ee,dee c..al25(p,g)si26 c..coc et al 1995 a&a 299, 479 , case b aa = 8.98d+1 * t9i32 * exp(-4.874*t9i) daa = aa*(-1.5d0*t9i + 4.874*t9i2) bb = 1.568d+3 * t9i32 * exp(-9.632*t9i) dbb = bb*(-1.5d0*t9i + 9.632*t9i2) cc = 2.42d+8 * t9i23 * exp(-23.18*t9i13) dcc = cc*(-twoth*t9i + oneth*23.18*t9i43) dd = 4.10d-02 * t9i32 * exp(-1.741*t9i) ddd = dd*(-1.5d0*t9i + 1.741*t9i2) ee = 2.193d+3 * t9i32 * exp(-4.642*t9i) dee = ee*(-1.5d0*t9i + 4.642*t9i2) term = aa + bb + cc + dd + ee dtermdt = daa + dbb + dcc + ddd + dee c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 1.117d+11 * t932 * exp(-64.048*t9i) drevdt = rev*(1.5d0*t9i + 64.048*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_al26pg(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ee,dee,ff,dff,theta parameter (theta = 0.1d0) c..al26(p,g)si27 c..coc et al 1995 a&a 299, 479 aa = 1.53d+9 * t9**(-1.75) * exp(-23.19*t9i13) daa = aa*(-1.75*t9i + oneth*23.19*t9i43) bb = theta*8.7d-7 * t9i32 * exp(-0.7845*t9i) dbb = bb*(-1.5d0*t9i + 0.7845*t9i2) cc = theta*1.00d-3 * t9i32 * exp(-1.075*t9i) dcc = cc*(-1.5d0*t9i + 1.075*t9i2) dd = 9.00d+00 * t9i32 * exp(-2.186*t9i) ddd = dd*(-1.5d0*t9i + 2.186*t9i2) ee = 5.05d+02 * t9i32 * exp(-3.209*t9i) dee = ee*(-1.5d0*t9i + 3.209*t9i2) ff = 9.45d+03 * t9i * exp(-4.008*t9i) dff = ff*(-t9i + 4.008*t9i2) term = aa + bb + cc + dd + ee + ff dtermdt = daa + dbb + dcc + ddd + dee + dff c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 3.46d+10 * t932 * exp(-86.621*t9i) drevdt = rev*(1.5d0*t9i + 86.621*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_al27an(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb c..al27(a,n)p30 aa = 8.2e+04*exp(-30.588*t9i) daa = aa*30.588*t9i2 bb = 5.21e+05 * t974 * exp(-33.554*t9i) dbb = 1.75d0*bb*t9i + bb*33.554*t9i2 term = aa + bb dtermdt = daa + dbb c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term aa = 5.21e+05 * t974 * exp(-2.966*t9i) daa = aa*(1.75d0*t9i + 2.966*t9i2) rev = 6.75d0 * (8.20e4 + aa) drevdt = 6.75d0 * daa rr = den * rev drrdt = den * drevdt * 1.0d-9 drrdd = rev return end subroutine rate_si27pg(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd c..si27(p,g)p28 aa = 1.64e+09 * t9i23 * exp(-24.439*t9i13) daa = aa*(-twoth*t9i + oneth*24.439*t9i43) bb = 2.00e-08 * t9i32 * exp(-0.928*t9i) dbb = bb*(-1.5d0*t9i + 0.928*t9i2) cc = 1.95e-02 * t9i32 * exp(-1.857*t9i) dcc = cc*(-1.5d0*t9i + 1.857*t9i2) dd = 3.70e+02 * t9i47 * exp(-3.817*t9i) ddd = dd*(-foursev*t9i + 3.817*t9i2) term = aa + bb + cc + dd dtermdt = daa + dbb + dcc + ddd c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 1.62e+10 * t932 * exp(-23.960*t9i) drevdt = rev*(1.5d0*t9i + 23.960*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_si28pg(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ee,dee,xx,dxx,q1 parameter (q1 = 1.0d0/8.4681d0) c..si28(p,g)p29 c..champagne et al 96 if (t9.le.5.0) then aa = 8.44d+08 * t9i23 * exp(-24.389*t9i13 - t92*q1) daa = aa*(-twoth*t9i + oneth*24.389*t9i43 - 2.0d0*t9*q1) bb = 1.0d0 + 0.17*t913 + 0.113*t923 + 0.0135*t9 1 + 0.194*t943 + 0.0591*t953 dbb = oneth*0.17*t9i23 + twoth*0.113*t9i13 + 0.0135 1 + fourth*0.194*t913 + fiveth*0.0591*t923 xx = aa * bb dxx = daa*bb + aa*dbb cc = 2.92d+02 * t9i32 * exp(-4.157*t9i) dcc = cc*(-1.5d0*t9i + 4.157*t9i2) dd = 4.30d+05 * t9i32 * exp(-18.51*t9i) ddd = dd*(-1.5d0*t9i + 18.51*t9i2) ee = 6.05d+03 * t9i32 * exp(-18.17*t9i) dee = ee*(-1.5d0*t9i + 18.17*t9i2) term = xx + cc + dd + ee dtermdt = dxx + dcc + ddd + dee c..cf88 else aa = 1.64d+08 * t9i23 * exp(-24.449*t9i13 - t92*q1) daa = aa*(-twoth*t9i + oneth*24.449*t9i43 - 2.0d0*t9*q1) bb = 1.0d0 + 0.017*t913 - 4.11*t923 - 0.491*t9 1 + 5.22*t943 + 1.58*t953 dbb = oneth*0.017*t9i23 - twoth*4.11*t9i13 - 0.491 1 + fourth*5.22*t913 + fiveth*1.58*t923 xx = aa * bb dxx = daa*bb + aa*dbb cc = 3.52d+02 * t9i32 * exp(-4.152*t9i) dcc = cc*(-1.5d0*t9i + 4.152*t9i2) dd = 6.3d+05 * t9i32 * exp(-18.505*t9i) ddd = dd*(-1.5d0*t9i + 18.505*t9i2) ee = 1.69d+03 * exp(-14.518*t9i) dee = ee*14.518*t9i2 term = xx + cc + dd + ee dtermdt = dxx + dcc + ddd + dee end if c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 9.46d+09 * t932 * exp(-31.879*t9i) drevdt = rev*(1.5d0*t9i + 31.879*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_si29pg(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ee,dee,xx,dxx,q1 parameter (q1 = 1.0d0/0.065536d0) c..si29(p,g)p30 aa = 3.26e+09 * t9i23 * exp(-24.459*t9i13 - t92*q1) daa = aa*(-twoth*t9i + oneth*24.459*t9i43 - 2.0d0*t9*q1) bb = 1.0d0 + 0.017*t913 + 4.27*t923 + 0.509*t9 1 + 15.40*t943 + 4.67*t953 dbb = oneth*0.017*t9i23 + twoth*4.27*t9i13 + 0.509 1 + fourth*15.40*t913 + fiveth*4.67*t923 xx = aa * bb dxx = daa*bb + aa*dbb cc = 2.98e+03 * t9i32 * exp(-3.667*t9i) dcc = cc*(-1.5d0*t9i + 3.667*t9i2) dd = 3.94e+04 * t9i32 * exp(-4.665*t9i) ddd = dd*(-1.5d0*t9i + 4.665*t9i2) ee = 2.08e+04 * t912 * exp(-8.657*t9i) dee = ee*(0.5d0*t9i + 8.657*t9i2) term = xx + cc + dd + ee dtermdt = dxx + dcc + ddd + dee c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 1.26e+10 * t932 * exp(-65.002*t9i) drevdt = rev*(1.5d0*t9i + 65.002*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_si30pg(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc, 1 dd,ddd,ee,dee,xx,dxx,q1 parameter (q1 = 1.0d0/0.4489d0) c..si30(p,g)p31 aa = 4.25e8 * t9i23 * exp(-24.468*t9i13 - t92*q1) daa = aa*(-twoth*t9i + oneth*24.468*t9i43 - 2.0d0*t9*q1) bb = 1.0d0 + 0.017*t913 + 0.150*t923 + 0.018*t9 1 + 5.53*t943 + 1.68*t953 dbb = oneth*0.017*t9i23 + twoth*0.150*t9i13 + 0.018 1 + fourth*5.53*t913 + fiveth*1.68*t923 xx = aa * bb dxx = daa*bb + aa*dbb cc = 1.86e4 * t9i32 * exp(-5.601*t9i) dcc = cc*(-1.5d0*t9i + 5.601*t9i2) dd = 3.15e5 * t9i32 * exp(-6.961*t9i) ddd = dd*(-1.5d0*t9i + 6.961*t9i2) ee = 2.75e5 * t9i12 * exp(-10.062*t9i) dee = ee*(-0.5d0*t9i + 10.062*t9i2) term = xx + cc + dd + ee dtermdt = dxx + dcc + ddd + dee c..rates fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 9.50e9 * t932 * exp(-84.673*t9i) drevdt = rev*(1.5d0*t9i + 84.673*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_weaknp(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision aa,daa,bb,dbb,cc,dcc, 1 zm1,zm2,zm3,zm4,zm5, 2 c1,c2 parameter (c1 = 1.0d0/5.93d0, 1 c2 = 0.98d0/886.7d0) c..free decay of neutrons, n(e-nu)p and p(e-,nu)n c..fit formula from schramm and wagoner annual review 1977 c..currently accepted best value for the neutron lifetime, c..886.7 (+/- 1.9) seconds. P.R. Huffman et al., Nature, 6 January 2000. zm1 = t9 * c1 zm2 = zm1*zm1 zm3 = zm1*zm2 zm4 = zm1*zm3 zm5 = zm1*zm4 aa = 27.512*zm5 + 36.492*zm4 + 11.108*zm3 1 - 6.382*zm2 + 0.565*zm1 + 1.0d0 daa = (5.0d0*27.512*zm4 + 4.0d0*36.492*zm3 + 3.0d0*11.108*zm2 1 - 2.0d0*6.382*zm1 + 0.565)*c1 c..n=>p fr = c2 * aa dfrdt = c2 * daa * 1.0d-9 dfrdd = 0.0d0 aa = 27.617*zm5 + 34.181*zm4 + 18.059*zm3 1 - 16.229*zm2 + 5.252*zm1 daa = (5.0d0*27.617*zm4 + 4.0d0*34.181*zm3 + 3.0d0*18.059*zm2 1 - 2.0d0*16.229*zm1 + 5.252)*c1 bb = exp(-2.531d0/zm1) dbb = bb*2.531d0/zm2*c1 cc = aa*bb dcc = daa*bb + aa*dbb c..p=>n rr = c2 * cc drrdt = c2 * dcc * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_dpn(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc c..d(p,n)2p aa = 3.35e7 * exp(-3.720*t9i13) daa = aa*oneth*3.720d0*t9i43 bb = 1.0d0 + 0.784*t913 + 0.346*t923 + 0.690*t9 dbb = oneth*0.784*t9i23 + twoth*0.346*t9i13 + 0.690 term = aa * bb dtermdt = daa * bb + aa * dbb c..rate cc = exp(-25.815*t9i) dcc = cc*25.815*t9i2 fr = den * cc * term dfrdt = den * (dcc*term + cc*dtermdt) * 1.0d-9 dfrdd = cc * term rev = 4.24e-10 * t9i32 drevdt = -1.5d0*rev*t9i rr = den * rev * term drrdt = den * (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = rev * term return end subroutine rate_dng(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,c1 parameter (c1 = 66.2d0*18.9d0) c..d(n,g)t term = 66.2 * (1.0d0 + 18.9*t9) dtermdt = c1 c..rate fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 1.63e+10 * t9i32 * exp(-72.62*t9i) drevdt = rev*(-1.5d0*t9i + 72.62*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_ddp(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb c..d(d,p)t aa = 4.13e8 * t9i23 * exp(-4.258*t9i13) daa = -twoth*aa*t9i + oneth*aa*4.258*t9i43 bb = 1.0d0 + 0.098*t913 + 4.39e-2*t923 + 3.01e-2*t9 1 + 0.543*t943 + 0.946*t953 dbb = oneth*0.098*t9i23 + twoth*4.39e-2*t9i13 + 3.01e-2 1 + fourth*0.543*t913 + fiveth*0.946*t923 term = aa * bb dtermdt = daa*bb + aa*dbb c..rate fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 1.73 * exp(-46.798*t9i) drevdt = rev*46.798*t9i2 rr = den * rev * term drrdt = den * (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = rev * term return end subroutine rate_ddn(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb c..d(d,n)he3 aa = 3.88e8 * t9i23 * exp(-4.258*t9i13) daa = -twoth*aa*t9i + oneth*aa*4.258*t9i43 bb = 1.0d0 + 0.098*t913 + 0.418*t923 + 0.287*t9 1 + 0.638*t943 + 1.112*t953 dbb = oneth*0.098*t9i23 + twoth*0.418*t9i13 + 0.287 1 + fourth*0.638*t913 + fiveth*1.112*t923 term = aa * bb dtermdt = daa*bb + aa*dbb c..rate fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 1.730 * exp(-37.935*t9i) drevdt = rev*37.935*t9i2 rr = den * rev * term drrdt = den * (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = rev * term return end subroutine rate_tpn(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa c..t(p,n)he3 term = 7.07e8 * (1.0d0 - 0.15*t912 + 0.098*t9) dtermdt = 7.07e8 * (-0.5d0*0.15*t9i12 + 0.098) aa = exp(-8.863*t9i) daa = aa*8.863*t9i2 c..rate fr = den * aa * term dfrdt = den * (daa*term + aa*dtermdt) * 1.0d-9 dfrdd = aa * term rev = 0.998 drevdt = 0.0d0 rr = den * rev * term drrdt = den * (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = rev * term return end subroutine rate_ddg(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb c..d(d,g)he4 aa = 4.84e+01 * t9i23 * exp(-4.258*t9i13) daa = aa*(-twoth*t9i + oneth*4.258*t9i43) bb = 1.0d0 + 0.098*t913 - 0.203*t923 - 0.139*t9 1 + 0.106*t943 + 0.185*t953 dbb = oneth*0.098*t9i23 - twoth*0.203*t9i13 - 0.139 1 + fourth*0.106*t913 + fiveth*0.185*t923 term = aa * bb dtermdt = daa*bb + aa*dbb c..rate fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 4.53e+10 * t932 * exp(-276.729*t9i) drevdt = rev*(1.5d0*t9i + 276.729*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_tpg(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb c..t(p,g)he4 aa = 2.20e+04 * t9i23 * exp(-3.869*t9i13) daa = aa*(-twoth*t9i + oneth*3.869*t9i43) bb = 1. + 0.108*t913 + 1.68*t923 + 1.26*t9 1 + 0.551*t943 + 1.06*t953 dbb = oneth*0.108*t9i23 + twoth*1.68*t9i13 + 1.26 1 + fourth*0.551*t913 + fiveth*1.06*t923 term = aa * bb dtermdt = daa*bb + aa*dbb c..rate fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 2.61e+10 * t932 * exp(-229.932*t9i) drevdt = rev*(1.5d0*t9i + 229.932*t9i2) rr = rev * term drrdt = (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = 0.0d0 return end subroutine rate_tdn(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb,cc,dcc,q1 parameter (q1 = 1.0d0/0.0144d0) c..t(d,n)he4 ; the "dt" reaction aa = 8.09e+10 * t9i23 * exp(-4.524*t9i13 - t92*q1) daa = -twoth*aa*t9i + aa*(oneth*4.524*t9i43 - 2.0d0*t9*q1) bb = 1.0d0 + 0.092*t913 + 1.80*t923 + 1.16*t9 1 + 10.52*t943 + 17.24*t953 dbb = oneth*0.092*t9i23 + twoth*1.80*t9i13 + 1.16 1 + fourth*10.52*t913 + fiveth*17.24*t923 cc = 8.73e+08 * t9i23 * exp(-0.523*t9i) dcc = -twoth*cc*t9i + cc*0.523*t9i2 term = aa * bb + cc dtermdt = daa*bb + aa*dbb + dcc c..rate fr = den * term dfrdt = den * dtermdt * 1.0d-9 dfrdd = term rev = 5.54*exp(-204.117*t9i) drevdt = rev*204.117*t9i2 rr = den * rev * term drrdt = den * (drevdt*term + rev*dtermdt) * 1.0d-9 drrdd = rev * term return end subroutine rate_tt2n(temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd) include 'implno.dek' include 'tfactors.dek' c..declare the pass double precision temp,den,fr,dfrdt,dfrdd,rr,drrdt,drrdd c..locals double precision term,dtermdt,rev,drevdt,aa,daa,bb,dbb c..t(t,2n)he4 aa = 1.67e+09 * t9i23 * exp(-4.872*t9i13) daa = aa*(-twoth*t9i + oneth*4.872*t9i43) bb = 1.0d0 + 0.086*t913 - 0.455*t923 - 0.272*t9 1 + 0.148*t943 + 0.225*t953 dbb = oneth*0.086*t9i23 - twoth*0.455*t9i